module Hasura.GraphQL.Transport.WSServerApp
  ( createWSServerApp,
    stopWSServerApp,
    createWSServerEnv,
  )
where

import Control.Concurrent.Async.Lifted.Safe qualified as LA
import Control.Concurrent.STM qualified as STM
import Control.Exception.Lifted
import Control.Monad.Trans.Control qualified as MC
import Data.Aeson qualified as J
import Data.Aeson.Encoding qualified as J
import Data.ByteString.Char8 qualified as B (pack)
import Data.Text (pack)
import Hasura.App.State
import Hasura.Backends.DataConnector.Agent.Client (AgentLicenseKey)
import Hasura.CredentialCache
import Hasura.GraphQL.Execute qualified as E
import Hasura.GraphQL.Logging
import Hasura.GraphQL.Transport.HTTP (MonadExecuteQuery)
import Hasura.GraphQL.Transport.HTTP.Protocol (encodeGQExecError)
import Hasura.GraphQL.Transport.Instances ()
import Hasura.GraphQL.Transport.WebSocket
import Hasura.GraphQL.Transport.WebSocket.Protocol
import Hasura.GraphQL.Transport.WebSocket.Server qualified as WS
import Hasura.GraphQL.Transport.WebSocket.Types
import Hasura.Logging qualified as L
import Hasura.Metadata.Class
import Hasura.Prelude
import Hasura.QueryTags
import Hasura.RQL.Types.SchemaCache
import Hasura.Server.AppStateRef
import Hasura.Server.Auth (UserAuthentication)
import Hasura.Server.Init.Config
  ( WSConnectionInitTimeout,
  )
import Hasura.Server.Limits
import Hasura.Server.Metrics (ServerMetrics (..))
import Hasura.Server.Prometheus
  ( PrometheusMetrics (..),
    decWebsocketConnections,
    incWebsocketConnections,
  )
import Hasura.Server.Types (MonadGetPolicies (..))
import Hasura.Services.Network
import Hasura.Tracing qualified as Tracing
import Network.WebSockets qualified as WS
import System.Metrics.Gauge qualified as EKG.Gauge

createWSServerApp ::
  ( MonadIO m,
    MC.MonadBaseControl IO m,
    LA.Forall (LA.Pure m),
    UserAuthentication m,
    E.MonadGQLExecutionCheck m,
    WS.MonadWSLog m,
    MonadQueryLog m,
    MonadExecutionLog m,
    MonadExecuteQuery m,
    MonadMetadataStorage m,
    MonadQueryTags m,
    HasResourceLimits m,
    ProvidesNetwork m,
    Tracing.MonadTrace m,
    MonadGetPolicies m
  ) =>
  HashSet (L.EngineLogType L.Hasura) ->
  WSServerEnv impl ->
  WSConnectionInitTimeout ->
  Maybe (CredentialCache AgentLicenseKey) ->
  -- | aka generalized 'WS.ServerApp'
  WS.HasuraServerApp m
createWSServerApp :: forall (m :: * -> *) impl.
(MonadIO m, MonadBaseControl IO m, Forall (Pure m),
 UserAuthentication m, MonadGQLExecutionCheck m, MonadWSLog m,
 MonadQueryLog m, MonadExecutionLog m, MonadExecuteQuery m,
 MonadMetadataStorage m, MonadQueryTags m, HasResourceLimits m,
 ProvidesNetwork m, MonadTrace m, MonadGetPolicies m) =>
HashSet (EngineLogType Hasura)
-> WSServerEnv impl
-> WSConnectionInitTimeout
-> Maybe (CredentialCache AgentLicenseKey)
-> HasuraServerApp m
createWSServerApp HashSet (EngineLogType Hasura)
enabledLogTypes WSServerEnv impl
serverEnv WSConnectionInitTimeout
connInitTimeout Maybe (CredentialCache AgentLicenseKey)
licenseKeyCache = \ !IpAddress
ipAddress !PendingConnection
pendingConn -> do
  let getMetricsConfig :: IO MetricsConfig
getMetricsConfig = SchemaCache -> MetricsConfig
scMetricsConfig (SchemaCache -> MetricsConfig)
-> IO SchemaCache -> IO MetricsConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppStateRef impl -> IO SchemaCache
forall impl. AppStateRef impl -> IO SchemaCache
getSchemaCache (WSServerEnv impl -> AppStateRef impl
forall impl. WSServerEnv impl -> AppStateRef impl
_wseAppStateRef WSServerEnv impl
serverEnv)
  IO MetricsConfig
