{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Test that the Peras voting rules can correctly decide when to vote.
--
-- NOTE: in this file, we use uncommon variable names such as `_L` or `_X`
-- because that is their name in the CIP-0140, and we can't have variable names
-- starting with capital letters. Contrary to typical Haskell conventions, those
-- do not denote ignored variables.
module Test.Consensus.Peras.Voting.Rules (tests) where

import GHC.Generics (Generic)
import Ouroboros.Consensus.Block.Abstract
  ( SlotNo (..)
  , WithOrigin (..)
  )
import Ouroboros.Consensus.Block.SupportsPeras
  ( HasPerasCertRound (..)
  , PerasRoundNo (..)
  , getPerasCertRound
  , onPerasRoundNo
  )
import Ouroboros.Consensus.BlockchainTime
  ( RelativeTime (..)
  )
import Ouroboros.Consensus.Peras.Params
  ( PerasBlockMinSlots (..)
  , PerasCertArrivalThreshold (..)
  , PerasCooldownRounds (..)
  , PerasIgnoranceRounds (..)
  , PerasParams (..)
  , mkPerasParams
  )
import Ouroboros.Consensus.Peras.Voting.Rules
  ( PerasVotingRulesDecision (..)
  , isPerasVotingAllowed
  )
import Ouroboros.Consensus.Peras.Voting.View
  ( LatestCertOnChainView (..)
  , LatestCertSeenView (..)
  , PerasVotingView (..)
  )
import Ouroboros.Consensus.Util.Pred (Evidence (..), explainShallow)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck
  ( Arbitrary (..)
  , Gen
  , Property
  , Testable (..)
  , choose
  , counterexample
  , forAll
  , frequency
  , tabulate
  , testProperty
  )
import Test.Util.Orphans.Arbitrary (genNominalDiffTime50Years)
import Test.Util.QuickCheck (geometric)
import Test.Util.TestEnv (adjustQuickCheckTests)

{-------------------------------------------------------------------------------
  Tests
-------------------------------------------------------------------------------}

tests :: TestTree
tests :: TestTree
tests =
  (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckTests (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
    TestName -> [TestTree] -> TestTree
testGroup
      TestName
"Peras voting rules"
      [ TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"isPerasVotingAllowed" Property
prop_isPerasVotingAllowed
      ]

{-------------------------------------------------------------------------------
  Model conformance test property
-------------------------------------------------------------------------------}

data PerasVotingRulesDecisionModel
  = PerasVotingDecisionModel
  { PerasVotingRulesDecisionModel -> Bool
shouldVote :: Bool
  , PerasVotingRulesDecisionModel -> Bool
vr1a :: Bool
  , PerasVotingRulesDecisionModel -> Bool
vr1b :: Bool
  , PerasVotingRulesDecisionModel -> Bool
vr2a :: Bool
  , PerasVotingRulesDecisionModel -> Bool
vr2b :: Bool
  }

-- | A simplified model of the Peras voting rules, used to compare against the
-- real implementation. The main difference is that this model computes the
-- result of the predicate directly over the inputs, rather than using the
-- 'Pred' combinators to produce evidence in either direction.
--
-- NOTE: this predicate could be lifted directly from the agda specification.
isPerasVotingAllowedModel ::
  PerasVotingView TestCert ->
  PerasVotingRulesDecisionModel
isPerasVotingAllowedModel :: PerasVotingView TestCert -> PerasVotingRulesDecisionModel
isPerasVotingAllowedModel
  PerasVotingView
    { PerasParams
perasParams :: PerasParams
perasParams :: forall cert. PerasVotingView cert -> PerasParams
perasParams
    , PerasRoundNo
currRoundNo :: PerasRoundNo
currRoundNo :: forall cert. PerasVotingView cert -> PerasRoundNo
currRoundNo
    , WithOrigin (LatestCertSeenView TestCert)
latestCertSeen :: WithOrigin (LatestCertSeenView TestCert)
latestCertSeen :: forall cert.
PerasVotingView cert -> WithOrigin (LatestCertSeenView cert)
latestCertSeen
    , WithOrigin (LatestCertOnChainView TestCert)
latestCertOnChain :: WithOrigin (LatestCertOnChainView TestCert)
latestCertOnChain :: forall cert.
PerasVotingView cert -> WithOrigin (LatestCertOnChainView cert)
latestCertOnChain
    } =
    PerasVotingDecisionModel
      { shouldVote :: Bool
shouldVote = Bool
vr1a Bool -> Bool -> Bool
&& Bool
vr1b Bool -> Bool -> Bool
|| Bool
vr2a Bool -> Bool -> Bool
&& Bool
vr2b
      , vr1a :: Bool
vr1a = Bool
vr1a
      , vr1b :: Bool
vr1b = Bool
vr1b
      , vr2a :: Bool
vr2a = Bool
vr2a
      , vr2b :: Bool
vr2b = Bool
vr2b
      }
   where
    vr1a :: Bool
vr1a =
      Bool
vr1a1 Bool -> Bool -> Bool
&& Bool
vr1a2
    vr1a1 :: Bool
vr1a1 =
      case WithOrigin (LatestCertSeenView TestCert)
latestCertSeen of
        NotOrigin LatestCertSeenView TestCert
cert ->
          PerasRoundNo
currRoundNo PerasRoundNo -> PerasRoundNo -> Bool
forall a. Eq a => a -> a -> Bool
== TestCert -> PerasRoundNo
forall cert. HasPerasCertRound cert => cert -> PerasRoundNo
getPerasCertRound (LatestCertSeenView TestCert -> TestCert
forall cert. LatestCertSeenView cert -> cert
lcsCert LatestCertSeenView TestCert
cert) PerasRoundNo -> PerasRoundNo -> PerasRoundNo
forall a. Num a => a -> a -> a
+ PerasRoundNo
1
        WithOrigin (LatestCertSeenView TestCert)
Origin ->
          PerasRoundNo
currRoundNo PerasRoundNo -> PerasRoundNo -> Bool
forall a. Eq a => a -> a -> Bool
== Word64 -> PerasRoundNo
PerasRoundNo Word64
0
    vr1a2 :: Bool
vr1a2 =
      case WithOrigin (LatestCertSeenView TestCert)
latestCertSeen of
        NotOrigin LatestCertSeenView TestCert
cert ->
          LatestCertSeenView TestCert -> SlotNo
forall cert. LatestCertSeenView cert -> SlotNo
lcsArrivalSlot LatestCertSeenView TestCert
cert SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<= LatestCertSeenView TestCert -> SlotNo
forall cert. LatestCertSeenView cert -> SlotNo
lcsRoundStartSlot LatestCertSeenView TestCert
cert SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
_X
        WithOrigin (LatestCertSeenView TestCert)
Origin ->
          Bool
True
    vr1b :: Bool
vr1b =
      case WithOrigin (LatestCertSeenView TestCert)
latestCertSeen of
        NotOrigin LatestCertSeenView TestCert
cert ->
          LatestCertSeenView TestCert -> Bool
forall cert. LatestCertSeenView cert -> Bool
lcsCandidateBlockExtendsCert LatestCertSeenView TestCert
cert
        WithOrigin (LatestCertSeenView TestCert)
Origin ->
          Bool
True
    vr2a :: Bool
vr2a =
      case WithOrigin (LatestCertSeenView TestCert)
latestCertSeen of
        NotOrigin LatestCertSeenView TestCert
cert ->
          TestCert -> PerasRoundNo
forall cert. HasPerasCertRound cert => cert -> PerasRoundNo
getPerasCertRound (LatestCertSeenView TestCert -> TestCert
forall cert. LatestCertSeenView cert -> cert
lcsCert LatestCertSeenView TestCert
cert) PerasRoundNo -> PerasRoundNo -> PerasRoundNo
forall a. Num a => a -> a -> a
+ PerasRoundNo
_R PerasRoundNo -> PerasRoundNo -> Bool
forall a. Ord a => a -> a -> Bool
<= PerasRoundNo
currRoundNo
        WithOrigin (LatestCertSeenView TestCert)
Origin ->
          PerasRoundNo
_R PerasRoundNo -> PerasRoundNo -> Bool
forall a. Ord a => a -> a -> Bool
<= PerasRoundNo
currRoundNo
    vr2b :: Bool
vr2b =
      case WithOrigin (LatestCertOnChainView TestCert)
latestCertOnChain of
        NotOrigin LatestCertOnChainView TestCert
cert ->
          (PerasRoundNo
currRoundNo PerasRoundNo -> PerasRoundNo -> Bool
forall a. Ord a => a -> a -> Bool
> TestCert -> PerasRoundNo
forall cert. HasPerasCertRound cert => cert -> PerasRoundNo
getPerasCertRound (LatestCertOnChainView TestCert -> TestCert
forall cert. LatestCertOnChainView cert -> cert
lcocCert LatestCertOnChainView TestCert
cert))
            Bool -> Bool -> Bool
&& ( (PerasRoundNo
currRoundNo PerasRoundNo -> PerasRoundNo -> PerasRoundNo
`rmod` PerasRoundNo
_K)
                   PerasRoundNo -> PerasRoundNo -> Bool
forall a. Eq a => a -> a -> Bool
== (TestCert -> PerasRoundNo
forall cert. HasPerasCertRound cert => cert -> PerasRoundNo
getPerasCertRound (LatestCertOnChainView TestCert -> TestCert
forall cert. LatestCertOnChainView cert -> cert
lcocCert LatestCertOnChainView TestCert
cert) PerasRoundNo -> PerasRoundNo -> PerasRoundNo
`rmod` PerasRoundNo
_K)
               )
        WithOrigin (LatestCertOnChainView TestCert)
Origin ->
          PerasRoundNo
currRoundNo PerasRoundNo -> PerasRoundNo -> PerasRoundNo
`rmod` PerasRoundNo
_K PerasRoundNo -> PerasRoundNo -> Bool
forall a. Eq a => a -> a -> Bool
== PerasRoundNo
_K PerasRoundNo -> PerasRoundNo -> PerasRoundNo
forall a. Num a => a -> a -> a
- PerasRoundNo
1

    _X :: SlotNo
_X =
      Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$
        PerasCertArrivalThreshold -> Word64
unPerasCertArrivalThreshold (PerasCertArrivalThreshold -> Word64)
-> PerasCertArrivalThreshold -> Word64
forall a b. (a -> b) -> a -> b
$
          PerasParams -> PerasCertArrivalThreshold
perasCertArrivalThreshold (PerasParams -> PerasCertArrivalThreshold)
-> PerasParams -> PerasCertArrivalThreshold
forall a b. (a -> b) -> a -> b
$
            PerasParams
perasParams
    _R :: PerasRoundNo
_R =
      Word64 -> PerasRoundNo
PerasRoundNo (Word64 -> PerasRoundNo) -> Word64 -> PerasRoundNo
forall a b. (a -> b) -> a -> b
$
        PerasIgnoranceRounds -> Word64
unPerasIgnoranceRounds (PerasIgnoranceRounds -> Word64) -> PerasIgnoranceRounds -> Word64
forall a b. (a -> b) -> a -> b
$
          PerasParams -> PerasIgnoranceRounds
perasIgnoranceRounds (PerasParams -> PerasIgnoranceRounds)
-> PerasParams -> PerasIgnoranceRounds
forall a b. (a -> b) -> a -> b
$
            PerasParams
perasParams
    _K :: PerasRoundNo
_K =
      Word64 -> PerasRoundNo
PerasRoundNo (Word64 -> PerasRoundNo) -> Word64 -> PerasRoundNo
forall a b. (a -> b) -> a -> b
$
        PerasCooldownRounds -> Word64
unPerasCooldownRounds (PerasCooldownRounds -> Word64) -> PerasCooldownRounds -> Word64
forall a b. (a -> b) -> a -> b
$
          PerasParams -> PerasCooldownRounds
perasCooldownRounds (PerasParams -> PerasCooldownRounds)
-> PerasParams -> PerasCooldownRounds
forall a b. (a -> b) -> a -> b
$
            PerasParams
perasParams

    rmod :: PerasRoundNo -> PerasRoundNo -> PerasRoundNo
rmod = (Word64 -> Word64 -> Word64)
-> PerasRoundNo -> PerasRoundNo -> PerasRoundNo
onPerasRoundNo Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
mod

-- | Test that the Peras voting rules can correctly decide when to vote based
-- on a simplified model that doesn't use anything fancy to evaluate the rules.
prop_isPerasVotingAllowed :: Property
prop_isPerasVotingAllowed :: Property
prop_isPerasVotingAllowed = Gen (PerasVotingView TestCert)
-> (PerasVotingView TestCert -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (PerasVotingView TestCert)
genPerasVotingView ((PerasVotingView TestCert -> Property) -> Property)
-> (PerasVotingView TestCert -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \PerasVotingView TestCert
pvv -> do
  -- Determine whether we should vote according to the model
  let PerasVotingDecisionModel{Bool
shouldVote :: PerasVotingRulesDecisionModel -> Bool
shouldVote :: Bool
shouldVote, Bool
vr1a :: PerasVotingRulesDecisionModel -> Bool
vr1a :: Bool
vr1a, Bool
vr1b :: PerasVotingRulesDecisionModel -> Bool
vr1b :: Bool
vr1b, Bool
vr2a :: PerasVotingRulesDecisionModel -> Bool
vr2a :: Bool
vr2a, Bool
vr2b :: PerasVotingRulesDecisionModel -> Bool
vr2b :: Bool
vr2b} =
        PerasVotingView TestCert -> PerasVotingRulesDecisionModel
isPerasVotingAllowedModel PerasVotingView TestCert
pvv
  -- Some helper functions to report success/failure
  let chain :: [c -> c] -> c -> c
chain = (c -> [c -> c] -> c) -> [c -> c] -> c -> c
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((c -> c) -> c -> c) -> c -> [c -> c] -> c
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (c -> c) -> c -> c
forall a b. (a -> b) -> a -> b
($)) ([c -> c] -> c -> c)
-> ([c -> c] -> [c -> c]) -> [c -> c] -> c -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [c -> c] -> [c -> c]
forall a. [a] -> [a]
reverse
  let ok :: TestName -> Property
ok TestName
desc =
        [Property -> Property] -> Property -> Property
forall {c}. [c -> c] -> c -> c
chain
          [ TestName -> [TestName] -> Property -> Property
forall prop.
Testable prop =>
TestName -> [TestName] -> prop -> Property
tabulate TestName
"VR-1A" [Bool -> TestName
forall a. Show a => a -> TestName
show Bool
vr1a]
          , TestName -> [TestName] -> Property -> Property
forall prop.
Testable prop =>
TestName -> [TestName] -> prop -> Property
tabulate TestName
"VR-1B" [Bool -> TestName
forall a. Show a => a -> TestName
show Bool
vr1b]
          , TestName -> [TestName] -> Property -> Property
forall prop.
Testable prop =>
TestName -> [TestName] -> prop -> Property
tabulate TestName
"VR-2A" [Bool -> TestName
forall a. Show a => a -> TestName
show Bool
vr2a]
          , TestName -> [TestName] -> Property -> Property
forall prop.
Testable prop =>
TestName -> [TestName] -> prop -> Property
tabulate TestName
"VR-2B" [Bool -> TestName
forall a. Show a => a -> TestName
show Bool
vr2b]
          , TestName -> [TestName] -> Property -> Property
forall prop.
Testable prop =>
TestName -> [TestName] -> prop -> Property
tabulate TestName
"VR-(1A|1B|2A|2B)" [(Bool, Bool, Bool, Bool) -> TestName
forall a. Show a => a -> TestName
show (Bool
vr1a, Bool
vr1b, Bool
vr2a, Bool
vr2b)]
          , TestName -> [TestName] -> Property -> Property
forall prop.
Testable prop =>
TestName -> [TestName] -> prop -> Property
tabulate TestName
"Should vote according to model" [Bool -> TestName
forall a. Show a => a -> TestName
show Bool
shouldVote]
          , TestName -> [TestName] -> Property -> Property
forall prop.
Testable prop =>
TestName -> [TestName] -> prop -> Property
tabulate TestName
"Actual result" [TestName
desc]
          ]
          (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
  let failure :: TestName -> Property
failure TestName
desc =
        TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
desc (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
  -- Now check that the real implementation agrees with the model
  let votingDecision :: PerasVotingRulesDecision
votingDecision = PerasVotingView TestCert -> PerasVotingRulesDecision
forall cert.
HasPerasCertRound cert =>
PerasVotingView cert -> PerasVotingRulesDecision
isPerasVotingAllowed PerasVotingView TestCert
pvv
  case PerasVotingRulesDecision
votingDecision of
    Vote (ETrue Pred PerasVotingRule
voteReason)
      | Bool
shouldVote ->
          TestName -> Property
ok (TestName -> Property) -> TestName -> Property
forall a b. (a -> b) -> a -> b
$ TestName
"Vote(" TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> Pred PerasVotingRule -> TestName
forall a. Explainable a => a -> TestName
explainShallow Pred PerasVotingRule
voteReason TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> TestName
")"
      | Bool
otherwise ->
          TestName -> Property
failure (TestName -> Property) -> TestName -> Property
forall a b. (a -> b) -> a -> b
$ TestName
"Expected not to vote, but got: " TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> PerasVotingRulesDecision -> TestName
forall a. Show a => a -> TestName
show PerasVotingRulesDecision
votingDecision
    NoVote (EFalse Pred PerasVotingRule
noVoteReason)
      | Bool -> Bool
not Bool
shouldVote ->
          TestName -> Property
ok (TestName -> Property) -> TestName -> Property
forall a b. (a -> b) -> a -> b
$ TestName
"NoVote(" TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> Pred PerasVotingRule -> TestName
forall a. Explainable a => a -> TestName
explainShallow Pred PerasVotingRule
noVoteReason TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> TestName
")"
      | Bool
otherwise ->
          TestName -> Property
failure (TestName -> Property) -> TestName -> Property
forall a b. (a -> b) -> a -> b
$ TestName
"Expected to vote, but got: " TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> PerasVotingRulesDecision -> TestName
forall a. Show a => a -> TestName
show PerasVotingRulesDecision
votingDecision

{-------------------------------------------------------------------------------
  Arbitrary helpers
-------------------------------------------------------------------------------}

-- * Peras parameters

-- NOTE: we use a geometric distribution to bias towards smaller values.
-- This increases the chance of covering all the voting rules more evenly,
-- while still allowing for larger values to be generated occasionally.
--
-- Moreover, geometric(0.5) + 1 means that:
--  - 50% chance of being 1
--  - 25% chance of being 2
--  - 12.5% chance of being 3
--  ... and so on
genPerasParams :: Gen PerasParams
genPerasParams :: Gen PerasParams
genPerasParams = do
  _L <- Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> (Int -> Int) -> Int -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> Word64) -> Gen Int -> Gen Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Double -> Gen Int
geometric Double
0.5
  _X <- fromIntegral . (+ 1) <$> geometric 0.5
  _R <- fromIntegral . (+ 1) <$> geometric 0.5
  _K <- fromIntegral . (+ 1) <$> geometric 0.5
  pure
    mkPerasParams
      { perasBlockMinSlots = PerasBlockMinSlots _L
      , perasCertArrivalThreshold = PerasCertArrivalThreshold _X
      , perasIgnoranceRounds = PerasIgnoranceRounds _R
      , perasCooldownRounds = PerasCooldownRounds _K
      }

-- * Slot numbers

genSlotNo :: Gen SlotNo
genSlotNo :: Gen SlotNo
genSlotNo = do
  n <- Gen Word64
forall a. Arbitrary a => Gen a
arbitrary
  pure (SlotNo n)

-- * Peras round numbers

genPerasRoundNo :: Gen PerasRoundNo
genPerasRoundNo :: Gen PerasRoundNo
genPerasRoundNo = do
  n <- Gen Word64
forall a. Arbitrary a => Gen a
arbitrary
  pure (PerasRoundNo n)

-- * Mocked certificate type

-- | A mocked certificate type for testing, so we don't have to deal with
-- development changes in the real certificate type.
data TestCert
  = TestCert
  { TestCert -> RelativeTime
tcArrivalTime :: RelativeTime
  , TestCert -> PerasRoundNo
tcRoundNo :: PerasRoundNo
  }
  deriving (Int -> TestCert -> TestName -> TestName
[TestCert] -> TestName -> TestName
TestCert -> TestName
(Int -> TestCert -> TestName -> TestName)
-> (TestCert -> TestName)
-> ([TestCert] -> TestName -> TestName)
-> Show TestCert
forall a.
(Int -> a -> TestName -> TestName)
-> (a -> TestName) -> ([a] -> TestName -> TestName) -> Show a
$cshowsPrec :: Int -> TestCert -> TestName -> TestName
showsPrec :: Int -> TestCert -> TestName -> TestName
$cshow :: TestCert -> TestName
show :: TestCert -> TestName
$cshowList :: [TestCert] -> TestName -> TestName
showList :: [TestCert] -> TestName -> TestName
Show, TestCert -> TestCert -> Bool
(TestCert -> TestCert -> Bool)
-> (TestCert -> TestCert -> Bool) -> Eq TestCert
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestCert -> TestCert -> Bool
== :: TestCert -> TestCert -> Bool
$c/= :: TestCert -> TestCert -> Bool
/= :: TestCert -> TestCert -> Bool
Eq, (forall x. TestCert -> Rep TestCert x)
-> (forall x. Rep TestCert x -> TestCert) -> Generic TestCert
forall x. Rep TestCert x -> TestCert
forall x. TestCert -> Rep TestCert x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TestCert -> Rep TestCert x
from :: forall x. TestCert -> Rep TestCert x
$cto :: forall x. Rep TestCert x -> TestCert
to :: forall x. Rep TestCert x -> TestCert
Generic)

instance HasPerasCertRound TestCert where
  getPerasCertRound :: TestCert -> PerasRoundNo
getPerasCertRound = TestCert -> PerasRoundNo
tcRoundNo

-- | Generate a test certificate
--
-- NOTE: to improve the probabilities of covering all the paths in the code,
-- we generate certificates relative to a given Peras round (the current one).
genTestCert :: PerasRoundNo -> Gen TestCert
genTestCert :: PerasRoundNo -> Gen TestCert
genTestCert PerasRoundNo
roundNo = do
  arrivalTime <- NominalDiffTime -> RelativeTime
RelativeTime (NominalDiffTime -> RelativeTime)
-> Gen NominalDiffTime -> Gen RelativeTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen NominalDiffTime
genNominalDiffTime50Years
  offset <- choose @Integer (-10, 3)
  -- NOTE: here we need to be careful not to underflow the round number
  let roundNo' =
        Word64 -> PerasRoundNo
PerasRoundNo (Word64 -> PerasRoundNo) -> Word64 -> PerasRoundNo
forall a b. (a -> b) -> a -> b
$
          Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word64) -> Integer -> Word64
forall a b. (a -> b) -> a -> b
$
            Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
0 (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$
              Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (PerasRoundNo -> Word64
unPerasRoundNo PerasRoundNo
roundNo) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
offset
  pure $
    TestCert
      { tcArrivalTime = arrivalTime
      , tcRoundNo = roundNo'
      }

-- * Certificate and voting views

genLatestCertSeen :: PerasRoundNo -> Gen (LatestCertSeenView TestCert)
genLatestCertSeen :: PerasRoundNo -> Gen (LatestCertSeenView TestCert)
genLatestCertSeen PerasRoundNo
roundNo = do
  cert <- PerasRoundNo -> Gen TestCert
genTestCert PerasRoundNo
roundNo
  arrivalSlot <- genSlotNo
  roundStartSlot <- genSlotNo
  candidateBlockExtendsCert <- arbitrary
  pure
    LatestCertSeenView
      { lcsCert = cert
      , lcsArrivalSlot = arrivalSlot
      , lcsRoundStartSlot = roundStartSlot
      , lcsCandidateBlockExtendsCert = candidateBlockExtendsCert
      }

genLatestCertOnChain :: PerasRoundNo -> Gen (LatestCertOnChainView TestCert)
genLatestCertOnChain :: PerasRoundNo -> Gen (LatestCertOnChainView TestCert)
genLatestCertOnChain PerasRoundNo
roundNo = do
  cert <- PerasRoundNo -> Gen TestCert
genTestCert PerasRoundNo
roundNo
  pure $
    LatestCertOnChainView
      { lcocCert = cert
      }

genPerasVotingView :: Gen (PerasVotingView TestCert)
genPerasVotingView :: Gen (PerasVotingView TestCert)
genPerasVotingView = do
  perasParams <- Gen PerasParams
genPerasParams
  currRoundNo <- genPerasRoundNo
  latestCertSeen <- genWithOrigin (genLatestCertSeen currRoundNo)
  latestCertOnChain <- genWithOrigin (genLatestCertOnChain currRoundNo)
  pure
    PerasVotingView
      { perasParams
      , currRoundNo
      , latestCertSeen = latestCertSeen
      , latestCertOnChain = latestCertOnChain
      }
 where
  genWithOrigin :: Gen t -> Gen (WithOrigin t)
genWithOrigin Gen t
gen =
    [(Int, Gen (WithOrigin t))] -> Gen (WithOrigin t)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
      [ (Int
1, WithOrigin t -> Gen (WithOrigin t)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WithOrigin t
forall t. WithOrigin t
Origin)
      , (Int
9, t -> WithOrigin t
forall t. t -> WithOrigin t
NotOrigin (t -> WithOrigin t) -> Gen t -> Gen (WithOrigin t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen t
gen)
      ]