{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | Tests of the node relaying announcements and votes, against peers run by
-- the Leios node-vs-environment tests.
--
-- Every peer both sends the node a schedule of notifications and records what
-- the node relays to it. The node relays a vote only once it has checked it
-- against the committee, and only after relaying the announcement it is for,
-- since a peer disconnects a peer that votes for an announcement it never sent.
module Test.Consensus.Leios.Relay (tests) where

import Cardano.Crypto.DSIGN.Class (signDSIGN, verifyDSIGN)
import Cardano.Crypto.Hash (Hash (UnsafeHash))
import Cardano.Crypto.Leios
  ( LeiosCommittee
  , LeiosSeat (..)
  , LeiosSeatId (..)
  , LeiosSigningKey
  , leiosCommitteeSize
  , leiosSignContext
  , resolveLeiosSeat
  )
import Cardano.Ledger.BaseTypes (Milliseconds32 (..), knownNonZeroBounded)
import Control.Concurrent.Class.MonadSTM.Strict
  ( STM
  , StrictTQueue
  , StrictTVar
  , atomically
  , modifyTVar
  , newTQueueIO
  , newTVarIO
  , orElse
  , readTQueue
  , readTVarIO
  , writeTQueue
  )
import Control.Monad (replicateM)
import Control.Monad.Class.MonadAsync (forConcurrently, withAsync)
import Control.Monad.Class.MonadTime.SI (DiffTime, Time (..), getMonotonicTime)
import Control.Monad.Class.MonadTimer.SI (threadDelay)
import Control.Monad.IOSim (IOSim, runSimOrThrow)
import Control.Tracer (mkTracer, nullTracer)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Short as SBS
import Data.Either (isRight)
import Data.Foldable (for_, toList)
import qualified Data.Foldable as Foldable
import Data.List (isInfixOf, mapAccumL, sortOn)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe, maybeToList)
import Data.Maybe.Strict (StrictMaybe (..))
import Data.Proxy (Proxy (..))
import Data.Ratio ((%))
import qualified Data.Set as Set
import Data.Time.Clock (NominalDiffTime)
import Data.Void (Void)
import Data.Word (Word16)
import Ouroboros.Consensus.Block (Header, SlotNo (..), blockHash, blockSlot)
import Ouroboros.Consensus.BlockchainTime (slotLengthFromSec)
import Ouroboros.Consensus.BlockchainTime.WallClock.Types (RelativeTime (..), addRelTime)
import Ouroboros.Consensus.Config (SecurityParam (..), TopLevelConfig)
import qualified Ouroboros.Consensus.HardFork.History as HardFork
import Ouroboros.Consensus.Leios.AnnounceState
  ( newAnnounceState
  , onValidAnnouncement
  , pruneAnnounceState
  )
import Ouroboros.Consensus.Leios.NotifyLog
  ( NotifyLog
  , appendNotifyLog
  , newNotifyLog
  , nextNotifyLog
  , notifyLogPruneCadence
  , notifyLogStart
  , pruneNotifyLog
  )
import qualified Ouroboros.Consensus.Leios.NotifyLog as NotifyLog
import Ouroboros.Consensus.Leios.Protocol (LeiosLedgerView (..), OCINStaleness (FreshOCIN))
import Ouroboros.Consensus.Leios.Types
  ( LeiosPoint
  , LeiosVote (..)
  , RankingBlockHash
  , milliseconds32ToNominalDiffTime
  , toRankingBlockHash
  )
import Ouroboros.Consensus.Leios.VoteState (TraceLeiosVoteState (..))
import Ouroboros.Consensus.MiniProtocol.LeiosNotify.Client
  ( leiosNotifyClientPeerPipelined
  , toLeiosNotifyClientPeerPipelined
  )
import qualified Ouroboros.Consensus.MiniProtocol.LeiosNotify.Client.Announcements as Announcements
import Ouroboros.Consensus.MiniProtocol.LeiosNotify.Client.Announcements.Validation
  ( AnnouncingHeader (ancElectionId)
  , ValidAnnouncement (..)
  , maxAnnouncementAgeRecv
  , maxAnnouncementAgeSend
  , mkAnnouncingHeader
  )
import Ouroboros.Consensus.MiniProtocol.LeiosNotify.Client.State
  ( VoteWindow (..)
  , leiosVoteWindow
  , voteLateGrace
  )
import Ouroboros.Consensus.MiniProtocol.LeiosNotify.Server
  ( WhetherExcessiveRequests (..)
  , leiosNotifyServerPeerLookahead
  )
import Ouroboros.Consensus.MiniProtocol.LeiosNotify.Type
  ( LeiosNotify (..)
  , Message (..)
  , byteLimitsLeiosNotify
  , timeLimitsLeiosNotify
  )
import Ouroboros.Consensus.Network.LeiosNotify
  ( leiosNotifyMiniProtocolNum
  , leiosNotifyPipelineDepth
  , runLookaheadFixedSenderPeerWithLimits
  )
import Ouroboros.Consensus.Node.Tracers (Tracers' (..), nullTracers)
import Ouroboros.Consensus.Storage.LeiosDB (newLeiosDBInMemory)
import Ouroboros.Network.Channel (Channel)
import Ouroboros.Network.Driver.Limits (runPipelinedPeerWithLimits)
import Ouroboros.Network.Protocol.Limits (ProtocolSizeLimits)
import Test.Cardano.Crypto.Leios.Gen (TestSeatType (..), mkCommitteeFromTestSeats)
import Test.Consensus.Leios.Environment
  ( EnvPeer (..)
  , LeiosNotifyCodec
  , NodeVsEnvConnection (..)
  , envLeiosNotifyCodec
  , refusingLeiosFetchServer
  , withNodeVsEnvConnection
  )
import Test.Consensus.Leios.NodeUnderTest
  ( Blk
  , NodeUnderTest
  , PeerAddr (..)
  , defaultNodeUnderTestConfig
  , withNodeUnderTest
  )
import Test.Consensus.Leios.TestBlock
  ( LeiosTestBlock (..)
  , LeiosTestLedgerConfig (..)
  , firstLeiosBlock
  , forkLeiosBlock
  , setAnnouncement
  , setCounterBelowImmTips
  , setSlot
  , singleNodeLeiosTestConfig
  )
import Test.QuickCheck
  ( Gen
  , Property
  , choose
  , conjoin
  , counterexample
  , cover
  , elements
  , forAllShow
  , frequency
  , once
  , oneof
  , property
  , sublistOf
  , (===)
  )
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))
import Test.Tasty.QuickCheck (testProperty)
import Test.Util.ChainDB (emptyNodeDBs)

tests :: TestTree
tests :: TestTree
tests =
  [Char] -> [TestTree] -> TestTree
testGroup
    [Char]
