{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | Tests for the chain sync client.
--
-- The chain sync client is a stateful component that tracks the chain of an
-- upstream peer. It validates the headers that it receives from the peer;
-- validated headers are then reported to the block fetch client which will
-- download them and offer them to the chain DB, which makes the final choice
-- whether or not to adopt those blocks.
--
-- The tests mock a series of state changes of the up-stream node as well as the
-- node's own state (the node's own state is relevant because if the node and the
-- up-stream peer diverge too much we are not interested in their chain anymore,
-- and we might not be able to validate their headers). We then check that the
-- chain sync client is reporting the right exceptions if and only if we expect
-- them to be thrown based on the mock state changes (exceptions such as
-- "fork is deep", "up-stream node asked for an invalid rollback", etc.).
--
-- The client's (simulated) wall-clock matters in this test because the
-- ChainSync client has special handling for headers that arrive before the
-- wall-clock reaches the onset of the header's claimed slot, which is
-- inevitable even with only honest peers due to non-global clocks
-- drifting/etc. This test advances time in a way that is unrealistic but does
-- allow for some headers to arrive early (but not so early that the client
-- disconnects from the server).
--
-- The approach to the clocks is as follows. A logical clock drives the whole
-- test; it ticks along the naturals. Each tick causes the local and upstream
-- chains to update and that's the primary content of the whole test. However,
-- the /first/ thing that happens at the start of each logical tick is the
-- client's simulated wall-clock advances (via a single 'threadDelay' call) to
-- the onset of the greatest slot involved in any of that logical tick's
-- server-side chain updates /less/ the randomly-chosen local clock skew. Thus,
-- if the greatest header involved in some logical tick is part of an upstream
-- chain update, then it will arrive as a future header (but only near-future,
-- never far-future). (Client-side updates are also handled, but slightly
-- differently; see the code comments.) Finally, recall that the @io-sim@ layer
-- means those delays happen nearly instantaneously with respect to the real
-- world wall-clock.
module Test.Consensus.MiniProtocol.ChainSync.Client (tests) where

import           Cardano.Crypto.DSIGN.Mock
import           Cardano.Slotting.Slot (WithOrigin (..))
import           Control.Monad (forM_, unless, void, when)
import           Control.Monad.Class.MonadThrow (Handler (..), catches)
import           Control.Monad.Class.MonadTime (MonadTime, getCurrentTime)
import           Control.Monad.Class.MonadTimer (MonadTimer)
import           Control.Monad.IOSim (runSimOrThrow)
import           Control.ResourceRegistry
import           Control.Tracer (contramap, contramapM, nullTracer)
import           Data.DerivingVia (InstantiatedAt (InstantiatedAt))
import           Data.List as List (foldl', intercalate)
import qualified Data.Map.Merge.Strict as Map
import qualified Data.Map.Strict as Map
import           Data.Maybe (fromMaybe, isJust)
import           Data.Semigroup (Max (Max), getMax)
import qualified Data.Set as Set
import           Data.Time (NominalDiffTime, diffUTCTime)
import           Data.Typeable
import           GHC.Generics (Generic)
import           Network.TypedProtocol.Channel
import           Network.TypedProtocol.Driver.Simple
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.BlockchainTime
import           Ouroboros.Consensus.Config
import qualified Ouroboros.Consensus.HardFork.History as HardFork
import           Ouroboros.Consensus.HeaderStateHistory
                     (HeaderStateHistory (..))
import qualified Ouroboros.Consensus.HeaderStateHistory as HeaderStateHistory
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.Extended hiding (ledgerState)
import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
                     (CSJConfig (..), ChainDbView (..),
                     ChainSyncClientException, ChainSyncClientResult (..),
                     ChainSyncLoPBucketConfig (..), ChainSyncState (..),
                     ChainSyncStateView (..), ConfigEnv (..), Consensus,
                     DynamicEnv (..), Our (..), Their (..),
                     TraceChainSyncClientEvent (..), bracketChainSyncClient,
                     chainSyncClient, chainSyncStateFor, viewChainSyncState)
import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck
                     (HistoricityCheck, HistoricityCutoff (..))
import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck as HistoricityCheck
import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck
                     (ClockSkew, clockSkewInSeconds, unClockSkew)
import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck as InFutureCheck
import           Ouroboros.Consensus.Node.GsmState (GsmState (Syncing))
import           Ouroboros.Consensus.Node.NetworkProtocolVersion
                     (NodeToNodeVersion)
import           Ouroboros.Consensus.Node.ProtocolInfo
import           Ouroboros.Consensus.NodeId
import           Ouroboros.Consensus.Protocol.BFT
import           Ouroboros.Consensus.Util (lastMaybe, whenJust)
import           Ouroboros.Consensus.Util.Condense
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.STM (Fingerprint (..),
                     WithFingerprint (..))
import           Ouroboros.Consensus.Util.Time (multipleNominalDelay,
                     nominalDelay)
import           Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as AF
import           Ouroboros.Network.Block (getTipPoint)
import           Ouroboros.Network.ControlMessage (ControlMessage (..))
import           Ouroboros.Network.Mock.Chain (Chain (Genesis))
import qualified Ouroboros.Network.Mock.Chain as Chain
import           Ouroboros.Network.Mock.ProducerState (chainState,
                     initChainProducerState)
import qualified Ouroboros.Network.Mock.ProducerState as CPS
import           Ouroboros.Network.Protocol.ChainSync.ClientPipelined
import           Ouroboros.Network.Protocol.ChainSync.Codec (codecChainSyncId)
import           Ouroboros.Network.Protocol.ChainSync.Examples
import           Ouroboros.Network.Protocol.ChainSync.PipelineDecision
                     (pipelineDecisionLowHighMark)
import           Ouroboros.Network.Protocol.ChainSync.Server
import           Ouroboros.Network.Protocol.ChainSync.Type (ChainSync)
import           Quiet (Quiet (..))
import           Test.QuickCheck
import           Test.Tasty
import           Test.Tasty.QuickCheck
import           Test.Util.ChainUpdates (ChainUpdate (..), UpdateBehavior (..),
                     genChainUpdates, toChainUpdates)
import           Test.Util.LogicalClock (Tick (..))
import           Test.Util.Orphans.Arbitrary ()
import           Test.Util.Orphans.IOLike ()
import           Test.Util.Schedule (Schedule (..), genSchedule, joinSchedule,
                     lastTick, shrinkSchedule)
import qualified Test.Util.TestBlock as TestBlock
import           Test.Util.TestBlock
import           Test.Util.Tracer (recordingTracerTVar)

{-------------------------------------------------------------------------------
  Top-level tests
-------------------------------------------------------------------------------}

tests :: TestTree
tests :: TestTree
tests = String -> [TestTree] -> TestTree
testGroup String
"ChainSyncClient"
    [ String -> (ChainSyncClientSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"chainSync" ChainSyncClientSetup -> Property
prop_chainSync
    ]

{-------------------------------------------------------------------------------
  Main property
-------------------------------------------------------------------------------}

prop_chainSync :: ChainSyncClientSetup -> Property
prop_chainSync :: ChainSyncClientSetup -> Property
prop_chainSync testSetup :: ChainSyncClientSetup
testSetup@ChainSyncClientSetup {
    SecurityParam
securityParam :: SecurityParam
securityParam :: ChainSyncClientSetup -> SecurityParam
securityParam
  , ClientUpdates
clientUpdates :: ClientUpdates
clientUpdates :: ChainSyncClientSetup -> ClientUpdates
clientUpdates
  , ServerUpdates
serverUpdates :: ServerUpdates
serverUpdates :: ChainSyncClientSetup -> ServerUpdates
serverUpdates
  , Tick
startTick :: Tick
startTick :: ChainSyncClientSetup -> Tick
startTick
  , InvalidBlocks
invalidBlocks :: InvalidBlocks
invalidBlocks :: ChainSyncClientSetup -> InvalidBlocks
invalidBlocks
  , SlotLengthTenths
clientSlowBy :: SlotLengthTenths
clientSlowBy :: ChainSyncClientSetup -> SlotLengthTenths
clientSlowBy
  } =
    String -> [String] -> Property -> Property
forall prop.
Testable prop =>
String -> [String] -> prop -> Property
tabulate String
"TickArrivalTimeStats" [TickArrivalTimeStats ZOM -> String
forall a. Show a => a -> String
show ([TraceEvent] -> TickArrivalTimeStats ZOM
tickArrivalTimeStats [TraceEvent]
traceEvents)] (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (ChainSyncClientSetup -> String
prettyChainSyncClientSetup ChainSyncClientSetup
testSetup) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
    (String
"Client chain: "     String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Chain TestBlock -> String
ppChain Chain TestBlock
finalClientChain  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
     String
"Server chain: "     String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Chain TestBlock -> String
ppChain Chain TestBlock
finalServerChain  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
     String
"Synced fragment: "  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> AnchoredFragment TestBlock -> String
ppFragment AnchoredFragment TestBlock
syncedFragment String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
     String
"Trace:\n"           String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unlines ((TraceEvent -> String) -> [TraceEvent] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map TraceEvent -> String
ppTraceEvent [TraceEvent]
traceEvents)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    -- If an exception has been thrown, we check that it was right to throw
    -- it, but not the other way around: we don't check whether a situation
    -- has occured where an exception should have been thrown, but wasn't.
    case Maybe ChainSyncClientTestResult
mbResult of
      Just (ClientFinished (ForkTooDeep Point blk
intersection Our (Tip blk)
_ Their (Tip blk)
_))     ->
        String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
label String
"ForkTooDeep" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"ForkTooDeep intersection: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Point blk -> String
forall blk. StandardHash blk => Point blk -> String
ppPoint Point blk
intersection) (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
        Bool -> Bool
not (Point blk -> AnchoredFragment TestBlock -> Bool
forall blk blk'.
(HasHeader blk, Typeable blk') =>
Point blk -> AnchoredFragment blk' -> Bool
withinFragmentBounds Point blk
intersection AnchoredFragment TestBlock
clientFragment)
      Just (ClientFinished (NoMoreIntersection (Our Tip blk
ourTip) (Their Tip blk
theirTip))) ->
        String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
label String
"NoMoreIntersection" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"NoMoreIntersection ourHead: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Point blk -> String
forall blk. StandardHash blk => Point blk -> String
ppPoint (Tip blk -> Point blk
forall {k} (b :: k). Tip b -> Point b
getTipPoint Tip blk
ourTip) String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
                        String
", theirHead: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Point blk -> String
forall blk. StandardHash blk => Point blk -> String
ppPoint (Tip blk -> Point blk
forall {k} (b :: k). Tip b -> Point b
getTipPoint Tip blk
theirTip)) (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
        Bool -> Bool
not (AnchoredFragment TestBlock
clientFragment AnchoredFragment TestBlock -> AnchoredFragment TestBlock -> Bool
`forksWithinK` AnchoredFragment TestBlock
syncedFragment)
      Just (ClientFinished (RolledBackPastIntersection Point blk
intersection Our (Tip blk)
_ Their (Tip blk)
_)) ->
        String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
label String
"RolledBackPastIntersection" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"RolledBackPastIntersection intersection: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Point blk -> String
forall blk. StandardHash blk => Point blk -> String
ppPoint Point blk
intersection) (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
        Bool -> Bool
not (Point blk -> AnchoredFragment TestBlock -> Bool
forall blk blk'.
(HasHeader blk, Typeable blk') =>
Point blk -> AnchoredFragment blk' -> Bool
withinFragmentBounds Point blk
intersection AnchoredFragment TestBlock
syncedFragment)
      Just (ClientFinished ChainSyncClientResult
result) ->
        String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Terminated with result: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ChainSyncClientResult -> String
forall a. Show a => a -> String
show ChainSyncClientResult
result) Bool
False
      Just (ClientThrew ChainSyncClientException
ex) ->
        String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Exception: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ChainSyncClientException -> String
forall e. Exception e => e -> String
displayException ChainSyncClientException
ex) Bool
False
      Just (ClientSelectedFutureTip FutureTip
ft) ->
        String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Client selected future tip: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FutureTip -> String
forall a. Show a => a -> String
show FutureTip
ft) Bool
False
      Maybe ChainSyncClientTestResult
Nothing ->
        String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Synced fragment not a suffix of the server chain"
        (AnchoredFragment TestBlock
syncedFragment AnchoredFragment TestBlock -> Chain TestBlock -> Property
`isSuffixOf` Chain TestBlock
finalServerChain) Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
        String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Synced fragment doesn't intersect with the client chain"
        (AnchoredFragment TestBlock
clientFragment AnchoredFragment TestBlock -> AnchoredFragment TestBlock -> Bool
`forksWithinK` AnchoredFragment TestBlock
syncedFragment) Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
        String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Synced fragment doesn't have the same anchor as the client fragment"
        (AnchoredFragment TestBlock -> Point TestBlock
forall block. AnchoredFragment block -> Point block
AF.anchorPoint AnchoredFragment TestBlock
clientFragment Point TestBlock -> Point TestBlock -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== AnchoredFragment TestBlock -> Point TestBlock
forall block. AnchoredFragment block -> Point block
AF.anchorPoint AnchoredFragment TestBlock
syncedFragment)
  where
    k :: Word64
k = SecurityParam -> Word64
maxRollbacks SecurityParam
securityParam

    ChainSyncOutcome {
        Chain TestBlock
finalClientChain :: Chain TestBlock
finalClientChain :: ChainSyncOutcome -> Chain TestBlock
finalClientChain
      , Chain TestBlock
finalServerChain :: Chain TestBlock
finalServerChain :: ChainSyncOutcome -> Chain TestBlock
finalServerChain
      , Maybe ChainSyncClientTestResult
mbResult :: Maybe ChainSyncClientTestResult
mbResult :: ChainSyncOutcome -> Maybe ChainSyncClientTestResult
mbResult
      , AnchoredFragment TestBlock
syncedFragment :: AnchoredFragment TestBlock
syncedFragment :: ChainSyncOutcome -> AnchoredFragment TestBlock
syncedFragment
      , [TraceEvent]
traceEvents :: [TraceEvent]
traceEvents :: ChainSyncOutcome -> [TraceEvent]
traceEvents
      } = (forall s. IOSim s ChainSyncOutcome) -> ChainSyncOutcome
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((forall s. IOSim s ChainSyncOutcome) -> ChainSyncOutcome)
-> (forall s. IOSim s ChainSyncOutcome) -> ChainSyncOutcome
forall a b. (a -> b) -> a -> b
$
        ClockSkew
-> SecurityParam
-> ClientUpdates
-> ServerUpdates
-> InvalidBlocks
-> Tick
-> IOSim s ChainSyncOutcome
forall (m :: * -> *).
(IOLike m, MonadTime m, MonadTimer m) =>
ClockSkew
-> SecurityParam
-> ClientUpdates
-> ServerUpdates
-> InvalidBlocks
-> Tick
-> m ChainSyncOutcome
runChainSync
          (SlotLengthTenths -> ClockSkew
slotLengthTenthsToClockSkew SlotLengthTenths
clientSlowBy)
          SecurityParam
securityParam
          ClientUpdates
clientUpdates
          ServerUpdates
serverUpdates
          InvalidBlocks
invalidBlocks
          Tick
startTick

    clientFragment :: AnchoredFragment TestBlock
clientFragment = Word64 -> AnchoredFragment TestBlock -> AnchoredFragment TestBlock
forall v a b.
Anchorable v a b =>
Word64 -> AnchoredSeq v a b -> AnchoredSeq v a b
AF.anchorNewest Word64
k (AnchoredFragment TestBlock -> AnchoredFragment TestBlock)
-> AnchoredFragment TestBlock -> AnchoredFragment TestBlock
forall a b. (a -> b) -> a -> b
$ Chain TestBlock -> AnchoredFragment TestBlock
forall block.
HasHeader block =>
Chain block -> AnchoredFragment block
Chain.toAnchoredFragment Chain TestBlock
finalClientChain

    forksWithinK
      :: AnchoredFragment TestBlock  -- ^ Our chain
      -> AnchoredFragment TestBlock  -- ^ Their chain
      -> Bool
    forksWithinK :: AnchoredFragment TestBlock -> AnchoredFragment TestBlock -> Bool
forksWithinK AnchoredFragment TestBlock
ourChain AnchoredFragment TestBlock
theirChain = case AnchoredFragment TestBlock
-> AnchoredFragment TestBlock
-> Maybe
     (AnchoredFragment TestBlock, AnchoredFragment TestBlock,
      AnchoredFragment TestBlock, AnchoredFragment TestBlock)
forall block1 block2.
(HasHeader block1, HasHeader block2,
 HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> AnchoredFragment block2
-> Maybe
     (AnchoredFragment block1, AnchoredFragment block2,
      AnchoredFragment block1, AnchoredFragment block2)
AF.intersect AnchoredFragment TestBlock
ourChain AnchoredFragment TestBlock
theirChain of
      Maybe
  (AnchoredFragment TestBlock, AnchoredFragment TestBlock,
   AnchoredFragment TestBlock, AnchoredFragment TestBlock)
Nothing -> Bool
False
      Just (AnchoredFragment TestBlock
_ourPrefix, AnchoredFragment TestBlock
_theirPrefix, AnchoredFragment TestBlock
ourSuffix, AnchoredFragment TestBlock
_theirSuffix) ->
        Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (AnchoredFragment TestBlock -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredFragment TestBlock
ourSuffix) Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
k

-- | Generalization of 'AF.withinFragmentBounds' that returns false if the
-- types don't line up
--
-- This kind of "dynamic type checking" is a bit ugly but is only necessary
-- for the tests.
withinFragmentBounds :: forall blk blk'. (HasHeader blk, Typeable blk')
                     => Point blk -> AnchoredFragment blk' -> Bool
withinFragmentBounds :: forall blk blk'.
(HasHeader blk, Typeable blk') =>
Point blk -> AnchoredFragment blk' -> Bool
withinFragmentBounds Point blk
p AnchoredFragment blk'
af =
    case forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @blk @blk' of
      Just blk :~: blk'
Refl -> Point blk -> AnchoredFragment blk -> Bool
forall block.
HasHeader block =>
Point block -> AnchoredFragment block -> Bool
AF.withinFragmentBounds Point blk
p AnchoredFragment blk
AnchoredFragment blk'
af
      Maybe (blk :~: blk')
Nothing   -> Bool
False

-- | Check whether the anchored fragment is a suffix of the chain.
isSuffixOf :: AnchoredFragment TestBlock -> Chain TestBlock -> Property
isSuffixOf :: AnchoredFragment TestBlock -> Chain TestBlock -> Property
isSuffixOf AnchoredFragment TestBlock
fragment Chain TestBlock
chain =
    Point TestBlock
fragmentAnchor Point TestBlock -> Point TestBlock -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Point TestBlock
chainAnchor Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.  [TestBlock]
fragmentBlocks [TestBlock] -> [TestBlock] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [TestBlock]
chainBlocks
  where
    nbBlocks :: Int
nbBlocks       = AnchoredFragment TestBlock -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredFragment TestBlock
fragment
    fragmentBlocks :: [TestBlock]
fragmentBlocks = AnchoredFragment TestBlock -> [TestBlock]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredFragment TestBlock
fragment
    fragmentAnchor :: Point TestBlock
fragmentAnchor = AnchoredFragment TestBlock -> Point TestBlock
forall block. AnchoredFragment block -> Point block
AF.anchorPoint AnchoredFragment TestBlock
fragment
    chainBlocks :: [TestBlock]
chainBlocks    = [TestBlock] -> [TestBlock]
forall a. [a] -> [a]
reverse ([TestBlock] -> [TestBlock]) -> [TestBlock] -> [TestBlock]
forall a b. (a -> b) -> a -> b
$ Int -> [TestBlock] -> [TestBlock]
forall a. Int -> [a] -> [a]
take Int
nbBlocks ([TestBlock] -> [TestBlock]) -> [TestBlock] -> [TestBlock]
forall a b. (a -> b) -> a -> b
$ Chain TestBlock -> [TestBlock]
forall block. Chain block -> [block]
Chain.toNewestFirst Chain TestBlock
chain
    chainAnchor :: Point TestBlock
chainAnchor    = Chain TestBlock -> Point TestBlock
forall block. HasHeader block => Chain block -> Point block
Chain.headPoint (Chain TestBlock -> Point TestBlock)
-> Chain TestBlock -> Point TestBlock
forall a b. (a -> b) -> a -> b
$ Int -> Chain TestBlock -> Chain TestBlock
forall block. Int -> Chain block -> Chain block
Chain.drop Int
nbBlocks Chain TestBlock
chain

{-------------------------------------------------------------------------------
  Infastructure to run a Chain Sync test
-------------------------------------------------------------------------------}

-- | Chain Sync Server
serverId :: CoreNodeId
serverId :: CoreNodeId
serverId = Word64 -> CoreNodeId
CoreNodeId Word64
1

-- | The schedule that determines the evolution of the local chain.
--
-- Note that the 'TestBlock' used in this test is constructed in such a way
-- that the block's slot number equals its block number.
newtype ClientUpdates =
  ClientUpdates { ClientUpdates -> Schedule ChainUpdate
getClientUpdates :: Schedule ChainUpdate }
  deriving (Int -> ClientUpdates -> String -> String
[ClientUpdates] -> String -> String
ClientUpdates -> String
(Int -> ClientUpdates -> String -> String)
-> (ClientUpdates -> String)
-> ([ClientUpdates] -> String -> String)
-> Show ClientUpdates
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ClientUpdates -> String -> String
showsPrec :: Int -> ClientUpdates -> String -> String
$cshow :: ClientUpdates -> String
show :: ClientUpdates -> String
$cshowList :: [ClientUpdates] -> String -> String
showList :: [ClientUpdates] -> String -> String
Show)

newtype ServerUpdates =
  ServerUpdates { ServerUpdates -> Schedule ChainUpdate
getServerUpdates :: Schedule ChainUpdate }
  deriving (Int -> ServerUpdates -> String -> String
[ServerUpdates] -> String -> String
ServerUpdates -> String
(Int -> ServerUpdates -> String -> String)
-> (ServerUpdates -> String)
-> ([ServerUpdates] -> String -> String)
-> Show ServerUpdates
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ServerUpdates -> String -> String
showsPrec :: Int -> ServerUpdates -> String -> String
$cshow :: ServerUpdates -> String
show :: ServerUpdates -> String
$cshowList :: [ServerUpdates] -> String -> String
showList :: [ServerUpdates] -> String -> String
Show)

-- | A 'Schedule' of events when we learn that a specific block is invalid. Note
-- that it is possible that learning that a block is invalid can precede us
-- receiving it from the ChainSync server (which models the possibility that
-- other peers already sent us that block earlier).
newtype InvalidBlocks =
  InvalidBlocks { InvalidBlocks -> Schedule TestHash
getInvalidBlocks :: Schedule TestHash }
  deriving (Int -> InvalidBlocks -> String -> String
[InvalidBlocks] -> String -> String
InvalidBlocks -> String
(Int -> InvalidBlocks -> String -> String)
-> (InvalidBlocks -> String)
-> ([InvalidBlocks] -> String -> String)
-> Show InvalidBlocks
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> InvalidBlocks -> String -> String
showsPrec :: Int -> InvalidBlocks -> String -> String
$cshow :: InvalidBlocks -> String
show :: InvalidBlocks -> String
$cshowList :: [InvalidBlocks] -> String -> String
showList :: [InvalidBlocks] -> String -> String
Show)

type TraceEvent = (Tick, RelativeTime, Either
  (TraceChainSyncClientEvent TestBlock)
  (TraceSendRecv (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))))

data ChainSyncOutcome = ChainSyncOutcome {
      ChainSyncOutcome -> Chain TestBlock
finalClientChain :: Chain TestBlock
    , ChainSyncOutcome -> Chain TestBlock
finalServerChain :: Chain TestBlock
    , ChainSyncOutcome -> AnchoredFragment TestBlock
syncedFragment   :: AnchoredFragment TestBlock
    , ChainSyncOutcome -> Maybe ChainSyncClientTestResult
mbResult         :: Maybe ChainSyncClientTestResult
    , ChainSyncOutcome -> [TraceEvent]
traceEvents      :: [TraceEvent]
    }

-- | We have a client and a server chain that both start at genesis. At
-- certain times, we apply updates to both of these chains to simulate changes
-- to the chains.
--
-- At a certain time, we start the chain sync protocol with a \"real\" chain
-- sync client and the example chain sync server. The chain sync client will
-- start to maintain a candidate fragment that is following the server chain.
-- Note that if client and/or server updates are scheduled at the same time as
-- the start of the syncing, then those updates are applied before syncing
-- starts.
--
-- Both the client and server chain will keep on receiving updates. The chain
-- sync client will keep the candidate fragment in sync with the updating
-- server chain.
--
-- At the end, we return the final chains, the synced candidate fragment, and
-- any exception thrown by the chain sync client. The candidate fragment can
-- then be compared to the actual server chain. If an exception was thrown, no
-- more chain updates are applied so the state at the time of the exception is
-- returned.
--
-- Note that updates that are scheduled before the time at which we start
-- syncing help generate different chains to start syncing from.
runChainSync ::
       forall m. (IOLike m, MonadTime m, MonadTimer m)
    => ClockSkew
    -> SecurityParam
    -> ClientUpdates
    -> ServerUpdates
    -> InvalidBlocks
    -> Tick  -- ^ Start chain syncing at this time
    -> m ChainSyncOutcome
runChainSync :: forall (m :: * -> *).
(IOLike m, MonadTime m, MonadTimer m) =>
ClockSkew
-> SecurityParam
-> ClientUpdates
-> ServerUpdates
-> InvalidBlocks
-> Tick
-> m ChainSyncOutcome
runChainSync ClockSkew
skew SecurityParam
securityParam (ClientUpdates Schedule ChainUpdate
clientUpdates)
    (ServerUpdates Schedule ChainUpdate
serverUpdates) (InvalidBlocks Schedule TestHash
invalidBlocks)
    Tick
startSyncingAt = (ResourceRegistry m -> m ChainSyncOutcome) -> m ChainSyncOutcome
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry ((ResourceRegistry m -> m ChainSyncOutcome) -> m ChainSyncOutcome)
-> (ResourceRegistry m -> m ChainSyncOutcome) -> m ChainSyncOutcome
forall a b. (a -> b) -> a -> b
$ \ResourceRegistry m
registry -> do

    SystemTime m
clientSystemTime <- do
        UTCTime
initialIoSimClockValue <- m UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
        SystemTime m -> m (SystemTime m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SystemTime {
            systemTimeWait :: m ()
systemTimeWait    = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          , systemTimeCurrent :: m RelativeTime
systemTimeCurrent = do
                UTCTime
now <- m UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
                -- Subtracting the initial @io-sim@ wall clock to create this
                -- 'RelativeTime' causes the test to behave as if the local
                -- node and the peer were invoked when the "true" wall clock
                -- (which the server's clock happens to equal) is at exactly
                -- the onset of Slot 0.
                RelativeTime -> m RelativeTime
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelativeTime -> m RelativeTime) -> RelativeTime -> m RelativeTime
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> RelativeTime
RelativeTime (NominalDiffTime -> RelativeTime)
-> NominalDiffTime -> RelativeTime
forall a b. (a -> b) -> a -> b
$
                    (UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
initialIoSimClockValue)
                  NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
-
                    ClockSkew -> NominalDiffTime
unClockSkew ClockSkew
skew
          }
    let SystemTime m
_ = SystemTime m
clientSystemTime :: SystemTime m

    StrictTVar m Tick
varCurrentLogicalTick <- Tick -> m (StrictTVar m Tick)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM (Word64 -> Tick
Tick Word64
0)

    -- Set up the client
    StrictTVar m (Chain TestBlock)
varClientState  <- Chain TestBlock -> m (StrictTVar m (Chain TestBlock))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM Chain TestBlock
forall block. Chain block
Genesis
    StrictTVar m (Maybe ChainSyncClientTestResult)
varClientResult <- Maybe ChainSyncClientTestResult
-> m (StrictTVar m (Maybe ChainSyncClientTestResult))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM Maybe ChainSyncClientTestResult
forall a. Maybe a
Nothing
    StrictTVar m (Set TestHash)
varKnownInvalid <- Set TestHash -> m (StrictTVar m (Set TestHash))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM Set TestHash
forall a. Monoid a => a
mempty
    -- Candidates are removed from the candidates map when disconnecting, so
    -- we lose access to them. Therefore, store the candidate 'TVar's in a
    -- separate map too, one that isn't emptied. We can use this map to look
    -- at the final state of each candidate.
    StrictTVar m (Map CoreNodeId (ChainSyncClientHandle m TestBlock))
varFinalCandidates <- Map CoreNodeId (ChainSyncClientHandle m TestBlock)
-> m (StrictTVar
        m (Map CoreNodeId (ChainSyncClientHandle m TestBlock)))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM Map CoreNodeId (ChainSyncClientHandle m TestBlock)
forall k a. Map k a
Map.empty
    StrictTVar m (Map CoreNodeId (ChainSyncClientHandle m TestBlock))
varHandles     <- Map CoreNodeId (ChainSyncClientHandle m TestBlock)
-> m (StrictTVar
        m (Map CoreNodeId (ChainSyncClientHandle m TestBlock)))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM Map CoreNodeId (ChainSyncClientHandle m TestBlock)
forall k a. Map k a
Map.empty

    (Tracer
  m
  (Either
     (TraceChainSyncClientEvent TestBlock)
     (TraceSendRecv
        (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))))
tracer, m [TraceEvent]
getTrace) <- do
          (Tracer m TraceEvent
tracer', m [TraceEvent]
getTrace) <- m (Tracer m TraceEvent, m [TraceEvent])
forall (m :: * -> *) ev. MonadSTM m => m (Tracer m ev, m [ev])
recordingTracerTVar
          let pairWithNow :: Either
  (TraceChainSyncClientEvent TestBlock)
  (TraceSendRecv
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))
-> m TraceEvent
pairWithNow Either
  (TraceChainSyncClientEvent TestBlock)
  (TraceSendRecv
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))
ev = do
                Tick
logicalNow <- StrictTVar m Tick -> m Tick
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar m Tick
varCurrentLogicalTick
                RelativeTime
now        <- SystemTime m -> m RelativeTime
forall (m :: * -> *). SystemTime m -> m RelativeTime
systemTimeCurrent SystemTime m
clientSystemTime
                TraceEvent -> m TraceEvent
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tick
logicalNow, RelativeTime
now, Either
  (TraceChainSyncClientEvent TestBlock)
  (TraceSendRecv
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))
ev)
          (Tracer
   m
   (Either
      (TraceChainSyncClientEvent TestBlock)
      (TraceSendRecv
         (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))),
 m [TraceEvent])
