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

module Cardano.Node.Socket.Emulator.Server (ServerHandler, runServerNode, processBlock, modifySlot, addTx, processChainEffects) where

import Cardano.BM.Data.Trace (Trace)
import Data.ByteString.Lazy qualified as LBS
import Data.Coerce (coerce)
import Data.Foldable (traverse_)
import Data.List (intersect)
import Data.Maybe (listToMaybe)
import Data.SOP.Strict (NS (S, Z))
import Data.Void (Void)

import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception (throwIO)
import Control.Lens (over, (^.))
import Control.Monad.Except (runExceptT)
import Control.Monad.Freer (send)
import Control.Monad.RWS.Strict (runRWST)

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.Consensus.Cardano.Block (CardanoBlock)
import Ouroboros.Consensus.HardFork.Combinator qualified as Consensus
import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr)
import Ouroboros.Consensus.Shelley.Eras (StandardCrypto)
import Ouroboros.Consensus.Shelley.Ledger qualified as Consensus
import Ouroboros.Consensus.Shelley.Ledger qualified as Shelley
import Ouroboros.Network.Block (Point (..), pointSlot)
import Ouroboros.Network.Block qualified as O
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.Api.Shelley qualified as C

import Cardano.Node.Emulator.API qualified as E
import Cardano.Node.Emulator.Internal.API (EmulatorError, EmulatorLogs, EmulatorMsg, EmulatorT)
import Cardano.Node.Emulator.Internal.API qualified as E
import Cardano.Node.Emulator.Internal.Node.Chain qualified as Chain
import Cardano.Node.Emulator.Internal.Node.Params (Params)
import Cardano.Node.Socket.Emulator.Types (AppState (..), BlockId (BlockId), SocketEmulatorState (..), Tip, blockId,
                                           chainSyncCodec, doNothingResponderProtocol, emulatorState, getChannel,
                                           getTip, nodeToClientVersion, nodeToClientVersionData, setTip,
                                           socketEmulatorState, toCardanoBlock, txSubmissionCodec)
import Control.Monad.Freer.Extras.Log (LogMsg (LMessage))
import Ledger (Block, CardanoTx (..), Slot (..))

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

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

-- | Run all chain effects in the IO Monad
runChainEffects
    :: Params
    -> MVar AppState
    -> EmulatorT IO a
    -> IO (EmulatorLogs, Either EmulatorError a)
