{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}

-- | Test properties of the shrinking functions
module Test.Consensus.PointSchedule.Shrinking.Tests (tests) where

import Cardano.Slotting.Slot (WithOrigin (..))
import Control.Monad.Class.MonadTime.SI (Time (..))
import Data.Foldable (toList)
import Data.Map (elems, empty, keys, singleton)
import Data.Maybe (mapMaybe)
import Ouroboros.Consensus.Util (lastMaybe)
import Test.Consensus.Genesis.Setup (genChains)
import Test.Consensus.Genesis.Tests.Uniform (genUniformSchedulePoints)
import Test.Consensus.PointSchedule
  ( PeerSchedule
  , PointSchedule (..)
  , prettyPointSchedule
  )
import Test.Consensus.PointSchedule.Peers (PeerId (..), Peers (..))
import Test.Consensus.PointSchedule.Shrinking (shrinkAdversarialPeer, shrinkHonestPeers)
import Test.Consensus.PointSchedule.SinglePeer (SchedulePoint (..))
import Test.QuickCheck (Property, conjoin, counterexample)
import Test.Tasty
import Test.Tasty.QuickCheck (choose, forAllBlind, testProperty)
import Test.Util.TestBlock (TestBlock)

tests :: TestTree
tests :: TestTree
tests =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"shrinking functions"
    [ TestName -> [TestTree] -> TestTree
testGroup
        TestName
"honest peer shrinking"
        [ TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"actually shortens the schedule" Property
prop_honShortens
        , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"preserves the final state all peers" Property
prop_honPreservesFinalStates
        ]
    , TestName -> [TestTree] -> TestTree
testGroup
        TestName
"adversarial peer shrinking"
        [ TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"preserves consistency of TP/HP/BP" Property
prop_advPreservesConsistency
        ]
    ]

prop_honShortens :: Property
prop_honShortens :: Property
prop_honShortens = (Peers (PeerSchedule TestBlock)
 -> Peers (PeerSchedule TestBlock) -> Bool)
-> Property
checkHonShrinkProperty Peers (PeerSchedule TestBlock)
-> Peers (PeerSchedule TestBlock) -> Bool
forall blk.
Peers (PeerSchedule blk) -> Peers (PeerSchedule blk) -> Bool
isShorterThan

prop_honPreservesFinalStates :: Property
prop_honPreservesFinalStates :: Property
prop_honPreservesFinalStates = (Peers (PeerSchedule TestBlock)
 -> Peers (PeerSchedule TestBlock) -> Bool)
-> Property
checkHonShrinkProperty Peers (PeerSchedule TestBlock)
-> Peers (PeerSchedule TestBlock) -> Bool
forall blk.
Eq blk =>
Peers (PeerSchedule blk) -> Peers (PeerSchedule blk) -> Bool
doesNotChangeFinalState

prop_advPreservesConsistency :: Property
prop_advPreservesConsistency :: Property
prop_advPreservesConsistency = (PeerSchedule TestBlock -> Bool) -> Property
checkAdvShrinkProperty PeerSchedule TestBlock -> Bool
forall blk. Ord blk => PeerSchedule blk -> Bool
preservesConsistency

