{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}

-- | A ChainSync protocol server that allows external scheduling of its
-- operations, while deferring the implementation of the message handler
-- logic to a simplified, abstract interface provided as a parameter.
module Test.Consensus.PeerSimulator.ScheduledChainSyncServer
  ( ChainSyncServerHandlers (..)
  , FindIntersect (..)
  , RequestNext (..)
  , ScheduledChainSyncServer (..)
  , runScheduledChainSyncServer
  ) where

import Control.Tracer (Tracer (Tracer), traceWith)
import Ouroboros.Consensus.Block (Header)
import Ouroboros.Consensus.Block.Abstract (Point (..))
import Ouroboros.Consensus.Util.IOLike (IOLike, MonadSTM (STM))
import Ouroboros.Network.Block (Tip (..))
import Ouroboros.Network.Protocol.ChainSync.Server
  ( ChainSyncServer (..)
  , ServerStIdle (ServerStIdle, recvMsgDoneClient, recvMsgFindIntersect, recvMsgRequestNext)
  , ServerStIntersect (SendMsgIntersectFound, SendMsgIntersectNotFound)
  , ServerStNext (SendMsgRollBackward, SendMsgRollForward)
  )
import Test.Consensus.PeerSimulator.ScheduledServer
  ( ScheduledServer (..)
  , awaitOnlineState
  , runHandler
  )
import Test.Consensus.PeerSimulator.Trace
  ( TraceEvent (TraceScheduledChainSyncServerEvent)
  , TraceScheduledChainSyncServerEvent (..)
  )
import Test.Consensus.PointSchedule.NodeState (NodeState)
import Test.Consensus.PointSchedule.Peers (PeerId)

-- | Pure representation of the messages produced by the handler for the @StNext@
-- protocol state of a ChainSync server.
data RequestNext blk
  = RollForward (Header blk) (Tip blk)
  | RollBackward (Point blk) (Tip blk)
  | AwaitReply

-- | Pure representation of the messages produced by the handler for the @StIntersect@
-- protocol state of a ChainSync server.
data FindIntersect blk
  = IntersectFound (Point blk) (Tip blk)
  | IntersectNotFound (Tip blk)

-- | Handlers for the request a ChainSync server might receive from a client.
-- These take an abstract argument that corresponds to the state of a point
-- schedule tick and return the simplified protocol message types.
--
-- See 'runHandlerWithTrace' for the meaning of @[String]@.
data ChainSyncServerHandlers m state blk
  = ChainSyncServerHandlers
  { forall (m :: * -> *) state blk.
ChainSyncServerHandlers m state blk
-> state
-> STM
     m
     (Maybe (RequestNext blk),
      [TraceScheduledChainSyncServerEvent state blk])
csshRequestNext ::
      state ->
      STM m (Maybe (RequestNext blk), [TraceScheduledChainSyncServerEvent state blk])
  , forall (m :: * -> *) state blk.
ChainSyncServerHandlers m state blk
-> [Point blk]
-> state
-> STM
     m
     (Maybe (FindIntersect blk),
      [TraceScheduledChainSyncServerEvent state blk])
csshFindIntersection ::
      [Point blk] ->
      state ->
      STM m (Maybe (FindIntersect blk), [TraceScheduledChainSyncServerEvent state blk])
  }

-- | Resources used by a ChainSync server mock.
data ScheduledChainSyncServer m state blk
  = ScheduledChainSyncServer
  { forall (m :: * -> *) state blk.
ScheduledChainSyncServer m state blk -> ScheduledServer m state blk
scssServer :: ScheduledServer m state blk
  , forall (m :: * -> *) state blk.
ScheduledChainSyncServer m state blk
-> Tracer m (TraceScheduledChainSyncServerEvent state blk)
scssTracer :: Tracer m (TraceScheduledChainSyncServerEvent state blk)
  , forall (m :: * -> *) state blk.
ScheduledChainSyncServer m state blk
-> ChainSyncServerHandlers m state blk
scssHandlers :: ChainSyncServerHandlers m state blk
  }