"Relay"
    [ [Char] -> Assertion -> TestTree
testCase [Char]
"the node relays an announcement to a peer" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
        down <- DiffTime -> [[(DiffTime, Notification)]] -> IO PeerOutcome
relayToOne DiffTime
0 [[LeiosTestBlock -> (DiffTime, Notification)
announce LeiosTestBlock
someAnnouncingBlock]]
        announcements down @?= [ltbHeader someAnnouncingBlock]
    , [Char] -> Assertion -> TestTree
testCase [Char]
"the node relays an announcement it hears from two peers once" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
        down <- DiffTime -> [[(DiffTime, Notification)]] -> IO PeerOutcome
relayToOne DiffTime
0 [[LeiosTestBlock -> (DiffTime, Notification)
announce LeiosTestBlock
someAnnouncingBlock], [LeiosTestBlock -> (DiffTime, Notification)
announce LeiosTestBlock
someAnnouncingBlock]]
        announcements down @?= [ltbHeader someAnnouncingBlock]
    , [Char] -> Assertion -> TestTree
testCase [Char]
"the node relays both announcements of an election, but no third" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
        down <-
          DiffTime -> [[(DiffTime, Notification)]] -> IO PeerOutcome
relayToOne
            DiffTime
0
            [[LeiosTestBlock -> (DiffTime, Notification)
announce LeiosTestBlock
someAnnouncingBlock, LeiosTestBlock -> (DiffTime, Notification)
announce LeiosTestBlock
equivocation], [DiffTime -> LeiosTestBlock -> (DiffTime, Notification)
announceAt DiffTime
1 LeiosTestBlock
thirdAnnouncement]]
        announcements down @?= map ltbHeader [someAnnouncingBlock, equivocation]
    , [Char] -> Assertion -> TestTree
testCase [Char]
"the node does not relay an announcement too old to relay" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
        -- connecting late, since a connection without KeepAlive times out
        (_, downs) <-
          DiffTime
-> [PeerSpec] -> [DiffTime] -> IO ([PeerOutcome], [PeerOutcome])
relayPeers
            DiffTime
400
            [DiffTime -> [(DiffTime, Notification)] -> PeerSpec
PeerSpec DiffTime
340 [DiffTime -> LeiosTestBlock -> (DiffTime, Notification)
announceAt DiffTime
350 LeiosTestBlock
someAnnouncingBlock, DiffTime -> LeiosTestBlock -> (DiffTime, Notification)
announceAt DiffTime
350 LeiosTestBlock
lateAnnouncingBlock]]
            [DiffTime
340]
        map announcements downs @?= [[ltbHeader lateAnnouncingBlock]]
    , [Char] -> Assertion -> TestTree
testCase [Char]
"the node does not relay an announcement of a revoked operational certificate" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
        down <- DiffTime -> [[(DiffTime, Notification)]] -> IO PeerOutcome
relayToOne DiffTime
0 [[LeiosTestBlock -> (DiffTime, Notification)
announce (LeiosTestBlock -> LeiosTestBlock
setCounterBelowImmTips LeiosTestBlock
someAnnouncingBlock)]]
        announcements down @?= []
    , [Char] -> Assertion -> TestTree
testCase [Char]
"a peer that connects later receives the announcement, until it is too old to relay" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
        (_, downs) <- DiffTime
-> [[(DiffTime, Notification)]]
-> [DiffTime]
-> IO ([PeerOutcome], [PeerOutcome])
relay DiffTime
400 [[LeiosTestBlock -> (DiffTime, Notification)
announce LeiosTestBlock
someAnnouncingBlock]] [DiffTime
0, DiffTime
10, DiffTime
350]
        map announcements downs @?= [[ltbHeader someAnnouncingBlock], [ltbHeader someAnnouncingBlock], []]
    , [Char] -> Assertion -> TestTree
testCase [Char]
"the node does not relay an announcement of an election pruned while validating it" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        [()]
prunedWhileValidating [()] -> [()] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= []
    , [Char] -> Assertion -> TestTree
testCase [Char]
"a vote is relayed no longer than its announcement, however long its diffusion period" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        VoteWindow -> RelativeTime
voteUntil
          (LeiosLedgerView -> RelativeTime -> VoteWindow
leiosVoteWindow LeiosLedgerView
leiosLedgerView{llvDiffusionPeriod = Milliseconds32 1000000} (NominalDiffTime -> RelativeTime
RelativeTime NominalDiffTime
1))
          RelativeTime -> RelativeTime -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= NominalDiffTime -> RelativeTime -> RelativeTime
addRelTime NominalDiffTime
maxAnnouncementAgeSend (NominalDiffTime -> RelativeTime
RelativeTime NominalDiffTime
1)
    , [Char] -> Assertion -> TestTree
testCase [Char]
"the log prunes each notification once it is no longer worth relaying" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        [(NominalDiffTime, Char)] -> NominalDiffTime -> [Char]
notifyLogAt [(NominalDiffTime
9, Char
'a'), (NominalDiffTime
300, Char
'b'), (NominalDiffTime
5, Char
'c')] NominalDiffTime
6 [Char] -> [Char] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= [Char]
"ab"
    , [Char] -> Assertion -> TestTree
testCase [Char]
"the log does not take a notification it was pruned past already" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        NominalDiffTime -> [(NominalDiffTime, Char)] -> [Char]
notifyLogPrunedAt NominalDiffTime
6 [(NominalDiffTime
9, Char
'a'), (NominalDiffTime
5, Char
'c'), (NominalDiffTime
6, Char
'd')] [Char] -> [Char] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= [Char]
"ad"
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty
        [Char]
"the log is pruned far more often than a downstream peer's grace"
        Property
prop_notifyLogPruneCadence
    , [Char] -> Assertion -> TestTree
testCase [Char]
"the node relays a vote to every other peer, after the announcement it is for" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
        (_, downs) <- DiffTime
-> [[(DiffTime, Notification)]]
-> [DiffTime]
-> IO ([PeerOutcome], [PeerOutcome])
relay DiffTime
20 [[(DiffTime, Notification)]
votedFor0] [DiffTime
0, DiffTime
0]
        for_ downs $ \PeerOutcome
down -> PeerOutcome -> [LeiosVote]
votes PeerOutcome
down [LeiosVote] -> [LeiosVote] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= [LeiosTestBlock -> Word16 -> LeiosVote
voteOf LeiosTestBlock
someAnnouncingBlock Word16
0]
    , [Char] -> Assertion -> TestTree
testCase [Char]
"the node relays a vote promptly" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
        down <- DiffTime -> [[(DiffTime, Notification)]] -> IO PeerOutcome
relayToOne DiffTime
0 [[(DiffTime, Notification)]
votedFor0]
        assertBool ("relayed at " <> show (voteTimes down)) $
          not (null (voteTimes down)) && all (<= Time 6) (voteTimes down)
    , [Char] -> Assertion -> TestTree
testCase [Char]
"the node relays a vote it hears from two peers once" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
        down <- DiffTime -> [[(DiffTime, Notification)]] -> IO PeerOutcome
relayToOne DiffTime
0 [[(DiffTime, Notification)]
votedFor0, [LeiosTestBlock -> (DiffTime, Notification)
announce LeiosTestBlock
someAnnouncingBlock, (DiffTime
5.5, LeiosTestBlock -> Word16 -> Notification
vote LeiosTestBlock
someAnnouncingBlock Word16
0)]]
        votes down @?= [voteOf someAnnouncingBlock 0]
    , [Char] -> Assertion -> TestTree
testCase [Char]
"the node relays only the first vote of a seat in an election" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
        down <- DiffTime -> [[(DiffTime, Notification)]] -> IO PeerOutcome
relayToOne DiffTime
0 [[(DiffTime, Notification)]
votedFor0, [LeiosTestBlock -> (DiffTime, Notification)
announce LeiosTestBlock
equivocation, (DiffTime
5.5, LeiosTestBlock -> Word16 -> Notification
vote LeiosTestBlock
equivocation Word16
0)]]
        votes down @?= [voteOf someAnnouncingBlock 0]
    , [Char] -> Assertion -> TestTree
testCase [Char]
"the node disconnects a peer that sends a badly signed vote, and does not relay it" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
        (ups, downs) <- DiffTime
-> [[(DiffTime, Notification)]]
-> [DiffTime]
-> IO ([PeerOutcome], [PeerOutcome])
relay DiffTime
20 ([[(DiffTime, Notification)]] -> [[(DiffTime, Notification)]]
withControl [[(DiffTime
5, LeiosTestBlock -> Word16 -> Notification
badlySignedVote LeiosTestBlock
someAnnouncingBlock Word16
0)]]) [DiffTime
0]
        concatMap votes downs @?= [control]
        map invalidVoteDisconnected ups @?= [True, False]
    , [Char] -> Assertion -> TestTree
testCase [Char]
"the node disconnects a peer that sends a vote from a seat outside the committee" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
        (ups, downs) <-
          DiffTime
-> [[(DiffTime, Notification)]]
-> [DiffTime]
-> IO ([PeerOutcome], [PeerOutcome])
relay DiffTime
20 ([[(DiffTime, Notification)]] -> [[(DiffTime, Notification)]]
withControl [[(DiffTime
5, LeiosTestBlock -> Word16 -> Notification
badlySignedVote LeiosTestBlock
someAnnouncingBlock Word16
seatOutside)]]) [DiffTime
0]
        concatMap votes downs @?= [control]
        map invalidVoteDisconnected ups @?= [True, False]
    , [Char] -> Assertion -> TestTree
testCase [Char]
"the node disconnects a peer that sends a vote from a seat without a key" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
        (ups, downs) <-
          DiffTime
-> [[(DiffTime, Notification)]]
-> [DiffTime]
-> IO ([PeerOutcome], [PeerOutcome])
relay
            DiffTime
20
            ( [[(DiffTime, Notification)]] -> [[(DiffTime, Notification)]]
withControl
                [[(DiffTime
5, LeiosTestBlock -> Word16 -> Notification
vote LeiosTestBlock
someAnnouncingBlock Word16
seatNoKey)], [(DiffTime
5, LeiosTestBlock -> Word16 -> Notification
vote LeiosTestBlock
someAnnouncingBlock Word16
seatBadPoP)]]
            )
            [DiffTime
0]
        concatMap votes downs @?= [control]
        map invalidVoteDisconnected ups @?= [True, True, False]
    , [Char] -> Assertion -> TestTree
testCase [Char]
"the node does not verify a vote of a seat it already has a vote of" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
        (ups, downs) <-
          DiffTime
-> [[(DiffTime, Notification)]]
-> [DiffTime]
-> IO ([PeerOutcome], [PeerOutcome])
relay
            DiffTime
20
            [[(DiffTime, Notification)]
votedFor0, [LeiosTestBlock -> (DiffTime, Notification)
announce LeiosTestBlock
someAnnouncingBlock, (DiffTime
5.5, LeiosTestBlock -> Word16 -> Notification
badlySignedVote LeiosTestBlock
someAnnouncingBlock Word16
0)]]
            [DiffTime
0]
        concatMap votes downs @?= [voteOf someAnnouncingBlock 0]
        map poNodeClientEnded ups @?= [Nothing, Nothing]
    , [Char] -> Assertion -> TestTree
testCase [Char]
"the node does not relay a vote for an announcement it did not relay" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
        down <-
          DiffTime -> [[(DiffTime, Notification)]] -> IO PeerOutcome
relayToOne
            DiffTime
0
            ( [[(DiffTime, Notification)]] -> [[(DiffTime, Notification)]]
withControl
                [[LeiosTestBlock -> (DiffTime, Notification)
announce LeiosTestBlock
equivocation], [DiffTime -> LeiosTestBlock -> (DiffTime, Notification)
announceAt DiffTime
1 LeiosTestBlock
thirdAnnouncement, (DiffTime
5, LeiosTestBlock -> Word16 -> Notification
vote LeiosTestBlock
thirdAnnouncement Word16
0)]]
            )
        votes down @?= [control]
    , [Char] -> Assertion -> TestTree
testCase [Char]
"the node relays a vote that arrives after its voting period, within its diffusion period" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
        -- Voting ends 8 s in, and diffusion 9 s in.
        down <- DiffTime -> [[(DiffTime, Notification)]] -> IO PeerOutcome
relayToOne DiffTime
0 [[LeiosTestBlock -> (DiffTime, Notification)
announce LeiosTestBlock
someAnnouncingBlock, (DiffTime
8.5, LeiosTestBlock -> Word16 -> Notification
vote LeiosTestBlock
someAnnouncingBlock Word16
0)]]
        votes down @?= [voteOf someAnnouncingBlock 0]
    , [Char] -> Assertion -> TestTree
testCase [Char]
"the node accepts a vote late within the grace, but does not relay it" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
        -- Diffusion ends 9 s in; the client accepts the vote until 69 s in.
        (ups, downs) <- DiffTime
-> [[(DiffTime, Notification)]]
-> [DiffTime]
-> IO ([PeerOutcome], [PeerOutcome])
relay DiffTime
70 ([[(DiffTime, Notification)]] -> [[(DiffTime, Notification)]]
withControl [[(DiffTime
68.5, LeiosTestBlock -> Word16 -> Notification
vote LeiosTestBlock
someAnnouncingBlock Word16
0)]]) [DiffTime
0]
        concatMap votes downs @?= [control]
        map poNodeClientEnded ups @?= [Nothing, Nothing]
    , [Char] -> Assertion -> TestTree
testCase [Char]
"the node accepts a vote early within the clock skew, but relays it once its window opens" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
        -- The window opens 4 s in; the client accepts the vote from 2 s in.
        (ups, downs) <- DiffTime
-> [[(DiffTime, Notification)]]
-> [DiffTime]
-> IO ([PeerOutcome], [PeerOutcome])
relay DiffTime
20 [[LeiosTestBlock -> (DiffTime, Notification)
announce LeiosTestBlock
someAnnouncingBlock, (DiffTime
2.5, LeiosTestBlock -> Word16 -> Notification
vote LeiosTestBlock
someAnnouncingBlock Word16
0)]] [DiffTime
0]
        map votes downs @?= [[voteOf someAnnouncingBlock 0]]
        map voteTimes downs @?= [[Time 4]]
        map poNodeClientEnded ups @?= [Nothing]
    , [Char] -> Assertion -> TestTree
testCase [Char]
"the node relays the early votes of a message once their window opens" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
        let early :: NonEmpty LeiosVote
early = LeiosTestBlock -> Word16 -> LeiosVote
voteOf LeiosTestBlock
someAnnouncingBlock Word16
0 LeiosVote -> [LeiosVote] -> NonEmpty LeiosVote
forall a. a -> [a] -> NonEmpty a
:| (Word16 -> LeiosVote) -> [Word16] -> [LeiosVote]
forall a b. (a -> b) -> [a] -> [b]
map (LeiosTestBlock -> Word16 -> LeiosVote
voteOf LeiosTestBlock
someAnnouncingBlock) [Word16
1, Word16
2]
        down <- DiffTime -> [[(DiffTime, Notification)]] -> IO PeerOutcome
relayToOne DiffTime
0 [[LeiosTestBlock -> (DiffTime, Notification)
announce LeiosTestBlock
someAnnouncingBlock, (DiffTime
2.5, NonEmpty LeiosVote -> Notification
NotifyVotes NonEmpty LeiosVote
early)]]
        votes down @?= toList early
        voteTimes down @?= map (const (Time 4)) (toList early)
    , [Char] -> Assertion -> TestTree
testCase [Char]
"a peer that connects during a vote's window receives the vote" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
        down <- DiffTime -> [[(DiffTime, Notification)]] -> IO PeerOutcome
relayToOne DiffTime
6 [[(DiffTime, Notification)]
votedFor0]
        votes down @?= [voteOf someAnnouncingBlock 0]
    , [Char] -> Assertion -> TestTree
testCase [Char]
"a peer that connects once a peer would reject the vote does not receive it" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
        (_, downs) <- DiffTime
-> [[(DiffTime, Notification)]]
-> [DiffTime]
-> IO ([PeerOutcome], [PeerOutcome])
relay DiffTime
100 [[(DiffTime, Notification)]
votedFor0] [DiffTime
0, DiffTime
90]
        map votes downs @?= [[voteOf someAnnouncingBlock 0], []]
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty
        [Char]
"the node relays the first valid vote of each seat it has by its deadline, no later than the log is pruned past it, and only what a peer accepts"
        (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ Gen VotingPeers
-> (VotingPeers -> [Char]) -> (VotingPeers -> Property) -> Property
forall prop a.
Testable prop =>
Gen a -> (a -> [Char]) -> (a -> prop) -> Property
forAllShow Gen VotingPeers
genVotingPeers VotingPeers -> [Char]
showVotingPeers VotingPeers -> Property
prop_relay
    ]
 where
  -- Seat 0 votes for 'someAnnouncingBlock' 5 seconds in, a second into its
  -- election's window.
  votedFor0 :: [(DiffTime, Notification)]
votedFor0 = [LeiosTestBlock -> (DiffTime, Notification)
announce LeiosTestBlock
someAnnouncingBlock, (DiffTime
5, LeiosTestBlock -> Word16 -> Notification
vote LeiosTestBlock
someAnnouncingBlock Word16
0)]

  -- Peers that announce 'someAnnouncingBlock' and send what a test expects the
  -- node to hold back, and a last one that sends a valid vote, so that the test
  -- cannot pass merely because the node relays nothing.
  withControl :: [[(DiffTime, Notification)]] -> [[(DiffTime, Notification)]]
withControl [[(DiffTime, Notification)]]
peers =
    ([(DiffTime, Notification)] -> [(DiffTime, Notification)])
-> [[(DiffTime, Notification)]] -> [[(DiffTime, Notification)]]
forall a b. (a -> b) -> [a] -> [b]
map (LeiosTestBlock -> (DiffTime, Notification)
announce LeiosTestBlock
someAnnouncingBlock (DiffTime, Notification)
-> [(DiffTime, Notification)] -> [(DiffTime, Notification)]
forall a. a -> [a] -> [a]
:) [[(DiffTime, Notification)]]
peers
      [[(DiffTime, Notification)]]
-> [[(DiffTime, Notification)]] -> [[(DiffTime, Notification)]]
forall a. Semigroup a => a -> a -> a
<> [[LeiosTestBlock -> (DiffTime, Notification)
announce LeiosTestBlock
someAnnouncingBlock, (DiffTime
6, LeiosTestBlock -> Word16 -> Notification
vote LeiosTestBlock
someAnnouncingBlock Word16
1)]]
  control :: LeiosVote
control = LeiosTestBlock -> Word16 -> LeiosVote
voteOf LeiosTestBlock
someAnnouncingBlock Word16
1

-- | Whether the node's client disconnected the peer for an invalid vote.
invalidVoteDisconnected :: PeerOutcome -> Bool
invalidVoteDisconnected :: PeerOutcome -> Bool
invalidVoteDisconnected PeerOutcome
o = Bool -> ([Char] -> Bool) -> Maybe [Char] -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ([Char]
"ExnLeiosInvalidVote" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf`) (PeerOutcome -> Maybe [Char]
poNodeClientEnded PeerOutcome
o)

{-------------------------------------------------------------------------------
  The property
-------------------------------------------------------------------------------}

-- | Upstream peers, which each announce, then vote, as the node's client
-- requires of them: only for announcements they sent, at most once per seat in
-- an election, within the window. A last peer only listens.
data VotingPeers = VotingPeers
  { VotingPeers -> [[(DiffTime, Notification)]]
honestPeers :: [[(DiffTime, Notification)]]
  -- ^ Peers that send only valid votes.
  , VotingPeers -> Maybe [(DiffTime, Notification)]
invalidPeer :: Maybe [(DiffTime, Notification)]
  -- ^ A peer that sends only invalid votes.
  , VotingPeers -> DiffTime
nodeVerifying :: DiffTime
  -- ^ How long the node takes to verify a vote.
  }

genVotingPeers :: Gen VotingPeers
genVotingPeers :: Gen VotingPeers
genVotingPeers = do
  n <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
3)
  VotingPeers
    <$> replicateM n (genUpstream [0 .. seatNoKey - 1] vote)
    <*> oneof [pure Nothing, Just <$> genUpstream [0 .. seatOutside] invalidVote]
    <*> (realToFrac <$> choose (0, 1 :: Double))
 where
  genUpstream :: [t]
-> (LeiosTestBlock -> t -> Notification)
-> Gen [(DiffTime, Notification)]
genUpstream [t]
seats LeiosTestBlock -> t -> Notification
signed = do
    blks <- [[LeiosTestBlock]] -> Gen [LeiosTestBlock]
forall a. HasCallStack => [a] -> Gen a
elements [[LeiosTestBlock
someAnnouncingBlock], [LeiosTestBlock
equivocation], [LeiosTestBlock
someAnnouncingBlock, LeiosTestBlock
equivocation]]
    -- Both blocks are in one election, so a seat votes for one of them.
    voters <- sublistOf seats
    vs <- mapM (genVote blks signed) voters
    pure $ map announce blks <> sortOn fst vs
  genVote :: [t] -> (t -> t -> b) -> t -> Gen (a, b)
genVote [t]
blks t -> t -> b
signed t
seat = do
    blk <- [t] -> Gen t
forall a. HasCallStack => [a] -> Gen a
elements [t]
blks
    -- From as early as the clock skew lets the node's client accept, until
    -- the deadline, often within the verifying time of it.
    at <-
      realToFrac
        <$> frequency [(3, choose (2.1 :: Double, 8.99)), (1, choose (8, 8.99))]
    pure (at, signed blk seat)
  -- A seat without a key cannot sign validly, and others sign with a wrong key.
  invalidVote :: LeiosTestBlock -> Word16 -> Notification
invalidVote LeiosTestBlock
blk Word16
seat
    | Word16
seat Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
seatNoKey Bool -> Bool -> Bool
|| Word16
seat Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
seatBadPoP = LeiosTestBlock -> Word16 -> Notification
vote LeiosTestBlock
blk Word16
seat
    | Bool
otherwise = LeiosTestBlock -> Word16 -> Notification
badlySignedVote LeiosTestBlock
blk Word16
seat

allPeers :: VotingPeers -> [[(DiffTime, Notification)]]
allPeers :: VotingPeers -> [[(DiffTime, Notification)]]
allPeers VotingPeers{[[(DiffTime, Notification)]]
honestPeers :: VotingPeers -> [[(DiffTime, Notification)]]
honestPeers :: [[(DiffTime, Notification)]]
honestPeers, Maybe [(DiffTime, Notification)]
invalidPeer :: VotingPeers -> Maybe [(DiffTime, Notification)]
invalidPeer :: Maybe [(DiffTime, Notification)]
invalidPeer} = [[(DiffTime, Notification)]]
honestPeers [[(DiffTime, Notification)]]
-> [[(DiffTime, Notification)]] -> [[(DiffTime, Notification)]]
forall a. Semigroup a => a -> a -> a
<> Maybe [(DiffTime, Notification)] -> [[(DiffTime, Notification)]]
forall a. Maybe a -> [a]
maybeToList Maybe [(DiffTime, Notification)]
invalidPeer

showVotingPeers :: VotingPeers -> String
showVotingPeers :: VotingPeers -> [Char]
showVotingPeers VotingPeers
peers =
  [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
    ([(DiffTime, Notification)] -> [Char])
-> [[(DiffTime, Notification)]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [(DiffTime, Notification)] -> [Char]
showPeer (VotingPeers -> [[(DiffTime, Notification)]]
honestPeers VotingPeers
peers)
      [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]
"invalid: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [(DiffTime, Notification)] -> [Char]
showPeer [(DiffTime, Notification)]
p | [(DiffTime, Notification)]
p <- Maybe [(DiffTime, Notification)] -> [[(DiffTime, Notification)]]
forall a. Maybe a -> [a]
maybeToList (VotingPeers -> Maybe [(DiffTime, Notification)]
invalidPeer VotingPeers
peers)]
      [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]
"verifying: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> DiffTime -> [Char]
forall a. Show a => a -> [Char]
show (VotingPeers -> DiffTime
nodeVerifying VotingPeers
peers)]
 where
  showPeer :: [(DiffTime, Notification)] -> [Char]
showPeer = [[Char]] -> [Char]
unwords ([[Char]] -> [Char])
-> ([(DiffTime, Notification)] -> [[Char]])
-> [(DiffTime, Notification)]
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((DiffTime, Notification) -> [Char])
-> [(DiffTime, Notification)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (DiffTime, Notification) -> [Char]
forall {a}. Show a => (a, Notification) -> [Char]
showSend
  showSend :: (a, Notification) -> [Char]
showSend (a
at, Notification
n) = a -> [Char]
forall a. Show a => a -> [Char]
show a
at [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
":" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Notification -> [Char]
showNotification Notification
n

prop_relay :: VotingPeers -> Property
prop_relay :: VotingPeers -> Property
prop_relay VotingPeers
peers =
  Double -> Bool -> [Char] -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> [Char] -> prop -> Property
cover Double
10 (([(DiffTime, LeiosVote)] -> [(DiffTime, LeiosVote)])
-> Set (SlotNo, Word16)
verifiedBy [(DiffTime, LeiosVote)] -> [(DiffTime, LeiosVote)]
earliestFinish Set (SlotNo, Word16) -> Set (SlotNo, Word16) -> Bool
forall a. Eq a => a -> a -> Bool
/= Set (SlotNo, Word16)
allValid) [Char]
"a vote misses its deadline" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin ([Property] -> Property) -> [Property] -> Property
forall a b. (a -> b) -> a -> b
$
      [ [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
"an honest peer was disconnected" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ PeerOutcome -> Maybe [Char]
poNodeClientEnded PeerOutcome
up Maybe [Char] -> Maybe [Char] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Maybe [Char]
forall a. Maybe a
Nothing
      | PeerOutcome
up <- [PeerOutcome]
honestOutcomes
      ]
        [Property] -> [Property] -> [Property]
forall a. Semigroup a => a -> a -> a
<> [ [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"the invalid peer was disconnected: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Maybe [Char] -> [Char]
forall a. Show a => a -> [Char]
show Maybe [Char]
ended) (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
               Bool -> ([Char] -> Bool) -> Maybe [Char] -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True ([Char]
"ExnLeiosInvalidVote" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf`) Maybe [Char]
ended
           | PeerOutcome
up <- [PeerOutcome]
invalidOutcomes
           , let ended :: Maybe [Char]
ended = PeerOutcome -> Maybe [Char]
poNodeClientEnded PeerOutcome
up
           ]
        [Property] -> [Property] -> [Property]