runChainEffects :: Params
-> MVar AppState
-> EmulatorT IO a
-> IO (EmulatorLogs, Either EmulatorError a)
runChainEffects Params
params MVar AppState
stateVar EmulatorT IO a
eff = do
    AppState (SocketEmulatorState EmulatorState
oldState TChan Block
chan Tip
tip) EmulatorLogs
events <- IO AppState -> IO AppState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AppState -> IO AppState) -> IO AppState -> IO AppState
forall a b. (a -> b) -> a -> b
$ MVar AppState -> IO AppState
forall a. MVar a -> IO a
takeMVar MVar AppState
stateVar
    (Either EmulatorError a
a, EmulatorState
newState, EmulatorLogs
newEvents) <- RWST Params EmulatorLogs EmulatorState IO (Either EmulatorError a)
-> Params
-> EmulatorState
-> IO (Either EmulatorError a, EmulatorState, EmulatorLogs)
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST (EmulatorT IO a
-> RWST
     Params EmulatorLogs EmulatorState IO (Either EmulatorError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT EmulatorT IO a
eff) Params
params EmulatorState
oldState
    IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar AppState -> AppState -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar AppState
stateVar (AppState -> IO ()) -> AppState -> IO ()
forall a b. (a -> b) -> a -> b
$ SocketEmulatorState -> EmulatorLogs -> AppState
AppState (EmulatorState -> TChan Block -> Tip -> SocketEmulatorState
SocketEmulatorState EmulatorState
newState TChan Block
chan Tip
tip) (EmulatorLogs
events EmulatorLogs -> EmulatorLogs -> EmulatorLogs
forall a. Semigroup a => a -> a -> a
<> EmulatorLogs
newEvents)
    (EmulatorLogs, Either EmulatorError a)
-> IO (EmulatorLogs, Either EmulatorError a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EmulatorLogs
newEvents, Either EmulatorError a
a)

processChainEffects ::
    Trace IO EmulatorMsg
    -> Params
    -> MVar AppState
    -> EmulatorT IO a
    -> IO a
processChainEffects :: Trace IO EmulatorMsg
-> Params -> MVar AppState -> EmulatorT IO a -> IO a
processChainEffects Trace IO EmulatorMsg
trace Params
params MVar AppState
stateVar EmulatorT IO a
eff = do
    (EmulatorLogs
events, Either EmulatorError a
result) <- Params
-> MVar AppState
-> EmulatorT IO a
-> IO (EmulatorLogs, Either EmulatorError a)
forall a.
Params
-> MVar AppState
-> EmulatorT IO a
-> IO (EmulatorLogs, Either EmulatorError a)
runChainEffects Params
params MVar AppState
stateVar EmulatorT IO a
eff
    Trace IO EmulatorMsg -> Eff '[LogMsg EmulatorMsg, IO] ~> IO
forall (m :: * -> *) l.
MonadIO m =>
Trace m l -> Eff '[LogMsg l, m] ~> m
LM.runLogEffects Trace IO EmulatorMsg
trace (Eff '[LogMsg EmulatorMsg, IO] () -> IO ())
-> Eff '[LogMsg EmulatorMsg, IO] () -> IO ()
forall a b. (a -> b) -> a -> b
$ (LogMessage EmulatorMsg -> Eff '[LogMsg EmulatorMsg, IO] ())
-> EmulatorLogs -> Eff '[LogMsg EmulatorMsg, IO] ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (LogMsg EmulatorMsg () -> Eff '[LogMsg EmulatorMsg, IO] ()
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send (LogMsg EmulatorMsg () -> Eff '[LogMsg EmulatorMsg, IO] ())
-> (LogMessage EmulatorMsg -> LogMsg EmulatorMsg ())
-> LogMessage EmulatorMsg
-> Eff '[LogMsg EmulatorMsg, IO] ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogMessage EmulatorMsg -> LogMsg EmulatorMsg ()
forall a. LogMessage a -> LogMsg a ()
LMessage) EmulatorLogs
events
    (EmulatorError -> IO a)
-> (a -> IO a) -> Either EmulatorError a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either EmulatorError -> IO a
forall e a. Exception e => e -> IO a
throwIO a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either EmulatorError a
result

handleCommand ::
    MonadIO m
 => Trace IO EmulatorMsg
 -> CommandChannel
 -> MVar AppState
 -> Params
 -> m ()
handleCommand :: Trace IO EmulatorMsg
-> CommandChannel -> MVar AppState -> Params -> m ()
handleCommand Trace IO EmulatorMsg
trace CommandChannel {TQueue ServerCommand
ccCommand :: TQueue ServerCommand
ccCommand :: CommandChannel -> TQueue ServerCommand
ccCommand, TQueue ServerResponse
ccResponse :: TQueue ServerResponse
ccResponse :: CommandChannel -> TQueue ServerResponse
ccResponse} MVar AppState
mvAppState Params
params = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
    STM ServerCommand -> IO ServerCommand
forall a. STM a -> IO a
atomically (TQueue ServerCommand -> STM ServerCommand
forall a. TQueue a -> STM a
readTQueue TQueue ServerCommand
ccCommand) IO ServerCommand -> (ServerCommand -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            AddTx Tx BabbageEra
tx     -> EmulatorT IO () -> IO ()
forall a. EmulatorT IO a -> IO a
process (EmulatorT IO () -> IO ()) -> EmulatorT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ CardanoTx -> EmulatorT IO ()
forall (m :: * -> *). MonadEmulator m => CardanoTx -> m ()
E.queueTx (CardanoTx -> EmulatorT IO ()) -> CardanoTx -> EmulatorT IO ()
forall a b. (a -> b) -> a -> b
$ Tx BabbageEra -> CardanoTx
CardanoEmulatorEraTx Tx BabbageEra
tx
            ModifySlot Slot -> Slot
f -> do
                Slot
s <- EmulatorT IO Slot -> IO Slot
forall a. EmulatorT IO a -> IO a
process (EmulatorT IO Slot -> IO Slot) -> EmulatorT IO Slot -> IO Slot
forall a b. (a -> b) -> a -> b
$ (Slot -> Slot) -> EmulatorT IO Slot
forall (m :: * -> *). MonadEmulator m => (Slot -> Slot) -> m Slot
E.modifySlot Slot -> Slot
f
                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 (Slot -> ServerResponse
SlotChanged Slot
s)
            ServerCommand
ProcessBlock -> do
                Block
block <- EmulatorT IO Block -> IO Block
forall a. EmulatorT IO a -> IO a
process EmulatorT IO Block
forall (m :: * -> *). MonadEmulator m => m Block
E.processBlock
                MVar AppState -> Block -> IO ()
forall (m :: * -> *). MonadIO m => MVar AppState -> Block -> m ()
setTip MVar AppState
mvAppState Block
block
                TChan Block
ch <- MVar AppState -> IO (TChan Block)
forall (m :: * -> *). MonadIO m => MVar AppState -> m (TChan Block)
getChannel MVar AppState
mvAppState
                STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    TChan Block -> Block -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan Block
ch Block
block
                    TQueue ServerResponse -> ServerResponse -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue ServerResponse
ccResponse (Block -> ServerResponse
BlockAdded Block
block)
    where
        process :: EmulatorT IO a -> IO a
        process :: EmulatorT IO a -> IO a
process = Trace IO EmulatorMsg
-> Params -> MVar AppState -> EmulatorT IO a -> IO a
forall a.
Trace IO EmulatorMsg
-> Params -> MVar AppState -> EmulatorT IO a -> IO a
processChainEffects Trace IO EmulatorMsg
trace Params
params MVar AppState
mvAppState

{- | Start the server in a new thread, and return a server handler
     used to control the server -}
runServerNode ::
    MonadIO m
 => Trace IO EmulatorMsg
 -> FilePath
 -> Integer
 -> AppState
 -> Params
 -> m ServerHandler
runServerNode :: Trace IO EmulatorMsg
-> FilePath -> Integer -> AppState -> Params -> m ServerHandler
runServerNode Trace IO EmulatorMsg
trace FilePath
shSocketPath Integer
k AppState
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 AppState
serverState      <- AppState -> IO (MVar AppState)
forall a. a -> IO (MVar a)
newMVar AppState
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 AppState -> IO (TChan Block)
forall (m :: * -> *). MonadIO m => MVar AppState -> m (TChan Block)
getChannel MVar AppState
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 AppState -> IO Void
forall (m :: * -> *).
MonadIO m =>
FilePath -> MVar AppState -> m Void
protocolLoop        FilePath
shSocketPath     MVar AppState
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 EmulatorMsg
-> CommandChannel -> MVar AppState -> Params -> IO ()
forall (m :: * -> *).
MonadIO m =>
Trace IO EmulatorMsg
-> CommandChannel -> MVar AppState -> Params -> m ()
handleCommand Trace IO EmulatorMsg
trace CommandChannel
shCommandChannel MVar AppState
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 AppState) IO

runChainSync :: MVar AppState -> ChainSyncMonad a -> IO a
runChainSync :: MVar AppState -> ChainSyncMonad a -> IO a
runChainSync = (ChainSyncMonad a -> MVar AppState -> IO a)
-> MVar AppState -> ChainSyncMonad a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ChainSyncMonad a -> MVar AppState -> 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 AppState) m
    , MonadIO m
    , block ~ CardanoBlock StandardCrypto)
 => LocalChannel
 -> m (ServerStIdle block (Point block) Tip m ())
idleState :: LocalChannel -> m (ServerStIdle block (Point block) Tip m ())
idleState LocalChannel
channel' =
    ServerStIdle block (Point block) Tip m ()
-> m (ServerStIdle block (Point block) Tip 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) Tip m ())
     (m (ServerStNext block (Point block) Tip m ())))
recvMsgRequestNext = LocalChannel
-> m (Either
        (ServerStNext block (Point block) Tip m ())
        (m (ServerStNext block (Point block) Tip m ())))
forall (m :: * -> *) block.
(MonadReader (MVar AppState) m, MonadIO m,
 block ~ CardanoBlock StandardCrypto) =>
LocalChannel
-> m (Either
        (ServerStNext block (Point block) Tip m ())
        (m (ServerStNext block (Point block) Tip m ())))
nextState LocalChannel
channel',
        recvMsgFindIntersect :: [Point block] -> m (ServerStIntersect block (Point block) Tip m ())
