{-# 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.Combinators (map)
import Data.Conduit.List (catMaybes)
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 (..),
  ServerOutput (..),
  TimedServerOutput (..),
 )
import Hydra.API.ServerOutputFilter (
  ServerOutputFilter,
 )
import Hydra.API.WSServer (wsApp)
import Hydra.Cardano.Api (LedgerEra)
import Hydra.Chain (Chain (..))
import Hydra.Chain.ChainState (IsChainState)
import Hydra.Chain.Direct.State ()
import Hydra.Events (EventSink (..), EventSource (..))
import Hydra.HeadLogic (aggregate)
import Hydra.HeadLogic.Outcome qualified as StateChanged
import Hydra.HeadLogic.State (
  Deposit (..),
  HeadState (Idle),
  IdleState (..),
 )
import Hydra.HeadLogic.StateEvent (StateEvent (..))
import Hydra.Logging (Tracer, traceWith)
import Hydra.Network (IP, PortNumber)
import Hydra.Node.Environment (Environment)
import Hydra.Tx (HeadId, IsTx (..), Party, txId)
import Network.HTTP.Types (status500)
import Network.Wai (responseLBS)
import Network.Wai.Handler.Warp (
  defaultSettings,
  runSettings,
  setBeforeMainLoop,
  setHost,
  setOnException,
  setOnExceptionResponse,
  setPort,
 )
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
  }

withAPIServer ::
  forall tx.
  IsChainState tx =>
  APIServerConfig ->
  Environment ->
  Party ->
  EventSource (StateEvent tx) IO ->
  Tracer IO APIServerLog ->
  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
-> Environment
-> Party
-> EventSource (StateEvent tx) IO
-> Tracer IO APIServerLog
-> Chain tx IO
-> PParams LedgerEra
-> ServerOutputFilter tx
-> (ClientInput tx -> IO ())
-> ((EventSink (StateEvent tx) IO, Server tx IO) -> IO ())
-> IO ()
withAPIServer APIServerConfig
config Environment
env Party
party EventSource (StateEvent tx) IO
eventSource Tracer IO APIServerLog
tracer 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) (HeadState tx)
headStateP <- HeadState tx
-> (HeadState tx -> StateChanged tx -> HeadState tx)
-> IO (Projection (STM IO) (StateChanged tx) (HeadState tx))
forall (m :: * -> *) model event.
MonadSTM m =>
model
-> (model -> event -> model) -> m (Projection (STM m) event model)
mkProjection (IdleState tx -> HeadState tx
forall tx. IdleState tx -> HeadState tx
Idle (IdleState tx -> HeadState tx) -> IdleState tx -> HeadState tx
forall a b. (a -> b) -> a -> b
$ ChainStateType tx -> IdleState tx
forall tx. ChainStateType tx -> IdleState tx
IdleState ChainStateType tx
mkChainState) HeadState tx -> StateChanged tx -> HeadState tx
forall tx.
IsChainState tx =>
HeadState tx -> StateChanged tx -> HeadState tx
aggregate
    Projection STM (StateChanged tx) CommitInfo
commitInfoP <- CommitInfo
-> (CommitInfo -> StateChanged tx -> CommitInfo)
-> IO (Projection (STM IO) (StateChanged tx) CommitInfo)
forall (m :: * -> *) model event.
MonadSTM m =>
model
-> (model -> event -> model) -> m (Projection (STM m) event model)
mkProjection CommitInfo
CannotCommit CommitInfo -> StateChanged tx -> CommitInfo
forall tx. CommitInfo -> StateChanged tx -> CommitInfo
projectCommitInfo
    Projection STM (StateChanged tx) (Maybe HeadId)
headIdP <- Maybe HeadId
-> (Maybe HeadId -> StateChanged tx -> Maybe HeadId)
-> IO (Projection (STM IO) (StateChanged tx) (Maybe HeadId))
forall (m :: * -> *) model event.
MonadSTM m =>
model
-> (model -> event -> model) -> m (Projection (STM m) event model)
mkProjection Maybe HeadId
forall a. Maybe a
Nothing Maybe HeadId -> StateChanged tx -> Maybe HeadId
forall tx. Maybe HeadId -> StateChanged tx -> Maybe HeadId
projectInitializingHeadId
    Projection STM (StateChanged tx) [TxIdType tx]
