{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies      #-}

module Cardano.Protocol.Socket.Mock.Server where

import Cardano.BM.Data.Trace (Trace)
import Cardano.Node.Types (PABServerLogMsg (..))
import Data.ByteString.Lazy qualified as LBS
import Data.List (intersect)
import Data.Maybe (listToMaybe)
import Data.Text (Text)
import Data.Void (Void)

import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Lens hiding (index, ix)
import Control.Monad.Freer (interpret, runM)
import Control.Monad.Freer.State (runState)
import Control.Monad.Reader
import Control.Tracer

import Ouroboros.Network.Protocol.ChainSync.Server (ChainSyncServer (..), ServerStIdle (..), ServerStIntersect (..),
                                                    ServerStNext (..))
import Ouroboros.Network.Protocol.ChainSync.Server qualified as ChainSync
import Ouroboros.Network.Protocol.LocalTxSubmission.Server qualified as TxSubmission
import Ouroboros.Network.Protocol.LocalTxSubmission.Type qualified as TxSubmission
import Plutus.Monitoring.Util qualified as LM

import Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..))
import Ouroboros.Network.Block (Point (..), pointSlot)
import Ouroboros.Network.IOManager
import Ouroboros.Network.Mux
import Ouroboros.Network.NodeToClient (NodeToClientProtocols (..), nodeToClientCodecCBORTerm,
                                       nodeToClientHandshakeCodec, nullErrorPolicies, versionedNodeToClientProtocols)
import Ouroboros.Network.Point qualified as OP (Block (..))
import Ouroboros.Network.Protocol.Handshake.Codec
import Ouroboros.Network.Protocol.Handshake.Version
import Ouroboros.Network.Snocket
import Ouroboros.Network.Socket

import Cardano.Api qualified as C

import Cardano.Protocol.Socket.Type

import Cardano.Chain (MockNodeServerChainState (..), addTxToPool, chainNewestFirst, channel, currentSlot, getChannel,
                      getTip, handleControlChain, tip, txPool)
import Cardano.Node.Emulator.Chain qualified as Chain
import Cardano.Node.Emulator.Params (Params)
import Ledger (Block, CardanoTx (..), Slot (..))

data CommandChannel = CommandChannel
  { CommandChannel -> TQueue ServerCommand
ccCommand  :: TQueue ServerCommand
  , CommandChannel -> TQueue ServerResponse
ccResponse :: TQueue ServerResponse
  }

type Error a = Either Text a

{- | Clone the original channel for each connected client, then use
     this wrapper to make sure that no data is consumed from the
     original channel. -}
newtype LocalChannel = LocalChannel (TChan Block)

{- | A handler used to pass around the path to the server
     and channels used for controlling the server. -}
data ServerHandler = ServerHandler {
    ServerHandler -> FilePath
shSocketPath     :: FilePath,
    -- The client will send a `ServerCommand` and the server will
    -- respond with a `ServerResponse`.
    ServerHandler -> CommandChannel
shCommandChannel :: CommandChannel
}

{- | The commands that control the server. This API is not part of the client
     interface, and in order to call them directly you will need access to the
     returned ServerHandler -}
data ServerCommand =
    -- This command will add a new block by processing
    -- transactions in the memory pool.
    ProcessBlock
    -- Set the slot number
  | ModifySlot (Slot -> Slot)
    -- Append a transaction to the transaction pool.
  | AddTx (C.Tx C.BabbageEra)

instance Show ServerCommand where
    show :: ServerCommand -> FilePath
show = \case
        ServerCommand
ProcessBlock -> FilePath
"ProcessBlock"
        ModifySlot Slot -> Slot
_ -> FilePath
"ModifySlot"
        AddTx Tx BabbageEra
t      -> FilePath
"AddTx " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Tx BabbageEra -> FilePath
forall a. Show a => a -> FilePath
show Tx BabbageEra
t

{- | The response from the server. Can be used for the information
     passed back, or for synchronisation.
-}
data ServerResponse =
    -- A block was added. We are using this for synchronization.
    BlockAdded Block
    | SlotChanged Slot
    deriving Int -> ServerResponse -> ShowS
[ServerResponse] -> ShowS
ServerResponse -> FilePath
(Int -> ServerResponse -> ShowS)
-> (ServerResponse -> FilePath)
-> ([ServerResponse] -> ShowS)
-> Show ServerResponse
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ServerResponse] -> ShowS
$cshowList :: [ServerResponse] -> ShowS
show :: ServerResponse -> FilePath
$cshow :: ServerResponse -> FilePath
showsPrec :: Int -> ServerResponse -> ShowS
$cshowsPrec :: Int -> ServerResponse -> ShowS
Show

processBlock :: MonadIO m => ServerHandler -> m Block
processBlock :: ServerHandler -> m Block
processBlock ServerHandler {CommandChannel
shCommandChannel :: CommandChannel
shCommandChannel :: ServerHandler -> CommandChannel
shCommandChannel} = do
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue ServerCommand -> ServerCommand -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue (CommandChannel -> TQueue ServerCommand
ccCommand CommandChannel
shCommandChannel) ServerCommand
ProcessBlock
    -- Wait for the server to finish processing blocks.
    IO Block -> m Block
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Block -> m Block) -> IO Block -> m Block
forall a b. (a -> b) -> a -> b
$ STM Block -> IO Block
forall a. STM a -> IO a
atomically (STM Block -> IO Block) -> STM Block -> IO Block
forall a b. (a -> b) -> a -> b
$ TQueue ServerResponse -> STM ServerResponse
forall a. TQueue a -> STM a
readTQueue (CommandChannel -> TQueue ServerResponse
ccResponse CommandChannel
shCommandChannel) STM ServerResponse -> (ServerResponse -> STM Block) -> STM Block
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        BlockAdded Block
block -> Block -> STM Block
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block
block
        ServerResponse
_                -> STM Block
forall a. STM a
retry

modifySlot :: MonadIO m => (Slot -> Slot) -> ServerHandler -> m Slot
modifySlot :: (Slot -> Slot) -> ServerHandler -> m Slot
modifySlot Slot -> Slot
f ServerHandler{CommandChannel
shCommandChannel :: CommandChannel
shCommandChannel :: ServerHandler -> CommandChannel
shCommandChannel} = do
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue ServerCommand -> ServerCommand -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue (CommandChannel -> TQueue ServerCommand
ccCommand CommandChannel
shCommandChannel) (ServerCommand -> STM ()) -> ServerCommand -> STM ()
forall a b. (a -> b) -> a -> b
$ (Slot -> Slot) -> ServerCommand
ModifySlot Slot -> Slot
f
    -- Wait for the server to finish changing the slot.
    IO Slot -> m Slot
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Slot -> m Slot) -> IO Slot -> m Slot
forall a b. (a -> b) -> a -> b
$ STM Slot -> IO Slot
forall a. STM a -> IO a
atomically (STM Slot -> IO Slot) -> STM Slot -> IO Slot
forall a b. (a -> b) -> a -> b
$ TQueue ServerResponse -> STM ServerResponse
forall a. TQueue a -> STM a
readTQueue (CommandChannel -> TQueue ServerResponse
ccResponse CommandChannel
shCommandChannel) STM ServerResponse -> (ServerResponse -> STM Slot) -> STM Slot
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        SlotChanged Slot
slot -> Slot -> STM Slot
forall (f :: * -> *) a. Applicative f => a -> f a
pure Slot
slot
        ServerResponse
_                -> STM Slot
forall a. STM a
retry

addTx :: MonadIO m => ServerHandler -> C.Tx C.BabbageEra -> m ()
addTx :: ServerHandler -> Tx BabbageEra -> m ()
addTx ServerHandler { CommandChannel
shCommandChannel :: CommandChannel
shCommandChannel :: ServerHandler -> CommandChannel
shCommandChannel } Tx BabbageEra
tx = do
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue ServerCommand -> ServerCommand -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue (CommandChannel -> TQueue ServerCommand
ccCommand  CommandChannel
shCommandChannel) (ServerCommand -> STM ()) -> ServerCommand -> STM ()
forall a b. (a -> b) -> a -> b
$ Tx BabbageEra -> ServerCommand
AddTx Tx BabbageEra
tx

{- Create a thread that keeps the number of blocks in the channel to the maximum
   limit of K -}
pruneChain :: MonadIO m => Integer -> TChan Block -> m ThreadId
pruneChain :: Integer -> TChan Block -> m ThreadId
pruneChain Integer
k TChan Block
original = do
  TChan Block
localChannel <- IO (TChan Block) -> m (TChan Block)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TChan Block) -> m (TChan Block))
-> IO (TChan Block) -> m (TChan Block)
forall a b. (a -> b) -> a -> b
$ STM (TChan Block) -> IO (TChan Block)
forall a. STM a -> IO a
atomically (STM (TChan Block) -> IO (TChan Block))
-> STM (TChan Block) -> IO (TChan Block)
forall a b. (a -> b) -> a -> b
$ TChan Block -> STM (TChan Block)
forall a. TChan a -> STM (TChan a)
cloneTChan TChan Block
original
  IO ThreadId -> m ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> m ThreadId)
-> (IO () -> IO ThreadId) -> IO () -> m ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO (IO () -> m ThreadId) -> IO () -> m ThreadId
forall a b. (a -> b) -> a -> b
$ Integer -> TChan Block -> IO ()
forall (m :: * -> *). MonadIO m => Integer -> TChan Block -> m ()
go Integer
k TChan Block
localChannel
  where
  go :: MonadIO m => Integer -> TChan Block -> m ()
  go :: Integer -> TChan Block -> m ()
go Integer
k' TChan Block
localChannel = do
    -- Wait for data on the channel
    Block
_ <- IO Block -> m Block
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Block -> m Block) -> IO Block -> m Block
forall a b. (a -> b) -> a -> b
$ STM Block -> IO Block
forall a. STM a -> IO a
atomically (STM Block -> IO Block) -> STM Block -> IO Block
forall a b. (a -> b) -> a -> b
$ TChan Block -> STM Block
forall a. TChan a -> STM a
readTChan TChan Block
localChannel
    if Integer
k' Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0
       {- When the counter reaches zero, there are K blocks in the
          original channel and we start to remove the oldest stored
          block by reading it. -}
       then do
           IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM Block -> IO Block
forall a. STM a -> IO a
atomically (TChan Block -> STM Block
forall a. TChan a -> STM a
readTChan TChan Block
original) IO Block -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Integer -> TChan Block -> IO ()
forall (m :: * -> *). MonadIO m => Integer -> TChan Block -> m ()
go Integer
0 TChan Block
localChannel
       else do
           Integer -> TChan Block -> m ()