recvMsgFindIntersect = [Point block] -> m (ServerStIntersect block (Point block) Tip m ())
forall (m :: * -> *) block.
(MonadReader (MVar AppState) m, MonadIO m,
 block ~ CardanoBlock StandardCrypto) =>
[Point block] -> m (ServerStIntersect block (Point block) Tip 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 AppState) m
    , MonadIO m
    , block ~ CardanoBlock StandardCrypto)
 => LocalChannel
 -> m (Either (ServerStNext block (Point block) Tip m ())
              (m (ServerStNext block (Point block) Tip m ())))
nextState :: LocalChannel
-> m (Either
        (ServerStNext block (Point block) Tip m ())
        (m (ServerStNext block (Point block) Tip m ())))
nextState localChannel :: LocalChannel
localChannel@(LocalChannel TChan Block
channel') = do
    MVar AppState
chainState <- m (MVar AppState)
forall r (m :: * -> *). MonadReader r m => m r
ask
    Tip
tip' <- MVar AppState -> m Tip
forall (m :: * -> *). MonadIO m => MVar AppState -> m Tip
getTip MVar AppState
chainState
    let blockHeader :: a
blockHeader = a
forall a. HasCallStack => a
undefined -- TODO
    (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
               (CardanoBlock StandardCrypto)
               (Point (CardanoBlock StandardCrypto))
               Tip
               m
               ())
            (m (ServerStNext
                  (CardanoBlock StandardCrypto)
                  (Point (CardanoBlock StandardCrypto))
                  Tip
                  m
                  ()))))
-> m (Either
        (ServerStNext
           (CardanoBlock StandardCrypto)
           (Point (CardanoBlock StandardCrypto))
           Tip
           m
           ())
        (m (ServerStNext
              (CardanoBlock StandardCrypto)
              (Point (CardanoBlock StandardCrypto))
              Tip
              m
              ())))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe Block
Nothing -> do
            m (ServerStNext
     (CardanoBlock StandardCrypto)
     (Point (CardanoBlock StandardCrypto))
     Tip
     m
     ())
-> Either
     (ServerStNext
        (CardanoBlock StandardCrypto)
        (Point (CardanoBlock StandardCrypto))
        Tip
        m
        ())
     (m (ServerStNext
           (CardanoBlock StandardCrypto)
           (Point (CardanoBlock StandardCrypto))
           Tip
           m
           ()))
forall a b. b -> Either a b
Right (m (ServerStNext
      (CardanoBlock StandardCrypto)
      (Point (CardanoBlock StandardCrypto))
      Tip
      m
      ())
 -> Either
      (ServerStNext
         (CardanoBlock StandardCrypto)
         (Point (CardanoBlock StandardCrypto))
         Tip
         m
         ())
      (m (ServerStNext
            (CardanoBlock StandardCrypto)
            (Point (CardanoBlock StandardCrypto))
            Tip
            m
            ())))
-> (ServerStNext
      (CardanoBlock StandardCrypto)
      (Point (CardanoBlock StandardCrypto))
      Tip
      m
      ()
    -> m (ServerStNext
            (CardanoBlock StandardCrypto)
            (Point (CardanoBlock StandardCrypto))
            Tip
            m
            ()))
-> ServerStNext
     (CardanoBlock StandardCrypto)
     (Point (CardanoBlock StandardCrypto))
     Tip
     m
     ()