forall a. Semigroup a => a -> a -> a
<> [ [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"peer " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ [(Time, Notification)] -> Property
honest (PeerOutcome -> [(Time, Notification)]
poReceived PeerOutcome
o)
           | (Int
i, PeerOutcome
o) <- [Int] -> [PeerOutcome] -> [(Int, PeerOutcome)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..] [PeerOutcome]
outcomes
           ]
        [Property] -> [Property] -> [Property]
forall a. Semigroup a => a -> a -> a
<> [ [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"relayed after its deadline, at " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Time -> [Char]
forall a. Show a => a -> [Char]
show Time
at [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
": " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> (SlotNo, Word16) -> [Char]
forall a. Show a => a -> [Char]
show (LeiosVote -> (SlotNo, Word16)
electionSeat LeiosVote
v)) Bool
False
           | PeerOutcome
o <- [PeerOutcome]
outcomes
           , (Time
at, NotifyVotes NonEmpty LeiosVote
vs) <- PeerOutcome -> [(Time, Notification)]
poReceived PeerOutcome
o
           , LeiosVote
v <- NonEmpty LeiosVote -> [LeiosVote]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty LeiosVote
vs
           , Time
at Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
> DiffTime -> Time
Time (SlotNo -> DiffTime
relayedUntilOf ((SlotNo, Word16) -> SlotNo
forall a b. (a, b) -> a
fst (LeiosVote -> (SlotNo, Word16)
electionSeat LeiosVote
v)))
           ]
        [Property] -> [Property] -> [Property]
forall a. Semigroup a => a -> a -> a
<> [ [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"not relayed, though verified by its deadline: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Set (SlotNo, Word16) -> [Char]
forall a. Show a => a -> [Char]
show Set (SlotNo, Word16)
missed) (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
               Set (SlotNo, Word16) -> Bool
forall a. Set a -> Bool
Set.null Set (SlotNo, Word16)
missed
           , [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"relayed, though verified only after the log was pruned past it: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Set (SlotNo, Word16) -> [Char]
forall a. Show a => a -> [Char]
show Set (SlotNo, Word16)
extra) (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
               Set (SlotNo, Word16) -> Bool
forall a. Set a -> Bool
Set.null Set (SlotNo, Word16)
extra
           ]
 where
  ups :: [[(DiffTime, Notification)]]
ups = VotingPeers -> [[(DiffTime, Notification)]]
allPeers VotingPeers
peers
  ([PeerOutcome]
upOutcomes, PeerOutcome
down) = case VerifyingTime
-> DiffTime
-> [PeerSpec]
-> [DiffTime]
-> ([PeerOutcome], [PeerOutcome])
runRelay (DiffTime -> VerifyingTime
VerifyingTime (VotingPeers -> DiffTime
nodeVerifying VotingPeers
peers)) DiffTime
20 (([(DiffTime, Notification)] -> PeerSpec)
-> [[(DiffTime, Notification)]] -> [PeerSpec]
forall a b. (a -> b) -> [a] -> [b]
map (DiffTime -> [(DiffTime, Notification)] -> PeerSpec
PeerSpec DiffTime
0) [[(DiffTime, Notification)]]
ups) [DiffTime
0] of
    ([PeerOutcome]
ups', [PeerOutcome
down']) -> ([PeerOutcome]
ups', PeerOutcome
down')
    ([PeerOutcome], [PeerOutcome])
_ -> [Char] -> ([PeerOutcome], PeerOutcome)
forall a. HasCallStack => [Char] -> a
error [Char]
"prop_relay: one downstream peer"
  ([PeerOutcome]
honestOutcomes, [PeerOutcome]
invalidOutcomes) = Int -> [PeerOutcome] -> ([PeerOutcome], [PeerOutcome])
forall a. Int -> [a] -> ([a], [a])
splitAt ([[(DiffTime, Notification)]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (VotingPeers -> [[(DiffTime, Notification)]]
honestPeers VotingPeers
peers)) [PeerOutcome]
upOutcomes
  outcomes :: [PeerOutcome]
outcomes = [PeerOutcome]
upOutcomes [PeerOutcome] -> [PeerOutcome] -> [PeerOutcome]
forall a. Semigroup a => a -> a -> a
<> [PeerOutcome
down]

  relayed :: Set (SlotNo, Word16)
relayed = [(SlotNo, Word16)] -> Set (SlotNo, Word16)
forall a. Ord a => [a] -> Set a
Set.fromList [LeiosVote -> (SlotNo, Word16)
electionSeat LeiosVote
v | LeiosVote
v <- PeerOutcome -> [LeiosVote]
votes PeerOutcome
down]
  allValid :: Set (SlotNo, Word16)
allValid = ([(DiffTime, LeiosVote)] -> [(DiffTime, LeiosVote)])
-> Set (SlotNo, Word16)
verifiedBy (((DiffTime, LeiosVote) -> (DiffTime, LeiosVote))
-> [(DiffTime, LeiosVote)] -> [(DiffTime, LeiosVote)]
forall a b. (a -> b) -> [a] -> [b]
map (\(DiffTime
_, LeiosVote
v) -> (DiffTime
0, LeiosVote
v)))
  missed :: Set (SlotNo, Word16)
missed = Set (SlotNo, Word16)
-> Set (SlotNo, Word16) -> Set (SlotNo, Word16)
forall a. Ord a => Set a -> Set a -> Set a
Set.difference (([(DiffTime, LeiosVote)] -> [(DiffTime, LeiosVote)])
-> Set (SlotNo, Word16)
verifiedBy [(DiffTime, LeiosVote)] -> [(DiffTime, LeiosVote)]
latestFinish) Set (SlotNo, Word16)
relayed
  extra :: Set (SlotNo, Word16)
extra = Set (SlotNo, Word16)
-> Set (SlotNo, Word16) -> Set (SlotNo, Word16)
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set (SlotNo, Word16)
relayed ((SlotNo -> DiffTime)
-> ([(DiffTime, LeiosVote)] -> [(DiffTime, LeiosVote)])
-> Set (SlotNo, Word16)
verifiedBy' SlotNo -> DiffTime
relayedUntilOf [(DiffTime, LeiosVote)] -> [(DiffTime, LeiosVote)]
earliestFinish)

  -- Every election and seat of which the node verified some peer's valid vote
  -- by its deadline, if each verification finished as given. Its client of a
  -- peer verifies one vote after the other, so a vote waits for the ones the
  -- peer sent before it.
  verifiedBy :: ([(DiffTime, LeiosVote)] -> [(DiffTime, LeiosVote)])
-> Set (SlotNo, Word16)
verifiedBy = (SlotNo -> DiffTime)
-> ([(DiffTime, LeiosVote)] -> [(DiffTime, LeiosVote)])
-> Set (SlotNo, Word16)
verifiedBy' SlotNo -> DiffTime
deadlineOf
  verifiedBy' :: (SlotNo -> DiffTime)
-> ([(DiffTime, LeiosVote)] -> [(DiffTime, LeiosVote)])
-> Set (SlotNo, Word16)
verifiedBy' SlotNo -> DiffTime
latest [(DiffTime, LeiosVote)] -> [(DiffTime, LeiosVote)]
finish =
    [(SlotNo, Word16)] -> Set (SlotNo, Word16)
forall a. Ord a => [a] -> Set a
Set.fromList
      [ LeiosVote -> (SlotNo, Word16)
electionSeat LeiosVote
v
      | [(DiffTime, Notification)]
sends <- [[(DiffTime, Notification)]]
ups
      , (DiffTime
done, LeiosVote
v) <- [(DiffTime, LeiosVote)] -> [(DiffTime, LeiosVote)]
finish [(DiffTime
at, LeiosVote
v) | (DiffTime
at, NotifyVotes NonEmpty LeiosVote
vs) <- [(DiffTime, Notification)]
sends, LeiosVote
v <- NonEmpty LeiosVote -> [LeiosVote]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty LeiosVote
vs]
      , LeiosVote -> Bool
validVote LeiosVote
v
      , DiffTime
done DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
<= SlotNo -> DiffTime
latest ((SlotNo, Word16) -> SlotNo
forall a b. (a, b) -> a
fst (LeiosVote -> (SlotNo, Word16)
electionSeat LeiosVote
v))
      ]

  -- At the latest, the node verifies every vote, each taking the whole
  -- verifying time.
  latestFinish :: [(DiffTime, LeiosVote)] -> [(DiffTime, LeiosVote)]
latestFinish =
    (DiffTime, [(DiffTime, LeiosVote)]) -> [(DiffTime, LeiosVote)]
forall a b. (a, b) -> b
snd
      ((DiffTime, [(DiffTime, LeiosVote)]) -> [(DiffTime, LeiosVote)])
-> ([(DiffTime, LeiosVote)] -> (DiffTime, [(DiffTime, LeiosVote)]))
-> [(DiffTime, LeiosVote)]
-> [(DiffTime, LeiosVote)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DiffTime
 -> (DiffTime, LeiosVote) -> (DiffTime, (DiffTime, LeiosVote)))
-> DiffTime
-> [(DiffTime, LeiosVote)]
-> (DiffTime, [(DiffTime, LeiosVote)])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (\DiffTime
done (DiffTime
at, LeiosVote
v) -> let done' :: DiffTime
done' = DiffTime -> DiffTime -> DiffTime
forall a. Ord a => a -> a -> a
max DiffTime
done (DiffTime -> LeiosVote -> DiffTime
start DiffTime
at LeiosVote
v) DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ DiffTime
verifying in (DiffTime
done', (DiffTime
done', LeiosVote
v))) DiffTime
0
  -- At the earliest, a vote the node relays was verified as soon as it arrived.
  earliestFinish :: [(DiffTime, LeiosVote)] -> [(DiffTime, LeiosVote)]
earliestFinish = ((DiffTime, LeiosVote) -> (DiffTime, LeiosVote))
-> [(DiffTime, LeiosVote)] -> [(DiffTime, LeiosVote)]
forall a b. (a -> b) -> [a] -> [b]
map (\(DiffTime
at, LeiosVote
v) -> (DiffTime -> LeiosVote -> DiffTime
start DiffTime
at LeiosVote
v DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ DiffTime
verifying, LeiosVote
v))
  -- The node waits for a vote's window to open.
  start :: DiffTime -> LeiosVote -> DiffTime
start DiffTime
at LeiosVote
v = DiffTime -> DiffTime -> DiffTime
forall a. Ord a => a -> a -> a
max DiffTime
at ((DiffTime, DiffTime) -> DiffTime
forall a b. (a, b) -> a
fst (SlotNo -> (DiffTime, DiffTime)
windowOf ((SlotNo, Word16) -> SlotNo
forall a b. (a, b) -> a
fst (LeiosVote -> (SlotNo, Word16)
electionSeat LeiosVote
v))))
  verifying :: DiffTime
verifying = VotingPeers -> DiffTime
nodeVerifying VotingPeers
peers

  electionSeat :: LeiosVote -> (SlotNo, Word16)
electionSeat LeiosVote
v = (Map RankingBlockHash SlotNo
announcedSlot Map RankingBlockHash SlotNo -> RankingBlockHash -> SlotNo
forall k a. Ord k => Map k a -> k -> a
Map.! LeiosVote -> RankingBlockHash
voteAnnouncingRbHash LeiosVote
v, LeiosSeatId -> Word16
leiosSeatIndex (LeiosVote -> LeiosSeatId
voteSeatId LeiosVote
v))

  announcedSlot :: Map RankingBlockHash SlotNo
announcedSlot =
    [(RankingBlockHash, SlotNo)] -> Map RankingBlockHash SlotNo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (Header LeiosTestBlock -> RankingBlockHash
rbHashOf Header LeiosTestBlock
hdr, Header LeiosTestBlock -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header LeiosTestBlock
hdr)
      | [(DiffTime, Notification)]
sends <- [[(DiffTime, Notification)]]
ups
      , (DiffTime
_, NotifyAnnouncement Header LeiosTestBlock
hdr) <- [(DiffTime, Notification)]
sends
      ]

{-------------------------------------------------------------------------------
  Checking what a peer receives
-------------------------------------------------------------------------------}

-- | The deadline of the votes of an election slot.
deadlineOf :: SlotNo -> DiffTime
deadlineOf :: SlotNo -> DiffTime
deadlineOf = (DiffTime, DiffTime) -> DiffTime
forall a b. (a, b) -> b
snd ((DiffTime, DiffTime) -> DiffTime)
-> (SlotNo -> (DiffTime, DiffTime)) -> SlotNo -> DiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo -> (DiffTime, DiffTime)
windowOf

-- | The latest the node may relay a vote of an election slot: until the log is
-- pruned past its deadline.
relayedUntilOf :: SlotNo -> DiffTime
relayedUntilOf :: SlotNo -> DiffTime
relayedUntilOf SlotNo
slot = SlotNo -> DiffTime
deadlineOf SlotNo
slot DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ NominalDiffTime -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac NominalDiffTime
notifyLogPruneCadence

-- | When the window of the votes of an election slot opens, and their
-- deadline.
windowOf :: SlotNo -> (DiffTime, DiffTime)
windowOf :: SlotNo -> (DiffTime, DiffTime)
windowOf SlotNo
slot = (NominalDiffTime -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac NominalDiffTime
opens, NominalDiffTime -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac NominalDiffTime
deadline)
 where
  MkVoteWindow (RelativeTime NominalDiffTime
opens) (RelativeTime NominalDiffTime
deadline) =
    -- One-second slots, the first starting when the run begins.
    LeiosLedgerView -> RelativeTime -> VoteWindow
leiosVoteWindow LeiosLedgerView
leiosLedgerView (NominalDiffTime -> RelativeTime
RelativeTime (Word64 -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SlotNo -> Word64
unSlotNo SlotNo
slot)))

-- | Why an honest peer's client would disconnect the node for this stream, if
-- it would: an announcement must be neither a repeat nor the third of its
-- election, nor older than 'maxAnnouncementAgeRecv'; a vote must follow the
-- announcement it is for, be the first of its seat in that election, verify
-- against the committee, and arrive between its window opening and its
-- diffusion period ending, even by a clock as far behind the node's as the
-- clock skew allows.
honest :: [(Time, Notification)] -> Property
honest :: [(Time, Notification)] -> Property
honest [(Time, Notification)]
received = case [(Time, Notification)] -> [[Char]]
honestViolations [(Time, Notification)]
received of
  [] -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
  [[Char]]
violations -> [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([[Char]] -> [Char]
unlines [[Char]]
violations) Bool
False

honestViolations :: [(Time, Notification)] -> [String]
honestViolations :: [(Time, Notification)] -> [[Char]]
honestViolations = ((State (AnnouncingHeader LeiosTestBlock),
  Map RankingBlockHash SlotNo, Set (SlotNo, Word16)),
 [[Char]])
-> [[Char]]
forall a b. (a, b) -> b
snd (((State (AnnouncingHeader LeiosTestBlock),
   Map RankingBlockHash SlotNo, Set (SlotNo, Word16)),
  [[Char]])
 -> [[Char]])
-> ([(Time, Notification)]
    -> ((State (AnnouncingHeader LeiosTestBlock),
         Map RankingBlockHash SlotNo, Set (SlotNo, Word16)),
        [[Char]]))
-> [(Time, Notification)]
-> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((State (AnnouncingHeader LeiosTestBlock),
   Map RankingBlockHash SlotNo, Set (SlotNo, Word16)),
  [[Char]])
 -> (Time, Notification)
 -> ((State (AnnouncingHeader LeiosTestBlock),
      Map RankingBlockHash SlotNo, Set (SlotNo, Word16)),
     [[Char]]))
-> ((State (AnnouncingHeader LeiosTestBlock),
     Map RankingBlockHash SlotNo, Set (SlotNo, Word16)),
    [[Char]])
-> [(Time, Notification)]
-> ((State (AnnouncingHeader LeiosTestBlock),
     Map RankingBlockHash SlotNo, Set (SlotNo, Word16)),
    [[Char]])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' ((State (AnnouncingHeader LeiosTestBlock),
  Map RankingBlockHash SlotNo, Set (SlotNo, Word16)),
 [[Char]])
-> (Time, Notification)
-> ((State (AnnouncingHeader LeiosTestBlock),
     Map RankingBlockHash SlotNo, Set (SlotNo, Word16)),
    [[Char]])
step ((State (AnnouncingHeader LeiosTestBlock)
forall anc. State anc
Announcements.empty, Map RankingBlockHash SlotNo
forall k a. Map k a
Map.empty, Set (SlotNo, Word16)
forall a. Set a
Set.empty), [])
 where
  step :: ((State (AnnouncingHeader LeiosTestBlock),
  Map RankingBlockHash SlotNo, Set (SlotNo, Word16)),
 [[Char]])
-> (Time, Notification)
-> ((State (AnnouncingHeader LeiosTestBlock),
     Map RankingBlockHash SlotNo, Set (SlotNo, Word16)),
    [[Char]])
step ((State (AnnouncingHeader LeiosTestBlock)
seen, Map RankingBlockHash SlotNo
announced, Set (SlotNo, Word16)
voted), [[Char]]
errs) (Time
at, Notification
n) = case Notification
n of
    NotifyAnnouncement Header LeiosTestBlock
hdr -> case TopLevelConfig LeiosTestBlock
-> Header LeiosTestBlock -> Maybe (AnnouncingHeader LeiosTestBlock)
forall blk.
BlockSupportsProtocol blk =>
TopLevelConfig blk -> Header blk -> Maybe (AnnouncingHeader blk)
mkAnnouncingHeader TopLevelConfig LeiosTestBlock
topLevelConfig Header LeiosTestBlock
hdr of
      Maybe (AnnouncingHeader LeiosTestBlock)
Nothing -> ((State (AnnouncingHeader LeiosTestBlock)
seen, Map RankingBlockHash SlotNo
announced, Set (SlotNo, Word16)
voted), [[Char]]
errs [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]
"not an announcement: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Header LeiosTestBlock -> [Char]
forall a. Show a => a -> [Char]
show Header LeiosTestBlock
hdr])
      Just AnnouncingHeader LeiosTestBlock