-> WSConnectionInitTimeout
-> WSServer WSConnData
-> PrometheusMetrics
-> WSHandlers m WSConnData
-> IpAddress
-> PendingConnection
-> m ()
forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m, Forall (Pure m),
 MonadWSLog m) =>
IO MetricsConfig
-> WSConnectionInitTimeout
-> WSServer a
-> PrometheusMetrics
-> WSHandlers m a
-> HasuraServerApp m
WS.createServerApp IO MetricsConfig
getMetricsConfig WSConnectionInitTimeout
connInitTimeout (WSServerEnv impl -> WSServer WSConnData
forall impl. WSServerEnv impl -> WSServer WSConnData
_wseServer WSServerEnv impl
serverEnv) PrometheusMetrics
prometheusMetrics WSHandlers m WSConnData
handlers IpAddress
ipAddress PendingConnection
pendingConn
  where
    handlers :: WSHandlers m WSConnData
handlers =
      (WSId
 -> RequestHead
 -> IpAddress
 -> WSSubProtocol
 -> m (Either RejectRequest (AcceptWith WSConnData)))
-> (WSConn WSConnData -> ByteString -> WSSubProtocol -> m ())
-> OnCloseH m WSConnData
-> WSHandlers m WSConnData
forall (m :: * -> *) a.
(WSId
 -> RequestHead
 -> IpAddress
 -> WSSubProtocol
 -> m (Either RejectRequest (AcceptWith a)))
-> (WSConn a -> ByteString -> WSSubProtocol -> m ())
-> OnCloseH m a
-> WSHandlers m a
WS.WSHandlers
        WSId
-> RequestHead
-> IpAddress
-> WSSubProtocol
-> m (Either RejectRequest (AcceptWith WSConnData))
onConnHandler
        WSConn WSConnData -> ByteString -> WSSubProtocol -> m ()
onMessageHandler
        OnCloseH m WSConnData
onCloseHandler

    logger :: Logger Hasura
logger = WSServerEnv impl -> Logger Hasura
forall impl. WSServerEnv impl -> Logger Hasura
_wseLogger WSServerEnv impl
serverEnv
    serverMetrics :: ServerMetrics
serverMetrics = WSServerEnv impl -> ServerMetrics
forall impl. WSServerEnv impl -> ServerMetrics
_wseServerMetrics WSServerEnv impl
serverEnv
    prometheusMetrics :: PrometheusMetrics
prometheusMetrics = WSServerEnv impl -> PrometheusMetrics
forall impl. WSServerEnv impl -> PrometheusMetrics
_wsePrometheusMetrics WSServerEnv impl
serverEnv

    getAuthMode :: IO AuthMode
getAuthMode = AppContext -> AuthMode
acAuthMode (AppContext -> AuthMode) -> IO AppContext -> IO AuthMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppStateRef impl -> IO AppContext
forall impl. AppStateRef impl -> IO AppContext
getAppContext (WSServerEnv impl -> AppStateRef impl
forall impl. WSServerEnv impl -> AppStateRef impl
_wseAppStateRef WSServerEnv impl
serverEnv)
    wsActions :: WSSubProtocol -> WSActions WSConnData
wsActions = Logger Hasura -> WSSubProtocol -> WSActions WSConnData
mkWSActions Logger Hasura
logger

    -- Mask async exceptions during event processing to help maintain integrity of mutable vars:
    -- here `sp` stands for sub-protocol
    onConnHandler :: WSId
-> RequestHead
-> IpAddress
-> WSSubProtocol
-> m (Either RejectRequest (AcceptWith WSConnData))
onConnHandler WSId
rid RequestHead
rh IpAddress
ip WSSubProtocol
sp = m (Either RejectRequest (AcceptWith WSConnData))
-> m (Either RejectRequest (AcceptWith WSConnData))
forall (m :: * -> *) a. MonadBaseControl IO m => m a -> m a
mask_ do
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Gauge -> IO ()
EKG.Gauge.inc (Gauge -> IO ()) -> Gauge -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerMetrics -> Gauge
smWebsocketConnections ServerMetrics
serverMetrics
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ConnectionsGauge -> IO ()
incWebsocketConnections (ConnectionsGauge -> IO ()) -> ConnectionsGauge -> IO ()
forall a b. (a -> b) -> a -> b
$ PrometheusMetrics -> ConnectionsGauge
pmConnections PrometheusMetrics
prometheusMetrics
      (ReaderT
   (WSServerEnv impl) m (Either RejectRequest (AcceptWith WSConnData))
 -> WSServerEnv impl
 -> m (Either RejectRequest (AcceptWith WSConnData)))