-> m (Tracer
        m
        (Either
           (TraceChainSyncClientEvent TestBlock)
           (TraceSendRecv
              (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))),
      m [TraceEvent])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Either
   (TraceChainSyncClientEvent TestBlock)
   (TraceSendRecv
      (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))
 -> m TraceEvent)
-> Tracer m TraceEvent
-> Tracer
     m
     (Either
        (TraceChainSyncClientEvent TestBlock)
        (TraceSendRecv
           (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))))
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Tracer m b -> Tracer m a
contramapM Either
  (TraceChainSyncClientEvent TestBlock)
  (TraceSendRecv
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))
-> m TraceEvent
pairWithNow Tracer m TraceEvent
tracer', m [TraceEvent]
getTrace)
    let chainSyncTracer :: Tracer m (TraceChainSyncClientEvent TestBlock)
chainSyncTracer = (TraceChainSyncClientEvent TestBlock
 -> Either
      (TraceChainSyncClientEvent TestBlock)
      (TraceSendRecv
         (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))))
-> Tracer
     m
     (Either
        (TraceChainSyncClientEvent TestBlock)
        (TraceSendRecv
           (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))))
-> Tracer m (TraceChainSyncClientEvent TestBlock)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap TraceChainSyncClientEvent TestBlock
-> Either
     (TraceChainSyncClientEvent TestBlock)
     (TraceSendRecv
        (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))
forall a b. a -> Either a b
Left  Tracer
  m
  (Either
     (TraceChainSyncClientEvent TestBlock)
     (TraceSendRecv
        (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))))
tracer
        protocolTracer :: Tracer
  m
  (TraceSendRecv
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))
protocolTracer  = (TraceSendRecv
   (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
 -> Either
      (TraceChainSyncClientEvent TestBlock)
      (TraceSendRecv
         (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))))
-> Tracer
     m
     (Either
        (TraceChainSyncClientEvent TestBlock)
        (TraceSendRecv
           (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))))
-> Tracer
     m
     (TraceSendRecv
        (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap TraceSendRecv
  (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
-> Either
     (TraceChainSyncClientEvent TestBlock)
     (TraceSendRecv
        (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))
forall a b. b -> Either a b
Right Tracer
  m
  (Either
     (TraceChainSyncClientEvent TestBlock)
     (TraceSendRecv
        (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))))
tracer

    let chainDbView :: ChainDbView m TestBlock
        chainDbView :: ChainDbView m TestBlock
chainDbView = ChainDbView
          { $sel:getCurrentChain:ChainDbView :: STM m (AnchoredFragment (Header TestBlock))
getCurrentChain =
              (TestBlock -> Header TestBlock)
-> AnchoredFragment TestBlock
-> AnchoredFragment (Header TestBlock)
forall block2 block1.
(HasHeader block2, HeaderHash block1 ~ HeaderHash block2) =>
(block1 -> block2)
-> AnchoredFragment block1 -> AnchoredFragment block2
AF.mapAnchoredFragment TestBlock -> Header TestBlock
forall ptype. TestBlockWith ptype -> Header (TestBlockWith ptype)
TestHeader (AnchoredFragment TestBlock -> AnchoredFragment (Header TestBlock))
-> (Chain TestBlock -> AnchoredFragment TestBlock)
-> Chain TestBlock
-> AnchoredFragment (Header TestBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> AnchoredFragment TestBlock -> AnchoredFragment TestBlock
forall v a b.
Anchorable v a b =>
Word64 -> AnchoredSeq v a b -> AnchoredSeq v a b
AF.anchorNewest Word64
k (AnchoredFragment TestBlock -> AnchoredFragment TestBlock)
-> (Chain TestBlock -> AnchoredFragment TestBlock)
-> Chain TestBlock
-> AnchoredFragment TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                Chain TestBlock -> AnchoredFragment TestBlock
forall block.
HasHeader block =>
Chain block -> AnchoredFragment block
Chain.toAnchoredFragment (Chain TestBlock -> AnchoredFragment (Header TestBlock))
-> STM m (Chain TestBlock)
-> STM m (AnchoredFragment (Header TestBlock))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                StrictTVar m (Chain TestBlock) -> STM m (Chain TestBlock)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Chain TestBlock)
varClientState
          , $sel:getHeaderStateHistory:ChainDbView :: STM m (HeaderStateHistory TestBlock)
getHeaderStateHistory =
              TopLevelConfig TestBlock
-> Chain TestBlock -> HeaderStateHistory TestBlock
computeHeaderStateHistory TopLevelConfig TestBlock
nodeCfg (Chain TestBlock -> HeaderStateHistory TestBlock)
-> STM m (Chain TestBlock) -> STM m (HeaderStateHistory TestBlock)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                StrictTVar m (Chain TestBlock) -> STM m (Chain TestBlock)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Chain TestBlock)
varClientState
          , $sel:getPastLedger:ChainDbView :: Point TestBlock -> STM m (Maybe (ExtLedgerState TestBlock))
getPastLedger     = \Point TestBlock
pt ->
              TopLevelConfig TestBlock
-> Point TestBlock
-> Chain TestBlock
-> Maybe (ExtLedgerState TestBlock)
computePastLedger TopLevelConfig TestBlock
nodeCfg Point TestBlock
pt (Chain TestBlock -> Maybe (ExtLedgerState TestBlock))
-> STM m (Chain TestBlock)
-> STM m (Maybe (ExtLedgerState TestBlock))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                StrictTVar m (Chain TestBlock) -> STM m (Chain TestBlock)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Chain TestBlock)
varClientState
          , $sel:getIsInvalidBlock:ChainDbView :: STM
  m
  (WithFingerprint
     (HeaderHash TestBlock -> Maybe (ExtValidationError TestBlock)))
getIsInvalidBlock = do
              Set TestHash
knownInvalid <- StrictTVar m (Set TestHash) -> STM m (Set TestHash)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Set TestHash)
varKnownInvalid
              let isInvalidBlock :: TestHash -> Maybe (ExtValidationError TestBlock)