-> Either
     (ServerStNext
        (CardanoBlock StandardCrypto)
        (Point (CardanoBlock StandardCrypto))
        Tip
        m
        ())
     (m (ServerStNext
           (CardanoBlock StandardCrypto)
           (Point (CardanoBlock StandardCrypto))
           Tip
           m
           ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerStNext
  (CardanoBlock StandardCrypto)
  (Point (CardanoBlock StandardCrypto))
  Tip
  m
  ()
-> m (ServerStNext
        (CardanoBlock StandardCrypto)
        (Point (CardanoBlock StandardCrypto))
        Tip
        m
        ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServerStNext
   (CardanoBlock StandardCrypto)
   (Point (CardanoBlock StandardCrypto))
   Tip
   m
   ()
 -> Either
      (ServerStNext
         (CardanoBlock StandardCrypto)
         (Point (CardanoBlock StandardCrypto))
         Tip
         m
         ())
      (m (ServerStNext
            (CardanoBlock StandardCrypto)
            (Point (CardanoBlock StandardCrypto))
            Tip
            m
            ())))
-> m (ServerStNext
        (CardanoBlock StandardCrypto)
        (Point (CardanoBlock StandardCrypto))
        Tip
        m
        ())
-> m (Either
        (ServerStNext
           (CardanoBlock StandardCrypto)
           (Point (CardanoBlock StandardCrypto))
           Tip
           m
           ())
        (m (ServerStNext
              (CardanoBlock StandardCrypto)
              (Point (CardanoBlock StandardCrypto))
              Tip
              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'
                LocalChannel
-> Tip
-> CardanoBlock StandardCrypto
-> m (ServerStNext
        (CardanoBlock StandardCrypto)
        (Point (CardanoBlock StandardCrypto))
        Tip
        m
        ())
forall (m :: * -> *) block.
(MonadReader (MVar AppState) m, MonadIO m,
 block ~ CardanoBlock StandardCrypto) =>
LocalChannel
-> Tip -> block -> m (ServerStNext block (Point block) Tip m ())
sendRollForward LocalChannel
localChannel Tip
tip' (CardanoBlock StandardCrypto
 -> m (ServerStNext
         (CardanoBlock StandardCrypto)
         (Point (CardanoBlock StandardCrypto))
         Tip
         m
         ()))
-> CardanoBlock StandardCrypto
-> m (ServerStNext
        (CardanoBlock StandardCrypto)
        (Point (CardanoBlock StandardCrypto))
        Tip
        m
        ())
forall a b. (a -> b) -> a -> b
$ Header StandardCrypto -> Block -> CardanoBlock StandardCrypto
toCardanoBlock Header StandardCrypto
forall a. a
blockHeader Block
nextBlock
        Just Block
nextBlock -> do
            ServerStNext
  (CardanoBlock StandardCrypto)
  (Point (CardanoBlock StandardCrypto))
  Tip
  m
  ()
-> Either
     (ServerStNext
        (CardanoBlock StandardCrypto)
        (Point (CardanoBlock StandardCrypto))
        Tip
        m
        ())
     (m (ServerStNext
           (CardanoBlock StandardCrypto)
           (Point (CardanoBlock StandardCrypto))
           Tip
           m
           ()))
forall a b. a -> Either a b
Left (ServerStNext
   (CardanoBlock StandardCrypto)
   (Point (CardanoBlock StandardCrypto))
   Tip
   m
   ()
 -> Either
      (ServerStNext
         (CardanoBlock StandardCrypto)
         (Point (CardanoBlock StandardCrypto))
         Tip
         m
         ())
      (m (ServerStNext
            (CardanoBlock StandardCrypto)
            (Point (CardanoBlock StandardCrypto))
            Tip
            m
            ())))
-> m (ServerStNext
        (CardanoBlock StandardCrypto)
        (Point (CardanoBlock StandardCrypto))
        Tip
        m
        ())
-> m (Either
        (ServerStNext
           (CardanoBlock StandardCrypto)
           (Point (CardanoBlock StandardCrypto))
           Tip
           m
           ())
        (m (ServerStNext
              (CardanoBlock StandardCrypto)
              (Point (CardanoBlock StandardCrypto))
              Tip
              m
              ())))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LocalChannel
-> Tip
-> CardanoBlock StandardCrypto
-> m (ServerStNext
        (CardanoBlock StandardCrypto)
        (Point (CardanoBlock StandardCrypto))
        Tip
        m
        ())
forall (m :: * -> *) block.
(MonadReader (MVar AppState) m, MonadIO m,
 block ~ CardanoBlock StandardCrypto) =>
LocalChannel
-> Tip -> block -> m (ServerStNext block (Point block) Tip m ())
sendRollForward LocalChannel
localChannel Tip
tip' (Header StandardCrypto -> Block -> CardanoBlock StandardCrypto
toCardanoBlock Header StandardCrypto
forall a. a
blockHeader 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 AppState) m
    , MonadIO m
    , block ~ CardanoBlock StandardCrypto)
 => [Point block]
 -> m (ServerStIntersect block (Point block) Tip m ())
findIntersect :: [Point block] -> m (ServerStIntersect block (Point block) Tip m ())
findIntersect [Point block]
clientPoints = do
    MVar AppState
mvState <- m (MVar AppState)
forall r (m :: * -> *). MonadReader r m => m r
ask
    AppState
appState <- IO AppState -> m AppState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AppState -> m AppState) -> IO AppState -> m AppState
forall a b. (a -> b) -> a -> b
$ MVar AppState -> IO AppState
forall a. MVar a -> IO a
readMVar MVar AppState
mvState
    let chainState :: ChainState
chainState = AppState
appState AppState -> Getting ChainState AppState ChainState -> ChainState
forall s a. s -> Getting a s a -> a
^. (SocketEmulatorState -> Const ChainState SocketEmulatorState)
-> AppState -> Const ChainState AppState
Lens' AppState SocketEmulatorState
socketEmulatorState ((SocketEmulatorState -> Const ChainState SocketEmulatorState)
 -> AppState -> Const ChainState AppState)
-> ((ChainState -> Const ChainState ChainState)
    -> SocketEmulatorState -> Const ChainState SocketEmulatorState)
-> Getting ChainState AppState ChainState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EmulatorState -> Const ChainState EmulatorState)
-> SocketEmulatorState -> Const ChainState SocketEmulatorState
Lens' SocketEmulatorState EmulatorState
emulatorState ((EmulatorState -> Const ChainState EmulatorState)
 -> SocketEmulatorState -> Const ChainState SocketEmulatorState)
-> ((ChainState -> Const ChainState ChainState)
    -> EmulatorState -> Const ChainState EmulatorState)
-> (ChainState -> Const ChainState ChainState)
-> SocketEmulatorState
-> Const ChainState SocketEmulatorState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChainState -> Const ChainState ChainState)
-> EmulatorState -> Const ChainState EmulatorState
Lens' EmulatorState ChainState
E.esChainState
        blocks :: Blockchain
blocks = ChainState -> Blockchain
Chain._chainNewestFirst ChainState
chainState
        slot :: Slot
slot = ChainState -> Slot
Chain._chainCurrentSlot ChainState
chainState
    [Point block]
serverPoints <- Blockchain -> Slot -> m [Point block]
forall (m :: * -> *) block.
(MonadIO m, block ~ CardanoBlock StandardCrypto) =>
Blockchain -> Slot -> m [Point block]
getChainPoints Blockchain
blocks Slot
slot
    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
    Tip
tip' <- MVar AppState -> m Tip
forall (m :: * -> *). MonadIO m => MVar AppState -> m Tip
getTip MVar AppState
mvState
    ServerStIntersect block (Point block) Tip m ()
-> m (ServerStIntersect block (Point block) Tip m ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServerStIntersect block (Point block) Tip m ()
 -> m (ServerStIntersect block (Point block) Tip m ()))
-> ServerStIntersect block (Point block) Tip m ()
-> m (ServerStIntersect block (Point block) Tip m ())
forall a b. (a -> b) -> a -> b
$ case Maybe (Point block)
point of
        Maybe (Point block)
Nothing ->
          Tip
-> ChainSyncServer block (Point block) Tip m ()
-> ServerStIntersect block (Point block) Tip m ()
forall tip header point (m :: * -> *) a.
tip
-> ChainSyncServer header point tip m a
-> ServerStIntersect header point tip m a
SendMsgIntersectNotFound
            Tip
forall b. Tip b
O.TipGenesis
            -- No intersection found. Resume from origin.
            (m (ServerStIdle block (Point block) Tip m ())
-> ChainSyncServer block (Point block) Tip 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) Tip m ())
 -> ChainSyncServer block (Point block) Tip m ())
-> m (ServerStIdle block (Point block) Tip m ())
-> ChainSyncServer block (Point block) Tip m ()
forall a b. (a -> b) -> a -> b
$ Integer -> m LocalChannel
forall (m :: * -> *).
(MonadReader (MVar AppState) m, MonadIO m) =>
Integer -> m LocalChannel
cloneChainFrom Integer
0 m LocalChannel
-> (LocalChannel -> m (ServerStIdle block (Point block) Tip m ()))
-> m (ServerStIdle block (Point block) Tip m ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LocalChannel -> m (ServerStIdle block (Point block) Tip m ())
forall (m :: * -> *) block.
(MonadReader (MVar AppState) m, MonadIO m,
 block ~ CardanoBlock StandardCrypto) =>
LocalChannel -> m (ServerStIdle block (Point block) Tip m ())
idleState)
        Just Point block