-> WSServerEnv impl
-> ReaderT
     (WSServerEnv impl) m (Either RejectRequest (AcceptWith WSConnData))
-> m (Either RejectRequest (AcceptWith WSConnData))
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT
  (WSServerEnv impl) m (Either RejectRequest (AcceptWith WSConnData))
-> WSServerEnv impl
-> m (Either RejectRequest (AcceptWith WSConnData))
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT WSServerEnv impl
serverEnv (ReaderT
   (WSServerEnv impl) m (Either RejectRequest (AcceptWith WSConnData))
 -> m (Either RejectRequest (AcceptWith WSConnData)))
-> ReaderT
     (WSServerEnv impl) m (Either RejectRequest (AcceptWith WSConnData))
-> m (Either RejectRequest (AcceptWith WSConnData))
forall a b. (a -> b) -> a -> b
$ OnConnH (ReaderT (WSServerEnv impl) m) WSConnData
forall (m :: * -> *) impl.
(MonadIO m, MonadReader (WSServerEnv impl) m) =>
OnConnH m WSConnData
onConn WSId
rid RequestHead
rh IpAddress
ip (WSSubProtocol -> WSActions WSConnData
wsActions WSSubProtocol
sp)

    onMessageHandler :: WSConn WSConnData -> ByteString -> WSSubProtocol -> m ()
onMessageHandler WSConn WSConnData
conn ByteString
bs WSSubProtocol
sp =
      m () -> m ()
