{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# 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 Data.Maybe (isJust)
import GHC.Generics (Generic)
import Ouroboros.Consensus.Block.Abstract
  ( Point (..)
  , SlotNo (..)
  , WithOrigin (..)
  )
import Ouroboros.Consensus.Block.SupportsPeras
  ( BoostedBlock
  , IsPerasCert (..)
  , PerasBlockMinSlots (..)
  , PerasCertArrivalThreshold (..)
  , PerasCooldownRounds (..)
  , PerasIgnoranceRounds (..)
  , PerasParams (..)
  , PerasRoundNo (..)
  , defaultPerasParams
  , onPerasRoundNo
  )
import Ouroboros.Consensus.BlockchainTime
  ( RelativeTime (..)
  )
import Ouroboros.Consensus.Peras.Voting.Rules
  ( PerasVotingRulesDecision (..)
  , isPerasVotingAllowed
  )
import Ouroboros.Consensus.Peras.Voting.View
  ( 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.Peras (genPointTestBlock)
import Test.Util.QuickCheck (geometric)
import Test.Util.TestBlock (TestBlock)
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 -> Maybe (Point TestBlock)
shouldVote :: Maybe (Point TestBlock)
  , 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 TestBlock ->
  PerasVotingRulesDecisionModel
isPerasVotingAllowedModel :: PerasVotingView TestCert TestBlock -> PerasVotingRulesDecisionModel
isPerasVotingAllowedModel
  PerasVotingView
    { PerasParams TestBlock
perasParams :: PerasParams TestBlock
perasParams :: forall cert blk. PerasVotingView cert blk -> PerasParams blk
perasParams
    , PerasRoundNo
currRoundNo :: PerasRoundNo
currRoundNo :: forall cert blk. PerasVotingView cert blk -> PerasRoundNo
currRoundNo
    , WithOrigin (LatestCertSeenView TestCert)
latestCertSeen :: WithOrigin (LatestCertSeenView TestCert)
latestCertSeen :: forall cert blk.
PerasVotingView cert blk -> WithOrigin (LatestCertSeenView cert)
latestCertSeen
    , WithOrigin PerasRoundNo
latestCertOnChainRound :: WithOrigin PerasRoundNo
latestCertOnChainRound :: forall cert blk.
PerasVotingView cert blk -> WithOrigin PerasRoundNo
latestCertOnChainRound
    , Point TestBlock
candidateBlock :: Point TestBlock
candidateBlock :: forall cert blk. PerasVotingView cert blk -> Point blk
candidateBlock
    } =
    PerasVotingDecisionModel
      { Maybe (Point TestBlock)
shouldVote :: Maybe (Point TestBlock)
shouldVote :: Maybe (Point TestBlock)
shouldVote
      , Bool
vr1a :: Bool
vr1a :: Bool
vr1a
      , Bool
vr1b :: Bool
vr1b :: Bool
vr1b
      , Bool
vr2a :: Bool
vr2a :: Bool
vr2a
      , Bool
vr2b :: Bool
vr2b :: Bool
vr2b
      }
   where
    shouldVote :: Maybe (Point TestBlock)
shouldVote
      | (Bool
vr1a Bool -> Bool -> Bool
&& Bool
vr1b) Bool -> Bool -> Bool
|| (Bool
vr2a Bool -> Bool -> Bool
&& Bool
vr2b) = Point TestBlock -> Maybe (Point TestBlock)
forall a. a -> Maybe a
Just Point TestBlock
candidateBlock
      | Bool
otherwise = Maybe (Point TestBlock)
forall a. Maybe a
Nothing

    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 blk. IsPerasCert cert blk => 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 blk. IsPerasCert cert blk => 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 PerasRoundNo
latestCertOnChainRound of
        NotOrigin PerasRoundNo
certRoundNo ->
          (PerasRoundNo
currRoundNo PerasRoundNo -> PerasRoundNo -> Bool
forall a. Ord a => a -> a -> Bool
> PerasRoundNo
certRoundNo)
            Bool -> Bool -> Bool
&& ( (PerasRoundNo
currRoundNo PerasRoundNo -> PerasRoundNo -> PerasRoundNo
`rmod` PerasRoundNo
_K)
                   PerasRoundNo -> PerasRoundNo -> Bool
forall a. Eq a => a -> a -> Bool
== (PerasRoundNo
certRoundNo PerasRoundNo -> PerasRoundNo -> PerasRoundNo
`rmod` PerasRoundNo
_K)
               )
        WithOrigin PerasRoundNo
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 TestBlock -> PerasCertArrivalThreshold
forall blk. PerasParams blk -> PerasCertArrivalThreshold
perasCertArrivalThreshold (PerasParams TestBlock -> PerasCertArrivalThreshold)
-> PerasParams TestBlock -> PerasCertArrivalThreshold
forall a b. (a -> b) -> a -> b
$
            PerasParams TestBlock
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 TestBlock -> PerasIgnoranceRounds
forall blk. PerasParams blk -> PerasIgnoranceRounds
perasIgnoranceRounds (PerasParams TestBlock -> PerasIgnoranceRounds)
-> PerasParams TestBlock -> PerasIgnoranceRounds
forall a b. (a -> b) -> a -> b
$
            PerasParams TestBlock
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 TestBlock -> PerasCooldownRounds
forall blk. PerasParams blk -> PerasCooldownRounds
perasCooldownRounds (PerasParams TestBlock -> PerasCooldownRounds)
-> PerasParams TestBlock -> PerasCooldownRounds
forall a b. (a -> b) -> a -> b
$
            PerasParams TestBlock
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 TestBlock)
-> (PerasVotingView TestCert TestBlock -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (PerasVotingView TestCert TestBlock)
genPerasVotingView ((PerasVotingView TestCert TestBlock -> Property) -> Property)
-> (PerasVotingView TestCert TestBlock -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \PerasVotingView TestCert TestBlock
pvv -> do
  -- Determine whether we should vote according to the model
  let PerasVotingDecisionModel{Maybe (Point TestBlock)
shouldVote :: PerasVotingRulesDecisionModel -> Maybe (Point TestBlock)
shouldVote :: Maybe (Point TestBlock)
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 TestBlock -> PerasVotingRulesDecisionModel
isPerasVotingAllowedModel PerasVotingView TestCert TestBlock
pvv
  -- Some helper functions to report success/failure
  let chain :: [t -> t] -> t -> t
chain = (t -> [t -> t] -> t) -> [t -> t] -> t -> t
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((t -> t) -> t -> t) -> t -> [t -> t] -> t
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (t -> t) -> t -> t
forall a b. (a -> b) -> a -> b
($)) ([t -> t] -> t -> t)
-> ([t -> t] -> [t -> t]) -> [t -> t] -> t -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [t -> t] -> [t -> t]
forall a. [a] -> [a]
reverse
  let ok :: TestName -> Property
ok TestName
desc =
        [Property -> Property] -> Property -> Property
forall {t}. [t -> t] -> t -> t
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 (Maybe (Point TestBlock) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Point TestBlock)
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 TestBlock
votingDecision = PerasVotingView TestCert TestBlock
-> PerasVotingRulesDecision TestBlock
forall cert blk.
IsPerasCert cert blk =>
PerasVotingView cert blk -> PerasVotingRulesDecision blk
isPerasVotingAllowed PerasVotingView TestCert TestBlock
pvv
  case PerasVotingRulesDecision TestBlock
votingDecision of
    Vote (ETrue Pred PerasVotingRule
voteReason) Point TestBlock
actualCandidate
      | Just Point TestBlock
expectedCandidate <- Maybe (Point TestBlock)
shouldVote ->
          if Point TestBlock
expectedCandidate Point TestBlock -> Point TestBlock -> Bool
forall a. Eq a => a -> a -> Bool
== Point TestBlock
actualCandidate
            then
              TestName -> Property
ok (TestName -> Property) -> TestName -> Property
forall a b. (a -> b) -> a -> b
$ TestName
"Vote(Point{..}," 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
")"
            else
              TestName -> Property
failure (TestName -> Property) -> TestName -> Property
forall a b. (a -> b) -> a -> b
$
                TestName
"Expected to vote for "
                  TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> Point TestBlock -> TestName
forall a. Show a => a -> TestName
show Point TestBlock
expectedCandidate
                  TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> TestName
", but got: "
                  TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> Point TestBlock -> TestName
forall a. Show a => a -> TestName
show Point TestBlock
actualCandidate
      | 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 TestBlock -> TestName
forall a. Show a => a -> TestName
show PerasVotingRulesDecision TestBlock
votingDecision
    NoVote (EFalse Pred PerasVotingRule
noVoteReason)
      | Maybe (Point TestBlock)
Nothing <- Maybe (Point TestBlock)
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 TestBlock -> TestName
forall a. Show a => a -> TestName
show PerasVotingRulesDecision TestBlock
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 blk)
genPerasParams :: forall blk. Gen (PerasParams blk)
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
    defaultPerasParams
      { 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)

type instance BoostedBlock (TestCert) = Point TestBlock

instance IsPerasCert TestCert TestBlock where
  getPerasCertRound :: TestCert -> PerasRoundNo
getPerasCertRound = TestCert -> PerasRoundNo
tcRoundNo

  -- We don't really care about the block being boosted for the voting rules
  getPerasCertBlock :: TestCert -> BoostedBlock TestCert
getPerasCertBlock = Point TestBlock -> TestCert -> Point TestBlock
forall a b. a -> b -> a
const Point TestBlock
forall {k} (block :: k). Point block
GenesisPoint

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

genLatestCertSeenView :: PerasRoundNo -> Gen (LatestCertSeenView TestCert)
genLatestCertSeenView :: PerasRoundNo -> Gen (LatestCertSeenView TestCert)
genLatestCertSeenView 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
      }

genLatestCertOnChainRound :: PerasRoundNo -> Gen PerasRoundNo
genLatestCertOnChainRound :: PerasRoundNo -> Gen PerasRoundNo
genLatestCertOnChainRound PerasRoundNo
roundNo = do
  cert <- PerasRoundNo -> Gen TestCert
genTestCert PerasRoundNo
roundNo
  pure (getPerasCertRound cert)

genPerasVotingView :: Gen (PerasVotingView TestCert TestBlock)
genPerasVotingView :: Gen (PerasVotingView TestCert TestBlock)
genPerasVotingView = do
  perasParams <- Gen (PerasParams TestBlock)
forall blk. Gen (PerasParams blk)
genPerasParams
  currRoundNo <- genPerasRoundNo
  latestCertSeen <- genWithOrigin (genLatestCertSeenView currRoundNo)
  latestCertOnChainRound <- genWithOrigin (genLatestCertOnChainRound currRoundNo)
  candidateBlock <- genPointTestBlock
  pure
    PerasVotingView
      { perasParams
      , currRoundNo
      , latestCertSeen
      , latestCertOnChainRound
      , candidateBlock
      }
 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)
      ]