samePeers :: Peers (PeerSchedule blk) -> Peers (PeerSchedule blk) -> Bool
samePeers :: forall blk.
Peers (PeerSchedule blk) -> Peers (PeerSchedule blk) -> Bool
samePeers Peers (PeerSchedule blk)
sch1 Peers (PeerSchedule blk)
sch2 =
  (Map Int (PeerSchedule blk) -> [Int]
forall k a. Map k a -> [k]
keys (Map Int (PeerSchedule blk) -> [Int])
-> Map Int (PeerSchedule blk) -> [Int]
forall a b. (a -> b) -> a -> b
$ Peers (PeerSchedule blk) -> Map Int (PeerSchedule blk)
forall a. Peers a -> Map Int a
adversarialPeers Peers (PeerSchedule blk)
sch1)
    [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== (Map Int (PeerSchedule blk) -> [Int]
forall k a. Map k a -> [k]
keys (Map Int (PeerSchedule blk) -> [Int])
-> Map Int (PeerSchedule blk) -> [Int]
forall a b. (a -> b) -> a -> b
$ Peers (PeerSchedule blk) -> Map Int (PeerSchedule blk)
forall a. Peers a -> Map Int a
adversarialPeers Peers (PeerSchedule blk)
sch2)

-- | Checks whether at least one peer schedule in the second given peers schedule
-- is shorter than its corresponding one in the fist given peers schedule. “Shorter”
-- here means that it executes in less time.
isShorterThan :: Peers (PeerSchedule blk) -> Peers (PeerSchedule blk) -> Bool
isShorterThan :: forall blk.
Peers (PeerSchedule blk) -> Peers (PeerSchedule blk) -> Bool
isShorterThan Peers (PeerSchedule blk)
original Peers (PeerSchedule blk)
shrunk =
  Peers (PeerSchedule blk) -> Peers (PeerSchedule blk) -> Bool
forall blk.
Peers (PeerSchedule blk) -> Peers (PeerSchedule blk) -> Bool
samePeers Peers (PeerSchedule blk)
original Peers (PeerSchedule blk)
shrunk
    Bool -> Bool -> Bool
&& ( [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$
           (PeerSchedule blk -> PeerSchedule blk -> Bool)
-> [PeerSchedule blk] -> [PeerSchedule blk] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
             (\PeerSchedule blk
oldSch PeerSchedule blk
newSch -> ((Time, SchedulePoint blk) -> Time
forall a b. (a, b) -> a
fst ((Time, SchedulePoint blk) -> Time)
-> Maybe (Time, SchedulePoint blk) -> Maybe Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PeerSchedule blk -> Maybe (Time, SchedulePoint blk)
forall a. [a] -> Maybe a
lastMaybe PeerSchedule blk
newSch) Maybe Time -> Maybe Time -> Bool
forall a. Ord a => a -> a -> Bool
< ((Time, SchedulePoint blk) -> Time
forall a b. (a, b) -> a
fst ((Time, SchedulePoint blk) -> Time)
-> Maybe (Time, SchedulePoint blk) -> Maybe Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PeerSchedule blk -> Maybe (Time, SchedulePoint blk)
forall a. [a] -> Maybe a
lastMaybe PeerSchedule blk
oldSch))
             (Peers (PeerSchedule blk) -> [PeerSchedule blk]
forall a. Peers a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Peers (PeerSchedule blk)
original)
             (Peers (PeerSchedule blk) -> [PeerSchedule blk]
forall a. Peers a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Peers (PeerSchedule blk)
shrunk)
       )

doesNotChangeFinalState :: Eq blk => Peers (PeerSchedule blk) -> Peers (PeerSchedule blk) -> Bool
doesNotChangeFinalState :: forall blk.
Eq blk =>
Peers (PeerSchedule blk) -> Peers (PeerSchedule blk) -> Bool
doesNotChangeFinalState Peers (PeerSchedule blk)
original Peers (PeerSchedule blk)
shrunk =
  Peers (PeerSchedule blk) -> Peers (PeerSchedule blk) -> Bool
forall blk.
Peers (PeerSchedule blk) -> Peers (PeerSchedule blk) -> Bool
samePeers Peers (PeerSchedule blk)
original Peers (PeerSchedule blk)
shrunk
    Bool -> Bool -> Bool
&& ( [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$
           (PeerSchedule blk -> PeerSchedule blk -> Bool)
-> [PeerSchedule blk] -> [PeerSchedule blk] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
             ( \PeerSchedule blk
oldSch PeerSchedule blk
newSch ->
                 PeerSchedule blk -> Maybe (SchedulePoint blk)
forall blk. PeerSchedule blk -> Maybe (SchedulePoint blk)
lastTP PeerSchedule blk
oldSch Maybe (SchedulePoint blk) -> Maybe (SchedulePoint blk) -> Bool
forall a. Eq a => a -> a -> Bool
== PeerSchedule blk -> Maybe (SchedulePoint blk)
forall blk. PeerSchedule blk -> Maybe (SchedulePoint blk)
lastTP PeerSchedule blk
newSch
                   Bool -> Bool -> Bool
&& PeerSchedule blk -> Maybe (SchedulePoint blk)
forall blk. PeerSchedule blk -> Maybe (SchedulePoint blk)
lastHP PeerSchedule blk
oldSch Maybe (SchedulePoint blk) -> Maybe (SchedulePoint blk) -> Bool
forall a. Eq a => a -> a -> Bool
== PeerSchedule blk -> Maybe (SchedulePoint blk)
forall blk. PeerSchedule blk -> Maybe (SchedulePoint blk)
lastHP PeerSchedule blk
newSch
                   Bool -> Bool -> Bool
&& PeerSchedule blk -> Maybe (SchedulePoint blk)
forall blk. PeerSchedule blk -> Maybe (SchedulePoint blk)
lastBP PeerSchedule blk
oldSch Maybe (SchedulePoint blk) -> Maybe (SchedulePoint blk) -> Bool
forall a. Eq a => a -> a -> Bool
== PeerSchedule blk -> Maybe (SchedulePoint blk)
forall blk. PeerSchedule blk -> Maybe (SchedulePoint blk)
lastBP PeerSchedule blk
newSch
             )
             (Peers (PeerSchedule blk) -> [PeerSchedule blk]
forall a. Peers a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Peers (PeerSchedule blk)
original)
             (Peers (PeerSchedule blk) -> [PeerSchedule blk]
forall a. Peers a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Peers (PeerSchedule blk)
shrunk)
       )
 where
  lastTP :: PeerSchedule blk -> Maybe (SchedulePoint blk)
  lastTP :: forall blk. PeerSchedule blk -> Maybe (SchedulePoint blk)
lastTP PeerSchedule blk
sch = [SchedulePoint blk] -> Maybe (SchedulePoint blk)
forall a. [a] -> Maybe a
lastMaybe ([SchedulePoint blk] -> Maybe (SchedulePoint blk))
-> [SchedulePoint blk] -> Maybe (SchedulePoint blk)
forall a b. (a -> b) -> a -> b
$ ((Time, SchedulePoint blk) -> Maybe (SchedulePoint blk))
-> PeerSchedule blk -> [SchedulePoint blk]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case (Time
_, p :: SchedulePoint blk
p@(ScheduleTipPoint WithOrigin blk
_)) -> SchedulePoint blk -> Maybe (SchedulePoint blk)
forall a. a -> Maybe a
Just SchedulePoint blk
p; (Time, SchedulePoint blk)
_ -> Maybe (SchedulePoint blk)
forall a. Maybe a
Nothing) PeerSchedule blk
sch
  lastHP :: PeerSchedule blk -> Maybe (SchedulePoint blk)
  lastHP :: forall blk. PeerSchedule blk -> Maybe (SchedulePoint blk)
lastHP PeerSchedule blk
sch = [SchedulePoint blk] -> Maybe (SchedulePoint blk)
forall a. [a] -> Maybe a
lastMaybe ([SchedulePoint blk] -> Maybe (SchedulePoint blk))
-> [SchedulePoint blk] -> Maybe (SchedulePoint blk)
forall a b. (a -> b) -> a -> b
$ ((Time, SchedulePoint blk) -> Maybe (SchedulePoint blk))
-> PeerSchedule blk -> [SchedulePoint blk]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case (Time
_, p :: SchedulePoint blk
p@(ScheduleHeaderPoint WithOrigin blk
_)) -> SchedulePoint blk -> Maybe (SchedulePoint blk)
forall a. a -> Maybe a
Just SchedulePoint blk
p; (Time, SchedulePoint blk)
_ -> Maybe (SchedulePoint blk)
forall a. Maybe a
Nothing) PeerSchedule blk
sch
  lastBP :: PeerSchedule blk -> Maybe (SchedulePoint blk)
  lastBP :: forall blk. PeerSchedule blk -> Maybe (SchedulePoint blk)
lastBP PeerSchedule blk
sch = [SchedulePoint blk] -> Maybe (SchedulePoint blk)
forall a. [a] -> Maybe a
lastMaybe ([SchedulePoint blk] -> Maybe (SchedulePoint blk))
-> [SchedulePoint blk] -> Maybe (SchedulePoint blk)
forall a b. (a -> b) -> a -> b
$ ((Time, SchedulePoint blk) -> Maybe (SchedulePoint blk))
-> PeerSchedule blk -> [SchedulePoint blk]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case (Time
_, p :: SchedulePoint blk
p@(ScheduleBlockPoint WithOrigin blk
_)) -> SchedulePoint blk -> Maybe (SchedulePoint blk)
forall a. a -> Maybe a
Just SchedulePoint blk
p; (Time, SchedulePoint blk)
_ -> Maybe (SchedulePoint blk)
forall a. Maybe a
Nothing) PeerSchedule blk
sch