forall (m :: * -> *) a. MonadBaseControl IO m => m a -> m a
mask_
        (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ HashSet (EngineLogType Hasura)
-> IO AuthMode
-> WSServerEnv impl
-> WSConn WSConnData
-> ByteString
-> WSActions WSConnData
-> Maybe (CredentialCache AgentLicenseKey)
-> m ()
forall (m :: * -> *) impl.
(MonadIO m, UserAuthentication m, MonadGQLExecutionCheck m,
 MonadQueryLog m, MonadExecutionLog m, MonadExecuteQuery m,
 MonadBaseControl IO m, MonadMetadataStorage m, MonadQueryTags m,
 HasResourceLimits m, ProvidesNetwork m, MonadTrace m,
 MonadGetPolicies m) =>
HashSet (EngineLogType Hasura)
-> IO AuthMode
-> WSServerEnv impl
-> WSConn WSConnData
-> ByteString
-> WSActions WSConnData
-> Maybe (CredentialCache AgentLicenseKey)
-> m ()
onMessage HashSet (EngineLogType Hasura)
enabledLogTypes IO AuthMode
getAuthMode WSServerEnv impl
serverEnv WSConn WSConnData
conn ByteString
bs (WSSubProtocol -> WSActions WSConnData
wsActions WSSubProtocol
sp) Maybe (CredentialCache AgentLicenseKey)
licenseKeyCache

    onCloseHandler :: OnCloseH m WSConnData
onCloseHandler WSConn WSConnData
conn = m () -> m ()
forall (m :: * -> *) a. MonadBaseControl IO m => m a -> m a
mask_ do
      IO GranularPrometheusMetricsState
granularPrometheusMetricsState <- m (IO GranularPrometheusMetricsState)
forall (m :: * -> *).
MonadGetPolicies m =>
m (IO GranularPrometheusMetricsState)
runGetPrometheusMetricsGranularity
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Gauge -> IO ()
EKG.Gauge.dec (Gauge -> IO ()) -> Gauge -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerMetrics -> Gauge
smWebsocketConnections ServerMetrics
serverMetrics
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ConnectionsGauge -> IO ()
decWebsocketConnections (ConnectionsGauge -> IO ()) -> ConnectionsGauge -> IO ()
forall a b. (a -> b) -> a -> b
$ PrometheusMetrics -> ConnectionsGauge
pmConnections PrometheusMetrics
prometheusMetrics
      Logger Hasura
-> ServerMetrics
-> PrometheusMetrics
-> SubscriptionsState
-> WSConn WSConnData
-> IO GranularPrometheusMetricsState
-> m ()
forall (m :: * -> *).
MonadIO m =>
Logger Hasura
-> ServerMetrics
-> PrometheusMetrics
-> SubscriptionsState
-> WSConn WSConnData
-> IO GranularPrometheusMetricsState
-> m ()
onClose Logger Hasura
logger ServerMetrics
serverMetrics PrometheusMetrics
prometheusMetrics (WSServerEnv impl -> SubscriptionsState
forall impl. WSServerEnv impl -> SubscriptionsState
_wseSubscriptionState WSServerEnv impl
serverEnv) WSConn WSConnData
conn IO GranularPrometheusMetricsState
granularPrometheusMetricsState

stopWSServerApp :: WSServerEnv impl -> IO ()
stopWSServerApp :: forall impl. WSServerEnv impl -> IO ()
stopWSServerApp WSServerEnv impl
wsEnv = WSServer WSConnData -> IO ()
forall a. WSServer a -> IO ()
WS.shutdown (WSServerEnv impl -> WSServer WSConnData
forall impl. WSServerEnv impl -> WSServer WSConnData
_wseServer WSServerEnv impl
wsEnv)

createWSServerEnv ::
  ( HasAppEnv m,
    MonadIO m
  ) =>
  AppStateRef impl ->
  m (WSServerEnv impl)
createWSServerEnv :: forall (m :: * -> *) impl.
(HasAppEnv m, MonadIO m) =>
AppStateRef impl -> m (WSServerEnv impl)
createWSServerEnv AppStateRef impl
appStateRef = do
  AppEnv {Int
Maybe Text
Maybe PGPool
Maybe (CredentialCache AgentLicenseKey)
SamplingPolicy
HostPreference
Manager
TxIsolation
ConnParams
PGPool
Refined NonNegative Seconds
TMVar MetadataResourceVersion
ConnectionOptions
CheckFeatureFlag
ServerMetrics
EventingMode
ReadOnlyMode
MaintenanceMode ()
InstanceId
PrometheusMetrics
ShutdownLatch
LoggingSettings
LockedEventsCtx
WSConnectionInitTimeout
KeepAliveDelay
OptionalInterval
Port
SubscriptionsState
Loggers
appEnvPort :: Port
appEnvHost :: HostPreference
appEnvMetadataDbPool :: PGPool
appEnvIntrospectionDbPool :: Maybe PGPool
appEnvManager :: Manager
appEnvLoggers :: Loggers
appEnvMetadataVersionRef :: TMVar MetadataResourceVersion
appEnvInstanceId :: InstanceId
appEnvEnableMaintenanceMode :: MaintenanceMode ()
appEnvLoggingSettings :: LoggingSettings
appEnvEventingMode :: EventingMode
appEnvEnableReadOnlyMode :: ReadOnlyMode
appEnvServerMetrics :: ServerMetrics
appEnvShutdownLatch :: ShutdownLatch
appEnvMetaVersionRef :: TMVar MetadataResourceVersion
appEnvPrometheusMetrics :: PrometheusMetrics
appEnvTraceSamplingPolicy :: SamplingPolicy
appEnvSubscriptionState :: SubscriptionsState
appEnvLockedEventsCtx :: LockedEventsCtx
appEnvConnParams :: ConnParams
appEnvTxIso :: TxIsolation
appEnvConsoleAssetsDir :: Maybe Text
appEnvConsoleSentryDsn :: Maybe Text
appEnvConnectionOptions :: ConnectionOptions
appEnvWebSocketKeepAlive :: KeepAliveDelay
appEnvWebSocketConnectionInitTimeout :: WSConnectionInitTimeout
appEnvGracefulShutdownTimeout :: Refined NonNegative Seconds
appEnvSchemaPollInterval :: OptionalInterval
appEnvCheckFeatureFlag :: CheckFeatureFlag
appEnvLicenseKeyCache :: Maybe (CredentialCache AgentLicenseKey)
appEnvMaxTotalHeaderLength :: Int
appEnvPort :: AppEnv -> Port
appEnvHost :: AppEnv -> HostPreference
appEnvMetadataDbPool :: AppEnv -> PGPool
appEnvIntrospectionDbPool :: AppEnv -> Maybe PGPool
appEnvManager :: AppEnv -> Manager
appEnvLoggers :: AppEnv -> Loggers
appEnvMetadataVersionRef :: AppEnv -> TMVar MetadataResourceVersion
appEnvInstanceId :: AppEnv -> InstanceId
appEnvEnableMaintenanceMode :: AppEnv -> MaintenanceMode ()
appEnvLoggingSettings :: AppEnv -> LoggingSettings
appEnvEventingMode :: AppEnv -> EventingMode
appEnvEnableReadOnlyMode :: AppEnv -> ReadOnlyMode
appEnvServerMetrics :: AppEnv -> ServerMetrics
appEnvShutdownLatch :: AppEnv -> ShutdownLatch
appEnvMetaVersionRef :: AppEnv -> TMVar MetadataResourceVersion
appEnvPrometheusMetrics :: AppEnv -> PrometheusMetrics
appEnvTraceSamplingPolicy :: AppEnv -> SamplingPolicy
appEnvSubscriptionState :: AppEnv -> SubscriptionsState
appEnvLockedEventsCtx :: AppEnv -> LockedEventsCtx
appEnvConnParams :: AppEnv -> ConnParams
appEnvTxIso :: AppEnv -> TxIsolation
appEnvConsoleAssetsDir :: AppEnv -> Maybe Text
appEnvConsoleSentryDsn :: AppEnv -> Maybe Text
appEnvConnectionOptions :: AppEnv -> ConnectionOptions
appEnvWebSocketKeepAlive :: AppEnv -> KeepAliveDelay
appEnvWebSocketConnectionInitTimeout :: AppEnv -> WSConnectionInitTimeout
appEnvGracefulShutdownTimeout :: AppEnv -> Refined NonNegative Seconds
appEnvSchemaPollInterval :: AppEnv -> OptionalInterval
appEnvCheckFeatureFlag :: AppEnv -> CheckFeatureFlag
appEnvLicenseKeyCache :: AppEnv -> Maybe (CredentialCache AgentLicenseKey)
appEnvMaxTotalHeaderLength :: AppEnv -> Int
..} <- m AppEnv
forall (m :: * -> *). HasAppEnv m => m AppEnv
askAppEnv
  let getCorsPolicy :: IO CorsPolicy
getCorsPolicy = AppContext -> CorsPolicy
acCorsPolicy (AppContext -> CorsPolicy) -> IO AppContext -> IO CorsPolicy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppStateRef impl -> IO AppContext
forall impl. AppStateRef impl -> IO AppContext
getAppContext AppStateRef impl
appStateRef
      logger :: Logger Hasura
logger = Loggers -> Logger Hasura
_lsLogger Loggers
appEnvLoggers

  AppContext {AllowListStatus
acEnableAllowlist :: AllowListStatus
acEnableAllowlist :: AppContext -> AllowListStatus
acEnableAllowlist, AuthMode
acAuthMode :: AppContext -> AuthMode
acAuthMode :: AuthMode
acAuthMode, SQLGenCtx
acSQLGenCtx :: SQLGenCtx
acSQLGenCtx :: AppContext -> SQLGenCtx
acSQLGenCtx, HashSet ExperimentalFeature
acExperimentalFeatures :: HashSet ExperimentalFeature
acExperimentalFeatures :: AppContext -> HashSet ExperimentalFeature
acExperimentalFeatures, NamingCase
acDefaultNamingConvention :: NamingCase
acDefaultNamingConvention :: AppContext -> NamingCase
acDefaultNamingConvention} <- IO AppContext -> m AppContext
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AppContext -> m AppContext) -> IO AppContext -> m AppContext
forall a b. (a -> b) -> a -> b
$ AppStateRef impl -> IO AppContext
forall impl. AppStateRef impl -> IO AppContext
getAppContext AppStateRef impl
appStateRef
  InlinedAllowlist