-- | Declare a mock ChainSync protocol server in its typed-protocols encoding
-- that halts and resumes operation in response to an external scheduler,
-- signalling via a blocking STM action that is sequenced by calling
-- 'awaitNextState' in 'recvMsgRequestNext' after the current state has been
-- fully processed, which is indicated by the handler for this message.
--
-- Handlers are supplied as a record of STM callbacks ('ChainSyncServerHandlers')
-- by the caller.
--
-- This architecture allows the server's behavior to be defined with a simple
-- interface separated from the scheduling and protocol plumbing infrastructure.
scheduledChainSyncServer ::
  IOLike m =>
  ScheduledChainSyncServer m a blk ->
  ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
scheduledChainSyncServer :: forall (m :: * -> *) a blk.
IOLike m =>
ScheduledChainSyncServer m a blk
-> ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
scheduledChainSyncServer ScheduledChainSyncServer{ChainSyncServerHandlers m a blk
scssHandlers :: forall (m :: * -> *) state blk.
ScheduledChainSyncServer m state blk
-> ChainSyncServerHandlers m state blk
scssHandlers :: ChainSyncServerHandlers m a blk
scssHandlers, Tracer m (TraceScheduledChainSyncServerEvent a blk)
scssTracer :: forall (m :: * -> *) state blk.
ScheduledChainSyncServer m state blk
-> Tracer m (TraceScheduledChainSyncServerEvent state blk)
scssTracer :: Tracer m (TraceScheduledChainSyncServerEvent a blk)
scssTracer, ScheduledServer m a blk
scssServer :: forall (m :: * -> *) state blk.
ScheduledChainSyncServer m state blk -> ScheduledServer m state blk
scssServer :: ScheduledServer m a blk
scssServer} =
  ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
go
 where
  ChainSyncServerHandlers{a
-> STM
     m
     (Maybe (RequestNext blk),
      [TraceScheduledChainSyncServerEvent a blk])
csshRequestNext :: forall (m :: * -> *) state blk.
ChainSyncServerHandlers m state blk
-> state
-> STM
     m
     (Maybe (RequestNext blk),
      [TraceScheduledChainSyncServerEvent state blk])
csshRequestNext :: a
-> STM
     m
     (Maybe (RequestNext blk),
      [TraceScheduledChainSyncServerEvent a blk])
csshRequestNext, [Point blk]
-> a
-> STM
     m
     (Maybe (FindIntersect blk),
      [TraceScheduledChainSyncServerEvent a blk])
csshFindIntersection :: forall (m :: * -> *) state blk.
ChainSyncServerHandlers m state blk
-> [Point blk]
-> state
-> STM
     m
     (Maybe (FindIntersect blk),
      [TraceScheduledChainSyncServerEvent state blk])
csshFindIntersection :: [Point blk]
-> a
-> STM
     m
     (Maybe (FindIntersect blk),
      [TraceScheduledChainSyncServerEvent a blk])
csshFindIntersection} = ChainSyncServerHandlers m a blk
scssHandlers

  go :: ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
go =
    m (ServerStIdle (Header blk) (Point blk) (Tip blk) m ())
-> ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
forall header point tip (m :: * -> *) a.
m (ServerStIdle header point tip m a)
-> ChainSyncServer header point tip m a
ChainSyncServer (m (ServerStIdle (Header blk) (Point blk) (Tip blk) m ())
 -> ChainSyncServer (Header blk) (Point blk) (Tip blk) m ())
-> m (ServerStIdle (Header blk) (Point blk) (Tip blk) m ())
-> ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
forall a b. (a -> b) -> a -> b
$
      ServerStIdle (Header blk) (Point blk) (Tip blk) m ()