anc -> case forall anc invalidity.
Eq anc =>
ElectionId
-> anc -> State anc -> Either (Error invalidity) (State anc)
Announcements.insert @_ @Void (AnnouncingHeader LeiosTestBlock -> ElectionId
forall blk. AnnouncingHeader blk -> ElectionId
ancElectionId AnnouncingHeader LeiosTestBlock
anc) AnnouncingHeader LeiosTestBlock
anc State (AnnouncingHeader LeiosTestBlock)
seen of
        Left Error Void
err -> ((State (AnnouncingHeader LeiosTestBlock)
seen, Map RankingBlockHash SlotNo
announced, Set (SlotNo, Word16)
voted), [[Char]]
errs [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Error Void -> [Char]
forall a. Show a => a -> [Char]
show Error Void
err [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
": " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Header LeiosTestBlock -> [Char]
forall a. Show a => a -> [Char]
show Header LeiosTestBlock
hdr])
        Right State (AnnouncingHeader LeiosTestBlock)
seen' ->
          ( (State (AnnouncingHeader LeiosTestBlock)
seen', RankingBlockHash
-> SlotNo
-> Map RankingBlockHash SlotNo
-> Map RankingBlockHash SlotNo
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Header LeiosTestBlock -> RankingBlockHash
rbHashOf Header LeiosTestBlock
hdr) (Header LeiosTestBlock -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header LeiosTestBlock
hdr) Map RankingBlockHash SlotNo
announced, Set (SlotNo, Word16)
voted)
          , [[Char]]
errs
              [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"too old, at " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Time -> [Char]
forall a. Show a => a -> [Char]
show Time
at [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
": " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Header LeiosTestBlock -> [Char]
forall a. Show a => a -> [Char]
show Header LeiosTestBlock
hdr
                 | Time -> Double
toSeconds Time
at Double -> Double -> Double
forall a. Num a => a -> a -> a
- SlotNo -> Double
forall {b}. Num b => SlotNo -> b
slotStart (Header LeiosTestBlock -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header LeiosTestBlock
hdr) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac NominalDiffTime
maxAnnouncementAgeRecv
                 ]
          )
    NotifyVotes NonEmpty LeiosVote
vs -> (((State (AnnouncingHeader LeiosTestBlock),
   Map RankingBlockHash SlotNo, Set (SlotNo, Word16)),
  [[Char]])
 -> LeiosVote
 -> ((State (AnnouncingHeader LeiosTestBlock),
      Map RankingBlockHash SlotNo, Set (SlotNo, Word16)),
     [[Char]]))
-> ((State (AnnouncingHeader LeiosTestBlock),
     Map RankingBlockHash SlotNo, Set (SlotNo, Word16)),
    [[Char]])
-> NonEmpty LeiosVote
-> ((State (AnnouncingHeader LeiosTestBlock),
     Map RankingBlockHash SlotNo, Set (SlotNo, Word16)),
    [[Char]])
forall b a. (b -> a -> b) -> b -> NonEmpty a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' (Time
-> ((State (AnnouncingHeader LeiosTestBlock),
     Map RankingBlockHash SlotNo, Set (SlotNo, Word16)),
    [[Char]])
-> LeiosVote
-> ((State (AnnouncingHeader LeiosTestBlock),
     Map RankingBlockHash SlotNo, Set (SlotNo, Word16)),
    [[Char]])
checkVote Time
at) ((State (AnnouncingHeader LeiosTestBlock)
seen, Map RankingBlockHash SlotNo
announced, Set (SlotNo, Word16)
voted), [[Char]]
errs) NonEmpty LeiosVote
vs
    Notification
NotifyOther -> ((State (AnnouncingHeader LeiosTestBlock)
seen, Map RankingBlockHash SlotNo
announced, Set (SlotNo, Word16)
voted), [[Char]]
errs)

  checkVote :: Time
-> ((State (AnnouncingHeader LeiosTestBlock),
     Map RankingBlockHash SlotNo, Set (SlotNo, Word16)),
    [[Char]])
-> LeiosVote
-> ((State (AnnouncingHeader LeiosTestBlock),
     Map RankingBlockHash SlotNo, Set (SlotNo, Word16)),
    [[Char]])
checkVote Time
at ((State (AnnouncingHeader LeiosTestBlock)
seen, Map RankingBlockHash SlotNo
announced, Set (SlotNo, Word16)
voted), [[Char]]
errs) LeiosVote
v = case RankingBlockHash -> Map RankingBlockHash SlotNo -> Maybe SlotNo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (LeiosVote -> RankingBlockHash
voteAnnouncingRbHash LeiosVote
v) Map RankingBlockHash SlotNo
announced of
    Maybe SlotNo
Nothing ->
      ((State (AnnouncingHeader LeiosTestBlock)
seen, Map RankingBlockHash SlotNo
announced, Set (SlotNo, Word16)
voted), [[Char]]
errs [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]
"a vote for an announcement not relayed before: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> LeiosVote -> [Char]
forall a. Show a => a -> [Char]
show LeiosVote
v])
    Just SlotNo