point' ->
          Point block
-> Tip
-> ChainSyncServer block (Point block) Tip m ()
-> ServerStIntersect block (Point block) Tip 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'
            Tip
tip'
            -- Resuming from point'.
            (m (ServerStIdle block (Point block) Tip m ())
-> ChainSyncServer block (Point block) Tip 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) Tip m ())
 -> ChainSyncServer block (Point block) Tip m ())
-> m (ServerStIdle block (Point block) Tip m ())
-> ChainSyncServer block (Point block) Tip m ()
forall a b. (a -> b) -> a -> b
$ Integer -> m LocalChannel
forall (m :: * -> *).
(MonadReader (MVar AppState) m, MonadIO m) =>
Integer -> m LocalChannel
cloneChainFrom (Point block -> Integer
forall block. Point block -> Integer
pointOffset Point block
point') m LocalChannel
-> (LocalChannel -> m (ServerStIdle block (Point block) Tip m ()))
-> m (ServerStIdle block (Point block) Tip m ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LocalChannel -> m (ServerStIdle block (Point block) Tip m ())
forall (m :: * -> *) block.
(MonadReader (MVar AppState) m, MonadIO m,
 block ~ CardanoBlock StandardCrypto) =>
LocalChannel -> m (ServerStIdle block (Point block) Tip m ())
idleState)

{- This is a wrapper around the creation of a `ServerStNext` -}
sendRollForward ::
    ( MonadReader (MVar AppState) m
    , MonadIO m
    , block ~ CardanoBlock StandardCrypto)
 => LocalChannel
 -> Tip -- tip
 -> block -- current
 -> m (ServerStNext block (Point block) Tip m ())
sendRollForward :: LocalChannel
-> Tip -> block -> m (ServerStNext block (Point block) Tip m ())
sendRollForward LocalChannel
channel' Tip
tip' block
current = ServerStNext block (Point block) Tip m ()
-> m (ServerStNext block (Point block) Tip m ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServerStNext block (Point block) Tip m ()
 -> m (ServerStNext block (Point block) Tip m ()))
-> ServerStNext block (Point block) Tip m ()
-> m (ServerStNext block (Point block) Tip m ())
forall a b. (a -> b) -> a -> b
$
    block
-> Tip
-> ChainSyncServer block (Point block) Tip m ()
-> ServerStNext block (Point block) Tip m ()
forall header tip point (m :: * -> *) a.
header
-> tip
-> ChainSyncServer header point tip m a
-> ServerStNext header point tip m a
SendMsgRollForward
        block
current
        Tip
tip'
        (m (ServerStIdle block (Point block) Tip m ())
-> ChainSyncServer block (Point block) Tip 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) Tip m ())
forall (m :: * -> *) block.
(MonadReader (MVar AppState) m, MonadIO m,
 block ~ CardanoBlock StandardCrypto) =>
LocalChannel -> m (ServerStIdle block (Point block) Tip 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 AppState) m
    , MonadIO m
    , block ~ CardanoBlock StandardCrypto)
 => ChainSyncServer block (Point block) Tip m ()
chainSyncServer :: ChainSyncServer block (Point block) Tip m ()
chainSyncServer =
    m (ServerStIdle block (Point block) Tip m ())
-> ChainSyncServer block (Point block) Tip 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 AppState) m, MonadIO m) =>
Integer -> m LocalChannel
cloneChainFrom Integer
0 m LocalChannel
-> (LocalChannel -> m (ServerStIdle block (Point block) Tip m ()))
-> m (ServerStIdle block (Point block) Tip m ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LocalChannel -> m (ServerStIdle block (Point block) Tip m ())
forall (m :: * -> *) block.
(MonadReader (MVar AppState) m, MonadIO m,
 block ~ CardanoBlock StandardCrypto) =>
LocalChannel -> m (ServerStIdle block (Point block) Tip 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 AppState) 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 AppState)
forall r (m :: * -> *). MonadReader r m => m r
ask m (MVar AppState)
-> (MVar AppState -> m (TChan Block)) -> m (TChan Block)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar AppState -> m (TChan Block)
forall (m :: * -> *). MonadIO m => MVar AppState -> 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 AppState) m
 => ChainSyncServer block (Point block) Tip ChainSyncMonad a
 -> m (ChainSyncServer block (Point block) Tip IO a)
hoistChainSync :: ChainSyncServer block (Point block) Tip ChainSyncMonad a
-> m (ChainSyncServer block (Point block) Tip IO a)
hoistChainSync ChainSyncServer block (Point block) Tip ChainSyncMonad a
machine = do
    MVar AppState
internalState <- m (MVar AppState)
forall r (m :: * -> *). MonadReader r m => m r
ask
    ChainSyncServer block (Point block) Tip IO a
-> m (ChainSyncServer block (Point block) Tip 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) Tip IO a)
runChainSyncServer = MVar AppState
-> ChainSyncMonad (ServerStIdle block (Point block) Tip IO a)
-> IO (ServerStIdle block (Point block) Tip IO a)
forall a. MVar AppState -> ChainSyncMonad a -> IO a
runChainSync MVar AppState
internalState (ChainSyncMonad (ServerStIdle block (Point block) Tip IO a)
 -> IO (ServerStIdle block (Point block) Tip IO a))
-> ChainSyncMonad (ServerStIdle block (Point block) Tip IO a)
-> IO (ServerStIdle block (Point block) Tip IO a)
forall a b. (a -> b) -> a -> b
$
            ChainSyncServer block (Point block) Tip ChainSyncMonad a
-> ChainSyncMonad
     (ServerStIdle block (Point block) Tip 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) Tip ChainSyncMonad a
machine ChainSyncMonad
  (ServerStIdle block (Point block) Tip ChainSyncMonad a)
-> (ServerStIdle block (Point block) Tip ChainSyncMonad a
    -> ChainSyncMonad (ServerStIdle block (Point block) Tip IO a))
-> ChainSyncMonad (ServerStIdle block (Point block) Tip IO a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ServerStIdle block (Point block) Tip ChainSyncMonad a
-> ChainSyncMonad (ServerStIdle block (Point block) Tip IO a)
forall (m :: * -> *) block a.
MonadReader (MVar AppState) m =>
ServerStIdle block (Point block) Tip ChainSyncMonad a
-> m (ServerStIdle block (Point block) Tip IO a)
hoistStIdle
    }

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

