{-# 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 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 (..),
  HeadStatus (..),
  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 (..), StateEvent (..))
import Hydra.HeadLogic.Outcome qualified as StateChanged
import Hydra.HeadLogic.State (SeenSnapshot (..), seenSnapshotNumber)
import Hydra.Logging (Tracer, traceWith)
import Hydra.Network (IP, PortNumber)
import Hydra.Tx (ConfirmedSnapshot (..), HeadId, IsTx (..), Party, txId)
import Hydra.Tx qualified as Tx
import Hydra.Tx.Environment (Environment)
import Hydra.Tx.Snapshot (Snapshot (..))
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
    -- Intialize our read models from stored events
    -- NOTE: we do not keep the stored events around in memory
    Projection STM (StateChanged tx) HeadStatus
headStatusP <- HeadStatus
-> (HeadStatus -> StateChanged tx -> HeadStatus)
-> IO (Projection (STM IO) (StateChanged tx) HeadStatus)
forall (m :: * -> *) model event.
MonadSTM m =>
model
-> (model -> event -> model) -> m (Projection (STM m) event model)
mkProjection HeadStatus
Idle HeadStatus -> StateChanged tx -> HeadStatus
forall tx. HeadStatus -> StateChanged tx -> HeadStatus
projectHeadStatus
    Projection STM (StateChanged tx) (Maybe (UTxOType tx))
snapshotUtxoP <- Maybe (UTxOType tx)
-> (Maybe (UTxOType tx) -> StateChanged tx -> Maybe (UTxOType tx))
-> IO (Projection (STM IO) (StateChanged tx) (Maybe (UTxOType tx)))
forall (m :: * -> *) model event.
MonadSTM m =>
model
-> (model -> event -> model) -> m (Projection (STM m) event model)
mkProjection Maybe (UTxOType tx)
forall a. Maybe a
Nothing Maybe (UTxOType tx) -> StateChanged tx -> Maybe (UTxOType tx)
forall tx.
Monoid (UTxOType tx) =>
Maybe (UTxOType tx) -> StateChanged tx -> Maybe (UTxOType tx)
projectSnapshotUtxo
    Projection STM (StateChanged tx) (SeenSnapshot tx)
seenSnapshotP <- SeenSnapshot tx
-> (SeenSnapshot tx -> StateChanged tx -> SeenSnapshot tx)
-> IO (Projection (STM IO) (StateChanged tx) (SeenSnapshot tx))
forall (m :: * -> *) model event.
MonadSTM m =>
model
-> (model -> event -> model) -> m (Projection (STM m) event model)
mkProjection SeenSnapshot tx
forall tx. SeenSnapshot tx
NoSeenSnapshot SeenSnapshot tx -> StateChanged tx -> SeenSnapshot tx
forall tx. SeenSnapshot tx -> StateChanged tx -> SeenSnapshot tx
projectSeenSnapshot
    Projection STM (StateChanged tx) (Maybe (ConfirmedSnapshot tx))
snapshotConfirmedP <- Maybe (ConfirmedSnapshot tx)
-> (Maybe (ConfirmedSnapshot tx)
    -> StateChanged tx -> Maybe (ConfirmedSnapshot tx))
-> IO
     (Projection
        (STM IO) (StateChanged tx) (Maybe (ConfirmedSnapshot tx)))
forall (m :: * -> *) model event.
MonadSTM m =>
model
-> (model -> event -> model) -> m (Projection (STM m) event model)
mkProjection Maybe (ConfirmedSnapshot tx)
forall a. Maybe a
Nothing Maybe (ConfirmedSnapshot tx)
-> StateChanged tx -> Maybe (ConfirmedSnapshot tx)
forall tx.
Maybe (ConfirmedSnapshot tx)
-> StateChanged tx -> Maybe (ConfirmedSnapshot tx)
projectSnapshotConfirmed
    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) HeadStatus
-> StateChanged tx -> STM ()
forall (stm :: * -> *) event model.
Projection stm event model -> event -> stm ()
update Projection STM (StateChanged tx) HeadStatus
headStatusP StateChanged tx
stateChanged
                  Projection STM (StateChanged tx) (Maybe (UTxOType tx))
-> StateChanged tx -> STM ()
forall (stm :: * -> *) event model.
Projection stm event model -> event -> stm ()
update Projection STM (StateChanged tx) (Maybe (UTxOType tx))
snapshotUtxoP StateChanged tx
stateChanged
                  Projection STM (StateChanged tx) (SeenSnapshot tx)
