{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE UndecidableInstances #-}

module Hydra.API.Server where

import Hydra.Prelude hiding (catMaybes, map, mapM_, seq, state)

import Cardano.Ledger.Core (PParams)
import Conduit (mapM_C, runConduitRes, (.|))
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
import Control.Concurrent.STM.TChan (newBroadcastTChanIO, writeTChan)
import Control.Exception (IOException)
import Data.Conduit.List (catMaybes, mapAccum)
import Data.Map.Strict qualified as Map
import Hydra.API.APIServerLog (APIServerLog (..))
import Hydra.API.ClientInput (ClientInput)
import Hydra.API.HTTPServer (httpApp)
import Hydra.API.Projection (Projection (..), mkProjection)
import Hydra.API.ServerOutput (
  ClientMessage,
  CommitInfo (..),
  NetworkInfo (..),
  ServerOutput (..),
  TimedServerOutput (..),
  fanoutProgressMode,
 )
import Hydra.API.ServerOutputFilter (
  ServerOutputFilter,
 )
import Hydra.API.WSServer (wsApp)
import Hydra.Cardano.Api (LedgerEra)
import Hydra.Chain (Chain (..))
import Hydra.Chain.ChainState (ChainStateType, IsChainState)
import Hydra.Chain.Direct.State ()
import Hydra.Config (renderConfig)
import Hydra.Events (EventSink (..), EventSource (..), mkEventSink)
import Hydra.HeadLogic (
  CoordinatedHeadState (..),
  HeadState (..),
  OpenState (..),
  SeenSnapshot (..),
  aggregateNodeState,
 )
import Hydra.HeadLogic.Outcome qualified as StateChanged
import Hydra.HeadLogic.StateEvent (StateEvent (..))
import Hydra.Logging (Tracer, traceWith)
import Hydra.Network (IP, PortNumber)
import Hydra.Node.ApiTransactionTimeout (ApiTransactionTimeout)
import Hydra.Node.Environment (Environment)
import Hydra.Node.State (Deposit (..), NodeState (..), initNodeState)
import Hydra.Options (RunOptions)
import Hydra.Tx (IsTx (..), Party, Snapshot, txId, utxoFromTx)
import Network.HTTP.Types (status500)
import Network.Wai (responseLBS)
import Network.Wai.Handler.Warp (
  defaultSettings,
  runSettings,
  setBeforeMainLoop,
  setHost,
  setOnException,
  setOnExceptionResponse,
  setPort,
  setTimeout,
 )
import Network.Wai.Handler.WarpTLS (runTLS, tlsSettings)
import Network.Wai.Handler.WebSockets (websocketsOr)
import Network.Wai.Middleware.Cors (simpleCors)
import Network.WebSockets (
  defaultConnectionOptions,
 )

-- | Handle to provide a means for sending server outputs to clients.
newtype Server tx m = Server
  { forall tx (m :: * -> *). Server tx m -> ClientMessage tx -> m ()
sendMessage :: ClientMessage tx -> m ()
  -- ^ Send some output to all connected clients.
  }

data APIServerConfig = APIServerConfig
  { APIServerConfig -> IP
host :: IP
  , APIServerConfig -> PortNumber
port :: PortNumber
  , APIServerConfig -> Maybe FilePath
tlsCertPath :: Maybe FilePath
  , APIServerConfig -> Maybe FilePath
tlsKeyPath :: Maybe FilePath
  , APIServerConfig -> ApiTransactionTimeout
apiTransactionTimeout :: ApiTransactionTimeout
  }

withAPIServer ::
  forall tx.
  IsChainState tx =>
  APIServerConfig ->
  RunOptions ->
  Environment ->
  Party ->
  EventSource (StateEvent tx) IO ->
  Tracer IO APIServerLog ->
  ChainStateType tx ->
  Chain tx IO ->
  PParams LedgerEra ->
  ServerOutputFilter tx ->
  (ClientInput tx -> IO ()) ->
  ((EventSink (StateEvent tx) IO, Server tx IO) -> IO ()) ->
  IO ()
withAPIServer :: forall tx.
IsChainState tx =>
APIServerConfig
-> RunOptions
-> Environment
-> Party
-> EventSource (StateEvent tx) IO
-> Tracer IO APIServerLog
-> ChainStateType tx
-> Chain tx IO
-> PParams LedgerEra
-> ServerOutputFilter tx
-> (ClientInput tx -> IO ())
-> ((EventSink (StateEvent tx) IO, Server tx IO) -> IO ())
-> IO ()
withAPIServer APIServerConfig
config RunOptions
runOptions Environment
env Party
party EventSource (StateEvent tx) IO
eventSource Tracer IO APIServerLog
tracer ChainStateType tx
initialChainState Chain tx IO
chain PParams LedgerEra
pparams ServerOutputFilter tx
serverOutputFilter ClientInput tx -> IO ()
callback (EventSink (StateEvent tx) IO, Server tx IO) -> IO ()
action =
  (IOException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle IOException -> IO ()
onIOException (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    TChan (Either (TimedServerOutput tx) (ClientMessage tx))
responseChannel <- IO (TChan (Either (TimedServerOutput tx) (ClientMessage tx)))
forall a. IO (TChan a)
newBroadcastTChanIO
    -- Initialize our read models from stored events
    -- NOTE: we do not keep the stored events around in memory
    Projection STM (StateChanged tx) (NodeState tx)
nodeStateP <- FilePath
-> NodeState tx
-> (NodeState tx -> StateChanged tx -> NodeState tx)
-> IO (Projection (STM IO) (StateChanged tx) (NodeState tx))
forall (m :: * -> *) model event.
MonadLabelledSTM m =>
FilePath
-> model
-> (model -> event -> model)
-> m (Projection (STM m) event model)
mkProjection FilePath
"nodeStateP" (ChainStateType tx -> NodeState tx
forall tx. IsChainState tx => ChainStateType tx -> NodeState tx
initNodeState ChainStateType tx
initialChainState) NodeState tx -> StateChanged tx -> NodeState tx
forall tx.
IsChainState tx =>
NodeState tx -> StateChanged tx -> NodeState tx
aggregateNodeState
    -- XXX: We never subscribe to changes of commitInfoP et al directly so a
    -- single read model and normal functions mapping from HeadState ->
    -- CommitInfo etc. would suffice and are less fragile
    Projection STM (StateChanged tx) CommitInfo
commitInfoP <- FilePath
-> CommitInfo
-> (CommitInfo -> StateChanged tx -> CommitInfo)
-> IO (Projection (STM IO) (StateChanged tx) CommitInfo)
forall (m :: * -> *) model event.
MonadLabelledSTM m =>
FilePath
-> model
-> (model -> event -> model)
-> m (Projection (STM m) event model)
mkProjection FilePath
"commitInfoP" CommitInfo
CannotCommit CommitInfo -> StateChanged tx -> CommitInfo
forall tx. CommitInfo -> StateChanged tx -> CommitInfo
projectCommitInfo
    Projection STM (StateChanged tx) [TxIdType tx]
pendingDepositsP <- FilePath
-> [TxIdType tx]
-> ([TxIdType tx] -> StateChanged tx -> [TxIdType tx])
-> IO (Projection (STM IO) (StateChanged tx) [TxIdType tx])
forall (m :: * -> *) model event.
MonadLabelledSTM m =>
FilePath
-> model
-> (model -> event -> model)
-> m (Projection (STM m) event model)
mkProjection FilePath
"pendingDepositsP" [] [TxIdType tx] -> StateChanged tx -> [TxIdType tx]
forall tx.
IsTx tx =>
[TxIdType tx] -> StateChanged tx -> [TxIdType tx]
projectPendingDeposits
    Projection STM (StateChanged tx) NetworkInfo
networkInfoP <- FilePath
-> NetworkInfo
-> (NetworkInfo -> StateChanged tx -> NetworkInfo)
-> IO (Projection (STM IO) (StateChanged tx) NetworkInfo)
forall (m :: * -> *) model event.
MonadLabelledSTM m =>
FilePath
-> model
-> (model -> event -> model)
-> m (Projection (STM m) event model)
mkProjection FilePath
"networkInfoP" (Bool -> Map Host Bool -> NetworkInfo
NetworkInfo Bool
False Map Host Bool
forall a. Monoid a => a
mempty) NetworkInfo -> StateChanged tx -> NetworkInfo
forall tx. NetworkInfo -> StateChanged tx -> NetworkInfo
projectNetworkInfo
    -- Track seen snapshots across the event stream history so that SnapshotConfirmed
    -- events (which may omit the snapshot) can be reconstructed for clients.
    let historyTimedOutputs :: ConduitT () (TimedServerOutput tx) (ResourceT IO) ()
historyTimedOutputs =
          ConduitT () (StateEvent tx) (ResourceT IO) ()
HasEventId (StateEvent tx) =>
ConduitT () (StateEvent tx) (ResourceT IO) ()
sourceEvents
            ConduitT () (StateEvent tx) (ResourceT IO) ()
-> ConduitT
     (StateEvent tx) (TimedServerOutput tx) (ResourceT IO) ()
-> ConduitT () (TimedServerOutput tx) (ResourceT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT
  (StateEvent tx)
  (Maybe (TimedServerOutput tx))
  (ResourceT IO)
  (Maybe (Snapshot tx))
-> ConduitT
     (StateEvent tx) (Maybe (TimedServerOutput tx)) (ResourceT IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ((StateEvent tx
 -> Maybe (Snapshot tx)
 -> (Maybe (Snapshot tx), Maybe (TimedServerOutput tx)))
-> Maybe (Snapshot tx)
-> ConduitT
     (StateEvent tx)
     (Maybe (TimedServerOutput tx))
     (ResourceT IO)
     (Maybe (Snapshot tx))
forall (m :: * -> *) a s b.
Monad m =>
(a -> s -> (s, b)) -> s -> ConduitT a b m s
mapAccum (\StateEvent tx
ev Maybe (Snapshot tx)
mSn -> (Maybe (Snapshot tx) -> StateChanged tx -> Maybe (Snapshot tx)
forall tx.
Maybe (Snapshot tx) -> StateChanged tx -> Maybe (Snapshot tx)
updateSeenSnapshot Maybe (Snapshot tx)
mSn (StateEvent tx -> StateChanged tx
forall tx. StateEvent tx -> StateChanged tx
stateChanged StateEvent tx
ev), Maybe (Snapshot tx)
-> StateEvent tx -> Maybe (TimedServerOutput tx)
forall tx.
IsChainState tx =>
Maybe (Snapshot tx)
-> StateEvent tx -> Maybe (TimedServerOutput tx)
mkTimedServerOutputFromStateEvent Maybe (Snapshot tx)
mSn StateEvent tx
ev)) Maybe (Snapshot tx)
forall a. Maybe a
Nothing)
            ConduitT
  (StateEvent tx) (Maybe (TimedServerOutput tx)) (ResourceT IO) ()
-> ConduitT
     (Maybe (TimedServerOutput tx))
     (TimedServerOutput tx)
     (ResourceT IO)
     ()
-> ConduitT
     (StateEvent tx) (TimedServerOutput tx) (ResourceT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT
  (Maybe (TimedServerOutput tx))
  (TimedServerOutput tx)
  (ResourceT IO)
  ()
forall (m :: * -> *) a. Monad m => ConduitT (Maybe a) a m ()
catMaybes
    ()
_ <-
      ConduitT () Void (ResourceT IO) () -> IO ()
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes (ConduitT () Void (ResourceT IO) () -> IO ())
-> ConduitT () Void (ResourceT IO) () -> IO ()
forall a b. (a -> b) -> a -> b
$
        ConduitT () (StateEvent tx) (ResourceT IO) ()
HasEventId (StateEvent tx) =>
ConduitT () (StateEvent tx) (ResourceT IO) ()
sourceEvents
          ConduitT () (StateEvent tx) (ResourceT IO) ()
-> ConduitT (StateEvent tx) Void (ResourceT IO) ()
-> ConduitT () Void (ResourceT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (StateEvent tx -> ResourceT IO ())
-> ConduitT (StateEvent tx) Void (ResourceT IO) ()
forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
mapM_C
            ( \StateEvent{StateChanged tx
$sel:stateChanged:StateEvent :: forall tx. StateEvent tx -> StateChanged tx
stateChanged :: StateChanged tx
stateChanged} ->
                IO () -> ResourceT IO ()
forall (m :: * -> *) a. Monad m => m a -> ResourceT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ResourceT IO ()) -> IO () -> ResourceT IO ()
forall a b. (a -> b) -> a -> b
$ STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO () -> IO ()) -> STM IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                  Projection STM (StateChanged tx) (NodeState tx)
-> StateChanged tx -> STM ()
forall (stm :: * -> *) event model.
Projection stm event model -> event -> stm ()
update Projection STM (StateChanged tx) (NodeState tx)
nodeStateP StateChanged tx
stateChanged
                  Projection STM (StateChanged tx) CommitInfo
-> StateChanged tx -> STM ()
forall (stm :: * -> *) event model.
Projection stm event model -> event -> stm ()
update Projection STM (StateChanged tx) CommitInfo
commitInfoP StateChanged tx
stateChanged
                  Projection STM (StateChanged tx) [TxIdType tx]
-> StateChanged tx -> STM ()
forall (stm :: * -> *) event model.
Projection stm event model -> event -> stm ()
update Projection STM (StateChanged tx) [TxIdType tx]
pendingDepositsP StateChanged tx
stateChanged
                  Projection STM (StateChanged tx) NetworkInfo
-> StateChanged tx -> STM ()
forall (stm :: * -> *) event model.
Projection stm event model -> event -> stm ()
update Projection STM (StateChanged tx) NetworkInfo
networkInfoP StateChanged tx
stateChanged
            )
    (IO ()
notifyServerRunning, IO ()
waitForServerRunning) <- IO (IO (), IO ())
setupServerNotification

    let serverSettings :: Settings
serverSettings =
          Settings
defaultSettings
            Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
& HostPreference -> Settings -> Settings
setHost (FilePath -> HostPreference
forall a. IsString a => FilePath -> a
fromString (FilePath -> HostPreference) -> FilePath -> HostPreference
forall a b. (a -> b) -> a -> b
$ IP -> FilePath
forall b a. (Show a, IsString b) => a -> b
show IP
host)
            Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
& Port -> Settings -> Settings
setPort (PortNumber -> Port
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port)
            Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
& Port -> Settings -> Settings
setTimeout Port
180
            Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
& (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings
setOnException (\Maybe Request
_ SomeException
e -> Tracer IO APIServerLog -> APIServerLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO APIServerLog
tracer (APIServerLog -> IO ()) -> APIServerLog -> IO ()
forall a b. (a -> b) -> a -> b
$ APIConnectionError{$sel:reason:APIServerStarted :: FilePath
reason = SomeException -> FilePath
forall b a. (Show a, IsString b) => a -> b
show SomeException
e})
            Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
& (SomeException -> Response) -> Settings -> Settings
setOnExceptionResponse (Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status500 [] (ByteString -> Response)
-> (SomeException -> ByteString) -> SomeException -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> ByteString
forall b a. (Show a, IsString b) => a -> b
show)
            Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
& IO () -> Settings -> Settings
setBeforeMainLoop IO ()
notifyServerRunning
    (FilePath, IO ()) -> (FilePath, IO ()) -> IO ()
forall (m :: * -> *) a b.
MonadAsync m =>
(FilePath, m a) -> (FilePath, m b) -> m ()
raceLabelled_
      ( FilePath
"api-server"
      , do
          Tracer IO APIServerLog -> APIServerLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO APIServerLog
tracer (PortNumber -> APIServerLog
APIServerStarted PortNumber
port)
          Settings -> Application -> IO ()
startServer Settings
serverSettings
            (Application -> IO ())
-> (Application -> Application) -> Application -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Application -> Application
simpleCors
            (Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$ ConnectionOptions -> ServerApp -> Application -> Application
websocketsOr
              ConnectionOptions
defaultConnectionOptions
              (Environment
-> Party
-> Tracer IO APIServerLog
-> Chain tx IO
-> ConduitT () (TimedServerOutput tx) (ResourceT IO) ()
-> (ClientInput tx -> IO ())
-> Projection STM (StateChanged tx) (NodeState tx)
-> Projection STM (StateChanged tx) NetworkInfo
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> ServerOutputFilter tx
-> ServerApp
forall tx.
IsChainState tx =>
Environment
-> Party
-> Tracer IO APIServerLog
-> Chain tx IO
-> ConduitT () (TimedServerOutput tx) (ResourceT IO) ()
-> (ClientInput tx -> IO ())
-> Projection STM (StateChanged tx) (NodeState tx)
-> Projection STM (StateChanged tx) NetworkInfo
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> ServerOutputFilter tx
-> ServerApp
wsApp Environment
env Party
party Tracer IO APIServerLog
tracer Chain tx IO
chain ConduitT () (TimedServerOutput tx) (ResourceT IO) ()
historyTimedOutputs ClientInput tx -> IO ()
callback Projection STM (StateChanged tx) (NodeState tx)
nodeStateP Projection STM (StateChanged tx) NetworkInfo
networkInfoP TChan (Either (TimedServerOutput tx) (ClientMessage tx))
responseChannel ServerOutputFilter tx
serverOutputFilter)
              ( Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Value
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (NodeState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> ApiTransactionTimeout
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Application
httpApp
                  Tracer IO APIServerLog
tracer
                  (RunOptions -> Value
renderConfig RunOptions
runOptions)
                  Chain tx IO
chain
                  Environment
env
                  PParams LedgerEra
pparams
                  (STM IO (NodeState tx) -> IO (NodeState tx)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO (NodeState tx) -> IO (NodeState tx))
-> STM IO (NodeState tx) -> IO (NodeState tx)
forall a b. (a -> b) -> a -> b
$ Projection STM (StateChanged tx) (NodeState tx)
-> STM (NodeState tx)
forall (stm :: * -> *) event model.
Projection stm event model -> stm model
getLatest Projection STM (StateChanged tx) (NodeState tx)
nodeStateP)
                  (STM IO CommitInfo -> IO CommitInfo
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO CommitInfo -> IO CommitInfo)
-> STM IO CommitInfo -> IO CommitInfo
forall a b. (a -> b) -> a -> b
$ Projection STM (StateChanged tx) CommitInfo -> STM CommitInfo
forall (stm :: * -> *) event model.
Projection stm event model -> stm model
getLatest Projection STM (StateChanged tx) CommitInfo
commitInfoP)
                  (STM IO [TxIdType tx] -> IO [TxIdType tx]
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO [TxIdType tx] -> IO [TxIdType tx])
-> STM IO [TxIdType tx] -> IO [TxIdType tx]
forall a b. (a -> b) -> a -> b
$ Projection STM (StateChanged tx) [TxIdType tx] -> STM [TxIdType tx]
forall (stm :: * -> *) event model.
Projection stm event model -> stm model
getLatest Projection STM (StateChanged tx) [TxIdType tx]
pendingDepositsP)
                  ClientInput tx -> IO ()
callback
                  (APIServerConfig -> ApiTransactionTimeout
apiTransactionTimeout APIServerConfig
config)
                  TChan (Either (TimedServerOutput tx) (ClientMessage tx))
responseChannel
              )
      )
      ( FilePath
"api-server-eventsink"
      , do
          IO ()
waitForServerRunning
          (EventSink (StateEvent tx) IO, Server tx IO) -> IO ()
action
            ( (HasEventId (StateEvent tx) => StateEvent tx -> IO ())
-> EventSink (StateEvent tx) IO
forall (m :: * -> *) e.
Monad m =>
(HasEventId e => e -> m ()) -> EventSink e m
mkEventSink
                ( \event :: StateEvent tx
event@StateEvent{StateChanged tx
$sel:stateChanged:StateEvent :: forall tx. StateEvent tx -> StateChanged tx
stateChanged :: StateChanged tx
stateChanged} -> do
                    -- Read the currently-seen snapshot BEFORE updating projections
                    Maybe (Snapshot tx)
mSeenSnapshot <- STM IO (Maybe (Snapshot tx)) -> IO (Maybe (Snapshot tx))
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO (Maybe (Snapshot tx)) -> IO (Maybe (Snapshot tx)))
-> STM IO (Maybe (Snapshot tx)) -> IO (Maybe (Snapshot tx))
forall a b. (a -> b) -> a -> b
$ NodeState tx -> Maybe (Snapshot tx)
forall tx. NodeState tx -> Maybe (Snapshot tx)
seenSnapshotOf (NodeState tx -> Maybe (Snapshot tx))
-> STM (NodeState tx) -> STM (Maybe (Snapshot tx))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Projection STM (StateChanged tx) (NodeState tx)
-> STM (NodeState tx)
forall (stm :: * -> *) event model.
Projection stm event model -> stm model
getLatest Projection STM (StateChanged tx) (NodeState tx)
nodeStateP
                    -- Update our read models
                    STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO () -> IO ()) -> STM IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                      Projection STM (StateChanged tx) (NodeState tx)
-> StateChanged tx -> STM ()
forall (stm :: * -> *) event model.
Projection stm event model -> event -> stm ()
update Projection STM (StateChanged tx) (NodeState tx)
nodeStateP StateChanged tx
stateChanged
                      Projection STM (StateChanged tx) CommitInfo
-> StateChanged tx -> STM ()
forall (stm :: * -> *) event model.
Projection stm event model -> event -> stm ()
update Projection STM (StateChanged tx) CommitInfo
commitInfoP StateChanged tx
stateChanged
                      Projection STM (StateChanged tx) [TxIdType tx]
-> StateChanged tx -> STM ()
forall (stm :: * -> *) event model.
Projection stm event model -> event -> stm ()
update Projection STM (StateChanged tx) [TxIdType tx]
pendingDepositsP StateChanged tx
stateChanged
                      Projection STM (StateChanged tx) NetworkInfo
-> StateChanged tx -> STM ()
forall (stm :: * -> *) event model.
Projection stm event model -> event -> stm ()
update Projection STM (StateChanged tx) NetworkInfo
networkInfoP StateChanged tx
stateChanged
                    -- Send to the client if it maps to a server output
                    case Maybe (Snapshot tx)
-> StateEvent tx -> Maybe (TimedServerOutput tx)
forall tx.
IsChainState tx =>
Maybe (Snapshot tx)
-> StateEvent tx -> Maybe (TimedServerOutput tx)
mkTimedServerOutputFromStateEvent Maybe (Snapshot tx)
mSeenSnapshot StateEvent tx
event of
                      Maybe (TimedServerOutput tx)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                      Just TimedServerOutput tx
timedOutput -> do
                        STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO () -> IO ()) -> STM IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Either (TimedServerOutput tx) (ClientMessage tx) -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan (Either (TimedServerOutput tx) (ClientMessage tx))
responseChannel (TimedServerOutput tx
-> Either (TimedServerOutput tx) (ClientMessage tx)
forall a b. a -> Either a b
Left TimedServerOutput tx
timedOutput)
                )
            , Server{$sel:sendMessage:Server :: ClientMessage tx -> IO ()
sendMessage = STM () -> IO ()
STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM () -> IO ())
-> (ClientMessage tx -> STM ()) -> ClientMessage tx -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> Either (TimedServerOutput tx) (ClientMessage tx) -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan (Either (TimedServerOutput tx) (ClientMessage tx))
responseChannel (Either (TimedServerOutput tx) (ClientMessage tx) -> STM ())
-> (ClientMessage tx
    -> Either (TimedServerOutput tx) (ClientMessage tx))
-> ClientMessage tx
-> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientMessage tx
-> Either (TimedServerOutput tx) (ClientMessage tx)
forall a b. b -> Either a b
Right}
            )
      )
 where
  APIServerConfig{IP
$sel:host:APIServerConfig :: APIServerConfig -> IP
host :: IP
host, PortNumber
$sel:port:APIServerConfig :: APIServerConfig -> PortNumber
port :: PortNumber
port, Maybe FilePath
$sel:tlsCertPath:APIServerConfig :: APIServerConfig -> Maybe FilePath
tlsCertPath :: Maybe FilePath
tlsCertPath, Maybe FilePath
$sel:tlsKeyPath:APIServerConfig :: APIServerConfig -> Maybe FilePath
tlsKeyPath :: Maybe FilePath
tlsKeyPath} = APIServerConfig
config

  EventSource{HasEventId (StateEvent tx) =>
ConduitT () (StateEvent tx) (ResourceT IO) ()
sourceEvents :: HasEventId (StateEvent tx) =>
ConduitT () (StateEvent tx) (ResourceT IO) ()
$sel:sourceEvents:EventSource :: forall e (m :: * -> *).
EventSource e m -> HasEventId e => ConduitT () e (ResourceT m) ()
sourceEvents} = EventSource (StateEvent tx) IO
eventSource

  startServer :: Settings -> Application -> IO ()
startServer Settings
settings Application
app =
    case (Maybe FilePath
tlsCertPath, Maybe FilePath
tlsKeyPath) of
      (Just FilePath
cert, Just FilePath
key) ->
        TLSSettings -> Settings -> Application -> IO ()
runTLS (FilePath -> FilePath -> TLSSettings
tlsSettings FilePath
cert FilePath
key) Settings
settings Application
app
      -- TODO: better error handling
      (Just FilePath
_, Maybe FilePath
Nothing) ->
        FilePath -> IO ()
forall (m :: * -> *) a. MonadIO m => FilePath -> m a
die FilePath
"TLS certificate provided without key"
      (Maybe FilePath
Nothing, Just FilePath
_) ->
        FilePath -> IO ()
forall (m :: * -> *) a. MonadIO m => FilePath -> m a
die FilePath
"TLS key provided without certificate"
      (Maybe FilePath, Maybe FilePath)
_ ->
        Settings -> Application -> IO ()
runSettings Settings
settings Application
app

  onIOException :: IOException -> IO ()
onIOException IOException
ioException =
    RunServerException -> IO ()
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO
      RunServerException
        { IOException
ioException :: IOException
$sel:ioException:RunServerException :: IOException
ioException
        , IP
host :: IP
$sel:host:RunServerException :: IP
host
        , PortNumber
port :: PortNumber
$sel:port:RunServerException :: PortNumber
port
        }

-- | An 'IOException' with more 'IP' and 'PortNumber' added as context.
data RunServerException = RunServerException
  { RunServerException -> IOException
ioException :: IOException
  , RunServerException -> IP
host :: IP
  , RunServerException -> PortNumber
port :: PortNumber
  }
  deriving stock (Port -> RunServerException -> ShowS
[RunServerException] -> ShowS
RunServerException -> FilePath
(Port -> RunServerException -> ShowS)
-> (RunServerException -> FilePath)
-> ([RunServerException] -> ShowS)
-> Show RunServerException
forall a.
(Port -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Port -> RunServerException -> ShowS
showsPrec :: Port -> RunServerException -> ShowS
$cshow :: RunServerException -> FilePath
show :: RunServerException -> FilePath
$cshowList :: [RunServerException] -> ShowS
showList :: [RunServerException] -> ShowS
Show)

instance Exception RunServerException

type NotifyServerRunning = IO ()

type WaitForServer = IO ()

-- | Setup notification and waiter to ensure that something only runs after the
-- server is actually listening.
setupServerNotification :: IO (NotifyServerRunning, WaitForServer)
setupServerNotification :: IO (IO (), IO ())
setupServerNotification = do
  MVar ()
mv <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  (IO (), IO ()) -> IO (IO (), IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
mv (), MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
mv)

-- | Defines the subset of 'StateEvent' that should be sent as 'TimedServerOutput' to clients.
-- The 'Maybe (Snapshot tx)' argument carries the snapshot currently being confirmed
-- (from the preceding 'SnapshotRequested' event), needed to reconstruct
-- 'SnapshotConfirmed' outputs when 'snapshot' is absent from the event.
mkTimedServerOutputFromStateEvent :: IsChainState tx => Maybe (Snapshot tx) -> StateEvent tx -> Maybe (TimedServerOutput tx)
mkTimedServerOutputFromStateEvent :: forall tx.
IsChainState tx =>
Maybe (Snapshot tx)
-> StateEvent tx -> Maybe (TimedServerOutput tx)
mkTimedServerOutputFromStateEvent Maybe (Snapshot tx)
mSeenSnapshot StateEvent tx
event =
  case StateChanged tx -> Maybe (ServerOutput tx)
mapStateChangedToServerOutput StateChanged tx
stateChanged of
    Maybe (ServerOutput tx)
Nothing -> Maybe (TimedServerOutput tx)
forall a. Maybe a
Nothing
    Just ServerOutput tx
output ->
      TimedServerOutput tx -> Maybe (TimedServerOutput tx)
forall a. a -> Maybe a
Just (TimedServerOutput tx -> Maybe (TimedServerOutput tx))
-> TimedServerOutput tx -> Maybe (TimedServerOutput tx)
forall a b. (a -> b) -> a -> b
$ TimedServerOutput{ServerOutput tx
output :: ServerOutput tx
$sel:output:TimedServerOutput :: ServerOutput tx
output, UTCTime
time :: UTCTime
$sel:time:TimedServerOutput :: UTCTime
time, $sel:seq:TimedServerOutput :: Natural
seq = EventId -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral EventId
eventId}
 where
  StateEvent{EventId
eventId :: EventId
$sel:eventId:StateEvent :: forall tx. StateEvent tx -> EventId
eventId, UTCTime
time :: UTCTime
$sel:time:StateEvent :: forall tx. StateEvent tx -> UTCTime
time, StateChanged tx
$sel:stateChanged:StateEvent :: forall tx. StateEvent tx -> StateChanged tx
stateChanged :: StateChanged tx
stateChanged} = StateEvent tx
event

  mapStateChangedToServerOutput :: StateChanged tx -> Maybe (ServerOutput tx)
mapStateChangedToServerOutput = \case
    StateChanged.HeadOpened{[Party]
HeadId
HeadSeed
HeadParameters
ChainStateType tx
parameters :: HeadParameters
chainState :: ChainStateType tx
headId :: HeadId
headSeed :: HeadSeed
parties :: [Party]
$sel:parameters:NetworkConnected :: forall tx. StateChanged tx -> HeadParameters
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
$sel:headSeed:NetworkConnected :: forall tx. StateChanged tx -> HeadSeed
$sel:parties:NetworkConnected :: forall tx. StateChanged tx -> [Party]
..} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just HeadIsOpen{[Party]
HeadId
headId :: HeadId
parties :: [Party]
$sel:headId:NetworkConnected :: HeadId
$sel:parties:NetworkConnected :: [Party]
..}
    StateChanged.HeadClosed{UTCTime
HeadId
SnapshotNumber
ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
snapshotNumber :: SnapshotNumber
chainState :: ChainStateType tx
contestationDeadline :: UTCTime
$sel:snapshotNumber:NetworkConnected :: forall tx. StateChanged tx -> SnapshotNumber
$sel:contestationDeadline:NetworkConnected :: forall tx. StateChanged tx -> UTCTime
..} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just HeadIsClosed{UTCTime
HeadId
SnapshotNumber
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
snapshotNumber :: SnapshotNumber
contestationDeadline :: UTCTime
$sel:snapshotNumber:NetworkConnected :: SnapshotNumber
$sel:contestationDeadline:NetworkConnected :: UTCTime
..}
    StateChanged.HeadContested{UTCTime
HeadId
SnapshotNumber
ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
$sel:snapshotNumber:NetworkConnected :: forall tx. StateChanged tx -> SnapshotNumber
$sel:contestationDeadline:NetworkConnected :: forall tx. StateChanged tx -> UTCTime
headId :: HeadId
chainState :: ChainStateType tx
contestationDeadline :: UTCTime
snapshotNumber :: SnapshotNumber
..} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just HeadIsContested{UTCTime
HeadId
SnapshotNumber
$sel:headId:NetworkConnected :: HeadId
$sel:snapshotNumber:NetworkConnected :: SnapshotNumber
$sel:contestationDeadline:NetworkConnected :: UTCTime
headId :: HeadId
contestationDeadline :: UTCTime
snapshotNumber :: SnapshotNumber
..}
    StateChanged.HeadIsReadyToFanout{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
..} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just ReadyToFanout{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
..}
    StateChanged.HeadFannedOut{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId, UTxOType tx
finalizedOutputs :: UTxOType tx
$sel:finalizedOutputs:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
finalizedOutputs} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just HeadIsFinalized{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, $sel:finalizedUTxO:NetworkConnected :: UTxOType tx
finalizedUTxO = UTxOType tx
finalizedOutputs}
    StateChanged.HeadPartialFannedOut{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId, UTxOType tx
distributedOutputs :: UTxOType tx
$sel:distributedOutputs:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
distributedOutputs, UTxOType tx
remainingOutputs :: UTxOType tx
$sel:remainingOutputs:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
remainingOutputs, FanoutMode tx
mode :: FanoutMode tx
$sel:mode:NetworkConnected :: forall tx. StateChanged tx -> FanoutMode tx
mode} ->
      ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just HeadPartiallyFannedOut{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, $sel:distributedUTxO:NetworkConnected :: UTxOType tx
distributedUTxO = UTxOType tx
distributedOutputs, $sel:remainingUTxO:NetworkConnected :: UTxOType tx
remainingUTxO = UTxOType tx
remainingOutputs, $sel:fanoutMode:NetworkConnected :: FanoutProgressMode
fanoutMode = FanoutMode tx -> FanoutProgressMode
forall tx. FanoutMode tx -> FanoutProgressMode
fanoutProgressMode FanoutMode tx
mode}
    StateChanged.HeadFanoutInitiated{} -> Maybe (ServerOutput tx)
forall a. Maybe a
Nothing
    StateChanged.HeadPartialFanoutSelected{} -> Maybe (ServerOutput tx)
forall a. Maybe a
Nothing
    StateChanged.HeadFanoutReverted{} -> Maybe (ServerOutput tx)
forall a. Maybe a
Nothing
    StateChanged.TransactionAppliedToLocalUTxO{tx
HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
tx :: tx
$sel:tx:NetworkConnected :: forall tx. StateChanged tx -> tx
..} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just TxValid{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, $sel:transactionId:NetworkConnected :: TxIdType tx
transactionId = tx -> TxIdType tx
forall tx. IsTx tx => tx -> TxIdType tx
txId tx
tx}
    StateChanged.TxInvalid{tx
HeadId
UTxOType tx
ValidationError
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
utxo :: UTxOType tx
transaction :: tx
validationError :: ValidationError
$sel:utxo:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
$sel:transaction:NetworkConnected :: forall tx. StateChanged tx -> tx
$sel:validationError:NetworkConnected :: forall tx. StateChanged tx -> ValidationError
..} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just (ServerOutput tx -> Maybe (ServerOutput tx))
-> ServerOutput tx -> Maybe (ServerOutput tx)
forall a b. (a -> b) -> a -> b
$ TxInvalid{tx
HeadId
UTxOType tx
ValidationError
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
utxo :: UTxOType tx
transaction :: tx
validationError :: ValidationError
$sel:utxo:NetworkConnected :: UTxOType tx
$sel:transaction:NetworkConnected :: tx
$sel:validationError:NetworkConnected :: ValidationError
..}
    StateChanged.SnapshotConfirmed{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId, $sel:snapshot:NetworkConnected :: forall tx. StateChanged tx -> Maybe (Snapshot tx)
snapshot = Maybe (Snapshot tx)
mSnapshot, MultiSignature (Snapshot tx)
signatures :: MultiSignature (Snapshot tx)
$sel:signatures:NetworkConnected :: forall tx. StateChanged tx -> MultiSignature (Snapshot tx)
signatures} ->
      case Maybe (Snapshot tx)
mSnapshot Maybe (Snapshot tx) -> Maybe (Snapshot tx) -> Maybe (Snapshot tx)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Snapshot tx)
mSeenSnapshot of
        Just Snapshot tx
snapshot -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just SnapshotConfirmed{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, Snapshot tx
snapshot :: Snapshot tx
snapshot :: Snapshot tx
snapshot, MultiSignature (Snapshot tx)
signatures :: MultiSignature (Snapshot tx)
$sel:signatures:NetworkConnected :: MultiSignature (Snapshot tx)
signatures}
        Maybe (Snapshot tx)
Nothing -> Maybe (ServerOutput tx)
forall a. Maybe a
Nothing
    StateChanged.IgnoredHeadInitializing{[Party]
[OnChainId]
HeadId
ContestationPeriod
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
$sel:parties:NetworkConnected :: forall tx. StateChanged tx -> [Party]
headId :: HeadId
contestationPeriod :: ContestationPeriod
parties :: [Party]
participants :: [OnChainId]
$sel:contestationPeriod:NetworkConnected :: forall tx. StateChanged tx -> ContestationPeriod
$sel:participants:NetworkConnected :: forall tx. StateChanged tx -> [OnChainId]
..} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just IgnoredHeadInitializing{[Party]
[OnChainId]
HeadId
ContestationPeriod
$sel:headId:NetworkConnected :: HeadId
$sel:parties:NetworkConnected :: [Party]
headId :: HeadId
contestationPeriod :: ContestationPeriod
parties :: [Party]
participants :: [OnChainId]
$sel:contestationPeriod:NetworkConnected :: ContestationPeriod
$sel:participants:NetworkConnected :: [OnChainId]
..}
    StateChanged.DecommitRecorded{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId, tx
decommitTx :: tx
$sel:decommitTx:NetworkConnected :: forall tx. StateChanged tx -> tx
decommitTx} ->
      ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just DecommitRequested{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, tx
decommitTx :: tx
$sel:decommitTx:NetworkConnected :: tx
decommitTx, $sel:utxoToDecommit:NetworkConnected :: UTxOType tx
utxoToDecommit = tx -> UTxOType tx
forall tx. IsTx tx => tx -> UTxOType tx
utxoFromTx tx
decommitTx}
    StateChanged.DecommitInvalid{tx
HeadId
DecommitInvalidReason tx
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
$sel:decommitTx:NetworkConnected :: forall tx. StateChanged tx -> tx
headId :: HeadId
decommitTx :: tx
decommitInvalidReason :: DecommitInvalidReason tx
$sel:decommitInvalidReason:NetworkConnected :: forall tx. StateChanged tx -> DecommitInvalidReason tx
..} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just DecommitInvalid{tx
HeadId
DecommitInvalidReason tx
$sel:headId:NetworkConnected :: HeadId
$sel:decommitTx:NetworkConnected :: tx
headId :: HeadId
decommitTx :: tx
decommitInvalidReason :: DecommitInvalidReason tx
$sel:decommitInvalidReason:NetworkConnected :: DecommitInvalidReason tx
..}
    StateChanged.DecommitApproved{HeadId
TxIdType tx
UTxOType tx
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
decommitTxId :: TxIdType tx
utxoToDecommit :: UTxOType tx
$sel:decommitTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
$sel:utxoToDecommit:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
..} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just DecommitApproved{HeadId
TxIdType tx
UTxOType tx
$sel:headId:NetworkConnected :: HeadId
$sel:utxoToDecommit:NetworkConnected :: UTxOType tx
headId :: HeadId
decommitTxId :: TxIdType tx
utxoToDecommit :: UTxOType tx
$sel:decommitTxId:NetworkConnected :: TxIdType tx
..}
    StateChanged.DecommitFinalized{HeadId
UTxOType tx
SnapshotVersion
ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
chainState :: ChainStateType tx
headId :: HeadId
distributedUTxO :: UTxOType tx
newVersion :: SnapshotVersion
$sel:newVersion:NetworkConnected :: forall tx. StateChanged tx -> SnapshotVersion
$sel:distributedUTxO:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
..} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just DecommitFinalized{HeadId
UTxOType tx
$sel:headId:NetworkConnected :: HeadId
$sel:distributedUTxO:NetworkConnected :: UTxOType tx
headId :: HeadId
distributedUTxO :: UTxOType tx
..}
    StateChanged.DepositRecorded{UTCTime
HeadId
TxIdType tx
UTxOType tx
ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
chainState :: ChainStateType tx
headId :: HeadId
depositTxId :: TxIdType tx
deposited :: UTxOType tx
created :: UTCTime
deadline :: UTCTime
$sel:depositTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
$sel:deposited:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
$sel:created:NetworkConnected :: forall tx. StateChanged tx -> UTCTime
$sel:deadline:NetworkConnected :: forall tx. StateChanged tx -> UTCTime
..} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just CommitRecorded{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, $sel:utxoToCommit:NetworkConnected :: UTxOType tx
utxoToCommit = UTxOType tx
deposited, $sel:pendingDeposit:NetworkConnected :: TxIdType tx
pendingDeposit = TxIdType tx
depositTxId, UTCTime
deadline :: UTCTime
$sel:deadline:NetworkConnected :: UTCTime
deadline}
    StateChanged.DepositActivated{TxIdType tx
$sel:depositTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
depositTxId :: TxIdType tx
depositTxId, UTCTime
chainTime :: UTCTime
$sel:chainTime:NetworkConnected :: forall tx. StateChanged tx -> UTCTime
chainTime, $sel:deposit:NetworkConnected :: forall tx. StateChanged tx -> Deposit tx
deposit = Deposit{UTCTime
HeadId
UTxOType tx
DepositStatus
headId :: HeadId
deposited :: UTxOType tx
created :: UTCTime
deadline :: UTCTime
status :: DepositStatus
$sel:headId:Deposit :: forall tx. Deposit tx -> HeadId
$sel:deposited:Deposit :: forall tx. Deposit tx -> UTxOType tx
$sel:created:Deposit :: forall tx. Deposit tx -> UTCTime
$sel:deadline:Deposit :: forall tx. Deposit tx -> UTCTime
$sel:status:Deposit :: forall tx. Deposit tx -> DepositStatus
..}} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just DepositActivated{UTCTime
HeadId
TxIdType tx
$sel:headId:NetworkConnected :: HeadId
$sel:deadline:NetworkConnected :: UTCTime
depositTxId :: TxIdType tx
chainTime :: UTCTime
headId :: HeadId
deadline :: UTCTime
$sel:depositTxId:NetworkConnected :: TxIdType tx
$sel:chainTime:NetworkConnected :: UTCTime
..}
    StateChanged.DepositExpired{TxIdType tx
$sel:depositTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
depositTxId :: TxIdType tx
depositTxId, UTCTime
$sel:chainTime:NetworkConnected :: forall tx. StateChanged tx -> UTCTime
chainTime :: UTCTime
chainTime, $sel:deposit:NetworkConnected :: forall tx. StateChanged tx -> Deposit tx
deposit = Deposit{UTCTime
HeadId
UTxOType tx
DepositStatus
$sel:headId:Deposit :: forall tx. Deposit tx -> HeadId
$sel:deposited:Deposit :: forall tx. Deposit tx -> UTxOType tx
$sel:created:Deposit :: forall tx. Deposit tx -> UTCTime
$sel:deadline:Deposit :: forall tx. Deposit tx -> UTCTime
$sel:status:Deposit :: forall tx. Deposit tx -> DepositStatus
headId :: HeadId
deposited :: UTxOType tx
created :: UTCTime
deadline :: UTCTime
status :: DepositStatus
..}} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just DepositExpired{UTCTime
HeadId
TxIdType tx
$sel:headId:NetworkConnected :: HeadId
$sel:deadline:NetworkConnected :: UTCTime
$sel:depositTxId:NetworkConnected :: TxIdType tx
$sel:chainTime:NetworkConnected :: UTCTime
depositTxId :: TxIdType tx
chainTime :: UTCTime
headId :: HeadId
deadline :: UTCTime
..}
    StateChanged.DepositRecovered{HeadId
TxIdType tx
UTxOType tx
ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
$sel:depositTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
chainState :: ChainStateType tx
headId :: HeadId
depositTxId :: TxIdType tx
recovered :: UTxOType tx
$sel:recovered:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
..} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just CommitRecovered{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, $sel:recoveredTxId:NetworkConnected :: TxIdType tx
recoveredTxId = TxIdType tx
depositTxId, $sel:recoveredUTxO:NetworkConnected :: UTxOType tx
recoveredUTxO = UTxOType tx
recovered}
    StateChanged.CommitApproved{HeadId
UTxOType tx
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
utxoToCommit :: UTxOType tx
$sel:utxoToCommit:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
..} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just CommitApproved{HeadId
UTxOType tx
$sel:headId:NetworkConnected :: HeadId
$sel:utxoToCommit:NetworkConnected :: UTxOType tx
headId :: HeadId
utxoToCommit :: UTxOType tx
..}
    StateChanged.CommitFinalized{HeadId
TxIdType tx
SnapshotVersion
ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
$sel:newVersion:NetworkConnected :: forall tx. StateChanged tx -> SnapshotVersion
$sel:depositTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
chainState :: ChainStateType tx
headId :: HeadId
newVersion :: SnapshotVersion
depositTxId :: TxIdType tx
..} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just CommitFinalized{HeadId
TxIdType tx
$sel:headId:NetworkConnected :: HeadId
$sel:depositTxId:NetworkConnected :: TxIdType tx
headId :: HeadId
depositTxId :: TxIdType tx
..}
    StateChanged tx
StateChanged.NetworkConnected -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just ServerOutput tx
forall tx. ServerOutput tx
NetworkConnected
    StateChanged tx
StateChanged.NetworkDisconnected -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just ServerOutput tx
forall tx. ServerOutput tx
NetworkDisconnected
    StateChanged.NetworkVersionMismatch{Maybe ProtocolVersion
ProtocolVersion
ourVersion :: ProtocolVersion
theirVersion :: Maybe ProtocolVersion
$sel:ourVersion:NetworkConnected :: forall tx. StateChanged tx -> ProtocolVersion
$sel:theirVersion:NetworkConnected :: forall tx. StateChanged tx -> Maybe ProtocolVersion
..} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just NetworkVersionMismatch{Maybe ProtocolVersion
ProtocolVersion
ourVersion :: ProtocolVersion
theirVersion :: Maybe ProtocolVersion
$sel:ourVersion:NetworkConnected :: ProtocolVersion
$sel:theirVersion:NetworkConnected :: Maybe ProtocolVersion
..}
    StateChanged.NetworkClusterIDMismatch{Text
clusterPeers :: Text
misconfiguredPeers :: Text
$sel:clusterPeers:NetworkConnected :: forall tx. StateChanged tx -> Text
$sel:misconfiguredPeers:NetworkConnected :: forall tx. StateChanged tx -> Text
..} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just NetworkClusterIDMismatch{Text
clusterPeers :: Text
misconfiguredPeers :: Text
$sel:clusterPeers:NetworkConnected :: Text
$sel:misconfiguredPeers:NetworkConnected :: Text
..}
    StateChanged.PeerConnected{Host
peer :: Host
$sel:peer:NetworkConnected :: forall tx. StateChanged tx -> Host
..} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just PeerConnected{Host
peer :: Host
$sel:peer:NetworkConnected :: Host
..}
    StateChanged.PeerDisconnected{Host
$sel:peer:NetworkConnected :: forall tx. StateChanged tx -> Host
peer :: Host
..} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just PeerDisconnected{Host
$sel:peer:NetworkConnected :: Host
peer :: Host
..}
    StateChanged.TransactionReceived{} -> Maybe (ServerOutput tx)
forall a. Maybe a
Nothing
    StateChanged.SnapshotRequested{} -> Maybe (ServerOutput tx)
forall a. Maybe a
Nothing
    StateChanged.SnapshotRequestDecided{} -> Maybe (ServerOutput tx)
forall a. Maybe a
Nothing
    StateChanged.PartySignedSnapshot{} -> Maybe (ServerOutput tx)
forall a. Maybe a
Nothing
    StateChanged.ChainRolledBack{} -> Maybe (ServerOutput tx)
forall a. Maybe a
Nothing
    StateChanged.TickObserved{} -> Maybe (ServerOutput tx)
forall a. Maybe a
Nothing
    StateChanged.LocalStateCleared{HeadId
SnapshotNumber
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
$sel:snapshotNumber:NetworkConnected :: forall tx. StateChanged tx -> SnapshotNumber
headId :: HeadId
snapshotNumber :: SnapshotNumber
..} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just SnapshotSideLoaded{HeadId
SnapshotNumber
$sel:headId:NetworkConnected :: HeadId
$sel:snapshotNumber:NetworkConnected :: SnapshotNumber
headId :: HeadId
snapshotNumber :: SnapshotNumber
..}
    StateChanged.Checkpoint{NodeState tx
state :: NodeState tx
$sel:state:NetworkConnected :: forall tx. StateChanged tx -> NodeState tx
state} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just (ServerOutput tx -> Maybe (ServerOutput tx))
-> ServerOutput tx -> Maybe (ServerOutput tx)
forall a b. (a -> b) -> a -> b
$ NodeState tx -> ServerOutput tx
forall tx. NodeState tx -> ServerOutput tx
EventLogRotated NodeState tx
state
    StateChanged.NodeUnsynced{NominalDiffTime
UTCTime
ChainSlot
$sel:chainTime:NetworkConnected :: forall tx. StateChanged tx -> UTCTime
chainSlot :: ChainSlot
chainTime :: UTCTime
drift :: NominalDiffTime
$sel:chainSlot:NetworkConnected :: forall tx. StateChanged tx -> ChainSlot
$sel:drift:NetworkConnected :: forall tx. StateChanged tx -> NominalDiffTime
..} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just NodeUnsynced{NominalDiffTime
UTCTime
ChainSlot
$sel:chainTime:NetworkConnected :: UTCTime
chainSlot :: ChainSlot
chainTime :: UTCTime
drift :: NominalDiffTime
$sel:chainSlot:NetworkConnected :: ChainSlot
$sel:drift:NetworkConnected :: NominalDiffTime
..}
    StateChanged.NodeSynced{NominalDiffTime
UTCTime
ChainSlot
$sel:chainTime:NetworkConnected :: forall tx. StateChanged tx -> UTCTime
$sel:chainSlot:NetworkConnected :: forall tx. StateChanged tx -> ChainSlot
$sel:drift:NetworkConnected :: forall tx. StateChanged tx -> NominalDiffTime
chainSlot :: ChainSlot
chainTime :: UTCTime
drift :: NominalDiffTime
..} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just NodeSynced{NominalDiffTime
UTCTime
ChainSlot
$sel:chainTime:NetworkConnected :: UTCTime
$sel:chainSlot:NetworkConnected :: ChainSlot
$sel:drift:NetworkConnected :: NominalDiffTime
chainSlot :: ChainSlot
chainTime :: UTCTime
drift :: NominalDiffTime
..}

-- | Advance the seen-snapshot state as events are processed sequentially.
updateSeenSnapshot :: Maybe (Snapshot tx) -> StateChanged.StateChanged tx -> Maybe (Snapshot tx)
updateSeenSnapshot :: forall tx.
Maybe (Snapshot tx) -> StateChanged tx -> Maybe (Snapshot tx)
updateSeenSnapshot Maybe (Snapshot tx)
_ (StateChanged.SnapshotRequested{Snapshot tx
requestedSnapshot :: Snapshot tx
$sel:requestedSnapshot:NetworkConnected :: forall tx. StateChanged tx -> Snapshot tx
requestedSnapshot}) = Snapshot tx -> Maybe (Snapshot tx)
forall a. a -> Maybe a
Just Snapshot tx
requestedSnapshot
updateSeenSnapshot Maybe (Snapshot tx)
_ StateChanged.SnapshotConfirmed{} = Maybe (Snapshot tx)
forall a. Maybe a
Nothing
updateSeenSnapshot Maybe (Snapshot tx)
mSn StateChanged tx
_ = Maybe (Snapshot tx)
mSn

-- | Extract the snapshot currently in 'SeenSnapshot' from a 'NodeState', if any.
seenSnapshotOf :: NodeState tx -> Maybe (Snapshot tx)
seenSnapshotOf :: forall tx. NodeState tx -> Maybe (Snapshot tx)
seenSnapshotOf NodeState tx
ns = case NodeState tx -> HeadState tx
forall tx. NodeState tx -> HeadState tx
headState NodeState tx
ns of
  Open OpenState{$sel:coordinatedHeadState:OpenState :: forall tx. OpenState tx -> CoordinatedHeadState tx
coordinatedHeadState = CoordinatedHeadState{$sel:seenSnapshot:CoordinatedHeadState :: forall tx. CoordinatedHeadState tx -> SeenSnapshot tx
seenSnapshot = SeenSnapshot Snapshot tx
sn Map Party (Signature (Snapshot tx))
_ ByteString
_}} -> Snapshot tx -> Maybe (Snapshot tx)
forall a. a -> Maybe a
Just Snapshot tx
sn
  HeadState tx
_ -> Maybe (Snapshot tx)
forall a. Maybe a
Nothing

-- | Projection to obtain the list of pending deposits.
projectPendingDeposits :: IsTx tx => [TxIdType tx] -> StateChanged.StateChanged tx -> [TxIdType tx]
projectPendingDeposits :: forall tx.
IsTx tx =>
[TxIdType tx] -> StateChanged tx -> [TxIdType tx]
projectPendingDeposits [TxIdType tx]
txIds = \case
  StateChanged.Checkpoint{NodeState tx
$sel:state:NetworkConnected :: forall tx. StateChanged tx -> NodeState tx
state :: NodeState tx
state} -> Map (TxIdType tx) (Deposit tx) -> [TxIdType tx]
forall k a. Map k a -> [k]
Map.keys (NodeState tx -> Map (TxIdType tx) (Deposit tx)
forall tx. NodeState tx -> PendingDeposits tx
pendingDeposits NodeState tx
state)
  StateChanged.DepositRecorded{TxIdType tx
$sel:depositTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
depositTxId :: TxIdType tx
depositTxId} -> TxIdType tx
depositTxId TxIdType tx -> [TxIdType tx] -> [TxIdType tx]
forall a. a -> [a] -> [a]
: [TxIdType tx]
txIds
  StateChanged.DepositRecovered{TxIdType tx
$sel:depositTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
depositTxId :: TxIdType tx
depositTxId} -> (TxIdType tx -> Bool) -> [TxIdType tx] -> [TxIdType tx]
forall a. (a -> Bool) -> [a] -> [a]
filter (TxIdType tx -> TxIdType tx -> Bool
forall a. Eq a => a -> a -> Bool
/= TxIdType tx
depositTxId) [TxIdType tx]
txIds
  StateChanged.CommitFinalized{TxIdType tx
$sel:depositTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
depositTxId :: TxIdType tx
depositTxId} -> (TxIdType tx -> Bool) -> [TxIdType tx] -> [TxIdType tx]
forall a. (a -> Bool) -> [a] -> [a]
filter (TxIdType tx -> TxIdType tx -> Bool
forall a. Eq a => a -> a -> Bool
/= TxIdType tx
depositTxId) [TxIdType tx]
txIds
  StateChanged tx
_other -> [TxIdType tx]
txIds

-- | Projection to obtain 'CommitInfo' needed to draft commit transactions.
-- NOTE: We only project 'HeadId' when the Head is 'Open' since that is when
-- deposits can be made.
projectCommitInfo :: CommitInfo -> StateChanged.StateChanged tx -> CommitInfo
projectCommitInfo :: forall tx. CommitInfo -> StateChanged tx -> CommitInfo
projectCommitInfo CommitInfo
commitInfo = \case
  StateChanged.Checkpoint NodeState tx
state ->
    case NodeState tx -> HeadState tx
forall tx. NodeState tx -> HeadState tx
headState NodeState tx
state of
      Open OpenState{HeadId
headId :: HeadId
$sel:headId:OpenState :: forall tx. OpenState tx -> HeadId
headId} -> HeadId -> CommitInfo
IncrementalCommit HeadId
headId
      HeadState tx
_ -> CommitInfo
CannotCommit
  StateChanged.HeadOpened{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId} -> HeadId -> CommitInfo
IncrementalCommit HeadId
headId
  StateChanged.HeadClosed{} -> CommitInfo
CannotCommit
  StateChanged tx
_other -> CommitInfo
commitInfo

projectNetworkInfo :: NetworkInfo -> StateChanged.StateChanged tx -> NetworkInfo
projectNetworkInfo :: forall tx. NetworkInfo -> StateChanged tx -> NetworkInfo
projectNetworkInfo NetworkInfo
networkInfo = \case
  StateChanged tx
StateChanged.NetworkConnected ->
    NetworkInfo
networkInfo{networkConnected = True}
  StateChanged tx
StateChanged.NetworkDisconnected ->
    NetworkInfo
networkInfo{networkConnected = False, peersInfo = mempty}
  StateChanged.PeerConnected{Host
$sel:peer:NetworkConnected :: forall tx. StateChanged tx -> Host
peer :: Host
peer} ->
    NetworkInfo
networkInfo{peersInfo = Map.insert peer True (peersInfo networkInfo)}
  StateChanged.PeerDisconnected{Host
$sel:peer:NetworkConnected :: forall tx. StateChanged tx -> Host
peer :: Host
peer} ->
    NetworkInfo
networkInfo{peersInfo = Map.insert peer False (peersInfo networkInfo)}
  StateChanged tx
_other -> NetworkInfo
networkInfo