-- | Checks that the shrunk schedule still has the properties TP >= HP and HP >= BP at any time
preservesConsistency :: Ord blk => PeerSchedule blk -> Bool
preservesConsistency :: forall blk. Ord blk => PeerSchedule blk -> Bool
preservesConsistency PeerSchedule blk
shrunk =
  (\(WithOrigin blk
_, WithOrigin blk
_, Bool
x) -> Bool
x) ((WithOrigin blk, WithOrigin blk, Bool) -> Bool)
-> (WithOrigin blk, WithOrigin blk, Bool) -> Bool
forall a b. (a -> b) -> a -> b
$
    ((Time, SchedulePoint blk)
 -> (WithOrigin blk, WithOrigin blk, Bool)
 -> (WithOrigin blk, WithOrigin blk, Bool))
-> (WithOrigin blk, WithOrigin blk, Bool)
-> PeerSchedule blk
-> (WithOrigin blk, WithOrigin blk, Bool)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
      ( \(Time
_t, SchedulePoint blk
p) (WithOrigin blk
tp, WithOrigin blk
hp, Bool
acc) ->
          case SchedulePoint blk
p of
            ScheduleTipPoint WithOrigin blk
newTp -> (WithOrigin blk
newTp, WithOrigin blk
hp, Bool
acc)
            ScheduleHeaderPoint WithOrigin blk
newHp -> (WithOrigin blk
tp, WithOrigin blk
newHp, Bool
acc Bool -> Bool -> Bool
&& WithOrigin blk
tp WithOrigin blk -> WithOrigin blk -> Bool
forall a. Ord a => a -> a -> Bool
>= WithOrigin blk
newHp)
            ScheduleBlockPoint WithOrigin blk
newBp -> (WithOrigin blk
tp, WithOrigin blk
hp, Bool
acc Bool -> Bool -> Bool
&& WithOrigin blk
hp WithOrigin blk -> WithOrigin blk -> Bool
forall a. Ord a => a -> a -> Bool
>= WithOrigin blk
newBp)
      )
      (WithOrigin blk
forall t. WithOrigin t
Origin, WithOrigin blk
forall t. WithOrigin t
Origin, Bool
True)
      PeerSchedule blk
