{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
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.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 Ouroboros.Consensus.Fragment.InFuture (ClockSkew,
clockSkewInSeconds, unClockSkew)
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 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.Storage.ChainDB.API
(InvalidBlockReason (ValidationError))
import Ouroboros.Consensus.Util (lastMaybe, whenJust)
import Ouroboros.Consensus.Util.Condense
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Consensus.Util.ResourceRegistry
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)
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
]
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
$
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
-> AnchoredFragment TestBlock
-> 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
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
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
serverId :: CoreNodeId
serverId :: CoreNodeId
serverId = Word64 -> CoreNodeId
CoreNodeId Word64
1
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)
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]
}
runChainSync ::
forall m. (IOLike m, MonadTime m, MonadTimer m)
=> ClockSkew
-> SecurityParam
-> ClientUpdates
-> ServerUpdates
-> InvalidBlocks
-> Tick
-> 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.
(IOLike 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
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)
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
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 (InvalidBlockReason 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 (InvalidBlockReason 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 InvalidBlockReason TestBlock
-> Maybe (InvalidBlockReason TestBlock)
forall a. a -> Maybe a
Just
(InvalidBlockReason TestBlock
-> Maybe (InvalidBlockReason TestBlock))
-> (TestBlockError () -> InvalidBlockReason TestBlock)
-> TestBlockError ()
-> Maybe (InvalidBlockReason TestBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtValidationError TestBlock -> InvalidBlockReason TestBlock
forall blk. ExtValidationError blk -> InvalidBlockReason blk
ValidationError
(ExtValidationError TestBlock -> InvalidBlockReason TestBlock)
-> (TestBlockError () -> ExtValidationError TestBlock)
-> TestBlockError ()
-> InvalidBlockReason 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 (InvalidBlockReason TestBlock))
-> TestBlockError () -> Maybe (InvalidBlockReason TestBlock)
forall a b. (a -> b) -> a -> b
$ TestBlockError ()
forall ptype. TestBlockError ptype
TestBlock.InvalidBlock
else Maybe (InvalidBlockReason TestBlock)
forall a. Maybe a
Nothing
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 (InvalidBlockReason TestBlock))
-> STM
m
(WithFingerprint
(TestHash -> Maybe (InvalidBlockReason TestBlock)))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WithFingerprint (TestHash -> Maybe (InvalidBlockReason TestBlock))
-> STM
m
(WithFingerprint
(TestHash -> Maybe (InvalidBlockReason TestBlock))))
-> WithFingerprint
(TestHash -> Maybe (InvalidBlockReason TestBlock))
-> STM
m
(WithFingerprint
(TestHash -> Maybe (InvalidBlockReason TestBlock)))
forall a b. (a -> b) -> a -> b
$ (TestHash -> Maybe (InvalidBlockReason TestBlock))
-> Fingerprint
-> WithFingerprint
(TestHash -> Maybe (InvalidBlockReason TestBlock))
forall a. a -> Fingerprint -> WithFingerprint a
WithFingerprint TestHash -> Maybe (InvalidBlockReason 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
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
(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
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
}
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
}
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"
let updateChainsDuringTick :: Tick -> m ()
updateChainsDuringTick :: Tick -> m ()
updateChainsDuringTick Tick
tick = do
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
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
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
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)
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. MonadSTM m => m (Channel m a, Channel m a)
createConnectedChannels
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.
(IOLike 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
-> (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
-> (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
(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
((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 <-
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
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
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)
-> PeerPipelined
(ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
'AsClient
'StIdle
m
ChainSyncClientResult
-> m ChainSyncClientResult
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
-> PeerPipelined (ChainSync header point tip) 'AsClient '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))
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 ()) -> 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.
(IOLike m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry m
registry String
"ChainSyncServer" (m () -> m (Thread m ())) -> m () -> m (Thread m ())
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
'StIdle
m
()
-> m ()
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 st m a
-> m a
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
'StIdle
m
()
forall header point tip (m :: * -> *) a.
Monad m =>
ChainSyncServer header point tip m a
-> Peer (ChainSync header point tip) 'AsServer 'StIdle m a
chainSyncServerPeer ChainSyncServer
(Header TestBlock) (Point TestBlock) (Tip TestBlock) m ()
server)
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
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
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
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)
DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
86400
[TraceEvent]
traceEvents <- m [TraceEvent]
getTrace
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
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)
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
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"
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
,
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
]
data FutureTip = FutureTip {
FutureTip -> RelativeTime
ftNow :: RelativeTime
, FutureTip -> (RelativeTime, Point TestBlock)
ftPoint :: (RelativeTime, Point TestBlock)
}
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
| ClientSelectedFutureTip !FutureTip
| ClientThrew !ChainSyncClientException
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"
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)
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"
computeHeaderStateHistory ::
TopLevelConfig TestBlock
-> Chain TestBlock
-> HeaderStateHistory TestBlock
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
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
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)
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
data ChainSyncClientSetup = ChainSyncClientSetup
{ ChainSyncClientSetup -> SecurityParam
securityParam :: SecurityParam
, ChainSyncClientSetup -> ClientUpdates
clientUpdates :: ClientUpdates
, ChainSyncClientSetup -> ServerUpdates
serverUpdates :: ServerUpdates
, ChainSyncClientSetup -> Tick
startTick :: Tick
, ChainSyncClientSetup -> InvalidBlocks
invalidBlocks :: InvalidBlocks
, ChainSyncClientSetup -> SlotLengthTenths
clientSlowBy :: SlotLengthTenths
}
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
} =
[ 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. [(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
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
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
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
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
| NewMaxServerSlot SlotNo
| NewMaxClientAndServerSlot SlotNo SlotNo
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
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
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
data TickArrivalTimeStats a = OnlyNotEarly_SomeEarly {
forall a. TickArrivalTimeStats a -> a
onlyNotEarlyTATS :: !a
, forall a. TickArrivalTimeStats a -> a
someEarlyTATS :: !a
}
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
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
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
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