hoistStIntersect ::
    MonadReader (MVar AppState) m
 => ServerStIntersect block (Point block) Tip ChainSyncMonad a
 -> m (ServerStIntersect block (Point block) Tip IO a)
hoistStIntersect :: ServerStIntersect block (Point block) Tip ChainSyncMonad a
-> m (ServerStIntersect block (Point block) Tip IO a)
hoistStIntersect (SendMsgIntersectFound Point block
point Tip
tip' ChainSyncServer block (Point block) Tip ChainSyncMonad a
nextState') =
    Point block
-> Tip
-> ChainSyncServer block (Point block) Tip IO a
-> ServerStIntersect block (Point block) Tip 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 Tip
tip' (ChainSyncServer block (Point block) Tip IO a
 -> ServerStIntersect block (Point block) Tip IO a)
-> m (ChainSyncServer block (Point block) Tip IO a)
-> m (ServerStIntersect block (Point block) Tip IO a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainSyncServer block (Point block) Tip ChainSyncMonad a
-> m (ChainSyncServer block (Point block) Tip IO a)
forall (m :: * -> *) block a.
MonadReader (MVar AppState) m =>
ChainSyncServer block (Point block) Tip ChainSyncMonad a
-> m (ChainSyncServer block (Point block) Tip IO a)
hoistChainSync ChainSyncServer block (Point block) Tip ChainSyncMonad a
nextState'
hoistStIntersect (SendMsgIntersectNotFound Tip
tip' ChainSyncServer block (Point block) Tip ChainSyncMonad a
nextState') =
    Tip
-> ChainSyncServer block (Point block) Tip IO a
-> ServerStIntersect block (Point block) Tip IO a
forall tip header point (m :: * -> *) a.
tip
-> ChainSyncServer header point tip m a
-> ServerStIntersect header point tip m a
SendMsgIntersectNotFound Tip
tip'    (ChainSyncServer block (Point block) Tip IO a
 -> ServerStIntersect block (Point block) Tip IO a)
-> m (ChainSyncServer block (Point block) Tip IO a)
-> m (ServerStIntersect block (Point block) Tip IO a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainSyncServer block (Point block) Tip ChainSyncMonad a
-> m (ChainSyncServer block (Point block) Tip IO a)
forall (m :: * -> *) block a.
MonadReader (MVar AppState) m =>
ChainSyncServer block (Point block) Tip ChainSyncMonad a
-> m (ChainSyncServer block (Point block) Tip IO a)
hoistChainSync ChainSyncServer block (Point block) Tip ChainSyncMonad a
nextState'

hoistStNext ::
    MonadReader (MVar AppState) m
 => ServerStNext block (Point block) Tip ChainSyncMonad a
 -> m (ServerStNext block (Point block) Tip IO a)
hoistStNext :: ServerStNext block (Point block) Tip ChainSyncMonad a
-> m (ServerStNext block (Point block) Tip IO a)
hoistStNext (SendMsgRollForward block
header Tip
tip' ChainSyncServer block (Point block) Tip ChainSyncMonad a
nextState') =
    block
-> Tip
-> ChainSyncServer block (Point block) Tip IO a
-> ServerStNext block (Point block) Tip 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 Tip
tip' (ChainSyncServer block (Point block) Tip IO a
 -> ServerStNext block (Point block) Tip IO a)
-> m (ChainSyncServer block (Point block) Tip IO a)
-> m (ServerStNext block (Point block) Tip IO a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainSyncServer block (Point block) Tip ChainSyncMonad a
-> m (ChainSyncServer block (Point block) Tip IO a)
forall (m :: * -> *) block a.
MonadReader (MVar AppState) m =>
ChainSyncServer block (Point block) Tip ChainSyncMonad a
-> m (ChainSyncServer block (Point block) Tip IO a)
hoistChainSync ChainSyncServer block (Point block) Tip ChainSyncMonad a
nextState'
hoistStNext (SendMsgRollBackward Point block
header Tip
tip' ChainSyncServer block (Point block) Tip ChainSyncMonad a
nextState') =
    Point block
-> Tip
-> ChainSyncServer block (Point block) Tip IO a
-> ServerStNext block (Point block) Tip 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 Tip
tip' (ChainSyncServer block (Point block) Tip IO a
 -> ServerStNext block (Point block) Tip IO a)
-> m (ChainSyncServer block (Point block) Tip IO a)
-> m (ServerStNext block (Point block) Tip IO a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainSyncServer block (Point block) Tip ChainSyncMonad a
-> m (ChainSyncServer block (Point block) Tip IO a)
forall (m :: * -> *) block a.
MonadReader (MVar AppState) m =>
ChainSyncServer block (Point block) Tip ChainSyncMonad a
-> m (ChainSyncServer block (Point block) Tip IO a)
hoistChainSync ChainSyncServer block (Point block) Tip 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 AppState
 -> m Void
protocolLoop :: FilePath -> MVar AppState -> m Void
protocolLoop FilePath
socketPath MVar AppState
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 AppState
-> NodeToClientProtocols 'ResponderMode ByteString IO Void ()
nodeToClientProtocols MVar AppState
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 AppState
  -> NodeToClientProtocols 'ResponderMode LBS.ByteString IO Void ()
nodeToClientProtocols :: MVar AppState
-> NodeToClientProtocols 'ResponderMode ByteString IO Void ()
nodeToClientProtocols MVar AppState
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 AppState
-> RunMiniProtocol 'ResponderMode ByteString IO Void ()
chainSync MVar AppState
internalState
    , localTxSubmissionProtocol :: RunMiniProtocol 'ResponderMode ByteString IO Void ()
localTxSubmissionProtocol = MVar AppState
-> RunMiniProtocol 'ResponderMode ByteString IO Void ()
txSubmission MVar AppState
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 AppState
  -> RunMiniProtocol 'ResponderMode LBS.ByteString IO Void ()
chainSync :: MVar AppState
-> RunMiniProtocol 'ResponderMode ByteString IO Void ()
chainSync MVar AppState
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
        (CardanoBlock StandardCrypto)
        (Point (CardanoBlock StandardCrypto))
        Tip))
-> Codec
     (ChainSync
        (CardanoBlock StandardCrypto)
        (Point (CardanoBlock StandardCrypto))
        Tip)
     DeserialiseFailure
     IO
     ByteString
-> Peer
     (ChainSync
        (CardanoBlock StandardCrypto)
        (Point (CardanoBlock StandardCrypto))
        Tip)
     '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
        (CardanoBlock StandardCrypto)
        (Point (CardanoBlock StandardCrypto))
        Tip))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
       Codec
  (ChainSync
     (CardanoBlock StandardCrypto)
     (Point (CardanoBlock StandardCrypto))
     Tip)
  DeserialiseFailure
  IO
  ByteString