allowlist <- IO InlinedAllowlist -> m InlinedAllowlist
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO InlinedAllowlist -> m InlinedAllowlist)
-> IO InlinedAllowlist -> m InlinedAllowlist
forall a b. (a -> b) -> a -> b
$ SchemaCache -> InlinedAllowlist
scAllowlist (SchemaCache -> InlinedAllowlist)
-> IO SchemaCache -> IO InlinedAllowlist
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppStateRef impl -> IO SchemaCache
forall impl. AppStateRef impl -> IO SchemaCache
getSchemaCache AppStateRef impl
appStateRef
  CorsPolicy
corsPolicy <- IO CorsPolicy -> m CorsPolicy
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO CorsPolicy
getCorsPolicy

  WSServer WSConnData
wsServer <- IO (WSServer WSConnData) -> m (WSServer WSConnData)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (WSServer WSConnData) -> m (WSServer WSConnData))
-> IO (WSServer WSConnData) -> m (WSServer WSConnData)
forall a b. (a -> b) -> a -> b
$ STM (WSServer WSConnData) -> IO (WSServer WSConnData)
forall a. STM a -> IO a
STM.atomically (STM (WSServer WSConnData) -> IO (WSServer WSConnData))
-> STM (WSServer WSConnData) -> IO (WSServer WSConnData)
forall a b. (a -> b) -> a -> b
$ AuthMode
-> AllowListStatus
-> InlinedAllowlist
-> CorsPolicy
-> SQLGenCtx
-> HashSet ExperimentalFeature
-> NamingCase
-> Logger Hasura
-> STM (WSServer WSConnData)
forall a.
AuthMode
-> AllowListStatus
-> InlinedAllowlist
-> CorsPolicy
-> SQLGenCtx
-> HashSet ExperimentalFeature
-> NamingCase
-> Logger Hasura
-> STM (WSServer a)
WS.createWSServer AuthMode
acAuthMode AllowListStatus
acEnableAllowlist InlinedAllowlist
allowlist CorsPolicy
corsPolicy SQLGenCtx
acSQLGenCtx HashSet ExperimentalFeature
acExperimentalFeatures NamingCase
acDefaultNamingConvention Logger Hasura
logger

  WSServerEnv impl -> m (WSServerEnv impl)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (WSServerEnv impl -> m (WSServerEnv impl))