forall (m :: * -> *). MonadIO m => Integer -> TChan Block -> m ()
go (Integer
k' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) TChan Block
localChannel

handleCommand ::
    MonadIO m
 => Trace IO PABServerLogMsg
 -> CommandChannel
 -> MVar MockNodeServerChainState
 -> Params
 -> m ()
handleCommand :: Trace IO PABServerLogMsg
-> CommandChannel
-> MVar MockNodeServerChainState
-> Params
-> m ()
handleCommand Trace IO PABServerLogMsg
trace CommandChannel {TQueue ServerCommand
ccCommand :: TQueue ServerCommand
ccCommand :: CommandChannel -> TQueue ServerCommand
ccCommand, TQueue ServerResponse
ccResponse :: TQueue ServerResponse
ccResponse :: CommandChannel -> TQueue ServerResponse
ccResponse} MVar MockNodeServerChainState
mvChainState Params
params =
    IO ServerCommand -> m ServerCommand
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (STM ServerCommand -> IO ServerCommand
forall a. STM a -> IO a
atomically (STM ServerCommand -> IO ServerCommand)
-> STM ServerCommand -> IO ServerCommand
forall a b. (a -> b) -> a -> b
$ TQueue ServerCommand -> STM ServerCommand
forall a. TQueue a -> STM a
readTQueue TQueue ServerCommand
ccCommand) m ServerCommand -> (ServerCommand -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        AddTx Tx BabbageEra
tx     -> do
            IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar MockNodeServerChainState
-> (MockNodeServerChainState -> IO MockNodeServerChainState)
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar MockNodeServerChainState
mvChainState (MockNodeServerChainState -> IO MockNodeServerChainState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MockNodeServerChainState -> IO MockNodeServerChainState)
-> (MockNodeServerChainState -> MockNodeServerChainState)
-> MockNodeServerChainState
-> IO MockNodeServerChainState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter
  MockNodeServerChainState MockNodeServerChainState TxPool TxPool
-> (TxPool -> TxPool)
-> MockNodeServerChainState
-> MockNodeServerChainState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  MockNodeServerChainState MockNodeServerChainState TxPool TxPool
Lens' MockNodeServerChainState TxPool
txPool ((Tx BabbageEra -> CardanoTx
CardanoEmulatorEraTx Tx BabbageEra
tx) CardanoTx -> TxPool -> TxPool
forall a. a -> [a] -> [a]
:))
        ModifySlot Slot -> Slot
f -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            MockNodeServerChainState
state <- IO MockNodeServerChainState -> IO MockNodeServerChainState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO MockNodeServerChainState -> IO MockNodeServerChainState)
-> IO MockNodeServerChainState -> IO MockNodeServerChainState
forall a b. (a -> b) -> a -> b
$ MVar MockNodeServerChainState -> IO MockNodeServerChainState
forall a. MVar a -> IO a
takeMVar MVar MockNodeServerChainState
mvChainState
            (Slot
s, MockNodeServerChainState
nextState') <- IO (Slot, MockNodeServerChainState)
-> IO (Slot, MockNodeServerChainState)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Slot, MockNodeServerChainState)
 -> IO (Slot, MockNodeServerChainState))
-> IO (Slot, MockNodeServerChainState)
-> IO (Slot, MockNodeServerChainState)
forall a b. (a -> b) -> a -> b
$ (Slot -> Slot)
-> Eff
     '[ChainControlEffect, LogMsg ChainEvent,
       State MockNodeServerChainState, IO]
     Slot
forall (effs :: [* -> *]).
Member ChainControlEffect effs =>
(Slot -> Slot) -> Eff effs Slot
Chain.modifySlot Slot -> Slot
f
                  Eff
  '[ChainControlEffect, LogMsg ChainEvent,
    State MockNodeServerChainState, IO]
  Slot
-> (Eff
      '[ChainControlEffect, LogMsg ChainEvent,
        State MockNodeServerChainState, IO]
      Slot
    -> Eff
         '[LogMsg ChainEvent, State MockNodeServerChainState, IO] Slot)
-> Eff
     '[LogMsg ChainEvent, State MockNodeServerChainState, IO] Slot
forall a b. a -> (a -> b) -> b
& (ChainControlEffect
 ~> Eff '[LogMsg ChainEvent, State MockNodeServerChainState, IO])
-> Eff
     '[ChainControlEffect, LogMsg ChainEvent,
       State MockNodeServerChainState, IO]
   ~> Eff '[LogMsg ChainEvent, State MockNodeServerChainState, IO]
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret (Params
-> ChainControlEffect
   ~> Eff '[LogMsg ChainEvent, State MockNodeServerChainState, IO]
forall (effs :: [* -> *]) (m :: * -> *).
(Member (State MockNodeServerChainState) effs,
 Member (LogMsg ChainEvent) effs, LastMember m effs, MonadIO m) =>
Params -> ChainControlEffect ~> Eff effs
handleControlChain Params
params)
                  Eff '[LogMsg ChainEvent, State MockNodeServerChainState, IO] Slot
-> (Eff
      '[LogMsg ChainEvent, State MockNodeServerChainState, IO] Slot
    -> Eff '[State MockNodeServerChainState, IO] Slot)
-> Eff '[State MockNodeServerChainState, IO] Slot
forall a b. a -> (a -> b) -> b
& (LogMsg ChainEvent ~> Eff '[State MockNodeServerChainState, IO])
-> Eff '[LogMsg ChainEvent, State MockNodeServerChainState, IO]
   ~> Eff '[State MockNodeServerChainState, IO]
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret ((ChainEvent -> PABServerLogMsg)
-> Trace IO PABServerLogMsg
-> LogMsg ChainEvent ~> Eff '[State MockNodeServerChainState, IO]
forall b a (m :: * -> *) (effs :: [* -> *]).
(LastMember m effs, MonadIO m) =>
(b -> a) -> Trace m a -> LogMsg b ~> Eff effs
LM.handleLogMsgTraceMap ChainEvent -> PABServerLogMsg
ProcessingChainEvent Trace IO PABServerLogMsg
trace)
                  Eff '[State MockNodeServerChainState, IO] Slot
-> (Eff '[State MockNodeServerChainState, IO] Slot
    -> Eff '[IO] (Slot, MockNodeServerChainState))
-> Eff '[IO] (Slot, MockNodeServerChainState)
forall a b. a -> (a -> b) -> b
& MockNodeServerChainState
-> Eff '[State MockNodeServerChainState, IO] Slot
-> Eff '[IO] (Slot, MockNodeServerChainState)
forall s (effs :: [* -> *]) a.
s -> Eff (State s : effs) a -> Eff effs (a, s)
runState MockNodeServerChainState
state
                  Eff '[IO] (Slot, MockNodeServerChainState)
-> (Eff '[IO] (Slot, MockNodeServerChainState)
    -> IO (Slot, MockNodeServerChainState))
-> IO (Slot, MockNodeServerChainState)
forall a b. a -> (a -> b) -> b
& Eff '[IO] (Slot, MockNodeServerChainState)
-> IO (Slot, MockNodeServerChainState)
forall (m :: * -> *) a. Monad m => Eff '[m] a -> m a
runM
            MVar MockNodeServerChainState -> MockNodeServerChainState -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar MockNodeServerChainState
mvChainState MockNodeServerChainState
nextState'
            STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                TQueue ServerResponse -> ServerResponse -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue ServerResponse
ccResponse (Slot -> ServerResponse
SlotChanged Slot
s)
        ServerCommand
ProcessBlock -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            MockNodeServerChainState
state <- IO MockNodeServerChainState -> IO MockNodeServerChainState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO MockNodeServerChainState -> IO MockNodeServerChainState)
-> IO MockNodeServerChainState -> IO MockNodeServerChainState
forall a b. (a -> b) -> a -> b
$ MVar MockNodeServerChainState -> IO MockNodeServerChainState
forall a. MVar a -> IO a
takeMVar MVar MockNodeServerChainState
mvChainState
            (Block
block, MockNodeServerChainState
nextState') <- IO (Block, MockNodeServerChainState)
-> IO (Block, MockNodeServerChainState)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Block, MockNodeServerChainState)
 -> IO (Block, MockNodeServerChainState))
-> IO (Block, MockNodeServerChainState)
-> IO (Block, MockNodeServerChainState)
forall a b. (a -> b) -> a -> b
$ Eff
  '[ChainControlEffect, LogMsg ChainEvent,
    State MockNodeServerChainState, IO]
  Block
forall (effs :: [* -> *]).
Member ChainControlEffect effs =>
Eff effs Block
Chain.processBlock
                  Eff
  '[ChainControlEffect, LogMsg ChainEvent,
    State MockNodeServerChainState, IO]
  Block
-> (Eff
      '[ChainControlEffect, LogMsg ChainEvent,
        State MockNodeServerChainState, IO]
      Block
    -> Eff
         '[LogMsg ChainEvent, State MockNodeServerChainState, IO] Block)
-> Eff
     '[LogMsg ChainEvent, State MockNodeServerChainState, IO] Block
forall a b. a -> (a -> b) -> b
& (ChainControlEffect
 ~> Eff '[LogMsg ChainEvent, State MockNodeServerChainState, IO])
-> Eff
     '[ChainControlEffect, LogMsg ChainEvent,
       State MockNodeServerChainState, IO]
   ~> Eff '[LogMsg ChainEvent, State MockNodeServerChainState, IO]
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret (Params
-> ChainControlEffect
   ~> Eff '[LogMsg ChainEvent, State MockNodeServerChainState, IO]
forall (effs :: [* -> *]) (m :: * -> *).
(Member (State MockNodeServerChainState) effs,
 Member (LogMsg ChainEvent) effs, LastMember m effs, MonadIO m) =>
Params -> ChainControlEffect ~> Eff effs
handleControlChain Params
params)
                  Eff '[LogMsg ChainEvent, State MockNodeServerChainState, IO] Block