-> StateChanged tx -> STM ()
forall (stm :: * -> *) event model.
Projection stm event model -> event -> stm ()
update Projection STM (StateChanged tx) (SeenSnapshot tx)
seenSnapshotP StateChanged tx
stateChanged
                  Projection STM (StateChanged tx) (Maybe (ConfirmedSnapshot tx))
-> StateChanged tx -> STM ()
forall (stm :: * -> *) event model.
Projection stm event model -> event -> stm ()
update Projection STM (StateChanged tx) (Maybe (ConfirmedSnapshot tx))
snapshotConfirmedP 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) HeadStatus
-> Projection STM (StateChanged tx) (Maybe HeadId)
-> Projection STM (StateChanged tx) (Maybe (UTxOType tx))
-> 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) HeadStatus
-> Projection STM (StateChanged tx) (Maybe HeadId)
-> Projection STM (StateChanged tx) (Maybe (UTxOType tx))
-> 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) HeadStatus
headStatusP Projection STM (StateChanged tx) (Maybe HeadId)
headIdP Projection STM (StateChanged tx) (Maybe (UTxOType tx))
snapshotUtxoP TChan (Either (TimedServerOutput tx) (ClientMessage tx))
responseChannel ServerOutputFilter tx
serverOutputFilter)
              ( Tracer IO APIServerLog
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO CommitInfo
-> IO (Maybe (UTxOType tx))
-> IO (SeenSnapshot tx)
-> IO (Maybe (ConfirmedSnapshot tx))
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> Application
forall tx.
IsChainState tx =>
Tracer IO APIServerLog
-> Chain tx IO
-> Environment
-> PParams LedgerEra
-> IO CommitInfo
-> IO (Maybe (UTxOType tx))
-> IO (SeenSnapshot tx)
-> IO (Maybe (ConfirmedSnapshot tx))
-> IO [TxIdType tx]
-> (ClientInput tx -> IO ())
-> Application
httpApp
                  Tracer IO APIServerLog
tracer
                  Chain tx IO
chain
                  Environment
env
                  PParams LedgerEra
pparams
                  (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 (Maybe (UTxOType tx)) -> IO (Maybe (UTxOType tx))
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO (Maybe (UTxOType tx)) -> IO (Maybe (UTxOType tx)))
-> STM IO (Maybe (UTxOType tx)) -> IO (Maybe (UTxOType tx))
forall a b. (a -> b) -> a -> b
$ Projection STM (StateChanged tx) (Maybe (UTxOType tx))
-> STM (Maybe (UTxOType tx))
forall (stm :: * -> *) event model.
Projection stm event model -> stm model
getLatest Projection STM (StateChanged tx) (Maybe (UTxOType tx))
snapshotUtxoP)
                  (STM IO (SeenSnapshot tx) -> IO (SeenSnapshot tx)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO (SeenSnapshot tx) -> IO (SeenSnapshot tx))
-> STM IO (SeenSnapshot tx) -> IO (SeenSnapshot tx)
forall a b. (a -> b) -> a -> b
$ Projection STM (StateChanged tx) (SeenSnapshot tx)
-> STM (SeenSnapshot tx)
forall (stm :: * -> *) event model.
Projection stm event model -> stm model
getLatest Projection STM (StateChanged tx) (SeenSnapshot tx)
seenSnapshotP)
                  (STM IO (Maybe (ConfirmedSnapshot tx))
-> IO (Maybe (ConfirmedSnapshot tx))
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO (Maybe (ConfirmedSnapshot tx))
 -> IO (Maybe (ConfirmedSnapshot tx)))
-> STM IO (Maybe (ConfirmedSnapshot tx))
-> IO (Maybe (ConfirmedSnapshot tx))
forall a b. (a -> b) -> a -> b
$ Projection STM (StateChanged tx) (Maybe (ConfirmedSnapshot tx))
-> STM (Maybe (ConfirmedSnapshot tx))
forall (stm :: * -> *) event model.
Projection stm event model -> stm model
getLatest Projection STM (StateChanged tx) (Maybe (ConfirmedSnapshot tx))
snapshotConfirmedP)
                  (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) HeadStatus
-> StateChanged tx -> STM ()
forall (stm :: * -> *) event model.
Projection stm event model -> event -> stm ()
update Projection STM (StateChanged tx) HeadStatus
headStatusP 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 (UTxOType tx))
-> StateChanged tx -> STM ()
forall (stm :: * -> *) event model.
Projection stm event model -> event -> stm ()
update Projection STM (StateChanged tx) (Maybe (UTxOType tx))
snapshotUtxoP StateChanged tx
stateChanged
                      Projection STM (StateChanged tx) (SeenSnapshot tx)
