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

module Test.Consensus.PeerSimulator.ScheduledBlockFetchServer (
    BlockFetch (..)
  , BlockFetchServerHandlers (..)
  , ScheduledBlockFetchServer (..)
  , SendBlocks (..)
  , runScheduledBlockFetchServer
  ) where

import           Control.Tracer
import           Ouroboros.Consensus.Block (Point)
import           Ouroboros.Consensus.Util.IOLike (IOLike, MonadSTM (STM))
import           Ouroboros.Network.BlockFetch.ClientState (ChainRange)
import           Ouroboros.Network.Protocol.BlockFetch.Server
import           Test.Consensus.PeerSimulator.ScheduledServer
                     (ScheduledServer (..), awaitOnlineState, runHandler)
import           Test.Consensus.PeerSimulator.Trace
import           Test.Consensus.PointSchedule.NodeState (NodeState)
import           Test.Consensus.PointSchedule.Peers (PeerId)

-- | Return values for the 'handlerSendBlocks'.
data SendBlocks blk =
  SendBlock blk [blk]
  |
  BatchDone

-- | Return values for the 'handlerBlockFetch'.
data BlockFetch blk =
  StartBatch [blk]
  -- ^ As a response to the client request, we should send the blocks in the
  -- given batch.
  |
  NoBlocks
  -- ^ Negative response to the client's request for blocks.
  deriving (BlockFetch blk -> BlockFetch blk -> Bool
(BlockFetch blk -> BlockFetch blk -> Bool)
-> (BlockFetch blk -> BlockFetch blk -> Bool)
-> Eq (BlockFetch blk)
forall blk. Eq blk => BlockFetch blk -> BlockFetch blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall blk. Eq blk => BlockFetch blk -> BlockFetch blk -> Bool
== :: BlockFetch blk -> BlockFetch blk -> Bool
$c/= :: forall blk. Eq blk => BlockFetch blk -> BlockFetch blk -> Bool
/= :: BlockFetch blk -> BlockFetch blk -> Bool
Eq, Int -> BlockFetch blk -> ShowS
[BlockFetch blk] -> ShowS
BlockFetch blk -> String
(Int -> BlockFetch blk -> ShowS)
-> (BlockFetch blk -> String)
-> ([BlockFetch blk] -> ShowS)
-> Show (BlockFetch blk)
forall blk. Show blk => Int -> BlockFetch blk -> ShowS
forall blk. Show blk => [BlockFetch blk] -> ShowS
forall blk. Show blk => BlockFetch blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk. Show blk => Int -> BlockFetch blk -> ShowS
showsPrec :: Int -> BlockFetch blk -> ShowS
$cshow :: forall blk. Show blk => BlockFetch blk -> String
show :: BlockFetch blk -> String
$cshowList :: forall blk. Show blk => [BlockFetch blk] -> ShowS
showList :: [BlockFetch blk] -> ShowS
Show)

-- | Handlers for the scheduled BlockFetch server.
data BlockFetchServerHandlers m state blk =
  BlockFetchServerHandlers {
    forall (m :: * -> *) state blk.
BlockFetchServerHandlers m state blk
-> ChainRange (Point blk)
-> state
-> STM
     m
     (Maybe (BlockFetch blk),
      [TraceScheduledBlockFetchServerEvent state blk])
bfshBlockFetch :: ChainRange (Point blk) -> state -> STM m (Maybe (BlockFetch blk), [TraceScheduledBlockFetchServerEvent state blk]),
    forall (m :: * -> *) state blk.
BlockFetchServerHandlers m state blk
-> [blk]
-> state
-> STM
     m
     (Maybe (SendBlocks blk),
      [TraceScheduledBlockFetchServerEvent state blk])
bfshSendBlocks :: [blk] -> state -> STM m (Maybe (SendBlocks blk), [TraceScheduledBlockFetchServerEvent state blk])
  }

-- | Resources used by a scheduled BlockFetch server. This comprises a generic
-- 'ScheduledServer' and BlockFetch-specific handlers.
data ScheduledBlockFetchServer m state blk =
  ScheduledBlockFetchServer {
    forall (m :: * -> *) state blk.
ScheduledBlockFetchServer m state blk
-> ScheduledServer m state blk
sbfsServer   :: ScheduledServer m state blk,
    forall (m :: * -> *) state blk.
ScheduledBlockFetchServer m state blk
-> Tracer m (TraceScheduledBlockFetchServerEvent state blk)
sbfsTracer   :: Tracer m (TraceScheduledBlockFetchServerEvent state blk),
    forall (m :: * -> *) state blk.
ScheduledBlockFetchServer m state blk
-> BlockFetchServerHandlers m state blk
sbfsHandlers :: BlockFetchServerHandlers m state blk
  }