isInvalidBlock TestHash
hash =
                    if TestHash
hash TestHash -> Set TestHash -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TestHash
knownInvalid
                    then ExtValidationError TestBlock
-> Maybe (ExtValidationError TestBlock)
forall a. a -> Maybe a
Just
                       (ExtValidationError TestBlock
 -> Maybe (ExtValidationError TestBlock))
-> (TestBlockError () -> ExtValidationError TestBlock)
-> TestBlockError ()
-> Maybe (ExtValidationError TestBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerError TestBlock -> ExtValidationError TestBlock
TestBlockError () -> ExtValidationError TestBlock
forall blk. LedgerError blk -> ExtValidationError blk
ExtValidationErrorLedger
                       (TestBlockError () -> Maybe (ExtValidationError TestBlock))
-> TestBlockError () -> Maybe (ExtValidationError TestBlock)
forall a b. (a -> b) -> a -> b
$ TestBlockError ()
forall ptype. TestBlockError ptype
TestBlock.InvalidBlock
                    else Maybe (ExtValidationError TestBlock)
forall a. Maybe a
Nothing
                  -- The set of known-invalid blocks grows monotonically (as a
                  -- function in the tick number), so its size can serve as a
                  -- fingerprint.
                  fp :: Fingerprint
fp = Word64 -> Fingerprint
Fingerprint (Word64 -> Fingerprint) -> Word64 -> Fingerprint
forall a b. (a -> b) -> a -> b
$ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ Set TestHash -> Int
forall a. Set a -> Int
Set.size Set TestHash
knownInvalid
              WithFingerprint (TestHash -> Maybe (ExtValidationError TestBlock))
-> STM
     m
     (WithFingerprint
        (TestHash -> Maybe (ExtValidationError TestBlock)))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WithFingerprint (TestHash -> Maybe (ExtValidationError TestBlock))
 -> STM
      m
      (WithFingerprint
         (TestHash -> Maybe (ExtValidationError TestBlock))))
-> WithFingerprint
     (TestHash -> Maybe (ExtValidationError TestBlock))
-> STM
     m
     (WithFingerprint
        (TestHash -> Maybe (ExtValidationError TestBlock)))
forall a b. (a -> b) -> a -> b
$ (TestHash -> Maybe (ExtValidationError TestBlock))
-> Fingerprint
-> WithFingerprint
     (TestHash -> Maybe (ExtValidationError TestBlock))
forall a. a -> Fingerprint -> WithFingerprint a
WithFingerprint TestHash -> Maybe (ExtValidationError TestBlock)
isInvalidBlock Fingerprint
fp
          }

        headerInFutureCheck :: InFutureCheck.SomeHeaderInFutureCheck m TestBlock
        headerInFutureCheck :: SomeHeaderInFutureCheck m TestBlock
headerInFutureCheck =
            ClockSkew -> SystemTime m -> SomeHeaderInFutureCheck m TestBlock
forall blk (m :: * -> *).
(HasHeader blk, HasHeader (Header blk), HasHardForkHistory blk,
 MonadDelay m) =>
ClockSkew -> SystemTime m -> SomeHeaderInFutureCheck m blk
InFutureCheck.realHeaderInFutureCheck ClockSkew
skew SystemTime m
clientSystemTime
            -- Note that this tests passes in the exact difference between the
            -- client's and server's clock as the tolerable clock skew.

        historicityCheck :: HistoricityCheck m TestBlock
        historicityCheck :: HistoricityCheck m TestBlock
historicityCheck =
            SystemTime m
-> m GsmState -> HistoricityCutoff -> HistoricityCheck m TestBlock
forall (m :: * -> *) blk.
(Monad m, HasHeader blk, HasAnnTip blk) =>
SystemTime m
-> m GsmState -> HistoricityCutoff -> HistoricityCheck m blk
HistoricityCheck.mkCheck
              SystemTime m
clientSystemTime
              -- The historicity check is disabled when we use 'CaughtUp' here,
              -- so we use 'Syncing'.
              (GsmState -> m GsmState
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GsmState
Syncing)
              HistoricityCutoff
historicityCutoff

        lopBucketConfig :: ChainSyncLoPBucketConfig
        lopBucketConfig :: ChainSyncLoPBucketConfig
lopBucketConfig = ChainSyncLoPBucketConfig
ChainSyncLoPBucketDisabled

        csjConfig :: CSJConfig
        csjConfig :: CSJConfig
csjConfig = CSJConfig
CSJDisabled

        diffusionPipelining :: DiffusionPipeliningSupport
        diffusionPipelining :: DiffusionPipeliningSupport
diffusionPipelining = DiffusionPipeliningSupport
DiffusionPipeliningOn

        client :: ChainSyncStateView m TestBlock
               -> Consensus ChainSyncClientPipelined
                    TestBlock
                    m
        client :: ChainSyncStateView m TestBlock
-> Consensus ChainSyncClientPipelined TestBlock m
client ChainSyncStateView {AnchoredFragment (Header TestBlock) -> STM m ()
csvSetCandidate :: AnchoredFragment (Header TestBlock) -> STM m ()
$sel:csvSetCandidate:ChainSyncStateView :: forall (m :: * -> *) blk.
ChainSyncStateView m blk
-> AnchoredFragment (Header blk) -> STM m ()
csvSetCandidate, WithOrigin SlotNo -> STM m ()
csvSetLatestSlot :: WithOrigin SlotNo -> STM m ()
$sel:csvSetLatestSlot:ChainSyncStateView :: forall (m :: * -> *) blk.
ChainSyncStateView m blk -> WithOrigin SlotNo -> STM m ()
csvSetLatestSlot, Idling m
csvIdling :: Idling m
$sel:csvIdling:ChainSyncStateView :: forall (m :: * -> *) blk. ChainSyncStateView m blk -> Idling m
csvIdling, LoPBucket m
csvLoPBucket :: LoPBucket m
$sel:csvLoPBucket:ChainSyncStateView :: forall (m :: * -> *) blk. ChainSyncStateView m blk -> LoPBucket m
csvLoPBucket, Jumping m TestBlock
csvJumping :: Jumping m TestBlock
$sel:csvJumping:ChainSyncStateView :: forall (m :: * -> *) blk. ChainSyncStateView m blk -> Jumping m blk
csvJumping} =
            ConfigEnv m TestBlock
-> DynamicEnv m TestBlock
-> Consensus ChainSyncClientPipelined TestBlock m
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk) =>
ConfigEnv m blk
-> DynamicEnv m blk -> Consensus ChainSyncClientPipelined blk m
chainSyncClient
              ConfigEnv {
                  ChainDbView m TestBlock
chainDbView :: ChainDbView m TestBlock
$sel:chainDbView:ConfigEnv :: ChainDbView m TestBlock
chainDbView
                , $sel:cfg:ConfigEnv :: TopLevelConfig TestBlock
cfg                     = TopLevelConfig TestBlock
nodeCfg
                , $sel:tracer:ConfigEnv :: Tracer m (TraceChainSyncClientEvent TestBlock)
tracer                  = Tracer m (TraceChainSyncClientEvent TestBlock)
chainSyncTracer
                , $sel:someHeaderInFutureCheck:ConfigEnv :: SomeHeaderInFutureCheck m TestBlock
someHeaderInFutureCheck = SomeHeaderInFutureCheck m TestBlock
headerInFutureCheck
                , HistoricityCheck m TestBlock
historicityCheck :: HistoricityCheck m TestBlock
$sel:historicityCheck:ConfigEnv :: HistoricityCheck m TestBlock
historicityCheck
                , $sel:mkPipelineDecision0:ConfigEnv :: MkPipelineDecision
mkPipelineDecision0     =
                    Word16 -> Word16 -> MkPipelineDecision
pipelineDecisionLowHighMark Word16
10 Word16
20
                , $sel:getDiffusionPipeliningSupport:ConfigEnv :: DiffusionPipeliningSupport
getDiffusionPipeliningSupport =
                    DiffusionPipeliningSupport
diffusionPipelining
                }
              DynamicEnv {
                  $sel:version:DynamicEnv :: NodeToNodeVersion
version             = NodeToNodeVersion
forall a. Bounded a => a
maxBound :: NodeToNodeVersion
                , $sel:controlMessageSTM:DynamicEnv :: ControlMessageSTM m
controlMessageSTM   = ControlMessage -> ControlMessageSTM m
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return ControlMessage
Continue
                , $sel:headerMetricsTracer:DynamicEnv :: HeaderMetricsTracer m
headerMetricsTracer = HeaderMetricsTracer m
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
                , $sel:setCandidate:DynamicEnv :: AnchoredFragment (Header TestBlock) -> STM m ()
setCandidate = AnchoredFragment (Header TestBlock) -> STM m ()
csvSetCandidate
                , $sel:idling:DynamicEnv :: Idling m
idling = Idling m
csvIdling
                , $sel:loPBucket:DynamicEnv :: LoPBucket m
loPBucket = LoPBucket m
csvLoPBucket
                , $sel:setLatestSlot:DynamicEnv :: WithOrigin SlotNo -> STM m ()
setLatestSlot = WithOrigin SlotNo -> STM m ()
csvSetLatestSlot
                , $sel:jumping:DynamicEnv :: Jumping m TestBlock
jumping = Jumping m TestBlock
csvJumping
                }

    -- Set up the server
    StrictTVar m (ChainProducerState TestBlock)
varChainProducerState <- ChainProducerState TestBlock
-> m (StrictTVar m (ChainProducerState TestBlock))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM (ChainProducerState TestBlock
 -> m (StrictTVar m (ChainProducerState TestBlock)))
-> ChainProducerState TestBlock
-> m (StrictTVar m (ChainProducerState TestBlock))
forall a b. (a -> b) -> a -> b
$ Chain TestBlock -> ChainProducerState TestBlock
forall block. Chain block -> ChainProducerState block
initChainProducerState Chain TestBlock
forall block. Chain block
Genesis
    let server :: ChainSyncServer (Header TestBlock) (Point TestBlock)
                                  (Tip TestBlock) m ()
        server :: ChainSyncServer
  (Header TestBlock) (Point TestBlock) (Tip TestBlock) m ()
server = ()
-> StrictTVar m (ChainProducerState TestBlock)
-> (TestBlock -> Header TestBlock)
-> ChainSyncServer
     (Header TestBlock) (Point TestBlock) (Tip TestBlock) m ()
forall blk header (m :: * -> *) a.
(HasHeader blk, MonadSTM m, HeaderHash header ~ HeaderHash blk) =>
a
-> StrictTVar m (ChainProducerState blk)
-> (blk -> header)
-> ChainSyncServer header (Point blk) (Tip blk) m a
chainSyncServerExample () (StrictTVar m (ChainProducerState TestBlock)
-> StrictTVar m (ChainProducerState TestBlock)
forall (m :: * -> *) a. StrictTVar m a -> StrictTVar m a
unsafeToUncheckedStrictTVar StrictTVar m (ChainProducerState TestBlock)
varChainProducerState) TestBlock -> Header TestBlock
forall blk. GetHeader blk => blk -> Header blk
getHeader

    let advanceWallClockForTick :: Tick -> m ()
        advanceWallClockForTick :: Tick -> m ()
advanceWallClockForTick Tick
tick = do
            Schedule NewMaxSlot -> Tick -> ([NewMaxSlot] -> m ()) -> m ()
forall a. Schedule a -> Tick -> ([a] -> m ()) -> m ()
doTick Schedule NewMaxSlot
clockUpdates Tick
tick (([NewMaxSlot] -> m ()) -> m ()) -> ([NewMaxSlot] -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \case
              [NewMaxSlot
newMaxSlot] -> do
                let target :: RelativeTime
target = NewMaxSlot -> RelativeTime
clientTimeForNewMaxSlot NewMaxSlot
newMaxSlot
                RelativeTime
now <- SystemTime m -> m RelativeTime
forall (m :: * -> *). SystemTime m -> m RelativeTime
systemTimeCurrent SystemTime m
clientSystemTime
                DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (DiffTime -> m ()) -> DiffTime -> m ()
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> DiffTime
nominalDelay (NominalDiffTime -> DiffTime) -> NominalDiffTime -> DiffTime
forall a b. (a -> b) -> a -> b
$ RelativeTime
target RelativeTime -> RelativeTime -> NominalDiffTime
`diffRelTime` RelativeTime
now

              [NewMaxSlot]
_ -> String -> m ()
forall a. HasCallStack => String -> a
error String
"impossible! bad mkClockUpdates"

    -- Do scheduled updates of the client and server chains
    let updateChainsDuringTick :: Tick -> m ()
        updateChainsDuringTick :: Tick -> m ()
updateChainsDuringTick Tick
tick = do
            -- Stop updating the client and server chains when the chain sync client
            -- has thrown an exception or has gracefully terminated, so that at the
            -- end, we can read the chains in the states they were in when the
            -- exception was thrown.
            Bool
stop <- (Maybe ChainSyncClientTestResult -> Bool)
-> m (Maybe ChainSyncClientTestResult) -> m Bool
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe ChainSyncClientTestResult -> Bool
forall a. Maybe a -> Bool
isJust (m (Maybe ChainSyncClientTestResult) -> m Bool)
-> m (Maybe ChainSyncClientTestResult) -> m Bool
forall a b. (a -> b) -> a -> b
$ STM m (Maybe ChainSyncClientTestResult)
-> m (Maybe ChainSyncClientTestResult)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe ChainSyncClientTestResult)
 -> m (Maybe ChainSyncClientTestResult))
-> STM m (Maybe ChainSyncClientTestResult)
-> m (Maybe ChainSyncClientTestResult)
forall a b. (a -> b) -> a -> b
$ StrictTVar m (Maybe ChainSyncClientTestResult)
-> STM m (Maybe ChainSyncClientTestResult)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Maybe ChainSyncClientTestResult)
varClientResult
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
stop (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
              -- Newly discovered invalid blocks
              Maybe [TestHash] -> ([TestHash] -> m ()) -> m ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust (Tick -> Map Tick [TestHash] -> Maybe [TestHash]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Tick
tick (Schedule TestHash -> Map Tick [TestHash]
forall a. Schedule a -> Map Tick [a]
getSchedule Schedule TestHash
invalidBlocks)) (([TestHash] -> m ()) -> m ()) -> ([TestHash] -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$
                STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ())
-> ([TestHash] -> STM m ()) -> [TestHash] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictTVar m (Set TestHash)
-> (Set TestHash -> Set TestHash) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (Set TestHash)
varKnownInvalid ((Set TestHash -> Set TestHash) -> STM m ())
-> ([TestHash] -> Set TestHash -> Set TestHash)
-> [TestHash]
-> STM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set TestHash -> Set TestHash -> Set TestHash
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Set TestHash -> Set TestHash -> Set TestHash)
-> ([TestHash] -> Set TestHash)
-> [TestHash]
-> Set TestHash
-> Set TestHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TestHash] -> Set TestHash
forall a. Ord a => [a] -> Set a
Set.fromList

              -- TODO interleave the client and server chain update
              -- applications in a more interesting way?

              -- Client
              Schedule ChainUpdate -> Tick -> ([ChainUpdate] -> m ()) -> m ()
forall a. Schedule a -> Tick -> ([a] -> m ()) -> m ()
doTick Schedule ChainUpdate
clientUpdates Tick
tick (([ChainUpdate] -> m ()) -> m ())
-> ([ChainUpdate] -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \[ChainUpdate]
chainUpdates ->
                STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m (Chain TestBlock)
-> (Chain TestBlock -> Chain TestBlock) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (Chain TestBlock)
varClientState ((Chain TestBlock -> Chain TestBlock) -> STM m ())
-> (Chain TestBlock -> Chain TestBlock) -> STM m ()
forall a b. (a -> b) -> a -> b
$ [ChainUpdate] -> Chain TestBlock -> Chain TestBlock
updateClientState [ChainUpdate]
chainUpdates

              -- Server
              Schedule ChainUpdate -> Tick -> ([ChainUpdate] -> m ()) -> m ()
forall a. Schedule a -> Tick -> ([a] -> m ()) -> m ()
doTick Schedule ChainUpdate
serverUpdates Tick
tick (([ChainUpdate] -> m ()) -> m ())
-> ([ChainUpdate] -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \[ChainUpdate]
chainUpdates ->
                STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
                  ChainProducerState TestBlock
chainProducerState <- StrictTVar m (ChainProducerState TestBlock)
-> STM m (ChainProducerState TestBlock)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (ChainProducerState TestBlock)
varChainProducerState
                  case [ChainUpdate TestBlock TestBlock]
-> ChainProducerState TestBlock
-> Maybe (ChainProducerState TestBlock)
forall block block'.
(HasHeader block, HeaderHash block ~ HeaderHash block') =>
[ChainUpdate block' block]
-> ChainProducerState block -> Maybe (ChainProducerState block)
CPS.applyChainUpdates
                         ([ChainUpdate] -> [ChainUpdate TestBlock TestBlock]
toChainUpdates [ChainUpdate]
chainUpdates)
                         ChainProducerState TestBlock
chainProducerState of
                    Just ChainProducerState TestBlock
chainProducerState' ->
                      StrictTVar m (ChainProducerState TestBlock)
-> ChainProducerState TestBlock -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (ChainProducerState TestBlock)
varChainProducerState ChainProducerState TestBlock
chainProducerState'
                    Maybe (ChainProducerState TestBlock)
Nothing                  ->
                      String -> STM m ()
forall a. HasCallStack => String -> a
error (String -> STM m ()) -> String -> STM m ()
forall a b. (a -> b) -> a -> b
$ String
"Invalid chainUpdates: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [ChainUpdate] -> String
forall a. Show a => a -> String
show [ChainUpdate]
chainUpdates String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
                              String
" for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Chain TestBlock -> String
forall a. Show a => a -> String
show (ChainProducerState TestBlock -> Chain TestBlock
forall block. ChainProducerState block -> Chain block
chainState ChainProducerState TestBlock
chainProducerState)

    -- Connect client to server and run the chain sync protocol
    --
    -- Happens /immediately after/ the chain and clock effects schedule for
    -- 'startSyncingAt'.
    let initiateChainSync :: m ()
initiateChainSync = do
            (Channel
  m
  (AnyMessage
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))
clientChannel, Channel
  m
  (AnyMessage
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))
serverChannel) <- m (Channel
     m
     (AnyMessage
        (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))),
   Channel
     m
     (AnyMessage
        (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))))
