{-# 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 (DiffusionPipeliningSupport (..),
                     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 ()

-- | A basic ChainSync client. It wraps around 'chainSyncClient', but simplifies
-- quite a few aspects. In particular, the size of the pipeline cannot exceed 20
-- messages and the “in future” checks are disabled.
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
        -- Preventing historical MsgRollBack and MsgAwaitReply messages is
        -- motivated by preventing additional load from CSJ-disengaged peers; we
        -- do not care about this in these tests.
      , $sel:historicityCheck:ConfigEnv :: HistoricityCheck m blk
CSClient.historicityCheck        = HistoricityCheck m blk
forall (m :: * -> *) blk. Applicative m => HistoricityCheck m blk
HistoricityCheck.noCheck
      , $sel:getDiffusionPipeliningSupport:ConfigEnv :: DiffusionPipeliningSupport
CSClient.getDiffusionPipeliningSupport = DiffusionPipeliningSupport
DiffusionPipeliningOn
      }
    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 = \()
_ ->
          -- We are not inspecting header slot time in the Genesis tests.
          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
      }

-- | Create and run a ChainSync client using 'bracketChainSyncClient' and
-- 'basicChainSyncClient', synchronously. Exceptions are caught, sent to the
-- 'StateViewTracers' and logged.
runChainSyncClient ::
  (IOLike m, MonadTimer m, LedgerSupportsProtocol blk, ShowProxy blk, ShowProxy (Header blk)) =>
  Tracer m (TraceEvent blk) ->
  TopLevelConfig blk ->
  ChainDbView m blk ->
  PeerId ->
  -- ^ The id of the peer to which the client connects.
  ChainSyncTimeout ->
  -- ^ Timeouts for this client.
  ChainSyncLoPBucketConfig ->
  -- ^ Configuration for the LoP bucket.
  CSJConfig ->
  -- ^ Configuration for ChainSync Jumping
  StateViewTracers blk m ->
  -- ^ Tracers used to record information for the future 'StateView'.
  StrictTVar m (Map PeerId (ChainSyncClientHandle m blk)) ->
  -- ^ A TVar containing a map of states for each peer. This
  -- function will (via 'bracketChainSyncClient') register and de-register a
  -- TVar for the state of the peer.
  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
-> DiffusionPipeliningSupport
-> (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
-> DiffusionPipeliningSupport
-> (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
      DiffusionPipeliningSupport
DiffusionPipeliningOn -- ^ TODO make this a parameter?
      ((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, MonadTimer m,
 MonadThrow (STM m), ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 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
-> ClientPipelined (ChainSync header point tip) '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 StateToken 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 StateToken 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
     'NonPipelined
     'StIdle
     m
     ()
-> m ((),
      Maybe (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))))
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadThrow m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeer Tracer
  m (TraceSendRecv (ChainSync (Header 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
     'NonPipelined
     'StIdle
     m
     ()
forall header point tip (m :: * -> *) a.
Monad m =>
ChainSyncServer header point tip m a
-> Server (ChainSync header point tip) 'NonPipelined 'StIdle m a
chainSyncServerPeer ChainSyncServer (Header 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
      -- NOTE: here we are able to trace exceptions, as what is done in `runChainSyncClient`
      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 ()