{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
module Main (main) where
import Bench.Consensus.ChainSyncClient.Driver (mainWith)
import Cardano.Crypto.DSIGN.Mock
import Control.Monad (void)
import Control.Tracer (contramap, debugTracer, nullTracer)
import Data.IORef (newIORef, readIORef, writeIORef)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Main.Utf8 (withStdTerminalHandles)
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 (clockSkewInSeconds)
import qualified Ouroboros.Consensus.HardFork.History as HardFork
import qualified Ouroboros.Consensus.HeaderStateHistory as HeaderStateHistory
import qualified Ouroboros.Consensus.HeaderValidation as HV
import qualified Ouroboros.Consensus.Ledger.Extended as Extended
import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient
import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck as HistoricityCheck
import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck as InFutureCheck
import Ouroboros.Consensus.MiniProtocol.ChainSync.Server
(chainSyncServerForFollower)
import Ouroboros.Consensus.Node.NetworkProtocolVersion
(NodeToNodeVersion)
import Ouroboros.Consensus.Node.ProtocolInfo
import Ouroboros.Consensus.NodeId
import Ouroboros.Consensus.Protocol.BFT
import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Consensus.Util.ResourceRegistry
import Ouroboros.Consensus.Util.STM (Fingerprint (..),
WithFingerprint (..))
import Ouroboros.Consensus.Util.Time (secondsToNominalDiffTime)
import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as AF
import Ouroboros.Network.Block (ChainUpdate (AddBlock, RollBack),
Tip (TipGenesis), tipFromHeader)
import Ouroboros.Network.ControlMessage (ControlMessage (Continue))
import qualified Ouroboros.Network.Mock.Chain as Chain
import Ouroboros.Network.Protocol.ChainSync.ClientPipelined
import Ouroboros.Network.Protocol.ChainSync.Codec (codecChainSyncId)
import Ouroboros.Network.Protocol.ChainSync.PipelineDecision
(pipelineDecisionLowHighMark)
import Ouroboros.Network.Protocol.ChainSync.Server
import Test.Util.Orphans.Arbitrary ()
import Test.Util.Orphans.IOLike ()
import qualified Test.Util.TestBlock as TB
type B = TB.TestBlock
type H = Header B
main :: IO ()
IO ()
main = IO () -> IO ()
forall (m :: * -> *) r. (MonadIO m, MonadMask m) => m r -> m r
withStdTerminalHandles (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int64 -> IO ()) -> IO ()
mainWith ((Int64 -> IO ()) -> IO ()) -> (Int64 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int64
n -> do
StrictTVar
IO (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B))
varCandidate <- AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B)
-> IO
(StrictTVar
IO
(AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B)))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B)
-> IO
(StrictTVar
IO
(AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B))))
-> AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B)
-> IO
(StrictTVar
IO
(AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B)))
forall a b. (a -> b) -> a -> b
$ Anchor (Header B)
-> AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B)
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AF.Empty Anchor (Header B)
forall block. Anchor block
AF.AnchorGenesis
StrictTVar IO (Tip B)
varServerTip <- Tip B -> IO (StrictTVar IO (Tip B))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO Tip B
forall {k} (b :: k). Tip b
TipGenesis
Follower IO B (WithPoint B (Header B))
follower <- StrictTVar IO (Tip B)
-> IO (Follower IO B (WithPoint B (Header B)))
mkFollower StrictTVar IO (Tip B)
varServerTip
StrictTVar
IO (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B))
-> StrictTVar IO (Tip B)
-> Follower IO B (WithPoint B (Header B))
-> Int
-> IO ()
oneBenchRun
StrictTVar
IO (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B))
varCandidate
StrictTVar IO (Tip B)
varServerTip
Follower IO B (WithPoint B (Header B))
follower
(Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
n)
{-# INLINE oneBenchRun #-}
oneBenchRun ::
StrictTVar IO (AnchoredFragment H)
-> StrictTVar IO (Tip B)
-> ChainDB.Follower IO B (ChainDB.WithPoint B H)
-> Int
-> IO ()
oneBenchRun :: StrictTVar
IO (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B))
-> StrictTVar IO (Tip B)
-> Follower IO B (WithPoint B (Header B))
-> Int
-> IO ()
oneBenchRun
StrictTVar
IO (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B))
varCandidate
StrictTVar IO (Tip B)
varServerTip
Follower IO B (WithPoint B (Header B))
follower
Int
n
=
(ResourceRegistry IO -> IO ()) -> IO ()
forall (m :: * -> *) a.
(IOLike m, HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry ((ResourceRegistry IO -> IO ()) -> IO ())
-> (ResourceRegistry IO -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ResourceRegistry IO
registry -> do
(Channel IO (AnyMessage (ChainSync (Header B) (Point B) (Tip B)))
clientChannel, Channel IO (AnyMessage (ChainSync (Header B) (Point B) (Tip B)))
serverChannel) <- IO
(Channel IO (AnyMessage (ChainSync (Header B) (Point B) (Tip B))),
Channel IO (AnyMessage (ChainSync (Header B) (Point B) (Tip B))))
forall (m :: * -> *) a. MonadSTM m => m (Channel m a, Channel m a)
createConnectedChannels
IO (Thread IO ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
(IO (Thread IO ()) -> IO ()) -> IO (Thread IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ ResourceRegistry IO -> [Char] -> IO () -> IO (Thread IO ())
forall (m :: * -> *) a.
(IOLike m, HasCallStack) =>
ResourceRegistry m -> [Char] -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry IO
registry [Char]
"ChainSyncServer"
(IO () -> IO (Thread IO ())) -> IO () -> IO (Thread IO ())
forall a b. (a -> b) -> a -> b
$ Tracer IO (TraceSendRecv (ChainSync (Header B) (Point B) (Tip B)))
-> Codec
(ChainSync (Header B) (Point B) (Tip B))
CodecFailure
IO
(AnyMessage (ChainSync (Header B) (Point B) (Tip B)))
-> Channel IO (AnyMessage (ChainSync (Header B) (Point B) (Tip B)))
-> Peer
(ChainSync (Header B) (Point B) (Tip B)) 'AsServer 'StIdle IO ()
-> IO ()
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 IO (TraceSendRecv (ChainSync (Header B) (Point B) (Tip B)))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Codec
(ChainSync (Header B) (Point B) (Tip B))
CodecFailure
IO
(AnyMessage (ChainSync (Header B) (Point B) (Tip B)))
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 IO (AnyMessage (ChainSync (Header B) (Point B) (Tip B)))
serverChannel
(Peer
(ChainSync (Header B) (Point B) (Tip B)) 'AsServer 'StIdle IO ()
-> IO ())
-> Peer
(ChainSync (Header B) (Point B) (Tip B)) 'AsServer 'StIdle IO ()
-> IO ()
forall a b. (a -> b) -> a -> b
$ ChainSyncServer (Header B) (Point B) (Tip B) IO ()
-> Peer
(ChainSync (Header B) (Point B) (Tip B)) 'AsServer 'StIdle IO ()
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 B) (Point B) (Tip B) IO ()
server
IO (Thread IO ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
(IO (Thread IO ()) -> IO ()) -> IO (Thread IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ ResourceRegistry IO -> [Char] -> IO () -> IO (Thread IO ())
forall (m :: * -> *) a.
(IOLike m, HasCallStack) =>
ResourceRegistry m -> [Char] -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry IO
registry [Char]
"ChainSyncClient"
(IO () -> IO (Thread IO ())) -> IO () -> IO (Thread IO ())
forall a b. (a -> b) -> a -> b
$ IO ChainSyncClientResult -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
(IO ChainSyncClientResult -> IO ())
-> IO ChainSyncClientResult -> IO ()
forall a b. (a -> b) -> a -> b
$ Tracer IO (TraceSendRecv (ChainSync (Header B) (Point B) (Tip B)))
-> Codec
(ChainSync (Header B) (Point B) (Tip B))
CodecFailure
IO
(AnyMessage (ChainSync (Header B) (Point B) (Tip B)))
-> Channel IO (AnyMessage (ChainSync (Header B) (Point B) (Tip B)))
-> PeerPipelined
(ChainSync (Header B) (Point B) (Tip B))
'AsClient
'StIdle
IO
ChainSyncClientResult
-> IO 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 IO (TraceSendRecv (ChainSync (Header B) (Point B) (Tip B)))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Codec
(ChainSync (Header B) (Point B) (Tip B))
CodecFailure
IO
(AnyMessage (ChainSync (Header B) (Point B) (Tip B)))
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 IO (AnyMessage (ChainSync (Header B) (Point B) (Tip B)))
clientChannel
(PeerPipelined
(ChainSync (Header B) (Point B) (Tip B))
'AsClient
'StIdle
IO
ChainSyncClientResult
-> IO ChainSyncClientResult)
-> PeerPipelined
(ChainSync (Header B) (Point B) (Tip B))
'AsClient
'StIdle
IO
ChainSyncClientResult
-> IO ChainSyncClientResult
forall a b. (a -> b) -> a -> b
$ ChainSyncClientPipelined
(Header B) (Point B) (Tip B) IO ChainSyncClientResult
-> PeerPipelined
(ChainSync (Header B) (Point B) (Tip B))
'AsClient
'StIdle
IO
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 ChainSyncClientPipelined
(Header B) (Point B) (Tip B) IO ChainSyncClientResult
client
STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO () -> IO ()) -> STM IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B)
candidate <- StrictTVar
IO (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B))
-> STM
IO (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
IO (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B))
varCandidate
Bool -> STM IO ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check (Bool -> STM IO ()) -> Bool -> STM IO ()
forall a b. (a -> b) -> a -> b
$ case Point (Header B) -> ChainHash (Header B)
forall {k} (block :: k). Point block -> ChainHash block
pointHash (Point (Header B) -> ChainHash (Header B))
-> Point (Header B) -> ChainHash (Header B)
forall a b. (a -> b) -> a -> b
$ AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B)
-> Point (Header B)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B)
candidate of
BlockHash (TB.TestHash NonEmpty Word64
ne) -> Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< NonEmpty Word64 -> Word64
forall a. NonEmpty a -> a
NE.head NonEmpty Word64
ne
ChainHash (Header B)
_ -> Bool
False
where
chainDbView :: CSClient.ChainDbView IO B
chainDbView :: ChainDbView IO B
chainDbView = CSClient.ChainDbView {
$sel:getCurrentChain:ChainDbView :: STM
IO (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B))
CSClient.getCurrentChain = AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B)
-> STM
IO (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B))
forall a. a -> STM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B)
-> STM
IO
(AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B)))
-> AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B)
-> STM
IO (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B))
forall a b. (a -> b) -> a -> b
$ Anchor (Header B)
-> AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B)
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AF.Empty Anchor (Header B)
forall block. Anchor block
AF.AnchorGenesis
, $sel:getHeaderStateHistory:ChainDbView :: STM IO (HeaderStateHistory B)
CSClient.getHeaderStateHistory =
HeaderStateHistory B -> STM IO (HeaderStateHistory B)
forall a. a -> STM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(HeaderStateHistory B -> STM IO (HeaderStateHistory B))
-> HeaderStateHistory B -> STM IO (HeaderStateHistory B)
forall a b. (a -> b) -> a -> b
$ TopLevelConfig B
-> ExtLedgerState B -> Chain B -> HeaderStateHistory B
forall blk.
(ApplyBlock (ExtLedgerState blk) blk, HasHardForkHistory blk,
HasAnnTip blk) =>
TopLevelConfig blk
-> ExtLedgerState blk -> Chain blk -> HeaderStateHistory blk
HeaderStateHistory.fromChain
TopLevelConfig B
topConfig
(Point B -> ExtLedgerState B
oracularLedgerDB Point B
forall {k} (block :: k). Point block
GenesisPoint)
Chain B
forall block. Chain block
Chain.Genesis
, $sel:getIsInvalidBlock:ChainDbView :: STM
IO (WithFingerprint (HeaderHash B -> Maybe (InvalidBlockReason B)))
CSClient.getIsInvalidBlock = WithFingerprint (TestHash -> Maybe (InvalidBlockReason B))
-> STM (WithFingerprint (TestHash -> Maybe (InvalidBlockReason B)))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WithFingerprint (HeaderHash B -> Maybe (InvalidBlockReason B))
WithFingerprint (TestHash -> Maybe (InvalidBlockReason B))
forall blk.
WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))
invalidBlock
, $sel:getPastLedger:ChainDbView :: Point B -> STM IO (Maybe (ExtLedgerState B))
CSClient.getPastLedger = Maybe (ExtLedgerState B) -> STM (Maybe (ExtLedgerState B))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (ExtLedgerState B) -> STM (Maybe (ExtLedgerState B)))
-> (Point B -> Maybe (ExtLedgerState B))
-> Point B
-> STM (Maybe (ExtLedgerState B))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtLedgerState B -> Maybe (ExtLedgerState B)
forall a. a -> Maybe a
Just (ExtLedgerState B -> Maybe (ExtLedgerState B))
-> (Point B -> ExtLedgerState B)
-> Point B
-> Maybe (ExtLedgerState B)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point B -> ExtLedgerState B
oracularLedgerDB
}
headerInFutureCheck ::
InFutureCheck.SomeHeaderInFutureCheck IO B
headerInFutureCheck :: SomeHeaderInFutureCheck IO B
headerInFutureCheck =
ClockSkew -> SystemTime IO -> SomeHeaderInFutureCheck IO B
forall blk (m :: * -> *).
(HasHeader blk, HasHeader (Header blk), HasHardForkHistory blk,
MonadDelay m) =>
ClockSkew -> SystemTime m -> SomeHeaderInFutureCheck m blk
InFutureCheck.realHeaderInFutureCheck
(Double -> ClockSkew
clockSkewInSeconds Double
0)
SystemTime IO
inTheYearOneBillion
client :: CSClient.Consensus ChainSyncClientPipelined B IO
client :: ChainSyncClientPipelined
(Header B) (Point B) (Tip B) IO ChainSyncClientResult
client =
ConfigEnv IO B
-> DynamicEnv IO B
-> ChainSyncClientPipelined
(Header B) (Point B) (Tip B) IO ChainSyncClientResult
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk) =>
ConfigEnv m blk
-> DynamicEnv m blk -> Consensus ChainSyncClientPipelined blk m
CSClient.chainSyncClient
CSClient.ConfigEnv {
ChainDbView IO B
chainDbView :: ChainDbView IO B
$sel:chainDbView:ConfigEnv :: ChainDbView IO B
CSClient.chainDbView
, $sel:cfg:ConfigEnv :: TopLevelConfig B
CSClient.cfg = TopLevelConfig B
topConfig
, $sel:tracer:ConfigEnv :: Tracer IO (TraceChainSyncClientEvent B)
CSClient.tracer = Tracer IO (TraceChainSyncClientEvent B)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Tracer IO (TraceChainSyncClientEvent B)
-> Tracer IO (TraceChainSyncClientEvent B)
-> Tracer IO (TraceChainSyncClientEvent B)
forall a. a -> a -> a
`asTypeOf` (TraceChainSyncClientEvent B -> [Char])
-> Tracer IO [Char] -> Tracer IO (TraceChainSyncClientEvent B)
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap TraceChainSyncClientEvent B -> [Char]
forall a. Show a => a -> [Char]
show Tracer IO [Char]
forall (m :: * -> *). Applicative m => Tracer m [Char]
debugTracer
, $sel:someHeaderInFutureCheck:ConfigEnv :: SomeHeaderInFutureCheck IO B
CSClient.someHeaderInFutureCheck = SomeHeaderInFutureCheck IO B
headerInFutureCheck
, $sel:historicityCheck:ConfigEnv :: HistoricityCheck IO B
CSClient.historicityCheck = HistoricityCheck IO B
forall (m :: * -> *) blk. Applicative m => HistoricityCheck m blk
HistoricityCheck.noCheck
, $sel:mkPipelineDecision0:ConfigEnv :: MkPipelineDecision
CSClient.mkPipelineDecision0 =
Word16 -> Word16 -> MkPipelineDecision
pipelineDecisionLowHighMark Word16
10 Word16
20
}
CSClient.DynamicEnv {
$sel:version:DynamicEnv :: NodeToNodeVersion
CSClient.version = NodeToNodeVersion
forall a. Bounded a => a
maxBound :: NodeToNodeVersion
, $sel:controlMessageSTM:DynamicEnv :: ControlMessageSTM IO
CSClient.controlMessageSTM = ControlMessage -> STM ControlMessage
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ControlMessage
Continue
, $sel:headerMetricsTracer:DynamicEnv :: HeaderMetricsTracer IO
CSClient.headerMetricsTracer = Tracer STM (SlotNo, Time)
HeaderMetricsTracer IO
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
, $sel:setCandidate:DynamicEnv :: AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B)
-> STM IO ()
CSClient.setCandidate = StrictTVar
IO (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B))
-> AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B)
-> STM IO ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar
IO (AnchoredSeq (WithOrigin SlotNo) (Anchor (Header B)) (Header B))
varCandidate
, $sel:setLatestSlot:DynamicEnv :: WithOrigin SlotNo -> STM IO ()
CSClient.setLatestSlot = \WithOrigin SlotNo
_ -> () -> STM ()
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
, $sel:idling:DynamicEnv :: Idling IO
CSClient.idling = Idling IO
forall (m :: * -> *). Applicative m => Idling m
CSClient.noIdling
, $sel:loPBucket:DynamicEnv :: LoPBucket IO
CSClient.loPBucket = LoPBucket IO
forall (m :: * -> *). Applicative m => LoPBucket m
CSClient.noLoPBucket
, $sel:jumping:DynamicEnv :: Jumping IO B
CSClient.jumping = Jumping IO B
forall (m :: * -> *) blk. MonadSTM m => Jumping m blk
CSClient.noJumping
}
server :: ChainSyncServer H (Point B) (Tip B) IO ()
server :: ChainSyncServer (Header B) (Point B) (Tip B) IO ()
server =
Tracer IO (TraceChainSyncServerEvent B)
-> STM IO (Tip B)
-> Follower IO B (WithPoint B (Header B))
-> ChainSyncServer (Header B) (Point B) (Tip B) IO ()
forall (m :: * -> *) blk b.
IOLike m =>
Tracer m (TraceChainSyncServerEvent blk)
-> STM m (Tip blk)
-> Follower m blk (WithPoint blk b)
-> ChainSyncServer b (Point blk) (Tip blk) m ()
chainSyncServerForFollower
Tracer IO (TraceChainSyncServerEvent B)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
(StrictTVar IO (Tip B) -> STM IO (Tip B)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar IO (Tip B)
varServerTip)
Follower IO B (WithPoint B (Header B))
follower
invalidBlock ::
WithFingerprint
(HeaderHash blk -> Maybe (ChainDB.InvalidBlockReason blk))
invalidBlock :: forall blk.
WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))
invalidBlock =
(HeaderHash blk -> Maybe (InvalidBlockReason blk))
-> Fingerprint
-> WithFingerprint
(HeaderHash blk -> Maybe (InvalidBlockReason blk))
forall a. a -> Fingerprint -> WithFingerprint a
WithFingerprint HeaderHash blk -> Maybe (InvalidBlockReason blk)
forall {p} {a}. p -> Maybe a
isInvalidBlock Fingerprint
fp
where
isInvalidBlock :: p -> Maybe a
isInvalidBlock p
_hash = Maybe a
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
0 :: Int)
inTheYearOneBillion :: SystemTime IO
inTheYearOneBillion :: SystemTime IO
inTheYearOneBillion = SystemTime {
systemTimeWait :: IO ()
systemTimeWait = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
, systemTimeCurrent :: IO RelativeTime
systemTimeCurrent = RelativeTime -> IO RelativeTime
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelativeTime -> IO RelativeTime)
-> RelativeTime -> IO RelativeTime
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> RelativeTime
RelativeTime (NominalDiffTime -> RelativeTime)
-> NominalDiffTime -> RelativeTime
forall a b. (a -> b) -> a -> b
$
Double -> NominalDiffTime
secondsToNominalDiffTime (Double -> NominalDiffTime) -> Double -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$
Double
86400
Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
365
Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1e9
}
oracularLedgerDB :: Point B -> Extended.ExtLedgerState B
oracularLedgerDB :: Point B -> ExtLedgerState B
oracularLedgerDB Point B
p =
Extended.ExtLedgerState {
headerState :: HeaderState B
Extended.headerState = HV.HeaderState {
headerStateTip :: WithOrigin (AnnTip B)
HV.headerStateTip = case Point B -> WithOrigin (RealPoint B)
forall blk. Point blk -> WithOrigin (RealPoint blk)
pointToWithOriginRealPoint Point B
p of
WithOrigin (RealPoint B)
Origin -> WithOrigin (AnnTip B)
forall t. WithOrigin t
Origin
NotOrigin RealPoint B
rp -> AnnTip B -> WithOrigin (AnnTip B)
forall t. t -> WithOrigin t
NotOrigin (AnnTip B -> WithOrigin (AnnTip B))
-> AnnTip B -> WithOrigin (AnnTip B)
forall a b. (a -> b) -> a -> b
$ HV.AnnTip {
annTipSlotNo :: SlotNo
HV.annTipSlotNo = RealPoint B -> SlotNo
forall blk. RealPoint blk -> SlotNo
realPointSlot RealPoint B
rp
, annTipInfo :: TipInfo B
HV.annTipInfo = RealPoint B -> HeaderHash B
forall blk. RealPoint blk -> HeaderHash blk
realPointHash RealPoint B
rp
, annTipBlockNo :: BlockNo
HV.annTipBlockNo =
TestHash -> BlockNo
testBlockHashBlockNo (RealPoint B -> HeaderHash B
forall blk. RealPoint blk -> HeaderHash blk
realPointHash RealPoint B
rp)
}
, headerStateChainDep :: ChainDepState (BlockProtocol B)
HV.headerStateChainDep = ()
}
, ledgerState :: LedgerState B
Extended.ledgerState = TB.TestLedger {
lastAppliedPoint :: Point B
TB.lastAppliedPoint = Point B
p
, payloadDependentState :: PayloadDependentState ()
TB.payloadDependentState = ()
}
}
testBlockHashBlockNo :: TB.TestHash -> BlockNo
testBlockHashBlockNo :: TestHash -> BlockNo
testBlockHashBlockNo (TB.TestHash NonEmpty Word64
ne) = Word64 -> BlockNo
BlockNo (Word64 -> BlockNo) -> Word64 -> BlockNo
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
$ NonEmpty Word64 -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty Word64
ne
kInt :: Int
kInt :: Int
kInt = Int
5
securityParam :: SecurityParam
securityParam :: SecurityParam
securityParam = Word64 -> SecurityParam
SecurityParam (Word64 -> SecurityParam) -> Word64 -> SecurityParam
forall a b. (a -> b) -> a -> b
$ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
kInt
initialChain :: NE.NonEmpty B
initialChain :: NonEmpty B
initialChain =
[B] -> NonEmpty B
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList
([B] -> NonEmpty B) -> [B] -> NonEmpty B
forall a b. (a -> b) -> a -> b
$ Int -> [B] -> [B]
forall a. Int -> [a] -> [a]
take Int
kInt
([B] -> [B]) -> [B] -> [B]
forall a b. (a -> b) -> a -> b
$ (B -> B) -> B -> [B]
forall a. (a -> a) -> a -> [a]
iterate B -> B
TB.successorBlock
(B -> [B]) -> B -> [B]
forall a b. (a -> b) -> a -> b
$ Word64 -> B
TB.firstBlock Word64
0
slotLengthInSeconds :: Int
slotLengthInSeconds :: Int
slotLengthInSeconds = Int
1
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
numCoreNodes :: NumCoreNodes
numCoreNodes :: NumCoreNodes
numCoreNodes = Word64 -> NumCoreNodes
NumCoreNodes Word64
2
topConfig :: TopLevelConfig B
topConfig :: TopLevelConfig B
topConfig = TopLevelConfig {
topLevelConfigProtocol :: ConsensusConfig (BlockProtocol B)
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 B
topLevelConfigLedger = EraParams -> TestBlockLedgerConfig
TB.testBlockLedgerConfigFrom EraParams
eraParams
, topLevelConfigBlock :: BlockConfig B
topLevelConfigBlock = NumCoreNodes -> BlockConfig B
forall ptype. NumCoreNodes -> BlockConfig (TestBlockWith ptype)
TB.TestBlockConfig NumCoreNodes
numCoreNodes
, topLevelConfigCodec :: CodecConfig B
topLevelConfigCodec = CodecConfig B
TB.TestBlockCodecConfig
, topLevelConfigStorage :: StorageConfig B
topLevelConfigStorage = StorageConfig B
TB.TestBlockStorageConfig
, topLevelConfigCheckpoints :: CheckpointsMap B
topLevelConfigCheckpoints = CheckpointsMap B
forall blk. CheckpointsMap blk
emptyCheckpointsMap
}
where
eraParams :: HardFork.EraParams
eraParams :: EraParams
eraParams = SecurityParam -> SlotLength -> EraParams
HardFork.defaultEraParams SecurityParam
securityParam SlotLength
slotLength
data FollowerState =
Resting !(RealPoint B)
| Switching !(Point B) !(NE.NonEmpty B)
| Switched !(NE.NonEmpty B)
mkFollower ::
StrictTVar IO (Tip B)
-> IO (ChainDB.Follower IO B (ChainDB.WithPoint B H))
mkFollower :: StrictTVar IO (Tip B)
-> IO (Follower IO B (WithPoint B (Header B)))
mkFollower StrictTVar IO (Tip B)
varTip = do
IORef FollowerState
varState <- FollowerState -> IO (IORef FollowerState)
forall a. a -> IO (IORef a)
newIORef (FollowerState -> IO (IORef FollowerState))
-> FollowerState -> IO (IORef FollowerState)
forall a b. (a -> b) -> a -> b
$ RealPoint B -> FollowerState
Resting (RealPoint B -> FollowerState) -> RealPoint B -> FollowerState
forall a b. (a -> b) -> a -> b
$ B -> RealPoint B
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint (B -> RealPoint B) -> B -> RealPoint B
forall a b. (a -> b) -> a -> b
$ NonEmpty B -> B
forall a. NonEmpty a -> a
NE.last NonEmpty B
initialChain
let wrap :: blk -> WithPoint blk (Header blk)
wrap blk
blk = Header blk -> Point blk -> WithPoint blk (Header blk)
forall blk b. b -> Point blk -> WithPoint blk b
ChainDB.WithPoint (blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader blk
blk) (blk -> Point blk
forall block. HasHeader block => block -> Point block
blockPoint blk
blk)
let next :: IO (ChainUpdate B (WithPoint B (Header B)))
next = IORef FollowerState -> IO FollowerState
forall a. IORef a -> IO a
readIORef IORef FollowerState
varState IO FollowerState
-> (FollowerState -> IO (ChainUpdate B (WithPoint B (Header B))))
-> IO (ChainUpdate B (WithPoint B (Header B)))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Switching Point B
ipoint NonEmpty B
blks -> do
IORef FollowerState -> FollowerState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef FollowerState
varState (FollowerState -> IO ()) -> FollowerState -> IO ()
forall a b. (a -> b) -> a -> b
$ NonEmpty B -> FollowerState
Switched NonEmpty B
blks
STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO () -> IO ()) -> STM IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ StrictTVar IO (Tip B) -> Tip B -> STM IO ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar IO (Tip B)
varTip (Tip B -> STM IO ()) -> Tip B -> STM IO ()
forall a b. (a -> b) -> a -> b
$ B -> Tip B
forall a. HasHeader a => a -> Tip a
tipFromHeader (B -> Tip B) -> B -> Tip B
forall a b. (a -> b) -> a -> b
$ NonEmpty B -> B
forall a. NonEmpty a -> a
NE.last NonEmpty B
blks
ChainUpdate B (WithPoint B (Header B))
-> IO (ChainUpdate B (WithPoint B (Header B)))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainUpdate B (WithPoint B (Header B))
-> IO (ChainUpdate B (WithPoint B (Header B))))
-> ChainUpdate B (WithPoint B (Header B))
-> IO (ChainUpdate B (WithPoint B (Header B)))
forall a b. (a -> b) -> a -> b
$ Point B -> ChainUpdate B (WithPoint B (Header B))
forall {k} (block :: k) a. Point block -> ChainUpdate block a
RollBack Point B
ipoint
Switched NonEmpty B
blks -> do
let blk :: B
blk = NonEmpty B -> B
forall a. NonEmpty a -> a
NE.head NonEmpty B
blks
IORef FollowerState -> FollowerState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef FollowerState
varState (FollowerState -> IO ()) -> FollowerState -> IO ()
forall a b. (a -> b) -> a -> b
$ case [B] -> Maybe (NonEmpty B)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty (NonEmpty B -> [B]
forall a. NonEmpty a -> [a]
NE.tail NonEmpty B
blks) of
Maybe (NonEmpty B)
Nothing -> RealPoint B -> FollowerState
Resting (RealPoint B -> FollowerState) -> RealPoint B -> FollowerState
forall a b. (a -> b) -> a -> b
$ B -> RealPoint B
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint B
blk
Just NonEmpty B
blks' -> NonEmpty B -> FollowerState
Switched NonEmpty B
blks'
STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO () -> IO ()) -> STM IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ StrictTVar IO (Tip B) -> Tip B -> STM IO ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar IO (Tip B)
varTip (Tip B -> STM IO ()) -> Tip B -> STM IO ()
forall a b. (a -> b) -> a -> b
$ B -> Tip B
forall a. HasHeader a => a -> Tip a
tipFromHeader (B -> Tip B) -> B -> Tip B
forall a b. (a -> b) -> a -> b
$ NonEmpty B -> B
forall a. NonEmpty a -> a
NE.last NonEmpty B
blks
ChainUpdate B (WithPoint B (Header B))
-> IO (ChainUpdate B (WithPoint B (Header B)))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainUpdate B (WithPoint B (Header B))
-> IO (ChainUpdate B (WithPoint B (Header B))))
-> ChainUpdate B (WithPoint B (Header B))
-> IO (ChainUpdate B (WithPoint B (Header B)))
forall a b. (a -> b) -> a -> b
$ WithPoint B (Header B) -> ChainUpdate B (WithPoint B (Header B))
forall {k} (block :: k) a. a -> ChainUpdate block a
AddBlock (WithPoint B (Header B) -> ChainUpdate B (WithPoint B (Header B)))
-> WithPoint B (Header B) -> ChainUpdate B (WithPoint B (Header B))
forall a b. (a -> b) -> a -> b
$ B -> WithPoint B (Header B)
forall {blk}.
(GetHeader blk, HasHeader blk) =>
blk -> WithPoint blk (Header blk)
wrap B
blk
Resting RealPoint B
rp -> do
let (Point B
ipoint, NonEmpty B
blks) = RealPoint B -> (Point B, NonEmpty B)
TB.updateToNextNumeral RealPoint B
rp
IORef FollowerState -> FollowerState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef FollowerState
varState (FollowerState -> IO ()) -> FollowerState -> IO ()
forall a b. (a -> b) -> a -> b
$ NonEmpty B -> FollowerState
Switched NonEmpty B
blks
STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO () -> IO ()) -> STM IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ StrictTVar IO (Tip B) -> Tip B -> STM IO ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar IO (Tip B)
varTip (Tip B -> STM IO ()) -> Tip B -> STM IO ()
forall a b. (a -> b) -> a -> b
$ B -> Tip B
forall a. HasHeader a => a -> Tip a
tipFromHeader (B -> Tip B) -> B -> Tip B
forall a b. (a -> b) -> a -> b
$ NonEmpty B -> B
forall a. NonEmpty a -> a
NE.last NonEmpty B
blks
ChainUpdate B (WithPoint B (Header B))
-> IO (ChainUpdate B (WithPoint B (Header B)))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainUpdate B (WithPoint B (Header B))
-> IO (ChainUpdate B (WithPoint B (Header B))))
-> ChainUpdate B (WithPoint B (Header B))
-> IO (ChainUpdate B (WithPoint B (Header B)))
forall a b. (a -> b) -> a -> b
$ Point B -> ChainUpdate B (WithPoint B (Header B))
forall {k} (block :: k) a. Point block -> ChainUpdate block a
RollBack Point B
ipoint
Follower IO B (WithPoint B (Header B))
-> IO (Follower IO B (WithPoint B (Header B)))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChainDB.Follower {
followerClose :: IO ()
ChainDB.followerClose = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
, followerInstruction :: IO (Maybe (ChainUpdate B (WithPoint B (Header B))))
ChainDB.followerInstruction = ChainUpdate B (WithPoint B (Header B))
-> Maybe (ChainUpdate B (WithPoint B (Header B)))
forall a. a -> Maybe a
Just (ChainUpdate B (WithPoint B (Header B))
-> Maybe (ChainUpdate B (WithPoint B (Header B))))
-> IO (ChainUpdate B (WithPoint B (Header B)))
-> IO (Maybe (ChainUpdate B (WithPoint B (Header B))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (ChainUpdate B (WithPoint B (Header B)))
next
, followerInstructionBlocking :: IO (ChainUpdate B (WithPoint B (Header B)))
ChainDB.followerInstructionBlocking = IO (ChainUpdate B (WithPoint B (Header B)))
next
, followerForward :: [Point B] -> IO (Maybe (Point B))
ChainDB.followerForward = \case
Point B
GenesisPoint : [Point B]
_ -> do
IORef FollowerState -> FollowerState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef FollowerState
varState (FollowerState -> IO ()) -> FollowerState -> IO ()
forall a b. (a -> b) -> a -> b
$ Point B -> NonEmpty B -> FollowerState
Switching Point B
forall {k} (block :: k). Point block
GenesisPoint NonEmpty B
initialChain
Maybe (Point B) -> IO (Maybe (Point B))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Point B) -> IO (Maybe (Point B)))
-> Maybe (Point B) -> IO (Maybe (Point B))
forall a b. (a -> b) -> a -> b
$ Point B -> Maybe (Point B)
forall a. a -> Maybe a
Just Point B
forall {k} (block :: k). Point block
GenesisPoint
[Point B]
ps -> [Char] -> IO (Maybe (Point B))
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO (Maybe (Point B))) -> [Char] -> IO (Maybe (Point B))
forall a b. (a -> b) -> a -> b
$ [Char]
"impossible! " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [[Char]] -> [Char]
unlines ((Point B -> [Char]) -> [Point B] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Point B -> [Char]
forall a. Show a => a -> [Char]
show [Point B]
ps)
}