-- | Make a 'BlockFetchServer' able to run with the normal infrastructure from a
-- 'ScheduledBlockFetchServer'.
scheduledBlockFetchServer ::
  forall m state blk.
  IOLike m =>
  ScheduledBlockFetchServer m state blk ->
  BlockFetchServer blk (Point blk) m ()
scheduledBlockFetchServer :: forall (m :: * -> *) state blk.
IOLike m =>
ScheduledBlockFetchServer m state blk
-> BlockFetchServer blk (Point blk) m ()
scheduledBlockFetchServer ScheduledBlockFetchServer {ScheduledServer m state blk
sbfsServer :: forall (m :: * -> *) state blk.
ScheduledBlockFetchServer m state blk
-> ScheduledServer m state blk
sbfsServer :: ScheduledServer m state blk
sbfsServer, Tracer m (TraceScheduledBlockFetchServerEvent state blk)
sbfsTracer :: forall (m :: * -> *) state blk.
ScheduledBlockFetchServer m state blk
-> Tracer m (TraceScheduledBlockFetchServerEvent state blk)
sbfsTracer :: Tracer m (TraceScheduledBlockFetchServerEvent state blk)
sbfsTracer, BlockFetchServerHandlers m state blk
sbfsHandlers :: forall (m :: * -> *) state blk.
ScheduledBlockFetchServer m state blk
-> BlockFetchServerHandlers m state blk
sbfsHandlers :: BlockFetchServerHandlers m state blk
sbfsHandlers} =
  BlockFetchServer blk (Point blk) m ()
server
  where
    server :: BlockFetchServer blk (Point blk) m ()
server = (ChainRange (Point blk)
 -> m (BlockFetchBlockSender blk (Point blk) m ()))
-> () -> BlockFetchServer blk (Point blk) m ()
forall point (m :: * -> *) block a.
(ChainRange point -> m (BlockFetchBlockSender block point m a))
-> a -> BlockFetchServer block point m a
BlockFetchServer ChainRange (Point blk)
-> m (BlockFetchBlockSender blk (Point blk) m ())
blockFetch ()

    BlockFetchServerHandlers {ChainRange (Point blk)
-> state
-> STM
     m
     (Maybe (BlockFetch blk),
      [TraceScheduledBlockFetchServerEvent state blk])
bfshBlockFetch :: forall (m :: * -> *) state blk.
BlockFetchServerHandlers m state blk
-> ChainRange (Point blk)
-> state
-> STM
     m
     (Maybe (BlockFetch blk),
      [TraceScheduledBlockFetchServerEvent state blk])
bfshBlockFetch :: ChainRange (Point blk)
-> state
-> STM
     m
     (Maybe (BlockFetch blk),
      [TraceScheduledBlockFetchServerEvent state blk])
bfshBlockFetch, [blk]
-> state
-> STM
     m
     (Maybe (SendBlocks blk),
      [TraceScheduledBlockFetchServerEvent state blk])
bfshSendBlocks :: forall (m :: * -> *) state blk.
BlockFetchServerHandlers m state blk
-> [blk]
-> state
-> STM
     m
     (Maybe (SendBlocks blk),
      [TraceScheduledBlockFetchServerEvent state blk])
bfshSendBlocks :: [blk]
-> state
-> STM
     m
     (Maybe (SendBlocks blk),
      [TraceScheduledBlockFetchServerEvent state blk])
bfshSendBlocks} = BlockFetchServerHandlers m state blk
sbfsHandlers

    blockFetch :: ChainRange (Point blk)
-> m (BlockFetchBlockSender blk (Point blk) m ())
blockFetch ChainRange (Point blk)
range =
      ScheduledServer m state blk
-> String
-> (state
    -> STM
         m
         (Maybe (BlockFetch blk),
          [TraceScheduledBlockFetchServerEvent state blk]))
-> Tracer m (TraceScheduledBlockFetchServerEvent state blk)
-> (BlockFetch blk
    -> m (BlockFetchBlockSender blk (Point blk) m ()))