slot ->
      ( (State (AnnouncingHeader LeiosTestBlock)
seen, Map RankingBlockHash SlotNo
announced, (SlotNo, Word16) -> Set (SlotNo, Word16) -> Set (SlotNo, Word16)
forall a. Ord a => a -> Set a -> Set a
Set.insert (SlotNo
slot, Word16
seat) Set (SlotNo, Word16)
voted)
      , [[Char]]
errs
          [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"a second vote of seat " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Word16 -> [Char]
forall a. Show a => a -> [Char]
show Word16
seat [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" in slot " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> SlotNo -> [Char]
forall a. Show a => a -> [Char]
show SlotNo
slot
             | (SlotNo, Word16) -> Set (SlotNo, Word16) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (SlotNo
slot, Word16
seat) Set (SlotNo, Word16)
voted
             ]
          [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]
"an invalid vote: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> LeiosVote -> [Char]
forall a. Show a => a -> [Char]
show LeiosVote
v | Bool -> Bool
not (LeiosVote -> Bool
validVote LeiosVote
v)]
          [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [ [Char]
"a vote outside its window, at " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Time -> [Char]
forall a. Show a => a -> [Char]
show Time
at
             | let age :: Double
age = Time -> Double
toSeconds Time
at Double -> Double -> Double
forall a. Num a => a -> a -> a
- SlotNo -> Double
forall {b}. Num b => SlotNo -> b
slotStart SlotNo
slot
             , Double
age Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
3 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
lHdr Bool -> Bool -> Bool
|| Double
age Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
3 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
lHdr Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
lVote Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
lDiff Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
grace
             ]
      )
   where
    seat :: Word16
seat = LeiosSeatId -> Word16
leiosSeatIndex (LeiosVote -> LeiosSeatId
voteSeatId LeiosVote
v)

  toSeconds :: Time -> Double
toSeconds (Time DiffTime
t) = DiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac DiffTime
t :: Double
  slotStart :: SlotNo -> b
slotStart (SlotNo Word64
s) = Word64 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
s -- One-second slots.
  lHdr :: Double
lHdr = NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Milliseconds32 -> NominalDiffTime
milliseconds32ToNominalDiffTime (LeiosLedgerView -> Milliseconds32
llvAnnouncementPeriod LeiosLedgerView
leiosLedgerView))
  lVote :: Double
lVote = NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Milliseconds32 -> NominalDiffTime
milliseconds32ToNominalDiffTime (LeiosLedgerView -> Milliseconds32
llvVotePeriod LeiosLedgerView
leiosLedgerView))
  lDiff :: Double
lDiff = NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Milliseconds32 -> NominalDiffTime
milliseconds32ToNominalDiffTime (LeiosLedgerView -> Milliseconds32
llvDiffusionPeriod LeiosLedgerView
leiosLedgerView))
  grace :: Double
grace = NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac NominalDiffTime
voteLateGrace

-- | Whether the vote's seat has a key in the committee, and its signature
-- verifies under it.
validVote :: LeiosVote -> Bool
validVote :: LeiosVote -> Bool
validVote MkLeiosVote{RankingBlockHash
voteAnnouncingRbHash :: LeiosVote -> RankingBlockHash
voteAnnouncingRbHash :: RankingBlockHash
voteAnnouncingRbHash, LeiosSeatId
voteSeatId :: LeiosVote -> LeiosSeatId
voteSeatId :: LeiosSeatId
voteSeatId, LeiosSignature
voteSignature :: LeiosSignature
voteSignature :: LeiosVote -> LeiosSignature
voteSignature} =
  case LeiosCommittee -> LeiosSeatId -> Maybe LeiosSeat
resolveLeiosSeat LeiosCommittee
committee LeiosSeatId
voteSeatId of
    Just LeiosSeat{seatVKey :: LeiosSeat -> StrictMaybe LeiosVerificationKey
seatVKey = SJust LeiosVerificationKey
vk} ->
      Either [Char] () -> Bool
forall a b. Either a b -> Bool
isRight (Either [Char] () -> Bool) -> Either [Char] () -> Bool
forall a b. (a -> b) -> a -> b
$ ContextDSIGN LeiosDSIGN
-> LeiosVerificationKey
-> RankingBlockHash
-> LeiosSignature
-> Either [Char] ()
forall v a.
(DSIGNAlgorithm v, Signable v a, HasCallStack) =>
ContextDSIGN v
-> VerKeyDSIGN v -> a -> SigDSIGN v -> Either [Char] ()
forall a.
(Signable LeiosDSIGN a, HasCallStack) =>
ContextDSIGN LeiosDSIGN
-> LeiosVerificationKey -> a -> LeiosSignature -> Either [Char] ()
verifyDSIGN ContextDSIGN LeiosDSIGN
BLS12381SignContext
leiosSignContext LeiosVerificationKey
vk RankingBlockHash
voteAnnouncingRbHash LeiosSignature
voteSignature
    Maybe LeiosSeat
_ -> Bool
False

announcements :: PeerOutcome -> [Header Blk]
announcements :: PeerOutcome -> [Header LeiosTestBlock]
announcements PeerOutcome
o = [Header LeiosTestBlock
hdr | (Time
_, NotifyAnnouncement Header LeiosTestBlock
hdr) <- PeerOutcome -> [(Time, Notification)]
poReceived PeerOutcome
o]

votes :: PeerOutcome -> [LeiosVote]
votes :: PeerOutcome -> [LeiosVote]
votes PeerOutcome
o = [[LeiosVote]] -> [LeiosVote]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [NonEmpty LeiosVote -> [LeiosVote]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty LeiosVote
vs | (Time
_, NotifyVotes NonEmpty LeiosVote
vs) <- PeerOutcome -> [(Time, Notification)]
poReceived PeerOutcome
o]

-- | The vote of this seat for the announcement this block carries.
voteOf :: LeiosTestBlock -> Word16 -> LeiosVote
voteOf :: LeiosTestBlock -> Word16 -> LeiosVote
voteOf LeiosTestBlock
blk Word16
seat = LeiosSigningKey -> LeiosTestBlock -> Word16 -> LeiosVote
signedBy ([LeiosSigningKey]
seatKeys [LeiosSigningKey] -> Int -> LeiosSigningKey
forall a. HasCallStack => [a] -> Int -> a
!! Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
seat) LeiosTestBlock
blk Word16
seat

voteTimes :: PeerOutcome -> [Time]
voteTimes :: PeerOutcome -> [Time]
voteTimes PeerOutcome
o = [Time
at | (Time
at, NotifyVotes NonEmpty LeiosVote
_) <- PeerOutcome -> [(Time, Notification)]
poReceived PeerOutcome
o]

{-------------------------------------------------------------------------------
  Running a scenario
-------------------------------------------------------------------------------}

-- | What a peer sends the node, or what the node relays to a peer.
data Notification
  = NotifyAnnouncement (Header Blk)
  | NotifyVotes (NonEmpty LeiosVote)
  | -- | An offer, which these tests neither send nor check.
    NotifyOther
  deriving Int -> Notification -> [Char] -> [Char]
[Notification] -> [Char] -> [Char]
Notification -> [Char]
(Int -> Notification -> [Char] -> [Char])
-> (Notification -> [Char])
-> ([Notification] -> [Char] -> [Char])
-> Show Notification
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Notification -> [Char] -> [Char]
showsPrec :: Int -> Notification -> [Char] -> [Char]
$cshow :: Notification -> [Char]
show :: Notification -> [Char]
$cshowList :: [Notification] -> [Char] -> [Char]
showList :: [Notification] -> [Char] -> [Char]
Show

showNotification :: Notification -> String
showNotification :: Notification -> [Char]
showNotification = \case
  NotifyAnnouncement Header LeiosTestBlock
hdr -> [Char]
"announce@" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> SlotNo -> [Char]
forall a. Show a => a -> [Char]
show (Header LeiosTestBlock -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header LeiosTestBlock
hdr)
  NotifyVotes NonEmpty LeiosVote
vs -> [Char]
"votes" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [(Word16, Bool)] -> [Char]
forall a. Show a => a -> [Char]
show [(LeiosSeatId -> Word16
leiosSeatIndex (LeiosVote -> LeiosSeatId
voteSeatId LeiosVote
v), LeiosVote -> Bool
validVote LeiosVote
v) | LeiosVote
v <- NonEmpty LeiosVote -> [LeiosVote]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty LeiosVote
vs]
  Notification
NotifyOther -> [Char]
"other"

-- | A peer: when it connects, and what it sends the node when.
data PeerSpec = PeerSpec
  { PeerSpec -> DiffTime
psConnectAt :: DiffTime
  , PeerSpec -> [(DiffTime, Notification)]
psSends :: [(DiffTime, Notification)]
  }

data PeerOutcome = PeerOutcome
  { PeerOutcome -> [(Time, Notification)]
poReceived :: [(Time, Notification)]
  -- ^ what the node relayed to the peer, and when
  , PeerOutcome -> Maybe [Char]
poNodeClientEnded :: Maybe String
  -- ^ How the node's client of this peer ended, if it did.
  }

-- | Run peers against one node until the given time: upstream peers, which
-- connect at once and send the node their schedules, and downstream peers,
-- which connect at the given times and send nothing. Every peer records what
-- the node relays to it, and the test fails if an honest peer's client would
-- disconnect the node for it.
relay :: DiffTime -> [[(DiffTime, Notification)]] -> [DiffTime] -> IO ([PeerOutcome], [PeerOutcome])
relay :: DiffTime
-> [[(DiffTime, Notification)]]
-> [DiffTime]
-> IO ([PeerOutcome], [PeerOutcome])
relay DiffTime
end [[(DiffTime, Notification)]]
ups = DiffTime
-> [PeerSpec] -> [DiffTime] -> IO ([PeerOutcome], [PeerOutcome])
relayPeers DiffTime
end (([(DiffTime, Notification)] -> PeerSpec)
-> [[(DiffTime, Notification)]] -> [PeerSpec]
forall a b. (a -> b) -> [a] -> [b]
map (DiffTime -> [(DiffTime, Notification)] -> PeerSpec
PeerSpec DiffTime
0) [[(DiffTime, Notification)]]
ups)

-- | 'relay', with upstream peers that connect when they say.
relayPeers :: DiffTime -> [PeerSpec] -> [DiffTime] -> IO ([PeerOutcome], [PeerOutcome])
relayPeers :: DiffTime
-> [PeerSpec] -> [DiffTime] -> IO ([PeerOutcome], [PeerOutcome])
relayPeers DiffTime
end [PeerSpec]
ups [DiffTime]
downs = do
  [(Int, PeerOutcome)]