forall (m :: * -> *) a.
(MonadLabelledSTM m, MonadTraceSTM m, Show a) =>
m (Channel m a, Channel m a)
createConnectedChannels
            -- Don't link the thread (which will cause the exception to be
            -- rethrown in the main thread), just catch the exception and store
            -- it, because we want a "regular ending".
            m (Thread m ()) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Thread m ()) -> m ()) -> m (Thread m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ ResourceRegistry m -> String -> m () -> m (Thread m ())
forall (m :: * -> *) a.
(MonadMask m, MonadAsync m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkThread ResourceRegistry m
registry String
"ChainSyncClient" (m () -> m (Thread m ())) -> m () -> m (Thread m ())
forall a b. (a -> b) -> a -> b
$
              Tracer m (TraceChainSyncClientEvent TestBlock)
-> ChainDbView m TestBlock
-> StrictTVar
     m (Map CoreNodeId (ChainSyncClientHandle m TestBlock))
-> STM m GsmState
-> CoreNodeId
-> NodeToNodeVersion
-> ChainSyncLoPBucketConfig
-> CSJConfig
-> DiffusionPipeliningSupport
-> (ChainSyncStateView m TestBlock -> m ())
-> m ()
forall (m :: * -> *) peer blk a.
(IOLike m, Ord peer, LedgerSupportsProtocol blk, MonadTimer m) =>
Tracer m (TraceChainSyncClientEvent blk)
-> ChainDbView m blk
-> StrictTVar m (Map peer (ChainSyncClientHandle m blk))
-> STM m GsmState
-> peer
-> NodeToNodeVersion
-> ChainSyncLoPBucketConfig
-> CSJConfig
-> DiffusionPipeliningSupport
-> (ChainSyncStateView m blk -> m a)
-> m a
bracketChainSyncClient
                 Tracer m (TraceChainSyncClientEvent TestBlock)
chainSyncTracer
                 ChainDbView m TestBlock
chainDbView
                 StrictTVar m (Map CoreNodeId (ChainSyncClientHandle m TestBlock))
varHandles
                 -- 'Syncing' only ever impacts the LoP, which is disabled in
                 -- this test, so any value would do.
                 (GsmState -> STM m GsmState
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GsmState
Syncing)
                 CoreNodeId
serverId
                 NodeToNodeVersion
forall a. Bounded a => a
maxBound
                 ChainSyncLoPBucketConfig
lopBucketConfig
                 CSJConfig
csjConfig
                 DiffusionPipeliningSupport
diffusionPipelining
                 ((ChainSyncStateView m TestBlock -> m ()) -> m ())
-> (ChainSyncStateView m TestBlock -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \ChainSyncStateView m TestBlock
csState -> do
                   STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
                     Map CoreNodeId (ChainSyncClientHandle m TestBlock)
handles <- StrictTVar m (Map CoreNodeId (ChainSyncClientHandle m TestBlock))
-> STM m (Map CoreNodeId (ChainSyncClientHandle m TestBlock))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Map CoreNodeId (ChainSyncClientHandle m TestBlock))
varHandles
                     StrictTVar m (Map CoreNodeId (ChainSyncClientHandle m TestBlock))
-> (Map CoreNodeId (ChainSyncClientHandle m TestBlock)
    -> Map CoreNodeId (ChainSyncClientHandle m TestBlock))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (Map CoreNodeId (ChainSyncClientHandle m TestBlock))
varFinalCandidates ((Map CoreNodeId (ChainSyncClientHandle m TestBlock)
  -> Map CoreNodeId (ChainSyncClientHandle m TestBlock))
 -> STM m ())
-> (Map CoreNodeId (ChainSyncClientHandle m TestBlock)
    -> Map CoreNodeId (ChainSyncClientHandle m TestBlock))
-> STM m ()
forall a b. (a -> b) -> a -> b
$ CoreNodeId
-> ChainSyncClientHandle m TestBlock
-> Map CoreNodeId (ChainSyncClientHandle m TestBlock)
-> Map CoreNodeId (ChainSyncClientHandle m TestBlock)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert CoreNodeId
serverId (Map CoreNodeId (ChainSyncClientHandle m TestBlock)
handles Map CoreNodeId (ChainSyncClientHandle m TestBlock)
-> CoreNodeId -> ChainSyncClientHandle m TestBlock
forall k a. Ord k => Map k a -> k -> a
Map.! CoreNodeId
serverId)
                   (ChainSyncClientResult
result, Maybe
  (AnyMessage
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))
_) <-
                     Tracer
  m
  (TraceSendRecv
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))
-> Codec
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
     CodecFailure
     m
     (AnyMessage
        (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))
-> Channel
     m
     (AnyMessage
        (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))
-> PeerPipelined
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
     'AsClient
     'StIdle
     m
     ChainSyncClientResult
-> m (ChainSyncClientResult,
      Maybe
        (AnyMessage
           (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))))
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadThrow m, Exception failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> PeerPipelined ps pr st m a
-> m (a, Maybe bytes)
runPipelinedPeer Tracer
  m
  (TraceSendRecv
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))
protocolTracer Codec
  (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
  CodecFailure
  m
  (AnyMessage
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))
forall {k} {k1} {k2} (header :: k) (point :: k1) (tip :: k2)
       (m :: * -> *).
Monad m =>
Codec
  (ChainSync header point tip)
  CodecFailure
  m
  (AnyMessage (ChainSync header point tip))
codecChainSyncId Channel
  m
  (AnyMessage
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))
clientChannel (PeerPipelined
   (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
   'AsClient
   'StIdle
   m
   ChainSyncClientResult
 -> m (ChainSyncClientResult,
       Maybe
         (AnyMessage
            (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))))
-> PeerPipelined
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
     'AsClient
     'StIdle
     m
     ChainSyncClientResult
-> m (ChainSyncClientResult,
      Maybe
        (AnyMessage
           (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))))
forall a b. (a -> b) -> a -> b
$
                       Consensus ChainSyncClientPipelined TestBlock m
-> PeerPipelined
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
     'AsClient
     'StIdle
     m
     ChainSyncClientResult
forall header point tip (m :: * -> *) a.
Monad m =>
ChainSyncClientPipelined header point tip m a
-> ClientPipelined (ChainSync header point tip) 'StIdle m a
chainSyncClientPeerPipelined (Consensus ChainSyncClientPipelined TestBlock m
 -> PeerPipelined
      (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
      'AsClient
      'StIdle
      m
      ChainSyncClientResult)
-> Consensus ChainSyncClientPipelined TestBlock m
-> PeerPipelined
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
     'AsClient
     'StIdle
     m
     ChainSyncClientResult
forall a b. (a -> b) -> a -> b
$ ChainSyncStateView m TestBlock
-> Consensus ChainSyncClientPipelined TestBlock m
client ChainSyncStateView m TestBlock
csState
                   STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m (Maybe ChainSyncClientTestResult)
-> Maybe ChainSyncClientTestResult -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (Maybe ChainSyncClientTestResult)
varClientResult (ChainSyncClientTestResult -> Maybe ChainSyncClientTestResult
forall a. a -> Maybe a
Just (ChainSyncClientResult -> ChainSyncClientTestResult
ClientFinished ChainSyncClientResult
result))
                   () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              m () -> (ChainSyncClientException -> m ()) -> m ()
forall e a. Exception e => m a -> (e -> m a) -> m a
`catchAlsoLinked` \ChainSyncClientException
ex -> do
                STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m (Maybe ChainSyncClientTestResult)
-> Maybe ChainSyncClientTestResult -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (Maybe ChainSyncClientTestResult)
varClientResult (ChainSyncClientTestResult -> Maybe ChainSyncClientTestResult
forall a. a -> Maybe a
Just (ChainSyncClientException -> ChainSyncClientTestResult
ClientThrew ChainSyncClientException
ex))
                -- Rethrow, but it will be ignored anyway.
                ChainSyncClientException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO ChainSyncClientException
ex
            m (Thread
     m
     ((),
      Maybe
        (AnyMessage
           (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))))
-> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Thread
      m
      ((),
       Maybe
         (AnyMessage
            (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))))
 -> m ())
-> m (Thread
        m
        ((),
         Maybe
           (AnyMessage
              (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))))
-> m ()
forall a b. (a -> b) -> a -> b
$ ResourceRegistry m
-> String
-> m ((),
      Maybe
        (AnyMessage
           (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))))
-> m (Thread
        m
        ((),
         Maybe
           (AnyMessage
              (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))))
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry m
registry String
"ChainSyncServer" (m ((),
    Maybe
      (AnyMessage
         (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))))
 -> m (Thread
         m
         ((),
          Maybe
            (AnyMessage
               (ChainSync
                  (Header TestBlock) (Point TestBlock) (Tip TestBlock))))))
-> m ((),
      Maybe
        (AnyMessage
           (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))))
-> m (Thread
        m
        ((),
         Maybe
           (AnyMessage
              (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))))
forall a b. (a -> b) -> a -> b
$
              Tracer
  m
  (TraceSendRecv
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))
-> Codec
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
     CodecFailure
     m
     (AnyMessage
        (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))
-> Channel
     m
     (AnyMessage
        (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))
-> Peer
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
     'AsServer
     'NonPipelined
     'StIdle
     m
     ()
-> m ((),
      Maybe
        (AnyMessage
           (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))))
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadThrow m, Exception failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeer Tracer
  m
  (TraceSendRecv
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Codec
  (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
  CodecFailure
  m
  (AnyMessage
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))
forall {k} {k1} {k2} (header :: k) (point :: k1) (tip :: k2)
       (m :: * -> *).
Monad m =>
Codec
  (ChainSync header point tip)
  CodecFailure
  m
  (AnyMessage (ChainSync header point tip))
codecChainSyncId Channel
  m
  (AnyMessage
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))
serverChannel
                      (ChainSyncServer
  (Header TestBlock) (Point TestBlock) (Tip TestBlock) m ()
-> Peer
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
     'AsServer
     'NonPipelined
     'StIdle
     m
     ()
forall header point tip (m :: * -> *) a.
Monad m =>
ChainSyncServer header point tip m a
-> Server (ChainSync header point tip) 'NonPipelined 'StIdle m a
chainSyncServerPeer ChainSyncServer
  (Header TestBlock) (Point TestBlock) (Tip TestBlock) m ()
server)

    -- If the candidate's tip's slot's onset is ahead of the local wall-clock
    -- (which is skewed by 'clientSlowBy'), then the ChainSync client
    -- mishandled a block from the future.
    let checkTipTime :: m ()
        checkTipTime :: m ()
checkTipTime = do
            RelativeTime
now        <- SystemTime m -> m RelativeTime
forall (m :: * -> *). SystemTime m -> m RelativeTime
systemTimeCurrent SystemTime m
clientSystemTime
            Map CoreNodeId (AnchoredFragment (Header TestBlock))
candidates <- STM m (Map CoreNodeId (AnchoredFragment (Header TestBlock)))
-> m (Map CoreNodeId (AnchoredFragment (Header TestBlock)))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Map CoreNodeId (AnchoredFragment (Header TestBlock)))
 -> m (Map CoreNodeId (AnchoredFragment (Header TestBlock))))
-> STM m (Map CoreNodeId (AnchoredFragment (Header TestBlock)))
-> m (Map CoreNodeId (AnchoredFragment (Header TestBlock)))
forall a b. (a -> b) -> a -> b
$ StrictTVar m (Map CoreNodeId (ChainSyncClientHandle m TestBlock))
-> (ChainSyncState TestBlock
    -> AnchoredFragment (Header TestBlock))
-> STM m (Map CoreNodeId (AnchoredFragment (Header TestBlock)))
forall (m :: * -> *) peer blk a.
IOLike m =>
StrictTVar m (Map peer (ChainSyncClientHandle m blk))
-> (ChainSyncState blk -> a) -> STM m (Map peer a)
viewChainSyncState StrictTVar m (Map CoreNodeId (ChainSyncClientHandle m TestBlock))
varHandles ChainSyncState TestBlock -> AnchoredFragment (Header TestBlock)
forall blk. ChainSyncState blk -> AnchoredFragment (Header blk)
csCandidate
            Map CoreNodeId (AnchoredFragment (Header TestBlock))
-> (AnchoredFragment (Header TestBlock) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Map CoreNodeId (AnchoredFragment (Header TestBlock))
candidates ((AnchoredFragment (Header TestBlock) -> m ()) -> m ())
-> (AnchoredFragment (Header TestBlock) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \AnchoredFragment (Header TestBlock)
candidate -> do
              let p :: Point TestBlock
p = Point (Header TestBlock) -> Point TestBlock
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (Header TestBlock) -> Point TestBlock)
-> Point (Header TestBlock) -> Point TestBlock
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header TestBlock) -> Point (Header TestBlock)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment (Header TestBlock)
candidate :: Point TestBlock
              case Point TestBlock -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point TestBlock
p of
                WithOrigin SlotNo
Origin  -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                At SlotNo
slot -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RelativeTime
now RelativeTime -> RelativeTime -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo -> RelativeTime
toOnset SlotNo
slot) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
                  STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m (Maybe ChainSyncClientTestResult)
-> Maybe ChainSyncClientTestResult -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (Maybe ChainSyncClientTestResult)
varClientResult (Maybe ChainSyncClientTestResult -> STM m ())
-> Maybe ChainSyncClientTestResult -> STM m ()
forall a b. (a -> b) -> a -> b
$ ChainSyncClientTestResult -> Maybe ChainSyncClientTestResult
forall a. a -> Maybe a
Just
                    (ChainSyncClientTestResult -> Maybe ChainSyncClientTestResult)
-> ChainSyncClientTestResult -> Maybe ChainSyncClientTestResult
forall a b. (a -> b) -> a -> b
$ FutureTip -> ChainSyncClientTestResult
ClientSelectedFutureTip (FutureTip -> ChainSyncClientTestResult)
-> FutureTip -> ChainSyncClientTestResult
forall a b. (a -> b) -> a -> b
$ FutureTip {
                          ftNow :: RelativeTime
ftNow   = RelativeTime
now
                        , ftPoint :: (RelativeTime, Point TestBlock)
ftPoint = (SlotNo -> RelativeTime
toOnset SlotNo
slot, Point TestBlock
p)
                        }

    do
      let loop :: Tick -> m ()
loop Tick
tick = do
              -- first update the clocks
              Tick -> m ()
advanceWallClockForTick Tick
tick
              STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m Tick -> Tick -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m Tick
varCurrentLogicalTick Tick
tick

              -- then do the messages
              Tick -> m ()
updateChainsDuringTick Tick
tick
              Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Tick
tick Tick -> Tick -> Bool
forall a. Eq a => a -> a -> Bool
== Tick
startSyncingAt) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ m ()
initiateChainSync

              -- check the invariants before advancing the clock again
              --
              -- This is not a perfect check, since the server's chain may have
              -- violated the invariant ephemerally (ie due to a subsequent
              -- rollback during the same logical tick). However, other
              -- QuickCheck seeds/counterexamples should trigger such a bug in
              -- a non-ephemeral way.
              m ()
checkTipTime

              Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Tick
tick Tick -> Tick -> Bool
forall a. Ord a => a -> a -> Bool
< Tick
finalTick) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Tick -> m ()
loop (Tick
tick Tick -> Tick -> Tick
forall a. Num a => a -> a -> a
+ Tick
1)
      Tick -> m ()
loop (Word64 -> Tick
Tick Word64
1)

      -- This delay seems enough to let all threads finish their final work.
      --
      -- TODO what is the necessary threshold?
      DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
86400

    [TraceEvent]
traceEvents <- m [TraceEvent]
getTrace
    -- Collect the return values
    STM m ChainSyncOutcome -> m ChainSyncOutcome
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m ChainSyncOutcome -> m ChainSyncOutcome)
-> STM m ChainSyncOutcome -> m ChainSyncOutcome
forall a b. (a -> b) -> a -> b
$ do
      Chain TestBlock
finalClientChain  <- StrictTVar m (Chain TestBlock) -> STM m (Chain TestBlock)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Chain TestBlock)
varClientState
      Chain TestBlock
finalServerChain  <- ChainProducerState TestBlock -> Chain TestBlock
forall block. ChainProducerState block -> Chain block
chainState (ChainProducerState TestBlock -> Chain TestBlock)
-> STM m (ChainProducerState TestBlock) -> STM m (Chain TestBlock)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (ChainProducerState TestBlock)
-> STM m (ChainProducerState TestBlock)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (ChainProducerState TestBlock)
varChainProducerState
      AnchoredFragment (Header TestBlock)