-> m (BlockFetchBlockSender blk (Point 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 state blk
sbfsServer String
"BlockFetch" (ChainRange (Point blk)
-> state
-> STM
     m
     (Maybe (BlockFetch blk),
      [TraceScheduledBlockFetchServerEvent state blk])
bfshBlockFetch ChainRange (Point blk)
range) Tracer m (TraceScheduledBlockFetchServerEvent state blk)
sbfsTracer ((BlockFetch blk -> m (BlockFetchBlockSender blk (Point blk) m ()))
 -> m (BlockFetchBlockSender blk (Point blk) m ()))
-> (BlockFetch blk
    -> m (BlockFetchBlockSender blk (Point blk) m ()))
-> m (BlockFetchBlockSender blk (Point blk) m ())
forall a b. (a -> b) -> a -> b
$ \case
        StartBatch [blk]
blocks -> do
          BlockFetchBlockSender blk (Point blk) m ()
-> m (BlockFetchBlockSender blk (Point blk) m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlockFetchBlockSender blk (Point blk) m ()
 -> m (BlockFetchBlockSender blk (Point blk) m ()))
-> BlockFetchBlockSender blk (Point blk) m ()
-> m (BlockFetchBlockSender blk (Point blk) m ())
forall a b. (a -> b) -> a -> b
$ m (BlockFetchSendBlocks blk (Point blk) m ())
-> BlockFetchBlockSender blk (Point blk) m ()
forall (m :: * -> *) block point a.
m (BlockFetchSendBlocks block point m a)
-> BlockFetchBlockSender block point m a
SendMsgStartBatch ([blk] -> m (BlockFetchSendBlocks blk (Point blk) m ())
sendBlocks [blk]
blocks)
        BlockFetch blk
NoBlocks -> do
          TraceScheduledBlockFetchServerEvent state blk -> m ()
trace (TraceScheduledBlockFetchServerEvent state blk -> m ())
-> TraceScheduledBlockFetchServerEvent state blk -> m ()
forall a b. (a -> b) -> a -> b
$ TraceScheduledBlockFetchServerEvent state blk
forall state blk. TraceScheduledBlockFetchServerEvent state blk
TraceNoBlocks
          BlockFetchBlockSender blk (Point blk) m ()
-> m (BlockFetchBlockSender blk (Point blk) m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m (BlockFetchServer blk (Point blk) m ())
-> BlockFetchBlockSender blk (Point blk) m ()
forall (m :: * -> *) block point a.
m (BlockFetchServer block point m a)
-> BlockFetchBlockSender block point m a
SendMsgNoBlocks (BlockFetchServer blk (Point blk) m ()
server BlockFetchServer blk (Point blk) m ()
-> m state -> m (BlockFetchServer blk (Point blk) m ())
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ScheduledServer m state blk -> m state
forall (m :: * -> *) state blk.
IOLike m =>
ScheduledServer m state blk -> m state
awaitOnlineState ScheduledServer m state blk
sbfsServer))

    sendBlocks :: [blk] -> m (BlockFetchSendBlocks blk (Point blk) m ())
sendBlocks [blk]
bs =
      ScheduledServer m state blk
-> String
-> (state
    -> STM
         m
         (Maybe (SendBlocks blk),
          [TraceScheduledBlockFetchServerEvent state blk]))
-> Tracer m (TraceScheduledBlockFetchServerEvent state blk)
-> (SendBlocks blk
    -> m (BlockFetchSendBlocks blk (Point blk) m ()))
-> m (BlockFetchSendBlocks blk (Point 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 state blk
sbfsServer String
"SendBlocks" ([blk]
-> state
-> STM
     m
     (Maybe (SendBlocks blk),
      [TraceScheduledBlockFetchServerEvent state blk])
bfshSendBlocks [blk]
bs) Tracer m (TraceScheduledBlockFetchServerEvent state blk)
sbfsTracer ((SendBlocks blk -> m (BlockFetchSendBlocks blk (Point blk) m ()))
 -> m (BlockFetchSendBlocks blk (Point blk) m ()))
-> (SendBlocks blk
    -> m (BlockFetchSendBlocks blk (Point blk) m ()))
-> m (BlockFetchSendBlocks blk (Point blk) m ())
forall a b. (a -> b) -> a -> b
$ \case
        SendBlock blk
blk [blk]
blks -> BlockFetchSendBlocks blk (Point blk) m ()
-> m (BlockFetchSendBlocks blk (Point blk) m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (blk
-> m (BlockFetchSendBlocks blk (Point blk) m ())
-> BlockFetchSendBlocks blk (Point blk) m ()
forall block (m :: * -> *) point a.
block
-> m (BlockFetchSendBlocks block point m a)
-> BlockFetchSendBlocks block point m a
SendMsgBlock blk
blk ([blk] -> m (BlockFetchSendBlocks blk (Point blk) m ())
sendBlocks [blk]
blks))
        SendBlocks blk
BatchDone -> BlockFetchSendBlocks blk (Point blk) m ()
-> m (BlockFetchSendBlocks blk (Point blk) m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m (BlockFetchServer blk (Point blk) m ())
-> BlockFetchSendBlocks blk (Point blk) m ()
forall (m :: * -> *) block point a.
m (BlockFetchServer block point m a)
-> BlockFetchSendBlocks block point m a
SendMsgBatchDone (BlockFetchServer blk (Point blk) m ()
-> m (BlockFetchServer blk (Point blk) m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BlockFetchServer blk (Point blk) m ()
server))

    trace :: TraceScheduledBlockFetchServerEvent state blk -> m ()
trace = Tracer m (TraceScheduledBlockFetchServerEvent state blk)
-> TraceScheduledBlockFetchServerEvent state blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceScheduledBlockFetchServerEvent state blk)
sbfsTracer

-- | Construct a BlockFetch server for the peer simulator.
--
-- See 'scheduledBlockFetchServer'.
runScheduledBlockFetchServer ::
  IOLike m =>
  PeerId ->
  STM m () ->
  STM m (Maybe (NodeState blk)) ->
  Tracer m (TraceEvent blk) ->
  BlockFetchServerHandlers m (NodeState blk) blk ->
  BlockFetchServer blk (Point blk) m ()
runScheduledBlockFetchServer :: forall (m :: * -> *) blk.
IOLike m =>
PeerId
-> STM m ()
-> STM m (Maybe (NodeState blk))
-> Tracer m (TraceEvent blk)
-> BlockFetchServerHandlers m (NodeState blk) blk
-> BlockFetchServer blk (Point blk) m ()
runScheduledBlockFetchServer PeerId
ssPeerId STM m ()
ssTickStarted STM m (Maybe (NodeState blk))
ssCurrentState Tracer m (TraceEvent blk)
tracer BlockFetchServerHandlers m (NodeState blk) blk
sbfsHandlers =
  ScheduledBlockFetchServer m (NodeState blk) blk
-> BlockFetchServer blk (Point blk) m ()
forall (m :: * -> *) state blk.
IOLike m =>
ScheduledBlockFetchServer m state blk
-> BlockFetchServer blk (Point blk) m ()
scheduledBlockFetchServer ScheduledBlockFetchServer {
    sbfsServer :: ScheduledServer m (NodeState blk) blk
sbfsServer = 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
-> TraceScheduledBlockFetchServerEvent (NodeState blk) blk
-> TraceEvent blk
forall blk.
PeerId
-> TraceScheduledBlockFetchServerEvent (NodeState blk) blk
-> TraceEvent blk
TraceScheduledBlockFetchServerEvent PeerId
ssPeerId (TraceScheduledBlockFetchServerEvent (NodeState blk) blk
 -> TraceEvent blk)
-> (TraceScheduledServerHandlerEvent (NodeState blk) blk
    -> TraceScheduledBlockFetchServerEvent (NodeState blk) blk)
-> TraceScheduledServerHandlerEvent (NodeState blk) blk
-> TraceEvent blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TraceScheduledServerHandlerEvent (NodeState blk) blk
-> TraceScheduledBlockFetchServerEvent (NodeState blk) blk
forall state blk.
TraceScheduledServerHandlerEvent state blk
-> TraceScheduledBlockFetchServerEvent state blk
TraceHandlerEventBF)
    },
    sbfsTracer :: Tracer m (TraceScheduledBlockFetchServerEvent (NodeState blk) blk)
sbfsTracer = (TraceScheduledBlockFetchServerEvent (NodeState blk) blk -> m ())
-> Tracer
     m (TraceScheduledBlockFetchServerEvent (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 ())
-> (TraceScheduledBlockFetchServerEvent (NodeState blk) blk
    -> TraceEvent blk)
-> TraceScheduledBlockFetchServerEvent (NodeState blk) blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerId
-> TraceScheduledBlockFetchServerEvent (NodeState blk) blk
-> TraceEvent blk
forall blk.
PeerId
-> TraceScheduledBlockFetchServerEvent (NodeState blk) blk
-> TraceEvent blk
TraceScheduledBlockFetchServerEvent PeerId
ssPeerId),
    BlockFetchServerHandlers m (NodeState blk) blk
sbfsHandlers :: BlockFetchServerHandlers m (NodeState blk) blk
sbfsHandlers :: BlockFetchServerHandlers m (NodeState blk) blk
sbfsHandlers
  }