-> (Eff
      '[LogMsg ChainEvent, State MockNodeServerChainState, IO] Block
    -> Eff '[State MockNodeServerChainState, IO] Block)
-> Eff '[State MockNodeServerChainState, IO] Block
forall a b. a -> (a -> b) -> b
& (LogMsg ChainEvent ~> Eff '[State MockNodeServerChainState, IO])
-> Eff '[LogMsg ChainEvent, State MockNodeServerChainState, IO]
   ~> Eff '[State MockNodeServerChainState, IO]
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret ((ChainEvent -> PABServerLogMsg)
-> Trace IO PABServerLogMsg
-> LogMsg ChainEvent ~> Eff '[State MockNodeServerChainState, IO]
forall b a (m :: * -> *) (effs :: [* -> *]).
(LastMember m effs, MonadIO m) =>
(b -> a) -> Trace m a -> LogMsg b ~> Eff effs
LM.handleLogMsgTraceMap ChainEvent -> PABServerLogMsg
ProcessingChainEvent Trace IO PABServerLogMsg
trace)
                  Eff '[State MockNodeServerChainState, IO] Block
-> (Eff '[State MockNodeServerChainState, IO] Block
    -> Eff '[IO] (Block, MockNodeServerChainState))
-> Eff '[IO] (Block, MockNodeServerChainState)
forall a b. a -> (a -> b) -> b
& MockNodeServerChainState
-> Eff '[State MockNodeServerChainState, IO] Block
-> Eff '[IO] (Block, MockNodeServerChainState)
forall s (effs :: [* -> *]) a.
s -> Eff (State s : effs) a -> Eff effs (a, s)
runState MockNodeServerChainState
state
                  Eff '[IO] (Block, MockNodeServerChainState)
-> (Eff '[IO] (Block, MockNodeServerChainState)
    -> IO (Block, MockNodeServerChainState))
-> IO (Block, MockNodeServerChainState)
forall a b. a -> (a -> b) -> b
& Eff '[IO] (Block, MockNodeServerChainState)
-> IO (Block, MockNodeServerChainState)
forall (m :: * -> *) a. Monad m => Eff '[m] a -> m a
runM
            MVar MockNodeServerChainState -> MockNodeServerChainState -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar MockNodeServerChainState
mvChainState MockNodeServerChainState
nextState'
            STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
                TQueue ServerResponse -> ServerResponse -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue ServerResponse
ccResponse (Block -> ServerResponse
BlockAdded Block
block)

{- | Start the server in a new thread, and return a server handler
     used to control the server -}
runServerNode ::
    MonadIO m
 => Trace IO PABServerLogMsg
 -> FilePath
 -> Integer
 -> MockNodeServerChainState
 -> Params
 -> m ServerHandler
runServerNode :: Trace IO PABServerLogMsg
-> FilePath
-> Integer
-> MockNodeServerChainState
-> Params
-> m ServerHandler
runServerNode Trace IO PABServerLogMsg
trace FilePath
shSocketPath Integer
k MockNodeServerChainState
initialState Params
params = IO ServerHandler -> m ServerHandler
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ServerHandler -> m ServerHandler)
-> IO ServerHandler -> m ServerHandler
forall a b. (a -> b) -> a -> b
$ do
    MVar MockNodeServerChainState
serverState      <- MockNodeServerChainState -> IO (MVar MockNodeServerChainState)
forall a. a -> IO (MVar a)
newMVar MockNodeServerChainState
initialState
    CommandChannel
shCommandChannel <- TQueue ServerCommand -> TQueue ServerResponse -> CommandChannel
CommandChannel (TQueue ServerCommand -> TQueue ServerResponse -> CommandChannel)
-> IO (TQueue ServerCommand)
-> IO (TQueue ServerResponse -> CommandChannel)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (TQueue ServerCommand)
forall a. IO (TQueue a)
newTQueueIO IO (TQueue ServerResponse -> CommandChannel)
-> IO (TQueue ServerResponse) -> IO CommandChannel
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (TQueue ServerResponse)
forall a. IO (TQueue a)
newTQueueIO
    TChan Block
globalChannel    <- MVar MockNodeServerChainState -> IO (TChan Block)
forall (m :: * -> *).
MonadIO m =>
MVar MockNodeServerChainState -> m (TChan Block)
getChannel MVar MockNodeServerChainState
serverState
    IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId)
-> (IO Void -> IO ()) -> IO Void -> IO ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Void -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void    (IO Void -> IO ThreadId) -> IO Void -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ FilePath -> MVar MockNodeServerChainState -> IO Void
forall (m :: * -> *).
MonadIO m =>
FilePath -> MVar MockNodeServerChainState -> m Void
protocolLoop        FilePath
shSocketPath     MVar MockNodeServerChainState
serverState
    IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> (IO () -> IO ()) -> IO () -> IO ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Trace IO PABServerLogMsg
-> CommandChannel
-> MVar MockNodeServerChainState
-> Params
-> IO ()
forall (m :: * -> *).
MonadIO m =>
Trace IO PABServerLogMsg
-> CommandChannel
-> MVar MockNodeServerChainState
-> Params
-> m ()
handleCommand Trace IO PABServerLogMsg
trace CommandChannel
shCommandChannel MVar MockNodeServerChainState
serverState Params
params
    IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void                    (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ Integer -> TChan Block -> IO ThreadId
forall (m :: * -> *).
MonadIO m =>
Integer -> TChan Block -> m ThreadId
pruneChain Integer
k TChan Block
globalChannel
    ServerHandler -> IO ServerHandler
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServerHandler -> IO ServerHandler)
-> ServerHandler -> IO ServerHandler
forall a b. (a -> b) -> a -> b
$ ServerHandler :: FilePath -> CommandChannel -> ServerHandler
ServerHandler { FilePath
shSocketPath :: FilePath
shSocketPath :: FilePath
shSocketPath, CommandChannel
shCommandChannel :: CommandChannel
shCommandChannel :: CommandChannel
shCommandChannel }

-- * ChainSync protocol

{- A monad for running all code executed when a state
   transition is invoked. It makes the implementation of
   state transitions easier to read. -}

type ChainSyncMonad = ReaderT (MVar MockNodeServerChainState) IO

runChainSync :: MVar MockNodeServerChainState -> ChainSyncMonad a -> IO a
runChainSync :: MVar MockNodeServerChainState -> ChainSyncMonad a -> IO a
runChainSync = (ChainSyncMonad a -> MVar MockNodeServerChainState -> IO a)
-> MVar MockNodeServerChainState -> ChainSyncMonad a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ChainSyncMonad a -> MVar MockNodeServerChainState -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT

{- The initial state of the protocol. You can move into
   requesting the next block or reset state by searching for an
   intersection. -}
idleState ::
    ( MonadReader (MVar MockNodeServerChainState) m
    , MonadIO m )
 => LocalChannel
 -> m (ServerStIdle Block (Point Block) Tip m ())
idleState :: LocalChannel -> m (ServerStIdle Block (Point Block) Block m ())
idleState LocalChannel
channel' =
    ServerStIdle Block (Point Block) Block m ()
-> m (ServerStIdle Block (Point Block) Block m ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ServerStIdle :: forall header point tip (m :: * -> *) a.
m (Either
     (ServerStNext header point tip m a)
     (m (ServerStNext header point tip m a)))
-> ([point] -> m (ServerStIntersect header point tip m a))
-> m a
-> ServerStIdle header point tip m a
ServerStIdle {
        recvMsgRequestNext :: m (Either
     (ServerStNext Block (Point Block) Block m ())
     (m (ServerStNext Block (Point Block) Block m ())))
recvMsgRequestNext = LocalChannel
-> m (Either
        (ServerStNext Block (Point Block) Block m ())
        (m (ServerStNext Block (Point Block) Block m ())))
forall (m :: * -> *).
(MonadReader (MVar MockNodeServerChainState) m, MonadIO m) =>
LocalChannel
-> m (Either
        (ServerStNext Block (Point Block) Block m ())
        (m (ServerStNext Block (Point Block) Block m ())))
nextState LocalChannel
channel',
        recvMsgFindIntersect :: [Point Block]
-> m (ServerStIntersect Block (Point Block) Block m ())
recvMsgFindIntersect = [Point Block]
-> m (ServerStIntersect Block (Point Block) Block m ())
forall (m :: * -> *).
(MonadReader (MVar MockNodeServerChainState) m, MonadIO m) =>
[Point Block]
-> m (ServerStIntersect Block (Point Block) Block m ())
findIntersect,
        recvMsgDoneClient :: m ()
recvMsgDoneClient = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    }

{- Get the next block, either immediately (the Just/Left branch)
   or within a monad (IO, in our case) where you can wait for the
   next block (Nothing/Right branch) -}
nextState ::
    ( MonadReader (MVar MockNodeServerChainState) m
    , MonadIO m )
 => LocalChannel
 -> m (Either (ServerStNext Block (Point Block) Tip m ())
              (m (ServerStNext Block (Point Block) Tip m ())))
nextState :: LocalChannel
-> m (Either
        (ServerStNext Block (Point Block) Block m ())
        (m (ServerStNext Block (Point Block) Block m ())))
nextState localChannel :: LocalChannel
localChannel@(LocalChannel TChan Block
channel') = do
    MVar MockNodeServerChainState
chainState <- m (MVar MockNodeServerChainState)
forall r (m :: * -> *). MonadReader r m => m r
ask
    Block
tip' <- MVar MockNodeServerChainState -> m Block
forall (m :: * -> *).
MonadIO m =>
MVar MockNodeServerChainState -> m Block
getTip MVar MockNodeServerChainState
chainState
    (IO (Maybe Block) -> m (Maybe Block)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Block) -> m (Maybe Block))
-> (STM (Maybe Block) -> IO (Maybe Block))
-> STM (Maybe Block)
-> m (Maybe Block)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (Maybe Block) -> IO (Maybe Block)
forall a. STM a -> IO a
atomically (STM (Maybe Block) -> m (Maybe Block))
-> STM (Maybe Block) -> m (Maybe Block)
forall a b. (a -> b) -> a -> b
$ TChan Block -> STM (Maybe Block)
forall a. TChan a -> STM (Maybe a)
tryReadTChan TChan Block
channel') m (Maybe Block)
-> (Maybe Block
    -> m (Either
            (ServerStNext Block (Point Block) Block m ())
            (m (ServerStNext Block (Point Block) Block m ()))))
-> m (Either
        (ServerStNext Block (Point Block) Block m ())
        (m (ServerStNext Block (Point Block) Block m ())))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe Block
Nothing -> do
            m (ServerStNext Block (Point Block) Block m ())
-> Either
     (ServerStNext Block (Point Block) Block m ())
     (m (ServerStNext Block (Point Block) Block m ()))
forall a b. b -> Either a b
Right (m (ServerStNext Block (Point Block) Block m ())
 -> Either
      (ServerStNext Block (Point Block) Block m ())
      (m (ServerStNext Block (Point Block) Block m ())))
-> (ServerStNext Block (Point Block) Block m ()
    -> m (ServerStNext Block (Point Block) Block m ()))
-> ServerStNext Block (Point Block) Block m ()
-> Either
     (ServerStNext Block (Point Block) Block m ())
     (m (ServerStNext Block (Point Block) Block m ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerStNext Block (Point Block) Block m ()
-> m (ServerStNext Block (Point Block) Block m ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServerStNext Block (Point Block) Block m ()
 -> Either
      (ServerStNext Block (Point Block) Block m ())
      (m (ServerStNext Block (Point Block) Block m ())))
-> m (ServerStNext Block (Point Block) Block m ())
-> m (Either
        (ServerStNext Block (Point Block) Block m ())
        (m (ServerStNext Block (Point Block) Block m ())))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
                Block
nextBlock <- IO Block -> m Block
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Block -> m Block)
-> (STM Block -> IO Block) -> STM Block -> m Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Block -> IO Block
forall a. STM a -> IO a
atomically (STM Block -> m Block) -> STM Block -> m Block
forall a b. (a -> b) -> a -> b
$ TChan Block -> STM Block
forall a. TChan a -> STM a
readTChan TChan Block
channel'
                IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar MockNodeServerChainState
-> (MockNodeServerChainState -> IO MockNodeServerChainState)
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar MockNodeServerChainState
chainState (MockNodeServerChainState -> IO MockNodeServerChainState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MockNodeServerChainState -> IO MockNodeServerChainState)
-> (MockNodeServerChainState -> MockNodeServerChainState)
-> MockNodeServerChainState
-> IO MockNodeServerChainState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe Block -> Identity (Maybe Block))
-> MockNodeServerChainState -> Identity MockNodeServerChainState
Lens' MockNodeServerChainState (Maybe Block)
tip ((Maybe Block -> Identity (Maybe Block))
 -> MockNodeServerChainState -> Identity MockNodeServerChainState)
-> Block -> MockNodeServerChainState -> MockNodeServerChainState
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Block
nextBlock))
                LocalChannel