candidateFragment <- ChainSyncState TestBlock -> AnchoredFragment (Header TestBlock)
forall blk. ChainSyncState blk -> AnchoredFragment (Header blk)
csCandidate (ChainSyncState TestBlock -> AnchoredFragment (Header TestBlock))
-> STM m (ChainSyncState TestBlock)
-> STM m (AnchoredFragment (Header TestBlock))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (Map CoreNodeId (ChainSyncClientHandle m TestBlock))
-> CoreNodeId -> STM m (ChainSyncState TestBlock)
forall peer (m :: * -> *) blk.
(Ord peer, IOLike m) =>
StrictTVar m (Map peer (ChainSyncClientHandle m blk))
-> peer -> STM m (ChainSyncState blk)
chainSyncStateFor StrictTVar m (Map CoreNodeId (ChainSyncClientHandle m TestBlock))
varFinalCandidates CoreNodeId
serverId
      Maybe ChainSyncClientTestResult
mbResult          <- StrictTVar m (Maybe ChainSyncClientTestResult)
-> STM m (Maybe ChainSyncClientTestResult)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Maybe ChainSyncClientTestResult)
varClientResult
      ChainSyncOutcome -> STM m ChainSyncOutcome
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return ChainSyncOutcome {
          Chain TestBlock
finalClientChain :: Chain TestBlock
finalClientChain :: Chain TestBlock
finalClientChain
        , Chain TestBlock
finalServerChain :: Chain TestBlock
finalServerChain :: Chain TestBlock
finalServerChain
        , Maybe ChainSyncClientTestResult
mbResult :: Maybe ChainSyncClientTestResult
mbResult :: Maybe ChainSyncClientTestResult
mbResult
        , syncedFragment :: AnchoredFragment TestBlock
syncedFragment   = (Header TestBlock -> TestBlock)
-> AnchoredFragment (Header TestBlock)
-> AnchoredFragment TestBlock
forall block2 block1.
(HasHeader block2, HeaderHash block1 ~ HeaderHash block2) =>
(block1 -> block2)
-> AnchoredFragment block1 -> AnchoredFragment block2
AF.mapAnchoredFragment Header TestBlock -> TestBlock
forall ptype. Header (TestBlockWith ptype) -> TestBlockWith ptype
testHeader AnchoredFragment (Header TestBlock)
candidateFragment
        , [TraceEvent]
traceEvents :: [TraceEvent]
traceEvents :: [TraceEvent]
traceEvents
        }
  where
    k :: Word64
k = SecurityParam -> Word64
maxRollbacks SecurityParam
securityParam

    toSkewedOnset :: SlotNo -> RelativeTime
    toSkewedOnset :: SlotNo -> RelativeTime
toSkewedOnset SlotNo
slot =
      let RelativeTime NominalDiffTime
onset = SlotNo -> RelativeTime
toOnset SlotNo
slot
      in
      NominalDiffTime -> RelativeTime
RelativeTime (NominalDiffTime -> RelativeTime)
-> NominalDiffTime -> RelativeTime
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
onset NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
- ClockSkew -> NominalDiffTime
unClockSkew ClockSkew
skew

    -- The target time (as reported by 'clientSystemTime') for the given
    -- 'NewMaxSlot'.
    clientTimeForNewMaxSlot :: NewMaxSlot -> RelativeTime
    clientTimeForNewMaxSlot :: NewMaxSlot -> RelativeTime
clientTimeForNewMaxSlot = \case
        NewMaxClientSlot SlotNo
slot -> SlotNo -> RelativeTime
toOnset SlotNo
slot
        NewMaxServerSlot SlotNo
slot -> SlotNo -> RelativeTime
toSkewedOnset SlotNo
slot

        NewMaxClientAndServerSlot SlotNo
cslot SlotNo
sslot ->
          SlotNo -> RelativeTime
toOnset SlotNo
cslot RelativeTime -> RelativeTime -> RelativeTime
forall a. Ord a => a -> a -> a
`max` SlotNo -> RelativeTime
toSkewedOnset SlotNo
sslot

    clockUpdates :: Schedule NewMaxSlot
    clockUpdates :: Schedule NewMaxSlot
clockUpdates =
        ClientUpdates -> ServerUpdates -> Schedule NewMaxSlot
mkClockUpdates
          (Schedule ChainUpdate -> ClientUpdates
ClientUpdates Schedule ChainUpdate
clientUpdates)
          (Schedule ChainUpdate -> ServerUpdates
ServerUpdates Schedule ChainUpdate
serverUpdates)

    -- Also see the module header for how ticks/time/clock skew are working in
    -- this test.
    clientTimeForTick :: Tick -> RelativeTime
    clientTimeForTick :: Tick -> RelativeTime
clientTimeForTick = \Tick
tick -> case Tick -> Map Tick RelativeTime -> Maybe (Tick, RelativeTime)
forall k v. Ord k => k -> Map k v -> Maybe (k, v)
Map.lookupLE Tick
tick Map Tick RelativeTime
clientTimes of
        Just (Tick
_, RelativeTime
time) -> RelativeTime
time
        -- Before any clock updates, the client time is exactly @skew@ before
        -- the onset of slot 0.
        Maybe (Tick, RelativeTime)
Nothing        -> NominalDiffTime -> RelativeTime
RelativeTime (- ClockSkew -> NominalDiffTime
unClockSkew ClockSkew
skew)
      where
        clientTimes :: Map.Map Tick RelativeTime
        clientTimes :: Map Tick RelativeTime
clientTimes =
            (Map Tick RelativeTime
 -> Tick -> [NewMaxSlot] -> Map Tick RelativeTime)
-> Map Tick RelativeTime
-> Map Tick [NewMaxSlot]
-> Map Tick RelativeTime
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' Map Tick RelativeTime
-> Tick -> [NewMaxSlot] -> Map Tick RelativeTime
forall {k}.
Ord k =>
Map k RelativeTime -> k -> [NewMaxSlot] -> Map k RelativeTime
f Map Tick RelativeTime
forall k a. Map k a
Map.empty (Schedule NewMaxSlot -> Map Tick [NewMaxSlot]
forall a. Schedule a -> Map Tick [a]
getSchedule Schedule NewMaxSlot
clockUpdates)
          where
            f :: Map k RelativeTime -> k -> [NewMaxSlot] -> Map k RelativeTime
f Map k RelativeTime
acc k
t [NewMaxSlot
newMaxSlot] = case Map k RelativeTime -> Maybe (k, RelativeTime)
forall k a. Map k a -> Maybe (k, a)
Map.lookupMax Map k RelativeTime
acc of
                Just (k
_, RelativeTime
time')
                  | RelativeTime
time' RelativeTime -> RelativeTime -> Bool
forall a. Ord a => a -> a -> Bool
< RelativeTime
time -> k -> RelativeTime -> Map k RelativeTime -> Map k RelativeTime
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
t RelativeTime
time Map k RelativeTime
acc
                  | Bool
otherwise    -> Map k RelativeTime
acc
                Maybe (k, RelativeTime)
Nothing -> k -> RelativeTime -> Map k RelativeTime
forall k a. k -> a -> Map k a
Map.singleton k
t RelativeTime
time
              where
                time :: RelativeTime
time = NewMaxSlot -> RelativeTime
clientTimeForNewMaxSlot NewMaxSlot
newMaxSlot
            f Map k RelativeTime
_   k
_ [NewMaxSlot]
_            = String -> Map k RelativeTime
forall a. HasCallStack => String -> a
error String
"bad clockUpdates"

    -- For the historicity check, which constrains the age of @MsgRollBackward@
    -- and @MsgAwaitReply@. This is calculated by considering the 'ChainUpdate'
    -- which rewinds the oldest block relative to the client wallclock time in
    -- the given tick, as well as the age of the last block sent up until a tick
    -- (as a @MsgAwaitReply@ will be sent right after).
    historicityCutoff :: HistoricityCutoff
    historicityCutoff :: HistoricityCutoff
historicityCutoff =
          NominalDiffTime -> HistoricityCutoff
HistoricityCutoff
        (NominalDiffTime -> HistoricityCutoff)
-> NominalDiffTime -> HistoricityCutoff
forall a b. (a -> b) -> a -> b
$ (NominalDiffTime -> NominalDiffTime -> NominalDiffTime)
-> NominalDiffTime -> [NominalDiffTime] -> NominalDiffTime
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Ord a => a -> a -> a
max NominalDiffTime
0
        ([NominalDiffTime] -> NominalDiffTime)
-> [NominalDiffTime] -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ [NominalDiffTime]
awaitReplyAges [NominalDiffTime] -> [NominalDiffTime] -> [NominalDiffTime]
forall a. Semigroup a => a -> a -> a
<> [NominalDiffTime]
rollbackAges
      where
        rollbackAges :: [NominalDiffTime]
        rollbackAges :: [NominalDiffTime]
rollbackAges =
          [ RelativeTime
clientTime RelativeTime -> RelativeTime -> NominalDiffTime
`diffRelTime` SlotNo -> RelativeTime
toSkewedOnset SlotNo
oldestRewound
          | (Tick
tick, [ChainUpdate]
updates) <- Map Tick [ChainUpdate] -> [(Tick, [ChainUpdate])]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Tick [ChainUpdate] -> [(Tick, [ChainUpdate])])
-> Map Tick [ChainUpdate] -> [(Tick, [ChainUpdate])]
forall a b. (a -> b) -> a -> b
$ Schedule ChainUpdate -> Map Tick [ChainUpdate]
forall a. Schedule a -> Map Tick [a]
getSchedule Schedule ChainUpdate
serverUpdates
          , let clientTime :: RelativeTime
clientTime = Tick -> RelativeTime
clientTimeForTick Tick
tick
          , SwitchFork Point TestBlock
rollbackPoint [TestBlock]
_blks <- [ChainUpdate]
updates
          , -- Here, we make use of the fact that the blocks generated for this
            -- test have dense slot numbers (ie there are no empty slots).
            let oldestRewound :: SlotNo
oldestRewound =
                  SlotNo -> (SlotNo -> SlotNo) -> WithOrigin SlotNo -> SlotNo
forall b t. b -> (t -> b) -> WithOrigin t -> b
withOrigin SlotNo
firstSlot SlotNo -> SlotNo
forall a. Enum a => a -> a
succ (WithOrigin SlotNo -> SlotNo) -> WithOrigin SlotNo -> SlotNo
forall a b. (a -> b) -> a -> b
$ Point TestBlock -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point TestBlock
rollbackPoint
          ]

        firstSlot :: SlotNo
firstSlot = TestBlock -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot (TestBlock -> SlotNo) -> TestBlock -> SlotNo
forall a b. (a -> b) -> a -> b
$ Word64 -> TestBlock
firstBlock Word64
0

        awaitReplyAges :: [NominalDiffTime]
        awaitReplyAges :: [NominalDiffTime]
awaitReplyAges =
          [ Tick -> RelativeTime
clientTimeForTick Tick
tick RelativeTime -> RelativeTime -> NominalDiffTime
`diffRelTime` SlotNo -> RelativeTime
toSkewedOnset SlotNo
lastSlotBefore
          | (Tick
tick, [ChainUpdate]
updates) <- Map Tick [ChainUpdate] -> [(Tick, [ChainUpdate])]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Tick [ChainUpdate] -> [(Tick, [ChainUpdate])])
-> Map Tick [ChainUpdate] -> [(Tick, [ChainUpdate])]
forall a b. (a -> b) -> a -> b
$ Schedule ChainUpdate -> Map Tick [ChainUpdate]
forall a. Schedule a -> Map Tick [a]
getSchedule Schedule ChainUpdate
serverUpdates
          , let lastSlotBefore :: SlotNo
lastSlotBefore = SlotNo -> Maybe SlotNo -> SlotNo
forall a. a -> Maybe a -> a
fromMaybe SlotNo
0 (Maybe SlotNo -> SlotNo) -> Maybe SlotNo -> SlotNo
forall a b. (a -> b) -> a -> b
$ do
                  ChainUpdate
lastUpdate <- [ChainUpdate] -> Maybe ChainUpdate
forall a. [a] -> Maybe a
lastMaybe [ChainUpdate]
updates
                  TestBlock
lastBlk    <- case ChainUpdate
lastUpdate of
                    AddBlock TestBlock
blk        -> TestBlock -> Maybe TestBlock
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestBlock
blk
                    SwitchFork Point TestBlock
_pt [TestBlock]
blks -> [TestBlock] -> Maybe TestBlock
forall a. [a] -> Maybe a
lastMaybe [TestBlock]
blks
                  SlotNo -> Maybe SlotNo
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SlotNo -> Maybe SlotNo) -> SlotNo -> Maybe SlotNo
forall a b. (a -> b) -> a -> b
$ TestBlock -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot TestBlock
lastBlk
          ]

    doTick :: Schedule a -> Tick -> ([a] -> m ()) -> m ()
    doTick :: forall a. Schedule a -> Tick -> ([a] -> m ()) -> m ()
doTick Schedule a
sched Tick
tick [a] -> m ()
kont = Maybe [a] -> ([a] -> m ()) -> m ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust (Tick -> Map Tick [a] -> Maybe [a]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Tick
tick (Schedule a -> Map Tick [a]
forall a. Schedule a -> Map Tick [a]
getSchedule Schedule a
sched)) [a] -> m ()
kont

    nodeCfg :: TopLevelConfig TestBlock
    nodeCfg :: TopLevelConfig TestBlock
nodeCfg = TopLevelConfig {
        topLevelConfigProtocol :: ConsensusConfig (BlockProtocol TestBlock)
topLevelConfigProtocol = BftConfig {
            bftParams :: BftParams
bftParams  = BftParams {
                             bftSecurityParam :: SecurityParam
bftSecurityParam = SecurityParam
securityParam
                           , bftNumNodes :: NumCoreNodes
bftNumNodes      = NumCoreNodes
numCoreNodes
                           }
          , bftSignKey :: SignKeyDSIGN (BftDSIGN BftMockCrypto)
bftSignKey = Word64 -> SignKeyDSIGN MockDSIGN
SignKeyMockDSIGN Word64
0
          , bftVerKeys :: Map NodeId (VerKeyDSIGN (BftDSIGN BftMockCrypto))
bftVerKeys = [(NodeId, VerKeyDSIGN MockDSIGN)]
-> Map NodeId (VerKeyDSIGN MockDSIGN)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [
                             (CoreNodeId -> NodeId
CoreId (Word64 -> CoreNodeId
CoreNodeId Word64
0), Word64 -> VerKeyDSIGN MockDSIGN
VerKeyMockDSIGN Word64
0)
                           , (CoreNodeId -> NodeId
CoreId (Word64 -> CoreNodeId
CoreNodeId Word64
1), Word64 -> VerKeyDSIGN MockDSIGN
VerKeyMockDSIGN Word64
1)
                           ]
          }
      , topLevelConfigLedger :: LedgerConfig TestBlock
topLevelConfigLedger      = EraParams -> TestBlockLedgerConfig
testBlockLedgerConfigFrom EraParams
eraParams
      , topLevelConfigBlock :: BlockConfig TestBlock
topLevelConfigBlock       = NumCoreNodes -> BlockConfig TestBlock
forall ptype. NumCoreNodes -> BlockConfig (TestBlockWith ptype)
TestBlockConfig NumCoreNodes
numCoreNodes
      , topLevelConfigCodec :: CodecConfig TestBlock
topLevelConfigCodec       = CodecConfig TestBlock
TestBlockCodecConfig
      , topLevelConfigStorage :: StorageConfig TestBlock
topLevelConfigStorage     = StorageConfig TestBlock
TestBlockStorageConfig
      , topLevelConfigCheckpoints :: CheckpointsMap TestBlock
topLevelConfigCheckpoints = CheckpointsMap TestBlock
forall blk. CheckpointsMap blk
emptyCheckpointsMap
      }

    eraParams :: HardFork.EraParams
    eraParams :: EraParams
eraParams = SecurityParam -> SlotLength -> EraParams
HardFork.defaultEraParams SecurityParam
securityParam SlotLength
slotLength

    numCoreNodes :: NumCoreNodes
    numCoreNodes :: NumCoreNodes
numCoreNodes = Word64 -> NumCoreNodes
NumCoreNodes Word64
2

    finalTick :: Tick
    finalTick :: Tick
finalTick = [Tick] -> Tick
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum
      [ Schedule ChainUpdate -> Tick
forall a. Schedule a -> Tick
lastTick Schedule ChainUpdate
clientUpdates
      , Schedule ChainUpdate -> Tick
forall a. Schedule a -> Tick
lastTick Schedule ChainUpdate
serverUpdates
      , Tick
startSyncingAt
      ]

    catchAlsoLinked :: Exception e => m a -> (e -> m a) -> m a
    catchAlsoLinked :: forall e a. Exception e => m a -> (e -> m a) -> m a
