{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Test.Consensus.PeerSimulator.ChainSync (
chainSyncNoSizeLimits
, chainSyncNoTimeouts
, runChainSyncClient
, runChainSyncServer
) where
import Control.Exception (SomeException)
import Control.Monad.Class.MonadTimer.SI (MonadTimer)
import Control.Tracer (Tracer (Tracer), nullTracer, traceWith)
import Data.Map.Strict (Map)
import Data.Proxy (Proxy (..))
import Network.TypedProtocol.Codec (AnyMessage)
import Ouroboros.Consensus.Block (Header, Point)
import Ouroboros.Consensus.BlockchainTime (RelativeTime (..))
import Ouroboros.Consensus.Config (TopLevelConfig (..))
import Ouroboros.Consensus.Ledger.SupportsProtocol
(LedgerSupportsProtocol)
import Ouroboros.Consensus.MiniProtocol.ChainSync.Client
(CSJConfig (..), ChainDbView, ChainSyncClientHandle,
ChainSyncLoPBucketConfig, ChainSyncStateView (..),
Consensus, bracketChainSyncClient, chainSyncClient)
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.Node.GsmState (GsmState (Syncing))
import Ouroboros.Consensus.Util (ShowProxy)
import Ouroboros.Consensus.Util.IOLike (Exception (fromException),
IOLike, MonadCatch (try), StrictTVar)
import Ouroboros.Network.Block (Tip)
import Ouroboros.Network.Channel (Channel)
import Ouroboros.Network.ControlMessage (ControlMessage (..))
import Ouroboros.Network.Driver (runPeer)
import Ouroboros.Network.Driver.Limits
(ProtocolLimitFailure (ExceededSizeLimit, ExceededTimeLimit),
runPipelinedPeerWithLimits)
import Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion)
import Ouroboros.Network.Protocol.ChainSync.ClientPipelined
(ChainSyncClientPipelined, chainSyncClientPeerPipelined)
import Ouroboros.Network.Protocol.ChainSync.Codec
(ChainSyncTimeout (..), byteLimitsChainSync,
codecChainSyncId, timeLimitsChainSync)
import Ouroboros.Network.Protocol.ChainSync.PipelineDecision
(pipelineDecisionLowHighMark)
import Ouroboros.Network.Protocol.ChainSync.Server (ChainSyncServer,
chainSyncServerPeer)
import Ouroboros.Network.Protocol.ChainSync.Type (ChainSync)
import Ouroboros.Network.Protocol.Limits (ProtocolSizeLimits (..))
import Test.Consensus.PeerSimulator.StateView
(PeerSimulatorComponentResult (..),
PeerSimulatorResult (..),
StateViewTracers (StateViewTracers, svtPeerSimulatorResultsTracer))
import Test.Consensus.PeerSimulator.Trace
(TraceChainSyncClientTerminationEvent (..),
TraceEvent (..))
import Test.Consensus.PointSchedule.Peers (PeerId)
import Test.Util.Orphans.IOLike ()
basicChainSyncClient ::
forall m blk.
(IOLike m, LedgerSupportsProtocol blk) =>
PeerId ->
Tracer m (TraceEvent blk) ->
TopLevelConfig blk ->
ChainDbView m blk ->
ChainSyncStateView m blk ->
Consensus ChainSyncClientPipelined blk m
basicChainSyncClient :: forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk) =>
PeerId
-> Tracer m (TraceEvent blk)
-> TopLevelConfig blk
-> ChainDbView m blk
-> ChainSyncStateView m blk
-> Consensus ChainSyncClientPipelined blk m
basicChainSyncClient
PeerId
peerId
Tracer m (TraceEvent blk)
tracer
TopLevelConfig blk
cfg
ChainDbView m blk
chainDbView
ChainSyncStateView m blk
csState =
ConfigEnv m blk
-> DynamicEnv m blk -> Consensus ChainSyncClientPipelined blk m
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk) =>
ConfigEnv m blk
-> DynamicEnv m blk -> Consensus ChainSyncClientPipelined blk m
chainSyncClient
CSClient.ConfigEnv {
$sel:mkPipelineDecision0:ConfigEnv :: MkPipelineDecision
CSClient.mkPipelineDecision0 = Word16 -> Word16 -> MkPipelineDecision
pipelineDecisionLowHighMark Word16
10 Word16
20
, $sel:tracer:ConfigEnv :: Tracer m (TraceChainSyncClientEvent blk)
CSClient.tracer = (TraceChainSyncClientEvent blk -> m ())
-> Tracer m (TraceChainSyncClientEvent blk)
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer (Tracer m (TraceEvent blk) -> TraceEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent blk)
tracer (TraceEvent blk -> m ())
-> (TraceChainSyncClientEvent blk -> TraceEvent blk)
-> TraceChainSyncClientEvent blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerId -> TraceChainSyncClientEvent blk -> TraceEvent blk
forall blk.
PeerId -> TraceChainSyncClientEvent blk -> TraceEvent blk
TraceChainSyncClientEvent PeerId
peerId)
, TopLevelConfig blk
cfg :: TopLevelConfig blk
$sel:cfg:ConfigEnv :: TopLevelConfig blk
CSClient.cfg
, ChainDbView m blk
chainDbView :: ChainDbView m blk
$sel:chainDbView:ConfigEnv :: ChainDbView m blk
CSClient.chainDbView
, $sel:someHeaderInFutureCheck:ConfigEnv :: SomeHeaderInFutureCheck m blk
CSClient.someHeaderInFutureCheck = SomeHeaderInFutureCheck m blk
dummyHeaderInFutureCheck
, $sel:historicityCheck:ConfigEnv :: HistoricityCheck m blk
CSClient.historicityCheck = HistoricityCheck m blk
forall (m :: * -> *) blk. Applicative m => HistoricityCheck m blk
HistoricityCheck.noCheck
}
CSClient.DynamicEnv {
$sel:version:DynamicEnv :: NodeToNodeVersion
CSClient.version = NodeToNodeVersion
forall a. Bounded a => a
maxBound
, $sel:controlMessageSTM:DynamicEnv :: ControlMessageSTM m
CSClient.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
CSClient.headerMetricsTracer = HeaderMetricsTracer m
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
, $sel:setCandidate:DynamicEnv :: AnchoredFragment (Header blk) -> STM m ()
CSClient.setCandidate = ChainSyncStateView m blk
-> AnchoredFragment (Header blk) -> STM m ()
forall (m :: * -> *) blk.
ChainSyncStateView m blk
-> AnchoredFragment (Header blk) -> STM m ()
csvSetCandidate ChainSyncStateView m blk
csState
, $sel:idling:DynamicEnv :: Idling m
CSClient.idling = ChainSyncStateView m blk -> Idling m
forall (m :: * -> *) blk. ChainSyncStateView m blk -> Idling m
csvIdling ChainSyncStateView m blk
csState
, $sel:loPBucket:DynamicEnv :: LoPBucket m
CSClient.loPBucket = ChainSyncStateView m blk -> LoPBucket m
forall (m :: * -> *) blk. ChainSyncStateView m blk -> LoPBucket m
csvLoPBucket ChainSyncStateView m blk
csState
, $sel:setLatestSlot:DynamicEnv :: WithOrigin SlotNo -> STM m ()
CSClient.setLatestSlot = ChainSyncStateView m blk -> WithOrigin SlotNo -> STM m ()
forall (m :: * -> *) blk.
ChainSyncStateView m blk -> WithOrigin SlotNo -> STM m ()
csvSetLatestSlot ChainSyncStateView m blk
csState
, $sel:jumping:DynamicEnv :: Jumping m blk
CSClient.jumping = ChainSyncStateView m blk -> Jumping m blk
forall (m :: * -> *) blk. ChainSyncStateView m blk -> Jumping m blk
csvJumping ChainSyncStateView m blk
csState
}
where
dummyHeaderInFutureCheck ::
InFutureCheck.SomeHeaderInFutureCheck m blk
dummyHeaderInFutureCheck :: SomeHeaderInFutureCheck m blk
dummyHeaderInFutureCheck =
HeaderInFutureCheck m blk () () -> SomeHeaderInFutureCheck m blk
forall (m :: * -> *) blk arrival judgment.
HeaderInFutureCheck m blk arrival judgment
-> SomeHeaderInFutureCheck m blk
InFutureCheck.SomeHeaderInFutureCheck InFutureCheck.HeaderInFutureCheck
{ proxyArrival :: Proxy ()
InFutureCheck.proxyArrival = Proxy ()
forall {k} (t :: k). Proxy t
Proxy
, recordHeaderArrival :: Header blk -> m ()
InFutureCheck.recordHeaderArrival = \Header blk
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
, judgeHeaderArrival :: LedgerConfig blk
-> LedgerState blk -> () -> Except PastHorizonException ()
InFutureCheck.judgeHeaderArrival = \LedgerConfig blk
_ LedgerState blk
_ ()
_ -> () -> Except PastHorizonException ()
forall a. a -> ExceptT PastHorizonException Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
, handleHeaderArrival :: () -> m (Except HeaderArrivalException RelativeTime)
InFutureCheck.handleHeaderArrival = \()
_ ->
Except HeaderArrivalException RelativeTime
-> m (Except HeaderArrivalException RelativeTime)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Except HeaderArrivalException RelativeTime
-> m (Except HeaderArrivalException RelativeTime))
-> Except HeaderArrivalException RelativeTime
-> m (Except HeaderArrivalException RelativeTime)
forall a b. (a -> b) -> a -> b
$ RelativeTime -> Except HeaderArrivalException RelativeTime
forall a. a -> ExceptT HeaderArrivalException Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelativeTime -> Except HeaderArrivalException RelativeTime)
-> RelativeTime -> Except HeaderArrivalException RelativeTime
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> RelativeTime
RelativeTime NominalDiffTime
0
}
runChainSyncClient ::
(IOLike m, MonadTimer m, LedgerSupportsProtocol blk, ShowProxy blk, ShowProxy (Header blk)) =>
Tracer m (TraceEvent blk) ->
TopLevelConfig blk ->
ChainDbView m blk ->
PeerId ->
ChainSyncTimeout ->
ChainSyncLoPBucketConfig ->
CSJConfig ->
StateViewTracers blk m ->
StrictTVar m (Map PeerId (ChainSyncClientHandle m blk)) ->
Channel m (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))) ->
m ()
runChainSyncClient :: forall (m :: * -> *) blk.
(IOLike m, MonadTimer m, LedgerSupportsProtocol blk, ShowProxy blk,
ShowProxy (Header blk)) =>
Tracer m (TraceEvent blk)
-> TopLevelConfig blk
-> ChainDbView m blk
-> PeerId
-> ChainSyncTimeout
-> ChainSyncLoPBucketConfig
-> CSJConfig
-> StateViewTracers blk m
-> StrictTVar m (Map PeerId (ChainSyncClientHandle m blk))
-> Channel
m (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
-> m ()
runChainSyncClient
Tracer m (TraceEvent blk)
tracer
TopLevelConfig blk
cfg
ChainDbView m blk
chainDbView
PeerId
peerId
ChainSyncTimeout
chainSyncTimeouts
ChainSyncLoPBucketConfig
lopBucketConfig
CSJConfig
csjConfig
StateViewTracers {Tracer m (PeerSimulatorResult blk)
svtPeerSimulatorResultsTracer :: forall blk (m :: * -> *).
StateViewTracers blk m -> Tracer m (PeerSimulatorResult blk)
svtPeerSimulatorResultsTracer :: Tracer m (PeerSimulatorResult blk)
svtPeerSimulatorResultsTracer}
StrictTVar m (Map PeerId (ChainSyncClientHandle m blk))
varHandles
Channel
m (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
channel =
Tracer m (TraceChainSyncClientEvent blk)
-> ChainDbView m blk
-> StrictTVar m (Map PeerId (ChainSyncClientHandle m blk))
-> STM m GsmState
-> PeerId
-> NodeToNodeVersion
-> ChainSyncLoPBucketConfig
-> CSJConfig
-> (ChainSyncStateView m blk -> 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 blk)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
ChainDbView m blk
chainDbView
StrictTVar m (Map PeerId (ChainSyncClientHandle m blk))
varHandles
(GsmState -> STM m GsmState
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GsmState
Syncing)
PeerId
peerId
(NodeToNodeVersion
forall a. Bounded a => a
maxBound :: NodeToNodeVersion)
ChainSyncLoPBucketConfig
lopBucketConfig
CSJConfig
csjConfig
((ChainSyncStateView m blk -> m ()) -> m ())
-> (ChainSyncStateView m blk -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \ChainSyncStateView m blk
csState -> do
Either
SomeException
(ChainSyncClientResult,
Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
res <-
m (ChainSyncClientResult,
Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
-> m (Either
SomeException
(ChainSyncClientResult,
Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))))
forall e a. Exception e => m a -> m (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (m (ChainSyncClientResult,
Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
-> m (Either
SomeException
(ChainSyncClientResult,
Maybe
(AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))))
-> m (ChainSyncClientResult,
Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
-> m (Either
SomeException
(ChainSyncClientResult,
Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))))
forall a b. (a -> b) -> a -> b
$
Tracer
m (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk)))
-> Codec
(ChainSync (Header blk) (Point blk) (Tip blk))
CodecFailure
m
(AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
-> ProtocolSizeLimits
(ChainSync (Header blk) (Point blk) (Tip blk))
(AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
-> ProtocolTimeLimits
(ChainSync (Header blk) (Point blk) (Tip blk))
-> Channel
m (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
-> PeerPipelined
(ChainSync (Header blk) (Point blk) (Tip blk))
'AsClient
'StIdle
m
ChainSyncClientResult
-> m (ChainSyncClientResult,
Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
a.
(MonadAsync m, MonadFork m, MonadMask m, MonadThrow (STM m),
MonadTimer m, forall (st' :: ps). Show (ClientHasAgency st'),
forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps,
Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> PeerPipelined ps pr st m a
-> m (a, Maybe bytes)
runPipelinedPeerWithLimits
Tracer
m (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk)))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
Codec
(ChainSync (Header blk) (Point blk) (Tip blk))
CodecFailure
m
(AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
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
ProtocolSizeLimits
(ChainSync (Header blk) (Point blk) (Tip blk))
(AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
forall header point tip bytes.
ProtocolSizeLimits (ChainSync header point tip) bytes
chainSyncNoSizeLimits
(ChainSyncTimeout
-> ProtocolTimeLimits
(ChainSync (Header blk) (Point blk) (Tip blk))
forall {k} {k1} {k2} (header :: k) (point :: k1) (tip :: k2).
ChainSyncTimeout -> ProtocolTimeLimits (ChainSync header point tip)
timeLimitsChainSync ChainSyncTimeout
chainSyncTimeouts)
Channel
m (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
channel
(ChainSyncClientPipelined
(Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
-> PeerPipelined
(ChainSync (Header blk) (Point blk) (Tip blk))
'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
(PeerId
-> Tracer m (TraceEvent blk)
-> TopLevelConfig blk
-> ChainDbView m blk
-> ChainSyncStateView m blk
-> ChainSyncClientPipelined
(Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk) =>
PeerId
-> Tracer m (TraceEvent blk)
-> TopLevelConfig blk
-> ChainDbView m blk
-> ChainSyncStateView m blk
-> Consensus ChainSyncClientPipelined blk m
basicChainSyncClient
PeerId
peerId
Tracer m (TraceEvent blk)
tracer
TopLevelConfig blk
cfg
ChainDbView m blk
chainDbView
ChainSyncStateView m blk
csState))
case Either
SomeException
(ChainSyncClientResult,
Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
res of
Right (ChainSyncClientResult,
Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
res' -> Tracer m (PeerSimulatorResult blk)
-> PeerSimulatorResult blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSimulatorResult blk)
svtPeerSimulatorResultsTracer (PeerSimulatorResult blk -> m ())
-> PeerSimulatorResult blk -> m ()
forall a b. (a -> b) -> a -> b
$
PeerId
-> PeerSimulatorComponentResult blk -> PeerSimulatorResult blk
forall blk.
PeerId
-> PeerSimulatorComponentResult blk -> PeerSimulatorResult blk
PeerSimulatorResult PeerId
peerId (PeerSimulatorComponentResult blk -> PeerSimulatorResult blk)
-> PeerSimulatorComponentResult blk -> PeerSimulatorResult blk
forall a b. (a -> b) -> a -> b
$ Either
SomeException
(ChainSyncClientResult,
Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
-> PeerSimulatorComponentResult blk
forall blk.
Either
SomeException (ChainSyncClientResult, Maybe (ChainSyncResult blk))
-> PeerSimulatorComponentResult blk
SomeChainSyncClientResult (Either
SomeException
(ChainSyncClientResult,
Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
-> PeerSimulatorComponentResult blk)
-> Either
SomeException
(ChainSyncClientResult,
Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
-> PeerSimulatorComponentResult blk
forall a b. (a -> b) -> a -> b
$ (ChainSyncClientResult,
Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
-> Either
SomeException
(ChainSyncClientResult,
Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
forall a b. b -> Either a b
Right (ChainSyncClientResult,
Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
res'
Left SomeException
exn -> SomeException -> m ()
traceException SomeException
exn
where
traceException :: SomeException -> m ()
traceException SomeException
exn = do
Tracer m (PeerSimulatorResult blk)
-> PeerSimulatorResult blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSimulatorResult blk)
svtPeerSimulatorResultsTracer (PeerSimulatorResult blk -> m ())
-> PeerSimulatorResult blk -> m ()
forall a b. (a -> b) -> a -> b
$
PeerId
-> PeerSimulatorComponentResult blk -> PeerSimulatorResult blk
forall blk.
PeerId
-> PeerSimulatorComponentResult blk -> PeerSimulatorResult blk
PeerSimulatorResult PeerId
peerId (PeerSimulatorComponentResult blk -> PeerSimulatorResult blk)
-> PeerSimulatorComponentResult blk -> PeerSimulatorResult blk
forall a b. (a -> b) -> a -> b
$ Either
SomeException
(ChainSyncClientResult,
Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
-> PeerSimulatorComponentResult blk
forall blk.
Either
SomeException (ChainSyncClientResult, Maybe (ChainSyncResult blk))
-> PeerSimulatorComponentResult blk
SomeChainSyncClientResult (Either
SomeException
(ChainSyncClientResult,
Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
-> PeerSimulatorComponentResult blk)
-> Either
SomeException
(ChainSyncClientResult,
Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
-> PeerSimulatorComponentResult blk
forall a b. (a -> b) -> a -> b
$ SomeException
-> Either
SomeException
(ChainSyncClientResult,
Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
forall a b. a -> Either a b
Left SomeException
exn
case SomeException -> Maybe ProtocolLimitFailure
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exn of
Just (ExceededSizeLimit PeerHasAgency pr st
_) ->
Tracer m (TraceEvent blk) -> TraceEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent blk)
tracer (TraceEvent blk -> m ()) -> TraceEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ PeerId -> TraceChainSyncClientTerminationEvent -> TraceEvent blk
forall blk.
PeerId -> TraceChainSyncClientTerminationEvent -> TraceEvent blk
TraceChainSyncClientTerminationEvent PeerId
peerId TraceChainSyncClientTerminationEvent
TraceExceededSizeLimitCS
Just (ExceededTimeLimit PeerHasAgency pr st
_) ->
Tracer m (TraceEvent blk) -> TraceEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent blk)
tracer (TraceEvent blk -> m ()) -> TraceEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ PeerId -> TraceChainSyncClientTerminationEvent -> TraceEvent blk
forall blk.
PeerId -> TraceChainSyncClientTerminationEvent -> TraceEvent blk
TraceChainSyncClientTerminationEvent PeerId
peerId TraceChainSyncClientTerminationEvent
TraceExceededTimeLimitCS
Maybe ProtocolLimitFailure
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
case SomeException -> Maybe ChainSyncClientException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exn of
Just ChainSyncClientException
CSClient.DensityTooLow ->
Tracer m (TraceEvent blk) -> TraceEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent blk)
tracer (TraceEvent blk -> m ()) -> TraceEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ PeerId -> TraceChainSyncClientTerminationEvent -> TraceEvent blk
forall blk.
PeerId -> TraceChainSyncClientTerminationEvent -> TraceEvent blk
TraceChainSyncClientTerminationEvent PeerId
peerId TraceChainSyncClientTerminationEvent
TraceTerminatedByGDDGovernor
Just ChainSyncClientException
CSClient.EmptyBucket ->
Tracer m (TraceEvent blk) -> TraceEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent blk)
tracer (TraceEvent blk -> m ()) -> TraceEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ PeerId -> TraceChainSyncClientTerminationEvent -> TraceEvent blk
forall blk.
PeerId -> TraceChainSyncClientTerminationEvent -> TraceEvent blk
TraceChainSyncClientTerminationEvent PeerId
peerId TraceChainSyncClientTerminationEvent
TraceTerminatedByLoP
Maybe ChainSyncClientException
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
chainSyncNoSizeLimits :: ProtocolSizeLimits (ChainSync header point tip) bytes
chainSyncNoSizeLimits :: forall header point tip bytes.
ProtocolSizeLimits (ChainSync header point tip) bytes
chainSyncNoSizeLimits = (bytes -> Word)
-> ProtocolSizeLimits (ChainSync header point tip) bytes
forall {k} {k1} {k2} bytes (header :: k) (point :: k1) (tip :: k2).
(bytes -> Word)
-> ProtocolSizeLimits (ChainSync header point tip) bytes
byteLimitsChainSync (Word -> bytes -> Word
forall a b. a -> b -> a
const Word
0)
chainSyncNoTimeouts :: ChainSyncTimeout
chainSyncNoTimeouts :: ChainSyncTimeout
chainSyncNoTimeouts =
ChainSyncTimeout
{ canAwaitTimeout :: Maybe DiffTime
canAwaitTimeout = Maybe DiffTime
forall a. Maybe a
Nothing,
intersectTimeout :: Maybe DiffTime
intersectTimeout = Maybe DiffTime
forall a. Maybe a
Nothing,
mustReplyTimeout :: Maybe DiffTime
mustReplyTimeout = Maybe DiffTime
forall a. Maybe a
Nothing,
idleTimeout :: Maybe DiffTime
idleTimeout = Maybe DiffTime
forall a. Maybe a
Nothing
}
runChainSyncServer ::
(IOLike m, ShowProxy blk, ShowProxy (Header blk)) =>
Tracer m (TraceEvent blk) ->
PeerId ->
StateViewTracers blk m ->
ChainSyncServer (Header blk) (Point blk) (Tip blk) m () ->
Channel m (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))) ->
m ()
runChainSyncServer :: forall (m :: * -> *) blk.
(IOLike m, ShowProxy blk, ShowProxy (Header blk)) =>
Tracer m (TraceEvent blk)
-> PeerId
-> StateViewTracers blk m
-> ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
-> Channel
m (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
-> m ()
runChainSyncServer Tracer m (TraceEvent blk)
_tracer PeerId
peerId StateViewTracers {Tracer m (PeerSimulatorResult blk)
svtPeerSimulatorResultsTracer :: forall blk (m :: * -> *).
StateViewTracers blk m -> Tracer m (PeerSimulatorResult blk)
svtPeerSimulatorResultsTracer :: Tracer m (PeerSimulatorResult blk)
svtPeerSimulatorResultsTracer} ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
server Channel
m (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
channel =
(m ((),
Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
-> m (Either
SomeException
((),
Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))))
forall e a. Exception e => m a -> m (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (m ((),
Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
-> m (Either
SomeException
((),
Maybe
(AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))))
-> m ((),
Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
-> m (Either
SomeException
((),
Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))))
forall a b. (a -> b) -> a -> b
$ Tracer
m (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk)))
-> Codec
(ChainSync (Header blk) (Point blk) (Tip blk))
CodecFailure
m
(AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
-> Channel
m (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
-> Peer
(ChainSync (Header blk) (Point blk) (Tip blk))
'AsServer
'StIdle
m
()
-> m ((),
Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
a.
(MonadThrow m, Show failure,
forall (st' :: ps). Show (ClientHasAgency st'),
forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr st m a
-> m (a, Maybe bytes)
runPeer Tracer
m (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk)))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Codec
(ChainSync (Header blk) (Point blk) (Tip blk))
CodecFailure
m
(AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
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 blk) (Point blk) (Tip blk)))
channel (ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
-> Peer
(ChainSync (Header blk) (Point blk) (Tip blk))
'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 blk) (Point blk) (Tip blk) m ()
server)) m (Either
SomeException
((),
Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))))
-> (Either
SomeException
((),
Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
-> m ())
-> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Right ((), Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
msgRes) -> Tracer m (PeerSimulatorResult blk)
-> PeerSimulatorResult blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSimulatorResult blk)
svtPeerSimulatorResultsTracer (PeerSimulatorResult blk -> m ())
-> PeerSimulatorResult blk -> m ()
forall a b. (a -> b) -> a -> b
$
PeerId
-> PeerSimulatorComponentResult blk -> PeerSimulatorResult blk
forall blk.
PeerId
-> PeerSimulatorComponentResult blk -> PeerSimulatorResult blk
PeerSimulatorResult PeerId
peerId (PeerSimulatorComponentResult blk -> PeerSimulatorResult blk)
-> PeerSimulatorComponentResult blk -> PeerSimulatorResult blk
forall a b. (a -> b) -> a -> b
$ Either
SomeException
(Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
-> PeerSimulatorComponentResult blk
forall blk.
Either SomeException (Maybe (ChainSyncResult blk))
-> PeerSimulatorComponentResult blk
SomeChainSyncServerResult (Either
SomeException
(Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
-> PeerSimulatorComponentResult blk)
-> Either
SomeException
(Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
-> PeerSimulatorComponentResult blk
forall a b. (a -> b) -> a -> b
$ Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
-> Either
SomeException
(Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
forall a b. b -> Either a b
Right Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
msgRes
Left SomeException
exn -> do
Tracer m (PeerSimulatorResult blk)
-> PeerSimulatorResult blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (PeerSimulatorResult blk)
svtPeerSimulatorResultsTracer (PeerSimulatorResult blk -> m ())
-> PeerSimulatorResult blk -> m ()
forall a b. (a -> b) -> a -> b
$
PeerId
-> PeerSimulatorComponentResult blk -> PeerSimulatorResult blk
forall blk.
PeerId
-> PeerSimulatorComponentResult blk -> PeerSimulatorResult blk
PeerSimulatorResult PeerId
peerId (PeerSimulatorComponentResult blk -> PeerSimulatorResult blk)
-> PeerSimulatorComponentResult blk -> PeerSimulatorResult blk
forall a b. (a -> b) -> a -> b
$ Either
SomeException
(Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
-> PeerSimulatorComponentResult blk
forall blk.
Either SomeException (Maybe (ChainSyncResult blk))
-> PeerSimulatorComponentResult blk
SomeChainSyncServerResult (Either
SomeException
(Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
-> PeerSimulatorComponentResult blk)
-> Either
SomeException
(Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
-> PeerSimulatorComponentResult blk
forall a b. (a -> b) -> a -> b
$ SomeException
-> Either
SomeException
(Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
forall a b. a -> Either a b
Left SomeException
exn
case SomeException -> Maybe SomeException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exn of
(Maybe SomeException
_ :: Maybe SomeException) -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()