-> Block
-> Block
-> m (ServerStNext Block (Point Block) Block m ())
forall (m :: * -> *).
(MonadReader (MVar MockNodeServerChainState) m, MonadIO m) =>
LocalChannel
-> Block
-> Block
-> m (ServerStNext Block (Point Block) Block m ())
sendRollForward LocalChannel
localChannel Block
tip' Block
nextBlock
        Just Block
nextBlock -> do
            IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar MockNodeServerChainState
-> (MockNodeServerChainState -> IO MockNodeServerChainState)
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar MockNodeServerChainState
chainState (MockNodeServerChainState -> IO MockNodeServerChainState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MockNodeServerChainState -> IO MockNodeServerChainState)
-> (MockNodeServerChainState -> MockNodeServerChainState)
-> MockNodeServerChainState
-> IO MockNodeServerChainState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe Block -> Identity (Maybe Block))
-> MockNodeServerChainState -> Identity MockNodeServerChainState
Lens' MockNodeServerChainState (Maybe Block)
tip ((Maybe Block -> Identity (Maybe Block))
 -> MockNodeServerChainState -> Identity MockNodeServerChainState)
-> Block -> MockNodeServerChainState -> MockNodeServerChainState
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Block
nextBlock))
            ServerStNext Block (Point Block) Block m ()
-> Either
     (ServerStNext Block (Point Block) Block m ())
     (m (ServerStNext Block (Point Block) Block m ()))
forall a b. a -> Either a b
Left (ServerStNext Block (Point Block) Block m ()
 -> Either
      (ServerStNext Block (Point Block) Block m ())
      (m (ServerStNext Block (Point Block) Block m ())))
-> m (ServerStNext Block (Point Block) Block m ())
-> m (Either
        (ServerStNext Block (Point Block) Block m ())
        (m (ServerStNext Block (Point Block) Block m ())))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LocalChannel
-> Block
-> Block
-> m (ServerStNext Block (Point Block) Block m ())
forall (m :: * -> *).
(MonadReader (MVar MockNodeServerChainState) m, MonadIO m) =>
LocalChannel
-> Block
-> Block
-> m (ServerStNext Block (Point Block) Block m ())
sendRollForward LocalChannel
localChannel Block
tip' Block
nextBlock

{- This protocol state will search for a block intersection
   with some client provided blocks. When an intersection is found
   the client state is reset to the new offset (the Just branch)
   or to the genesis block if no intersection was found. -}
findIntersect ::
    ( MonadReader (MVar MockNodeServerChainState) m
    , MonadIO m )
 => [Point Block]
 -> m (ServerStIntersect Block (Point Block) Tip m ())
findIntersect :: [Point Block]
-> m (ServerStIntersect Block (Point Block) Block m ())
findIntersect [Point Block]
clientPoints = do
    MVar MockNodeServerChainState
mvState <- m (MVar MockNodeServerChainState)
forall r (m :: * -> *). MonadReader r m => m r
ask
    MockNodeServerChainState
chainState <- IO MockNodeServerChainState -> m MockNodeServerChainState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO MockNodeServerChainState -> m MockNodeServerChainState)
-> IO MockNodeServerChainState -> m MockNodeServerChainState
forall a b. (a -> b) -> a -> b
$ MVar MockNodeServerChainState -> IO MockNodeServerChainState
forall a. MVar a -> IO a
readMVar MVar MockNodeServerChainState
mvState
    [Point Block]
serverPoints <- TChan Block -> MockNodeServerChainState -> m [Point Block]
forall (m :: * -> *).
MonadIO m =>
TChan Block -> MockNodeServerChainState -> m [Point Block]
getChainPoints (Getting (TChan Block) MockNodeServerChainState (TChan Block)
-> MockNodeServerChainState -> TChan Block
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (TChan Block) MockNodeServerChainState (TChan Block)
Lens' MockNodeServerChainState (TChan Block)
channel MockNodeServerChainState
chainState) MockNodeServerChainState
chainState
    let point :: Maybe (Point Block)
point = [Point Block] -> Maybe (Point Block)
forall a. [a] -> Maybe a
listToMaybe
              ([Point Block] -> Maybe (Point Block))
-> [Point Block] -> Maybe (Point Block)
forall a b. (a -> b) -> a -> b
$ [Point Block] -> [Point Block] -> [Point Block]
forall a. Eq a => [a] -> [a] -> [a]
intersect [Point Block]
serverPoints
                          [Point Block]
clientPoints
    Block
tip' <- MVar MockNodeServerChainState -> m Block
forall (m :: * -> *).
MonadIO m =>
MVar MockNodeServerChainState -> m Block
getTip MVar MockNodeServerChainState
mvState
    ServerStIntersect Block (Point Block) Block m ()
-> m (ServerStIntersect Block (Point Block) Block m ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServerStIntersect Block (Point Block) Block m ()
 -> m (ServerStIntersect Block (Point Block) Block m ()))
-> ServerStIntersect Block (Point Block) Block m ()
-> m (ServerStIntersect Block (Point Block) Block m ())
forall a b. (a -> b) -> a -> b
$ case Maybe (Point Block)
point of
        Maybe (Point Block)
Nothing ->
          Block
-> ChainSyncServer Block (Point Block) Block m ()
-> ServerStIntersect Block (Point Block) Block m ()
forall tip header point (m :: * -> *) a.
tip
-> ChainSyncServer header point tip m a
-> ServerStIntersect header point tip m a
SendMsgIntersectNotFound
            Block