-> ((Int, PeerOutcome) -> Assertion) -> Assertion
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([Int] -> [PeerOutcome] -> [(Int, PeerOutcome)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..] ([PeerOutcome]
ups' [PeerOutcome] -> [PeerOutcome] -> [PeerOutcome]
forall a. Semigroup a => a -> a -> a
<> [PeerOutcome]
downs')) (((Int, PeerOutcome) -> Assertion) -> Assertion)
-> ((Int, PeerOutcome) -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \(Int
i, PeerOutcome
o) -> case [(Time, Notification)] -> [[Char]]
honestViolations (PeerOutcome -> [(Time, Notification)]
poReceived PeerOutcome
o) of
    [] -> () -> Assertion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [[Char]]
violations -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure ([Char] -> Assertion) -> [Char] -> Assertion
forall a b. (a -> b) -> a -> b
$ [Char]
"peer " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
":\n" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [[Char]] -> [Char]
unlines [[Char]]
violations
  ([PeerOutcome], [PeerOutcome]) -> IO ([PeerOutcome], [PeerOutcome])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PeerOutcome]
ups', [PeerOutcome]
downs')
 where
  ([PeerOutcome]
ups', [PeerOutcome]
downs') = VerifyingTime
-> DiffTime
-> [PeerSpec]
-> [DiffTime]
-> ([PeerOutcome], [PeerOutcome])
runRelay (DiffTime -> VerifyingTime
VerifyingTime DiffTime
0) DiffTime
end [PeerSpec]
ups [DiffTime]
downs

-- | 'relayPeers', with a node that takes this long to verify each vote, and
-- without failing for what the node relays.
runRelay :: VerifyingTime -> DiffTime -> [PeerSpec] -> [DiffTime] -> ([PeerOutcome], [PeerOutcome])
runRelay :: VerifyingTime
-> DiffTime
-> [PeerSpec]
-> [DiffTime]
-> ([PeerOutcome], [PeerOutcome])
runRelay VerifyingTime
verifying DiffTime
end [PeerSpec]
ups [DiffTime]
downs = Int -> [PeerOutcome] -> ([PeerOutcome], [PeerOutcome])
forall a. Int -> [a] -> ([a], [a])
splitAt ([PeerSpec] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PeerSpec]
ups) ([PeerOutcome] -> ([PeerOutcome], [PeerOutcome]))
-> [PeerOutcome] -> ([PeerOutcome], [PeerOutcome])
forall a b. (a -> b) -> a -> b
$ (forall s. IOSim s [PeerOutcome]) -> [PeerOutcome]
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((forall s. IOSim s [PeerOutcome]) -> [PeerOutcome])
-> (forall s. IOSim s [PeerOutcome]) -> [PeerOutcome]
forall a b. (a -> b) -> a -> b
$ VerifyingTime
-> (NodeUnderTest (IOSim s) -> IOSim s [PeerOutcome])
-> IOSim s [PeerOutcome]
forall s a.
VerifyingTime
-> (NodeUnderTest (IOSim s) -> IOSim s a) -> IOSim s a
withNode VerifyingTime
verifying ((NodeUnderTest (IOSim s) -> IOSim s [PeerOutcome])
 -> IOSim s [PeerOutcome])
-> (NodeUnderTest (IOSim s) -> IOSim s [PeerOutcome])
-> IOSim s [PeerOutcome]
forall a b. (a -> b) -> a -> b
$ \NodeUnderTest (IOSim s)
nut ->
  [(Int, PeerSpec)]
-> ((Int, PeerSpec) -> IOSim s PeerOutcome)
-> IOSim s [PeerOutcome]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, MonadAsync m) =>
t a -> (a -> m b) -> m (t b)
forConcurrently ([Int] -> [PeerSpec] -> [(Int, PeerSpec)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] [PeerSpec]
specs) (((Int, PeerSpec) -> IOSim s PeerOutcome) -> IOSim s [PeerOutcome])
-> ((Int, PeerSpec) -> IOSim s PeerOutcome)
-> IOSim s [PeerOutcome]
forall a b. (a -> b) -> a -> b
$ \(Int
i, PeerSpec
spec) -> NodeUnderTest (IOSim s)
-> DiffTime -> PeerAddr -> PeerSpec -> IOSim s PeerOutcome
forall s.
NodeUnderTest (IOSim s)
-> DiffTime -> PeerAddr -> PeerSpec -> IOSim s PeerOutcome
runPeer NodeUnderTest (IOSim s)
nut DiffTime
end (Int -> PeerAddr
PeerAddr Int
i) PeerSpec
spec
 where
  specs :: [PeerSpec]
specs = [PeerSpec]
ups [PeerSpec] -> [PeerSpec] -> [PeerSpec]
forall a. Semigroup a => a -> a -> a
<> [DiffTime -> [(DiffTime, Notification)] -> PeerSpec
PeerSpec DiffTime
at [] | DiffTime
at <- [DiffTime]
downs]

-- | 'relay' for 20 seconds, past every vote's diffusion period, to one downstream peer
-- connecting at the given time.
relayToOne :: DiffTime -> [[(DiffTime, Notification)]] -> IO PeerOutcome
relayToOne :: DiffTime -> [[(DiffTime, Notification)]] -> IO PeerOutcome
relayToOne DiffTime
at [[(DiffTime, Notification)]]
ups =
  DiffTime
-> [[(DiffTime, Notification)]]
-> [DiffTime]
-> IO ([PeerOutcome], [PeerOutcome])
relay DiffTime
20 [[(DiffTime, Notification)]]
ups [DiffTime
at] IO ([PeerOutcome], [PeerOutcome])
-> (([PeerOutcome], [PeerOutcome]) -> IO PeerOutcome)
-> IO PeerOutcome
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    ([PeerOutcome]
_, [PeerOutcome
down]) -> PeerOutcome -> IO PeerOutcome
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PeerOutcome
down
    ([PeerOutcome], [PeerOutcome])
_ -> [Char] -> IO PeerOutcome
forall a. HasCallStack => [Char] -> a
error [Char]
"relayToOne: one downstream peer"

runPeer :: NodeUnderTest (IOSim s) -> DiffTime -> PeerAddr -> PeerSpec -> IOSim s PeerOutcome
runPeer :: forall s.
NodeUnderTest (IOSim s)
-> DiffTime -> PeerAddr -> PeerSpec -> IOSim s PeerOutcome
runPeer NodeUnderTest (IOSim s)
nut DiffTime
end PeerAddr
addr PeerSpec{DiffTime
psConnectAt :: PeerSpec -> DiffTime
psConnectAt :: DiffTime
psConnectAt, [(DiffTime, Notification)]
psSends :: PeerSpec -> [(DiffTime, Notification)]
psSends :: [(DiffTime, Notification)]
psSends} = do
  DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
psConnectAt
  queue <- IOSim s (StrictTQueue (IOSim s) Notification)
forall (m :: * -> *) a. MonadSTM m => m (StrictTQueue m a)
newTQueueIO
  received <- newTVarIO []
  let c = NodeUnderTest (IOSim s) -> LeiosNotifyCodec s
forall s. NodeUnderTest (IOSim s) -> LeiosNotifyCodec s
envLeiosNotifyCodec NodeUnderTest (IOSim s)
nut
      envPeer =
        EnvPeer
          { epLeiosNotifyServer :: Channel (IOSim s) ByteString -> IOSim s ()
epLeiosNotifyServer = LeiosNotifyCodec s
-> STM (IOSim s) Notification
-> Channel (IOSim s) ByteString
-> IOSim s ()
forall s.
LeiosNotifyCodec s
-> STM (IOSim s) Notification
-> Channel (IOSim s) ByteString
-> IOSim s ()
runFeedingServer LeiosNotifyCodec s
c (StrictTQueue (IOSim s) Notification -> STM (IOSim s) Notification
forall (m :: * -> *) a. MonadSTM m => StrictTQueue m a -> STM m a
readTQueue StrictTQueue (IOSim s) Notification
queue)
          , epLeiosNotifyClient :: Maybe (Channel (IOSim s) ByteString -> IOSim s ())
epLeiosNotifyClient = (Channel (IOSim s) ByteString -> IOSim s ())
-> Maybe (Channel (IOSim s) ByteString -> IOSim s ())
forall a. a -> Maybe a
Just ((Channel (IOSim s) ByteString -> IOSim s ())
 -> Maybe (Channel (IOSim s) ByteString -> IOSim s ()))
-> (Channel (IOSim s) ByteString -> IOSim s ())
-> Maybe (Channel (IOSim s) ByteString -> IOSim s ())
forall a b. (a -> b) -> a -> b
$ LeiosNotifyCodec s
-> StrictTVar (IOSim s) [(Time, Notification)]
-> Channel (IOSim s) ByteString
-> IOSim s ()
forall s.
LeiosNotifyCodec s
-> StrictTVar (IOSim s) [(Time, Notification)]
-> Channel (IOSim s) ByteString
-> IOSim s ()
runRecordingClient LeiosNotifyCodec s
c StrictTVar (IOSim s) [(Time, Notification)]
received
          , epLeiosFetchServer :: Channel (IOSim s) ByteString -> IOSim s ()
epLeiosFetchServer = NodeUnderTest (IOSim s)
-> Channel (IOSim s) ByteString -> IOSim s ()
forall s.
NodeUnderTest (IOSim s)
-> Channel (IOSim s) ByteString -> IOSim s ()
refusingLeiosFetchServer NodeUnderTest (IOSim s)
nut
          , epLeiosFetchClient :: Maybe (Channel (IOSim s) ByteString -> IOSim s ())
epLeiosFetchClient = Maybe (Channel (IOSim s) ByteString -> IOSim s ())
forall a. Maybe a
Nothing
          }
  withAsync (feedAt queue psSends) $ \Async (IOSim s) ()
_feeder ->
    NodeUnderTest (IOSim s)
-> PeerAddr
-> EnvPeer (IOSim s)
-> (NodeVsEnvConnection (IOSim s) -> IOSim s PeerOutcome)
-> IOSim s PeerOutcome
forall s a.
NodeUnderTest (IOSim s)
-> PeerAddr
-> EnvPeer (IOSim s)
-> (NodeVsEnvConnection (IOSim s) -> IOSim s a)
-> IOSim s a
withNodeVsEnvConnection NodeUnderTest (IOSim s)
nut PeerAddr
addr EnvPeer (IOSim s)
envPeer ((NodeVsEnvConnection (IOSim s) -> IOSim s PeerOutcome)
 -> IOSim s PeerOutcome)
-> (NodeVsEnvConnection (IOSim s) -> IOSim s PeerOutcome)
-> IOSim s PeerOutcome
forall a b. (a -> b) -> a -> b
$ \NodeVsEnvConnection (IOSim s)
conn -> do
      Time now <- IOSim s Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
      threadDelay (end - now)
      ended <- case Map.lookup leiosNotifyMiniProtocolNum (connNodeInitiators conn) of
        Maybe (STM s (Either SomeException NodeToNodeInitiatorResult))
Nothing -> Maybe [Char] -> IOSim s (Maybe [Char])
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"the node runs no LeiosNotify client")
        Just STM s (Either SomeException NodeToNodeInitiatorResult)