-> StateChanged tx -> STM ()
forall (stm :: * -> *) event model.
Projection stm event model -> event -> stm ()
update Projection STM (StateChanged tx) (SeenSnapshot tx)
seenSnapshotP StateChanged tx
stateChanged
                      Projection STM (StateChanged tx) (Maybe (ConfirmedSnapshot tx))
-> StateChanged tx -> STM ()
forall (stm :: * -> *) event model.
Projection stm event model -> event -> stm ()
update Projection STM (StateChanged tx) (Maybe (ConfirmedSnapshot tx))
snapshotConfirmedP 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

  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, $sel:transaction:NetworkConnected :: tx
transaction = 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
$sel:transaction:NetworkConnected :: tx
headId :: HeadId
utxo :: UTxOType tx
transaction :: tx
validationError :: ValidationError
$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
TxIdType tx
SnapshotVersion
ChainStateType tx
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
$sel:chainState:NetworkConnected :: forall tx. StateChanged tx -> ChainStateType tx
$sel:decommitTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
chainState :: ChainStateType tx
headId :: HeadId
decommitTxId :: TxIdType tx
newVersion :: SnapshotVersion
$sel:newVersion:NetworkConnected :: forall tx. StateChanged tx -> SnapshotVersion
..} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just DecommitFinalized{HeadId
TxIdType tx
$sel:headId:NetworkConnected :: HeadId
$sel:decommitTxId:NetworkConnected :: TxIdType tx
headId :: HeadId
decommitTxId :: TxIdType tx
..}
    StateChanged.CommitRecorded{Map (TxIdType tx) (UTxOType tx)
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
$sel:newLocalUTxO:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
chainState :: ChainStateType tx
headId :: HeadId
pendingDeposits :: Map (TxIdType tx) (UTxOType tx)
newLocalUTxO :: UTxOType tx
utxoToCommit :: UTxOType tx
pendingDeposit :: TxIdType tx
deadline :: UTCTime
$sel:pendingDeposits:NetworkConnected :: forall tx. StateChanged tx -> Map (TxIdType tx) (UTxOType tx)
$sel:utxoToCommit:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
$sel:pendingDeposit:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
$sel:deadline:NetworkConnected :: forall tx. StateChanged tx -> UTCTime
..} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just CommitRecorded{UTCTime
HeadId
TxIdType tx
UTxOType tx
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
utxoToCommit :: UTxOType tx
pendingDeposit :: TxIdType tx
deadline :: UTCTime
$sel:utxoToCommit:NetworkConnected :: UTxOType tx
$sel:pendingDeposit:NetworkConnected :: TxIdType tx
$sel:deadline:NetworkConnected :: UTCTime
..}
    StateChanged.CommitApproved{HeadId
UTxOType tx
$sel:headId:NetworkConnected :: forall tx. StateChanged tx -> HeadId
$sel:utxoToCommit:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
headId :: HeadId
utxoToCommit :: 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
chainState :: ChainStateType tx
headId :: HeadId
newVersion :: SnapshotVersion
depositTxId :: TxIdType tx
$sel:depositTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
..} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just CommitFinalized{HeadId
TxIdType tx
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
depositTxId :: TxIdType tx
$sel:depositTxId:NetworkConnected :: TxIdType tx
..}
    StateChanged.CommitRecovered{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:newLocalUTxO:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
chainState :: ChainStateType tx
headId :: HeadId
recoveredUTxO :: UTxOType tx
newLocalUTxO :: UTxOType tx
recoveredTxId :: TxIdType tx
$sel:recoveredUTxO:NetworkConnected :: forall tx. StateChanged tx -> UTxOType tx
$sel:recoveredTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
..} -> ServerOutput tx -> Maybe (ServerOutput tx)
forall a. a -> Maybe a
Just CommitRecovered{HeadId
TxIdType tx
UTxOType tx
$sel:headId:NetworkConnected :: HeadId
headId :: HeadId
recoveredUTxO :: UTxOType tx
recoveredTxId :: TxIdType tx
$sel:recoveredUTxO:NetworkConnected :: UTxOType tx
$sel:recoveredTxId:NetworkConnected :: 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.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
..}

--

