{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MonoLocalBinds        #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeOperators         #-}
{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}

module Plutus.PAB.Webserver.Server
    ( startServer
    , startServer'
    , startServerDebug
    , startServerDebug'
    ) where

import Control.Concurrent (MVar, forkFinally, forkIO, newEmptyMVar, putMVar)
import Control.Concurrent.Availability (Availability, available, newToken)
import Control.Concurrent.STM qualified as STM
import Control.Monad (void, when)
import Control.Monad.Except (ExceptT (ExceptT))
import Control.Monad.Freer.Extras.Log (logInfo, logWarn)
import Control.Monad.IO.Class (liftIO)
import Data.Aeson (FromJSON, ToJSON)
import Data.Bifunctor (first)
import Data.ByteString.Lazy.Char8 qualified as LBS
import Data.Function ((&))
import Data.Monoid (Endo (Endo, appEndo))
import Data.OpenApi.Schema qualified as OpenApi
import Data.Proxy (Proxy (Proxy))
import Network.Wai (Middleware)
import Network.Wai.Handler.Warp qualified as Warp
import Network.Wai.Handler.WarpTLS qualified as WarpTLS
import Network.Wai.Middleware.Cors qualified as Cors
import Network.Wai.Middleware.Servant.Options qualified as Cors
import Plutus.PAB.Core (PABAction, PABRunner (PABRunner, runPABAction))
import Plutus.PAB.Core qualified as Core
import Plutus.PAB.Effects.Contract qualified as Contract
import Plutus.PAB.Monitoring.PABLogMsg qualified as LM
import Plutus.PAB.Simulator (Simulation)
import Plutus.PAB.Types (PABError,
                         WebserverConfig (WebserverConfig, certificatePath, endpointTimeout, keyPath, permissiveCorsPolicy, staticDir),
                         baseUrl, defaultWebServerConfig)
import Plutus.PAB.Webserver.API (API, SwaggerAPI, WSAPI)
import Plutus.PAB.Webserver.Handler (apiHandler, swagger)
import Plutus.PAB.Webserver.WebSocket qualified as WS
import Servant (Application, Handler (Handler), Raw, ServerT, err500, errBody, hoistServer, serve,
                serveDirectoryFileServer, (:<|>) ((:<|>)))
import Servant qualified
import Servant.Client (BaseUrl (baseUrlPort))
import Wallet.Emulator.Wallet (WalletId)

asHandler :: forall t env a. PABRunner t env -> PABAction t env a -> Handler a
asHandler :: PABRunner t env -> PABAction t env a -> Handler a
asHandler PABRunner{forall a. PABAction t env a -> IO (Either PABError a)
runPABAction :: forall a. PABAction t env a -> IO (Either PABError a)
runPABAction :: forall t env.
PABRunner t env
-> forall a. PABAction t env a -> IO (Either PABError a)
runPABAction} = ExceptT ServerError IO a -> Handler a
forall a. ExceptT ServerError IO a -> Handler a
Servant.Handler (ExceptT ServerError IO a -> Handler a)
-> (PABAction t env a -> ExceptT ServerError IO a)
-> PABAction t env a
-> Handler a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either ServerError a) -> ExceptT ServerError IO a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ServerError a) -> ExceptT ServerError IO a)
-> (PABAction t env a -> IO (Either ServerError a))
-> PABAction t env a
-> ExceptT ServerError IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either PABError a -> Either ServerError a)
-> IO (Either PABError a) -> IO (Either ServerError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((PABError -> ServerError)
-> Either PABError a -> Either ServerError a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first PABError -> ServerError
mapError) (IO (Either PABError a) -> IO (Either ServerError a))
-> (PABAction t env a -> IO (Either PABError a))
-> PABAction t env a
-> IO (Either ServerError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PABAction t env a -> IO (Either PABError a)
forall a. PABAction t env a -> IO (Either PABError a)
runPABAction where
    mapError :: PABError -> Servant.ServerError
    mapError :: PABError -> ServerError
mapError PABError
e = ServerError
Servant.err500 { errBody :: ByteString
Servant.errBody = [Char] -> ByteString
LBS.pack ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ PABError -> [Char]
forall a. Show a => a -> [Char]
show PABError
e }

type CombinedAPI t = BaseCombinedAPI t :<|> SwaggerAPI

type BaseCombinedAPI t =
    API (Contract.ContractDef t) WalletId
    :<|> WSAPI

app ::
    forall t env.
    ( FromJSON (Contract.ContractDef t)
    , ToJSON (Contract.ContractDef t)
    , Contract.PABContract t
    , Servant.MimeUnrender Servant.JSON (Contract.ContractDef t)
    , OpenApi.ToSchema (Contract.ContractDef t)
    ) =>
    Maybe FilePath
    -> PABRunner t env
    -> Application
app :: Maybe [Char] -> PABRunner t env -> Application
app Maybe [Char]
fp PABRunner t env
pabRunner = do
    let apiServer :: ServerT (CombinedAPI t) Handler
        apiServer :: ServerT (CombinedAPI t) Handler
apiServer =
            Proxy (API (ContractDef t) WalletId :<|> WSAPI)
-> (forall x. Eff (PABEffects t env) x -> Handler x)
-> ServerT
     (API (ContractDef t) WalletId :<|> WSAPI) (Eff (PABEffects t env))
-> ServerT (API (ContractDef t) WalletId :<|> WSAPI) Handler
forall api (m :: * -> *) (n :: * -> *).
HasServer api '[] =>
Proxy api
-> (forall x. m x -> n x) -> ServerT api m -> ServerT api n
Servant.hoistServer
                (Proxy (API (ContractDef t) WalletId :<|> WSAPI)
forall k (t :: k). Proxy t
Proxy @(BaseCombinedAPI t))
                (PABRunner t env -> PABAction t env x -> Handler x
forall t env a. PABRunner t env -> PABAction t env a -> Handler a
asHandler PABRunner t env
pabRunner)
                (PABAction t env ()
:<|> (PABAction t env (FullReport (ContractDef t))
      :<|> ((ContractActivationArgs (ContractDef t)
             -> PABAction t env ContractInstanceId)
            :<|> ((ContractInstanceId
                   -> PABAction t env (ContractInstanceClientState (ContractDef t))
                      :<|> (PABAction t env (ContractSignatureResponse (ContractDef t))
                            :<|> (([Char] -> Value -> PABAction t env ())
                                  :<|> PABAction t env ())))
                  :<|> ((WalletId
                         -> Maybe Text
                         -> PABAction t env [ContractInstanceClientState (ContractDef t)])
                        :<|> ((Maybe Text
                               -> PABAction t env [ContractInstanceClientState (ContractDef t)])
                              :<|> PABAction
                                     t env [ContractSignatureResponse (ContractDef t)])))))
forall t env.
PABContract t =>
PABAction t env ()
:<|> (PABAction t env (FullReport (ContractDef t))
      :<|> ((ContractActivationArgs (ContractDef t)
             -> PABAction t env ContractInstanceId)
            :<|> ((ContractInstanceId
                   -> PABAction t env (ContractInstanceClientState (ContractDef t))
                      :<|> (PABAction t env (ContractSignatureResponse (ContractDef t))
                            :<|> (([Char] -> Value -> PABAction t env ())
                                  :<|> PABAction t env ())))
                  :<|> ((WalletId
                         -> Maybe Text
                         -> PABAction t env [ContractInstanceClientState (ContractDef t)])
                        :<|> ((Maybe Text
                               -> PABAction t env [ContractInstanceClientState (ContractDef t)])
                              :<|> PABAction
                                     t env [ContractSignatureResponse (ContractDef t)])))))
apiHandler (PABAction t env ()
 :<|> (PABAction t env (FullReport (ContractDef t))
       :<|> ((ContractActivationArgs (ContractDef t)
              -> PABAction t env ContractInstanceId)
             :<|> ((ContractInstanceId
                    -> PABAction t env (ContractInstanceClientState (ContractDef t))
                       :<|> (PABAction t env (ContractSignatureResponse (ContractDef t))
                             :<|> (([Char] -> Value -> PABAction t env ())
                                   :<|> PABAction t env ())))
                   :<|> ((WalletId
                          -> Maybe Text
                          -> PABAction t env [ContractInstanceClientState (ContractDef t)])
                         :<|> ((Maybe Text
                                -> PABAction t env [ContractInstanceClientState (ContractDef t)])
                               :<|> PABAction
                                      t env [ContractSignatureResponse (ContractDef t)]))))))
-> ((ContractInstanceId -> PendingConnection -> PABAction t env ())
    :<|> (PendingConnection -> PABAction t env ()))
-> (PABAction t env ()
    :<|> (PABAction t env (FullReport (ContractDef t))
          :<|> ((ContractActivationArgs (ContractDef t)
                 -> PABAction t env ContractInstanceId)
                :<|> ((ContractInstanceId
                       -> PABAction t env (ContractInstanceClientState (ContractDef t))
                          :<|> (PABAction t env (ContractSignatureResponse (ContractDef t))
                                :<|> (([Char] -> Value -> PABAction t env ())
                                      :<|> PABAction t env ())))
                      :<|> ((WalletId
                             -> Maybe Text
                             -> PABAction t env [ContractInstanceClientState (ContractDef t)])
                            :<|> ((Maybe Text
                                   -> PABAction t env [ContractInstanceClientState (ContractDef t)])
                                  :<|> PABAction
                                         t env [ContractSignatureResponse (ContractDef t)]))))))
   :<|> ((ContractInstanceId
          -> PendingConnection -> PABAction t env ())
         :<|> (PendingConnection -> PABAction t env ()))
forall a b. a -> b -> a :<|> b
:<|> (ContractInstanceId -> PendingConnection -> PABAction t env ())
:<|> (PendingConnection -> PABAction t env ())
forall t env.
(ContractInstanceId -> PendingConnection -> PABAction t env ())
:<|> (PendingConnection -> PABAction t env ())
WS.wsHandler) ((Handler ()
  :<|> (Handler (FullReport (ContractDef t))
        :<|> ((ContractActivationArgs (ContractDef t)
               -> Handler ContractInstanceId)
              :<|> ((ContractInstanceId
                     -> Handler (ContractInstanceClientState (ContractDef t))
                        :<|> (Handler (ContractSignatureResponse (ContractDef t))
                              :<|> (([Char] -> Value -> Handler ()) :<|> Handler ())))
                    :<|> ((WalletId
                           -> Maybe Text
                           -> Handler [ContractInstanceClientState (ContractDef t)])
                          :<|> ((Maybe Text
                                 -> Handler [ContractInstanceClientState (ContractDef t)])
                                :<|> Handler [ContractSignatureResponse (ContractDef t)]))))))
 :<|> ((ContractInstanceId -> PendingConnection -> Handler ())
       :<|> (PendingConnection -> Handler ())))
-> (Handler Value
    :<|> (Handler
            (SwaggerUiHtml "swagger-ui" ("swagger.json" :> Get '[JSON] Value))
          :<|> (Handler
                  (SwaggerUiHtml "swagger-ui" ("swagger.json" :> Get '[JSON] Value))
                :<|> Tagged Handler Application)))
-> ((Handler ()
     :<|> (Handler (FullReport (ContractDef t))
           :<|> ((ContractActivationArgs (ContractDef t)
                  -> Handler ContractInstanceId)
                 :<|> ((ContractInstanceId
                        -> Handler (ContractInstanceClientState (ContractDef t))
                           :<|> (Handler (ContractSignatureResponse (ContractDef t))
                                 :<|> (([Char] -> Value -> Handler ()) :<|> Handler ())))
                       :<|> ((WalletId
                              -> Maybe Text
                              -> Handler [ContractInstanceClientState (ContractDef t)])
                             :<|> ((Maybe Text
                                    -> Handler [ContractInstanceClientState (ContractDef t)])
                                   :<|> Handler [ContractSignatureResponse (ContractDef t)]))))))
    :<|> ((ContractInstanceId -> PendingConnection -> Handler ())
          :<|> (PendingConnection -> Handler ())))
   :<|> (Handler Value
         :<|> (Handler
                 (SwaggerUiHtml "swagger-ui" ("swagger.json" :> Get '[JSON] Value))
               :<|> (Handler
                       (SwaggerUiHtml "swagger-ui" ("swagger.json" :> Get '[JSON] Value))
                     :<|> Tagged Handler Application)))
forall a b. a -> b -> a :<|> b
:<|> (forall t api (dir :: Symbol).
(Server api ~ Handler Value, ToSchema (ContractDef t)) =>
Server (SwaggerSchemaUI' dir api)
forall api (dir :: Symbol).
(Server api ~ Handler Value, ToSchema (ContractDef t)) =>
Server (SwaggerSchemaUI' dir api)
swagger @t)

    case Maybe [Char]
fp of
        Maybe [Char]
Nothing -> do
            Proxy (CombinedAPI t)
-> ServerT (CombinedAPI t) Handler -> Application
forall api.
HasServer api '[] =>
Proxy api -> Server api -> Application
Servant.serve (Proxy (CombinedAPI t)
forall k (t :: k). Proxy t
Proxy @(CombinedAPI t)) ServerT (CombinedAPI t) Handler
apiServer
        Just [Char]
filePath -> do
            let
                fileServer :: ServerT Raw Handler
                fileServer :: ServerT Raw Handler
fileServer = [Char] -> ServerT Raw Handler
forall (m :: * -> *). [Char] -> ServerT Raw m
serveDirectoryFileServer [Char]
filePath
            Proxy (CombinedAPI t :<|> Raw)
-> Server (CombinedAPI t :<|> Raw) -> Application
forall api.
HasServer api '[] =>
Proxy api -> Server api -> Application
Servant.serve (Proxy (CombinedAPI t :<|> Raw)
forall k (t :: k). Proxy t
Proxy @(CombinedAPI t :<|> Raw)) (((Handler ()
  :<|> (Handler (FullReport (ContractDef t))
        :<|> ((ContractActivationArgs (ContractDef t)
               -> Handler ContractInstanceId)
              :<|> ((ContractInstanceId
                     -> Handler (ContractInstanceClientState (ContractDef t))
                        :<|> (Handler (ContractSignatureResponse (ContractDef t))
                              :<|> (([Char] -> Value -> Handler ()) :<|> Handler ())))
                    :<|> ((WalletId
                           -> Maybe Text
                           -> Handler [ContractInstanceClientState (ContractDef t)])
                          :<|> ((Maybe Text
                                 -> Handler [ContractInstanceClientState (ContractDef t)])
                                :<|> Handler [ContractSignatureResponse (ContractDef t)]))))))
 :<|> ((ContractInstanceId -> PendingConnection -> Handler ())
       :<|> (PendingConnection -> Handler ())))
:<|> (Handler Value
      :<|> (Handler
              (SwaggerUiHtml "swagger-ui" ("swagger.json" :> Get '[JSON] Value))
            :<|> (Handler
                    (SwaggerUiHtml "swagger-ui" ("swagger.json" :> Get '[JSON] Value))
                  :<|> Tagged Handler Application)))
ServerT (CombinedAPI t) Handler
apiServer (((Handler ()
   :<|> (Handler (FullReport (ContractDef t))
         :<|> ((ContractActivationArgs (ContractDef t)
                -> Handler ContractInstanceId)
               :<|> ((ContractInstanceId
                      -> Handler (ContractInstanceClientState (ContractDef t))
                         :<|> (Handler (ContractSignatureResponse (ContractDef t))
                               :<|> (([Char] -> Value -> Handler ()) :<|> Handler ())))
                     :<|> ((WalletId
                            -> Maybe Text
                            -> Handler [ContractInstanceClientState (ContractDef t)])
                           :<|> ((Maybe Text
                                  -> Handler [ContractInstanceClientState (ContractDef t)])
                                 :<|> Handler [ContractSignatureResponse (ContractDef t)]))))))
  :<|> ((ContractInstanceId -> PendingConnection -> Handler ())
        :<|> (PendingConnection -> Handler ())))
 :<|> (Handler Value
       :<|> (Handler
               (SwaggerUiHtml "swagger-ui" ("swagger.json" :> Get '[JSON] Value))
             :<|> (Handler
                     (SwaggerUiHtml "swagger-ui" ("swagger.json" :> Get '[JSON] Value))
                   :<|> Tagged Handler Application))))
-> Tagged Handler Application
-> (((Handler ()
      :<|> (Handler (FullReport (ContractDef t))
            :<|> ((ContractActivationArgs (ContractDef t)
                   -> Handler ContractInstanceId)
                  :<|> ((ContractInstanceId
                         -> Handler (ContractInstanceClientState (ContractDef t))
                            :<|> (Handler (ContractSignatureResponse (ContractDef t))
                                  :<|> (([Char] -> Value -> Handler ()) :<|> Handler ())))
                        :<|> ((WalletId
                               -> Maybe Text
                               -> Handler [ContractInstanceClientState (ContractDef t)])
                              :<|> ((Maybe Text
                                     -> Handler [ContractInstanceClientState (ContractDef t)])
                                    :<|> Handler [ContractSignatureResponse (ContractDef t)]))))))
     :<|> ((ContractInstanceId -> PendingConnection -> Handler ())
           :<|> (PendingConnection -> Handler ())))
    :<|> (Handler Value
          :<|> (Handler
                  (SwaggerUiHtml "swagger-ui" ("swagger.json" :> Get '[JSON] Value))
                :<|> (Handler
                        (SwaggerUiHtml "swagger-ui" ("swagger.json" :> Get '[JSON] Value))
                      :<|> Tagged Handler Application))))
   :<|> Tagged Handler Application
forall a b. a -> b -> a :<|> b
:<|> Tagged Handler Application
ServerT Raw Handler
fileServer)

-- | Start the server using the config. Returns an action that shuts it down
--   again, and an MVar that is filled when the webserver
--   thread exits.
startServer ::
    forall t env.
    ( FromJSON (Contract.ContractDef t)
    , ToJSON (Contract.ContractDef t)
    , Contract.PABContract t
    , Servant.MimeUnrender Servant.JSON (Contract.ContractDef t)
    , OpenApi.ToSchema (Contract.ContractDef t)
    )
    => WebserverConfig -- ^ Optional file path for static assets
    -> Availability
    -> PABAction t env (MVar (), PABAction t env ())
startServer :: WebserverConfig
-> Availability -> PABAction t env (MVar (), PABAction t env ())
startServer WebserverConfig{BaseUrl
baseUrl :: BaseUrl
baseUrl :: WebserverConfig -> BaseUrl
baseUrl, Maybe [Char]
staticDir :: Maybe [Char]
staticDir :: WebserverConfig -> Maybe [Char]
staticDir, Bool
permissiveCorsPolicy :: Bool
permissiveCorsPolicy :: WebserverConfig -> Bool
permissiveCorsPolicy, Maybe Second
endpointTimeout :: Maybe Second
endpointTimeout :: WebserverConfig -> Maybe Second
endpointTimeout, Maybe [Char]
certificatePath :: Maybe [Char]
certificatePath :: WebserverConfig -> Maybe [Char]
certificatePath, Maybe [Char]
keyPath :: Maybe [Char]
keyPath :: WebserverConfig -> Maybe [Char]
keyPath} Availability
availability = do
    Bool -> PABAction t env () -> PABAction t env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
permissiveCorsPolicy (PABAction t env () -> PABAction t env ())
-> PABAction t env () -> PABAction t env ()
forall a b. (a -> b) -> a -> b
$
      PABMultiAgentMsg t -> PABAction t env ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logWarn @(LM.PABMultiAgentMsg t) (Text -> PABMultiAgentMsg t
forall t. Text -> PABMultiAgentMsg t
LM.UserLog Text
"Warning: Using a very permissive CORS policy! *Any* website serving JavaScript can interact with these endpoints.")
    [Middleware]
-> Int
-> Maybe TLSSettings
-> Maybe [Char]
-> Availability
-> Int
-> PABAction t env (MVar (), PABAction t env ())
forall t env.
(FromJSON (ContractDef t), ToJSON (ContractDef t), PABContract t,
 MimeUnrender JSON (ContractDef t), ToSchema (ContractDef t)) =>
[Middleware]
-> Int
-> Maybe TLSSettings
-> Maybe [Char]
-> Availability
-> Int
-> PABAction t env (MVar (), PABAction t env ())
startServer' [Middleware]
middlewares (BaseUrl -> Int
baseUrlPort BaseUrl
baseUrl) Maybe TLSSettings
tlsSettings Maybe [Char]
staticDir Availability
availability (Maybe Second -> Int
forall a p. (Integral a, Num p) => Maybe a -> p
timeout Maybe Second
endpointTimeout)
      where
        middlewares :: [Middleware]
middlewares = if Bool
permissiveCorsPolicy then [Middleware]
corsMiddlewares else []
        corsMiddlewares :: [Middleware]
corsMiddlewares =
            [ -- a custom CORS policy since 'simpleCors' doesn't support "content-type" header by default
            let policy :: CorsResourcePolicy
policy = CorsResourcePolicy
Cors.simpleCorsResourcePolicy { corsRequestHeaders :: [HeaderName]
Cors.corsRequestHeaders = [ HeaderName
"content-type" ] }
            in (Request -> Maybe CorsResourcePolicy) -> Middleware
Cors.cors (Maybe CorsResourcePolicy -> Request -> Maybe CorsResourcePolicy
forall a b. a -> b -> a
const (Maybe CorsResourcePolicy -> Request -> Maybe CorsResourcePolicy)
-> Maybe CorsResourcePolicy -> Request -> Maybe CorsResourcePolicy
forall a b. (a -> b) -> a -> b
$ CorsResourcePolicy -> Maybe CorsResourcePolicy
forall a. a -> Maybe a
Just CorsResourcePolicy
policy)
            -- this middleware handles preflight OPTIONS browser requests
            , Proxy (API (ContractDef t) Integer) -> Middleware
forall api.
(GenerateList NoContent (Foreign NoContent api),
 HasForeign NoTypes NoContent api) =>
Proxy api -> Middleware
Cors.provideOptions (Proxy (API (ContractDef t) Integer)
forall k (t :: k). Proxy t
Proxy @(API (Contract.ContractDef t) Integer))
            ]
        tlsSettings :: Maybe TLSSettings
tlsSettings = [Char] -> [Char] -> TLSSettings
WarpTLS.tlsSettings ([Char] -> [Char] -> TLSSettings)
-> Maybe [Char] -> Maybe ([Char] -> TLSSettings)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Char]
certificatePath Maybe ([Char] -> TLSSettings) -> Maybe [Char] -> Maybe TLSSettings
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe [Char]
keyPath
        -- By default we use the normal request timeout: 30 seconds. But if
        -- someone has asked for a longer endpoint timeout, we need to set
        -- that to be the webserver timeout as well.
        timeout :: Maybe a -> p
timeout Maybe a
Nothing  = p
30
        timeout (Just a
s) = a -> p
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> p) -> a -> p
forall a b. (a -> b) -> a -> b
$ a -> a -> a
forall a. Ord a => a -> a -> a
max a
s a
30

-- | Start the server. Returns an action that shuts it down
--   again, and an MVar that is filled when the webserver
--   thread exits.
startServer' ::
    forall t env.
    ( FromJSON (Contract.ContractDef t)
    , ToJSON (Contract.ContractDef t)
    , Contract.PABContract t
    , Servant.MimeUnrender Servant.JSON (Contract.ContractDef t)
    , OpenApi.ToSchema (Contract.ContractDef t)
    )
    => [Middleware] -- ^ Optional wai middleware
    -> Int -- ^ Port
    -> Maybe WarpTLS.TLSSettings -- ^ Optionally use HTTPS with these settings
    -> Maybe FilePath -- ^ Optional file path for static assets
    -> Availability
    -> Int
    -> PABAction t env (MVar (), PABAction t env ())
startServer' :: [Middleware]
-> Int
-> Maybe TLSSettings
-> Maybe [Char]
-> Availability
-> Int
-> PABAction t env (MVar (), PABAction t env ())
startServer' [Middleware]
waiMiddlewares Int
port Maybe TLSSettings
tlsSettings Maybe [Char]
staticPath Availability
availability Int
timeout = do
    PABRunner t env
simRunner <- PABAction t env (PABRunner t env)
forall t env. PABAction t env (PABRunner t env)
Core.pabRunner
    TMVar ()
shutdownVar <- IO (TMVar ()) -> Eff (PABEffects t env) (TMVar ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TMVar ()) -> Eff (PABEffects t env) (TMVar ()))
-> IO (TMVar ()) -> Eff (PABEffects t env) (TMVar ())
forall a b. (a -> b) -> a -> b
$ STM (TMVar ()) -> IO (TMVar ())
forall a. STM a -> IO a
STM.atomically (STM (TMVar ()) -> IO (TMVar ()))
-> STM (TMVar ()) -> IO (TMVar ())
forall a b. (a -> b) -> a -> b
$ STM (TMVar ())
forall a. STM (TMVar a)
STM.newEmptyTMVar @()
    MVar ()
mvar <- IO (MVar ()) -> Eff (PABEffects t env) (MVar ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

    let shutdownHandler :: IO () -> IO ()
        shutdownHandler :: IO () -> IO ()
shutdownHandler IO ()
doShutdown = IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
            STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> STM ()
forall a. TMVar a -> STM a
STM.takeTMVar TMVar ()
shutdownVar
            [Char] -> IO ()
putStrLn [Char]
"webserver: shutting down"
            IO ()
doShutdown
        warpSettings :: Warp.Settings
        warpSettings :: Settings
warpSettings = Settings
Warp.defaultSettings
            Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
& Int -> Settings -> Settings
Warp.setPort Int
port
            Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
& (IO () -> IO ()) -> Settings -> Settings
Warp.setInstallShutdownHandler IO () -> IO ()
shutdownHandler
            Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
& IO () -> Settings -> Settings
Warp.setBeforeMainLoop (Availability -> IO ()
forall (m :: * -> *). MonadIO m => Availability -> m ()
available Availability
availability)
            Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
& Int -> Settings -> Settings
Warp.setTimeout Int
timeout
            Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
& HostPreference -> Settings -> Settings
Warp.setHost HostPreference
"*6" -- HostIPv6@ - "any IPv4 or IPv6 hostname, IPv6 preferred"
        middleware :: Middleware
middleware = Endo Application -> Middleware
forall a. Endo a -> a -> a
appEndo (Endo Application -> Middleware) -> Endo Application -> Middleware
forall a b. (a -> b) -> a -> b
$ (Middleware -> Endo Application)
-> [Middleware] -> Endo Application
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Middleware -> Endo Application
forall a. (a -> a) -> Endo a
Endo [Middleware]
waiMiddlewares
        run :: Settings -> Application -> IO ()
run = (Settings -> Application -> IO ())
-> (TLSSettings -> Settings -> Application -> IO ())
-> Maybe TLSSettings
-> Settings
-> Application
-> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Settings -> Application -> IO ()
Warp.runSettings TLSSettings -> Settings -> Application -> IO ()
WarpTLS.runTLS Maybe TLSSettings
tlsSettings
    PABMultiAgentMsg t -> PABAction t env ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logInfo @(LM.PABMultiAgentMsg t) (Int -> PABMultiAgentMsg t
forall t. Int -> PABMultiAgentMsg t
LM.StartingPABBackendServer Int
port)
    Eff (PABEffects t env) ThreadId -> PABAction t env ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Eff (PABEffects t env) ThreadId -> PABAction t env ())
-> Eff (PABEffects t env) ThreadId -> PABAction t env ()
forall a b. (a -> b) -> a -> b
$ IO ThreadId -> Eff (PABEffects t env) ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> Eff (PABEffects t env) ThreadId)
-> IO ThreadId -> Eff (PABEffects t env) ThreadId
forall a b. (a -> b) -> a -> b
$
        IO () -> (Either SomeException () -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally
            (Settings -> Application -> IO ()
run Settings
warpSettings (Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$ Middleware
middleware
               Middleware -> Middleware
forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> PABRunner t env -> Application
forall t env.
(FromJSON (ContractDef t), ToJSON (ContractDef t), PABContract t,
 MimeUnrender JSON (ContractDef t), ToSchema (ContractDef t)) =>
Maybe [Char] -> PABRunner t env -> Application
app Maybe [Char]
staticPath PABRunner t env
simRunner)
            (\Either SomeException ()
_ -> MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
mvar ())

    (MVar (), PABAction t env ())
-> PABAction t env (MVar (), PABAction t env ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MVar ()
mvar, IO () -> PABAction t env ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PABAction t env ()) -> IO () -> PABAction t env ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> () -> STM ()
forall a. TMVar a -> a -> STM ()
STM.putTMVar TMVar ()
shutdownVar ())

-- | Start the server using a default configuration for debugging.
startServerDebug ::
    ( FromJSON (Contract.ContractDef t)
    , ToJSON (Contract.ContractDef t)
    , Contract.PABContract t
    , Servant.MimeUnrender Servant.JSON (Contract.ContractDef t)
    , OpenApi.ToSchema (Contract.ContractDef t)
    )
    => Simulation t (Simulation t ())
startServerDebug :: Simulation t (Simulation t ())
startServerDebug = WebserverConfig -> Simulation t (Simulation t ())
forall t.
(FromJSON (ContractDef t), ToJSON (ContractDef t), PABContract t,
 MimeUnrender JSON (ContractDef t), ToSchema (ContractDef t)) =>
WebserverConfig -> Simulation t (Simulation t ())
startServerDebug' WebserverConfig
defaultWebServerConfig

-- | Start the server using (mostly) a default configuration for debugging,
-- but allow an optional webserver config.
startServerDebug' ::
    ( FromJSON (Contract.ContractDef t)
    , ToJSON (Contract.ContractDef t)
    , Contract.PABContract t
    , Servant.MimeUnrender Servant.JSON (Contract.ContractDef t)
    , OpenApi.ToSchema (Contract.ContractDef t)
    )
    => WebserverConfig
    -> Simulation t (Simulation t ())
startServerDebug' :: WebserverConfig -> Simulation t (Simulation t ())
startServerDebug' WebserverConfig
conf = do
    Availability
tk <- Eff (PABEffects t (SimulatorState t)) Availability
forall (m :: * -> *). MonadIO m => m Availability
newToken
    (MVar (), Simulation t ()) -> Simulation t ()
forall a b. (a, b) -> b
snd ((MVar (), Simulation t ()) -> Simulation t ())
-> Eff (PABEffects t (SimulatorState t)) (MVar (), Simulation t ())
-> Simulation t (Simulation t ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WebserverConfig
-> Availability
-> Eff (PABEffects t (SimulatorState t)) (MVar (), Simulation t ())
forall t env.
(FromJSON (ContractDef t), ToJSON (ContractDef t), PABContract t,
 MimeUnrender JSON (ContractDef t), ToSchema (ContractDef t)) =>
WebserverConfig
-> Availability -> PABAction t env (MVar (), PABAction t env ())
startServer WebserverConfig
conf Availability
tk