-> WSServerEnv impl -> m (WSServerEnv impl)
forall a b. (a -> b) -> a -> b
$ Logger Hasura
-> SubscriptionsState
-> AppStateRef impl
-> Manager
-> IO CorsPolicy
-> ReadOnlyMode
-> WSServer WSConnData
-> KeepAliveDelay
-> ServerMetrics
-> PrometheusMetrics
-> SamplingPolicy
-> WSServerEnv impl
forall impl.
Logger Hasura
-> SubscriptionsState
-> AppStateRef impl
-> Manager
-> IO CorsPolicy
-> ReadOnlyMode
-> WSServer WSConnData
-> KeepAliveDelay
-> ServerMetrics
-> PrometheusMetrics
-> SamplingPolicy
-> WSServerEnv impl
WSServerEnv
      (Loggers -> Logger Hasura
_lsLogger Loggers
appEnvLoggers)
      SubscriptionsState
appEnvSubscriptionState
      AppStateRef impl
appStateRef
      Manager
appEnvManager
      IO CorsPolicy
getCorsPolicy
      ReadOnlyMode
appEnvEnableReadOnlyMode
      WSServer WSConnData
wsServer
      KeepAliveDelay
appEnvWebSocketKeepAlive
      ServerMetrics
appEnvServerMetrics
      PrometheusMetrics
appEnvPrometheusMetrics
      SamplingPolicy
appEnvTraceSamplingPolicy

mkWSActions :: L.Logger L.Hasura -> WSSubProtocol -> WS.WSActions WSConnData
mkWSActions :: Logger Hasura -> WSSubProtocol -> WSActions WSConnData
mkWSActions Logger Hasura
logger WSSubProtocol
subProtocol =
  WSPostExecErrMessageAction WSConnData
-> WSOnErrorMessageAction WSConnData
-> WSCloseConnAction WSConnData
-> WSKeepAliveMessageAction WSConnData
-> (DataMsg -> ServerMsg)
-> AcceptRequest
-> ([Encoding] -> Encoding)
-> WSActions WSConnData
forall a.
WSPostExecErrMessageAction a
-> WSOnErrorMessageAction a
-> WSCloseConnAction a
-> WSKeepAliveMessageAction a
-> (DataMsg -> ServerMsg)
-> AcceptRequest
-> ([Encoding] -> Encoding)
-> WSActions a
WS.WSActions
    WSPostExecErrMessageAction WSConnData
mkPostExecErrMessageAction
    WSOnErrorMessageAction WSConnData
mkOnErrorMessageAction
    WSCloseConnAction WSConnData
mkConnectionCloseAction
    WSKeepAliveMessageAction WSConnData
keepAliveAction
    DataMsg -> ServerMsg
getServerMsgType
    AcceptRequest
mkAcceptRequest
    [Encoding] -> Encoding
fmtErrorMessage
  where
    mkPostExecErrMessageAction :: WSPostExecErrMessageAction WSConnData