-- | 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.CommitRecorded{TxIdType tx
$sel:pendingDeposit:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
pendingDeposit :: TxIdType tx
pendingDeposit} -> TxIdType tx
pendingDeposit TxIdType tx -> [TxIdType tx] -> [TxIdType tx]
forall a. a -> [a] -> [a]
: [TxIdType tx]
txIds
  StateChanged.CommitRecovered{TxIdType tx
$sel:recoveredTxId:NetworkConnected :: forall tx. StateChanged tx -> TxIdType tx
recoveredTxId :: TxIdType tx
recoveredTxId} -> (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
recoveredTxId) [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

-- | Projection function related to 'headStatus' field in 'Greetings' message.
projectHeadStatus :: HeadStatus -> StateChanged.StateChanged tx -> HeadStatus
projectHeadStatus :: forall tx. HeadStatus -> StateChanged tx -> HeadStatus
projectHeadStatus HeadStatus
headStatus = \case
  StateChanged.HeadInitialized{} -> HeadStatus
Initializing
  StateChanged.HeadOpened{} -> HeadStatus
Open
  StateChanged.HeadClosed{} -> HeadStatus
Closed
  StateChanged.HeadIsReadyToFanout{} -> HeadStatus
FanoutPossible
  StateChanged.HeadFannedOut{} -> HeadStatus
Final
  StateChanged tx
_other -> HeadStatus
headStatus

-- | Projection of latest confirmed snapshot UTxO.
projectSnapshotUtxo :: Monoid (UTxOType tx) => Maybe (UTxOType tx) -> StateChanged.StateChanged tx -> Maybe (UTxOType tx)
projectSnapshotUtxo :: forall tx.
Monoid (UTxOType tx) =>
Maybe (UTxOType tx) -> StateChanged tx -> Maybe (UTxOType tx)
projectSnapshotUtxo Maybe (UTxOType tx)
snapshotUtxo = \case
  StateChanged.SnapshotConfirmed HeadId
_ Snapshot tx
snapshot MultiSignature (Snapshot tx)
_ -> UTxOType tx -> Maybe (UTxOType tx)
forall a. a -> Maybe a
Just (UTxOType tx -> Maybe (UTxOType tx))
-> UTxOType tx -> Maybe (UTxOType tx)
forall a b. (a -> b) -> a -> b
$ Snapshot tx -> UTxOType tx
forall tx. Snapshot tx -> UTxOType tx
Tx.utxo Snapshot tx
snapshot UTxOType tx -> UTxOType tx -> UTxOType tx
forall a. Semigroup a => a -> a -> a
<> UTxOType tx -> Maybe (UTxOType tx) -> UTxOType tx
forall a. a -> Maybe a -> a
fromMaybe UTxOType tx
forall a. Monoid a => a
mempty (Snapshot tx -> Maybe (UTxOType tx)
forall tx. Snapshot tx -> Maybe (UTxOType tx)
Tx.utxoToCommit Snapshot tx
snapshot)
  StateChanged.HeadOpened HeadId
_ ChainStateType tx
_ UTxOType tx
utxos -> UTxOType tx -> Maybe (UTxOType tx)
forall a. a -> Maybe a
Just UTxOType tx
utxos
  StateChanged tx
_other -> Maybe (UTxOType tx)
snapshotUtxo

-- | Projection of latest seen snapshot.
projectSeenSnapshot :: SeenSnapshot tx -> StateChanged.StateChanged tx -> SeenSnapshot tx
projectSeenSnapshot :: forall tx. SeenSnapshot tx -> StateChanged tx -> SeenSnapshot tx
projectSeenSnapshot SeenSnapshot tx
seenSnapshot = \case
  StateChanged.SnapshotRequestDecided{SnapshotNumber
$sel:snapshotNumber:NetworkConnected :: forall tx. StateChanged tx -> SnapshotNumber
snapshotNumber :: SnapshotNumber
snapshotNumber} ->
    RequestedSnapshot
      { $sel:lastSeen:NoSeenSnapshot :: SnapshotNumber
lastSeen = SeenSnapshot tx -> SnapshotNumber
forall tx. SeenSnapshot tx -> SnapshotNumber
seenSnapshotNumber SeenSnapshot tx
seenSnapshot
      , $sel:requested:NoSeenSnapshot :: SnapshotNumber
requested = SnapshotNumber
snapshotNumber
      }
  StateChanged.SnapshotRequested{Snapshot tx
$sel:snapshot:NetworkConnected :: forall tx. StateChanged tx -> Snapshot tx
snapshot :: Snapshot tx
snapshot} ->
    Snapshot tx
-> Map Party (Signature (Snapshot tx)) -> SeenSnapshot tx
forall tx.
Snapshot tx
-> Map Party (Signature (Snapshot tx)) -> SeenSnapshot tx
SeenSnapshot Snapshot tx
snapshot Map Party (Signature (Snapshot tx))
forall a. Monoid a => a
mempty
  StateChanged.HeadOpened{} ->
    SeenSnapshot tx
forall tx. SeenSnapshot tx
NoSeenSnapshot
  StateChanged.SnapshotConfirmed{$sel:snapshot:NetworkConnected :: forall tx. StateChanged tx -> Snapshot tx
snapshot = Snapshot{SnapshotNumber
number :: SnapshotNumber
$sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number}} ->
    SnapshotNumber -> SeenSnapshot tx
forall tx. SnapshotNumber -> SeenSnapshot tx
LastSeenSnapshot SnapshotNumber
number
  StateChanged.PartySignedSnapshot{Party
$sel:party:NetworkConnected :: forall tx. StateChanged tx -> Party
party :: Party
party, Signature (Snapshot tx)
signature :: Signature (Snapshot tx)
$sel:signature:NetworkConnected :: forall tx. StateChanged tx -> Signature (Snapshot tx)
signature} ->
    case SeenSnapshot tx
seenSnapshot of
      ss :: SeenSnapshot tx
ss@SeenSnapshot{Map Party (Signature (Snapshot tx))
signatories :: Map Party (Signature (Snapshot tx))
$sel:signatories:NoSeenSnapshot :: forall tx. SeenSnapshot tx -> Map Party (Signature (Snapshot tx))
signatories} ->
        SeenSnapshot tx
ss{signatories = Map.insert party signature signatories}
      SeenSnapshot tx
_ -> SeenSnapshot tx
seenSnapshot
  StateChanged.LocalStateCleared{SnapshotNumber
$sel:snapshotNumber:NetworkConnected :: forall tx. StateChanged tx -> SnapshotNumber
snapshotNumber :: SnapshotNumber
snapshotNumber} ->
    case SnapshotNumber
snapshotNumber of
      SnapshotNumber
0 -> SeenSnapshot tx
forall tx. SeenSnapshot tx
NoSeenSnapshot
      SnapshotNumber
_ -> SnapshotNumber -> SeenSnapshot tx
forall tx. SnapshotNumber -> SeenSnapshot tx
LastSeenSnapshot SnapshotNumber
snapshotNumber
  StateChanged tx
_other -> SeenSnapshot tx
seenSnapshot

-- | Projection of latest confirmed snapshot.
projectSnapshotConfirmed :: Maybe (ConfirmedSnapshot tx) -> StateChanged.StateChanged tx -> Maybe (ConfirmedSnapshot tx)
projectSnapshotConfirmed :: forall tx.
Maybe (ConfirmedSnapshot tx)
-> StateChanged tx -> Maybe (ConfirmedSnapshot tx)
projectSnapshotConfirmed Maybe (ConfirmedSnapshot tx)
snapshotConfirmed = \case
  StateChanged.SnapshotConfirmed HeadId
_ Snapshot tx
snapshot MultiSignature (Snapshot tx)
signatures -> ConfirmedSnapshot tx -> Maybe (ConfirmedSnapshot tx)
forall a. a -> Maybe a
Just (ConfirmedSnapshot tx -> Maybe (ConfirmedSnapshot tx))
-> ConfirmedSnapshot tx -> Maybe (ConfirmedSnapshot tx)
forall a b. (a -> b) -> a -> b
$ Snapshot tx -> MultiSignature (Snapshot tx) -> ConfirmedSnapshot tx
forall tx.
Snapshot tx -> MultiSignature (Snapshot tx) -> ConfirmedSnapshot tx
ConfirmedSnapshot Snapshot tx
snapshot MultiSignature (Snapshot tx)
signatures
  StateChanged.HeadOpened HeadId
headId ChainStateType tx
_ UTxOType tx
utxos -> ConfirmedSnapshot tx -> Maybe (ConfirmedSnapshot tx)
forall a. a -> Maybe a
Just (ConfirmedSnapshot tx -> Maybe (ConfirmedSnapshot tx))
-> ConfirmedSnapshot tx -> Maybe (ConfirmedSnapshot tx)
forall a b. (a -> b) -> a -> b
$ HeadId -> UTxOType tx -> ConfirmedSnapshot tx
forall tx. HeadId -> UTxOType tx -> ConfirmedSnapshot tx
InitialSnapshot HeadId
headId UTxOType tx
utxos
  StateChanged tx
_other -> Maybe (ConfirmedSnapshot tx)
snapshotConfirmed