{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Cardano.Node.Mock where
import Control.Concurrent (threadDelay)
import Control.Concurrent.MVar (MVar, modifyMVar_, putMVar, takeMVar)
import Control.Lens (over, set, unto, view)
import Control.Monad (forever, void)
import Control.Monad.Freer (Eff, LastMember, Member, interpret, reinterpret, runM)
import Control.Monad.Freer.Extras.Log
import Control.Monad.Freer.Extras.Modify (handleZoomedState)
import Control.Monad.Freer.Reader (Reader)
import Control.Monad.Freer.Reader qualified as Eff
import Control.Monad.Freer.State qualified as Eff
import Control.Monad.Freer.Writer qualified as Eff
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Foldable (traverse_)
import Data.Function ((&))
import Data.Time.Units (Millisecond, toMicroseconds)
import Data.Time.Units.Extra ()
import Servant (NoContent (NoContent))
import Cardano.Api qualified as C
import Cardano.BM.Data.Trace (Trace)
import Cardano.Chain (handleChain, handleControlChain)
import Cardano.Node.Emulator.Chain qualified as Chain
import Cardano.Node.Emulator.Params (Params (..))
import Cardano.Node.Emulator.TimeSlot (SlotConfig (SlotConfig, scSlotLength), currentSlot)
import Cardano.Node.Types
import Cardano.Protocol.Socket.Mock.Client qualified as Client
import Cardano.Protocol.Socket.Mock.Server qualified as Server
import Plutus.PAB.Arbitrary ()
import Plutus.PAB.Monitoring.Monitoring qualified as LM
healthcheck :: Monad m => m NoContent
healthcheck :: m NoContent
healthcheck = NoContent -> m NoContent
forall (f :: * -> *) a. Applicative f => a -> f a
pure NoContent
NoContent
consumeEventHistory :: MonadIO m => MVar AppState -> m [LogMessage PABServerLogMsg]
consumeEventHistory :: MVar AppState -> m [LogMessage PABServerLogMsg]
consumeEventHistory MVar AppState
stateVar =
IO [LogMessage PABServerLogMsg] -> m [LogMessage PABServerLogMsg]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [LogMessage PABServerLogMsg] -> m [LogMessage PABServerLogMsg])
-> IO [LogMessage PABServerLogMsg]
-> m [LogMessage PABServerLogMsg]
forall a b. (a -> b) -> a -> b
$ do
AppState
oldState <- MVar AppState -> IO AppState
forall a. MVar a -> IO a
takeMVar MVar AppState
stateVar
let events :: [LogMessage PABServerLogMsg]
events = Getting
[LogMessage PABServerLogMsg] AppState [LogMessage PABServerLogMsg]
-> AppState -> [LogMessage PABServerLogMsg]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
[LogMessage PABServerLogMsg] AppState [LogMessage PABServerLogMsg]
Lens' AppState [LogMessage PABServerLogMsg]
eventHistory AppState
oldState
let newState :: AppState
newState = ASetter
AppState
AppState
[LogMessage PABServerLogMsg]
[LogMessage PABServerLogMsg]
-> [LogMessage PABServerLogMsg] -> AppState -> AppState
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
AppState
AppState
[LogMessage PABServerLogMsg]
[LogMessage PABServerLogMsg]
Lens' AppState [LogMessage PABServerLogMsg]
eventHistory [LogMessage PABServerLogMsg]
forall a. Monoid a => a
mempty AppState
oldState
MVar AppState -> AppState -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar AppState
stateVar AppState
newState
[LogMessage PABServerLogMsg] -> IO [LogMessage PABServerLogMsg]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [LogMessage PABServerLogMsg]
events
addTx ::
( Member (LogMsg PABServerLogMsg) effs
, Member (Reader (Maybe Client.TxSendHandle)) effs
, MonadIO m
, LastMember m effs
)
=> C.Tx C.BabbageEra -> Eff effs NoContent
addTx :: Tx BabbageEra -> Eff effs NoContent
addTx Tx BabbageEra
tx = do
PABServerLogMsg -> Eff effs ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logInfo (PABServerLogMsg -> Eff effs ()) -> PABServerLogMsg -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ BlockEvent -> PABServerLogMsg
BlockOperation (BlockEvent -> PABServerLogMsg) -> BlockEvent -> PABServerLogMsg
forall a b. (a -> b) -> a -> b
$ Tx BabbageEra -> BlockEvent
NewTransaction Tx BabbageEra
tx
Maybe TxSendHandle
clientHandler <- Eff effs (Maybe TxSendHandle)
forall r (effs :: [* -> *]). Member (Reader r) effs => Eff effs r
Eff.ask
case Maybe TxSendHandle
clientHandler of
Maybe TxSendHandle
Nothing -> PABServerLogMsg -> Eff effs ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logError PABServerLogMsg
TxSendCalledWithoutMock
Just TxSendHandle
handler ->
IO () -> Eff effs ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Eff effs ()) -> IO () -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ TxSendHandle -> Tx BabbageEra -> IO ()
Client.queueTx TxSendHandle
handler Tx BabbageEra
tx
NoContent -> Eff effs NoContent
forall (f :: * -> *) a. Applicative f => a -> f a
pure NoContent
NoContent
runChainEffects ::
Trace IO PABServerLogMsg
-> Params
-> Maybe Client.TxSendHandle
-> MVar AppState
-> Eff (NodeServerEffects IO) a
-> IO ([LogMessage PABServerLogMsg], a)
runChainEffects :: Trace IO PABServerLogMsg
-> Params
-> Maybe TxSendHandle
-> MVar AppState
-> Eff (NodeServerEffects IO) a
-> IO ([LogMessage PABServerLogMsg], a)
runChainEffects Trace IO PABServerLogMsg
trace Params
params Maybe TxSendHandle
clientHandler MVar AppState
stateVar Eff (NodeServerEffects IO) a
eff = do
AppState
oldAppState <- 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
((a
a, [LogMessage PABServerLogMsg]
events), AppState
newState) <- IO ((a, [LogMessage PABServerLogMsg]), AppState)
-> IO ((a, [LogMessage PABServerLogMsg]), AppState)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
(IO ((a, [LogMessage PABServerLogMsg]), AppState)
-> IO ((a, [LogMessage PABServerLogMsg]), AppState))
-> IO ((a, [LogMessage PABServerLogMsg]), AppState)
-> IO ((a, [LogMessage PABServerLogMsg]), AppState)
forall a b. (a -> b) -> a -> b
$ Eff (NodeServerEffects IO) a -> Eff (NodeServerEffects IO) a
forall (effs :: [* -> *]) b.
FindElem ChainControlEffect effs =>
Eff effs b -> Eff effs b
processBlock Eff (NodeServerEffects IO) a
eff
Eff (NodeServerEffects IO) a
-> (Eff (NodeServerEffects IO) a
-> Eff
'[State MockNodeServerChainState, LogMsg PABServerLogMsg,
Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
a)
-> Eff
'[State MockNodeServerChainState, LogMsg PABServerLogMsg,
Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
a
forall a b. a -> (a -> b) -> b
& Eff (NodeServerEffects IO) a
-> Eff
'[State MockNodeServerChainState, LogMsg PABServerLogMsg,
Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
a
runChain
Eff
'[State MockNodeServerChainState, LogMsg PABServerLogMsg,
Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
a
-> (Eff
'[State MockNodeServerChainState, LogMsg PABServerLogMsg,
Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
a
-> Eff
'[LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
a)
-> Eff
'[LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
a
forall a b. a -> (a -> b) -> b
& Eff
'[State MockNodeServerChainState, LogMsg PABServerLogMsg,
Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
a
-> Eff
'[LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
a
forall x.
Eff
'[State MockNodeServerChainState, LogMsg PABServerLogMsg,
Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
x
-> Eff
'[LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
x
mergeState
Eff
'[LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
a
-> (Eff
'[LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
a
-> Eff
'[Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
(a, [LogMessage PABServerLogMsg]))
-> Eff
'[Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
(a, [LogMessage PABServerLogMsg])
forall a b. a -> (a -> b) -> b
& Eff
'[LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
a
-> Eff
'[Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
(a, [LogMessage PABServerLogMsg])
forall a.
Eff
'[LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
a
-> Eff
'[Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
(a, [LogMessage PABServerLogMsg])
toWriter
Eff
'[Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
(a, [LogMessage PABServerLogMsg])
-> (Eff
'[Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
(a, [LogMessage PABServerLogMsg])
-> Eff
'[LogMsg PABServerLogMsg, IO]
((a, [LogMessage PABServerLogMsg]), AppState))
-> Eff
'[LogMsg PABServerLogMsg, IO]
((a, [LogMessage PABServerLogMsg]), AppState)
forall a b. a -> (a -> b) -> b
& AppState
-> Eff
'[Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
(a, [LogMessage PABServerLogMsg])
-> Eff
'[LogMsg PABServerLogMsg, IO]
((a, [LogMessage PABServerLogMsg]), AppState)
runReaders AppState
oldAppState
Eff
'[LogMsg PABServerLogMsg, IO]
((a, [LogMessage PABServerLogMsg]), AppState)
-> (Eff
'[LogMsg PABServerLogMsg, IO]
((a, [LogMessage PABServerLogMsg]), AppState)
-> Eff '[IO] ((a, [LogMessage PABServerLogMsg]), AppState))
-> Eff '[IO] ((a, [LogMessage PABServerLogMsg]), AppState)
forall a b. a -> (a -> b) -> b
& (LogMsg PABServerLogMsg ~> Eff '[IO])
-> Eff '[LogMsg PABServerLogMsg, IO] ~> Eff '[IO]
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret (Trace IO PABServerLogMsg -> LogMsg PABServerLogMsg ~> Eff '[IO]
forall a (m :: * -> *) (effs :: [* -> *]).
(LastMember m effs, MonadIO m) =>
Trace m a -> LogMsg a ~> Eff effs
LM.handleLogMsgTrace Trace IO PABServerLogMsg
trace)
Eff '[IO] ((a, [LogMessage PABServerLogMsg]), AppState)
-> (Eff '[IO] ((a, [LogMessage PABServerLogMsg]), AppState)
-> IO ((a, [LogMessage PABServerLogMsg]), AppState))
-> IO ((a, [LogMessage PABServerLogMsg]), AppState)
forall a b. a -> (a -> b) -> b
& Eff '[IO] ((a, [LogMessage PABServerLogMsg]), AppState)
-> IO ((a, [LogMessage PABServerLogMsg]), AppState)
forall (m :: * -> *) a. Monad m => Eff '[m] a -> m a
runM
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
newState
([LogMessage PABServerLogMsg], a)
-> IO ([LogMessage PABServerLogMsg], a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([LogMessage PABServerLogMsg]
events, a
a)
where
processBlock :: Eff effs b -> Eff effs b
processBlock Eff effs b
e = Eff effs b
e Eff effs b -> (b -> Eff effs b) -> Eff effs b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \b
r -> Eff effs Block
forall (effs :: [* -> *]).
Member ChainControlEffect effs =>
Eff effs Block
Chain.processBlock Eff effs Block -> Eff effs b -> Eff effs b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> Eff effs b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
r
runChain :: Eff (NodeServerEffects IO) a
-> Eff
'[State MockNodeServerChainState, LogMsg PABServerLogMsg,
Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
a
runChain = (LogMsg ChainEvent
~> Eff
'[State MockNodeServerChainState, LogMsg PABServerLogMsg,
Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO])
-> Eff
'[LogMsg ChainEvent, State MockNodeServerChainState,
LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
~> Eff
'[State MockNodeServerChainState, LogMsg PABServerLogMsg,
Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret ((ChainEvent -> PABServerLogMsg)
-> LogMsg ChainEvent
~> Eff
'[State MockNodeServerChainState, LogMsg PABServerLogMsg,
Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
forall a b (effs :: [* -> *]).
Member (LogMsg b) effs =>
(a -> b) -> LogMsg a ~> Eff effs
mapLog ChainEvent -> PABServerLogMsg
ProcessingChainEvent)
(Eff
'[LogMsg ChainEvent, State MockNodeServerChainState,
LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
a
-> Eff
'[State MockNodeServerChainState, LogMsg PABServerLogMsg,
Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
a)
-> (Eff (NodeServerEffects IO) a
-> Eff
'[LogMsg ChainEvent, State MockNodeServerChainState,
LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
a)
-> Eff (NodeServerEffects IO) a
-> Eff
'[State MockNodeServerChainState, LogMsg PABServerLogMsg,
Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChainEffect
~> Eff
'[LogMsg ChainEvent, State MockNodeServerChainState,
LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO])
-> Eff
'[ChainEffect, State MockNodeServerChainState,
LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
~> Eff
'[LogMsg ChainEvent, State MockNodeServerChainState,
LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
forall (f :: * -> *) (g :: * -> *) (effs :: [* -> *]).
(f ~> Eff (g : effs)) -> Eff (f : effs) ~> Eff (g : effs)
reinterpret (Params
-> ChainEffect
~> Eff
'[LogMsg ChainEvent, State MockNodeServerChainState,
LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
forall (effs :: [* -> *]).
Member (State MockNodeServerChainState) effs =>
Params -> ChainEffect ~> Eff effs
handleChain Params
params)
(Eff
'[ChainEffect, State MockNodeServerChainState,
LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
a
-> Eff
'[LogMsg ChainEvent, State MockNodeServerChainState,
LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
a)
-> (Eff (NodeServerEffects IO) a
-> Eff
'[ChainEffect, State MockNodeServerChainState,
LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
a)
-> Eff (NodeServerEffects IO) a
-> Eff
'[LogMsg ChainEvent, State MockNodeServerChainState,
LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogMsg ChainEvent
~> Eff
'[ChainEffect, State MockNodeServerChainState,
LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO])
-> Eff
'[LogMsg ChainEvent, ChainEffect, State MockNodeServerChainState,
LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
~> Eff
'[ChainEffect, State MockNodeServerChainState,
LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret ((ChainEvent -> PABServerLogMsg)
-> LogMsg ChainEvent
~> Eff
'[ChainEffect, State MockNodeServerChainState,
LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
forall a b (effs :: [* -> *]).
Member (LogMsg b) effs =>
(a -> b) -> LogMsg a ~> Eff effs
mapLog ChainEvent -> PABServerLogMsg
ProcessingChainEvent)
(Eff
'[LogMsg ChainEvent, ChainEffect, State MockNodeServerChainState,
LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
a
-> Eff
'[ChainEffect, State MockNodeServerChainState,
LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
a)
-> (Eff (NodeServerEffects IO) a
-> Eff
'[LogMsg ChainEvent, ChainEffect, State MockNodeServerChainState,
LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
a)
-> Eff (NodeServerEffects IO) a
-> Eff
'[ChainEffect, State MockNodeServerChainState,
LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChainControlEffect
~> Eff
'[LogMsg ChainEvent, ChainEffect, State MockNodeServerChainState,
LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO])
-> Eff (NodeServerEffects IO)
~> Eff
'[LogMsg ChainEvent, ChainEffect, State MockNodeServerChainState,
LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
forall (f :: * -> *) (g :: * -> *) (effs :: [* -> *]).
(f ~> Eff (g : effs)) -> Eff (f : effs) ~> Eff (g : effs)
reinterpret (Params
-> ChainControlEffect
~> Eff
'[LogMsg ChainEvent, ChainEffect, State MockNodeServerChainState,
LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
forall (effs :: [* -> *]) (m :: * -> *).
(Member (State MockNodeServerChainState) effs,
Member (LogMsg ChainEvent) effs, LastMember m effs, MonadIO m) =>
Params -> ChainControlEffect ~> Eff effs
handleControlChain Params
params)
mergeState :: Eff
'[State MockNodeServerChainState, LogMsg PABServerLogMsg,
Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
x
-> Eff
'[LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
x
mergeState = (State MockNodeServerChainState
~> Eff
'[LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO])
-> forall x.
Eff
'[State MockNodeServerChainState, LogMsg PABServerLogMsg,
Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
x
-> Eff
'[LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
x
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret (Lens' AppState MockNodeServerChainState
-> State MockNodeServerChainState
~> Eff
'[LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
forall s2 (effs :: [* -> *]) s1.
Member (State s2) effs =>
Lens' s2 s1 -> State s1 ~> Eff effs
handleZoomedState Lens' AppState MockNodeServerChainState
chainState)
toWriter :: Eff
'[LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
a
-> Eff
'[Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
(a, [LogMessage PABServerLogMsg])
toWriter = Eff
'[Writer [LogMessage PABServerLogMsg], Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
a
-> Eff
'[Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
(a, [LogMessage PABServerLogMsg])
forall w (effs :: [* -> *]) a.
Monoid w =>
Eff (Writer w : effs) a -> Eff effs (a, w)
Eff.runWriter (Eff
'[Writer [LogMessage PABServerLogMsg], Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
a
-> Eff
'[Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
(a, [LogMessage PABServerLogMsg]))
-> (Eff
'[LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
a
-> Eff
'[Writer [LogMessage PABServerLogMsg], Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
a)
-> Eff
'[LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
a
-> Eff
'[Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
(a, [LogMessage PABServerLogMsg])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogMsg PABServerLogMsg
~> Eff
'[Writer [LogMessage PABServerLogMsg], Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO])
-> Eff
'[LogMsg PABServerLogMsg, Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
~> Eff
'[Writer [LogMessage PABServerLogMsg], Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
forall (f :: * -> *) (g :: * -> *) (effs :: [* -> *]).
(f ~> Eff (g : effs)) -> Eff (f : effs) ~> Eff (g : effs)
reinterpret (AReview [LogMessage PABServerLogMsg] (LogMessage PABServerLogMsg)
-> LogMsg PABServerLogMsg
~> Eff
'[Writer [LogMessage PABServerLogMsg], Reader (Maybe TxSendHandle),
State AppState, LogMsg PABServerLogMsg, IO]
forall a w (effs :: [* -> *]).
Member (Writer w) effs =>
AReview w (LogMessage a) -> LogMsg a ~> Eff effs
handleLogWriter @PABServerLogMsg @[LogMessage PABServerLogMsg] ((LogMessage PABServerLogMsg -> [LogMessage PABServerLogMsg])
-> AReview
[LogMessage PABServerLogMsg] (LogMessage PABServerLogMsg)
forall (p :: * -> * -> *) (f :: * -> *) b t s a.
(Profunctor p, Bifunctor p, Functor f) =>
(b -> t) -> Optic p f s t a b
unto LogMessage PABServerLogMsg -> [LogMessage PABServerLogMsg]
forall (m :: * -> *) a. Monad m => a -> m a
return))
runReaders :: AppState
-> Eff
'[Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
(a, [LogMessage PABServerLogMsg])
-> Eff
'[LogMsg PABServerLogMsg, IO]
((a, [LogMessage PABServerLogMsg]), AppState)
runReaders AppState
s = AppState
-> Eff
'[State AppState, LogMsg PABServerLogMsg, IO]
(a, [LogMessage PABServerLogMsg])
-> Eff
'[LogMsg PABServerLogMsg, IO]
((a, [LogMessage PABServerLogMsg]), AppState)
forall s (effs :: [* -> *]) a.
s -> Eff (State s : effs) a -> Eff effs (a, s)
Eff.runState AppState
s (Eff
'[State AppState, LogMsg PABServerLogMsg, IO]
(a, [LogMessage PABServerLogMsg])
-> Eff
'[LogMsg PABServerLogMsg, IO]
((a, [LogMessage PABServerLogMsg]), AppState))
-> (Eff
'[Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
(a, [LogMessage PABServerLogMsg])
-> Eff
'[State AppState, LogMsg PABServerLogMsg, IO]
(a, [LogMessage PABServerLogMsg]))
-> Eff
'[Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
(a, [LogMessage PABServerLogMsg])
-> Eff
'[LogMsg PABServerLogMsg, IO]
((a, [LogMessage PABServerLogMsg]), AppState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe TxSendHandle
-> Eff
'[Reader (Maybe TxSendHandle), State AppState,
LogMsg PABServerLogMsg, IO]
(a, [LogMessage PABServerLogMsg])
-> Eff
'[State AppState, LogMsg PABServerLogMsg, IO]
(a, [LogMessage PABServerLogMsg])
forall r (effs :: [* -> *]) a.
r -> Eff (Reader r : effs) a -> Eff effs a
Eff.runReader Maybe TxSendHandle
clientHandler
processChainEffects ::
Trace IO PABServerLogMsg
-> Params
-> Maybe Client.TxSendHandle
-> MVar AppState
-> Eff (NodeServerEffects IO) a
-> IO a
processChainEffects :: Trace IO PABServerLogMsg
-> Params
-> Maybe TxSendHandle
-> MVar AppState
-> Eff (NodeServerEffects IO) a
-> IO a
processChainEffects Trace IO PABServerLogMsg
trace Params
params Maybe TxSendHandle
clientHandler MVar AppState
stateVar Eff (NodeServerEffects IO) a
eff = do
([LogMessage PABServerLogMsg]
events, a
result) <- IO ([LogMessage PABServerLogMsg], a)
-> IO ([LogMessage PABServerLogMsg], a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([LogMessage PABServerLogMsg], a)
-> IO ([LogMessage PABServerLogMsg], a))
-> IO ([LogMessage PABServerLogMsg], a)
-> IO ([LogMessage PABServerLogMsg], a)
forall a b. (a -> b) -> a -> b
$ Trace IO PABServerLogMsg
-> Params
-> Maybe TxSendHandle
-> MVar AppState
-> Eff (NodeServerEffects IO) a
-> IO ([LogMessage PABServerLogMsg], a)
forall a.
Trace IO PABServerLogMsg
-> Params
-> Maybe TxSendHandle
-> MVar AppState
-> Eff (NodeServerEffects IO) a
-> IO ([LogMessage PABServerLogMsg], a)
runChainEffects Trace IO PABServerLogMsg
trace Params
params Maybe TxSendHandle
clientHandler MVar AppState
stateVar Eff (NodeServerEffects IO) a
eff
Trace IO PABServerLogMsg -> Eff '[LogMsg PABServerLogMsg, IO] ~> IO
forall (m :: * -> *) l.
MonadIO m =>
Trace m l -> Eff '[LogMsg l, m] ~> m
LM.runLogEffects Trace IO PABServerLogMsg
trace (Eff '[LogMsg PABServerLogMsg, IO] () -> IO ())
-> Eff '[LogMsg PABServerLogMsg, IO] () -> IO ()
forall a b. (a -> b) -> a -> b
$ (LogMessage PABServerLogMsg
-> Eff '[LogMsg PABServerLogMsg, IO] ())
-> [LogMessage PABServerLogMsg]
-> Eff '[LogMsg PABServerLogMsg, IO] ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\(LogMessage LogLevel
_ PABServerLogMsg
chainEvent) -> PABServerLogMsg -> Eff '[LogMsg PABServerLogMsg, IO] ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logDebug PABServerLogMsg
chainEvent) [LogMessage PABServerLogMsg]
events
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 AppState) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_
MVar AppState
stateVar
(\AppState
state -> AppState -> IO AppState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AppState -> IO AppState) -> AppState -> IO AppState
forall a b. (a -> b) -> a -> b
$ ASetter
AppState
AppState
[LogMessage PABServerLogMsg]
[LogMessage PABServerLogMsg]
-> ([LogMessage PABServerLogMsg] -> [LogMessage PABServerLogMsg])
-> AppState
-> AppState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
AppState
AppState
[LogMessage PABServerLogMsg]
[LogMessage PABServerLogMsg]
Lens' AppState [LogMessage PABServerLogMsg]
eventHistory ([LogMessage PABServerLogMsg]
-> [LogMessage PABServerLogMsg] -> [LogMessage PABServerLogMsg]
forall a. Monoid a => a -> a -> a
mappend [LogMessage PABServerLogMsg]
events) AppState
state)
a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result
slotCoordinator ::
SlotConfig
-> Server.ServerHandler
-> IO a
slotCoordinator :: SlotConfig -> ServerHandler -> IO a
slotCoordinator sc :: SlotConfig
sc@SlotConfig{Integer
scSlotLength :: Integer
scSlotLength :: SlotConfig -> Integer
scSlotLength} ServerHandler
serverHandler = do
IO () -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO a) -> IO () -> IO a
forall a b. (a -> b) -> a -> b
$ do
IO Block -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Block -> IO ()) -> IO Block -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerHandler -> IO Block
forall (m :: * -> *). MonadIO m => ServerHandler -> m Block
Server.processBlock ServerHandler
serverHandler
Slot
newSlot <- SlotConfig -> IO Slot
currentSlot SlotConfig
sc
IO Slot -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Slot -> IO ()) -> IO Slot -> IO ()
forall a b. (a -> b) -> a -> b
$ (Slot -> Slot) -> ServerHandler -> IO Slot
forall (m :: * -> *).
MonadIO m =>
(Slot -> Slot) -> ServerHandler -> m Slot
Server.modifySlot (Slot -> Slot -> Slot
forall a b. a -> b -> a
const Slot
newSlot) ServerHandler
serverHandler
IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay
(Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
(Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Millisecond -> Integer
forall a. TimeUnit a => a -> Integer
toMicroseconds (Integer -> Millisecond
forall a. Num a => Integer -> a
fromInteger Integer
scSlotLength :: Millisecond)