{-# 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
  }