catchAlsoLinked m a
ma e -> m a
handler = m a
ma m a -> [Handler m a] -> m a
forall (m :: * -> *) a. MonadCatch m => m a -> [Handler m a] -> m a
`catches`
      [ (e -> m a) -> Handler m a
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler e -> m a
handler
      , (ExceptionInLinkedThread -> m a) -> Handler m a
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((ExceptionInLinkedThread -> m a) -> Handler m a)
-> (ExceptionInLinkedThread -> m a) -> Handler m a
forall a b. (a -> b) -> a -> b
$ \(ExceptionInLinkedThread String
_ SomeException
ex) -> SomeException -> m a
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
ex m a -> (e -> m a) -> m a
forall e a. Exception e => m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` e -> m a
handler
      ]

-- | See 'ClientSelectedFutureTip'
data FutureTip = FutureTip {
      FutureTip -> RelativeTime
ftNow   :: RelativeTime
      -- ^ when the header was selected prematurely
    , FutureTip -> (RelativeTime, Point TestBlock)
ftPoint :: (RelativeTime, Point TestBlock)
      -- ^ point of the header that was selected prematurely, and the
      -- 'RelativeTime' of its slot's onset
    }
  deriving (Int -> FutureTip -> String -> String
[FutureTip] -> String -> String
FutureTip -> String
(Int -> FutureTip -> String -> String)
-> (FutureTip -> String)
-> ([FutureTip] -> String -> String)
-> Show FutureTip
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> FutureTip -> String -> String
showsPrec :: Int -> FutureTip -> String -> String
$cshow :: FutureTip -> String
show :: FutureTip -> String
$cshowList :: [FutureTip] -> String -> String
showList :: [FutureTip] -> String -> String
Show)

data ChainSyncClientTestResult =
    ClientFinished          !ChainSyncClientResult
    -- ^ This is only a property failure if the result was unjustified.
  | ClientSelectedFutureTip !FutureTip
    -- ^ This is always a property failure.
  | ClientThrew             !ChainSyncClientException
    -- ^ This is only a property failure if the exception was unjustified.

updateClientState :: [ChainUpdate] -> Chain TestBlock -> Chain TestBlock
updateClientState :: [ChainUpdate] -> Chain TestBlock -> Chain TestBlock
updateClientState [ChainUpdate]
chainUpdates Chain TestBlock
chain =
    case [ChainUpdate TestBlock TestBlock]
-> Chain TestBlock -> Maybe (Chain TestBlock)
forall block.
HasHeader block =>
[ChainUpdate block block] -> Chain block -> Maybe (Chain block)
Chain.applyChainUpdates ([ChainUpdate] -> [ChainUpdate TestBlock TestBlock]
toChainUpdates [ChainUpdate]
chainUpdates) Chain TestBlock
chain of
      Just Chain TestBlock
chain' -> Chain TestBlock
chain'
      Maybe (Chain TestBlock)
Nothing     -> String -> Chain TestBlock
forall a. HasCallStack => String -> a
error String
"Client chain update failed"

-- | Simulates 'ChainDB.getPastLedger'.
computePastLedger ::
     TopLevelConfig TestBlock
  -> Point TestBlock
  -> Chain TestBlock
  -> Maybe (ExtLedgerState TestBlock)
computePastLedger :: TopLevelConfig TestBlock
-> Point TestBlock
-> Chain TestBlock
-> Maybe (ExtLedgerState TestBlock)
computePastLedger TopLevelConfig TestBlock
cfg Point TestBlock
pt Chain TestBlock
chain
    | Point TestBlock
pt Point TestBlock -> [Point TestBlock] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Point TestBlock]
validPoints
    = ExtLedgerState TestBlock -> Maybe (ExtLedgerState TestBlock)
forall a. a -> Maybe a
Just (ExtLedgerState TestBlock -> Maybe (ExtLedgerState TestBlock))
-> ExtLedgerState TestBlock -> Maybe (ExtLedgerState TestBlock)
forall a b. (a -> b) -> a -> b
$ ExtLedgerState TestBlock -> [TestBlock] -> ExtLedgerState TestBlock
go ExtLedgerState TestBlock
testInitExtLedger (Chain TestBlock -> [TestBlock]
forall block. Chain block -> [block]
Chain.toOldestFirst Chain TestBlock
chain)
    | Bool
otherwise
    = Maybe (ExtLedgerState TestBlock)
forall a. Maybe a
Nothing
  where
    SecurityParam Word64
k = TopLevelConfig TestBlock -> SecurityParam
forall blk.
ConsensusProtocol (BlockProtocol blk) =>
TopLevelConfig blk -> SecurityParam
configSecurityParam TopLevelConfig TestBlock
cfg

    curFrag :: AnchoredFragment TestBlock
    curFrag :: AnchoredFragment TestBlock
curFrag =
          Word64 -> AnchoredFragment TestBlock -> AnchoredFragment TestBlock
forall v a b.
Anchorable v a b =>
Word64 -> AnchoredSeq v a b -> AnchoredSeq v a b
AF.anchorNewest Word64
k
        (AnchoredFragment TestBlock -> AnchoredFragment TestBlock)
-> (Chain TestBlock -> AnchoredFragment TestBlock)
-> Chain TestBlock
-> AnchoredFragment TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chain TestBlock -> AnchoredFragment TestBlock
forall block.
HasHeader block =>
Chain block -> AnchoredFragment block
Chain.toAnchoredFragment
        (Chain TestBlock -> AnchoredFragment TestBlock)
-> Chain TestBlock -> AnchoredFragment TestBlock
forall a b. (a -> b) -> a -> b
$ Chain TestBlock
chain

    validPoints :: [Point TestBlock]
    validPoints :: [Point TestBlock]
validPoints =
        AnchoredFragment TestBlock -> Point TestBlock
forall block. AnchoredFragment block -> Point block
AF.anchorPoint AnchoredFragment TestBlock
curFrag Point TestBlock -> [Point TestBlock] -> [Point TestBlock]
forall a. a -> [a] -> [a]
: (TestBlock -> Point TestBlock) -> [TestBlock] -> [Point TestBlock]
forall a b. (a -> b) -> [a] -> [b]
map TestBlock -> Point TestBlock
forall block. HasHeader block => block -> Point block
blockPoint (AnchoredFragment TestBlock -> [TestBlock]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredFragment TestBlock
curFrag)

    -- | Apply blocks to the ledger state until we have applied the block
    -- matching @pt@, after which we return the resulting ledger.
    --
    -- PRECONDITION: @pt@ is in the list of blocks or genesis.
    go :: ExtLedgerState TestBlock -> [TestBlock] -> ExtLedgerState TestBlock
    go :: ExtLedgerState TestBlock -> [TestBlock] -> ExtLedgerState TestBlock
go !ExtLedgerState TestBlock
st [TestBlock]
blks
        | Point (ExtLedgerState TestBlock) -> Point TestBlock
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (ExtLedgerState TestBlock -> Point (ExtLedgerState TestBlock)
forall l. GetTip l => l -> Point l
getTip ExtLedgerState TestBlock
st) Point TestBlock -> Point TestBlock -> Bool
forall a. Eq a => a -> a -> Bool
== Point TestBlock
pt
        = ExtLedgerState TestBlock
st
        | TestBlock
blk:[TestBlock]
blks' <- [TestBlock]
blks
        = ExtLedgerState TestBlock -> [TestBlock] -> ExtLedgerState TestBlock
go (LedgerCfg (ExtLedgerState TestBlock)
-> TestBlock
-> ExtLedgerState TestBlock
-> ExtLedgerState TestBlock
forall l blk. ApplyBlock l blk => LedgerCfg l -> blk -> l -> l
tickThenReapply (TopLevelConfig TestBlock -> ExtLedgerCfg TestBlock
forall blk. TopLevelConfig blk -> ExtLedgerCfg blk
ExtLedgerCfg TopLevelConfig TestBlock
cfg) TestBlock
blk ExtLedgerState TestBlock
st) [TestBlock]
blks'
        | Bool
otherwise
        = String -> ExtLedgerState TestBlock
forall a. HasCallStack => String -> a
error String
"point not in the list of blocks"

-- | Simulates 'ChainDB.getHeaderStateHistory'.
computeHeaderStateHistory ::
     TopLevelConfig TestBlock
  -> Chain TestBlock
  -> HeaderStateHistory TestBlock
computeHeaderStateHistory :: TopLevelConfig TestBlock
-> Chain TestBlock -> HeaderStateHistory TestBlock
computeHeaderStateHistory TopLevelConfig TestBlock
cfg =
      Int -> HeaderStateHistory TestBlock -> HeaderStateHistory TestBlock
forall blk. Int -> HeaderStateHistory blk -> HeaderStateHistory blk
HeaderStateHistory.trim (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
k)
    (HeaderStateHistory TestBlock -> HeaderStateHistory TestBlock)
-> (Chain TestBlock -> HeaderStateHistory TestBlock)
-> Chain TestBlock
-> HeaderStateHistory TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevelConfig TestBlock
-> ExtLedgerState TestBlock
-> Chain TestBlock
-> HeaderStateHistory TestBlock
forall blk.
(ApplyBlock (ExtLedgerState blk) blk, HasHardForkHistory blk,
 HasAnnTip blk) =>
TopLevelConfig blk
-> ExtLedgerState blk -> Chain blk -> HeaderStateHistory blk
HeaderStateHistory.fromChain TopLevelConfig TestBlock
cfg ExtLedgerState TestBlock
testInitExtLedger
  where
    SecurityParam Word64
k = TopLevelConfig TestBlock -> SecurityParam
forall blk.
ConsensusProtocol (BlockProtocol blk) =>
TopLevelConfig blk -> SecurityParam
configSecurityParam TopLevelConfig TestBlock
cfg

{-------------------------------------------------------------------------------
  ChainSyncClientSetup
-------------------------------------------------------------------------------}

slotLength :: SlotLength
slotLength :: SlotLength
slotLength = Integer -> SlotLength
slotLengthFromSec (Integer -> SlotLength) -> Integer -> SlotLength
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Enum a => Int -> a
toEnum Int
slotLengthInSeconds

slotLengthInSeconds :: Int
slotLengthInSeconds :: Int
slotLengthInSeconds = Int
10

-- | The onset of the slot
toOnset :: SlotNo -> RelativeTime
toOnset :: SlotNo -> RelativeTime
toOnset SlotNo
slot = NominalDiffTime -> RelativeTime
RelativeTime (NominalDiffTime -> RelativeTime)
-> NominalDiffTime -> RelativeTime
forall a b. (a -> b) -> a -> b
$
    NominalDiffTime -> Word64 -> NominalDiffTime
forall a. Integral a => NominalDiffTime -> a -> NominalDiffTime
multipleNominalDelay
      (SlotLength -> NominalDiffTime
getSlotLength SlotLength
slotLength)
      (SlotNo -> Word64
unSlotNo SlotNo
slot)

-- | Tenths of a slot length
--
-- This adds some fractionality to the test without over-complicating it.
newtype SlotLengthTenths = SlotLengthTenths Int
  deriving (Int -> SlotLengthTenths -> String -> String
[SlotLengthTenths] -> String -> String
SlotLengthTenths -> String
(Int -> SlotLengthTenths -> String -> String)
-> (SlotLengthTenths -> String)
-> ([SlotLengthTenths] -> String -> String)
-> Show SlotLengthTenths
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> SlotLengthTenths -> String -> String
showsPrec :: Int -> SlotLengthTenths -> String -> String
$cshow :: SlotLengthTenths -> String
show :: SlotLengthTenths -> String
$cshowList :: [SlotLengthTenths] -> String -> String
showList :: [SlotLengthTenths] -> String -> String
Show)

slotLengthTenthsToClockSkew :: SlotLengthTenths -> ClockSkew
slotLengthTenthsToClockSkew :: SlotLengthTenths -> ClockSkew
slotLengthTenthsToClockSkew (SlotLengthTenths Int
tenths) =
    Double -> ClockSkew
clockSkewInSeconds (Double -> ClockSkew) -> Double -> ClockSkew
forall a b. (a -> b) -> a -> b
$ (Int -> Double
forall a. Enum a => Int -> a
toEnum Int
slotLengthInSeconds Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a. Enum a => Int -> a
toEnum Int
tenths) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
10

-- | Bundle dependent arguments for test generation
data ChainSyncClientSetup = ChainSyncClientSetup
  { ChainSyncClientSetup -> SecurityParam
securityParam :: SecurityParam
  , ChainSyncClientSetup -> ClientUpdates
clientUpdates :: ClientUpdates
    -- ^ Depends on 'securityParam' and 'clientUpdates'
  , ChainSyncClientSetup -> ServerUpdates
serverUpdates :: ServerUpdates
    -- ^ Depends on 'securityParam' and 'clientUpdates'
  , ChainSyncClientSetup -> Tick
startTick     :: Tick
    -- ^ Depends on 'clientUpdates' and 'serverUpdates'
  , ChainSyncClientSetup -> InvalidBlocks
invalidBlocks :: InvalidBlocks
    -- ^ Blocks that are discovered to be invalid.
  , ChainSyncClientSetup -> SlotLengthTenths
clientSlowBy  :: SlotLengthTenths
    -- ^ The server's clock minus the client's clock.
    --
    -- This is also passed to the code-under-test as the tolerable clock skew.
  }
  deriving (Int -> ChainSyncClientSetup -> String -> String
[ChainSyncClientSetup] -> String -> String
ChainSyncClientSetup -> String
(Int -> ChainSyncClientSetup -> String -> String)
-> (ChainSyncClientSetup -> String)
-> ([ChainSyncClientSetup] -> String -> String)
-> Show ChainSyncClientSetup
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ChainSyncClientSetup -> String -> String
showsPrec :: Int -> ChainSyncClientSetup -> String -> String
$cshow :: ChainSyncClientSetup -> String
show :: ChainSyncClientSetup -> String
$cshowList :: [ChainSyncClientSetup] -> String -> String
showList :: [ChainSyncClientSetup] -> String -> String
Show)

instance Arbitrary ChainSyncClientSetup where
  arbitrary :: Gen ChainSyncClientSetup
arbitrary = do
    SecurityParam
securityParam  <- Word64 -> SecurityParam
SecurityParam (Word64 -> SecurityParam) -> Gen Word64 -> Gen SecurityParam
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
2, Word64
5)
    ClientUpdates
clientUpdates0 <- Schedule ChainUpdate -> ClientUpdates
ClientUpdates (Schedule ChainUpdate -> ClientUpdates)
-> Gen (Schedule ChainUpdate) -> Gen ClientUpdates
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      UpdateBehavior -> SecurityParam -> Gen (Schedule ChainUpdate)
genUpdateSchedule UpdateBehavior
SelectedChainBehavior SecurityParam
securityParam
    ServerUpdates
serverUpdates  <- Schedule ChainUpdate -> ServerUpdates
ServerUpdates (Schedule ChainUpdate -> ServerUpdates)
-> Gen (Schedule ChainUpdate) -> Gen ServerUpdates
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      UpdateBehavior -> SecurityParam -> Gen (Schedule ChainUpdate)
genUpdateSchedule UpdateBehavior
TentativeChainBehavior SecurityParam
securityParam
    let clientUpdates :: ClientUpdates
clientUpdates = ServerUpdates -> ClientUpdates -> ClientUpdates
removeLateClientUpdates ServerUpdates
serverUpdates ClientUpdates
clientUpdates0
        maxStartTick :: Tick
maxStartTick  = [Tick] -> Tick
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum
          [ Word64 -> Tick
Tick Word64
1
          , Schedule ChainUpdate -> Tick
forall a. Schedule a -> Tick
lastTick (ClientUpdates -> Schedule ChainUpdate
getClientUpdates ClientUpdates
clientUpdates) Tick -> Tick -> Tick
forall a. Num a => a -> a -> a
- Tick
1
          , Schedule ChainUpdate -> Tick
forall a. Schedule a -> Tick
lastTick (ServerUpdates -> Schedule ChainUpdate
getServerUpdates ServerUpdates
serverUpdates) Tick -> Tick -> Tick
forall a. Num a => a -> a -> a
- Tick
1
          ]
    Tick
startTick <- Int -> (Tick, Tick) -> Gen Tick
forall a. Enum a => Int -> (a, a) -> Gen a
chooseExponential Int
3 (Tick
1, Tick
maxStartTick)
    let trapBlocks :: [TestHash]
trapBlocks =
          [ TestBlock -> HeaderHash TestBlock
forall b. HasHeader b => b -> HeaderHash b
blockHash TestBlock
b
          | AddBlock TestBlock
b <- Schedule ChainUpdate -> [ChainUpdate]
forall a. Schedule a -> [a]
joinSchedule (ServerUpdates -> Schedule ChainUpdate
getServerUpdates ServerUpdates
serverUpdates)
          , TestBlock -> Validity
forall ptype. TestBlockWith ptype -> Validity
tbValid TestBlock
b Validity -> Validity -> Bool
forall a. Eq a => a -> a -> Bool
== Validity
Invalid
          ]
    InvalidBlocks
invalidBlocks <- Schedule TestHash -> InvalidBlocks
InvalidBlocks (Schedule TestHash -> InvalidBlocks)
-> Gen (Schedule TestHash) -> Gen InvalidBlocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([TestHash] -> Gen (Schedule TestHash)
forall a. [a] -> Gen (Schedule a)
genSchedule ([TestHash] -> Gen (Schedule TestHash))
-> Gen [TestHash] -> Gen (Schedule TestHash)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [TestHash] -> Gen [TestHash]
forall a. [a] -> Gen [a]
shuffle [TestHash]
trapBlocks)

    SlotLengthTenths
clientSlowBy <- Int -> SlotLengthTenths
SlotLengthTenths (Int -> SlotLengthTenths) -> Gen Int -> Gen SlotLengthTenths
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
50)

    ChainSyncClientSetup -> Gen ChainSyncClientSetup
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return ChainSyncClientSetup {
        SecurityParam
securityParam :: SecurityParam
securityParam :: SecurityParam
securityParam
      , ClientUpdates
clientUpdates :: ClientUpdates
clientUpdates :: ClientUpdates
clientUpdates
      , ServerUpdates
serverUpdates :: ServerUpdates
serverUpdates :: ServerUpdates
serverUpdates
      , Tick
startTick :: Tick
startTick :: Tick
startTick
      , InvalidBlocks
invalidBlocks :: InvalidBlocks
invalidBlocks :: InvalidBlocks
invalidBlocks
      , SlotLengthTenths
clientSlowBy :: SlotLengthTenths
clientSlowBy :: SlotLengthTenths
clientSlowBy
      }
  shrink :: ChainSyncClientSetup -> [ChainSyncClientSetup]
shrink cscs :: ChainSyncClientSetup
cscs@ChainSyncClientSetup {
      ClientUpdates
clientUpdates :: ChainSyncClientSetup -> ClientUpdates
clientUpdates :: ClientUpdates
clientUpdates
    , ServerUpdates
serverUpdates :: ChainSyncClientSetup -> ServerUpdates
serverUpdates :: ServerUpdates
serverUpdates
    , Tick
startTick :: ChainSyncClientSetup -> Tick
startTick :: Tick
startTick
    , SlotLengthTenths
clientSlowBy :: ChainSyncClientSetup -> SlotLengthTenths
clientSlowBy :: SlotLengthTenths
clientSlowBy
    } =
    -- We don't shrink 'securityParam' because the updates depend on it

    -- We also don't shrink 'invalidBlocks' right now (as it does not impact
    -- correctness), but it might be confusing to see blocks in it that are not
    -- part of the update schedules.
    [ ChainSyncClientSetup
cscs
      { serverUpdates = ServerUpdates serverUpdates'
      , clientUpdates = removeLateClientUpdates
                          (ServerUpdates serverUpdates')
                          clientUpdates
      , startTick     = startTick'
      }
    | Schedule ChainUpdate
serverUpdates' <- Schedule ChainUpdate -> [Schedule ChainUpdate]
forall a. Schedule a -> [Schedule a]
shrinkSchedule (ServerUpdates -> Schedule ChainUpdate
getServerUpdates ServerUpdates
serverUpdates)
    , let maxStartTick :: Tick
maxStartTick = [Tick] -> Tick
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum
            [ Tick
1
            , Schedule ChainUpdate -> Tick
forall a. Schedule a -> Tick
lastTick (ClientUpdates -> Schedule ChainUpdate
getClientUpdates ClientUpdates
clientUpdates) Tick -> Tick -> Tick
forall a. Num a => a -> a -> a
- Tick
1
            , Schedule ChainUpdate -> Tick
forall a. Schedule a -> Tick
lastTick Schedule ChainUpdate
serverUpdates' Tick -> Tick -> Tick
forall a. Num a => a -> a -> a
- Tick
1
            ]
    , Tick
startTick' <- [Tick
1..Tick -> Tick -> Tick
forall a. Ord a => a -> a -> a
min Tick
startTick Tick
maxStartTick]
    ] [ChainSyncClientSetup]
-> [ChainSyncClientSetup] -> [ChainSyncClientSetup]
forall a. Semigroup a => a -> a -> a
<>
    [ ChainSyncClientSetup
cscs
      { clientUpdates = clientUpdates'
      , startTick     = startTick'
      }
    | ClientUpdates
clientUpdates' <-
        ServerUpdates -> ClientUpdates -> ClientUpdates
removeLateClientUpdates ServerUpdates
serverUpdates (ClientUpdates -> ClientUpdates)
-> (Schedule ChainUpdate -> ClientUpdates)
-> Schedule ChainUpdate
-> ClientUpdates
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schedule ChainUpdate -> ClientUpdates
ClientUpdates (Schedule ChainUpdate -> ClientUpdates)
-> [Schedule ChainUpdate] -> [ClientUpdates]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Schedule ChainUpdate -> [Schedule ChainUpdate]
forall a. Schedule a -> [Schedule a]
shrinkSchedule (ClientUpdates -> Schedule ChainUpdate
getClientUpdates ClientUpdates
clientUpdates)
    , let maxStartTick :: Tick
maxStartTick = [Tick] -> Tick
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum
            [ Tick
1
            , Schedule ChainUpdate -> Tick
forall a. Schedule a -> Tick
lastTick (ClientUpdates -> Schedule ChainUpdate
getClientUpdates ClientUpdates
clientUpdates') Tick -> Tick -> Tick
forall a. Num a => a -> a -> a
- Tick
1
            , Schedule ChainUpdate -> Tick
forall a. Schedule a -> Tick
lastTick (ServerUpdates -> Schedule ChainUpdate
getServerUpdates ServerUpdates
serverUpdates)  Tick -> Tick -> Tick
forall a. Num a => a -> a -> a
- Tick
1
            ]
    , Tick
startTick' <- [Tick
1..Tick -> Tick -> Tick
forall a. Ord a => a -> a -> a
min Tick
startTick Tick
maxStartTick]
    ] [ChainSyncClientSetup]
-> [ChainSyncClientSetup] -> [ChainSyncClientSetup]
forall a. Semigroup a => a -> a -> a
<>
    [ ChainSyncClientSetup
cscs { clientSlowBy = SlotLengthTenths y }
    | let SlotLengthTenths Int
x = SlotLengthTenths
clientSlowBy
    , Int
y <- Int -> [Int]
forall a. Arbitrary a => a -> [a]
shrink Int
x
    ]

chooseExponential :: Enum a => Int -> (a, a) -> Gen a
chooseExponential :: forall a. Enum a => Int -> (a, a) -> Gen a
chooseExponential Int
decayFactor (a
low, a
up) =
  [(Int, Gen a)] -> Gen a
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
    [ (Int
decayFactor, a -> Gen a
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
low)
    , (Int
1, Int -> (a, a) -> Gen a
forall a. Enum a => Int -> (a, a) -> Gen a
chooseExponential Int
decayFactor (a -> a
forall a. Enum a => a -> a
succ a
low, a
up))
    ]

prettyChainSyncClientSetup :: ChainSyncClientSetup -> String
prettyChainSyncClientSetup :: ChainSyncClientSetup -> String
prettyChainSyncClientSetup ChainSyncClientSetup
testSetup =
    [String] -> String
unlines
      [ String
"ChainSyncClientSetup:"
      , String
"securityParam: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a. Show a => a -> String
show (SecurityParam -> Word64
maxRollbacks SecurityParam
securityParam)
      , String
"clientSlowBy: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> String
forall a. Show a => a -> String
show (ClockSkew -> NominalDiffTime
unClockSkew ClockSkew
skew)
      , String
"--"
      , String
"clockUpdates:"
      , Schedule NewMaxSlot -> String
forall a. Condense a => a -> String
condense (ClientUpdates -> ServerUpdates -> Schedule NewMaxSlot
mkClockUpdates ClientUpdates
clientUpdates ServerUpdates
serverUpdates) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"--"
      , String
"clientUpdates:"
      , Schedule ChainUpdate -> String
forall a. Condense a => a -> String
condense (ClientUpdates -> Schedule ChainUpdate
getClientUpdates ClientUpdates
clientUpdates) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"--"
      , String
"serverUpdates:"
      , Schedule ChainUpdate -> String
forall a. Condense a => a -> String
condense (ServerUpdates -> Schedule ChainUpdate
getServerUpdates ServerUpdates
serverUpdates) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"--"
      , String
"startTick: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Tick -> String
forall a. Show a => a -> String
show Tick
startTick
      , String
"invalidBlocks: "
      , Schedule TestHash -> String
forall a. Condense a => a -> String
condense (InvalidBlocks -> Schedule TestHash
getInvalidBlocks InvalidBlocks
invalidBlocks)
      ]
  where
    -- if you add a field to this pattern to avoid warnings, add it below too
    ChainSyncClientSetup SecurityParam
_ ClientUpdates
_ ServerUpdates
_ Tick
_ InvalidBlocks
_ SlotLengthTenths
_dummy = ChainSyncClientSetup
testSetup
    ChainSyncClientSetup {
        SecurityParam
securityParam :: ChainSyncClientSetup -> SecurityParam
securityParam :: SecurityParam
securityParam
      , SlotLengthTenths
clientSlowBy :: ChainSyncClientSetup -> SlotLengthTenths
clientSlowBy :: SlotLengthTenths
clientSlowBy
      , ClientUpdates
clientUpdates :: ChainSyncClientSetup -> ClientUpdates
clientUpdates :: ClientUpdates
clientUpdates
      , ServerUpdates
serverUpdates :: ChainSyncClientSetup -> ServerUpdates
serverUpdates :: ServerUpdates
serverUpdates
      , Tick
startTick :: ChainSyncClientSetup -> Tick
startTick :: Tick
startTick
      , InvalidBlocks
invalidBlocks :: ChainSyncClientSetup -> InvalidBlocks
invalidBlocks :: InvalidBlocks
invalidBlocks
      } = ChainSyncClientSetup
testSetup

    skew :: ClockSkew
skew = SlotLengthTenths -> ClockSkew
slotLengthTenthsToClockSkew SlotLengthTenths
clientSlowBy

-- | Remove client updates that happen at a tick after the tick in which the
-- last server updates happened.
--
-- If we don't do this, the client's chain might no longer intersect with the
-- synced candidate. This is because the ChainSync protocol won't have had a
-- chance to update the candidate fragment, as the code to handle this case
-- (our chain has changed such that it no longer intersects with the synced
-- candidate -> initiate the \"find a new intersection\" part of the protocol)
-- is run when we receive new messages (roll forward/backward) from the
-- server.
removeLateClientUpdates :: ServerUpdates -> ClientUpdates -> ClientUpdates
removeLateClientUpdates :: ServerUpdates -> ClientUpdates -> ClientUpdates
removeLateClientUpdates (ServerUpdates (Schedule Map Tick [ChainUpdate]
sus))
    | Just ((Tick
lastServerUpdateTickNo, [ChainUpdate]
_), Map Tick [ChainUpdate]
_) <- Map Tick [ChainUpdate]
-> Maybe ((Tick, [ChainUpdate]), Map Tick [ChainUpdate])
forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.maxViewWithKey Map Tick [ChainUpdate]
sus
    = \(ClientUpdates (Schedule Map Tick [ChainUpdate]
cus)) ->
       let (Map Tick [ChainUpdate]
cus', Map Tick [ChainUpdate]
_) = Tick
-> Map Tick [ChainUpdate]
-> (Map Tick [ChainUpdate], Map Tick [ChainUpdate])
forall k a. Ord k => k -> Map k a -> (Map k a, Map k a)
Map.split (Tick -> Tick
forall a. Enum a => a -> a
succ Tick
lastServerUpdateTickNo) Map Tick [ChainUpdate]
cus
           -- @cus'@ contains the entries with a key < @succ
           -- lastServerUpdateTickNo@
       in Schedule ChainUpdate -> ClientUpdates
ClientUpdates (Map Tick [ChainUpdate] -> Schedule ChainUpdate
forall a. Map Tick [a] -> Schedule a
Schedule Map Tick [ChainUpdate]
cus')
    | Bool
otherwise
    = ClientUpdates -> ClientUpdates
forall a. a -> a
id

{-------------------------------------------------------------------------------
  Generating a schedule of updates
-------------------------------------------------------------------------------}

genUpdateSchedule ::
     UpdateBehavior
  -> SecurityParam
  -> Gen (Schedule ChainUpdate)
genUpdateSchedule :: UpdateBehavior -> SecurityParam -> Gen (Schedule ChainUpdate)
genUpdateSchedule UpdateBehavior
updateBehavior SecurityParam
securityParam =
    UpdateBehavior -> SecurityParam -> Int -> Gen [ChainUpdate]
genChainUpdates UpdateBehavior
updateBehavior SecurityParam
securityParam Int
10 Gen [ChainUpdate]
-> ([ChainUpdate] -> Gen (Schedule ChainUpdate))
-> Gen (Schedule ChainUpdate)
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [ChainUpdate] -> Gen (Schedule ChainUpdate)
forall a. [a] -> Gen (Schedule a)
genSchedule

data NewMaxSlot =
    NewMaxClientSlot          SlotNo
    -- ^ the client's chain reaches a new greatest slot
  | NewMaxServerSlot                 SlotNo
    -- ^ the server's chain reaches a new greatest slot
  | NewMaxClientAndServerSlot SlotNo SlotNo
    -- ^ both the client and the server's chain reach a new greatest slot,
    -- respectively
  deriving (Int -> NewMaxSlot -> String -> String
[NewMaxSlot] -> String -> String
NewMaxSlot -> String
(Int -> NewMaxSlot -> String -> String)
-> (NewMaxSlot -> String)
-> ([NewMaxSlot] -> String -> String)
-> Show NewMaxSlot
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> NewMaxSlot -> String -> String
showsPrec :: Int -> NewMaxSlot -> String -> String
$cshow :: NewMaxSlot -> String
show :: NewMaxSlot -> String
$cshowList :: [NewMaxSlot] -> String -> String
showList :: [NewMaxSlot] -> String -> String
Show)

instance Condense NewMaxSlot where
  condense :: NewMaxSlot -> String
condense = \case
    NewMaxClientSlot SlotNo
slot -> String
"c" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SlotNo -> String
forall a. Condense a => a -> String
condense SlotNo
slot String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"|s_"
    NewMaxServerSlot SlotNo
slot -> String
"c_|s" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SlotNo -> String
forall a. Condense a => a -> String
condense SlotNo
slot

    NewMaxClientAndServerSlot SlotNo
cslot SlotNo
sslot ->
      String
"c" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SlotNo -> String
forall a. Condense a => a -> String
condense SlotNo
cslot String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"|s" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SlotNo -> String
forall a. Condense a => a -> String
condense SlotNo
sslot

-- | The schedule of when the the client and server chains reach a new greatest
-- slot, respectively.
--
-- The resulting schedule has exactly one entry per tick in the map (ie no
-- simultaneity). Moreover, it's monotonic within the client and within the
-- server, but not necessarily in their union.
--
-- We need to track them separately because the client selecting a block in a
-- slot implies the local clock has reached surpassed that onset, whereas the
-- server doing so does not.
mkClockUpdates :: ClientUpdates -> ServerUpdates -> Schedule NewMaxSlot
mkClockUpdates :: ClientUpdates -> ServerUpdates -> Schedule NewMaxSlot
mkClockUpdates = \(ClientUpdates Schedule ChainUpdate
cupds) (ServerUpdates Schedule ChainUpdate
supds) ->
      Map Tick [NewMaxSlot] -> Schedule NewMaxSlot
forall a. Map Tick [a] -> Schedule a
Schedule
    (Map Tick [NewMaxSlot] -> Schedule NewMaxSlot)
-> Map Tick [NewMaxSlot] -> Schedule NewMaxSlot
forall a b. (a -> b) -> a -> b
$ (NewMaxSlot -> [NewMaxSlot])
-> Map Tick NewMaxSlot -> Map Tick [NewMaxSlot]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((NewMaxSlot -> [NewMaxSlot] -> [NewMaxSlot]
forall a. a -> [a] -> [a]
:[]))
    (Map Tick NewMaxSlot -> Map Tick [NewMaxSlot])
-> Map Tick NewMaxSlot -> Map Tick [NewMaxSlot]
forall a b. (a -> b) -> a -> b
$ SimpleWhenMissing Tick SlotNo NewMaxSlot
-> SimpleWhenMissing Tick SlotNo NewMaxSlot
-> SimpleWhenMatched Tick SlotNo SlotNo NewMaxSlot
-> Map Tick SlotNo
-> Map Tick SlotNo
-> Map Tick NewMaxSlot
forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
Map.merge
        ((Tick -> SlotNo -> NewMaxSlot)
-> SimpleWhenMissing Tick SlotNo NewMaxSlot
forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
Map.mapMissing ((Tick -> SlotNo -> NewMaxSlot)
 -> SimpleWhenMissing Tick SlotNo NewMaxSlot)
-> (Tick -> SlotNo -> NewMaxSlot)
-> SimpleWhenMissing Tick SlotNo NewMaxSlot
forall a b. (a -> b) -> a -> b
$ \Tick
_ -> SlotNo -> NewMaxSlot
NewMaxClientSlot)
        ((Tick -> SlotNo -> NewMaxSlot)
-> SimpleWhenMissing Tick SlotNo NewMaxSlot
forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
Map.mapMissing ((Tick -> SlotNo -> NewMaxSlot)
 -> SimpleWhenMissing Tick SlotNo NewMaxSlot)
-> (Tick -> SlotNo -> NewMaxSlot)
-> SimpleWhenMissing Tick SlotNo NewMaxSlot
forall a b. (a -> b) -> a -> b
$ \Tick
_ -> SlotNo -> NewMaxSlot
NewMaxServerSlot)
        ((Tick -> SlotNo -> SlotNo -> NewMaxSlot)
-> SimpleWhenMatched Tick SlotNo SlotNo NewMaxSlot
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
Map.zipWithMatched ((Tick -> SlotNo -> SlotNo -> NewMaxSlot)
 -> SimpleWhenMatched Tick SlotNo SlotNo NewMaxSlot)
-> (Tick -> SlotNo -> SlotNo -> NewMaxSlot)
-> SimpleWhenMatched Tick SlotNo SlotNo NewMaxSlot
forall a b. (a -> b) -> a -> b
$ \Tick
_ -> SlotNo -> SlotNo -> NewMaxSlot
NewMaxClientAndServerSlot)
        (Schedule ChainUpdate -> Map Tick SlotNo
newMaxes Schedule ChainUpdate
cupds)
        (Schedule ChainUpdate -> Map Tick SlotNo
newMaxes Schedule ChainUpdate
supds)
  where
    newMaxes :: Schedule ChainUpdate -> Map.Map Tick SlotNo
    newMaxes :: Schedule ChainUpdate -> Map Tick SlotNo
newMaxes =
        Map Tick SlotNo -> Map Tick SlotNo
forall k v. (Eq k, Ord v) => Map k v -> Map k v
makeMonotonic
      (Map Tick SlotNo -> Map Tick SlotNo)
-> (Schedule ChainUpdate -> Map Tick SlotNo)
-> Schedule ChainUpdate
-> Map Tick SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([ChainUpdate] -> Maybe SlotNo)
-> Map Tick [ChainUpdate] -> Map Tick SlotNo
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe ((Max SlotNo -> SlotNo) -> Maybe (Max SlotNo) -> Maybe SlotNo
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Max SlotNo -> SlotNo
forall a. Max a -> a
getMax (Maybe (Max SlotNo) -> Maybe SlotNo)
-> ([ChainUpdate] -> Maybe (Max SlotNo))
-> [ChainUpdate]
-> Maybe SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChainUpdate -> Maybe (Max SlotNo))
-> [ChainUpdate] -> Maybe (Max SlotNo)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ChainUpdate -> Maybe (Max SlotNo)
maxSlot)
      (Map Tick [ChainUpdate] -> Map Tick SlotNo)
-> (Schedule ChainUpdate -> Map Tick [ChainUpdate])
-> Schedule ChainUpdate
-> Map Tick SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schedule ChainUpdate -> Map Tick [ChainUpdate]
forall a. Schedule a -> Map Tick [a]
getSchedule

    maxSlot :: ChainUpdate -> Maybe (Max SlotNo)
    maxSlot :: ChainUpdate -> Maybe (Max SlotNo)
maxSlot = (TestBlock -> Maybe (Max SlotNo))
-> [TestBlock] -> Maybe (Max SlotNo)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Max SlotNo -> Maybe (Max SlotNo)
forall a. a -> Maybe a
Just (Max SlotNo -> Maybe (Max SlotNo))
-> (TestBlock -> Max SlotNo) -> TestBlock -> Maybe (Max SlotNo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo -> Max SlotNo
forall a. a -> Max a
Max (SlotNo -> Max SlotNo)
-> (TestBlock -> SlotNo) -> TestBlock -> Max SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestBlock -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot) ([TestBlock] -> Maybe (Max SlotNo))
-> (ChainUpdate -> [TestBlock])
-> ChainUpdate
-> Maybe (Max SlotNo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      AddBlock TestBlock
b      -> [TestBlock
b]
      SwitchFork Point TestBlock
_ [TestBlock]
bs -> [TestBlock]
bs

    makeMonotonic :: (Eq k, Ord v) => Map.Map k v -> Map.Map k v
    makeMonotonic :: forall k v. (Eq k, Ord v) => Map k v -> Map k v
makeMonotonic Map k v
mp = [(k, v)] -> Map k v
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList ([(k, v)] -> Map k v) -> [(k, v)] -> Map k v
forall a b. (a -> b) -> a -> b
$ case Map k v -> [(k, v)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map k v
mp of
        []           -> []
        (k
k0, v
x) : [(k, v)]
xs -> (k
k0, v
x) (k, v) -> [(k, v)] -> [(k, v)]
forall a. a -> [a] -> [a]
: v -> [(k, v)] -> [(k, v)]
forall {t} {a}. Ord t => t -> [(a, t)] -> [(a, t)]
go v
x [(k, v)]
xs
    go :: t -> [(a, t)] -> [(a, t)]
go t
acc = \case
        []          -> []
        (a
k, t
x) : [(a, t)]
xs -> if t
x t -> t -> Bool
forall a. Ord a => a -> a -> Bool
> t
acc then (a
k, t
x) (a, t) -> [(a, t)] -> [(a, t)]
forall a. a -> [a] -> [a]
: t -> [(a, t)] -> [(a, t)]
go t
x [(a, t)]
xs else t -> [(a, t)] -> [(a, t)]
go t
acc [(a, t)]
xs

{-------------------------------------------------------------------------------
  Pretty-printing
-------------------------------------------------------------------------------}

ppBlock :: TestBlock -> String
ppBlock :: TestBlock -> String
ppBlock = TestBlock -> String
forall a. Condense a => a -> String
condense

ppPoint :: StandardHash blk => Point blk -> String
ppPoint :: forall blk. StandardHash blk => Point blk -> String
ppPoint Point blk
GenesisPoint              = String
"Origin"
ppPoint (BlockPoint (SlotNo Word64
s) HeaderHash blk
h) = String
"(S:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a. Show a => a -> String
show Word64
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"; H:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HeaderHash blk -> String
forall a. Show a => a -> String
show HeaderHash blk
h String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"

ppChain :: Chain TestBlock -> String
ppChain :: Chain TestBlock -> String
ppChain = Point TestBlock -> [TestBlock] -> String
ppBlocks Point TestBlock
forall {k} (block :: k). Point block
GenesisPoint ([TestBlock] -> String)
-> (Chain TestBlock -> [TestBlock]) -> Chain TestBlock -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chain TestBlock -> [TestBlock]
forall block. Chain block -> [block]
Chain.toOldestFirst

ppFragment :: AnchoredFragment TestBlock -> String
ppFragment :: AnchoredFragment TestBlock -> String
ppFragment AnchoredFragment TestBlock
f = Point TestBlock -> [TestBlock] -> String
ppBlocks (AnchoredFragment TestBlock -> Point TestBlock
forall block. AnchoredFragment block -> Point block
AF.anchorPoint AnchoredFragment TestBlock
f) (AnchoredFragment TestBlock -> [TestBlock]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredFragment TestBlock
f)

ppBlocks :: Point TestBlock -> [TestBlock] -> String
ppBlocks :: Point TestBlock -> [TestBlock] -> String
ppBlocks Point TestBlock
a [TestBlock]
bs = Point TestBlock -> String
forall blk. StandardHash blk => Point blk -> String
ppPoint Point TestBlock
a String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ] " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" :> " ((TestBlock -> String) -> [TestBlock] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map TestBlock -> String
ppBlock [TestBlock]
bs)

ppTraceEvent :: TraceEvent -> String
ppTraceEvent :: TraceEvent -> String
ppTraceEvent (Tick Word64
n, RelativeTime NominalDiffTime
t, Either
  (TraceChainSyncClientEvent TestBlock)
  (TraceSendRecv
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))
ev) = (Word64, NominalDiffTime) -> String
forall a. Show a => a -> String
show (Word64
n, NominalDiffTime
t) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" | " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> case Either
  (TraceChainSyncClientEvent TestBlock)
  (TraceSendRecv
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)))
ev of
    Left  TraceChainSyncClientEvent TestBlock
cl -> String
"Client: "   String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TraceChainSyncClientEvent TestBlock -> String
forall a. Show a => a -> String
show TraceChainSyncClientEvent TestBlock
cl
    Right TraceSendRecv
  (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
pt -> String
"Protocol: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TraceSendRecv
  (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
-> String
forall a. Show a => a -> String
show TraceSendRecv
  (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
pt

{-------------------------------------------------------------------------------
  Classifying examples
-------------------------------------------------------------------------------}

data TickArrivalTimeStats a = OnlyNotEarly_SomeEarly {
    forall a. TickArrivalTimeStats a -> a
onlyNotEarlyTATS :: !a
    -- ^ Logical ticks in which some headers are arriving but none are from the
    -- future
  , forall a. TickArrivalTimeStats a -> a
someEarlyTATS    :: !a
    -- ^ Logical ticks in which some headers are arriving from the future
  }
  deriving ((forall a b.
 (a -> b) -> TickArrivalTimeStats a -> TickArrivalTimeStats b)
-> (forall a b.
    a -> TickArrivalTimeStats b -> TickArrivalTimeStats a)
-> Functor TickArrivalTimeStats
forall a b. a -> TickArrivalTimeStats b -> TickArrivalTimeStats a
forall a b.
(a -> b) -> TickArrivalTimeStats a -> TickArrivalTimeStats b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b.
(a -> b) -> TickArrivalTimeStats a -> TickArrivalTimeStats b
fmap :: forall a b.
(a -> b) -> TickArrivalTimeStats a -> TickArrivalTimeStats b
$c<$ :: forall a b. a -> TickArrivalTimeStats b -> TickArrivalTimeStats a
<$ :: forall a b. a -> TickArrivalTimeStats b -> TickArrivalTimeStats a
Functor, (forall x.
 TickArrivalTimeStats a -> Rep (TickArrivalTimeStats a) x)
-> (forall x.
    Rep (TickArrivalTimeStats a) x -> TickArrivalTimeStats a)
-> Generic (TickArrivalTimeStats a)
forall x. Rep (TickArrivalTimeStats a) x -> TickArrivalTimeStats a
forall x. TickArrivalTimeStats a -> Rep (TickArrivalTimeStats a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x.
Rep (TickArrivalTimeStats a) x -> TickArrivalTimeStats a
forall a x.
TickArrivalTimeStats a -> Rep (TickArrivalTimeStats a) x
$cfrom :: forall a x.
TickArrivalTimeStats a -> Rep (TickArrivalTimeStats a) x
from :: forall x. TickArrivalTimeStats a -> Rep (TickArrivalTimeStats a) x
$cto :: forall a x.
Rep (TickArrivalTimeStats a) x -> TickArrivalTimeStats a
to :: forall x. Rep (TickArrivalTimeStats a) x -> TickArrivalTimeStats a
Generic)
  deriving (Int -> TickArrivalTimeStats a -> String -> String
[TickArrivalTimeStats a] -> String -> String
TickArrivalTimeStats a -> String
(Int -> TickArrivalTimeStats a -> String -> String)
-> (TickArrivalTimeStats a -> String)
-> ([TickArrivalTimeStats a] -> String -> String)
-> Show (TickArrivalTimeStats a)
forall a.
Show a =>
Int -> TickArrivalTimeStats a -> String -> String
forall a. Show a => [TickArrivalTimeStats a] -> String -> String
forall a. Show a => TickArrivalTimeStats a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: forall a.
Show a =>
Int -> TickArrivalTimeStats a -> String -> String
showsPrec :: Int -> TickArrivalTimeStats a -> String -> String
$cshow :: forall a. Show a => TickArrivalTimeStats a -> String
show :: TickArrivalTimeStats a -> String
$cshowList :: forall a. Show a => [TickArrivalTimeStats a] -> String -> String
showList :: [TickArrivalTimeStats a] -> String -> String
Show) via (Quiet (TickArrivalTimeStats a))
  deriving (Semigroup (TickArrivalTimeStats a)
TickArrivalTimeStats a
Semigroup (TickArrivalTimeStats a) =>
TickArrivalTimeStats a
-> (TickArrivalTimeStats a
    -> TickArrivalTimeStats a -> TickArrivalTimeStats a)
-> ([TickArrivalTimeStats a] -> TickArrivalTimeStats a)
-> Monoid (TickArrivalTimeStats a)
[TickArrivalTimeStats a] -> TickArrivalTimeStats a
TickArrivalTimeStats a
-> TickArrivalTimeStats a -> TickArrivalTimeStats a
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. Monoid a => Semigroup (TickArrivalTimeStats a)
forall a. Monoid a => TickArrivalTimeStats a
forall a.
Monoid a =>
[TickArrivalTimeStats a] -> TickArrivalTimeStats a
forall a.
Monoid a =>
TickArrivalTimeStats a
-> TickArrivalTimeStats a -> TickArrivalTimeStats a
$cmempty :: forall a. Monoid a => TickArrivalTimeStats a
mempty :: TickArrivalTimeStats a
$cmappend :: forall a.
Monoid a =>
TickArrivalTimeStats a
-> TickArrivalTimeStats a -> TickArrivalTimeStats a
mappend :: TickArrivalTimeStats a
-> TickArrivalTimeStats a -> TickArrivalTimeStats a
$cmconcat :: forall a.
Monoid a =>
[TickArrivalTimeStats a] -> TickArrivalTimeStats a
mconcat :: [TickArrivalTimeStats a] -> TickArrivalTimeStats a
Monoid, NonEmpty (TickArrivalTimeStats a) -> TickArrivalTimeStats a
TickArrivalTimeStats a
-> TickArrivalTimeStats a -> TickArrivalTimeStats a
(TickArrivalTimeStats a
 -> TickArrivalTimeStats a -> TickArrivalTimeStats a)
-> (NonEmpty (TickArrivalTimeStats a) -> TickArrivalTimeStats a)
-> (forall b.
    Integral b =>
    b -> TickArrivalTimeStats a -> TickArrivalTimeStats a)
-> Semigroup (TickArrivalTimeStats a)
forall b.
Integral b =>
b -> TickArrivalTimeStats a -> TickArrivalTimeStats a
forall a.
Monoid a =>
NonEmpty (TickArrivalTimeStats a) -> TickArrivalTimeStats a
forall a.
Monoid a =>
TickArrivalTimeStats a
-> TickArrivalTimeStats a -> TickArrivalTimeStats a
forall a b.
(Monoid a, Integral b) =>
b -> TickArrivalTimeStats a -> TickArrivalTimeStats a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: forall a.
Monoid a =>
TickArrivalTimeStats a
-> TickArrivalTimeStats a -> TickArrivalTimeStats a
<> :: TickArrivalTimeStats a
-> TickArrivalTimeStats a -> TickArrivalTimeStats a
$csconcat :: forall a.
Monoid a =>
NonEmpty (TickArrivalTimeStats a) -> TickArrivalTimeStats a
sconcat :: NonEmpty (TickArrivalTimeStats a) -> TickArrivalTimeStats a
$cstimes :: forall a b.
(Monoid a, Integral b) =>
b -> TickArrivalTimeStats a -> TickArrivalTimeStats a
stimes :: forall b.
Integral b =>
b -> TickArrivalTimeStats a -> TickArrivalTimeStats a
Semigroup) via
    (InstantiatedAt Generic (TickArrivalTimeStats a))

data ZOM = Zero | One | Many
  deriving (Int -> ZOM -> String -> String
[ZOM] -> String -> String
ZOM -> String
(Int -> ZOM -> String -> String)
-> (ZOM -> String) -> ([ZOM] -> String -> String) -> Show ZOM
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ZOM -> String -> String
showsPrec :: Int -> ZOM -> String -> String
$cshow :: ZOM -> String
show :: ZOM -> String
$cshowList :: [ZOM] -> String -> String
showList :: [ZOM] -> String -> String
Show)

sizeZOM :: Set.Set a -> ZOM
sizeZOM :: forall a. Set a -> ZOM
sizeZOM Set a
x = case Set a -> Int
forall a. Set a -> Int
Set.size Set a
x of
    Int
0 -> ZOM
Zero
    Int
1 -> ZOM
One
    Int
_ -> ZOM
Many   -- NB negatives are impossible

tickArrivalTimeStats :: [TraceEvent] -> TickArrivalTimeStats ZOM
tickArrivalTimeStats :: [TraceEvent] -> TickArrivalTimeStats ZOM
tickArrivalTimeStats [TraceEvent]
events =
    (Set Tick -> ZOM)
-> TickArrivalTimeStats (Set Tick) -> TickArrivalTimeStats ZOM
forall a b.
(a -> b) -> TickArrivalTimeStats a -> TickArrivalTimeStats b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Set Tick -> ZOM
forall a. Set a -> ZOM
sizeZOM (TickArrivalTimeStats (Set Tick) -> TickArrivalTimeStats ZOM)
-> TickArrivalTimeStats (Set Tick) -> TickArrivalTimeStats ZOM
forall a b. (a -> b) -> a -> b
$
    OnlyNotEarly_SomeEarly {
        onlyNotEarlyTATS :: Set Tick
onlyNotEarlyTATS = Set Tick
onlyNotEarly Set Tick -> Set Tick -> Set Tick
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Tick
someEarly
      , someEarlyTATS :: Set Tick
someEarlyTATS    = Set Tick
someEarly
      }
  where
    -- if you add a field to this pattern to avoid warnings, add it below too
    OnlyNotEarly_SomeEarly Set Tick
_ Set Tick
_dummy = [TraceEvent] -> TickArrivalTimeStats (Set Tick)
tickArrivalTimes [TraceEvent]
events
    OnlyNotEarly_SomeEarly {
        onlyNotEarlyTATS :: forall a. TickArrivalTimeStats a -> a
onlyNotEarlyTATS = Set Tick
onlyNotEarly
      , someEarlyTATS :: forall a. TickArrivalTimeStats a -> a
someEarlyTATS    = Set Tick
someEarly
      } = [TraceEvent] -> TickArrivalTimeStats (Set Tick)
tickArrivalTimes [TraceEvent]
events

-- | WARNING 'onlyNotEarlyTATS' is instead merely @someNotEarlyTATS@ in this
-- codomain: it might overlap with the 'someEarlyTATs' field
tickArrivalTimes :: [TraceEvent] -> TickArrivalTimeStats (Set.Set Tick)
tickArrivalTimes :: [TraceEvent] -> TickArrivalTimeStats (Set Tick)
tickArrivalTimes = (TraceEvent -> TickArrivalTimeStats (Set Tick))
-> [TraceEvent] -> TickArrivalTimeStats (Set Tick)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((TraceEvent -> TickArrivalTimeStats (Set Tick))
 -> [TraceEvent] -> TickArrivalTimeStats (Set Tick))
-> (TraceEvent -> TickArrivalTimeStats (Set Tick))
-> [TraceEvent]
-> TickArrivalTimeStats (Set Tick)
forall a b. (a -> b) -> a -> b
$ \case
    (Tick
n, RelativeTime
now, Left (TraceDownloadedHeader Header TestBlock
hdr)) ->
      let onset :: RelativeTime
onset    = SlotNo -> RelativeTime
toOnset (Header TestBlock -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header TestBlock
hdr)
          thisTick :: Set Tick
thisTick = Tick -> Set Tick
forall a. a -> Set a
Set.singleton Tick
n
      in
      if RelativeTime
now RelativeTime -> RelativeTime -> Bool
forall a. Ord a => a -> a -> Bool
< RelativeTime
onset
      then OnlyNotEarly_SomeEarly {
          onlyNotEarlyTATS :: Set Tick
onlyNotEarlyTATS = Set Tick
forall a. Set a
Set.empty
        , someEarlyTATS :: Set Tick
someEarlyTATS    = Set Tick
thisTick
        }
      else OnlyNotEarly_SomeEarly {
          onlyNotEarlyTATS :: Set Tick
onlyNotEarlyTATS = Set Tick
thisTick
        , someEarlyTATS :: Set Tick
someEarlyTATS    = Set Tick
forall a. Set a
Set.empty
        }
    TraceEvent
_ -> TickArrivalTimeStats (Set Tick)
forall a. Monoid a => a
mempty