client -> STM (IOSim s) (Maybe [Char]) -> IOSim s (Maybe [Char])
forall a. HasCallStack => STM (IOSim s) a -> IOSim s a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM (IOSim s) (Maybe [Char]) -> IOSim s (Maybe [Char]))
-> STM (IOSim s) (Maybe [Char]) -> IOSim s (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char])
-> (Either SomeException NodeToNodeInitiatorResult -> [Char])
-> Either SomeException NodeToNodeInitiatorResult
-> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SomeException -> [Char])
-> (NodeToNodeInitiatorResult -> [Char])
-> Either SomeException NodeToNodeInitiatorResult
-> [Char]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> [Char]
forall a. Show a => a -> [Char]
show ([Char] -> NodeToNodeInitiatorResult -> [Char]
forall a b. a -> b -> a
const [Char]
"ended") (Either SomeException NodeToNodeInitiatorResult -> Maybe [Char])
-> STM s (Either SomeException NodeToNodeInitiatorResult)
-> STM s (Maybe [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM s (Either SomeException NodeToNodeInitiatorResult)
client) STM (IOSim s) (Maybe [Char])
-> STM (IOSim s) (Maybe [Char]) -> STM (IOSim s) (Maybe [Char])
forall a. STM (IOSim s) a -> STM (IOSim s) a -> STM (IOSim s) a
forall (m :: * -> *) a. MonadSTM m => STM m a -> STM m a -> STM m a
`orElse` Maybe [Char] -> STM s (Maybe [Char])
forall a. a -> STM s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [Char]
forall a. Maybe a
Nothing
      PeerOutcome <$> (reverse <$> readTVarIO received) <*> pure ended

-- | Put each notification in the queue at its time since the run began.
feedAt :: StrictTQueue (IOSim s) Notification -> [(DiffTime, Notification)] -> IOSim s ()
feedAt :: forall s.
StrictTQueue (IOSim s) Notification
-> [(DiffTime, Notification)] -> IOSim s ()
feedAt StrictTQueue (IOSim s) Notification
queue = ((DiffTime, Notification) -> IOSim s ())
-> [(DiffTime, Notification)] -> IOSim s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (((DiffTime, Notification) -> IOSim s ())
 -> [(DiffTime, Notification)] -> IOSim s ())
-> ((DiffTime, Notification) -> IOSim s ())
-> [(DiffTime, Notification)]
-> IOSim s ()
forall a b. (a -> b) -> a -> b
$ \(DiffTime
at, Notification
n) -> do
  Time now <- IOSim s Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
  threadDelay (max 0 (at - now))
  atomically $ writeTQueue queue n

-- | The peer's server: each request gets the next notification from the queue.
runFeedingServer ::
  LeiosNotifyCodec s -> STM (IOSim s) Notification -> Channel (IOSim s) BSL.ByteString -> IOSim s ()
runFeedingServer :: forall s.
LeiosNotifyCodec s
-> STM (IOSim s) Notification
-> Channel (IOSim s) ByteString
-> IOSim s ()
runFeedingServer LeiosNotifyCodec s
c STM (IOSim s) Notification
next Channel (IOSim s) ByteString
chan = do
  peer <- IOSim s WhetherExcessiveRequests
-> STM
     (IOSim s)
     (Message
        (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote)
        'StBusy
        'StIdle)
-> IOSim
     s
     (LeiosNotifyServerPeerLookahead
        LeiosPoint (Header LeiosTestBlock) LeiosVote (IOSim s))
forall (m :: * -> *) point announcement vote.
(MonadThrow m, MonadSTM m) =>
m WhetherExcessiveRequests
-> STM
     m (Message (LeiosNotify point announcement vote) 'StBusy 'StIdle)
-> m (LeiosNotifyServerPeerLookahead point announcement vote m)
leiosNotifyServerPeerLookahead (WhetherExcessiveRequests -> IOSim s WhetherExcessiveRequests
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WhetherExcessiveRequests
NotExcessiveRequests) (Notification
-> Message
     (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote)
     'StBusy
     'StIdle
toMessage (Notification
 -> Message
      (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote)
      'StBusy
      'StIdle)
-> STM s Notification
-> STM
     s
     (Message
        (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote)
        'StBusy
        'StIdle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (IOSim s) Notification
STM s Notification
next)
  fst
    <$> runLookaheadFixedSenderPeerWithLimits nullTracer c sizeLimits timeLimitsLeiosNotify chan peer
 where
  toMessage :: Notification -> Message (LeiosNotify LeiosPoint (Header Blk) LeiosVote) StBusy StIdle
  toMessage :: Notification
-> Message
     (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote)
     'StBusy
     'StIdle
toMessage = \case
    NotifyAnnouncement Header LeiosTestBlock
hdr -> Header LeiosTestBlock
-> Message
     (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote)
     'StBusy
     'StIdle
forall announcement point vote.
announcement
-> Message (LeiosNotify point announcement vote) 'StBusy 'StIdle
MsgLeiosBlockAnnouncement Header LeiosTestBlock
hdr
    NotifyVotes NonEmpty LeiosVote
vs -> NonEmpty LeiosVote
-> Message
     (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote)
     'StBusy
     'StIdle
forall vote point announcement.
NonEmpty vote
-> Message (LeiosNotify point announcement vote) 'StBusy 'StIdle
MsgLeiosVotes NonEmpty LeiosVote
vs
    Notification
NotifyOther -> [Char]
-> Message
     (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote)
     'StBusy
     'StIdle
forall a. HasCallStack => [Char] -> a
error [Char]
"runFeedingServer: the tests send no offers"

-- | The peer's client: keep the node's server's pipeline full, and record each
-- notification it relays.
runRecordingClient ::
  forall s.
  LeiosNotifyCodec s ->
  StrictTVar (IOSim s) [(Time, Notification)] ->
  Channel (IOSim s) BSL.ByteString ->
  IOSim s ()
runRecordingClient :: forall s.
LeiosNotifyCodec s
-> StrictTVar (IOSim s) [(Time, Notification)]
-> Channel (IOSim s) ByteString
-> IOSim s ()
runRecordingClient LeiosNotifyCodec s
c StrictTVar (IOSim s) [(Time, Notification)]
received Channel (IOSim s) ByteString
chan =
  ((), Maybe ByteString) -> ()
forall a b. (a, b) -> a
fst
    (((), Maybe ByteString) -> ())
-> IOSim s ((), Maybe ByteString) -> IOSim s ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tracer
  (IOSim s)
  (TraceSendRecv
     (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote))
-> LeiosNotifyCodec s
-> ProtocolSizeLimits
     (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote)
     ByteString
-> ProtocolTimeLimits
     (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote)
-> Channel (IOSim s) ByteString
-> PeerPipelined
     (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote)
     'AsClient
     'StIdle
     (IOSim s)
     ()
-> IOSim s ((), Maybe ByteString)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadEvaluate m, MonadFork m, MonadMask m,
 MonadTimer m, MonadThrow (STM m), ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 NFData a, NFData failure, Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> PeerPipelined ps pr st m a
-> m (a, Maybe bytes)
runPipelinedPeerWithLimits
      Tracer
  (IOSim s)
  (TraceSendRecv
     (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote))
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer
      LeiosNotifyCodec s
c
      ProtocolSizeLimits
  (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote)
  ByteString
forall point announcement vote.
ProtocolSizeLimits (LeiosNotify point announcement vote) ByteString
sizeLimits
      ProtocolTimeLimits
  (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote)
forall point announcement vote.
ProtocolTimeLimits (LeiosNotify point announcement vote)
timeLimitsLeiosNotify
      Channel (IOSim s) ByteString
chan
      ( Peer
  (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote)
  'AsClient
  ('Pipelined 'Z C)
  'StIdle
  (IOSim s)
  ()
-> PeerPipelined
     (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote)
     'AsClient
     'StIdle
     (IOSim s)
     ()
forall point announcement vote (m :: * -> *) a.
Peer
  (LeiosNotify point announcement vote)
  'AsClient
  ('Pipelined 'Z C)
  'StIdle
  m
  a
-> LeiosNotifyClientPeerPipelined point announcement vote m a
toLeiosNotifyClientPeerPipelined (Peer
   (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote)
   'AsClient
   ('Pipelined 'Z C)
   'StIdle
   (IOSim s)
   ()
 -> PeerPipelined
      (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote)
      'AsClient
      'StIdle
      (IOSim s)
      ())
-> Peer
     (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote)
     'AsClient
     ('Pipelined 'Z C)
     'StIdle
     (IOSim s)
     ()
-> PeerPipelined
     (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote)
     'AsClient
     'StIdle
     (IOSim s)
     ()
forall a b. (a -> b) -> a -> b
$
          STM (IOSim s) (Either () Int)
-> IOSim
     s
     (Message
        (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote)
        'StBusy
        'StIdle
      -> IOSim s ())
-> Peer
     (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote)
     'AsClient
     ('Pipelined 'Z C)
     'StIdle
     (IOSim s)
     ()
forall (m :: * -> *) point announcement vote a.
(PrimMonad m, MonadSTM m) =>
STM m (Either a Int)
-> m (Message (LeiosNotify point announcement vote) 'StBusy 'StIdle
      -> m ())
-> Peer
     (LeiosNotify point announcement vote)
     'AsClient
     ('Pipelined 'Z C)
     'StIdle
     m
     a
leiosNotifyClientPeerPipelined (Either () Int -> STM s (Either () Int)
forall a. a -> STM s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Either () Int
forall a b. b -> Either a b
Right Int
leiosNotifyPipelineDepth)) ((Message
   (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote)
   'StBusy
   'StIdle
 -> IOSim s ())
-> IOSim
     s
     (Message
        (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote)
        'StBusy
        'StIdle
      -> IOSim s ())
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Message
  (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote)
  'StBusy
  'StIdle
-> IOSim s ()
record)
      )
 where
  record :: Message (LeiosNotify LeiosPoint (Header Blk) LeiosVote) StBusy StIdle -> IOSim s ()
  record :: Message
  (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote)
  'StBusy
  'StIdle
-> IOSim s ()
record Message
  (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote)
  'StBusy
  'StIdle
msg = do
    now <- IOSim s Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
    let n = case Message
  (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote)
  'StBusy
  'StIdle
msg of
          MsgLeiosBlockAnnouncement Header LeiosTestBlock
hdr -> Header LeiosTestBlock -> Notification
NotifyAnnouncement Header LeiosTestBlock
hdr
          MsgLeiosVotes NonEmpty LeiosVote
vs -> NonEmpty LeiosVote -> Notification
NotifyVotes NonEmpty LeiosVote
vs
          Message
  (LeiosNotify LeiosPoint (Header LeiosTestBlock) LeiosVote)
  'StBusy
  'StIdle
_ -> Notification
NotifyOther
    atomically $ modifyTVar received ((now, n) :)

sizeLimits :: ProtocolSizeLimits (LeiosNotify point announcement vote) BSL.ByteString
sizeLimits :: forall point announcement vote.
ProtocolSizeLimits (LeiosNotify point announcement vote) ByteString
sizeLimits = (ByteString -> Word)
-> ProtocolSizeLimits
     (LeiosNotify point announcement vote) ByteString
forall bytes point announcement vote.
(bytes -> Word)
-> ProtocolSizeLimits (LeiosNotify point announcement vote) bytes
byteLimitsLeiosNotify (Int64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word) -> (ByteString -> Int64) -> ByteString -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BSL.length)

-- | How long the node takes to verify a vote, beyond what verifying takes in the
-- simulation, which is no time at all.
newtype VerifyingTime = VerifyingTime DiffTime

-- | A node of the committee 'committee', with the periods of 'leiosLedgerView'.
withNode :: VerifyingTime -> (NodeUnderTest (IOSim s) -> IOSim s a) -> IOSim s a
withNode :: forall s a.
VerifyingTime
-> (NodeUnderTest (IOSim s) -> IOSim s a) -> IOSim s a
withNode (VerifyingTime DiffTime
verifying) NodeUnderTest (IOSim s) -> IOSim s a
body = do
  nodeDBs <- IOSim s (NodeDBs (StrictTMVar (IOSim s) MockFS))
forall (m :: * -> *).
MonadSTM m =>
m (NodeDBs (StrictTMVar m MockFS))
emptyNodeDBs
  leiosDB <- newLeiosDBInMemory
  withNodeUnderTest (defaultNodeUnderTestConfig k ledgerConfig) tracers nodeDBs leiosDB body
 where
  tracers :: Tracers
  (IOSim s) (ConnectionId PeerAddr) (ConnectionId ()) LeiosTestBlock
tracers =
    Tracers
  (IOSim s) (ConnectionId PeerAddr) (ZonkAny 0) LeiosTestBlock
forall (m :: * -> *) remotePeer localPeer blk.
Monad m =>
Tracers m remotePeer localPeer blk
nullTracers
      { leiosVoteStateTracer = mkTracer $ \case
          TraceLeiosVoteValidated LeiosVote
_ -> DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
verifying
          TraceLeiosVoteState
_ -> () -> IOSim s ()
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      }

k :: SecurityParam
k :: SecurityParam
k = NonZero Word64 -> SecurityParam
SecurityParam (NonZero Word64 -> SecurityParam)
-> NonZero Word64 -> SecurityParam
forall a b. (a -> b) -> a -> b
$ forall (n :: Natural) a.
(KnownNat n, 1 <= n, WithinBounds n a, Num a) =>
NonZero a
knownNonZeroBounded @10

-- | One-second slots, the first starting when the run begins.
ledgerConfig :: LeiosTestLedgerConfig
ledgerConfig :: LeiosTestLedgerConfig
ledgerConfig =
  LeiosTestLedgerConfig
    { ltlcHardForkParams :: EraParams
ltlcHardForkParams =
        SecurityParam -> SlotLength -> PerasEnabled () -> EraParams
HardFork.defaultEraParams SecurityParam
k (Integer -> SlotLength
slotLengthFromSec Integer
1) PerasEnabled ()
forall a. PerasEnabled a
HardFork.NoPerasEnabled
    , ltlcForecastRange :: SlotNo
ltlcForecastRange = SlotNo
100000
    , ltlcLeios :: LeiosLedgerView
ltlcLeios = LeiosLedgerView
leiosLedgerView
    }

topLevelConfig :: TopLevelConfig Blk
topLevelConfig :: TopLevelConfig LeiosTestBlock
topLevelConfig = LeiosTestLedgerConfig
-> SecurityParam -> TopLevelConfig LeiosTestBlock
singleNodeLeiosTestConfig LeiosTestLedgerConfig
ledgerConfig SecurityParam
k

{-------------------------------------------------------------------------------
  The node's announcement state on its own
-------------------------------------------------------------------------------}

-- | What the node relays of a valid announcement of an election that its
-- announcement state pruned while the announcement was validated.
prunedWhileValidating :: [()]
prunedWhileValidating :: [()]
prunedWhileValidating = (forall s. IOSim s [()]) -> [()]
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((forall s. IOSim s [()]) -> [()])
-> (forall s. IOSim s [()]) -> [()]
forall a b. (a -> b) -> a -> b
$ do
  notifyLog <- IOSim s (NotifyLog (IOSim s) LeiosTestBlock)
forall (m :: * -> *) blk.
(IOLike m, NoThunks (Header blk)) =>
m (NotifyLog m blk)
newNotifyLog
  st <- newAnnounceState notifyLog
  atomically $ pruneAnnounceState st (blockSlot someAnnouncingBlock + 1)
  atomically $ onValidAnnouncement st valid
  atomically $ ([()] <$ nextNotifyLog notifyLog notifyLogStart) `orElse` pure []
 where
  valid :: ValidAnnouncement LeiosTestBlock
valid =
    MkValidAnnouncement
      { announcingHeader :: AnnouncingHeader LeiosTestBlock
announcingHeader =
          AnnouncingHeader LeiosTestBlock
-> Maybe (AnnouncingHeader LeiosTestBlock)
-> AnnouncingHeader LeiosTestBlock
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> AnnouncingHeader LeiosTestBlock
forall a. HasCallStack => [Char] -> a
error [Char]
"prunedWhileValidating: an announcement") (Maybe (AnnouncingHeader LeiosTestBlock)
 -> AnnouncingHeader LeiosTestBlock)
-> Maybe (AnnouncingHeader LeiosTestBlock)
-> AnnouncingHeader LeiosTestBlock
forall a b. (a -> b) -> a -> b
$
            TopLevelConfig LeiosTestBlock
-> Header LeiosTestBlock -> Maybe (AnnouncingHeader LeiosTestBlock)
forall blk.
BlockSupportsProtocol blk =>
TopLevelConfig blk -> Header blk -> Maybe (AnnouncingHeader blk)
mkAnnouncingHeader TopLevelConfig LeiosTestBlock
topLevelConfig (LeiosTestBlock -> Header LeiosTestBlock
ltbHeader LeiosTestBlock
someAnnouncingBlock)
      , announcementOnset :: RelativeTime
announcementOnset = NominalDiffTime -> RelativeTime
RelativeTime NominalDiffTime
1
      , announcementAge :: NominalDiffTime
announcementAge = NominalDiffTime
0
      , announcementStaleness :: OCINStaleness
announcementStaleness = OCINStaleness
FreshOCIN
      }

-- | The log's notifications once pruned at the given time, of entries worth
-- relaying until the given times, each a vote of the seat its name stands for.
notifyLogAt :: [(NominalDiffTime, Char)] -> NominalDiffTime -> String
notifyLogAt :: [(NominalDiffTime, Char)] -> NominalDiffTime -> [Char]
notifyLogAt [(NominalDiffTime, Char)]
appends NominalDiffTime
now = (forall s. IOSim s [Char]) -> [Char]
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((forall s. IOSim s [Char]) -> [Char])
-> (forall s. IOSim s [Char]) -> [Char]
forall a b. (a -> b) -> a -> b
$ do
  notifyLog <- forall (m :: * -> *) blk.
(IOLike m, NoThunks (Header blk)) =>
m (NotifyLog m blk)
newNotifyLog @_ @Blk
  for_ appends $ \(NominalDiffTime
expires, Char
name) ->
    STM (IOSim s) () -> IOSim s ()
forall a. HasCallStack => STM (IOSim s) a -> IOSim s a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM (IOSim s) () -> IOSim s ()) -> STM (IOSim s) () -> IOSim s ()
forall a b. (a -> b) -> a -> b
$
      NotifyLog (IOSim s) LeiosTestBlock
-> Notification LeiosTestBlock -> RelativeTime -> STM (IOSim s) ()
forall (m :: * -> *) blk.
IOLike m =>
NotifyLog m blk -> Notification blk -> RelativeTime -> STM m ()
appendNotifyLog
        NotifyLog (IOSim s) LeiosTestBlock
notifyLog
        (LeiosVote -> Notification LeiosTestBlock
forall blk. LeiosVote -> Notification blk
NotifyLog.NotifyVote (LeiosTestBlock -> Word16 -> LeiosVote
voteOf LeiosTestBlock
someAnnouncingBlock (Char -> Word16
seatOf Char
name)))
        (NominalDiffTime -> RelativeTime
RelativeTime NominalDiffTime
expires)
  atomically $ pruneNotifyLog notifyLog (RelativeTime now)
  atomically $ map nameOf <$> notifyLogNotifications notifyLog

-- | The log's notifications, of entries worth relaying until the given times,
-- appended once it was pruned at the given time.
notifyLogPrunedAt :: NominalDiffTime -> [(NominalDiffTime, Char)] -> String
notifyLogPrunedAt :: NominalDiffTime -> [(NominalDiffTime, Char)] -> [Char]
notifyLogPrunedAt NominalDiffTime
now [(NominalDiffTime, Char)]
appends = (forall s. IOSim s [Char]) -> [Char]
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((forall s. IOSim s [Char]) -> [Char])
-> (forall s. IOSim s [Char]) -> [Char]
forall a b. (a -> b) -> a -> b
$ do
  notifyLog <- forall (m :: * -> *) blk.
(IOLike m, NoThunks (Header blk)) =>
m (NotifyLog m blk)
newNotifyLog @_ @Blk
  atomically $ pruneNotifyLog notifyLog (RelativeTime now)
  for_ appends $ \(NominalDiffTime
expires, Char
name) ->
    STM (IOSim s) () -> IOSim s ()
forall a. HasCallStack => STM (IOSim s) a -> IOSim s a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM (IOSim s) () -> IOSim s ()) -> STM (IOSim s) () -> IOSim s ()
forall a b. (a -> b) -> a -> b
$
      NotifyLog (IOSim s) LeiosTestBlock
-> Notification LeiosTestBlock -> RelativeTime -> STM (IOSim s) ()
forall (m :: * -> *) blk.
IOLike m =>
NotifyLog m blk -> Notification blk -> RelativeTime -> STM m ()
appendNotifyLog
        NotifyLog (IOSim s) LeiosTestBlock
notifyLog
        (LeiosVote -> Notification LeiosTestBlock
forall blk. LeiosVote -> Notification blk
NotifyLog.NotifyVote (LeiosTestBlock -> Word16 -> LeiosVote
voteOf LeiosTestBlock
someAnnouncingBlock (Char -> Word16
seatOf Char
name)))
        (NominalDiffTime -> RelativeTime
RelativeTime NominalDiffTime
expires)
  atomically $ map nameOf <$> notifyLogNotifications notifyLog

-- | The node relays a notification at most 'notifyLogPruneCadence' after it is
-- no longer worth relaying, which must leave a downstream peer's grace for
-- transmission and queueing: 'voteLateGrace' for a vote, and the margin between
-- 'maxAnnouncementAgeSend' and 'maxAnnouncementAgeRecv' for an announcement.
prop_notifyLogPruneCadence :: Property
prop_notifyLogPruneCadence :: Property
prop_notifyLogPruneCadence =
  Property -> Property
