{-# 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           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

-- | Apparently, `unsnoc` hasn't been invented yet, so we'll do this manually
lastM :: [a] -> Maybe a
lastM :: forall a. [a] -> Maybe a
lastM []     = Maybe a
forall a. Maybe a
Nothing
lastM [a
a]    = a -> Maybe a
forall a. a -> Maybe a
Just a
a
lastM (a
_:[a]
ps) = [a] -> Maybe a
forall a. [a] -> Maybe a
lastM [a]
ps

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
lastM 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
lastM 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
lastM ([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
lastM ([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
lastM ([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)
$sel:psSchedule:PointSchedule :: forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule, Time
psMinEndTime :: Time
$sel:psMinEndTime:PointSchedule :: 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
$ Peers (PeerSchedule TestBlock) -> Time -> PointSchedule TestBlock
forall blk. Peers (PeerSchedule blk) -> Time -> PointSchedule blk
PointSchedule Peers (PeerSchedule TestBlock)
shrunk 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)
    )