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

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

import Data.Foldable (toList)
import Data.Map (keys)
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 (Peers (..))
import Test.Consensus.PointSchedule.Shrinking (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 =
  [Char] -> [TestTree] -> TestTree
testGroup
    [Char]
"shrinking functions"
    [ [Char] -> [TestTree] -> TestTree
testGroup
        [Char]
"honest peer shrinking"
        [ [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"actually shortens the schedule" Property
prop_shortens
        , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"preserves the final state all peers" Property
prop_preservesFinalStates
        ]
    ]

prop_shortens :: Property
prop_shortens :: Property
prop_shortens = (Peers (PeerSchedule TestBlock)
 -> Peers (PeerSchedule TestBlock) -> Bool)
-> Property
checkShrinkProperty Peers (PeerSchedule TestBlock)
-> Peers (PeerSchedule TestBlock) -> Bool
forall blk.
Peers (PeerSchedule blk) -> Peers (PeerSchedule blk) -> Bool
isShorterThan

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

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

checkShrinkProperty ::
  (Peers (PeerSchedule TestBlock) -> Peers (PeerSchedule TestBlock) -> Bool) -> Property
checkShrinkProperty :: (Peers (PeerSchedule TestBlock)
 -> Peers (PeerSchedule TestBlock) -> Bool)
-> Property
checkShrinkProperty 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 ())
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)
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 ->
                [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample
                  ( [Char]
"Original schedule:\n"
                      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unlines (([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"    " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ PointSchedule TestBlock -> [[Char]]
forall blk.
CondenseList (NodeState blk) =>
PointSchedule blk -> [[Char]]
prettyPointSchedule PointSchedule TestBlock
sch)
                      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\nShrunk schedule:\n"
                      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unlines
                        ( ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"    " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$
                            PointSchedule TestBlock -> [[Char]]
forall blk.
CondenseList (NodeState blk) =>
PointSchedule blk -> [[Char]]
prettyPointSchedule (PointSchedule TestBlock -> [[Char]])
-> PointSchedule TestBlock -> [[Char]]
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)
    )