shrunk

checkHonShrinkProperty ::
  (Peers (PeerSchedule TestBlock) -> Peers (PeerSchedule TestBlock) -> Bool) -> Property
checkHonShrinkProperty :: (Peers (PeerSchedule TestBlock)
 -> Peers (PeerSchedule TestBlock) -> Bool)
-> Property
checkHonShrinkProperty Peers (PeerSchedule TestBlock)
-> Peers (PeerSchedule TestBlock) -> Bool
prop =
  Gen (PointSchedule TestBlock)
-> (PointSchedule TestBlock -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind
    (Gen Word -> Gen (GenesisTest TestBlock ())
forall blk.
(HasHeader blk, IssueTestBlock blk) =>
Gen Word -> Gen (GenesisTest blk ())
genChains ((Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
choose (Word
1, Word
4)) Gen (GenesisTest TestBlock ())
-> (GenesisTest TestBlock () -> Gen (PointSchedule TestBlock))
-> Gen (PointSchedule TestBlock)
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GenesisTest TestBlock () -> Gen (PointSchedule TestBlock)
forall blk.
HasHeader blk =>
GenesisTest blk () -> Gen (PointSchedule blk)
genUniformSchedulePoints)
    ( \sch :: PointSchedule TestBlock
sch@PointSchedule{Peers (PeerSchedule TestBlock)
psSchedule :: Peers (PeerSchedule TestBlock)
psSchedule :: forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule, [PeerId]
psStartOrder :: [PeerId]
psStartOrder :: forall blk. PointSchedule blk -> [PeerId]
psStartOrder, Time
psMinEndTime :: Time
psMinEndTime :: forall blk. PointSchedule blk -> Time
psMinEndTime} ->
        [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin ([Property] -> Property) -> [Property] -> Property
forall a b. (a -> b) -> a -> b
$
          (Peers (PeerSchedule TestBlock) -> Property)
-> [Peers (PeerSchedule TestBlock)] -> [Property]
forall a b. (a -> b) -> [a] -> [b]
map
            ( \Peers (PeerSchedule TestBlock)
shrunk ->
                TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample
                  ( TestName
"Original schedule:\n"
                      TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ [TestName] -> TestName
unlines ((TestName -> TestName) -> [TestName] -> [TestName]
forall a b. (a -> b) -> [a] -> [b]
map (TestName
"    " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++) ([TestName] -> [TestName]) -> [TestName] -> [TestName]
forall a b. (a -> b) -> a -> b
$ PointSchedule TestBlock -> [TestName]
forall blk.
CondenseList (NodeState blk) =>
PointSchedule blk -> [TestName]
prettyPointSchedule PointSchedule TestBlock
sch)
                      TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
"\nShrunk schedule:\n"
                      TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ [TestName] -> TestName
unlines
                        ( (TestName -> TestName) -> [TestName] -> [TestName]
forall a b. (a -> b) -> [a] -> [b]
map (TestName
"    " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++) ([TestName] -> [TestName]) -> [TestName] -> [TestName]
forall a b. (a -> b) -> a -> b
$
                            PointSchedule TestBlock -> [TestName]
forall blk.
CondenseList (NodeState blk) =>
PointSchedule blk -> [TestName]
prettyPointSchedule (PointSchedule TestBlock -> [TestName])
-> PointSchedule TestBlock -> [TestName]
forall a b. (a -> b) -> a -> b
$
                              PointSchedule{psSchedule :: Peers (PeerSchedule TestBlock)
psSchedule = Peers (PeerSchedule TestBlock)
shrunk, [PeerId]
psStartOrder :: [PeerId]
psStartOrder :: [PeerId]
psStartOrder, Time
psMinEndTime :: Time
psMinEndTime :: Time
psMinEndTime}
                        )
                  )
                  (Peers (PeerSchedule TestBlock)
-> Peers (PeerSchedule TestBlock) -> Bool
prop Peers (PeerSchedule TestBlock)
psSchedule Peers (PeerSchedule TestBlock)
shrunk)
            )
            (Peers (PeerSchedule TestBlock) -> [Peers (PeerSchedule TestBlock)]
forall blk. Peers (PeerSchedule blk) -> [Peers (PeerSchedule blk)]
shrinkHonestPeers Peers (PeerSchedule TestBlock)
psSchedule)
    )

checkAdvShrinkProperty :: (PeerSchedule TestBlock -> Bool) -> Property
checkAdvShrinkProperty :: (PeerSchedule TestBlock -> Bool) -> Property
checkAdvShrinkProperty PeerSchedule TestBlock -> Bool
prop =
  Gen (PeerSchedule TestBlock)
-> (PeerSchedule TestBlock -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind
    ( do
        chains <- Gen Word -> Gen (GenesisTest TestBlock ())
forall blk.
(HasHeader blk, IssueTestBlock blk) =>
Gen Word -> Gen (GenesisTest blk ())
genChains ((Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
choose (Word
1, Word
4))
        PointSchedule{psSchedule} <- genUniformSchedulePoints chains
        -- \| We generated at least one honest peer schedule, and it can serve as adversarial
        -- for the intent of this test.
        case elems $ honestPeers psSchedule of
          PeerSchedule TestBlock
sch : [PeerSchedule TestBlock]
_ -> PeerSchedule TestBlock -> Gen (PeerSchedule TestBlock)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PeerSchedule TestBlock
sch
          [PeerSchedule TestBlock]
_ -> TestName -> Gen (PeerSchedule TestBlock)
forall a. HasCallStack => TestName -> a
error TestName
"checkAdvShrinkProperty: no honest peer schedule generated"
    )
    ( \PeerSchedule TestBlock
sch ->
        [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin ([Property] -> Property) -> [Property] -> Property
forall a b. (a -> b) -> a -> b
$
          (PeerSchedule TestBlock -> Property)
-> [PeerSchedule TestBlock] -> [Property]
forall a b. (a -> b) -> [a] -> [b]
map
            ( \PeerSchedule TestBlock
shrunk ->
                TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample
                  ( TestName
"Original schedule:\n"
                      TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ [TestName] -> TestName
unlines ((TestName -> TestName) -> [TestName] -> [TestName]
forall a b. (a -> b) -> [a] -> [b]
map (TestName
"    " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++) ([TestName] -> [TestName]) -> [TestName] -> [TestName]
forall a b. (a -> b) -> a -> b
$ PointSchedule TestBlock -> [TestName]
forall blk.
CondenseList (NodeState blk) =>
PointSchedule blk -> [TestName]
prettyPointSchedule (PointSchedule TestBlock -> [TestName])
-> PointSchedule TestBlock -> [TestName]
forall a b. (a -> b) -> a -> b
$ PeerSchedule TestBlock -> PointSchedule TestBlock
mkAdvPointSchedule PeerSchedule TestBlock
sch)
                      TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
"\nShrunk schedule:\n"
                      TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ [TestName] -> TestName
unlines ((TestName -> TestName) -> [TestName] -> [TestName]
forall a b. (a -> b) -> [a] -> [b]
map (TestName
"    " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++) ([TestName] -> [TestName]) -> [TestName] -> [TestName]
forall a b. (a -> b) -> a -> b
$ PointSchedule TestBlock -> [TestName]
forall blk.
CondenseList (NodeState blk) =>
PointSchedule blk -> [TestName]
prettyPointSchedule (PointSchedule TestBlock -> [TestName])
-> PointSchedule TestBlock -> [TestName]
forall a b. (a -> b) -> a -> b
$ PeerSchedule TestBlock -> PointSchedule TestBlock
mkAdvPointSchedule PeerSchedule TestBlock
shrunk)
                  )
                  (PeerSchedule TestBlock -> Bool
prop PeerSchedule TestBlock
shrunk)
            )
            (PeerSchedule TestBlock -> [PeerSchedule TestBlock]
forall blk. Ord blk => PeerSchedule blk -> [PeerSchedule blk]
shrinkAdversarialPeer PeerSchedule TestBlock
sch)
    )

mkAdvPointSchedule :: PeerSchedule TestBlock -> PointSchedule TestBlock
mkAdvPointSchedule :: PeerSchedule TestBlock -> PointSchedule TestBlock
mkAdvPointSchedule PeerSchedule TestBlock
sch =
  PointSchedule
    { psSchedule :: Peers (PeerSchedule TestBlock)
psSchedule = Peers{honestPeers :: Map Int (PeerSchedule TestBlock)
honestPeers = Map Int (PeerSchedule TestBlock)
forall k a. Map k a
empty, adversarialPeers :: Map Int (PeerSchedule TestBlock)
adversarialPeers = Int -> PeerSchedule TestBlock -> Map Int (PeerSchedule TestBlock)
forall k a. k -> a -> Map k a
singleton Int
1 PeerSchedule TestBlock
sch}
    , psStartOrder :: [PeerId]
psStartOrder = [Int -> PeerId
AdversarialPeer Int
1]
    , psMinEndTime :: Time
psMinEndTime = case PeerSchedule TestBlock -> Maybe (Time, SchedulePoint TestBlock)
forall a. [a] -> Maybe a
lastMaybe PeerSchedule TestBlock
sch of
        Maybe (Time, SchedulePoint TestBlock)
Nothing -> DiffTime -> Time
Time DiffTime
0
        Just (Time
t, SchedulePoint TestBlock
_) -> Time
t
    }