-> m (ServerStIdle (Header blk) (Point blk) (Tip blk) m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ServerStIdle
          { m (Either
     (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
     (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ())))
recvMsgRequestNext :: m (Either
     (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
     (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ())))
recvMsgRequestNext :: m (Either
     (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
     (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ())))
recvMsgRequestNext
          , [Point blk]
-> m (ServerStIntersect (Header blk) (Point blk) (Tip blk) m ())
recvMsgFindIntersect :: [Point blk]
-> m (ServerStIntersect (Header blk) (Point blk) (Tip blk) m ())
recvMsgFindIntersect :: [Point blk]
-> m (ServerStIntersect (Header blk) (Point blk) (Tip blk) m ())
recvMsgFindIntersect
          , m ()
recvMsgDoneClient :: m ()
recvMsgDoneClient :: m ()
recvMsgDoneClient
          }

  recvMsgRequestNext :: m (Either
     (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
     (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ())))
recvMsgRequestNext =
    ScheduledServer m a blk
-> String
-> (a
    -> STM
         m
         (Maybe (RequestNext blk),
          [TraceScheduledChainSyncServerEvent a blk]))
-> Tracer m (TraceScheduledChainSyncServerEvent a blk)
-> (RequestNext blk
    -> m (Either
            (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
            (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ()))))
-> m (Either
        (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
        (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ())))
forall (m :: * -> *) state blk msg traceMsg h.
IOLike m =>
ScheduledServer m state blk
-> String
-> (state -> STM m (Maybe msg, [traceMsg]))
-> Tracer m traceMsg
-> (msg -> m h)
-> m h
runHandler ScheduledServer m a blk
scssServer String
"MsgRequestNext" a
-> STM
     m
     (Maybe (RequestNext blk),
      [TraceScheduledChainSyncServerEvent a blk])
csshRequestNext Tracer m (TraceScheduledChainSyncServerEvent a blk)
scssTracer ((RequestNext blk
  -> m (Either
          (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
          (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ()))))
 -> m (Either
         (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
         (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ()))))
-> (RequestNext blk
    -> m (Either
            (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
            (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ()))))
-> m (Either
        (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
        (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ())))
forall a b. (a -> b) -> a -> b
$ \case
      RollForward Header blk
header Tip blk
tip -> do
        TraceScheduledChainSyncServerEvent a blk -> m ()
trace (TraceScheduledChainSyncServerEvent a blk -> m ())
-> TraceScheduledChainSyncServerEvent a blk -> m ()
forall a b. (a -> b) -> a -> b
$ Header blk -> Tip blk -> TraceScheduledChainSyncServerEvent a blk
forall state blk.
Header blk
-> Tip blk -> TraceScheduledChainSyncServerEvent state blk
TraceRollForward Header blk
header Tip blk
tip
        Either
  (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
  (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ()))
-> m (Either
        (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
        (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ())))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
   (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ()))
 -> m (Either
         (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
         (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ()))))
-> Either
     (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
     (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ()))
-> m (Either
        (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
        (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ())))
forall a b. (a -> b) -> a -> b
$ ServerStNext (Header blk) (Point blk) (Tip blk) m ()
-> Either
     (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
     (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ()))
forall a b. a -> Either a b
Left (ServerStNext (Header blk) (Point blk) (Tip blk) m ()
 -> Either
      (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
      (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ())))
-> ServerStNext (Header blk) (Point blk) (Tip blk) m ()
-> Either
     (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
     (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ()))
forall a b. (a -> b) -> a -> b
$ Header blk
-> Tip blk
-> ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
-> ServerStNext (Header blk) (Point blk) (Tip blk) m ()
forall header tip point (m :: * -> *) a.
header
-> tip
-> ChainSyncServer header point tip m a
-> ServerStNext header point tip m a
SendMsgRollForward Header blk
header Tip blk
tip ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
go
      RollBackward Point blk
point Tip blk
tip -> do
        TraceScheduledChainSyncServerEvent a blk -> m ()
trace (TraceScheduledChainSyncServerEvent a blk -> m ())
-> TraceScheduledChainSyncServerEvent a blk -> m ()
forall a b. (a -> b) -> a -> b
$ Point blk -> Tip blk -> TraceScheduledChainSyncServerEvent a blk
forall state blk.
Point blk
-> Tip blk -> TraceScheduledChainSyncServerEvent state blk
TraceRollBackward Point blk
point Tip blk
tip
        Either
  (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
  (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ()))
-> m (Either
        (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
        (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ())))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
   (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ()))
 -> m (Either
         (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
         (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ()))))
-> Either
     (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
     (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ()))
-> m (Either
        (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
        (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ())))