mkPostExecErrMessageAction WSConn WSConnData
wsConn OperationId
opId GQExecError
execErr =
      WSConn WSConnData -> ServerMsg -> IO ()
forall (m :: * -> *).
MonadIO m =>
WSConn WSConnData -> ServerMsg -> m ()
sendMsg WSConn WSConnData
wsConn (ServerMsg -> IO ()) -> ServerMsg -> IO ()
forall a b. (a -> b) -> a -> b
$ case WSSubProtocol
subProtocol of
        WSSubProtocol
Apollo -> DataMsg -> ServerMsg
SMData (DataMsg -> ServerMsg) -> DataMsg -> ServerMsg
forall a b. (a -> b) -> a -> b
$ OperationId -> GQResponse -> DataMsg
DataMsg OperationId
opId (GQResponse -> DataMsg) -> GQResponse -> DataMsg
forall a b. (a -> b) -> a -> b
$ GQExecError -> GQResponse
forall a. GQExecError -> Either GQExecError a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError GQExecError
execErr
        WSSubProtocol
GraphQLWS -> ErrorMsg -> ServerMsg
SMErr (ErrorMsg -> ServerMsg) -> ErrorMsg -> ServerMsg
forall a b. (a -> b) -> a -> b
$ OperationId -> Encoding -> ErrorMsg
ErrorMsg OperationId
opId (Encoding -> ErrorMsg) -> Encoding -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ GQExecError -> Encoding
encodeGQExecError GQExecError
execErr

    mkOnErrorMessageAction :: WSOnErrorMessageAction WSConnData
mkOnErrorMessageAction WSConn WSConnData
wsConn ConnErrMsg
err WSErrorMessage
mErrMsg =
      case WSSubProtocol
subProtocol of
        WSSubProtocol
Apollo ->
          case WSErrorMessage
mErrMsg of
            WSErrorMessage
WS.ConnInitFailed -> Logger Hasura
-> WSConn WSConnData
-> ServerErrorCode
-> Maybe ServerMsg
-> Maybe Word16
-> IO ()
forall (m :: * -> *).
MonadIO m =>
Logger Hasura
-> WSConn WSConnData
-> ServerErrorCode
-> Maybe ServerMsg
-> Maybe Word16
-> m ()
sendCloseWithMsg Logger Hasura
logger WSConn WSConnData
wsConn (WSSubProtocol -> WSErrorMessage -> ConnErrMsg -> ServerErrorCode
WS.mkWSServerErrorCode WSSubProtocol
subProtocol WSErrorMessage
mErrMsg ConnErrMsg
err) (ServerMsg -> Maybe ServerMsg
forall a. a -> Maybe a
Just (ServerMsg -> Maybe ServerMsg) -> ServerMsg -> Maybe ServerMsg
forall a b. (a -> b) -> a -> b
$ ConnErrMsg -> ServerMsg
SMConnErr ConnErrMsg
err) Maybe Word16
forall a. Maybe a
Nothing
            WSErrorMessage
WS.ClientMessageParseFailed -> WSConn WSConnData -> ServerMsg -> IO ()
forall (m :: * -> *).
MonadIO m =>
WSConn WSConnData -> ServerMsg -> m ()
sendMsg WSConn WSConnData
wsConn (ServerMsg -> IO ()) -> ServerMsg -> IO ()
forall a b. (a -> b) -> a -> b
$ ConnErrMsg -> ServerMsg
SMConnErr ConnErrMsg
err
        WSSubProtocol
GraphQLWS -> Logger Hasura
-> WSConn WSConnData
-> ServerErrorCode
-> Maybe ServerMsg
-> Maybe Word16
-> IO ()
forall (m :: * -> *).
MonadIO m =>
Logger Hasura
-> WSConn WSConnData
-> ServerErrorCode
-> Maybe ServerMsg
-> Maybe Word16
-> m ()
sendCloseWithMsg Logger Hasura
logger WSConn WSConnData
wsConn (WSSubProtocol -> WSErrorMessage -> ConnErrMsg -> ServerErrorCode
WS.mkWSServerErrorCode WSSubProtocol
subProtocol WSErrorMessage
mErrMsg ConnErrMsg
err) Maybe ServerMsg
forall a. Maybe a
Nothing Maybe Word16
forall a. Maybe a
Nothing

    mkConnectionCloseAction :: WSCloseConnAction WSConnData