forall block.
(block ~ CardanoBlock StandardCrypto) =>
Codec
  (ChainSync block (Point block) Tip)
  DeserialiseFailure
  IO
  ByteString
chainSyncCodec
       (ChainSyncServer
  (CardanoBlock StandardCrypto)
  (Point (CardanoBlock StandardCrypto))
  Tip
  IO
  ()
-> Peer
     (ChainSync
        (CardanoBlock StandardCrypto)
        (Point (CardanoBlock StandardCrypto))
        Tip)
     '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 AppState)
  (ChainSyncServer
     (CardanoBlock StandardCrypto)
     (Point (CardanoBlock StandardCrypto))
     Tip
     IO
     ())
-> MVar AppState
-> ChainSyncServer
     (CardanoBlock StandardCrypto)
     (Point (CardanoBlock StandardCrypto))
     Tip
     IO
     ()
forall r a. Reader r a -> r -> a
runReader (ChainSyncServer
  (CardanoBlock StandardCrypto)
  (Point (CardanoBlock StandardCrypto))
  Tip
  ChainSyncMonad
  ()
-> Reader
     (MVar AppState)
     (ChainSyncServer
        (CardanoBlock StandardCrypto)
        (Point (CardanoBlock StandardCrypto))
        Tip
        IO
        ())
forall (m :: * -> *) block a.
MonadReader (MVar AppState) m =>
ChainSyncServer block (Point block) Tip ChainSyncMonad a
-> m (ChainSyncServer block (Point block) Tip IO a)
hoistChainSync ChainSyncServer
  (CardanoBlock StandardCrypto)
  (Point (CardanoBlock StandardCrypto))
  Tip
  ChainSyncMonad
  ()
forall (m :: * -> *) block.
(MonadReader (MVar AppState) m, MonadIO m,
 block ~ CardanoBlock StandardCrypto) =>
ChainSyncServer block (Point block) Tip m ()
chainSyncServer)
                      MVar AppState
mvChainState))

txSubmission
  :: MVar AppState
  -> RunMiniProtocol 'ResponderMode LBS.ByteString IO Void ()
txSubmission :: MVar AppState
-> RunMiniProtocol 'ResponderMode ByteString IO Void ()
txSubmission MVar AppState
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
        (GenTx (CardanoBlock StandardCrypto))
        (HardForkApplyTxErr
           (ByronBlock : CardanoShelleyEras StandardCrypto))))
-> Codec
     (LocalTxSubmission
        (GenTx (CardanoBlock StandardCrypto))
        (HardForkApplyTxErr
           (ByronBlock : CardanoShelleyEras StandardCrypto)))
     DeserialiseFailure
     IO
     ByteString
-> Peer
     (LocalTxSubmission
        (GenTx (CardanoBlock StandardCrypto))
        (HardForkApplyTxErr
           (ByronBlock : CardanoShelleyEras StandardCrypto)))
     '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
        (GenTx (CardanoBlock StandardCrypto))
        (HardForkApplyTxErr
           (ByronBlock : CardanoShelleyEras StandardCrypto))))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      Codec
  (LocalTxSubmission
     (GenTx (CardanoBlock StandardCrypto))
     (HardForkApplyTxErr
        (ByronBlock : CardanoShelleyEras StandardCrypto)))
  DeserialiseFailure
  IO
  ByteString
forall block.
(block ~ CardanoBlock StandardCrypto) =>
Codec
  (LocalTxSubmission (GenTx block) (ApplyTxErr block))
  DeserialiseFailure
  IO
  ByteString