forall a b. (a -> b) -> a -> b
$ ServerStNext (Header blk) (Point blk) (Tip blk) m ()
-> Either
     (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
     (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ()))
forall a b. a -> Either a b
Left (ServerStNext (Header blk) (Point blk) (Tip blk) m ()
 -> Either
      (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
      (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ())))
-> ServerStNext (Header blk) (Point blk) (Tip blk) m ()
-> Either
     (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
     (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ()))
forall a b. (a -> b) -> a -> b
$ Point blk
-> Tip blk
-> ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
-> ServerStNext (Header blk) (Point blk) (Tip blk) m ()
forall point tip header (m :: * -> *) a.
point
-> tip
-> ChainSyncServer header point tip m a
-> ServerStNext header point tip m a
SendMsgRollBackward Point blk
point Tip blk
tip ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
go
      RequestNext blk
AwaitReply ->
        Either
  (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
  (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ()))
-> m (Either
        (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
        (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ())))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
   (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ()))
 -> m (Either
         (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
         (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ()))))
-> Either
     (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
     (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ()))
-> m (Either
        (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
        (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ())))
forall a b. (a -> b) -> a -> b
$ m (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
-> Either
     (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
     (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ()))
forall a b. b -> Either a b
Right (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
 -> Either
      (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
      (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ())))
-> m (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
-> Either
     (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
     (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ()))
forall a b. (a -> b) -> a -> b
$ do
          -- beginning of the continuation
          m (Either
     (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
     (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ())))
restart m (Either
     (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
     (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ())))
-> (Either
      (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
      (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ()))
    -> m (ServerStNext (Header blk) (Point blk) (Tip blk) m ()))
-> m (ServerStNext (Header blk) (Point blk) (Tip blk) 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
            -- If we get 'Right', then we still do not have anything to serve
            -- and we loop; what 'Right' contains is the continuation starting
            -- at 'do' above; by unwrapping the 'Right', we do not send
            -- another AwaitReply message (which Typed Protocols does not
            -- allow anyway).
            Right m (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
cont -> m (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
cont
            Left ServerStNext (Header blk) (Point blk) (Tip blk) m ()
msg -> ServerStNext (Header blk) (Point blk) (Tip blk) m ()
-> m (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ServerStNext (Header blk) (Point blk) (Tip blk) m ()
msg
   where
    -- Yield control back to the scheduler, then wait for the next state and
    -- continue processing the client's current 'MsgRequestNext'.
    restart :: m (Either
     (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
     (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ())))
restart = ScheduledServer m a blk -> m a
forall (m :: * -> *) state blk.
IOLike m =>
ScheduledServer m state blk -> m state
awaitOnlineState ScheduledServer m a blk
scssServer m a
-> m (Either
        (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
        (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ())))
-> m (Either
        (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
        (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ())))
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m (Either
     (ServerStNext (Header blk) (Point blk) (Tip blk) m ())
     (m (ServerStNext (Header blk) (Point blk) (Tip blk) m ())))
recvMsgRequestNext

  recvMsgFindIntersect :: [Point blk]
-> m (ServerStIntersect (Header blk) (Point blk) (Tip blk) m ())
recvMsgFindIntersect [Point blk]
pts =
    ScheduledServer m a blk
-> String
-> (a
    -> STM
         m
         (Maybe (FindIntersect blk),
          [TraceScheduledChainSyncServerEvent a blk]))
-> Tracer m (TraceScheduledChainSyncServerEvent a blk)
-> (FindIntersect blk
    -> m (ServerStIntersect (Header blk) (Point blk) (Tip blk) m ()))
-> m (ServerStIntersect (Header blk) (Point blk) (Tip blk) m ())
forall (m :: * -> *) state blk msg traceMsg h.
IOLike m =>
ScheduledServer m state blk
-> String
-> (state -> STM m (Maybe msg, [traceMsg]))
-> Tracer m traceMsg
-> (msg -> m h)
-> m h
runHandler ScheduledServer m a blk
scssServer String
"MsgFindIntersect" ([Point blk]
-> a
-> STM
     m
     (Maybe (FindIntersect blk),
      [TraceScheduledChainSyncServerEvent a blk])
csshFindIntersection [Point blk]
pts) Tracer m (TraceScheduledChainSyncServerEvent a blk)
scssTracer ((FindIntersect blk
  -> m (ServerStIntersect (Header blk) (Point blk) (Tip blk) m ()))
 -> m (ServerStIntersect (Header blk) (Point blk) (Tip blk) m ()))
-> (FindIntersect blk
    -> m (ServerStIntersect (Header blk) (Point blk) (Tip blk) m ()))
-> m (ServerStIntersect (Header blk) (Point blk) (Tip blk) m ())
forall a b. (a -> b) -> a -> b
$ \case
      IntersectNotFound Tip blk
tip -> do
        TraceScheduledChainSyncServerEvent a blk -> m ()
trace TraceScheduledChainSyncServerEvent a blk
forall state blk. TraceScheduledChainSyncServerEvent state blk
TraceIntersectionNotFound
        ServerStIntersect (Header blk) (Point blk) (Tip blk) m ()
-> m (ServerStIntersect (Header blk) (Point blk) (Tip blk) m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServerStIntersect (Header blk) (Point blk) (Tip blk) m ()
 -> m (ServerStIntersect (Header blk) (Point blk) (Tip blk) m ()))
-> ServerStIntersect (Header blk) (Point blk) (Tip blk) m ()
-> m (ServerStIntersect (Header blk) (Point blk) (Tip blk) m ())
forall a b. (a -> b) -> a -> b
$ Tip blk
-> ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
-> ServerStIntersect (Header blk) (Point blk) (Tip blk) m ()
forall tip header point (m :: * -> *) a.
tip
-> ChainSyncServer header point tip m a
-> ServerStIntersect header point tip m a
SendMsgIntersectNotFound Tip blk
tip ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
go
      IntersectFound Point blk
intersection Tip blk
tip -> do
        TraceScheduledChainSyncServerEvent a blk -> m ()
trace (TraceScheduledChainSyncServerEvent a blk -> m ())
-> TraceScheduledChainSyncServerEvent a blk -> m ()
forall a b. (a -> b) -> a -> b
$ Point blk -> TraceScheduledChainSyncServerEvent a blk
forall state blk.
Point blk -> TraceScheduledChainSyncServerEvent state blk
TraceIntersectionFound Point blk
intersection
        ServerStIntersect (Header blk) (Point blk) (Tip blk) m ()
-> m (ServerStIntersect (Header blk) (Point blk) (Tip blk) m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServerStIntersect (Header blk) (Point blk) (Tip blk) m ()
 -> m (ServerStIntersect (Header blk) (Point blk) (Tip blk) m ()))
-> ServerStIntersect (Header blk) (Point blk) (Tip blk) m ()
-> m (ServerStIntersect (Header blk) (Point blk) (Tip blk) m ())
forall a b. (a -> b) -> a -> b
$ Point blk
-> Tip blk
-> ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
-> ServerStIntersect (Header blk) (Point blk) (Tip blk) m ()
forall point tip header (m :: * -> *) a.
point
-> tip
-> ChainSyncServer header point tip m a
-> ServerStIntersect header point tip m a
SendMsgIntersectFound Point blk
intersection Tip blk
tip ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
go

  recvMsgDoneClient :: m ()
recvMsgDoneClient =
    TraceScheduledChainSyncServerEvent a blk -> m ()
trace TraceScheduledChainSyncServerEvent a blk
forall state blk. TraceScheduledChainSyncServerEvent state blk
TraceClientIsDone

  trace :: TraceScheduledChainSyncServerEvent a blk -> m ()
trace = Tracer m (TraceScheduledChainSyncServerEvent a blk)
-> TraceScheduledChainSyncServerEvent a blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceScheduledChainSyncServerEvent a blk)
scssTracer

-- | Construct a ChainSync server for the peer simulator.
--
-- See 'scheduledChainSyncServer'.
runScheduledChainSyncServer ::
  IOLike m =>
  PeerId ->
  STM m () ->
  STM m (Maybe (NodeState blk)) ->
  Tracer m (TraceEvent blk) ->
  ChainSyncServerHandlers m (NodeState blk) blk ->
  ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
runScheduledChainSyncServer :: forall (m :: * -> *) blk.
IOLike m =>
PeerId
-> STM m ()
-> STM m (Maybe (NodeState blk))
-> Tracer m (TraceEvent blk)
-> ChainSyncServerHandlers m (NodeState blk) blk
-> ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
runScheduledChainSyncServer PeerId
ssPeerId STM m ()
ssTickStarted STM m (Maybe (NodeState blk))
ssCurrentState Tracer m (TraceEvent blk)
tracer ChainSyncServerHandlers m (NodeState blk) blk
scssHandlers =
  ScheduledChainSyncServer m (NodeState blk) blk
-> ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
forall (m :: * -> *) a blk.
IOLike m =>
ScheduledChainSyncServer m a blk
-> ChainSyncServer (Header blk) (Point blk) (Tip blk) m ()
scheduledChainSyncServer
    ScheduledChainSyncServer
      { scssServer :: ScheduledServer m (NodeState blk) blk
scssServer =
          ScheduledServer
            { PeerId
ssPeerId :: PeerId
ssPeerId :: PeerId
ssPeerId
            , STM m ()
ssTickStarted :: STM m ()
ssTickStarted :: STM m ()
ssTickStarted
            , STM m (Maybe (NodeState blk))
ssCurrentState :: STM m (Maybe (NodeState blk))
ssCurrentState :: STM m (Maybe (NodeState blk))
ssCurrentState
            , ssCommonTracer :: Tracer m (TraceScheduledServerHandlerEvent (NodeState blk) blk)
ssCommonTracer =
                (TraceScheduledServerHandlerEvent (NodeState blk) blk -> m ())
-> Tracer m (TraceScheduledServerHandlerEvent (NodeState blk) 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 ())
-> (TraceScheduledServerHandlerEvent (NodeState blk) blk
    -> TraceEvent blk)
-> TraceScheduledServerHandlerEvent (NodeState blk) blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerId
-> TraceScheduledChainSyncServerEvent (NodeState blk) blk
-> TraceEvent blk
forall blk.
PeerId
-> TraceScheduledChainSyncServerEvent (NodeState blk) blk
-> TraceEvent blk
TraceScheduledChainSyncServerEvent PeerId
ssPeerId (TraceScheduledChainSyncServerEvent (NodeState blk) blk
 -> TraceEvent blk)
-> (TraceScheduledServerHandlerEvent (NodeState blk) blk
    -> TraceScheduledChainSyncServerEvent (NodeState blk) blk)
-> TraceScheduledServerHandlerEvent (NodeState blk) blk
-> TraceEvent blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TraceScheduledServerHandlerEvent (NodeState blk) blk
-> TraceScheduledChainSyncServerEvent (NodeState blk) blk
forall state blk.
TraceScheduledServerHandlerEvent state blk
-> TraceScheduledChainSyncServerEvent state blk
TraceHandlerEventCS)
            }
      , scssTracer :: Tracer m (TraceScheduledChainSyncServerEvent (NodeState blk) blk)
scssTracer = (TraceScheduledChainSyncServerEvent (NodeState blk) blk -> m ())
-> Tracer
     m (TraceScheduledChainSyncServerEvent (NodeState blk) 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 ())
-> (TraceScheduledChainSyncServerEvent (NodeState blk) blk
    -> TraceEvent blk)
-> TraceScheduledChainSyncServerEvent (NodeState blk) blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerId
-> TraceScheduledChainSyncServerEvent (NodeState blk) blk
-> TraceEvent blk
forall blk.
PeerId
-> TraceScheduledChainSyncServerEvent (NodeState blk) blk
-> TraceEvent blk
TraceScheduledChainSyncServerEvent PeerId
ssPeerId)
      , ChainSyncServerHandlers m (NodeState blk) blk
scssHandlers :: ChainSyncServerHandlers m (NodeState blk) blk
scssHandlers :: ChainSyncServerHandlers m (NodeState blk) blk
scssHandlers
      }