mkConnectionCloseAction WSConn WSConnData
wsConn OperationId
opId String
errMsg =
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WSSubProtocol
subProtocol WSSubProtocol -> WSSubProtocol -> Bool
forall a. Eq a => a -> a -> Bool
== WSSubProtocol
GraphQLWS)
        (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Logger Hasura
-> WSConn WSConnData
-> ServerErrorCode
-> Maybe ServerMsg
-> Maybe Word16
-> IO ()
forall (m :: * -> *).
MonadIO m =>
Logger Hasura
-> WSConn WSConnData
-> ServerErrorCode
-> Maybe ServerMsg
-> Maybe Word16
-> m ()
sendCloseWithMsg Logger Hasura
logger WSConn WSConnData
wsConn (String -> ServerErrorCode
GenericError4400 String
errMsg) (ServerMsg -> Maybe ServerMsg
forall a. a -> Maybe a
Just (ServerMsg -> Maybe ServerMsg)
-> (ErrorMsg -> ServerMsg) -> ErrorMsg -> Maybe ServerMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMsg -> ServerMsg
SMErr (ErrorMsg -> Maybe ServerMsg) -> ErrorMsg -> Maybe ServerMsg
forall a b. (a -> b) -> a -> b
$ OperationId -> Encoding -> ErrorMsg
ErrorMsg OperationId
opId (Encoding -> ErrorMsg) -> Encoding -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ Text -> Encoding
forall a. ToJSON a => a -> Encoding
J.toEncoding (String -> Text
pack String
errMsg)) (Word16 -> Maybe Word16
forall a. a -> Maybe a
Just Word16
1000)

    getServerMsgType :: DataMsg -> ServerMsg
getServerMsgType = case WSSubProtocol
subProtocol of
      WSSubProtocol
Apollo -> DataMsg -> ServerMsg
SMData
      WSSubProtocol
GraphQLWS -> DataMsg -> ServerMsg
SMNext

    keepAliveAction :: WSKeepAliveMessageAction WSConnData
keepAliveAction WSConn WSConnData
wsConn = WSConn WSConnData -> ServerMsg -> IO ()
forall (m :: * -> *).
MonadIO m =>
WSConn WSConnData -> ServerMsg -> m ()
sendMsg WSConn WSConnData
wsConn
      (ServerMsg -> IO ()) -> ServerMsg -> IO ()
forall a b. (a -> b) -> a -> b
$ case WSSubProtocol
subProtocol of
        WSSubProtocol
Apollo -> ServerMsg
SMConnKeepAlive
        WSSubProtocol
GraphQLWS -> Maybe PingPongPayload -> ServerMsg
SMPing (Maybe PingPongPayload -> ServerMsg)
-> (PingPongPayload -> Maybe PingPongPayload)
-> PingPongPayload
-> ServerMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PingPongPayload -> Maybe PingPongPayload
forall a. a -> Maybe a
Just (PingPongPayload -> ServerMsg) -> PingPongPayload -> ServerMsg
forall a b. (a -> b) -> a -> b
$ PingPongPayload
keepAliveMessage

    mkAcceptRequest :: AcceptRequest
mkAcceptRequest =
      AcceptRequest
WS.defaultAcceptRequest
        { acceptSubprotocol :: Maybe ByteString
WS.acceptSubprotocol = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> (WSSubProtocol -> ByteString)
-> WSSubProtocol
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
B.pack (String -> ByteString)
-> (WSSubProtocol -> String) -> WSSubProtocol -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WSSubProtocol -> String
showSubProtocol (WSSubProtocol -> Maybe ByteString)
-> WSSubProtocol -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ WSSubProtocol
subProtocol
        }

    fmtErrorMessage :: [Encoding] -> Encoding
fmtErrorMessage [Encoding]
errMsgs = case WSSubProtocol
subProtocol of
      WSSubProtocol
Apollo -> Series -> Encoding
J.pairs (Key -> Encoding -> Series
J.pair Key
"errors" (Encoding -> Series) -> Encoding -> Series
forall a b. (a -> b) -> a -> b
$ (Encoding -> Encoding) -> [Encoding] -> Encoding
forall a. (a -> Encoding) -> [a] -> Encoding
J.list Encoding -> Encoding
forall a. a -> a
id [Encoding]
errMsgs)
      WSSubProtocol
GraphQLWS -> (Encoding -> Encoding) -> [Encoding] -> Encoding
forall a. (a -> Encoding) -> [a] -> Encoding
J.list Encoding -> Encoding
forall a. a -> a
id [Encoding]
errMsgs