txSubmissionCodec
      (IO
  (LocalTxSubmissionServer
     (GenTx (CardanoBlock StandardCrypto))
     (HardForkApplyTxErr
        (ByronBlock : CardanoShelleyEras StandardCrypto))
     IO
     ())
-> Peer
     (LocalTxSubmission
        (GenTx (CardanoBlock StandardCrypto))
        (HardForkApplyTxErr
           (ByronBlock : CardanoShelleyEras StandardCrypto)))
     '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
  (GenTx (CardanoBlock StandardCrypto))
  (HardForkApplyTxErr
     (ByronBlock : CardanoShelleyEras StandardCrypto))
  IO
  ()
-> IO
     (LocalTxSubmissionServer
        (GenTx (CardanoBlock StandardCrypto))
        (HardForkApplyTxErr
           (ByronBlock : CardanoShelleyEras StandardCrypto))
        IO
        ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocalTxSubmissionServer
   (GenTx (CardanoBlock StandardCrypto))
   (HardForkApplyTxErr
      (ByronBlock : CardanoShelleyEras StandardCrypto))
   IO
   ()
 -> IO
      (LocalTxSubmissionServer
         (GenTx (CardanoBlock StandardCrypto))
         (HardForkApplyTxErr
            (ByronBlock : CardanoShelleyEras StandardCrypto))
         IO
         ()))
-> LocalTxSubmissionServer
     (GenTx (CardanoBlock StandardCrypto))
     (HardForkApplyTxErr
        (ByronBlock : CardanoShelleyEras StandardCrypto))
     IO
     ()
-> IO
     (LocalTxSubmissionServer
        (GenTx (CardanoBlock StandardCrypto))
        (HardForkApplyTxErr
           (ByronBlock : CardanoShelleyEras StandardCrypto))
        IO
        ())
forall a b. (a -> b) -> a -> b
$ MVar AppState
-> LocalTxSubmissionServer
     (GenTx (CardanoBlock StandardCrypto))
     (ApplyTxErr (CardanoBlock StandardCrypto))
     IO
     ()
forall block.
(block ~ CardanoBlock StandardCrypto) =>
MVar AppState
-> LocalTxSubmissionServer (GenTx block) (ApplyTxErr block) IO ()
txSubmissionServer MVar AppState
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
    :: forall m block. (MonadIO m, block ~ CardanoBlock StandardCrypto)
    => [Block] -> Slot -> m [Point block]
getChainPoints :: Blockchain -> Slot -> m [Point block]
getChainPoints Blockchain
chain Slot
slot = do
  [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] -> Blockchain -> [Point block]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Slot -> Block -> Point block
mkPoint [Slot
slot, Slot
slot Slot -> Slot -> Slot
forall a. Num a => a -> a -> a
- Slot
1 .. Slot
0] Blockchain
chain
  where
    mkPoint :: Slot -> Block -> Point block
    mkPoint :: Slot -> Block -> Point block
mkPoint Slot
s Block
block =
      WithOrigin (Block SlotNo (HeaderHash block)) -> Point block
forall block.
WithOrigin (Block SlotNo (HeaderHash block)) -> Point block
Point (Block
  SlotNo
  (OneEraHash (ByronBlock : CardanoShelleyEras StandardCrypto))
-> WithOrigin
     (Block
        SlotNo
        (OneEraHash (ByronBlock : CardanoShelleyEras StandardCrypto)))
forall t. t -> WithOrigin t
At (SlotNo
-> OneEraHash (ByronBlock : CardanoShelleyEras StandardCrypto)
-> Block
     SlotNo
     (OneEraHash (ByronBlock : CardanoShelleyEras StandardCrypto))
forall slot hash. slot -> hash -> Block slot hash
OP.Block (Slot -> SlotNo
forall a b. (Integral a, Num b) => a -> b
fromIntegral Slot
s)
                          (BlockId
-> OneEraHash (ByronBlock : CardanoShelleyEras StandardCrypto)
coerce (BlockId
 -> OneEraHash (ByronBlock : CardanoShelleyEras StandardCrypto))
-> BlockId
-> OneEraHash (ByronBlock : CardanoShelleyEras StandardCrypto)
forall a b. (a -> b) -> a -> b
$ 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 :: forall block. (block ~ CardanoBlock StandardCrypto)
    => MVar AppState
    -> TxSubmission.LocalTxSubmissionServer (Shelley.GenTx block) (ApplyTxErr block) IO ()
txSubmissionServer :: MVar AppState
-> LocalTxSubmissionServer (GenTx block) (ApplyTxErr block) IO ()
txSubmissionServer MVar AppState
state = LocalTxSubmissionServer (GenTx block) (ApplyTxErr block) IO ()
txSubmissionState
    where
      txSubmissionState :: TxSubmission.LocalTxSubmissionServer (Shelley.GenTx block) (ApplyTxErr block) IO ()
      txSubmissionState :: LocalTxSubmissionServer (GenTx block) (ApplyTxErr block) 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 :: GenTx block
-> IO
     (SubmitResult
        (HardForkApplyTxErr
           (ByronBlock : CardanoShelleyEras StandardCrypto)),
      LocalTxSubmissionServer
        (GenTx block)
        (HardForkApplyTxErr
           (ByronBlock : CardanoShelleyEras StandardCrypto))
        IO
        ())
TxSubmission.recvMsgSubmitTx =
            \GenTx block
tx -> do
                case GenTx block
tx of
                    (Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (S (Z tx')))))))) -> do
                        let Consensus.ShelleyTx _txid shelleyEraTx = GenTx x
GenTx
  (ShelleyBlock (Praos StandardCrypto) (BabbageEra StandardCrypto))
tx'
                        let ctx :: CardanoTx
ctx = Tx BabbageEra -> CardanoTx
CardanoEmulatorEraTx (ShelleyBasedEra BabbageEra
-> Tx (ShelleyLedgerEra BabbageEra) -> Tx BabbageEra
forall era.
ShelleyBasedEra era -> Tx (ShelleyLedgerEra era) -> Tx era
C.ShelleyTx ShelleyBasedEra BabbageEra
C.ShelleyBasedEraBabbage Tx (BabbageEra StandardCrypto)
Tx (ShelleyLedgerEra BabbageEra)
shelleyEraTx)
                        ()
_ <- MVar AppState -> (AppState -> IO AppState) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar AppState
state (AppState -> IO AppState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AppState -> IO AppState)
-> (AppState -> AppState) -> AppState -> IO AppState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter AppState AppState ChainState ChainState
-> (ChainState -> ChainState) -> AppState -> AppState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((SocketEmulatorState -> Identity SocketEmulatorState)
-> AppState -> Identity AppState
Lens' AppState SocketEmulatorState
socketEmulatorState ((SocketEmulatorState -> Identity SocketEmulatorState)
 -> AppState -> Identity AppState)
-> ((ChainState -> Identity ChainState)
    -> SocketEmulatorState -> Identity SocketEmulatorState)
-> ASetter AppState AppState ChainState ChainState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EmulatorState -> Identity EmulatorState)
-> SocketEmulatorState -> Identity SocketEmulatorState
Lens' SocketEmulatorState EmulatorState
emulatorState ((EmulatorState -> Identity EmulatorState)
 -> SocketEmulatorState -> Identity SocketEmulatorState)
-> ((ChainState -> Identity ChainState)
    -> EmulatorState -> Identity EmulatorState)
-> (ChainState -> Identity ChainState)
-> SocketEmulatorState
-> Identity SocketEmulatorState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChainState -> Identity ChainState)
-> EmulatorState -> Identity EmulatorState
Lens' EmulatorState ChainState
E.esChainState) (CardanoTx -> ChainState -> ChainState
Chain.addTxToPool CardanoTx
ctx))
                        () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    GenTx block
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                (SubmitResult
   (HardForkApplyTxErr
      (ByronBlock : CardanoShelleyEras StandardCrypto)),
 LocalTxSubmissionServer
   (GenTx block)
   (HardForkApplyTxErr
      (ByronBlock : CardanoShelleyEras StandardCrypto))
   IO
   ())
-> IO
     (SubmitResult
        (HardForkApplyTxErr
           (ByronBlock : CardanoShelleyEras StandardCrypto)),
      LocalTxSubmissionServer
        (GenTx block)
        (HardForkApplyTxErr
           (ByronBlock : CardanoShelleyEras StandardCrypto))
        IO
        ())
forall (m :: * -> *) a. Monad m => a -> m a
return (SubmitResult
  (HardForkApplyTxErr
     (ByronBlock : CardanoShelleyEras StandardCrypto))
forall reason. SubmitResult reason
TxSubmission.SubmitSuccess, LocalTxSubmissionServer (GenTx block) (ApplyTxErr block) IO ()
LocalTxSubmissionServer
  (GenTx block)
  (HardForkApplyTxErr
     (ByronBlock : CardanoShelleyEras StandardCrypto))
  IO
  ()
txSubmissionState)
        , recvMsgDone :: ()
TxSubmission.recvMsgDone     = ()
        }