tip'
            -- No intersection found. Resume from origin.
            (m (ServerStIdle Block (Point Block) Block m ())
-> ChainSyncServer Block (Point Block) Block m ()
forall header point tip (m :: * -> *) a.
m (ServerStIdle header point tip m a)
-> ChainSyncServer header point tip m a
ChainSyncServer (m (ServerStIdle Block (Point Block) Block m ())
 -> ChainSyncServer Block (Point Block) Block m ())
-> m (ServerStIdle Block (Point Block) Block m ())
-> ChainSyncServer Block (Point Block) Block m ()
forall a b. (a -> b) -> a -> b
$ Integer -> m LocalChannel
forall (m :: * -> *).
(MonadReader (MVar MockNodeServerChainState) m, MonadIO m) =>
Integer -> m LocalChannel
cloneChainFrom Integer
0 m LocalChannel
-> (LocalChannel
    -> m (ServerStIdle Block (Point Block) Block m ()))
-> m (ServerStIdle Block (Point Block) Block m ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LocalChannel -> m (ServerStIdle Block (Point Block) Block m ())
forall (m :: * -> *).
(MonadReader (MVar MockNodeServerChainState) m, MonadIO m) =>
LocalChannel -> m (ServerStIdle Block (Point Block) Block m ())
idleState)
        Just Point Block
point' ->
          Point Block
-> Block
-> ChainSyncServer Block (Point Block) Block m ()
-> ServerStIntersect Block (Point Block) Block m ()
forall point tip header (m :: * -> *) a.
point
-> tip
-> ChainSyncServer header point tip m a
-> ServerStIntersect header point tip m a
SendMsgIntersectFound
            Point Block
point'
            Block
tip'
            -- Resuming from point'.
            (m (ServerStIdle Block (Point Block) Block m ())
-> ChainSyncServer Block (Point Block) Block m ()
forall header point tip (m :: * -> *) a.
m (ServerStIdle header point tip m a)
-> ChainSyncServer header point tip m a
ChainSyncServer (m (ServerStIdle Block (Point Block) Block m ())
 -> ChainSyncServer Block (Point Block) Block m ())
-> m (ServerStIdle Block (Point Block) Block m ())
-> ChainSyncServer Block (Point Block) Block m ()
forall a b. (a -> b) -> a -> b
$ Integer -> m LocalChannel
forall (m :: * -> *).
(MonadReader (MVar MockNodeServerChainState) m, MonadIO m) =>
Integer -> m LocalChannel
cloneChainFrom (Point Block -> Integer
pointOffset Point Block
point') m LocalChannel
-> (LocalChannel
    -> m (ServerStIdle Block (Point Block) Block m ()))
-> m (ServerStIdle Block (Point Block) Block m ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LocalChannel -> m (ServerStIdle Block (Point Block) Block m ())
forall (m :: * -> *).
(MonadReader (MVar MockNodeServerChainState) m, MonadIO m) =>
LocalChannel -> m (ServerStIdle Block (Point Block) Block m ())
idleState)

{- This is a wrapper around the creation of a `ServerStNext` -}
sendRollForward ::
    ( MonadReader (MVar MockNodeServerChainState) m
    , MonadIO m )
 => LocalChannel
 -> Block -- tip
 -> Block -- current
 -> m (ServerStNext Block (Point Block) Tip m ())
sendRollForward :: LocalChannel
-> Block
-> Block
-> m (ServerStNext Block (Point Block) Block m ())
sendRollForward LocalChannel
channel' Block
tip' Block
current = ServerStNext Block (Point Block) Block m ()
-> m (ServerStNext Block (Point Block) Block m ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServerStNext Block (Point Block) Block m ()
 -> m (ServerStNext Block (Point Block) Block m ()))
-> ServerStNext Block (Point Block) Block m ()
-> m (ServerStNext Block (Point Block) Block m ())
forall a b. (a -> b) -> a -> b
$
    Block
-> Block
-> ChainSyncServer Block (Point Block) Block m ()
-> ServerStNext Block (Point Block) Block m ()
forall header tip point (m :: * -> *) a.
header
-> tip
-> ChainSyncServer header point tip m a
-> ServerStNext header point tip m a
SendMsgRollForward
        Block
current
        Block
tip'
        (m (ServerStIdle Block (Point Block) Block m ())
-> ChainSyncServer Block (Point Block) Block m ()
forall header point tip (m :: * -> *) a.
m (ServerStIdle header point tip m a)
-> ChainSyncServer header point tip m a
ChainSyncServer (LocalChannel -> m (ServerStIdle Block (Point Block) Block m ())
forall (m :: * -> *).
(MonadReader (MVar MockNodeServerChainState) m, MonadIO m) =>
LocalChannel -> m (ServerStIdle Block (Point Block) Block m ())
idleState LocalChannel
channel'))

{- This is the state for a new connection. For now we start with
   slot 0, and in idleState. This will probably change, since it
   makes more sense to start in the `StIntersect` state. -}
chainSyncServer ::
    ( MonadReader (MVar MockNodeServerChainState) m
    , MonadIO m )
 => ChainSyncServer Block (Point Block) Tip m ()
chainSyncServer :: ChainSyncServer Block (Point Block) Block m ()
chainSyncServer =
    m (ServerStIdle Block (Point Block) Block m ())
-> ChainSyncServer Block (Point Block) Block m ()
forall header point tip (m :: * -> *) a.
m (ServerStIdle header point tip m a)
-> ChainSyncServer header point tip m a
ChainSyncServer (Integer -> m LocalChannel
forall (m :: * -> *).
(MonadReader (MVar MockNodeServerChainState) m, MonadIO m) =>
Integer -> m LocalChannel
cloneChainFrom Integer
0 m LocalChannel
-> (LocalChannel
    -> m (ServerStIdle Block (Point Block) Block m ()))
-> m (ServerStIdle Block (Point Block) Block m ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LocalChannel -> m (ServerStIdle Block (Point Block) Block m ())
forall (m :: * -> *).
(MonadReader (MVar MockNodeServerChainState) m, MonadIO m) =>
LocalChannel -> m (ServerStIdle Block (Point Block) Block m ())
idleState)

{- Use a `TChan` to model a broadcast channel of which we
   clone (with potentially varying offsets) for clients. -}
cloneChainFrom :: forall m.
    ( MonadReader (MVar MockNodeServerChainState) m
    , MonadIO m )
 => Integer
 -> m LocalChannel
cloneChainFrom :: Integer -> m LocalChannel
cloneChainFrom Integer
offset = TChan Block -> LocalChannel
LocalChannel (TChan Block -> LocalChannel) -> m (TChan Block) -> m LocalChannel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (TChan Block)
go
  where
    go :: m (TChan Block)
    go :: m (TChan Block)
go = do
        TChan Block
globalChannel <- m (MVar MockNodeServerChainState)
forall r (m :: * -> *). MonadReader r m => m r
ask m (MVar MockNodeServerChainState)
-> (MVar MockNodeServerChainState -> m (TChan Block))
-> m (TChan Block)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar MockNodeServerChainState -> m (TChan Block)
forall (m :: * -> *).
MonadIO m =>
MVar MockNodeServerChainState -> m (TChan Block)
getChannel
        IO (TChan Block) -> m (TChan Block)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TChan Block) -> m (TChan Block))
-> IO (TChan Block) -> m (TChan Block)
forall a b. (a -> b) -> a -> b
$ STM (TChan Block) -> IO (TChan Block)
forall a. STM a -> IO a
atomically (STM (TChan Block) -> IO (TChan Block))
-> STM (TChan Block) -> IO (TChan Block)
forall a b. (a -> b) -> a -> b
$ do
            TChan Block
localChannel <- TChan Block -> STM (TChan Block)
forall a. TChan a -> STM (TChan a)
cloneTChan TChan Block
globalChannel
            TChan Block -> Integer -> STM (TChan Block)
forall a. TChan a -> Integer -> STM (TChan a)
consume TChan Block
localChannel Integer
offset

    consume :: TChan a -> Integer -> STM (TChan a)
    consume :: TChan a -> Integer -> STM (TChan a)
consume TChan a
channel' Integer
ix | Integer
ix Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0    = TChan a -> STM (TChan a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure TChan a
channel'
    consume TChan a
channel' Integer
ix =
        -- We should have all requested blocks available on the
        -- channel, for consumption.
        TChan a -> STM (Maybe a)
forall a. TChan a -> STM (Maybe a)
tryReadTChan TChan a
channel' STM (Maybe a) -> STM (TChan a) -> STM (TChan a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TChan a -> Integer -> STM (TChan a)
forall a. TChan a -> Integer -> STM (TChan a)
consume TChan a
channel' (Integer
ix Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)

-- * Protocol setup

{- The node protocols always run in the IO monad. I wanted to use a
   different monad stack (mainly to be able to pass the internal state
   in a `MonadReader` and future proofing) so I wrote some hoisting
   functions for each of the states which transform the `ChainSyncMonad`
   into IO. -}

hoistChainSync ::
    MonadReader (MVar MockNodeServerChainState) m
 => ChainSyncServer Block (Point Block) Tip ChainSyncMonad a
 -> m (ChainSyncServer Block (Point Block) Tip IO a)
hoistChainSync :: ChainSyncServer Block (Point Block) Block ChainSyncMonad a
-> m (ChainSyncServer Block (Point Block) Block IO a)
hoistChainSync ChainSyncServer Block (Point Block) Block ChainSyncMonad a
machine = do
    MVar MockNodeServerChainState
internalState <- m (MVar MockNodeServerChainState)
forall r (m :: * -> *). MonadReader r m => m r
ask
    ChainSyncServer Block (Point Block) Block IO a
-> m (ChainSyncServer Block (Point Block) Block IO a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChainSyncServer :: forall header point tip (m :: * -> *) a.
m (ServerStIdle header point tip m a)
-> ChainSyncServer header point tip m a
ChainSyncServer {
        {- The basic idea is running the reader monad to remove it,
           leaving only IO, which is what we need. We do the same for all
           other states. -}
        runChainSyncServer :: IO (ServerStIdle Block (Point Block) Block IO a)
runChainSyncServer = MVar MockNodeServerChainState
-> ChainSyncMonad (ServerStIdle Block (Point Block) Block IO a)
-> IO (ServerStIdle Block (Point Block) Block IO a)
forall a. MVar MockNodeServerChainState -> ChainSyncMonad a -> IO a
runChainSync MVar MockNodeServerChainState
internalState (ChainSyncMonad (ServerStIdle Block (Point Block) Block IO a)
 -> IO (ServerStIdle Block (Point Block) Block IO a))
-> ChainSyncMonad (ServerStIdle Block (Point Block) Block IO a)
-> IO (ServerStIdle Block (Point Block) Block IO a)
forall a b. (a -> b) -> a -> b
$
            ChainSyncServer Block (Point Block) Block ChainSyncMonad a
-> ChainSyncMonad
     (ServerStIdle Block (Point Block) Block ChainSyncMonad a)
forall header point tip (m :: * -> *) a.
ChainSyncServer header point tip m a
-> m (ServerStIdle header point tip m a)
runChainSyncServer ChainSyncServer Block (Point Block) Block ChainSyncMonad a
machine ChainSyncMonad
  (ServerStIdle Block (Point Block) Block ChainSyncMonad a)
-> (ServerStIdle Block (Point Block) Block ChainSyncMonad a
    -> ChainSyncMonad (ServerStIdle Block (Point Block) Block IO a))
-> ChainSyncMonad (ServerStIdle Block (Point Block) Block IO a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ServerStIdle Block (Point Block) Block ChainSyncMonad a
-> ChainSyncMonad (ServerStIdle Block (Point Block) Block IO a)
forall (m :: * -> *) a.
MonadReader (MVar MockNodeServerChainState) m =>
ServerStIdle Block (Point Block) Block ChainSyncMonad a
-> m (ServerStIdle Block (Point Block) Block IO a)
hoistStIdle
    }

hoistStIdle ::
    MonadReader (MVar MockNodeServerChainState) m
 => ServerStIdle Block (Point Block) Tip ChainSyncMonad a
 -> m (ServerStIdle Block (Point Block) Tip IO a)
hoistStIdle :: ServerStIdle Block (Point Block) Block ChainSyncMonad a
-> m (ServerStIdle Block (Point Block) Block IO a)
hoistStIdle (ServerStIdle ChainSyncMonad
  (Either
     (ServerStNext Block (Point Block) Block ChainSyncMonad a)
     (ChainSyncMonad
        (ServerStNext Block (Point Block) Block ChainSyncMonad a)))
nextState' [Point Block]
-> ChainSyncMonad
     (ServerStIntersect Block (Point Block) Block ChainSyncMonad a)
findIntersect' ChainSyncMonad a
done) = do
    MVar MockNodeServerChainState
internalState <- m (MVar MockNodeServerChainState)
forall r (m :: * -> *). MonadReader r m => m r
ask
    ServerStIdle Block (Point Block) Block IO a
-> m (ServerStIdle Block (Point Block) Block IO a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ServerStIdle :: forall header point tip (m :: * -> *) a.
m (Either
     (ServerStNext header point tip m a)
     (m (ServerStNext header point tip m a)))
-> ([point] -> m (ServerStIntersect header point tip m a))
-> m a
-> ServerStIdle header point tip m a
ServerStIdle {
        recvMsgRequestNext :: IO
  (Either
     (ServerStNext Block (Point Block) Block IO a)
     (IO (ServerStNext Block (Point Block) Block IO a)))
recvMsgRequestNext =
            MVar MockNodeServerChainState
-> ChainSyncMonad
     (Either
        (ServerStNext Block (Point Block) Block IO a)
        (IO (ServerStNext Block (Point Block) Block IO a)))
-> IO
     (Either
        (ServerStNext Block (Point Block) Block IO a)
        (IO (ServerStNext Block (Point Block) Block IO a)))
forall a. MVar MockNodeServerChainState -> ChainSyncMonad a -> IO a
runChainSync MVar MockNodeServerChainState
internalState (ChainSyncMonad
   (Either
      (ServerStNext Block (Point Block) Block IO a)
      (IO (ServerStNext Block (Point Block) Block IO a)))
 -> IO
      (Either
         (ServerStNext Block (Point Block) Block IO a)
         (IO (ServerStNext Block (Point Block) Block IO a))))
-> ChainSyncMonad
     (Either
        (ServerStNext Block (Point Block) Block IO a)
        (IO (ServerStNext Block (Point Block) Block IO a)))
-> IO
     (Either
        (ServerStNext Block (Point Block) Block IO a)
        (IO (ServerStNext Block (Point Block) Block IO a)))
forall a b. (a -> b) -> a -> b
$
                ChainSyncMonad
  (Either
     (ServerStNext Block (Point Block) Block ChainSyncMonad a)
     (ChainSyncMonad
        (ServerStNext Block (Point Block) Block ChainSyncMonad a)))
nextState' ChainSyncMonad
  (Either
     (ServerStNext Block (Point Block) Block ChainSyncMonad a)
     (ChainSyncMonad
        (ServerStNext Block (Point Block) Block ChainSyncMonad a)))
-> (Either
      (ServerStNext Block (Point Block) Block ChainSyncMonad a)
      (ChainSyncMonad
         (ServerStNext Block (Point Block) Block ChainSyncMonad a))
    -> ChainSyncMonad
         (Either
            (ServerStNext Block (Point Block) Block IO a)
            (IO (ServerStNext Block (Point Block) Block IO a))))
-> ChainSyncMonad
     (Either
        (ServerStNext Block (Point Block) Block IO a)
        (IO (ServerStNext Block (Point Block) Block IO a)))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Left ServerStNext Block (Point Block) Block ChainSyncMonad a
stNext -> ServerStNext Block (Point Block) Block IO a
-> Either
     (ServerStNext Block (Point Block) Block IO a)
     (IO (ServerStNext Block (Point Block) Block IO a))
forall a b. a -> Either a b
Left         (ServerStNext Block (Point Block) Block IO a
 -> Either
      (ServerStNext Block (Point Block) Block IO a)
      (IO (ServerStNext Block (Point Block) Block IO a)))
-> ReaderT
     (MVar MockNodeServerChainState)
     IO
     (ServerStNext Block (Point Block) Block IO a)
-> ChainSyncMonad
     (Either
        (ServerStNext Block (Point Block) Block IO a)
        (IO (ServerStNext Block (Point Block) Block IO a)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>  ServerStNext Block (Point Block) Block ChainSyncMonad a
-> ReaderT
     (MVar MockNodeServerChainState)
     IO
     (ServerStNext Block (Point Block) Block IO a)
forall (m :: * -> *) a.
MonadReader (MVar MockNodeServerChainState) m =>
ServerStNext Block (Point Block) Block ChainSyncMonad a
-> m (ServerStNext Block (Point Block) Block IO a)
hoistStNext     ServerStNext Block (Point Block) Block ChainSyncMonad a
stNext
                    Right ChainSyncMonad
  (ServerStNext Block (Point Block) Block ChainSyncMonad a)
mNext -> IO (ServerStNext Block (Point Block) Block IO a)
-> Either
     (ServerStNext Block (Point Block) Block IO a)
     (IO (ServerStNext Block (Point Block) Block IO a))
forall a b. b -> Either a b
Right (IO (ServerStNext Block (Point Block) Block IO a)
 -> Either
      (ServerStNext Block (Point Block) Block IO a)
      (IO (ServerStNext Block (Point Block) Block IO a)))
-> (ServerStNext Block (Point Block) Block IO a
    -> IO (ServerStNext Block (Point Block) Block IO a))
-> ServerStNext Block (Point Block) Block IO a
-> Either
     (ServerStNext Block (Point Block) Block IO a)
     (IO (ServerStNext Block (Point Block) Block IO a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerStNext Block (Point Block) Block IO a
-> IO (ServerStNext Block (Point Block) Block IO a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServerStNext Block (Point Block) Block IO a
 -> Either
      (ServerStNext Block (Point Block) Block IO a)
      (IO (ServerStNext Block (Point Block) Block IO a)))
-> ReaderT
     (MVar MockNodeServerChainState)
     IO
     (ServerStNext Block (Point Block) Block IO a)
-> ChainSyncMonad
     (Either
        (ServerStNext Block (Point Block) Block IO a)
        (IO (ServerStNext Block (Point Block) Block IO a)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ServerStNext Block (Point Block) Block ChainSyncMonad a
-> ReaderT
     (MVar MockNodeServerChainState)
     IO
     (ServerStNext Block (Point Block) Block IO a)
forall (m :: * -> *) a.
MonadReader (MVar MockNodeServerChainState) m =>
ServerStNext Block (Point Block) Block ChainSyncMonad a
-> m (ServerStNext Block (Point Block) Block IO a)
hoistStNext (ServerStNext Block (Point Block) Block ChainSyncMonad a
 -> ReaderT
      (MVar MockNodeServerChainState)
      IO
      (ServerStNext Block (Point Block) Block IO a))
-> ChainSyncMonad
     (ServerStNext Block (Point Block) Block ChainSyncMonad a)
-> ReaderT
     (MVar MockNodeServerChainState)
     IO
     (ServerStNext Block (Point Block) Block IO a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ChainSyncMonad
  (ServerStNext Block (Point Block) Block ChainSyncMonad a)
mNext ),
        recvMsgFindIntersect :: [Point Block]
-> IO (ServerStIntersect Block (Point Block) Block IO a)
recvMsgFindIntersect = \[Point Block]
points ->
            MVar MockNodeServerChainState
-> ChainSyncMonad
     (ServerStIntersect Block (Point Block) Block IO a)
-> IO (ServerStIntersect Block (Point Block) Block IO a)
forall a. MVar MockNodeServerChainState -> ChainSyncMonad a -> IO a
runChainSync MVar MockNodeServerChainState
internalState
                         ([Point Block]
-> ChainSyncMonad
     (ServerStIntersect Block (Point Block) Block ChainSyncMonad a)
findIntersect' [Point Block]
points ChainSyncMonad
  (ServerStIntersect Block (Point Block) Block ChainSyncMonad a)
-> (ServerStIntersect Block (Point Block) Block ChainSyncMonad a
    -> ChainSyncMonad
         (ServerStIntersect Block (Point Block) Block IO a))
-> ChainSyncMonad
     (ServerStIntersect Block (Point Block) Block IO a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ServerStIntersect Block (Point Block) Block ChainSyncMonad a
-> ChainSyncMonad
     (ServerStIntersect Block (Point Block) Block IO a)
forall (m :: * -> *) a.
MonadReader (MVar MockNodeServerChainState) m =>
ServerStIntersect Block (Point Block) Block ChainSyncMonad a
-> m (ServerStIntersect Block (Point Block) Block IO a)
hoistStIntersect),
        recvMsgDoneClient :: IO a
recvMsgDoneClient    = MVar MockNodeServerChainState -> ChainSyncMonad a -> IO a
forall a. MVar MockNodeServerChainState -> ChainSyncMonad a -> IO a
runChainSync MVar MockNodeServerChainState
internalState ChainSyncMonad a
done
   }

hoistStIntersect ::
    MonadReader (MVar MockNodeServerChainState) m
 => ServerStIntersect Block (Point Block) Tip ChainSyncMonad a
 -> m (ServerStIntersect Block (Point Block) Tip IO a)
hoistStIntersect :: ServerStIntersect Block (Point Block) Block ChainSyncMonad a
-> m (ServerStIntersect Block (Point Block) Block IO a)
hoistStIntersect (SendMsgIntersectFound Point Block
point Block
tip' ChainSyncServer Block (Point Block) Block ChainSyncMonad a
nextState') =
    Point Block
-> Block
-> ChainSyncServer Block (Point Block) Block IO a
-> ServerStIntersect Block (Point Block) Block IO a
forall point tip header (m :: * -> *) a.
point
-> tip
-> ChainSyncServer header point tip m a
-> ServerStIntersect header point tip m a
SendMsgIntersectFound Point Block
point Block
tip' (ChainSyncServer Block (Point Block) Block IO a
 -> ServerStIntersect Block (Point Block) Block IO a)
-> m (ChainSyncServer Block (Point Block) Block IO a)
-> m (ServerStIntersect Block (Point Block) Block IO a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainSyncServer Block (Point Block) Block ChainSyncMonad a
-> m (ChainSyncServer Block (Point Block) Block IO a)
forall (m :: * -> *) a.
MonadReader (MVar MockNodeServerChainState) m =>
ChainSyncServer Block (Point Block) Block ChainSyncMonad a
-> m (ChainSyncServer Block (Point Block) Block IO a)
hoistChainSync ChainSyncServer Block (Point Block) Block ChainSyncMonad a
nextState'
hoistStIntersect (SendMsgIntersectNotFound Block
tip' ChainSyncServer Block (Point Block) Block ChainSyncMonad a
nextState') =
    Block
-> ChainSyncServer Block (Point Block) Block IO a
-> ServerStIntersect Block (Point Block) Block IO a
forall tip header point (m :: * -> *) a.
tip
-> ChainSyncServer header point tip m a
-> ServerStIntersect header point tip m a
SendMsgIntersectNotFound Block
tip'    (ChainSyncServer Block (Point Block) Block IO a
 -> ServerStIntersect Block (Point Block) Block IO a)
-> m (ChainSyncServer Block (Point Block) Block IO a)
-> m (ServerStIntersect Block (Point Block) Block IO a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainSyncServer Block (Point Block) Block ChainSyncMonad a
-> m (ChainSyncServer Block (Point Block) Block IO a)
forall (m :: * -> *) a.
MonadReader (MVar MockNodeServerChainState) m =>
ChainSyncServer Block (Point Block) Block ChainSyncMonad a
-> m (ChainSyncServer Block (Point Block) Block IO a)
hoistChainSync ChainSyncServer Block (Point Block) Block ChainSyncMonad a
nextState'

hoistStNext ::
    MonadReader (MVar MockNodeServerChainState) m
 => ServerStNext Block (Point Block) Tip ChainSyncMonad a
 -> m (ServerStNext Block (Point Block) Tip IO a)
hoistStNext :: ServerStNext Block (Point Block) Block ChainSyncMonad a
-> m (ServerStNext Block (Point Block) Block IO a)
hoistStNext (SendMsgRollForward Block
header Block
tip' ChainSyncServer Block (Point Block) Block ChainSyncMonad a
nextState') =
    Block
-> Block
-> ChainSyncServer Block (Point Block) Block IO a
-> ServerStNext Block (Point Block) Block IO a
forall header tip point (m :: * -> *) a.
header
-> tip
-> ChainSyncServer header point tip m a
-> ServerStNext header point tip m a
SendMsgRollForward Block
header Block
tip' (ChainSyncServer Block (Point Block) Block IO a
 -> ServerStNext Block (Point Block) Block IO a)
-> m (ChainSyncServer Block (Point Block) Block IO a)
-> m (ServerStNext Block (Point Block) Block IO a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainSyncServer Block (Point Block) Block ChainSyncMonad a
-> m (ChainSyncServer Block (Point Block) Block IO a)
forall (m :: * -> *) a.
MonadReader (MVar MockNodeServerChainState) m =>
ChainSyncServer Block (Point Block) Block ChainSyncMonad a
-> m (ChainSyncServer Block (Point Block) Block IO a)
hoistChainSync ChainSyncServer Block (Point Block) Block ChainSyncMonad a
nextState'
hoistStNext (SendMsgRollBackward Point Block
header Block
tip' ChainSyncServer Block (Point Block) Block ChainSyncMonad a
nextState') =
    Point Block
-> Block
-> ChainSyncServer Block (Point Block) Block IO a
-> ServerStNext Block (Point Block) Block IO a
forall point tip header (m :: * -> *) a.
point
-> tip
-> ChainSyncServer header point tip m a
-> ServerStNext header point tip m a
SendMsgRollBackward Point Block
header Block
tip' (ChainSyncServer Block (Point Block) Block IO a
 -> ServerStNext Block (Point Block) Block IO a)
-> m (ChainSyncServer Block (Point Block) Block IO a)
-> m (ServerStNext Block (Point Block) Block IO a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainSyncServer Block (Point Block) Block ChainSyncMonad a
-> m (ChainSyncServer Block (Point Block) Block IO a)
forall (m :: * -> *) a.
MonadReader (MVar MockNodeServerChainState) m =>
ChainSyncServer Block (Point Block) Block ChainSyncMonad a
-> m (ChainSyncServer Block (Point Block) Block IO a)
hoistChainSync ChainSyncServer Block (Point Block) Block ChainSyncMonad a
nextState'

{- This is boilerplate code that sets up the node protocols,
   you can find in:
     ouroboros-network/ouroboros-network/demo/chain-sync.hs -}

protocolLoop ::
    MonadIO m
 => FilePath
 -> MVar MockNodeServerChainState
 -> m Void
protocolLoop :: FilePath -> MVar MockNodeServerChainState -> m Void
protocolLoop FilePath
socketPath MVar MockNodeServerChainState
internalState = IO Void -> m Void
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Void -> m Void) -> IO Void -> m Void
forall a b. (a -> b) -> a -> b
$ (IOManager -> IO Void) -> IO Void
WithIOManager
withIOManager ((IOManager -> IO Void) -> IO Void)
-> (IOManager -> IO Void) -> IO Void
forall a b. (a -> b) -> a -> b
$ \IOManager
iocp -> do
    NetworkMutableState LocalAddress
networkState <- IO (NetworkMutableState LocalAddress)
forall addr. IO (NetworkMutableState addr)
newNetworkMutableState
    Async ()
_ <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ NetworkMutableState LocalAddress -> IO ()
forall addr. NetworkMutableState addr -> IO ()
cleanNetworkMutableState NetworkMutableState LocalAddress
networkState
    Snocket IO LocalSocket LocalAddress
-> NetworkServerTracers LocalAddress NodeToClientVersion
-> NetworkMutableState LocalAddress
-> AcceptedConnectionsLimit
-> LocalAddress
-> Codec
     (Handshake NodeToClientVersion Term)
     DeserialiseFailure
     IO
     ByteString
-> ProtocolTimeLimits (Handshake NodeToClientVersion Term)
-> VersionDataCodec
     Term NodeToClientVersion NodeToClientVersionData
-> (NodeToClientVersionData
    -> NodeToClientVersionData -> Accept NodeToClientVersionData)
-> Versions
     NodeToClientVersion
     NodeToClientVersionData
     (SomeResponderApplication LocalAddress ByteString IO ())
-> ErrorPolicies
-> (LocalAddress -> Async Void -> IO Void)
-> IO Void
forall vNumber vData t fd addr b.
(Ord vNumber, Typeable vNumber, Show vNumber, Ord addr) =>
Snocket IO fd addr
-> NetworkServerTracers addr vNumber
-> NetworkMutableState addr
-> AcceptedConnectionsLimit
-> addr
-> Codec (Handshake vNumber Term) DeserialiseFailure IO ByteString
-> ProtocolTimeLimits (Handshake vNumber Term)
-> VersionDataCodec Term vNumber vData
-> (vData -> vData -> Accept vData)
-> Versions
     vNumber vData (SomeResponderApplication addr ByteString IO b)
-> ErrorPolicies
-> (addr -> Async Void -> IO t)
-> IO t
withServerNode
      (IOManager -> Snocket IO LocalSocket LocalAddress
localSnocket IOManager
iocp)
      NetworkServerTracers LocalAddress NodeToClientVersion
forall addr vNumber. NetworkServerTracers addr vNumber
nullNetworkServerTracers
      NetworkMutableState LocalAddress
networkState
      (Word32 -> Word32 -> DiffTime -> AcceptedConnectionsLimit
AcceptedConnectionsLimit Word32
forall a. Bounded a => a
maxBound Word32
forall a. Bounded a => a
maxBound DiffTime
0)
      (FilePath -> LocalAddress
localAddressFromPath FilePath
socketPath)
      Codec
  (Handshake NodeToClientVersion Term)
  DeserialiseFailure
  IO
  ByteString
forall (m :: * -> *).
MonadST m =>
Codec
  (Handshake NodeToClientVersion Term)
  DeserialiseFailure
  m
  ByteString
nodeToClientHandshakeCodec
      ProtocolTimeLimits (Handshake NodeToClientVersion Term)
forall k (vNumber :: k).
ProtocolTimeLimits (Handshake vNumber Term)
noTimeLimitsHandshake
      ((NodeToClientVersion -> CodecCBORTerm Text NodeToClientVersionData)
-> VersionDataCodec
     Term NodeToClientVersion NodeToClientVersionData
forall vNumber vData.
(vNumber -> CodecCBORTerm Text vData)
-> VersionDataCodec Term vNumber vData
cborTermVersionDataCodec NodeToClientVersion -> CodecCBORTerm Text NodeToClientVersionData
nodeToClientCodecCBORTerm)
      NodeToClientVersionData
-> NodeToClientVersionData -> Accept NodeToClientVersionData
forall v. Acceptable v => v -> v -> Accept v
acceptableVersion
      (OuroborosApplication
  'ResponderMode LocalAddress ByteString IO Void ()
-> SomeResponderApplication LocalAddress ByteString IO ()
forall (appType :: MuxMode) addr bytes (m :: * -> *) a b.
(HasResponder appType ~ 'True) =>
OuroborosApplication appType addr bytes m a b
-> SomeResponderApplication addr bytes m b
SomeResponderApplication (OuroborosApplication
   'ResponderMode LocalAddress ByteString IO Void ()
 -> SomeResponderApplication LocalAddress ByteString IO ())
-> Versions
     NodeToClientVersion
     NodeToClientVersionData
     (OuroborosApplication
        'ResponderMode LocalAddress ByteString IO Void ())
-> Versions
     NodeToClientVersion
     NodeToClientVersionData
     (SomeResponderApplication LocalAddress ByteString IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        NodeToClientVersion
-> NodeToClientVersionData
-> (ConnectionId LocalAddress
    -> STM IO ControlMessage
    -> NodeToClientProtocols 'ResponderMode ByteString IO Void ())
-> Versions
     NodeToClientVersion
     NodeToClientVersionData
     (OuroborosApplication
        'ResponderMode LocalAddress ByteString IO Void ())
forall (m :: * -> *) (appType :: MuxMode) bytes a b.
NodeToClientVersion
-> NodeToClientVersionData
-> (ConnectionId LocalAddress
    -> STM m ControlMessage
    -> NodeToClientProtocols appType bytes m a b)
-> Versions
     NodeToClientVersion
     NodeToClientVersionData
     (OuroborosApplication appType LocalAddress bytes m a b)
versionedNodeToClientProtocols
          NodeToClientVersion
nodeToClientVersion
          NodeToClientVersionData
nodeToClientVersionData
          (\ConnectionId LocalAddress
_ STM IO ControlMessage
_ -> MVar MockNodeServerChainState
-> NodeToClientProtocols 'ResponderMode ByteString IO Void ()
nodeToClientProtocols MVar MockNodeServerChainState
internalState))
      ErrorPolicies
nullErrorPolicies
      ((LocalAddress -> Async Void -> IO Void) -> IO Void)
-> (LocalAddress -> Async Void -> IO Void) -> IO Void
forall a b. (a -> b) -> a -> b
$ \LocalAddress
_ Async Void
serverAsync -> Async Void -> IO Void
forall a. Async a -> IO a
wait Async Void
serverAsync

nodeToClientProtocols
  :: MVar MockNodeServerChainState
  -> NodeToClientProtocols 'ResponderMode LBS.ByteString IO Void ()
nodeToClientProtocols :: MVar MockNodeServerChainState
-> NodeToClientProtocols 'ResponderMode ByteString IO Void ()
nodeToClientProtocols MVar MockNodeServerChainState
internalState =
  NodeToClientProtocols :: forall (appType :: MuxMode) bytes (m :: * -> *) a b.
RunMiniProtocol appType bytes m a b
-> RunMiniProtocol appType bytes m a b
-> RunMiniProtocol appType bytes m a b
-> RunMiniProtocol appType bytes m a b
-> NodeToClientProtocols appType bytes m a b
NodeToClientProtocols
    { localChainSyncProtocol :: RunMiniProtocol 'ResponderMode ByteString IO Void ()
localChainSyncProtocol = MVar MockNodeServerChainState
-> RunMiniProtocol 'ResponderMode ByteString IO Void ()
chainSync MVar MockNodeServerChainState
internalState
    , localTxSubmissionProtocol :: RunMiniProtocol 'ResponderMode ByteString IO Void ()
localTxSubmissionProtocol = MVar MockNodeServerChainState
-> RunMiniProtocol 'ResponderMode ByteString IO Void ()
txSubmission MVar MockNodeServerChainState
internalState
    , localStateQueryProtocol :: RunMiniProtocol 'ResponderMode ByteString IO Void ()
localStateQueryProtocol = RunMiniProtocol 'ResponderMode ByteString IO Void ()
forall (m :: * -> *) a.
MonadTimer m =>
RunMiniProtocol 'ResponderMode ByteString m Void a
doNothingResponderProtocol
    , localTxMonitorProtocol :: RunMiniProtocol 'ResponderMode ByteString IO Void ()
localTxMonitorProtocol = RunMiniProtocol 'ResponderMode ByteString IO Void ()
forall (m :: * -> *) a.
MonadTimer m =>
RunMiniProtocol 'ResponderMode ByteString m Void a
doNothingResponderProtocol
    }

chainSync
  :: MVar MockNodeServerChainState
  -> RunMiniProtocol 'ResponderMode LBS.ByteString IO Void ()
chainSync :: MVar MockNodeServerChainState
-> RunMiniProtocol 'ResponderMode ByteString IO Void ()
chainSync MVar MockNodeServerChainState
mvChainState =
     MuxPeer ByteString IO ()
-> RunMiniProtocol 'ResponderMode ByteString IO Void ()
forall bytes (m :: * -> *) b.
MuxPeer bytes m b -> RunMiniProtocol 'ResponderMode bytes m Void b
ResponderProtocolOnly (MuxPeer ByteString IO ()
 -> RunMiniProtocol 'ResponderMode ByteString IO Void ())
-> MuxPeer ByteString IO ()
-> RunMiniProtocol 'ResponderMode ByteString IO Void ()
forall a b. (a -> b) -> a -> b
$
     Tracer IO (TraceSendRecv (ChainSync Block (Point Block) Block))
-> Codec
     (ChainSync Block (Point Block) Block)
     DeserialiseFailure
     IO
     ByteString
-> Peer
     (ChainSync Block (Point Block) Block) 'AsServer 'StIdle IO ()
-> MuxPeer ByteString IO ()
forall (pr :: PeerRole) ps (st :: ps) failure bytes (m :: * -> *)
       a.
(Show failure, forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Peer ps pr st m a
-> MuxPeer bytes m a
MuxPeer
       Tracer IO (TraceSendRecv (ChainSync Block (Point Block) Block))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
       Codec
  (ChainSync Block (Point Block) Block)
  DeserialiseFailure
  IO
  ByteString
forall block.
(Serialise block, Serialise (HeaderHash block)) =>
Codec
  (ChainSync block (Point block) Block)
  DeserialiseFailure
  IO
  ByteString
chainSyncCodec
       (ChainSyncServer Block (Point Block) Block IO ()
-> Peer
     (ChainSync Block (Point Block) Block) 'AsServer 'StIdle IO ()
forall header point tip (m :: * -> *) a.
Monad m =>
ChainSyncServer header point tip m a
-> Peer (ChainSync header point tip) 'AsServer 'StIdle m a
ChainSync.chainSyncServerPeer
           (Reader
  (MVar MockNodeServerChainState)
  (ChainSyncServer Block (Point Block) Block IO ())
-> MVar MockNodeServerChainState
-> ChainSyncServer Block (Point Block) Block IO ()
forall r a. Reader r a -> r -> a
runReader (ChainSyncServer Block (Point Block) Block ChainSyncMonad ()
-> Reader
     (MVar MockNodeServerChainState)
     (ChainSyncServer Block (Point Block) Block IO ())
forall (m :: * -> *) a.
MonadReader (MVar MockNodeServerChainState) m =>
ChainSyncServer Block (Point Block) Block ChainSyncMonad a
-> m (ChainSyncServer Block (Point Block) Block IO a)
hoistChainSync ChainSyncServer Block (Point Block) Block ChainSyncMonad ()
forall (m :: * -> *).
(MonadReader (MVar MockNodeServerChainState) m, MonadIO m) =>
ChainSyncServer Block (Point Block) Block m ()
chainSyncServer)
                      MVar MockNodeServerChainState
mvChainState))

txSubmission
  :: MVar MockNodeServerChainState
  -> RunMiniProtocol 'ResponderMode LBS.ByteString IO Void ()
txSubmission :: MVar MockNodeServerChainState
-> RunMiniProtocol 'ResponderMode ByteString IO Void ()
txSubmission MVar MockNodeServerChainState
mvChainState =
    MuxPeer ByteString IO ()
-> RunMiniProtocol 'ResponderMode ByteString IO Void ()
forall bytes (m :: * -> *) b.
MuxPeer bytes m b -> RunMiniProtocol 'ResponderMode bytes m Void b
ResponderProtocolOnly (MuxPeer ByteString IO ()
 -> RunMiniProtocol 'ResponderMode ByteString IO Void ())
-> MuxPeer ByteString IO ()
-> RunMiniProtocol 'ResponderMode ByteString IO Void ()
forall a b. (a -> b) -> a -> b
$
    Tracer
  IO (TraceSendRecv (LocalTxSubmission (Tx BabbageEra) FilePath))
-> Codec
     (LocalTxSubmission (Tx BabbageEra) FilePath)
     DeserialiseFailure
     IO
     ByteString
-> Peer
     (LocalTxSubmission (Tx BabbageEra) FilePath)
     'AsServer
     'StIdle
     IO
     ()
-> MuxPeer ByteString IO ()
forall (pr :: PeerRole) ps (st :: ps) failure bytes (m :: * -> *)
       a.
(Show failure, forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Peer ps pr st m a
-> MuxPeer bytes m a
MuxPeer
      Tracer
  IO (TraceSendRecv (LocalTxSubmission (Tx BabbageEra) FilePath))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      Codec
  (LocalTxSubmission (Tx BabbageEra) FilePath)
  DeserialiseFailure
  IO
  ByteString
txSubmissionCodec
      (IO (LocalTxSubmissionServer (Tx BabbageEra) FilePath IO ())
-> Peer
     (LocalTxSubmission (Tx BabbageEra) FilePath)
     'AsServer
     'StIdle
     IO
     ()
forall tx reject (m :: * -> *) a.
Monad m =>
m (LocalTxSubmissionServer tx reject m a)
-> Peer (LocalTxSubmission tx reject) 'AsServer 'StIdle m a
TxSubmission.localTxSubmissionServerPeer
          (LocalTxSubmissionServer (Tx BabbageEra) FilePath IO ()
-> IO (LocalTxSubmissionServer (Tx BabbageEra) FilePath IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocalTxSubmissionServer (Tx BabbageEra) FilePath IO ()
 -> IO (LocalTxSubmissionServer (Tx BabbageEra) FilePath IO ()))
-> LocalTxSubmissionServer (Tx BabbageEra) FilePath IO ()
-> IO (LocalTxSubmissionServer (Tx BabbageEra) FilePath IO ())
forall a b. (a -> b) -> a -> b
$ MVar MockNodeServerChainState
-> LocalTxSubmissionServer (Tx BabbageEra) FilePath IO ()
txSubmissionServer MVar MockNodeServerChainState
mvChainState))

-- * Computing intersections

-- Given a `Point` find its offset into the chain.
pointOffset :: Point Block
            -> Integer
pointOffset :: Point Block -> Integer
pointOffset Point Block
pt =
  case Point Block -> WithOrigin SlotNo
forall block. Point block -> WithOrigin SlotNo
pointSlot Point Block
pt of
    WithOrigin SlotNo
Origin        -> Integer
0
    At (SlotNo Word64
s) -> Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
s

-- Currently selects all points from the blockchain.
getChainPoints :: MonadIO m => TChan Block -> MockNodeServerChainState -> m [Point Block]
getChainPoints :: TChan Block -> MockNodeServerChainState -> m [Point Block]
getChainPoints TChan Block
ch MockNodeServerChainState
st = do
  [Block]
chain <- TChan Block -> m [Block]
forall (m :: * -> *). MonadIO m => TChan Block -> m [Block]
chainNewestFirst TChan Block
ch
  [Point Block] -> m [Point Block]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Point Block] -> m [Point Block])
-> [Point Block] -> m [Point Block]
forall a b. (a -> b) -> a -> b
$ (Slot -> Block -> Point Block)
-> [Slot] -> [Block] -> [Point Block]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Slot -> Block -> Point Block
mkPoint
    [(MockNodeServerChainState
st MockNodeServerChainState
-> Getting Slot MockNodeServerChainState Slot -> Slot
forall s a. s -> Getting a s a -> a
^. Getting Slot MockNodeServerChainState Slot
Lens' MockNodeServerChainState Slot
currentSlot) .. Slot
0]
    [Block]
chain
  where
    mkPoint :: Slot -> Block -> Point Block
    mkPoint :: Slot -> Block -> Point Block
mkPoint (Slot Integer
s) Block
block =
      WithOrigin (Block SlotNo (HeaderHash Block)) -> Point Block
forall block.
WithOrigin (Block SlotNo (HeaderHash block)) -> Point block
Point (Block SlotNo BlockId -> WithOrigin (Block SlotNo BlockId)
forall t. t -> WithOrigin t
At (SlotNo -> BlockId -> Block SlotNo BlockId
forall slot hash. slot -> hash -> Block slot hash
OP.Block (Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
s)
                          (Block -> BlockId
blockId Block
block)))

-- * TxSubmission protocol

{- I did not use the same approach for this protocol as I did
   for the `ChainSync`. This protocol has only one state and
   it is much simpler. -}

txSubmissionServer ::
    MVar MockNodeServerChainState
 -> TxSubmission.LocalTxSubmissionServer (C.Tx C.BabbageEra) String IO ()
txSubmissionServer :: MVar MockNodeServerChainState
-> LocalTxSubmissionServer (Tx BabbageEra) FilePath IO ()
txSubmissionServer MVar MockNodeServerChainState
state = LocalTxSubmissionServer (Tx BabbageEra) FilePath IO ()
txSubmissionState
    where
      txSubmissionState :: TxSubmission.LocalTxSubmissionServer (C.Tx C.BabbageEra) String IO ()
      txSubmissionState :: LocalTxSubmissionServer (Tx BabbageEra) FilePath IO ()
txSubmissionState =
        LocalTxSubmissionServer :: forall tx reject (m :: * -> *) a.
(tx
 -> m (SubmitResult reject, LocalTxSubmissionServer tx reject m a))
-> a -> LocalTxSubmissionServer tx reject m a
TxSubmission.LocalTxSubmissionServer {
          recvMsgSubmitTx :: Tx BabbageEra
-> IO
     (SubmitResult FilePath,
      LocalTxSubmissionServer (Tx BabbageEra) FilePath IO ())
TxSubmission.recvMsgSubmitTx =
            \Tx BabbageEra
tx -> do
                MVar MockNodeServerChainState
-> (MockNodeServerChainState -> IO MockNodeServerChainState)
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar MockNodeServerChainState
state (MockNodeServerChainState -> IO MockNodeServerChainState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MockNodeServerChainState -> IO MockNodeServerChainState)
-> (MockNodeServerChainState -> MockNodeServerChainState)
-> MockNodeServerChainState
-> IO MockNodeServerChainState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter
  MockNodeServerChainState MockNodeServerChainState TxPool TxPool
-> (TxPool -> TxPool)
-> MockNodeServerChainState
-> MockNodeServerChainState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  MockNodeServerChainState MockNodeServerChainState TxPool TxPool
Lens' MockNodeServerChainState TxPool
txPool (CardanoTx -> TxPool -> TxPool
addTxToPool (Tx BabbageEra -> CardanoTx
CardanoEmulatorEraTx Tx BabbageEra
tx)))
                (SubmitResult FilePath,
 LocalTxSubmissionServer (Tx BabbageEra) FilePath IO ())
-> IO
     (SubmitResult FilePath,
      LocalTxSubmissionServer (Tx BabbageEra) FilePath IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (SubmitResult FilePath
forall reason. SubmitResult reason
TxSubmission.SubmitSuccess, LocalTxSubmissionServer (Tx BabbageEra) FilePath IO ()
txSubmissionState)
        , recvMsgDone :: ()
TxSubmission.recvMsgDone     = ()
        }