pendingDepositsP <- [TxIdType tx]
-> ([TxIdType tx] -> StateChanged tx -> [TxIdType tx])
-> IO (Projection (STM IO) (StateChanged tx) [TxIdType tx])
forall (m :: * -> *) model event.
MonadSTM m =>
model
-> (model -> event -> model) -> m (Projection (STM m) event model)
mkProjection [] [TxIdType tx] -> StateChanged tx -> [TxIdType tx]
forall tx.
IsTx tx =>
[TxIdType tx] -> StateChanged tx -> [TxIdType tx]
projectPendingDeposits
    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
.| (StateEvent tx -> Maybe (TimedServerOutput tx))
-> ConduitT
     (StateEvent tx) (Maybe (TimedServerOutput tx)) (ResourceT IO) ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
map StateEvent tx -> Maybe (TimedServerOutput tx)
forall tx. IsTx tx => StateEvent tx -> Maybe (TimedServerOutput tx)
mkTimedServerOutputFromStateEvent 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
stateChanged :: StateChanged tx
$sel:stateChanged:StateEvent :: forall tx. StateEvent tx -> 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) (HeadState tx)
-> StateChanged tx -> STM ()
forall (stm :: * -> *) event model.
Projection stm event model -> event -> stm ()
update Projection STM (StateChanged tx) (HeadState tx)
headStateP 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) (Maybe HeadId)
-> StateChanged tx -> STM ()
forall (stm :: * -> *) event model.
Projection stm event model -> event -> stm ()
update Projection STM (StateChanged tx) (Maybe HeadId)
headIdP 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
            )
    (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
& (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
    IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
forall (m :: * -> *) a b. MonadAsync m => m a -> m b -> m ()
race_
      ( 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
              (Party
-> Tracer IO APIServerLog
-> ConduitT () (TimedServerOutput tx) (ResourceT IO) ()
-> (ClientInput tx -> IO ())
-> Projection STM (StateChanged tx) (HeadState tx)
-> Projection STM (StateChanged tx) (Maybe HeadId)
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> ServerOutputFilter tx
-> ServerApp
forall tx.
IsChainState tx =>
Party
-> Tracer IO APIServerLog
-> ConduitT () (TimedServerOutput tx) (ResourceT IO) ()
-> (ClientInput tx -> IO ())
-> Projection STM (StateChanged tx) (HeadState tx)
-> Projection STM (StateChanged tx) (Maybe HeadId)
-> TChan (Either (TimedServerOutput tx) (ClientMessage tx))
-> ServerOutputFilter tx
-> ServerApp
wsApp Party
party Tracer IO APIServerLog
tracer ConduitT () (TimedServerOutput tx) (ResourceT IO) ()
historyTimedOutputs ClientInput tx -> IO ()
callback Projection STM (StateChanged tx) (HeadState tx)
headStateP Projection STM (StateChanged tx) (Maybe HeadId)
headIdP TChan (Either (TimedServerOutput tx) (ClientMessage tx))
responseChannel ServerOutputFilter tx
serverOutputFilter)
              ( Tracer IO APIServerLog
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (HeadState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> Application
forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO (HeadState tx)
-> IO CommitInfo
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> Application
httpApp
                  Tracer IO APIServerLog
tracer
                  Chain tx IO
chain
                  Environment
env
                  PParams LedgerEra
pparams
                  (STM IO (HeadState tx) -> IO (HeadState tx)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO (HeadState tx) -> IO (HeadState tx))
-> STM IO (HeadState tx) -> IO (HeadState tx)
forall a b. (a -> b) -> a -> b
$ Projection STM (StateChanged tx) (HeadState tx)
-> STM (HeadState tx)
forall (stm :: * -> *) event model.
Projection stm event model -> stm model
getLatest Projection STM (StateChanged tx) (HeadState tx)
headStateP)
                  (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
              )
      )
      ( do
          IO ()
waitForServerRunning
          (EventSink (StateEvent tx) IO, Server tx IO) -> IO ()
action
            ( EventSink
                { $sel:putEvent:EventSink :: HasEventId (StateEvent tx) => StateEvent tx -> IO ()
putEvent = \event :: StateEvent tx
event@StateEvent{StateChanged tx
$sel:stateChanged:StateEvent :: forall tx. StateEvent tx -> StateChanged tx
stateChanged :: StateChanged tx
stateChanged} -> do
                    -- 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) (HeadState tx)
-> StateChanged tx -> STM ()
forall (stm :: * -> *) event model.
Projection stm event model -> event -> stm ()
update Projection STM (StateChanged tx) (HeadState tx)
headStateP 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) (Maybe HeadId)
-> StateChanged tx -> STM ()
forall (stm :: * -> *) event model.
Projection stm event model -> event -> stm ()
update Projection STM (StateChanged tx) (Maybe HeadId)
headIdP 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
                    -- Send to the client if it maps to a server output
                    case StateEvent tx -> Maybe (TimedServerOutput tx)
forall tx. IsTx tx => StateEvent tx -> Maybe (TimedServerOutput tx)
mkTimedServerOutputFromStateEvent 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

  Chain{ChainStateType tx
mkChainState :: ChainStateType tx
$sel:mkChainState:Chain :: forall tx (m :: * -> *). Chain tx m -> ChainStateType tx
mkChainState} = Chain tx IO
chain

  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.
mkTimedServerOutputFromStateEvent :: IsTx tx => StateEvent tx -> Maybe (TimedServerOutput tx)
mkTimedServerOutputFromStateEvent :: forall tx. IsTx tx => StateEvent tx -> Maybe (TimedServerOutput tx)
mkTimedServerOutputFromStateEvent 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.HeadInitialized{HeadId
headId :: HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId, [Party]
parties :: [Party]
$sel:parties:NetworkConnected :: forall tx. StateChanged tx -> [Party]
parties} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just HeadIsInitializing{HeadId
headId :: HeadId
$sel:headId:NetworkConnected :: HeadId
headId, [Party]
parties :: [Party]
$sel:parties:NetworkConnected :: [Party]
parties}
    StateChanged.CommittedUTxO{HeadId
UTxOType tx
Party
ChainStateType tx
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
party :: Party
committedUTxO :: UTxOType tx
chainState :: ChainStateType tx
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
$sel:party:NetworkConnected :: forall tx. StateChanged tx -> Party
$sel:committedUTxO:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
..} -> 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
$ Committed{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, Party
party :: Party
$sel:party:NetworkConnected :: Party
party, $sel:utxo:NetworkConnected :: UTxOType tx
utxo = UTxOType tx
committedUTxO}
    StateChanged.HeadOpened{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId, UTxOType tx
initialUTxO :: UTxOType tx
$sel:initialUTxO:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
initialUTxO} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just HeadIsOpen{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, $sel:utxo:NetworkConnected :: UTxOType tx
utxo = UTxOType tx
initialUTxO}
    StateChanged.HeadClosed{UTCTime
HeadId
SnapshotNumber
ChainStateType tx
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
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:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
$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.HeadAborted{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId, UTxOType tx
utxo :: UTxOType tx
$sel:utxo:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
utxo} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just HeadIsAborted{HeadId
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
headId, UTxOType tx
$sel:utxo:NetworkConnected :: UTxOType tx
utxo :: UTxOType tx
utxo}
    StateChanged.HeadFannedOut{HeadId
UTxOType tx
ChainStateType tx
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
$sel:utxo:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
headId :: HeadId
utxo :: UTxOType tx
chainState :: ChainStateType tx
..} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just HeadIsFinalized{HeadId
UTxOType tx
$sel:headId:NetworkConnected :: HeadId
$sel:utxo:NetworkConnected :: UTxOType tx
headId :: HeadId
utxo :: UTxOType tx
..}
    StateChanged.TransactionAppliedToLocalUTxO{tx
HeadId
UTxOType tx
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
tx :: tx
newLocalUTxO :: UTxOType tx
$sel:tx:NetworkConnected :: forall tx. StateChanged tx -> tx
$sel:newLocalUTxO:NetworkConnected :: forall tx. StateChanged tx -> UTxOType 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
$sel:utxo:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
headId :: HeadId
utxo :: UTxOType tx
transaction :: tx
validationError :: ValidationError
$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
$sel:utxo:NetworkConnected :: UTxOType tx
headId :: HeadId
utxo :: UTxOType tx
transaction :: tx
validationError :: ValidationError
$sel:transaction:NetworkConnected :: tx
$sel:validationError:NetworkConnected :: ValidationError
..}
    StateChanged.SnapshotConfirmed{HeadId
Snapshot tx
MultiSignature (Snapshot tx)
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
snapshot :: Snapshot tx
signatures :: MultiSignature (Snapshot tx)
$sel:snapshot:NetworkConnected :: forall tx. StateChanged tx -> Snapshot tx
$sel:signatures:NetworkConnected :: forall tx. StateChanged tx -> MultiSignature (Snapshot tx)
..} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just SnapshotConfirmed{HeadId
Snapshot tx
MultiSignature (Snapshot tx)
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
snapshot :: Snapshot tx
signatures :: MultiSignature (Snapshot tx)
$sel:snapshot:NetworkConnected :: Snapshot tx
$sel:signatures:NetworkConnected :: MultiSignature (Snapshot tx)
..}
    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{tx
HeadId
UTxOType tx
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
$sel:newLocalUTxO:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
headId :: HeadId
decommitTx :: tx
newLocalUTxO :: UTxOType tx
utxoToDecommit :: UTxOType tx
$sel:decommitTx:NetworkConnected :: forall tx. StateChanged tx -> tx
$sel:utxoToDecommit:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
..} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just DecommitRequested{tx
HeadId
UTxOType tx
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
decommitTx :: tx
utxoToDecommit :: UTxOType tx
$sel:decommitTx:NetworkConnected :: tx
$sel:utxoToDecommit:NetworkConnected :: UTxOType tx
..}
    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
$sel:utxoToDecommit:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
headId :: HeadId
decommitTxId :: TxIdType tx
utxoToDecommit :: UTxOType tx
$sel:decommitTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType 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:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
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
headId :: HeadId
distributedUTxO :: UTxOType tx
$sel:distributedUTxO:NetworkConnected :: UTxOType tx
..}
    StateChanged.DepositRecorded{UTCTime
HeadId
TxIdType tx
UTxOType tx
ChainStateType tx
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
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:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
$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:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
$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{} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just ServerOutput tx
forall tx. ServerOutput tx
EventLogRotated

-- | 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.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 want to project 'HeadId' when the Head is in the 'Initializing'
-- state since this is when Head parties need to commit some funds.
projectCommitInfo :: CommitInfo -> StateChanged.StateChanged tx -> CommitInfo
projectCommitInfo :: forall tx. CommitInfo -> StateChanged tx -> CommitInfo
projectCommitInfo CommitInfo
commitInfo = \case
  StateChanged.HeadInitialized{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId} -> HeadId -> CommitInfo
NormalCommit HeadId
headId
  StateChanged.HeadOpened{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId} -> HeadId -> CommitInfo
IncrementalCommit HeadId
headId
  StateChanged.HeadAborted{} -> CommitInfo
CannotCommit
  StateChanged.HeadClosed{} -> CommitInfo
CannotCommit
  StateChanged tx
_other -> CommitInfo
commitInfo

-- | Projection to obtain the 'HeadId' needed to draft a commit transaction.
-- NOTE: We only want to project 'HeadId' when the Head is in the 'Initializing'
-- state since this is when Head parties need to commit some funds.
projectInitializingHeadId :: Maybe HeadId -> StateChanged.StateChanged tx -> Maybe HeadId
projectInitializingHeadId :: forall tx. Maybe HeadId -> StateChanged tx -> Maybe HeadId
projectInitializingHeadId Maybe HeadId
mHeadId = \case
  StateChanged.HeadInitialized{HeadId
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
headId :: HeadId
headId} -> HeadId -> Maybe HeadId
forall a. a -> Maybe a
Just HeadId
headId
  StateChanged.HeadOpened{} -> Maybe HeadId
forall a. Maybe a
Nothing
  StateChanged.HeadAborted{} -> Maybe HeadId
forall a. Maybe a
Nothing
  StateChanged tx
_other -> Maybe HeadId
mHeadId