forall prop. Testable prop => prop -> Property
once (Property -> Property)
-> ([Property] -> Property) -> [Property] -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin ([Property] -> Property) -> [Property] -> Property
forall a b. (a -> b) -> a -> b
$
    [ [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
"the vote grace" (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
        NominalDiffTime
notifyLogPruneCadence NominalDiffTime -> NominalDiffTime -> Bool
forall {a}. (Ord a, Num a) => a -> a -> Bool
`farBelow` NominalDiffTime
voteLateGrace
    , [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
"the announcement grace" (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
        NominalDiffTime
notifyLogPruneCadence NominalDiffTime -> NominalDiffTime -> Bool
forall {a}. (Ord a, Num a) => a -> a -> Bool
`farBelow` (NominalDiffTime
maxAnnouncementAgeRecv NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
- NominalDiffTime
maxAnnouncementAgeSend)
    ]
 where
  farBelow :: a -> a -> Bool
farBelow a
a a
b = a
10 a -> a -> a
forall a. Num a => a -> a -> a
* a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
b

-- | The seat a name stands for in a log, 'a' for seat 0.
seatOf :: Char -> Word16
seatOf :: Char -> Word16
seatOf Char
name = Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
name Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'a')

-- | The name of the seat of a vote in a log.
nameOf :: NotifyLog.Notification Blk -> Char
nameOf :: Notification LeiosTestBlock -> Char
nameOf = \case
  NotifyLog.NotifyVote LeiosVote
v -> Int -> Char
forall a. Enum a => Int -> a
toEnum (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'a' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (LeiosSeatId -> Word16
leiosSeatIndex (LeiosVote -> LeiosSeatId
voteSeatId LeiosVote
v)))
  NotifyLog.NotifyAnnouncement AnnouncingHeader LeiosTestBlock
_ -> Char
'?'

-- | Every notification in the log.
notifyLogNotifications :: NotifyLog (IOSim s) Blk -> STM (IOSim s) [NotifyLog.Notification Blk]
notifyLogNotifications :: forall s.
NotifyLog (IOSim s) LeiosTestBlock
-> STM (IOSim s) [Notification LeiosTestBlock]
notifyLogNotifications NotifyLog (IOSim s) LeiosTestBlock
notifyLog = NotifyCursor -> STM (IOSim s) [Notification LeiosTestBlock]
go NotifyCursor
notifyLogStart
 where
  go :: NotifyCursor -> STM (IOSim s) [Notification LeiosTestBlock]
go NotifyCursor
cursor =
    (NotifyLog (IOSim s) LeiosTestBlock
-> NotifyCursor
-> STM (IOSim s) (Notification LeiosTestBlock, NotifyCursor)
forall (m :: * -> *) blk.
IOLike m =>
NotifyLog m blk
-> NotifyCursor -> STM m (Notification blk, NotifyCursor)
nextNotifyLog NotifyLog (IOSim s) LeiosTestBlock
notifyLog NotifyCursor
cursor STM (IOSim s) (Notification LeiosTestBlock, NotifyCursor)
-> ((Notification LeiosTestBlock, NotifyCursor)
    -> STM (IOSim s) [Notification LeiosTestBlock])
-> STM (IOSim s) [Notification LeiosTestBlock]
forall a b.
STM (IOSim s) a -> (a -> STM (IOSim s) b) -> STM (IOSim s) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Notification LeiosTestBlock
n, NotifyCursor
cursor') -> (Notification LeiosTestBlock
n Notification LeiosTestBlock
-> [Notification LeiosTestBlock] -> [Notification LeiosTestBlock]
forall a. a -> [a] -> [a]
:) ([Notification LeiosTestBlock] -> [Notification LeiosTestBlock])
-> STM (IOSim s) [Notification LeiosTestBlock]
-> STM (IOSim s) [Notification LeiosTestBlock]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NotifyCursor -> STM (IOSim s) [Notification LeiosTestBlock]
go NotifyCursor
cursor')
      STM (IOSim s) [Notification LeiosTestBlock]
-> STM (IOSim s) [Notification LeiosTestBlock]
-> STM (IOSim s) [Notification LeiosTestBlock]
forall a. STM (IOSim s) a -> STM (IOSim s) a -> STM (IOSim s) a
forall (m :: * -> *) a. MonadSTM m => STM m a -> STM m a -> STM m a
`orElse` [Notification LeiosTestBlock]
-> STM s [Notification LeiosTestBlock]
forall a. a -> STM s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

{-------------------------------------------------------------------------------
  Fixtures
-------------------------------------------------------------------------------}

-- | The committee 'committee'. A vote is relayed between 3 s and 7 s after its
-- election slot began.
leiosLedgerView :: LeiosLedgerView
leiosLedgerView :: LeiosLedgerView
leiosLedgerView =
  MkLeiosLedgerView
    { llvCommittee :: LeiosCommittee
llvCommittee = LeiosCommittee
committee
    , llvQuorumStakeThreshold :: UnitInterval
llvQuorumStakeThreshold = UnitInterval
forall a. Bounded a => a
maxBound
    , llvAnnouncementPeriod :: Milliseconds32
llvAnnouncementPeriod = Word32 -> Milliseconds32
Milliseconds32 Word32
1000
    , llvVotePeriod :: Milliseconds32
llvVotePeriod = Word32 -> Milliseconds32
Milliseconds32 Word32
4000
    , llvDiffusionPeriod :: Milliseconds32
llvDiffusionPeriod = Word32 -> Milliseconds32
Milliseconds32 Word32
1000
    , llvMaxEbBodySize :: Word32
llvMaxEbBodySize = Word32
5000
    , llvMaxEbTxsSize :: Word32
llvMaxEbTxsSize = Word32
5000
    }

-- | Three seats with keys, then one without a key and one whose key's proof of
-- possession does not verify.
seatKeys :: [LeiosSigningKey]
committee :: LeiosCommittee
([LeiosSigningKey]
seatKeys, LeiosCommittee
committee) =
  [(TestSeatType, Rational)] -> ([LeiosSigningKey], LeiosCommittee)
mkCommitteeFromTestSeats [(TestSeatType
kind, Integer
1 Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
5) | TestSeatType
kind <- [TestSeatType
WithKey, TestSeatType
WithKey, TestSeatType
WithKey, TestSeatType
NoKey, TestSeatType
BadPoP]]

seatNoKey, seatBadPoP, seatOutside :: Word16
seatNoKey :: Word16
seatNoKey = Word16
3
seatBadPoP :: Word16
seatBadPoP = Word16
4
seatOutside :: Word16
seatOutside = Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (LeiosCommittee -> Int
leiosCommitteeSize LeiosCommittee
committee)

-- | The vote of this seat for the announcement this block carries, signed with
-- the seat's key.
vote :: LeiosTestBlock -> Word16 -> Notification
vote :: LeiosTestBlock -> Word16 -> Notification
vote LeiosTestBlock
blk Word16
seat = NonEmpty LeiosVote -> Notification
NotifyVotes (LeiosTestBlock -> Word16 -> LeiosVote
voteOf LeiosTestBlock
blk Word16
seat LeiosVote -> [LeiosVote] -> NonEmpty LeiosVote
forall a. a -> [a] -> NonEmpty a
:| [])

-- | As 'vote', but signed with a key of no seat.
badlySignedVote :: LeiosTestBlock -> Word16 -> Notification
badlySignedVote :: LeiosTestBlock -> Word16 -> Notification
badlySignedVote LeiosTestBlock
blk Word16
seat = NonEmpty LeiosVote -> Notification
NotifyVotes (LeiosSigningKey -> LeiosTestBlock -> Word16 -> LeiosVote
signedBy ([LeiosSigningKey] -> LeiosSigningKey
forall a. HasCallStack => [a] -> a
last [LeiosSigningKey]
seatKeys') LeiosTestBlock
blk Word16
seat LeiosVote -> [LeiosVote] -> NonEmpty LeiosVote
forall a. a -> [a] -> NonEmpty a
:| [])
 where
  ([LeiosSigningKey]
seatKeys', LeiosCommittee
_) = [(TestSeatType, Rational)] -> ([LeiosSigningKey], LeiosCommittee)
mkCommitteeFromTestSeats [(TestSeatType
WithKey, Rational
1) | Int
_ <- [Int
0 .. LeiosCommittee -> Int
leiosCommitteeSize LeiosCommittee
committee Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1]]

signedBy :: LeiosSigningKey -> LeiosTestBlock -> Word16 -> LeiosVote
signedBy :: LeiosSigningKey -> LeiosTestBlock -> Word16 -> LeiosVote
signedBy LeiosSigningKey
sk LeiosTestBlock
blk Word16
seat =
  MkLeiosVote
    { voteAnnouncingRbHash :: RankingBlockHash
voteAnnouncingRbHash = RankingBlockHash
rbHash
    , voteSeatId :: LeiosSeatId
voteSeatId = Word16 -> LeiosSeatId
LeiosSeatId Word16
seat
    , voteSignature :: LeiosSignature
voteSignature = ContextDSIGN LeiosDSIGN
-> RankingBlockHash -> LeiosSigningKey -> LeiosSignature
forall v a.
(DSIGNAlgorithm v, Signable v a, HasCallStack) =>
ContextDSIGN v -> a -> SignKeyDSIGN v -> SigDSIGN v
forall a.
(Signable LeiosDSIGN a, HasCallStack) =>
ContextDSIGN LeiosDSIGN -> a -> LeiosSigningKey -> LeiosSignature
signDSIGN ContextDSIGN LeiosDSIGN
BLS12381SignContext
leiosSignContext RankingBlockHash
rbHash LeiosSigningKey
sk
    }
 where
  rbHash :: RankingBlockHash
rbHash = Header LeiosTestBlock -> RankingBlockHash
rbHashOf (LeiosTestBlock -> Header LeiosTestBlock
ltbHeader LeiosTestBlock
blk)

announce :: LeiosTestBlock -> (DiffTime, Notification)
announce :: LeiosTestBlock -> (DiffTime, Notification)
announce = DiffTime -> LeiosTestBlock -> (DiffTime, Notification)
announceAt DiffTime
0

announceAt :: DiffTime -> LeiosTestBlock -> (DiffTime, Notification)
announceAt :: DiffTime -> LeiosTestBlock -> (DiffTime, Notification)
announceAt DiffTime
at LeiosTestBlock
blk = (DiffTime
at, Header LeiosTestBlock -> Notification
NotifyAnnouncement (LeiosTestBlock -> Header LeiosTestBlock
ltbHeader LeiosTestBlock
blk))

rbHashOf :: Header Blk -> RankingBlockHash
rbHashOf :: Header LeiosTestBlock -> RankingBlockHash
rbHashOf = Proxy LeiosTestBlock
-> HeaderHash LeiosTestBlock -> RankingBlockHash
forall blk.
ConvertRawHash blk =>
Proxy blk -> HeaderHash blk -> RankingBlockHash
toRankingBlockHash (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @LeiosTestBlock) (TestHash -> RankingBlockHash)
-> (Header LeiosTestBlock -> TestHash)
-> Header LeiosTestBlock
-> RankingBlockHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header LeiosTestBlock -> HeaderHash (Header LeiosTestBlock)
Header LeiosTestBlock -> TestHash
forall b. HasHeader b => b -> HeaderHash b
blockHash

-- | Announces an endorser block in slot 1.
someAnnouncingBlock :: LeiosTestBlock
someAnnouncingBlock :: LeiosTestBlock
someAnnouncingBlock = EndorserBlockHash -> Word32 -> LeiosTestBlock -> LeiosTestBlock
setAnnouncement (ShortByteString -> EndorserBlockHash
forall h a.
(HashAlgorithm h, HasCallStack) =>
ShortByteString -> Hash h a
UnsafeHash (Int -> Word8 -> ShortByteString
SBS.replicate Int
32 Word8
1)) Word32
1000 (Word64 -> LeiosTestBlock
firstLeiosBlock Word64
0)

-- | Another announcement in the election of 'someAnnouncingBlock'.
equivocation :: LeiosTestBlock
equivocation :: LeiosTestBlock
equivocation = EndorserBlockHash -> Word32 -> LeiosTestBlock -> LeiosTestBlock
setAnnouncement (ShortByteString -> EndorserBlockHash
forall h a.
(HashAlgorithm h, HasCallStack) =>
ShortByteString -> Hash h a
UnsafeHash (Int -> Word8 -> ShortByteString
SBS.replicate Int
32 Word8
2)) Word32
1000 (LeiosTestBlock -> LeiosTestBlock
forkLeiosBlock (Word64 -> LeiosTestBlock
firstLeiosBlock Word64
0))

-- | A third announcement in the election of 'someAnnouncingBlock'.
thirdAnnouncement :: LeiosTestBlock
thirdAnnouncement :: LeiosTestBlock
thirdAnnouncement =
  EndorserBlockHash -> Word32 -> LeiosTestBlock -> LeiosTestBlock
setAnnouncement
    (ShortByteString -> EndorserBlockHash
forall h a.
(HashAlgorithm h, HasCallStack) =>
ShortByteString -> Hash h a
UnsafeHash (Int -> Word8 -> ShortByteString
SBS.replicate Int
32 Word8
3))
    Word32
1000
    (LeiosTestBlock -> LeiosTestBlock
forkLeiosBlock (LeiosTestBlock -> LeiosTestBlock
forkLeiosBlock (Word64 -> LeiosTestBlock
firstLeiosBlock Word64
0)))

-- | Announces an endorser block in slot 349.
lateAnnouncingBlock :: LeiosTestBlock
lateAnnouncingBlock :: LeiosTestBlock
lateAnnouncingBlock = EndorserBlockHash -> Word32 -> LeiosTestBlock -> LeiosTestBlock
setAnnouncement (ShortByteString -> EndorserBlockHash
forall h a.
(HashAlgorithm h, HasCallStack) =>
ShortByteString -> Hash h a
UnsafeHash (Int -> Word8 -> ShortByteString
SBS.replicate Int
32 Word8
4)) Word32
1000 (SlotNo -> LeiosTestBlock -> LeiosTestBlock
setSlot SlotNo
349 (Word64 -> LeiosTestBlock
firstLeiosBlock Word64
1))