{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
module Hasura.GraphQL.Transport.WebSocket
( onConn,
onMessage,
onClose,
sendMsg,
sendCloseWithMsg,
)
where
import Control.Concurrent.Extended (sleep)
import Control.Concurrent.STM qualified as STM
import Control.Monad.Trans.Control qualified as MC
import Data.Aeson qualified as J
import Data.Aeson.Casing qualified as J
import Data.Aeson.TH qualified as J
import Data.ByteString (ByteString)
import Data.ByteString.Lazy qualified as LBS
import Data.CaseInsensitive qualified as CI
import Data.Dependent.Map qualified as DM
import Data.Environment qualified as Env
import Data.HashMap.Strict qualified as Map
import Data.HashMap.Strict.InsOrd qualified as OMap
import Data.HashSet qualified as Set
import Data.List.NonEmpty qualified as NE
import Data.String
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Time.Clock qualified as TC
import Data.Word (Word16)
import GHC.AssertNF.CPP
import Hasura.Backends.Postgres.Instances.Transport (runPGMutationTransaction)
import Hasura.Base.Error
import Hasura.EncJSON
import Hasura.GraphQL.Execute qualified as E
import Hasura.GraphQL.Execute.Action qualified as EA
import Hasura.GraphQL.Execute.Backend qualified as EB
import Hasura.GraphQL.Execute.RemoteJoin qualified as RJ
import Hasura.GraphQL.Execute.Subscription.Plan qualified as ES
import Hasura.GraphQL.Execute.Subscription.Poll qualified as ES
import Hasura.GraphQL.Execute.Subscription.State qualified as ES
import Hasura.GraphQL.Logging
import Hasura.GraphQL.Namespace (RootFieldAlias (..))
import Hasura.GraphQL.ParameterizedQueryHash (ParameterizedQueryHash)
import Hasura.GraphQL.Parser.Directives (cached)
import Hasura.GraphQL.Transport.Backend
import Hasura.GraphQL.Transport.HTTP
import Hasura.GraphQL.Transport.HTTP.Protocol
import Hasura.GraphQL.Transport.Instances ()
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.RQL.Types.Numeric qualified as Numeric
import Hasura.RQL.Types.RemoteSchema
import Hasura.RQL.Types.ResultCustomization
import Hasura.RQL.Types.SchemaCache (scApiLimits)
import Hasura.SQL.AnyBackend qualified as AB
import Hasura.Server.Auth
( AuthMode,
UserAuthentication,
resolveUserInfo,
)
import Hasura.Server.Cors
import Hasura.Server.Init.Config (KeepAliveDelay (..))
import Hasura.Server.Limits
( HasResourceLimits (..),
ResourceLimits (..),
)
import Hasura.Server.Metrics (ServerMetrics (..))
import Hasura.Server.Prometheus
( GraphQLRequestMetrics (..),
PrometheusMetrics (..),
)
import Hasura.Server.Telemetry.Counters qualified as Telem
import Hasura.Server.Types (RequestId, getRequestId)
import Hasura.Session
import Hasura.Tracing qualified as Tracing
import Language.GraphQL.Draft.Syntax (Name (..))
import Language.GraphQL.Draft.Syntax qualified as G
import ListT qualified
import Network.HTTP.Client qualified as HTTP
import Network.HTTP.Types qualified as HTTP
import Network.WebSockets qualified as WS
import StmContainers.Map qualified as STMMap
import System.Metrics.Prometheus.Counter qualified as Prometheus.Counter
import System.Metrics.Prometheus.Histogram qualified as Prometheus.Histogram
data OpDetail
= ODStarted
| ODProtoErr !Text
| ODQueryErr !QErr
| ODCompleted
| ODStopped
deriving (OpDetail -> OpDetail -> Bool
(OpDetail -> OpDetail -> Bool)
-> (OpDetail -> OpDetail -> Bool) -> Eq OpDetail
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OpDetail -> OpDetail -> Bool
$c/= :: OpDetail -> OpDetail -> Bool
== :: OpDetail -> OpDetail -> Bool
$c== :: OpDetail -> OpDetail -> Bool
Eq)
$( J.deriveToJSON
J.defaultOptions
{ J.constructorTagModifier = J.snakeCase . drop 2,
J.sumEncoding = J.TaggedObject "type" "detail"
}
''OpDetail
)
data OperationDetails = OperationDetails
{ OperationDetails -> OperationId
_odOperationId :: !OperationId,
OperationDetails -> Maybe RequestId
_odRequestId :: !(Maybe RequestId),
OperationDetails -> Maybe OperationName
_odOperationName :: !(Maybe OperationName),
OperationDetails -> OpDetail
_odOperationType :: !OpDetail,
OperationDetails -> Maybe GQLReqUnparsed
_odQuery :: !(Maybe GQLReqUnparsed),
OperationDetails -> Maybe ParameterizedQueryHash
_odParameterizedQueryHash :: !(Maybe ParameterizedQueryHash)
}
deriving (OperationDetails -> OperationDetails -> Bool
(OperationDetails -> OperationDetails -> Bool)
-> (OperationDetails -> OperationDetails -> Bool)
-> Eq OperationDetails
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OperationDetails -> OperationDetails -> Bool
$c/= :: OperationDetails -> OperationDetails -> Bool
== :: OperationDetails -> OperationDetails -> Bool
$c== :: OperationDetails -> OperationDetails -> Bool
Eq)
$(J.deriveToJSON hasuraJSON ''OperationDetails)
data WSEvent
= EAccepted
| ERejected !QErr
| EConnErr !ConnErrMsg
| EOperation !OperationDetails
| EClosed
deriving (WSEvent -> WSEvent -> Bool
(WSEvent -> WSEvent -> Bool)
-> (WSEvent -> WSEvent -> Bool) -> Eq WSEvent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WSEvent -> WSEvent -> Bool
$c/= :: WSEvent -> WSEvent -> Bool
== :: WSEvent -> WSEvent -> Bool
$c== :: WSEvent -> WSEvent -> Bool
Eq)
$( J.deriveToJSON
J.defaultOptions
{ J.constructorTagModifier = J.snakeCase . drop 1,
J.sumEncoding = J.TaggedObject "type" "detail"
}
''WSEvent
)
data WsConnInfo = WsConnInfo
{ WsConnInfo -> WSId
_wsciWebsocketId :: !WS.WSId,
WsConnInfo -> Maybe UTCTime
_wsciTokenExpiry :: !(Maybe TC.UTCTime),
WsConnInfo -> Maybe Text
_wsciMsg :: !(Maybe Text)
}
deriving (WsConnInfo -> WsConnInfo -> Bool
(WsConnInfo -> WsConnInfo -> Bool)
-> (WsConnInfo -> WsConnInfo -> Bool) -> Eq WsConnInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WsConnInfo -> WsConnInfo -> Bool
$c/= :: WsConnInfo -> WsConnInfo -> Bool
== :: WsConnInfo -> WsConnInfo -> Bool
$c== :: WsConnInfo -> WsConnInfo -> Bool
Eq)
$(J.deriveToJSON hasuraJSON ''WsConnInfo)
data WSLogInfo = WSLogInfo
{ WSLogInfo -> Maybe SessionVariables
_wsliUserVars :: !(Maybe SessionVariables),
WSLogInfo -> WsConnInfo
_wsliConnectionInfo :: !WsConnInfo,
WSLogInfo -> WSEvent
_wsliEvent :: !WSEvent
}
deriving (WSLogInfo -> WSLogInfo -> Bool
(WSLogInfo -> WSLogInfo -> Bool)
-> (WSLogInfo -> WSLogInfo -> Bool) -> Eq WSLogInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WSLogInfo -> WSLogInfo -> Bool
$c/= :: WSLogInfo -> WSLogInfo -> Bool
== :: WSLogInfo -> WSLogInfo -> Bool
$c== :: WSLogInfo -> WSLogInfo -> Bool
Eq)
$(J.deriveToJSON hasuraJSON ''WSLogInfo)
data WSLog = WSLog
{ WSLog -> LogLevel
_wslLogLevel :: !L.LogLevel,
WSLog -> WSLogInfo
_wslInfo :: !WSLogInfo
}
instance L.ToEngineLog WSLog L.Hasura where
toEngineLog :: WSLog -> (LogLevel, EngineLogType Hasura, Value)
toEngineLog (WSLog LogLevel
logLevel WSLogInfo
wsLog) =
(LogLevel
logLevel, EngineLogType Hasura
L.ELTWebsocketLog, WSLogInfo -> Value
forall a. ToJSON a => a -> Value
J.toJSON WSLogInfo
wsLog)
mkWsInfoLog :: Maybe SessionVariables -> WsConnInfo -> WSEvent -> WSLog
mkWsInfoLog :: Maybe SessionVariables -> WsConnInfo -> WSEvent -> WSLog
mkWsInfoLog Maybe SessionVariables
uv WsConnInfo
ci WSEvent
ev =
LogLevel -> WSLogInfo -> WSLog
WSLog LogLevel
L.LevelInfo (WSLogInfo -> WSLog) -> WSLogInfo -> WSLog
forall a b. (a -> b) -> a -> b
$ Maybe SessionVariables -> WsConnInfo -> WSEvent -> WSLogInfo
WSLogInfo Maybe SessionVariables
uv WsConnInfo
ci WSEvent
ev
mkWsErrorLog :: Maybe SessionVariables -> WsConnInfo -> WSEvent -> WSLog
mkWsErrorLog :: Maybe SessionVariables -> WsConnInfo -> WSEvent -> WSLog
mkWsErrorLog Maybe SessionVariables
uv WsConnInfo
ci WSEvent
ev =
LogLevel -> WSLogInfo -> WSLog
WSLog LogLevel
L.LevelError (WSLogInfo -> WSLog) -> WSLogInfo -> WSLog
forall a b. (a -> b) -> a -> b
$ Maybe SessionVariables -> WsConnInfo -> WSEvent -> WSLogInfo
WSLogInfo Maybe SessionVariables
uv WsConnInfo
ci WSEvent
ev
logWSEvent ::
(MonadIO m) =>
L.Logger L.Hasura ->
WSConn ->
WSEvent ->
m ()
logWSEvent :: Logger Hasura -> WSConn -> WSEvent -> m ()
logWSEvent (L.Logger forall a (m :: * -> *).
(ToEngineLog a Hasura, MonadIO m) =>
a -> m ()
logger) WSConn
wsConn WSEvent
wsEv = do
WSConnState
userInfoME <- IO WSConnState -> m WSConnState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO WSConnState -> m WSConnState)
-> IO WSConnState -> m WSConnState
forall a b. (a -> b) -> a -> b
$ TVar WSConnState -> IO WSConnState
forall a. TVar a -> IO a
STM.readTVarIO TVar WSConnState
userInfoR
let (Maybe SessionVariables
userVarsM, Maybe UTCTime
tokenExpM) = case WSConnState
userInfoME of
CSInitialised WsClientState {[Header]
Maybe UTCTime
UserInfo
IpAddress
wscsIpAddress :: WsClientState -> IpAddress
wscsReqHeaders :: WsClientState -> [Header]
wscsTokenExpTime :: WsClientState -> Maybe UTCTime
wscsUserInfo :: WsClientState -> UserInfo
wscsIpAddress :: IpAddress
wscsReqHeaders :: [Header]
wscsTokenExpTime :: Maybe UTCTime
wscsUserInfo :: UserInfo
..} ->
( SessionVariables -> Maybe SessionVariables
forall a. a -> Maybe a
Just (SessionVariables -> Maybe SessionVariables)
-> SessionVariables -> Maybe SessionVariables
forall a b. (a -> b) -> a -> b
$ UserInfo -> SessionVariables
_uiSession UserInfo
wscsUserInfo,
Maybe UTCTime
wscsTokenExpTime
)
WSConnState
_ -> (Maybe SessionVariables
forall a. Maybe a
Nothing, Maybe UTCTime
forall a. Maybe a
Nothing)
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ WSLog -> IO ()
forall a (m :: * -> *).
(ToEngineLog a Hasura, MonadIO m) =>
a -> m ()
logger (WSLog -> IO ()) -> WSLog -> IO ()
forall a b. (a -> b) -> a -> b
$ LogLevel -> WSLogInfo -> WSLog
WSLog LogLevel
logLevel (WSLogInfo -> WSLog) -> WSLogInfo -> WSLog
forall a b. (a -> b) -> a -> b
$ Maybe SessionVariables -> WsConnInfo -> WSEvent -> WSLogInfo
WSLogInfo Maybe SessionVariables
userVarsM (WSId -> Maybe UTCTime -> Maybe Text -> WsConnInfo
WsConnInfo WSId
wsId Maybe UTCTime
tokenExpM Maybe Text
forall a. Maybe a
Nothing) WSEvent
wsEv
where
WSConnData TVar WSConnState
userInfoR OperationMap
_ ErrRespType
_ GraphQLQueryType
_ = WSConn -> WSConnData
forall a. WSConn a -> a
WS.getData WSConn
wsConn
wsId :: WSId
wsId = WSConn -> WSId
forall a. WSConn a -> WSId
WS.getWSId WSConn
wsConn
logLevel :: LogLevel
logLevel = LogLevel -> LogLevel -> Bool -> LogLevel
forall a. a -> a -> Bool -> a
bool LogLevel
L.LevelInfo LogLevel
L.LevelError Bool
isError
isError :: Bool
isError = case WSEvent
wsEv of
WSEvent
EAccepted -> Bool
False
ERejected QErr
_ -> Bool
True
EConnErr ConnErrMsg
_ -> Bool
True
WSEvent
EClosed -> Bool
False
EOperation OperationDetails
operation -> case OperationDetails -> OpDetail
_odOperationType OperationDetails
operation of
OpDetail
ODStarted -> Bool
False
ODProtoErr Text
_ -> Bool
True
ODQueryErr QErr
_ -> Bool
True
OpDetail
ODCompleted -> Bool
False
OpDetail
ODStopped -> Bool
False
sendMsg :: (MonadIO m) => WSConn -> ServerMsg -> m ()
sendMsg :: WSConn -> ServerMsg -> m ()
sendMsg WSConn
wsConn ServerMsg
msg =
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ WSConn -> WSQueueResponse -> IO ()
forall a. WSConn a -> WSQueueResponse -> IO ()
WS.sendMsg WSConn
wsConn (WSQueueResponse -> IO ()) -> WSQueueResponse -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe WSEventInfo -> WSQueueResponse
WS.WSQueueResponse (ServerMsg -> ByteString
encodeServerMsg ServerMsg
msg) Maybe WSEventInfo
forall a. Maybe a
Nothing
sendCloseWithMsg ::
(MonadIO m) =>
L.Logger L.Hasura ->
WSConn ->
ServerErrorCode ->
Maybe ServerMsg ->
Maybe Word16 ->
m ()
sendCloseWithMsg :: Logger Hasura
-> WSConn
-> ServerErrorCode
-> Maybe ServerMsg
-> Maybe Word16
-> m ()
sendCloseWithMsg Logger Hasura
logger WSConn
wsConn ServerErrorCode
errCode Maybe ServerMsg
mErrServerMsg Maybe Word16
mCode = do
case Maybe ServerMsg
mErrServerMsg of
Just ServerMsg
errServerMsg ->
WSConn -> ServerMsg -> m ()
forall (m :: * -> *). MonadIO m => WSConn -> ServerMsg -> m ()
sendMsg WSConn
wsConn ServerMsg
errServerMsg
Maybe ServerMsg
Nothing -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Logger Hasura -> WSConn -> WSEvent -> m ()
forall (m :: * -> *).
MonadIO m =>
Logger Hasura -> WSConn -> WSEvent -> m ()
logWSEvent Logger Hasura
logger WSConn
wsConn WSEvent
EClosed
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Connection -> Word16 -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> Word16 -> a -> IO ()
WS.sendCloseCode Connection
wsc Word16
errCloseCode ByteString
errMsg
where
wsc :: Connection
wsc = WSConn -> Connection
forall a. WSConn a -> Connection
WS.getRawWebSocketConnection WSConn
wsConn
errMsg :: ByteString
errMsg = ServerErrorCode -> ByteString
encodeServerErrorMsg ServerErrorCode
errCode
errCloseCode :: Word16
errCloseCode = Word16 -> Maybe Word16 -> Word16
forall a. a -> Maybe a -> a
fromMaybe (ServerErrorCode -> Word16
getErrCode ServerErrorCode
errCode) Maybe Word16
mCode
getErrCode :: ServerErrorCode -> Word16
getErrCode :: ServerErrorCode -> Word16
getErrCode ServerErrorCode
err = case ServerErrorCode
err of
ServerErrorCode
ProtocolError1002 -> Word16
1002
GenericError4400 String
_ -> Word16
4400
ServerErrorCode
Unauthorized4401 -> Word16
4401
ServerErrorCode
Forbidden4403 -> Word16
4403
ServerErrorCode
ConnectionInitTimeout4408 -> Word16
4408
NonUniqueSubscription4409 OperationId
_ -> Word16
4409
ServerErrorCode
TooManyRequests4429 -> Word16
4429
sendMsgWithMetadata ::
(MonadIO m) =>
WSConn ->
ServerMsg ->
Maybe OperationName ->
Maybe ParameterizedQueryHash ->
ES.SubscriptionMetadata ->
m ()
sendMsgWithMetadata :: WSConn
-> ServerMsg
-> Maybe OperationName
-> Maybe ParameterizedQueryHash
-> SubscriptionMetadata
-> m ()
sendMsgWithMetadata WSConn
wsConn ServerMsg
msg Maybe OperationName
opName Maybe ParameterizedQueryHash
paramQueryHash (ES.SubscriptionMetadata DiffTime
execTime) =
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ WSConn -> WSQueueResponse -> IO ()
forall a. WSConn a -> WSQueueResponse -> IO ()
WS.sendMsg WSConn
wsConn (WSQueueResponse -> IO ()) -> WSQueueResponse -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe WSEventInfo -> WSQueueResponse
WS.WSQueueResponse ByteString
bs Maybe WSEventInfo
wsInfo
where
bs :: ByteString
bs = ServerMsg -> ByteString
encodeServerMsg ServerMsg
msg
(Maybe ServerMsgType
msgType, Maybe OperationId
operationId) = case ServerMsg
msg of
(SMNext (DataMsg OperationId
opId GQResponse
_)) -> (ServerMsgType -> Maybe ServerMsgType
forall a. a -> Maybe a
Just ServerMsgType
SMT_GQL_NEXT, OperationId -> Maybe OperationId
forall a. a -> Maybe a
Just OperationId
opId)
(SMData (DataMsg OperationId
opId GQResponse
_)) -> (ServerMsgType -> Maybe ServerMsgType
forall a. a -> Maybe a
Just ServerMsgType
SMT_GQL_DATA, OperationId -> Maybe OperationId
forall a. a -> Maybe a
Just OperationId
opId)
ServerMsg
_ -> (Maybe ServerMsgType
forall a. Maybe a
Nothing, Maybe OperationId
forall a. Maybe a
Nothing)
wsInfo :: Maybe WSEventInfo
wsInfo =
WSEventInfo -> Maybe WSEventInfo
forall a. a -> Maybe a
Just
(WSEventInfo -> Maybe WSEventInfo)
-> WSEventInfo -> Maybe WSEventInfo
forall a b. (a -> b) -> a -> b
$! WSEventInfo :: Maybe ServerMsgType
-> Maybe OperationId
-> Maybe OperationName
-> Maybe Double
-> Maybe Int64
-> Maybe ParameterizedQueryHash
-> WSEventInfo
WS.WSEventInfo
{ _wseiEventType :: Maybe ServerMsgType
WS._wseiEventType = Maybe ServerMsgType
msgType,
_wseiOperationId :: Maybe OperationId
WS._wseiOperationId = Maybe OperationId
operationId,
_wseiOperationName :: Maybe OperationName
WS._wseiOperationName = Maybe OperationName
opName,
_wseiQueryExecutionTime :: Maybe Double
WS._wseiQueryExecutionTime = Double -> Maybe Double
forall a. a -> Maybe a
Just (Double -> Maybe Double) -> Double -> Maybe Double
forall a b. (a -> b) -> a -> b
$! DiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac DiffTime
execTime,
_wseiResponseSize :: Maybe Int64
WS._wseiResponseSize = Int64 -> Maybe Int64
forall a. a -> Maybe a
Just (Int64 -> Maybe Int64) -> Int64 -> Maybe Int64
forall a b. (a -> b) -> a -> b
$! ByteString -> Int64
LBS.length ByteString
bs,
_wseiParameterizedQueryHash :: Maybe ParameterizedQueryHash
WS._wseiParameterizedQueryHash = Maybe ParameterizedQueryHash
paramQueryHash
}
onConn ::
(MonadIO m, MonadReader WSServerEnv m) =>
WS.OnConnH m WSConnData
onConn :: OnConnH m WSConnData
onConn WSId
wsId RequestHead
requestHead IpAddress
ipAddress WSActions WSConnData
onConnHActions = do
Either QErr (WsHeaders, ErrRespType, GraphQLQueryType)
res <- ExceptT QErr m (WsHeaders, ErrRespType, GraphQLQueryType)
-> m (Either QErr (WsHeaders, ErrRespType, GraphQLQueryType))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT QErr m (WsHeaders, ErrRespType, GraphQLQueryType)
-> m (Either QErr (WsHeaders, ErrRespType, GraphQLQueryType)))
-> ExceptT QErr m (WsHeaders, ErrRespType, GraphQLQueryType)
-> m (Either QErr (WsHeaders, ErrRespType, GraphQLQueryType))
forall a b. (a -> b) -> a -> b
$ do
(ErrRespType
errType, GraphQLQueryType
queryType) <- ExceptT QErr m (ErrRespType, GraphQLQueryType)
checkPath
let reqHdrs :: [Header]
reqHdrs = RequestHead -> [Header]
WS.requestHeaders RequestHead
requestHead
[Header]
headers <- ExceptT QErr m [Header]
-> (Header -> ExceptT QErr m [Header])
-> Maybe Header
-> ExceptT QErr m [Header]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Header] -> ExceptT QErr m [Header]
forall (m :: * -> *) a. Monad m => a -> m a
return [Header]
reqHdrs) ((ByteString -> [Header] -> ExceptT QErr m [Header])
-> [Header] -> ByteString -> ExceptT QErr m [Header]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ByteString -> [Header] -> ExceptT QErr m [Header]
enforceCors [Header]
reqHdrs (ByteString -> ExceptT QErr m [Header])
-> (Header -> ByteString) -> Header -> ExceptT QErr m [Header]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header -> ByteString
forall a b. (a, b) -> b
snd) Maybe Header
getOrigin
(WsHeaders, ErrRespType, GraphQLQueryType)
-> ExceptT QErr m (WsHeaders, ErrRespType, GraphQLQueryType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Header] -> WsHeaders
WsHeaders ([Header] -> WsHeaders) -> [Header] -> WsHeaders
forall a b. (a -> b) -> a -> b
$ [Header] -> [Header]
forall a b. (Eq a, IsString a) => [(a, b)] -> [(a, b)]
filterWsHeaders [Header]
headers, ErrRespType
errType, GraphQLQueryType
queryType)
(QErr -> m (Either RejectRequest (AcceptWith WSConnData)))
-> ((WsHeaders, ErrRespType, GraphQLQueryType)
-> m (Either RejectRequest (AcceptWith WSConnData)))
-> Either QErr (WsHeaders, ErrRespType, GraphQLQueryType)
-> m (Either RejectRequest (AcceptWith WSConnData))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either QErr -> m (Either RejectRequest (AcceptWith WSConnData))
reject (WsHeaders, ErrRespType, GraphQLQueryType)
-> m (Either RejectRequest (AcceptWith WSConnData))
accept Either QErr (WsHeaders, ErrRespType, GraphQLQueryType)
res
where
kaAction :: WSKeepAliveMessageAction WSConnData
kaAction = WSActions WSConnData -> WSKeepAliveMessageAction WSConnData
forall a. WSActions a -> WSKeepAliveMessageAction a
WS._wsaKeepAliveAction WSActions WSConnData
onConnHActions
acceptRequest :: AcceptRequest
acceptRequest = WSActions WSConnData -> AcceptRequest
forall a. WSActions a -> AcceptRequest
WS._wsaAcceptRequest WSActions WSConnData
onConnHActions
keepAliveAction :: KeepAliveDelay -> WSKeepAliveMessageAction WSConnData
keepAliveAction KeepAliveDelay
keepAliveDelay WSConn
wsConn =
IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
WSKeepAliveMessageAction WSConnData
kaAction WSConn
wsConn
DiffTime -> IO ()
sleep (DiffTime -> IO ()) -> DiffTime -> IO ()
forall a b. (a -> b) -> a -> b
$ Seconds -> DiffTime
seconds (NonNegative Seconds -> Seconds
forall a. NonNegative a -> a
Numeric.getNonNegative (NonNegative Seconds -> Seconds) -> NonNegative Seconds -> Seconds
forall a b. (a -> b) -> a -> b
$ KeepAliveDelay -> NonNegative Seconds
unKeepAliveDelay KeepAliveDelay
keepAliveDelay)
tokenExpiryHandler :: WSKeepAliveMessageAction WSConnData
tokenExpiryHandler WSConn
wsConn = do
UTCTime
expTime <- IO UTCTime -> IO UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> IO UTCTime) -> IO UTCTime -> IO UTCTime
forall a b. (a -> b) -> a -> b
$
STM UTCTime -> IO UTCTime
forall a. STM a -> IO a
STM.atomically (STM UTCTime -> IO UTCTime) -> STM UTCTime -> IO UTCTime
forall a b. (a -> b) -> a -> b
$ do
WSConnState
connState <- TVar WSConnState -> STM WSConnState
forall a. TVar a -> STM a
STM.readTVar (TVar WSConnState -> STM WSConnState)
-> TVar WSConnState -> STM WSConnState
forall a b. (a -> b) -> a -> b
$ (WSConnData -> TVar WSConnState
_wscUser (WSConnData -> TVar WSConnState)
-> (WSConn -> WSConnData) -> WSConn -> TVar WSConnState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WSConn -> WSConnData
forall a. WSConn a -> a
WS.getData) WSConn
wsConn
case WSConnState
connState of
CSNotInitialised WsHeaders
_ IpAddress
_ -> STM UTCTime
forall a. STM a
STM.retry
CSInitError Text
_ -> STM UTCTime
forall a. STM a
STM.retry
CSInitialised WsClientState
clientState -> Maybe UTCTime -> STM UTCTime -> STM UTCTime
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
onNothing (WsClientState -> Maybe UTCTime
wscsTokenExpTime WsClientState
clientState) STM UTCTime
forall a. STM a
STM.retry
UTCTime
currTime <- IO UTCTime
TC.getCurrentTime
DiffTime -> IO ()
sleep (DiffTime -> IO ()) -> DiffTime -> IO ()
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> DiffTime
forall x y. (Duration x, Duration y) => x -> y
convertDuration (NominalDiffTime -> DiffTime) -> NominalDiffTime -> DiffTime
forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
TC.diffUTCTime UTCTime
expTime UTCTime
currTime
accept :: (WsHeaders, ErrRespType, GraphQLQueryType)
-> m (Either RejectRequest (AcceptWith WSConnData))
accept (WsHeaders
hdrs, ErrRespType
errType, GraphQLQueryType
queryType) = do
(L.Logger forall a (m :: * -> *).
(ToEngineLog a Hasura, MonadIO m) =>
a -> m ()
logger) <- (WSServerEnv -> Logger Hasura) -> m (Logger Hasura)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WSServerEnv -> Logger Hasura
_wseLogger
KeepAliveDelay
keepAliveDelay <- (WSServerEnv -> KeepAliveDelay) -> m KeepAliveDelay
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WSServerEnv -> KeepAliveDelay
_wseKeepAliveDelay
WSLog -> m ()
forall a (m :: * -> *).
(ToEngineLog a Hasura, MonadIO m) =>
a -> m ()
logger (WSLog -> m ()) -> WSLog -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe SessionVariables -> WsConnInfo -> WSEvent -> WSLog
mkWsInfoLog Maybe SessionVariables
forall a. Maybe a
Nothing (WSId -> Maybe UTCTime -> Maybe Text -> WsConnInfo
WsConnInfo WSId
wsId Maybe UTCTime
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) WSEvent
EAccepted
WSConnData
connData <-
IO WSConnData -> m WSConnData
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO WSConnData -> m WSConnData) -> IO WSConnData -> m WSConnData
forall a b. (a -> b) -> a -> b
$
TVar WSConnState
-> OperationMap -> ErrRespType -> GraphQLQueryType -> WSConnData
WSConnData
(TVar WSConnState
-> OperationMap -> ErrRespType -> GraphQLQueryType -> WSConnData)
-> IO (TVar WSConnState)
-> IO
(OperationMap -> ErrRespType -> GraphQLQueryType -> WSConnData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WSConnState -> IO (TVar WSConnState)
forall a. a -> IO (TVar a)
STM.newTVarIO (WsHeaders -> IpAddress -> WSConnState
CSNotInitialised WsHeaders
hdrs IpAddress
ipAddress)
IO (OperationMap -> ErrRespType -> GraphQLQueryType -> WSConnData)
-> IO OperationMap
-> IO (ErrRespType -> GraphQLQueryType -> WSConnData)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO OperationMap
forall key value. IO (Map key value)
STMMap.newIO
IO (ErrRespType -> GraphQLQueryType -> WSConnData)
-> IO ErrRespType -> IO (GraphQLQueryType -> WSConnData)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ErrRespType -> IO ErrRespType
forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrRespType
errType
IO (GraphQLQueryType -> WSConnData)
-> IO GraphQLQueryType -> IO WSConnData
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GraphQLQueryType -> IO GraphQLQueryType
forall (f :: * -> *) a. Applicative f => a -> f a
pure GraphQLQueryType
queryType
Either RejectRequest (AcceptWith WSConnData)
-> m (Either RejectRequest (AcceptWith WSConnData))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either RejectRequest (AcceptWith WSConnData)
-> m (Either RejectRequest (AcceptWith WSConnData)))
-> Either RejectRequest (AcceptWith WSConnData)
-> m (Either RejectRequest (AcceptWith WSConnData))
forall a b. (a -> b) -> a -> b
$
AcceptWith WSConnData
-> Either RejectRequest (AcceptWith WSConnData)
forall a b. b -> Either a b
Right (AcceptWith WSConnData
-> Either RejectRequest (AcceptWith WSConnData))
-> AcceptWith WSConnData
-> Either RejectRequest (AcceptWith WSConnData)
forall a b. (a -> b) -> a -> b
$
WSConnData
-> AcceptRequest
-> WSKeepAliveMessageAction WSConnData
-> WSKeepAliveMessageAction WSConnData
-> AcceptWith WSConnData
forall a.
a
-> AcceptRequest
-> (WSConn a -> IO ())
-> (WSConn a -> IO ())
-> AcceptWith a
WS.AcceptWith
WSConnData
connData
AcceptRequest
acceptRequest
(KeepAliveDelay -> WSKeepAliveMessageAction WSConnData
keepAliveAction KeepAliveDelay
keepAliveDelay)
WSKeepAliveMessageAction WSConnData
tokenExpiryHandler
reject :: QErr -> m (Either RejectRequest (AcceptWith WSConnData))
reject QErr
qErr = do
(L.Logger forall a (m :: * -> *).
(ToEngineLog a Hasura, MonadIO m) =>
a -> m ()
logger) <- (WSServerEnv -> Logger Hasura) -> m (Logger Hasura)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WSServerEnv -> Logger Hasura
_wseLogger
WSLog -> m ()
forall a (m :: * -> *).
(ToEngineLog a Hasura, MonadIO m) =>
a -> m ()
logger (WSLog -> m ()) -> WSLog -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe SessionVariables -> WsConnInfo -> WSEvent -> WSLog
mkWsErrorLog Maybe SessionVariables
forall a. Maybe a
Nothing (WSId -> Maybe UTCTime -> Maybe Text -> WsConnInfo
WsConnInfo WSId
wsId Maybe UTCTime
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) (QErr -> WSEvent
ERejected QErr
qErr)
Either RejectRequest (AcceptWith WSConnData)
-> m (Either RejectRequest (AcceptWith WSConnData))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either RejectRequest (AcceptWith WSConnData)
-> m (Either RejectRequest (AcceptWith WSConnData)))
-> Either RejectRequest (AcceptWith WSConnData)
-> m (Either RejectRequest (AcceptWith WSConnData))
forall a b. (a -> b) -> a -> b
$
RejectRequest -> Either RejectRequest (AcceptWith WSConnData)
forall a b. a -> Either a b
Left (RejectRequest -> Either RejectRequest (AcceptWith WSConnData))
-> RejectRequest -> Either RejectRequest (AcceptWith WSConnData)
forall a b. (a -> b) -> a -> b
$
Int -> ByteString -> [Header] -> ByteString -> RejectRequest
WS.RejectRequest
(Status -> Int
HTTP.statusCode (Status -> Int) -> Status -> Int
forall a b. (a -> b) -> a -> b
$ QErr -> Status
qeStatus QErr
qErr)
(Status -> ByteString
HTTP.statusMessage (Status -> ByteString) -> Status -> ByteString
forall a b. (a -> b) -> a -> b
$ QErr -> Status
qeStatus QErr
qErr)
[]
(ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
J.encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ Bool -> QErr -> Value
encodeGQLErr Bool
False QErr
qErr)
checkPath :: ExceptT QErr m (ErrRespType, GraphQLQueryType)
checkPath = case RequestHead -> ByteString
WS.requestPath RequestHead
requestHead of
ByteString
"/v1alpha1/graphql" -> (ErrRespType, GraphQLQueryType)
-> ExceptT QErr m (ErrRespType, GraphQLQueryType)
forall (m :: * -> *) a. Monad m => a -> m a
return (ErrRespType
ERTLegacy, GraphQLQueryType
E.QueryHasura)
ByteString
"/v1/graphql" -> (ErrRespType, GraphQLQueryType)
-> ExceptT QErr m (ErrRespType, GraphQLQueryType)
forall (m :: * -> *) a. Monad m => a -> m a
return (ErrRespType
ERTGraphqlCompliant, GraphQLQueryType
E.QueryHasura)
ByteString
"/v1beta1/relay" -> (ErrRespType, GraphQLQueryType)
-> ExceptT QErr m (ErrRespType, GraphQLQueryType)
forall (m :: * -> *) a. Monad m => a -> m a
return (ErrRespType
ERTGraphqlCompliant, GraphQLQueryType
E.QueryRelay)
ByteString
_ ->
Text -> ExceptT QErr m (ErrRespType, GraphQLQueryType)
forall (m :: * -> *) a. QErrM m => Text -> m a
throw404 Text
"only '/v1/graphql', '/v1alpha1/graphql' and '/v1beta1/relay' are supported on websockets"
getOrigin :: Maybe Header
getOrigin =
(Header -> Bool) -> [Header] -> Maybe Header
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (CI ByteString -> CI ByteString -> Bool
forall a. Eq a => a -> a -> Bool
(==) CI ByteString
"Origin" (CI ByteString -> Bool)
-> (Header -> CI ByteString) -> Header -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header -> CI ByteString
forall a b. (a, b) -> a
fst) (RequestHead -> [Header]
WS.requestHeaders RequestHead
requestHead)
enforceCors :: ByteString -> [Header] -> ExceptT QErr m [Header]
enforceCors ByteString
origin [Header]
reqHdrs = do
(L.Logger forall a (m :: * -> *).
(ToEngineLog a Hasura, MonadIO m) =>
a -> m ()
logger) <- (WSServerEnv -> Logger Hasura) -> ExceptT QErr m (Logger Hasura)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WSServerEnv -> Logger Hasura
_wseLogger
CorsPolicy
corsPolicy <- (WSServerEnv -> CorsPolicy) -> ExceptT QErr m CorsPolicy
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WSServerEnv -> CorsPolicy
_wseCorsPolicy
case CorsPolicy -> CorsConfig
cpConfig CorsPolicy
corsPolicy of
CorsConfig
CCAllowAll -> [Header] -> ExceptT QErr m [Header]
forall (m :: * -> *) a. Monad m => a -> m a
return [Header]
reqHdrs
CCDisabled Bool
readCookie ->
if Bool
readCookie
then [Header] -> ExceptT QErr m [Header]
forall (m :: * -> *) a. Monad m => a -> m a
return [Header]
reqHdrs
else do
m () -> ExceptT QErr m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT QErr m ()) -> m () -> ExceptT QErr m ()
forall a b. (a -> b) -> a -> b
$ WSLog -> m ()
forall a (m :: * -> *).
(ToEngineLog a Hasura, MonadIO m) =>
a -> m ()
logger (WSLog -> m ()) -> WSLog -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe SessionVariables -> WsConnInfo -> WSEvent -> WSLog
mkWsInfoLog Maybe SessionVariables
forall a. Maybe a
Nothing (WSId -> Maybe UTCTime -> Maybe Text -> WsConnInfo
WsConnInfo WSId
wsId Maybe UTCTime
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
corsNote)) WSEvent
EAccepted
[Header] -> ExceptT QErr m [Header]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Header] -> ExceptT QErr m [Header])
-> [Header] -> ExceptT QErr m [Header]
forall a b. (a -> b) -> a -> b
$ (Header -> Bool) -> [Header] -> [Header]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Header
h -> Header -> CI ByteString
forall a b. (a, b) -> a
fst Header
h CI ByteString -> CI ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= CI ByteString
"Cookie") [Header]
reqHdrs
CCAllowedOrigins Domains
ds
| ByteString -> Text
bsToTxt ByteString
origin Text -> HashSet Text -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Domains -> HashSet Text
dmFqdns Domains
ds -> [Header] -> ExceptT QErr m [Header]
forall (m :: * -> *) a. Monad m => a -> m a
return [Header]
reqHdrs
| Domains -> Text -> Bool
inWildcardList Domains
ds (ByteString -> Text
bsToTxt ByteString
origin) -> [Header] -> ExceptT QErr m [Header]
forall (m :: * -> *) a. Monad m => a -> m a
return [Header]
reqHdrs
| Bool
otherwise -> ExceptT QErr m [Header]
forall a. ExceptT QErr m a
corsErr
filterWsHeaders :: [(a, b)] -> [(a, b)]
filterWsHeaders [(a, b)]
hdrs = (((a, b) -> Bool) -> [(a, b)] -> [(a, b)])
-> [(a, b)] -> ((a, b) -> Bool) -> [(a, b)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((a, b) -> Bool) -> [(a, b)] -> [(a, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter [(a, b)]
hdrs (((a, b) -> Bool) -> [(a, b)]) -> ((a, b) -> Bool) -> [(a, b)]
forall a b. (a -> b) -> a -> b
$ \(a
n, b
_) ->
a
n
a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ a
"sec-websocket-key",
a
"sec-websocket-version",
a
"upgrade",
a
"connection"
]
corsErr :: ExceptT QErr m a
corsErr =
Code -> Text -> ExceptT QErr m a
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400
Code
AccessDenied
Text
"received origin header does not match configured CORS domains"
corsNote :: Text
corsNote =
Text
"Cookie is not read when CORS is disabled, because it is a potential "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"security issue. If you're already handling CORS before Hasura and enforcing "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"CORS on websocket connections, then you can use the flag --ws-read-cookie or "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"HASURA_GRAPHQL_WS_READ_COOKIE to force read cookie when CORS is disabled."
onStart ::
forall m.
( MonadIO m,
E.MonadGQLExecutionCheck m,
MonadQueryLog m,
Tracing.MonadTrace m,
MonadExecuteQuery m,
MC.MonadBaseControl IO m,
MonadMetadataStorage (MetadataStorageT m),
EB.MonadQueryTags m,
HasResourceLimits m
) =>
Env.Environment ->
HashSet (L.EngineLogType L.Hasura) ->
WSServerEnv ->
WSConn ->
StartMsg ->
WS.WSActions WSConnData ->
m ()
onStart :: Environment
-> HashSet (EngineLogType Hasura)
-> WSServerEnv
-> WSConn
-> StartMsg
-> WSActions WSConnData
-> m ()
onStart Environment
env HashSet (EngineLogType Hasura)
enabledLogTypes WSServerEnv
serverEnv WSConn
wsConn (StartMsg OperationId
opId GQLReqUnparsed
q) WSActions WSConnData
onMessageActions = ExceptT () m () -> m ()
catchAndIgnore (ExceptT () m () -> m ()) -> ExceptT () m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
ExceptT () m DiffTime
timerTot <- ExceptT () m (ExceptT () m DiffTime)
forall (m :: * -> *) (n :: * -> *).
(MonadIO m, MonadIO n) =>
m (n DiffTime)
startTimer
Maybe (SubscriberType, Maybe OperationName)
op <- IO (Maybe (SubscriberType, Maybe OperationName))
-> ExceptT () m (Maybe (SubscriberType, Maybe OperationName))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (SubscriberType, Maybe OperationName))
-> ExceptT () m (Maybe (SubscriberType, Maybe OperationName)))
-> IO (Maybe (SubscriberType, Maybe OperationName))
-> ExceptT () m (Maybe (SubscriberType, Maybe OperationName))
forall a b. (a -> b) -> a -> b
$ STM (Maybe (SubscriberType, Maybe OperationName))
-> IO (Maybe (SubscriberType, Maybe OperationName))
forall a. STM a -> IO a
STM.atomically (STM (Maybe (SubscriberType, Maybe OperationName))
-> IO (Maybe (SubscriberType, Maybe OperationName)))
-> STM (Maybe (SubscriberType, Maybe OperationName))
-> IO (Maybe (SubscriberType, Maybe OperationName))
forall a b. (a -> b) -> a -> b
$ OperationId
-> OperationMap
-> STM (Maybe (SubscriberType, Maybe OperationName))
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
STMMap.lookup OperationId
opId OperationMap
opMap
let opName :: Maybe OperationName
opName = GQLReqUnparsed -> Maybe OperationName
forall a. GQLReq a -> Maybe OperationName
_grOperationName GQLReqUnparsed
q
Bool -> ExceptT () m () -> ExceptT () m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (SubscriberType, Maybe OperationName) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (SubscriberType, Maybe OperationName)
op) (ExceptT () m () -> ExceptT () m ())
-> ExceptT () m () -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$
ExceptT () m () -> ExceptT () m ()
forall a. ExceptT () m () -> ExceptT () m a
withComplete (ExceptT () m () -> ExceptT () m ())
-> ExceptT () m () -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$
Text -> ExceptT () m ()
sendStartErr (Text -> ExceptT () m ()) -> Text -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$
Text
"an operation already exists with this id: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> OperationId -> Text
unOperationId OperationId
opId
WSConnState
userInfoM <- IO WSConnState -> ExceptT () m WSConnState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO WSConnState -> ExceptT () m WSConnState)
-> IO WSConnState -> ExceptT () m WSConnState
forall a b. (a -> b) -> a -> b
$ TVar WSConnState -> IO WSConnState
forall a. TVar a -> IO a
STM.readTVarIO TVar WSConnState
userInfoR
(UserInfo
userInfo, [Header]
origReqHdrs, IpAddress
ipAddress) <- case WSConnState
userInfoM of
CSInitialised WsClientState {[Header]
Maybe UTCTime
UserInfo
IpAddress
wscsIpAddress :: IpAddress
wscsReqHeaders :: [Header]
wscsTokenExpTime :: Maybe UTCTime
wscsUserInfo :: UserInfo
wscsIpAddress :: WsClientState -> IpAddress
wscsReqHeaders :: WsClientState -> [Header]
wscsTokenExpTime :: WsClientState -> Maybe UTCTime
wscsUserInfo :: WsClientState -> UserInfo
..} -> (UserInfo, [Header], IpAddress)
-> ExceptT () m (UserInfo, [Header], IpAddress)
forall (m :: * -> *) a. Monad m => a -> m a
return (UserInfo
wscsUserInfo, [Header]
wscsReqHeaders, IpAddress
wscsIpAddress)
CSInitError Text
initErr -> do
let e :: Text
e = Text
"cannot start as connection_init failed with : " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
initErr
ExceptT () m () -> ExceptT () m (UserInfo, [Header], IpAddress)
forall a. ExceptT () m () -> ExceptT () m a
withComplete (ExceptT () m () -> ExceptT () m (UserInfo, [Header], IpAddress))
-> ExceptT () m () -> ExceptT () m (UserInfo, [Header], IpAddress)
forall a b. (a -> b) -> a -> b
$ Text -> ExceptT () m ()
sendStartErr Text
e
CSNotInitialised WsHeaders
_ IpAddress
_ -> do
let e :: Text
e = Text
"start received before the connection is initialised"
ExceptT () m () -> ExceptT () m (UserInfo, [Header], IpAddress)
forall a. ExceptT () m () -> ExceptT () m a
withComplete (ExceptT () m () -> ExceptT () m (UserInfo, [Header], IpAddress))
-> ExceptT () m () -> ExceptT () m (UserInfo, [Header], IpAddress)
forall a b. (a -> b) -> a -> b
$ Text -> ExceptT () m ()
sendStartErr Text
e
(RequestId
requestId, [Header]
reqHdrs) <- IO (RequestId, [Header]) -> ExceptT () m (RequestId, [Header])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (RequestId, [Header]) -> ExceptT () m (RequestId, [Header]))
-> IO (RequestId, [Header]) -> ExceptT () m (RequestId, [Header])
forall a b. (a -> b) -> a -> b
$ [Header] -> IO (RequestId, [Header])
forall (m :: * -> *).
MonadIO m =>
[Header] -> m (RequestId, [Header])
getRequestId [Header]
origReqHdrs
(SchemaCache
sc, SchemaCacheVer
scVer) <- IO (SchemaCache, SchemaCacheVer)
-> ExceptT () m (SchemaCache, SchemaCacheVer)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (SchemaCache, SchemaCacheVer)
getSchemaCache
UserInfo -> ApiLimit -> ResourceLimits
operationLimit <- RequestId -> ExceptT () m (UserInfo -> ApiLimit -> ResourceLimits)
forall (m :: * -> *).
HasResourceLimits m =>
RequestId -> m (UserInfo -> ApiLimit -> ResourceLimits)
askGraphqlOperationLimit RequestId
requestId
let runLimits ::
ExceptT (Either GQExecError QErr) (ExceptT () m) a ->
ExceptT (Either GQExecError QErr) (ExceptT () m) a
runLimits :: ExceptT (Either GQExecError QErr) (ExceptT () m) a
-> ExceptT (Either GQExecError QErr) (ExceptT () m) a
runLimits = (QErr -> Either GQExecError QErr)
-> (ExceptT
QErr (ExceptT (Either GQExecError QErr) (ExceptT () m)) a
-> ExceptT
QErr (ExceptT (Either GQExecError QErr) (ExceptT () m)) a)
-> ExceptT (Either GQExecError QErr) (ExceptT () m) a
-> ExceptT (Either GQExecError QErr) (ExceptT () m) a
forall e f (n :: * -> *) a.
Monad n =>
(e -> f)
-> (ExceptT e (ExceptT f n) a -> ExceptT e (ExceptT f n) a)
-> ExceptT f n a
-> ExceptT f n a
withErr QErr -> Either GQExecError QErr
forall a b. b -> Either a b
Right ((ExceptT QErr (ExceptT (Either GQExecError QErr) (ExceptT () m)) a
-> ExceptT
QErr (ExceptT (Either GQExecError QErr) (ExceptT () m)) a)
-> ExceptT (Either GQExecError QErr) (ExceptT () m) a
-> ExceptT (Either GQExecError QErr) (ExceptT () m) a)
-> (ExceptT
QErr (ExceptT (Either GQExecError QErr) (ExceptT () m)) a
-> ExceptT
QErr (ExceptT (Either GQExecError QErr) (ExceptT () m)) a)
-> ExceptT (Either GQExecError QErr) (ExceptT () m) a
-> ExceptT (Either GQExecError QErr) (ExceptT () m) a
forall a b. (a -> b) -> a -> b
$ ResourceLimits
-> forall (m :: * -> *) a.
(MonadBaseControl IO m, MonadError QErr m) =>
m a -> m a
runResourceLimits (ResourceLimits
-> forall (m :: * -> *) a.
(MonadBaseControl IO m, MonadError QErr m) =>
m a -> m a)
-> ResourceLimits
-> forall (m :: * -> *) a.
(MonadBaseControl IO m, MonadError QErr m) =>
m a -> m a
forall a b. (a -> b) -> a -> b
$ UserInfo -> ApiLimit -> ResourceLimits
operationLimit UserInfo
userInfo (SchemaCache -> ApiLimit
scApiLimits SchemaCache
sc)
Either QErr GQLReqParsed
reqParsedE <- m (Either QErr GQLReqParsed)
-> ExceptT () m (Either QErr GQLReqParsed)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either QErr GQLReqParsed)
-> ExceptT () m (Either QErr GQLReqParsed))
-> m (Either QErr GQLReqParsed)
-> ExceptT () m (Either QErr GQLReqParsed)
forall a b. (a -> b) -> a -> b
$ UserInfo
-> ([Header], IpAddress)
-> Bool
-> SchemaCache
-> GQLReqUnparsed
-> RequestId
-> m (Either QErr GQLReqParsed)
forall (m :: * -> *).
MonadGQLExecutionCheck m =>
UserInfo
-> ([Header], IpAddress)
-> Bool
-> SchemaCache
-> GQLReqUnparsed
-> RequestId
-> m (Either QErr GQLReqParsed)
E.checkGQLExecution UserInfo
userInfo ([Header]
reqHdrs, IpAddress
ipAddress) Bool
enableAL SchemaCache
sc GQLReqUnparsed
q RequestId
requestId
GQLReqParsed
reqParsed <- Either QErr GQLReqParsed
-> (QErr -> ExceptT () m GQLReqParsed) -> ExceptT () m GQLReqParsed
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
onLeft Either QErr GQLReqParsed
reqParsedE (ExceptT () m () -> ExceptT () m GQLReqParsed
forall a. ExceptT () m () -> ExceptT () m a
withComplete (ExceptT () m () -> ExceptT () m GQLReqParsed)
-> (QErr -> ExceptT () m ()) -> QErr -> ExceptT () m GQLReqParsed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestId -> Maybe OperationType -> QErr -> ExceptT () m ()
preExecErr RequestId
requestId Maybe OperationType
forall a. Maybe a
Nothing)
Either QErr SingleOperation
queryPartsE <- ExceptT QErr (ExceptT () m) SingleOperation
-> ExceptT () m (Either QErr SingleOperation)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT QErr (ExceptT () m) SingleOperation
-> ExceptT () m (Either QErr SingleOperation))
-> ExceptT QErr (ExceptT () m) SingleOperation
-> ExceptT () m (Either QErr SingleOperation)
forall a b. (a -> b) -> a -> b
$ GQLReqParsed -> ExceptT QErr (ExceptT () m) SingleOperation
forall (m :: * -> *).
MonadError QErr m =>
GQLReqParsed -> m SingleOperation
getSingleOperation GQLReqParsed
reqParsed
SingleOperation
queryParts <- Either QErr SingleOperation
-> (QErr -> ExceptT () m SingleOperation)
-> ExceptT () m SingleOperation
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
onLeft Either QErr SingleOperation
queryPartsE (ExceptT () m () -> ExceptT () m SingleOperation
forall a. ExceptT () m () -> ExceptT () m a
withComplete (ExceptT () m () -> ExceptT () m SingleOperation)
-> (QErr -> ExceptT () m ())
-> QErr
-> ExceptT () m SingleOperation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestId -> Maybe OperationType -> QErr -> ExceptT () m ()
preExecErr RequestId
requestId Maybe OperationType
forall a. Maybe a
Nothing)
let gqlOpType :: OperationType
gqlOpType = SingleOperation -> OperationType
forall (frag :: * -> *) var.
TypedOperationDefinition frag var -> OperationType
G._todType SingleOperation
queryParts
maybeOperationName :: Maybe Name
maybeOperationName = OperationName -> Name
_unOperationName (OperationName -> Name) -> Maybe OperationName -> Maybe Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GQLReqParsed -> Maybe OperationName
forall a. GQLReq a -> Maybe OperationName
_grOperationName GQLReqParsed
reqParsed
Either QErr (ParameterizedQueryHash, ResolvedExecutionPlan)
execPlanE <-
ExceptT
QErr (ExceptT () m) (ParameterizedQueryHash, ResolvedExecutionPlan)
-> ExceptT
() m (Either QErr (ParameterizedQueryHash, ResolvedExecutionPlan))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
QErr (ExceptT () m) (ParameterizedQueryHash, ResolvedExecutionPlan)
-> ExceptT
() m (Either QErr (ParameterizedQueryHash, ResolvedExecutionPlan)))
-> ExceptT
QErr (ExceptT () m) (ParameterizedQueryHash, ResolvedExecutionPlan)
-> ExceptT
() m (Either QErr (ParameterizedQueryHash, ResolvedExecutionPlan))
forall a b. (a -> b) -> a -> b
$
Environment
-> Logger Hasura
-> UserInfo
-> SQLGenCtx
-> ReadOnlyMode
-> SchemaCache
-> SchemaCacheVer
-> GraphQLQueryType
-> Manager
-> [Header]
-> GQLReqUnparsed
-> SingleOperation
-> Maybe Name
-> RequestId
-> ExceptT
QErr (ExceptT () m) (ParameterizedQueryHash, ResolvedExecutionPlan)
forall (m :: * -> *).
(MonadError QErr m, MonadMetadataStorage (MetadataStorageT m),
MonadIO m, MonadBaseControl IO m, MonadTrace m,
MonadGQLExecutionCheck m, MonadQueryTags m) =>
Environment
-> Logger Hasura
-> UserInfo
-> SQLGenCtx
-> ReadOnlyMode
-> SchemaCache
-> SchemaCacheVer
-> GraphQLQueryType
-> Manager
-> [Header]
-> GQLReqUnparsed
-> SingleOperation
-> Maybe Name
-> RequestId
-> m (ParameterizedQueryHash, ResolvedExecutionPlan)
E.getResolvedExecPlan
Environment
env
Logger Hasura
logger
UserInfo
userInfo
SQLGenCtx
sqlGenCtx
ReadOnlyMode
readOnlyMode
SchemaCache
sc
SchemaCacheVer
scVer
GraphQLQueryType
queryType
Manager
httpMgr
[Header]
reqHdrs
GQLReqUnparsed
q
SingleOperation
queryParts
Maybe Name
maybeOperationName
RequestId
requestId
(ParameterizedQueryHash
parameterizedQueryHash, ResolvedExecutionPlan
execPlan) <- Either QErr (ParameterizedQueryHash, ResolvedExecutionPlan)
-> (QErr
-> ExceptT () m (ParameterizedQueryHash, ResolvedExecutionPlan))
-> ExceptT () m (ParameterizedQueryHash, ResolvedExecutionPlan)
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
onLeft Either QErr (ParameterizedQueryHash, ResolvedExecutionPlan)
execPlanE (ExceptT () m ()
-> ExceptT () m (ParameterizedQueryHash, ResolvedExecutionPlan)
forall a. ExceptT () m () -> ExceptT () m a
withComplete (ExceptT () m ()
-> ExceptT () m (ParameterizedQueryHash, ResolvedExecutionPlan))
-> (QErr -> ExceptT () m ())
-> QErr
-> ExceptT () m (ParameterizedQueryHash, ResolvedExecutionPlan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestId -> Maybe OperationType -> QErr -> ExceptT () m ()
preExecErr RequestId
requestId (OperationType -> Maybe OperationType
forall a. a -> Maybe a
Just OperationType
gqlOpType))
case ResolvedExecutionPlan
execPlan of
E.QueryExecutionPlan ExecutionPlan
queryPlan [QueryRootField UnpreparedValue]
asts DirectiveMap
dirMap -> Text -> ExceptT () m () -> ExceptT () m ()
forall (m :: * -> *) a. MonadTrace m => Text -> m a -> m a
Tracing.trace Text
"Query" (ExceptT () m () -> ExceptT () m ())
-> ExceptT () m () -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$ do
let filteredSessionVars :: SessionVariables
filteredSessionVars = SessVarPred -> SessionVariables -> SessionVariables
runSessVarPred ([QueryRootField UnpreparedValue] -> SessVarPred
forall d.
[RootField
(QueryDBRoot
(RemoteRelationshipField UnpreparedValue) UnpreparedValue)
(RemoteSchemaRootField
(RemoteRelationshipField UnpreparedValue) RemoteSchemaVariable)
(ActionQuery (RemoteRelationshipField UnpreparedValue))
d]
-> SessVarPred
filterVariablesFromQuery [QueryRootField UnpreparedValue]
asts) (UserInfo -> SessionVariables
_uiSession UserInfo
userInfo)
cacheKey :: QueryCacheKey
cacheKey = GQLReqParsed -> RoleName -> SessionVariables -> QueryCacheKey
QueryCacheKey GQLReqParsed
reqParsed (UserInfo -> RoleName
_uiRole UserInfo
userInfo) SessionVariables
filteredSessionVars
remoteSchemas :: [RemoteSchemaInfo]
remoteSchemas =
ExecutionPlan -> [ExecutionStep]
forall k v. InsOrdHashMap k v -> [v]
OMap.elems ExecutionPlan
queryPlan [ExecutionStep]
-> (ExecutionStep -> [RemoteSchemaInfo]) -> [RemoteSchemaInfo]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
E.ExecStepDB [Header]
_remoteHeaders AnyBackend DBStepInfo
_ Maybe RemoteJoins
remoteJoins ->
[RemoteSchemaInfo]
-> (RemoteJoins -> [RemoteSchemaInfo])
-> Maybe RemoteJoins
-> [RemoteSchemaInfo]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((RemoteSchemaJoin -> RemoteSchemaInfo)
-> [RemoteSchemaJoin] -> [RemoteSchemaInfo]
forall a b. (a -> b) -> [a] -> [b]
map RemoteSchemaJoin -> RemoteSchemaInfo
RJ._rsjRemoteSchema ([RemoteSchemaJoin] -> [RemoteSchemaInfo])
-> (RemoteJoins -> [RemoteSchemaJoin])
-> RemoteJoins
-> [RemoteSchemaInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteJoins -> [RemoteSchemaJoin]
RJ.getRemoteSchemaJoins) Maybe RemoteJoins
remoteJoins
ExecutionStep
_ -> []
actionsInfo :: [ActionsInfo]
actionsInfo =
([ActionsInfo] -> ExecutionStep -> [ActionsInfo])
-> [ActionsInfo] -> [ExecutionStep] -> [ActionsInfo]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [ActionsInfo] -> ExecutionStep -> [ActionsInfo]
getExecStepActionWithActionInfo [] ([ExecutionStep] -> [ActionsInfo])
-> [ExecutionStep] -> [ActionsInfo]
forall a b. (a -> b) -> a -> b
$
ExecutionPlan -> [ExecutionStep]
forall k v. InsOrdHashMap k v -> [v]
OMap.elems (ExecutionPlan -> [ExecutionStep])
-> ExecutionPlan -> [ExecutionStep]
forall a b. (a -> b) -> a -> b
$
(ExecutionStep -> Bool) -> ExecutionPlan -> ExecutionPlan
forall v k. (v -> Bool) -> InsOrdHashMap k v -> InsOrdHashMap k v
OMap.filter
( \case
E.ExecStepAction ActionExecutionPlan
_ ActionsInfo
_ Maybe RemoteJoins
_remoteJoins -> Bool
True
ExecutionStep
_ -> Bool
False
)
ExecutionPlan
queryPlan
cachedDirective :: Maybe CachedDirective
cachedDirective = Identity CachedDirective -> CachedDirective
forall a. Identity a -> a
runIdentity (Identity CachedDirective -> CachedDirective)
-> Maybe (Identity CachedDirective) -> Maybe CachedDirective
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DirectiveKey CachedDirective
-> DirectiveMap -> Maybe (Identity CachedDirective)
forall k1 (k2 :: k1 -> *) (f :: k1 -> *) (v :: k1).
GCompare k2 =>
k2 v -> DMap k2 f -> Maybe (f v)
DM.lookup DirectiveKey CachedDirective
cached DirectiveMap
dirMap
([Header]
_responseHeaders, Maybe EncJSON
cachedValue) <- (ExceptT QErr m (([Header], Maybe EncJSON), TracingMetadata)
-> ExceptT () m (([Header], Maybe EncJSON), TracingMetadata))
-> TraceT (ExceptT QErr m) ([Header], Maybe EncJSON)
-> ExceptT () m ([Header], Maybe EncJSON)
forall (n :: * -> *) (m :: * -> *) a b.
MonadTrace n =>
(m (a, TracingMetadata) -> n (b, TracingMetadata))
-> TraceT m a -> n b
Tracing.interpTraceT ((QErr -> ())
-> ExceptT QErr m (([Header], Maybe EncJSON), TracingMetadata)
-> ExceptT () m (([Header], Maybe EncJSON), TracingMetadata)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT QErr -> ()
forall a. Monoid a => a
mempty) (TraceT (ExceptT QErr m) ([Header], Maybe EncJSON)
-> ExceptT () m ([Header], Maybe EncJSON))
-> TraceT (ExceptT QErr m) ([Header], Maybe EncJSON)
-> ExceptT () m ([Header], Maybe EncJSON)
forall a b. (a -> b) -> a -> b
$ [RemoteSchemaInfo]
-> [ActionsInfo]
-> QueryCacheKey
-> Maybe CachedDirective
-> TraceT (ExceptT QErr m) ([Header], Maybe EncJSON)
forall (m :: * -> *).
MonadExecuteQuery m =>
[RemoteSchemaInfo]
-> [ActionsInfo]
-> QueryCacheKey
-> Maybe CachedDirective
-> TraceT (ExceptT QErr m) ([Header], Maybe EncJSON)
cacheLookup [RemoteSchemaInfo]
remoteSchemas [ActionsInfo]
actionsInfo QueryCacheKey
cacheKey Maybe CachedDirective
cachedDirective
case Maybe EncJSON
cachedValue of
Just EncJSON
cachedResponseData -> do
Logger Hasura -> QueryLog -> ExceptT () m ()
forall (m :: * -> *).
MonadQueryLog m =>
Logger Hasura -> QueryLog -> m ()
logQueryLog Logger Hasura
logger (QueryLog -> ExceptT () m ()) -> QueryLog -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$ GQLReqUnparsed
-> Maybe (RootFieldAlias, GeneratedQuery)
-> RequestId
-> QueryLogKind
-> QueryLog
QueryLog GQLReqUnparsed
q Maybe (RootFieldAlias, GeneratedQuery)
forall a. Maybe a
Nothing RequestId
requestId QueryLogKind
QueryLogKindCached
let reportedExecutionTime :: DiffTime
reportedExecutionTime = DiffTime
0
IO () -> ExceptT () m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT () m ()) -> IO () -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$ DiffTime -> OperationType -> IO ()
recordGQLQuerySuccess DiffTime
reportedExecutionTime OperationType
gqlOpType
EncJSON
-> Maybe OperationName
-> ParameterizedQueryHash
-> SubscriptionMetadata
-> ExceptT () m ()
sendSuccResp EncJSON
cachedResponseData Maybe OperationName
opName ParameterizedQueryHash
parameterizedQueryHash (SubscriptionMetadata -> ExceptT () m ())
-> SubscriptionMetadata -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$ DiffTime -> SubscriptionMetadata
ES.SubscriptionMetadata DiffTime
reportedExecutionTime
Maybe EncJSON
Nothing -> do
Either
(Either GQExecError QErr)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
conclusion <- ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
-> ExceptT
()
m
(Either
(Either GQExecError QErr)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
-> ExceptT
()
m
(Either
(Either GQExecError QErr)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)))
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
-> ExceptT
()
m
(Either
(Either GQExecError QErr)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart))
forall a b. (a -> b) -> a -> b
$
ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
forall a.
ExceptT (Either GQExecError QErr) (ExceptT () m) a
-> ExceptT (Either GQExecError QErr) (ExceptT () m) a
runLimits (ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart))
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
forall a b. (a -> b) -> a -> b
$
ExecutionPlan
-> (RootFieldAlias
-> ExecutionStep
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart)
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
forall k a b.
InsOrdHashMap k a
-> (k -> a -> ExceptT (Either GQExecError QErr) (ExceptT () m) b)
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) (InsOrdHashMap k b)
forWithKey ExecutionPlan
queryPlan ((RootFieldAlias
-> ExecutionStep
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart)
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart))
-> (RootFieldAlias
-> ExecutionStep
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart)
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
forall a b. (a -> b) -> a -> b
$ \RootFieldAlias
fieldName ->
let getResponse :: ExecutionStep
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart
getResponse = \case
E.ExecStepDB [Header]
_headers AnyBackend DBStepInfo
exists Maybe RemoteJoins
remoteJoins -> ExceptT QErr (ExceptT () m) AnnotatedResponsePart
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart
forall (n :: * -> *) a.
Monad n =>
ExceptT QErr n a -> ExceptT (Either GQExecError QErr) n a
doQErr (ExceptT QErr (ExceptT () m) AnnotatedResponsePart
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart)
-> ExceptT QErr (ExceptT () m) AnnotatedResponsePart
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart
forall a b. (a -> b) -> a -> b
$ do
(DiffTime
telemTimeIO_DT, EncJSON
resp) <-
AnyBackend DBStepInfo
-> (forall (b :: BackendType).
BackendTransport b =>
DBStepInfo b -> ExceptT QErr (ExceptT () m) (DiffTime, EncJSON))
-> ExceptT QErr (ExceptT () m) (DiffTime, EncJSON)
forall (c :: BackendType -> Constraint) (i :: BackendType -> *) r.
AllBackendsSatisfy c =>
AnyBackend i -> (forall (b :: BackendType). c b => i b -> r) -> r
AB.dispatchAnyBackend @BackendTransport
AnyBackend DBStepInfo
exists
\(EB.DBStepInfo SourceName
_ SourceConfig b
sourceConfig Maybe (PreparedQuery b)
genSql ExecutionMonad b EncJSON
tx :: EB.DBStepInfo b) ->
RequestId
-> GQLReqUnparsed
-> RootFieldAlias
-> UserInfo
-> Logger Hasura
-> SourceConfig b
-> ExecutionMonad b EncJSON
-> Maybe (PreparedQuery b)
-> ExceptT QErr (ExceptT () m) (DiffTime, EncJSON)
forall (b :: BackendType) (m :: * -> *).
(BackendTransport b, MonadIO m, MonadError QErr m, MonadQueryLog m,
MonadTrace m) =>
RequestId
-> GQLReqUnparsed
-> RootFieldAlias
-> UserInfo
-> Logger Hasura
-> SourceConfig b
-> ExecutionMonad b EncJSON
-> Maybe (PreparedQuery b)
-> m (DiffTime, EncJSON)
runDBQuery @b
RequestId
requestId
GQLReqUnparsed
q
RootFieldAlias
fieldName
UserInfo
userInfo
Logger Hasura
logger
SourceConfig b
sourceConfig
ExecutionMonad b EncJSON
tx
Maybe (PreparedQuery b)
genSql
EncJSON
finalResponse <-
RequestId
-> Logger Hasura
-> Environment
-> Manager
-> [Header]
-> UserInfo
-> EncJSON
-> Maybe RemoteJoins
-> GQLReqUnparsed
-> ExceptT QErr (ExceptT () m) EncJSON
forall (m :: * -> *).
(MonadError QErr m, MonadIO m, MonadQueryTags m, MonadQueryLog m,
MonadTrace m) =>
RequestId
-> Logger Hasura
-> Environment
-> Manager
-> [Header]
-> UserInfo
-> EncJSON
-> Maybe RemoteJoins
-> GQLReqUnparsed
-> m EncJSON
RJ.processRemoteJoins RequestId
requestId Logger Hasura
logger Environment
env Manager
httpMgr [Header]
reqHdrs UserInfo
userInfo EncJSON
resp Maybe RemoteJoins
remoteJoins GQLReqUnparsed
q
AnnotatedResponsePart
-> ExceptT QErr (ExceptT () m) AnnotatedResponsePart
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnnotatedResponsePart
-> ExceptT QErr (ExceptT () m) AnnotatedResponsePart)
-> AnnotatedResponsePart
-> ExceptT QErr (ExceptT () m) AnnotatedResponsePart
forall a b. (a -> b) -> a -> b
$ DiffTime
-> Locality -> EncJSON -> [Header] -> AnnotatedResponsePart
AnnotatedResponsePart DiffTime
telemTimeIO_DT Locality
Telem.Local EncJSON
finalResponse []
E.ExecStepRemote RemoteSchemaInfo
rsi ResultCustomizer
resultCustomizer GQLReqOutgoing
gqlReq Maybe RemoteJoins
remoteJoins -> do
Logger Hasura
-> QueryLog -> ExceptT (Either GQExecError QErr) (ExceptT () m) ()
forall (m :: * -> *).
MonadQueryLog m =>
Logger Hasura -> QueryLog -> m ()
logQueryLog Logger Hasura
logger (QueryLog -> ExceptT (Either GQExecError QErr) (ExceptT () m) ())
-> QueryLog -> ExceptT (Either GQExecError QErr) (ExceptT () m) ()
forall a b. (a -> b) -> a -> b
$ GQLReqUnparsed
-> Maybe (RootFieldAlias, GeneratedQuery)
-> RequestId
-> QueryLogKind
-> QueryLog
QueryLog GQLReqUnparsed
q Maybe (RootFieldAlias, GeneratedQuery)
forall a. Maybe a
Nothing RequestId
requestId QueryLogKind
QueryLogKindRemoteSchema
RequestId
-> GQLReqUnparsed
-> RootFieldAlias
-> UserInfo
-> [Header]
-> RemoteSchemaInfo
-> ResultCustomizer
-> GQLReqOutgoing
-> Maybe RemoteJoins
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart
runRemoteGQ RequestId
requestId GQLReqUnparsed
q RootFieldAlias
fieldName UserInfo
userInfo [Header]
reqHdrs RemoteSchemaInfo
rsi ResultCustomizer
resultCustomizer GQLReqOutgoing
gqlReq Maybe RemoteJoins
remoteJoins
E.ExecStepAction ActionExecutionPlan
actionExecPlan ActionsInfo
_ Maybe RemoteJoins
remoteJoins -> do
Logger Hasura
-> QueryLog -> ExceptT (Either GQExecError QErr) (ExceptT () m) ()
forall (m :: * -> *).
MonadQueryLog m =>
Logger Hasura -> QueryLog -> m ()
logQueryLog Logger Hasura
logger (QueryLog -> ExceptT (Either GQExecError QErr) (ExceptT () m) ())
-> QueryLog -> ExceptT (Either GQExecError QErr) (ExceptT () m) ()
forall a b. (a -> b) -> a -> b
$ GQLReqUnparsed
-> Maybe (RootFieldAlias, GeneratedQuery)
-> RequestId
-> QueryLogKind
-> QueryLog
QueryLog GQLReqUnparsed
q Maybe (RootFieldAlias, GeneratedQuery)
forall a. Maybe a
Nothing RequestId
requestId QueryLogKind
QueryLogKindAction
(DiffTime
time, (EncJSON
resp, Maybe [Header]
_)) <- ExceptT QErr (ExceptT () m) (DiffTime, (EncJSON, Maybe [Header]))
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(DiffTime, (EncJSON, Maybe [Header]))
forall (n :: * -> *) a.
Monad n =>
ExceptT QErr n a -> ExceptT (Either GQExecError QErr) n a
doQErr (ExceptT QErr (ExceptT () m) (DiffTime, (EncJSON, Maybe [Header]))
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(DiffTime, (EncJSON, Maybe [Header])))
-> ExceptT
QErr (ExceptT () m) (DiffTime, (EncJSON, Maybe [Header]))
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(DiffTime, (EncJSON, Maybe [Header]))
forall a b. (a -> b) -> a -> b
$ do
(DiffTime
time, (EncJSON
resp, Maybe [Header]
hdrs)) <- UserInfo
-> ActionExecutionPlan
-> ExceptT
QErr (ExceptT () m) (DiffTime, (EncJSON, Maybe [Header]))
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadError QErr m, MonadTrace m,
MonadMetadataStorage (MetadataStorageT m)) =>
UserInfo
-> ActionExecutionPlan -> m (DiffTime, (EncJSON, Maybe [Header]))
EA.runActionExecution UserInfo
userInfo ActionExecutionPlan
actionExecPlan
EncJSON
finalResponse <-
RequestId
-> Logger Hasura
-> Environment
-> Manager
-> [Header]
-> UserInfo
-> EncJSON
-> Maybe RemoteJoins
-> GQLReqUnparsed
-> ExceptT QErr (ExceptT () m) EncJSON
forall (m :: * -> *).
(MonadError QErr m, MonadIO m, MonadQueryTags m, MonadQueryLog m,
MonadTrace m) =>
RequestId
-> Logger Hasura
-> Environment
-> Manager
-> [Header]
-> UserInfo
-> EncJSON
-> Maybe RemoteJoins
-> GQLReqUnparsed
-> m EncJSON
RJ.processRemoteJoins RequestId
requestId Logger Hasura
logger Environment
env Manager
httpMgr [Header]
reqHdrs UserInfo
userInfo EncJSON
resp Maybe RemoteJoins
remoteJoins GQLReqUnparsed
q
(DiffTime, (EncJSON, Maybe [Header]))
-> ExceptT
QErr (ExceptT () m) (DiffTime, (EncJSON, Maybe [Header]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiffTime
time, (EncJSON
finalResponse, Maybe [Header]
hdrs))
AnnotatedResponsePart
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnnotatedResponsePart
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart)
-> AnnotatedResponsePart
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart
forall a b. (a -> b) -> a -> b
$ DiffTime
-> Locality -> EncJSON -> [Header] -> AnnotatedResponsePart
AnnotatedResponsePart DiffTime
time Locality
Telem.Empty EncJSON
resp []
E.ExecStepRaw Value
json -> do
Logger Hasura
-> QueryLog -> ExceptT (Either GQExecError QErr) (ExceptT () m) ()
forall (m :: * -> *).
MonadQueryLog m =>
Logger Hasura -> QueryLog -> m ()
logQueryLog Logger Hasura
logger (QueryLog -> ExceptT (Either GQExecError QErr) (ExceptT () m) ())
-> QueryLog -> ExceptT (Either GQExecError QErr) (ExceptT () m) ()
forall a b. (a -> b) -> a -> b
$ GQLReqUnparsed
-> Maybe (RootFieldAlias, GeneratedQuery)
-> RequestId
-> QueryLogKind
-> QueryLog
QueryLog GQLReqUnparsed
q Maybe (RootFieldAlias, GeneratedQuery)
forall a. Maybe a
Nothing RequestId
requestId QueryLogKind
QueryLogKindIntrospection
Value
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart
forall (m :: * -> *).
Applicative m =>
Value -> m AnnotatedResponsePart
buildRaw Value
json
E.ExecStepMulti [ExecutionStep]
lst -> do
[AnnotatedResponsePart]
allResponses <- (ExecutionStep
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart)
-> [ExecutionStep]
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) [AnnotatedResponsePart]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ExecutionStep
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart
getResponse [ExecutionStep]
lst
AnnotatedResponsePart
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnnotatedResponsePart
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart)
-> AnnotatedResponsePart
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart
forall a b. (a -> b) -> a -> b
$ DiffTime
-> Locality -> EncJSON -> [Header] -> AnnotatedResponsePart
AnnotatedResponsePart DiffTime
0 Locality
Telem.Local ([EncJSON] -> EncJSON
encJFromList ((AnnotatedResponsePart -> EncJSON)
-> [AnnotatedResponsePart] -> [EncJSON]
forall a b. (a -> b) -> [a] -> [b]
map AnnotatedResponsePart -> EncJSON
arpResponse [AnnotatedResponsePart]
allResponses)) []
in ExecutionStep
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart
getResponse
QueryType
-> ExceptT () m DiffTime
-> RequestId
-> Either
(Either GQExecError QErr)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
-> Maybe OperationName
-> ParameterizedQueryHash
-> OperationType
-> ExceptT () m ()
sendResultFromFragments QueryType
Telem.Query ExceptT () m DiffTime
timerTot RequestId
requestId Either
(Either GQExecError QErr)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
conclusion Maybe OperationName
opName ParameterizedQueryHash
parameterizedQueryHash OperationType
gqlOpType
case Either
(Either GQExecError QErr)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
conclusion of
Left Either GQExecError QErr
_ -> () -> ExceptT () m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Right InsOrdHashMap RootFieldAlias AnnotatedResponsePart
results ->
ExceptT () m CacheStoreResponse -> ExceptT () m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT () m CacheStoreResponse -> ExceptT () m ())
-> ExceptT () m CacheStoreResponse -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$
(ExceptT QErr m (CacheStoreResponse, TracingMetadata)
-> ExceptT () m (CacheStoreResponse, TracingMetadata))
-> TraceT (ExceptT QErr m) CacheStoreResponse
-> ExceptT () m CacheStoreResponse
forall (n :: * -> *) (m :: * -> *) a b.
MonadTrace n =>
(m (a, TracingMetadata) -> n (b, TracingMetadata))
-> TraceT m a -> n b
Tracing.interpTraceT ((QErr -> ())
-> ExceptT QErr m (CacheStoreResponse, TracingMetadata)
-> ExceptT () m (CacheStoreResponse, TracingMetadata)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT QErr -> ()
forall a. Monoid a => a
mempty) (TraceT (ExceptT QErr m) CacheStoreResponse
-> ExceptT () m CacheStoreResponse)
-> TraceT (ExceptT QErr m) CacheStoreResponse
-> ExceptT () m CacheStoreResponse
forall a b. (a -> b) -> a -> b
$
QueryCacheKey
-> Maybe CachedDirective
-> EncJSON
-> TraceT (ExceptT QErr m) CacheStoreResponse
forall (m :: * -> *).
MonadExecuteQuery m =>
QueryCacheKey
-> Maybe CachedDirective
-> EncJSON
-> TraceT (ExceptT QErr m) CacheStoreResponse
cacheStore QueryCacheKey
cacheKey Maybe CachedDirective
cachedDirective (EncJSON -> TraceT (ExceptT QErr m) CacheStoreResponse)
-> EncJSON -> TraceT (ExceptT QErr m) CacheStoreResponse
forall a b. (a -> b) -> a -> b
$ InsOrdHashMap RootFieldAlias AnnotatedResponsePart -> EncJSON
encodeAnnotatedResponseParts InsOrdHashMap RootFieldAlias AnnotatedResponsePart
results
IO () -> ExceptT () m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT () m ()) -> IO () -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$ Maybe RequestId -> Maybe ParameterizedQueryHash -> IO ()
sendCompleted (RequestId -> Maybe RequestId
forall a. a -> Maybe a
Just RequestId
requestId) (ParameterizedQueryHash -> Maybe ParameterizedQueryHash
forall a. a -> Maybe a
Just ParameterizedQueryHash
parameterizedQueryHash)
E.MutationExecutionPlan ExecutionPlan
mutationPlan -> do
case ExecutionPlan
-> Maybe
(SourceConfig ('Postgres 'Vanilla),
InsOrdHashMap RootFieldAlias (DBStepInfo ('Postgres 'Vanilla)))
coalescePostgresMutations ExecutionPlan
mutationPlan of
Just (SourceConfig ('Postgres 'Vanilla)
sourceConfig, InsOrdHashMap RootFieldAlias (DBStepInfo ('Postgres 'Vanilla))
pgMutations) -> do
Either (Either GQExecError QErr) (DiffTime, RootFieldMap EncJSON)
resp <-
ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(DiffTime, RootFieldMap EncJSON)
-> ExceptT
()
m
(Either (Either GQExecError QErr) (DiffTime, RootFieldMap EncJSON))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(DiffTime, RootFieldMap EncJSON)
-> ExceptT
()
m
(Either
(Either GQExecError QErr) (DiffTime, RootFieldMap EncJSON)))
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(DiffTime, RootFieldMap EncJSON)
-> ExceptT
()
m
(Either (Either GQExecError QErr) (DiffTime, RootFieldMap EncJSON))
forall a b. (a -> b) -> a -> b
$
ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(DiffTime, RootFieldMap EncJSON)
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(DiffTime, RootFieldMap EncJSON)
forall a.
ExceptT (Either GQExecError QErr) (ExceptT () m) a
-> ExceptT (Either GQExecError QErr) (ExceptT () m) a
runLimits (ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(DiffTime, RootFieldMap EncJSON)
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(DiffTime, RootFieldMap EncJSON))
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(DiffTime, RootFieldMap EncJSON)
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(DiffTime, RootFieldMap EncJSON)
forall a b. (a -> b) -> a -> b
$
ExceptT QErr (ExceptT () m) (DiffTime, RootFieldMap EncJSON)
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(DiffTime, RootFieldMap EncJSON)
forall (n :: * -> *) a.
Monad n =>
ExceptT QErr n a -> ExceptT (Either GQExecError QErr) n a
doQErr (ExceptT QErr (ExceptT () m) (DiffTime, RootFieldMap EncJSON)
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(DiffTime, RootFieldMap EncJSON))
-> ExceptT QErr (ExceptT () m) (DiffTime, RootFieldMap EncJSON)
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(DiffTime, RootFieldMap EncJSON)
forall a b. (a -> b) -> a -> b
$
RequestId
-> GQLReqUnparsed
-> UserInfo
-> Logger Hasura
-> SourceConfig ('Postgres 'Vanilla)
-> InsOrdHashMap RootFieldAlias (DBStepInfo ('Postgres 'Vanilla))
-> ExceptT QErr (ExceptT () m) (DiffTime, RootFieldMap EncJSON)
forall (m :: * -> *) (pgKind :: PostgresKind).
(MonadIO m, MonadError QErr m, MonadQueryLog m, MonadTrace m) =>
RequestId
-> GQLReqUnparsed
-> UserInfo
-> Logger Hasura
-> SourceConfig ('Postgres pgKind)
-> RootFieldMap (DBStepInfo ('Postgres pgKind))
-> m (DiffTime, RootFieldMap EncJSON)
runPGMutationTransaction RequestId
requestId GQLReqUnparsed
q UserInfo
userInfo Logger Hasura
logger SourceConfig ('Postgres 'Vanilla)
sourceConfig InsOrdHashMap RootFieldAlias (DBStepInfo ('Postgres 'Vanilla))
pgMutations
RequestId
-> OperationType
-> Either
(Either GQExecError QErr) (DiffTime, RootFieldMap EncJSON)
-> ((DiffTime, RootFieldMap EncJSON) -> ExceptT () m ())
-> ExceptT () m ()
forall a.
RequestId
-> OperationType
-> Either (Either GQExecError QErr) a
-> (a -> ExceptT () m ())
-> ExceptT () m ()
handleResult RequestId
requestId OperationType
gqlOpType Either (Either GQExecError QErr) (DiffTime, RootFieldMap EncJSON)
resp \(DiffTime
telemTimeIO_DT, RootFieldMap EncJSON
results) -> do
let telemQueryType :: QueryType
telemQueryType = QueryType
Telem.Query
telemLocality :: Locality
telemLocality = Locality
Telem.Local
telemTimeIO :: Seconds
telemTimeIO = DiffTime -> Seconds
forall x y. (Duration x, Duration y) => x -> y
convertDuration DiffTime
telemTimeIO_DT
DiffTime
totalTime <- ExceptT () m DiffTime
timerTot
let telemTimeTot :: Seconds
telemTimeTot = DiffTime -> Seconds
Seconds DiffTime
totalTime
EncJSON
-> Maybe OperationName
-> ParameterizedQueryHash
-> SubscriptionMetadata
-> ExceptT () m ()
sendSuccResp (RootFieldMap EncJSON -> EncJSON
encodeEncJSONResults RootFieldMap EncJSON
results) Maybe OperationName
opName ParameterizedQueryHash
parameterizedQueryHash (SubscriptionMetadata -> ExceptT () m ())
-> SubscriptionMetadata -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$
DiffTime -> SubscriptionMetadata
ES.SubscriptionMetadata DiffTime
telemTimeIO_DT
RequestDimensions -> RequestTimings -> ExceptT () m ()
forall (m :: * -> *).
MonadIO m =>
RequestDimensions -> RequestTimings -> m ()
Telem.recordTimingMetric RequestDimensions :: QueryType -> Locality -> Transport -> RequestDimensions
Telem.RequestDimensions {Transport
Locality
QueryType
$sel:telemTransport:RequestDimensions :: Transport
$sel:telemLocality:RequestDimensions :: Locality
$sel:telemQueryType:RequestDimensions :: QueryType
telemTransport :: Transport
telemLocality :: Locality
telemQueryType :: QueryType
..} RequestTimings :: Seconds -> Seconds -> RequestTimings
Telem.RequestTimings {Seconds
$sel:telemTimeTot:RequestTimings :: Seconds
$sel:telemTimeIO:RequestTimings :: Seconds
telemTimeTot :: Seconds
telemTimeIO :: Seconds
..}
IO () -> ExceptT () m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT () m ()) -> IO () -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$ DiffTime -> OperationType -> IO ()
recordGQLQuerySuccess DiffTime
totalTime OperationType
gqlOpType
Maybe
(SourceConfig ('Postgres 'Vanilla),
InsOrdHashMap RootFieldAlias (DBStepInfo ('Postgres 'Vanilla)))
Nothing -> do
Either
(Either GQExecError QErr)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
conclusion <- ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
-> ExceptT
()
m
(Either
(Either GQExecError QErr)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
-> ExceptT
()
m
(Either
(Either GQExecError QErr)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)))
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
-> ExceptT
()
m
(Either
(Either GQExecError QErr)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart))
forall a b. (a -> b) -> a -> b
$
ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
forall a.
ExceptT (Either GQExecError QErr) (ExceptT () m) a
-> ExceptT (Either GQExecError QErr) (ExceptT () m) a
runLimits (ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart))
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
forall a b. (a -> b) -> a -> b
$
ExecutionPlan
-> (RootFieldAlias
-> ExecutionStep
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart)
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
forall k a b.
InsOrdHashMap k a
-> (k -> a -> ExceptT (Either GQExecError QErr) (ExceptT () m) b)
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) (InsOrdHashMap k b)
forWithKey ExecutionPlan
mutationPlan ((RootFieldAlias
-> ExecutionStep
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart)
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart))
-> (RootFieldAlias
-> ExecutionStep
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart)
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
forall a b. (a -> b) -> a -> b
$ \RootFieldAlias
fieldName ->
let getResponse :: ExecutionStep
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart
getResponse = \case
E.ExecStepDB [Header]
_responseHeaders AnyBackend DBStepInfo
exists Maybe RemoteJoins
remoteJoins -> ExceptT QErr (ExceptT () m) AnnotatedResponsePart
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart
forall (n :: * -> *) a.
Monad n =>
ExceptT QErr n a -> ExceptT (Either GQExecError QErr) n a
doQErr (ExceptT QErr (ExceptT () m) AnnotatedResponsePart
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart)
-> ExceptT QErr (ExceptT () m) AnnotatedResponsePart
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart
forall a b. (a -> b) -> a -> b
$ do
(DiffTime
telemTimeIO_DT, EncJSON
resp) <-
AnyBackend DBStepInfo
-> (forall (b :: BackendType).
BackendTransport b =>
DBStepInfo b -> ExceptT QErr (ExceptT () m) (DiffTime, EncJSON))
-> ExceptT QErr (ExceptT () m) (DiffTime, EncJSON)
forall (c :: BackendType -> Constraint) (i :: BackendType -> *) r.
AllBackendsSatisfy c =>
AnyBackend i -> (forall (b :: BackendType). c b => i b -> r) -> r
AB.dispatchAnyBackend @BackendTransport
AnyBackend DBStepInfo
exists
\(EB.DBStepInfo SourceName
_ SourceConfig b
sourceConfig Maybe (PreparedQuery b)
genSql ExecutionMonad b EncJSON
tx :: EB.DBStepInfo b) ->
RequestId
-> GQLReqUnparsed
-> RootFieldAlias
-> UserInfo
-> Logger Hasura
-> SourceConfig b
-> ExecutionMonad b EncJSON
-> Maybe (PreparedQuery b)
-> ExceptT QErr (ExceptT () m) (DiffTime, EncJSON)
forall (b :: BackendType) (m :: * -> *).
(BackendTransport b, MonadIO m, MonadError QErr m, MonadQueryLog m,
MonadTrace m) =>
RequestId
-> GQLReqUnparsed
-> RootFieldAlias
-> UserInfo
-> Logger Hasura
-> SourceConfig b
-> ExecutionMonad b EncJSON
-> Maybe (PreparedQuery b)
-> m (DiffTime, EncJSON)
runDBMutation @b
RequestId
requestId
GQLReqUnparsed
q
RootFieldAlias
fieldName
UserInfo
userInfo
Logger Hasura
logger
SourceConfig b
sourceConfig
ExecutionMonad b EncJSON
tx
Maybe (PreparedQuery b)
genSql
EncJSON
finalResponse <-
RequestId
-> Logger Hasura
-> Environment
-> Manager
-> [Header]
-> UserInfo
-> EncJSON
-> Maybe RemoteJoins
-> GQLReqUnparsed
-> ExceptT QErr (ExceptT () m) EncJSON
forall (m :: * -> *).
(MonadError QErr m, MonadIO m, MonadQueryTags m, MonadQueryLog m,
MonadTrace m) =>
RequestId
-> Logger Hasura
-> Environment
-> Manager
-> [Header]
-> UserInfo
-> EncJSON
-> Maybe RemoteJoins
-> GQLReqUnparsed
-> m EncJSON
RJ.processRemoteJoins RequestId
requestId Logger Hasura
logger Environment
env Manager
httpMgr [Header]
reqHdrs UserInfo
userInfo EncJSON
resp Maybe RemoteJoins
remoteJoins GQLReqUnparsed
q
AnnotatedResponsePart
-> ExceptT QErr (ExceptT () m) AnnotatedResponsePart
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnnotatedResponsePart
-> ExceptT QErr (ExceptT () m) AnnotatedResponsePart)
-> AnnotatedResponsePart
-> ExceptT QErr (ExceptT () m) AnnotatedResponsePart
forall a b. (a -> b) -> a -> b
$ DiffTime
-> Locality -> EncJSON -> [Header] -> AnnotatedResponsePart
AnnotatedResponsePart DiffTime
telemTimeIO_DT Locality
Telem.Local EncJSON
finalResponse []
E.ExecStepAction ActionExecutionPlan
actionExecPlan ActionsInfo
_ Maybe RemoteJoins
remoteJoins -> do
Logger Hasura
-> QueryLog -> ExceptT (Either GQExecError QErr) (ExceptT () m) ()
forall (m :: * -> *).
MonadQueryLog m =>
Logger Hasura -> QueryLog -> m ()
logQueryLog Logger Hasura
logger (QueryLog -> ExceptT (Either GQExecError QErr) (ExceptT () m) ())
-> QueryLog -> ExceptT (Either GQExecError QErr) (ExceptT () m) ()
forall a b. (a -> b) -> a -> b
$ GQLReqUnparsed
-> Maybe (RootFieldAlias, GeneratedQuery)
-> RequestId
-> QueryLogKind
-> QueryLog
QueryLog GQLReqUnparsed
q Maybe (RootFieldAlias, GeneratedQuery)
forall a. Maybe a
Nothing RequestId
requestId QueryLogKind
QueryLogKindAction
(DiffTime
time, (EncJSON
resp, Maybe [Header]
hdrs)) <- ExceptT QErr (ExceptT () m) (DiffTime, (EncJSON, Maybe [Header]))
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(DiffTime, (EncJSON, Maybe [Header]))
forall (n :: * -> *) a.
Monad n =>
ExceptT QErr n a -> ExceptT (Either GQExecError QErr) n a
doQErr (ExceptT QErr (ExceptT () m) (DiffTime, (EncJSON, Maybe [Header]))
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(DiffTime, (EncJSON, Maybe [Header])))
-> ExceptT
QErr (ExceptT () m) (DiffTime, (EncJSON, Maybe [Header]))
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(DiffTime, (EncJSON, Maybe [Header]))
forall a b. (a -> b) -> a -> b
$ do
(DiffTime
time, (EncJSON
resp, Maybe [Header]
hdrs)) <- UserInfo
-> ActionExecutionPlan
-> ExceptT
QErr (ExceptT () m) (DiffTime, (EncJSON, Maybe [Header]))
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadError QErr m, MonadTrace m,
MonadMetadataStorage (MetadataStorageT m)) =>
UserInfo
-> ActionExecutionPlan -> m (DiffTime, (EncJSON, Maybe [Header]))
EA.runActionExecution UserInfo
userInfo ActionExecutionPlan
actionExecPlan
EncJSON
finalResponse <-
RequestId
-> Logger Hasura
-> Environment
-> Manager
-> [Header]
-> UserInfo
-> EncJSON
-> Maybe RemoteJoins
-> GQLReqUnparsed
-> ExceptT QErr (ExceptT () m) EncJSON
forall (m :: * -> *).
(MonadError QErr m, MonadIO m, MonadQueryTags m, MonadQueryLog m,
MonadTrace m) =>
RequestId
-> Logger Hasura
-> Environment
-> Manager
-> [Header]
-> UserInfo
-> EncJSON
-> Maybe RemoteJoins
-> GQLReqUnparsed
-> m EncJSON
RJ.processRemoteJoins RequestId
requestId Logger Hasura
logger Environment
env Manager
httpMgr [Header]
reqHdrs UserInfo
userInfo EncJSON
resp Maybe RemoteJoins
remoteJoins GQLReqUnparsed
q
(DiffTime, (EncJSON, Maybe [Header]))
-> ExceptT
QErr (ExceptT () m) (DiffTime, (EncJSON, Maybe [Header]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiffTime
time, (EncJSON
finalResponse, Maybe [Header]
hdrs))
AnnotatedResponsePart
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnnotatedResponsePart
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart)
-> AnnotatedResponsePart
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart
forall a b. (a -> b) -> a -> b
$ DiffTime
-> Locality -> EncJSON -> [Header] -> AnnotatedResponsePart
AnnotatedResponsePart DiffTime
time Locality
Telem.Empty EncJSON
resp ([Header] -> AnnotatedResponsePart)
-> [Header] -> AnnotatedResponsePart
forall a b. (a -> b) -> a -> b
$ [Header] -> Maybe [Header] -> [Header]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [Header]
hdrs
E.ExecStepRemote RemoteSchemaInfo
rsi ResultCustomizer
resultCustomizer GQLReqOutgoing
gqlReq Maybe RemoteJoins
remoteJoins -> do
Logger Hasura
-> QueryLog -> ExceptT (Either GQExecError QErr) (ExceptT () m) ()
forall (m :: * -> *).
MonadQueryLog m =>
Logger Hasura -> QueryLog -> m ()
logQueryLog Logger Hasura
logger (QueryLog -> ExceptT (Either GQExecError QErr) (ExceptT () m) ())
-> QueryLog -> ExceptT (Either GQExecError QErr) (ExceptT () m) ()
forall a b. (a -> b) -> a -> b
$ GQLReqUnparsed
-> Maybe (RootFieldAlias, GeneratedQuery)
-> RequestId
-> QueryLogKind
-> QueryLog
QueryLog GQLReqUnparsed
q Maybe (RootFieldAlias, GeneratedQuery)
forall a. Maybe a
Nothing RequestId
requestId QueryLogKind
QueryLogKindRemoteSchema
RequestId
-> GQLReqUnparsed
-> RootFieldAlias
-> UserInfo
-> [Header]
-> RemoteSchemaInfo
-> ResultCustomizer
-> GQLReqOutgoing
-> Maybe RemoteJoins
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart
runRemoteGQ RequestId
requestId GQLReqUnparsed
q RootFieldAlias
fieldName UserInfo
userInfo [Header]
reqHdrs RemoteSchemaInfo
rsi ResultCustomizer
resultCustomizer GQLReqOutgoing
gqlReq Maybe RemoteJoins
remoteJoins
E.ExecStepRaw Value
json -> do
Logger Hasura
-> QueryLog -> ExceptT (Either GQExecError QErr) (ExceptT () m) ()
forall (m :: * -> *).
MonadQueryLog m =>
Logger Hasura -> QueryLog -> m ()
logQueryLog Logger Hasura
logger (QueryLog -> ExceptT (Either GQExecError QErr) (ExceptT () m) ())
-> QueryLog -> ExceptT (Either GQExecError QErr) (ExceptT () m) ()
forall a b. (a -> b) -> a -> b
$ GQLReqUnparsed
-> Maybe (RootFieldAlias, GeneratedQuery)
-> RequestId
-> QueryLogKind
-> QueryLog
QueryLog GQLReqUnparsed
q Maybe (RootFieldAlias, GeneratedQuery)
forall a. Maybe a
Nothing RequestId
requestId QueryLogKind
QueryLogKindIntrospection
Value
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart
forall (m :: * -> *).
Applicative m =>
Value -> m AnnotatedResponsePart
buildRaw Value
json
E.ExecStepMulti [ExecutionStep]
lst -> do
[AnnotatedResponsePart]
allResponses <- (ExecutionStep
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart)
-> [ExecutionStep]
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) [AnnotatedResponsePart]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ExecutionStep
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart
getResponse [ExecutionStep]
lst
AnnotatedResponsePart
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnnotatedResponsePart
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart)
-> AnnotatedResponsePart
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart
forall a b. (a -> b) -> a -> b
$ DiffTime
-> Locality -> EncJSON -> [Header] -> AnnotatedResponsePart
AnnotatedResponsePart DiffTime
0 Locality
Telem.Local ([EncJSON] -> EncJSON
encJFromList ((AnnotatedResponsePart -> EncJSON)
-> [AnnotatedResponsePart] -> [EncJSON]
forall a b. (a -> b) -> [a] -> [b]
map AnnotatedResponsePart -> EncJSON
arpResponse [AnnotatedResponsePart]
allResponses)) []
in ExecutionStep
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart
getResponse
QueryType
-> ExceptT () m DiffTime
-> RequestId
-> Either
(Either GQExecError QErr)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
-> Maybe OperationName
-> ParameterizedQueryHash
-> OperationType
-> ExceptT () m ()
sendResultFromFragments QueryType
Telem.Query ExceptT () m DiffTime
timerTot RequestId
requestId Either
(Either GQExecError QErr)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
conclusion Maybe OperationName
opName ParameterizedQueryHash
parameterizedQueryHash OperationType
gqlOpType
IO () -> ExceptT () m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT () m ()) -> IO () -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$ Maybe RequestId -> Maybe ParameterizedQueryHash -> IO ()
sendCompleted (RequestId -> Maybe RequestId
forall a. a -> Maybe a
Just RequestId
requestId) (ParameterizedQueryHash -> Maybe ParameterizedQueryHash
forall a. a -> Maybe a
Just ParameterizedQueryHash
parameterizedQueryHash)
E.SubscriptionExecutionPlan SubscriptionExecution
subExec -> do
case SubscriptionExecution
subExec of
E.SEAsyncActionsWithNoRelationships RootFieldMap (ActionId, ActionLogResponse -> Either QErr EncJSON)
actions -> do
Logger Hasura -> QueryLog -> ExceptT () m ()
forall (m :: * -> *).
MonadQueryLog m =>
Logger Hasura -> QueryLog -> m ()
logQueryLog Logger Hasura
logger (QueryLog -> ExceptT () m ()) -> QueryLog -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$ GQLReqUnparsed
-> Maybe (RootFieldAlias, GeneratedQuery)
-> RequestId
-> QueryLogKind
-> QueryLog
QueryLog GQLReqUnparsed
q Maybe (RootFieldAlias, GeneratedQuery)
forall a. Maybe a
Nothing RequestId
requestId QueryLogKind
QueryLogKindAction
IO () -> ExceptT () m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
let allActionIds :: [ActionId]
allActionIds = ((ActionId, ActionLogResponse -> Either QErr EncJSON) -> ActionId)
-> [(ActionId, ActionLogResponse -> Either QErr EncJSON)]
-> [ActionId]
forall a b. (a -> b) -> [a] -> [b]
map (ActionId, ActionLogResponse -> Either QErr EncJSON) -> ActionId
forall a b. (a, b) -> a
fst ([(ActionId, ActionLogResponse -> Either QErr EncJSON)]
-> [ActionId])
-> [(ActionId, ActionLogResponse -> Either QErr EncJSON)]
-> [ActionId]
forall a b. (a -> b) -> a -> b
$ RootFieldMap (ActionId, ActionLogResponse -> Either QErr EncJSON)
-> [(ActionId, ActionLogResponse -> Either QErr EncJSON)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList RootFieldMap (ActionId, ActionLogResponse -> Either QErr EncJSON)
actions
case [ActionId] -> Maybe (NonEmpty ActionId)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [ActionId]
allActionIds of
Maybe (NonEmpty ActionId)
Nothing -> Maybe RequestId -> Maybe ParameterizedQueryHash -> IO ()
sendCompleted (RequestId -> Maybe RequestId
forall a. a -> Maybe a
Just RequestId
requestId) (ParameterizedQueryHash -> Maybe ParameterizedQueryHash
forall a. a -> Maybe a
Just ParameterizedQueryHash
parameterizedQueryHash)
Just NonEmpty ActionId
actionIds -> do
let sendResponseIO :: HashMap ActionId ActionLogResponse -> IO ()
sendResponseIO HashMap ActionId ActionLogResponse
actionLogMap = do
(DiffTime
dTime, Either QErr (RootFieldMap EncJSON)
resultsE) <- IO (Either QErr (RootFieldMap EncJSON))
-> IO (DiffTime, Either QErr (RootFieldMap EncJSON))
forall (m :: * -> *) a. MonadIO m => m a -> m (DiffTime, a)
withElapsedTime (IO (Either QErr (RootFieldMap EncJSON))
-> IO (DiffTime, Either QErr (RootFieldMap EncJSON)))
-> IO (Either QErr (RootFieldMap EncJSON))
-> IO (DiffTime, Either QErr (RootFieldMap EncJSON))
forall a b. (a -> b) -> a -> b
$
ExceptT QErr IO (RootFieldMap EncJSON)
-> IO (Either QErr (RootFieldMap EncJSON))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT QErr IO (RootFieldMap EncJSON)
-> IO (Either QErr (RootFieldMap EncJSON)))
-> ExceptT QErr IO (RootFieldMap EncJSON)
-> IO (Either QErr (RootFieldMap EncJSON))
forall a b. (a -> b) -> a -> b
$
RootFieldMap (ActionId, ActionLogResponse -> Either QErr EncJSON)
-> ((ActionId, ActionLogResponse -> Either QErr EncJSON)
-> ExceptT QErr IO EncJSON)
-> ExceptT QErr IO (RootFieldMap EncJSON)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for RootFieldMap (ActionId, ActionLogResponse -> Either QErr EncJSON)
actions (((ActionId, ActionLogResponse -> Either QErr EncJSON)
-> ExceptT QErr IO EncJSON)
-> ExceptT QErr IO (RootFieldMap EncJSON))
-> ((ActionId, ActionLogResponse -> Either QErr EncJSON)
-> ExceptT QErr IO EncJSON)
-> ExceptT QErr IO (RootFieldMap EncJSON)
forall a b. (a -> b) -> a -> b
$ \(ActionId
actionId, ActionLogResponse -> Either QErr EncJSON
resultBuilder) -> do
ActionLogResponse
actionLogResponse <-
ActionId
-> HashMap ActionId ActionLogResponse -> Maybe ActionLogResponse
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup ActionId
actionId HashMap ActionId ActionLogResponse
actionLogMap
Maybe ActionLogResponse
-> ExceptT QErr IO ActionLogResponse
-> ExceptT QErr IO ActionLogResponse
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
`onNothing` Text -> ExceptT QErr IO ActionLogResponse
forall (m :: * -> *) a. QErrM m => Text -> m a
throw500 Text
"unexpected: cannot lookup action_id in response map"
Either QErr EncJSON -> ExceptT QErr IO EncJSON
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either QErr EncJSON -> ExceptT QErr IO EncJSON)
-> Either QErr EncJSON -> ExceptT QErr IO EncJSON
forall a b. (a -> b) -> a -> b
$ ActionLogResponse -> Either QErr EncJSON
resultBuilder ActionLogResponse
actionLogResponse
case Either QErr (RootFieldMap EncJSON)
resultsE of
Left QErr
err -> RequestId -> QErr -> IO ()
sendError RequestId
requestId QErr
err
Right RootFieldMap EncJSON
results -> do
let dataMsg :: ServerMsg
dataMsg =
DataMsg -> ServerMsg
sendDataMsg (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
$
ByteString -> GQResponse
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> GQResponse) -> ByteString -> GQResponse
forall a b. (a -> b) -> a -> b
$
EncJSON -> ByteString
encJToLBS (EncJSON -> ByteString) -> EncJSON -> ByteString
forall a b. (a -> b) -> a -> b
$
RootFieldMap EncJSON -> EncJSON
encodeEncJSONResults RootFieldMap EncJSON
results
WSConn
-> ServerMsg
-> Maybe OperationName
-> Maybe ParameterizedQueryHash
-> SubscriptionMetadata
-> IO ()
forall (m :: * -> *).
MonadIO m =>
WSConn
-> ServerMsg
-> Maybe OperationName
-> Maybe ParameterizedQueryHash
-> SubscriptionMetadata
-> m ()
sendMsgWithMetadata WSConn
wsConn ServerMsg
dataMsg Maybe OperationName
opName (ParameterizedQueryHash -> Maybe ParameterizedQueryHash
forall a. a -> Maybe a
Just ParameterizedQueryHash
parameterizedQueryHash) (SubscriptionMetadata -> IO ()) -> SubscriptionMetadata -> IO ()
forall a b. (a -> b) -> a -> b
$ DiffTime -> SubscriptionMetadata
ES.SubscriptionMetadata DiffTime
dTime
asyncActionQueryLive :: LiveAsyncActionQuery
asyncActionQueryLive =
LiveAsyncActionQueryWithNoRelationships -> LiveAsyncActionQuery
ES.LAAQNoRelationships (LiveAsyncActionQueryWithNoRelationships -> LiveAsyncActionQuery)
-> LiveAsyncActionQueryWithNoRelationships -> LiveAsyncActionQuery
forall a b. (a -> b) -> a -> b
$
(HashMap ActionId ActionLogResponse -> IO ())
-> IO () -> LiveAsyncActionQueryWithNoRelationships
ES.LiveAsyncActionQueryWithNoRelationships HashMap ActionId ActionLogResponse -> IO ()
sendResponseIO (Maybe RequestId -> Maybe ParameterizedQueryHash -> IO ()
sendCompleted (RequestId -> Maybe RequestId
forall a. a -> Maybe a
Just RequestId
requestId) (ParameterizedQueryHash -> Maybe ParameterizedQueryHash
forall a. a -> Maybe a
Just ParameterizedQueryHash
parameterizedQueryHash))
AsyncActionSubscriptionState
-> OperationId
-> NonEmpty ActionId
-> (QErr -> IO ())
-> LiveAsyncActionQuery
-> IO ()
ES.addAsyncActionLiveQuery
(SubscriptionsState -> AsyncActionSubscriptionState
ES._ssAsyncActions SubscriptionsState
subscriptionsState)
OperationId
opId
NonEmpty ActionId
actionIds
(RequestId -> QErr -> IO ()
sendError RequestId
requestId)
LiveAsyncActionQuery
asyncActionQueryLive
E.SEOnSourceDB (E.SSLivequery HashSet ActionId
actionIds HashMap ActionId ActionLogResponse
-> ExceptT QErr IO (SourceName, SubscriptionQueryPlan)
liveQueryBuilder) -> do
Either QErr (HashMap ActionId ActionLogResponse)
actionLogMapE <- ((HashMap ActionId ActionLogResponse, Bool)
-> HashMap ActionId ActionLogResponse)
-> Either QErr (HashMap ActionId ActionLogResponse, Bool)
-> Either QErr (HashMap ActionId ActionLogResponse)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HashMap ActionId ActionLogResponse, Bool)
-> HashMap ActionId ActionLogResponse
forall a b. (a, b) -> a
fst (Either QErr (HashMap ActionId ActionLogResponse, Bool)
-> Either QErr (HashMap ActionId ActionLogResponse))
-> ExceptT
() m (Either QErr (HashMap ActionId ActionLogResponse, Bool))
-> ExceptT () m (Either QErr (HashMap ActionId ActionLogResponse))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT
QErr (ExceptT () m) (HashMap ActionId ActionLogResponse, Bool)
-> ExceptT
() m (Either QErr (HashMap ActionId ActionLogResponse, Bool))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (HashSet ActionId
-> ExceptT
QErr (ExceptT () m) (HashMap ActionId ActionLogResponse, Bool)
forall (m :: * -> *) (t :: * -> *).
(MonadError QErr m, MonadMetadataStorage (MetadataStorageT m),
Foldable t) =>
t ActionId -> m (HashMap ActionId ActionLogResponse, Bool)
EA.fetchActionLogResponses HashSet ActionId
actionIds)
HashMap ActionId ActionLogResponse
actionLogMap <- Either QErr (HashMap ActionId ActionLogResponse)
-> (QErr -> ExceptT () m (HashMap ActionId ActionLogResponse))
-> ExceptT () m (HashMap ActionId ActionLogResponse)
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
onLeft Either QErr (HashMap ActionId ActionLogResponse)
actionLogMapE (ExceptT () m ()
-> ExceptT () m (HashMap ActionId ActionLogResponse)
forall a. ExceptT () m () -> ExceptT () m a
withComplete (ExceptT () m ()
-> ExceptT () m (HashMap ActionId ActionLogResponse))
-> (QErr -> ExceptT () m ())
-> QErr
-> ExceptT () m (HashMap ActionId ActionLogResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestId -> Maybe OperationType -> QErr -> ExceptT () m ()
preExecErr RequestId
requestId (OperationType -> Maybe OperationType
forall a. a -> Maybe a
Just OperationType
gqlOpType))
Either QErr (SubscriberDetails CohortKey)
opMetadataE <- IO (Either QErr (SubscriberDetails CohortKey))
-> ExceptT () m (Either QErr (SubscriberDetails CohortKey))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either QErr (SubscriberDetails CohortKey))
-> ExceptT () m (Either QErr (SubscriberDetails CohortKey)))
-> IO (Either QErr (SubscriberDetails CohortKey))
-> ExceptT () m (Either QErr (SubscriberDetails CohortKey))
forall a b. (a -> b) -> a -> b
$ (HashMap ActionId ActionLogResponse
-> ExceptT QErr IO (SourceName, SubscriptionQueryPlan))
-> ParameterizedQueryHash
-> RequestId
-> HashMap ActionId ActionLogResponse
-> IO (Either QErr (SubscriberDetails CohortKey))
startLiveQuery HashMap ActionId ActionLogResponse
-> ExceptT QErr IO (SourceName, SubscriptionQueryPlan)
liveQueryBuilder ParameterizedQueryHash
parameterizedQueryHash RequestId
requestId HashMap ActionId ActionLogResponse
actionLogMap
SubscriberDetails CohortKey
lqId <- Either QErr (SubscriberDetails CohortKey)
-> (QErr -> ExceptT () m (SubscriberDetails CohortKey))
-> ExceptT () m (SubscriberDetails CohortKey)
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
onLeft Either QErr (SubscriberDetails CohortKey)
opMetadataE (ExceptT () m () -> ExceptT () m (SubscriberDetails CohortKey)
forall a. ExceptT () m () -> ExceptT () m a
withComplete (ExceptT () m () -> ExceptT () m (SubscriberDetails CohortKey))
-> (QErr -> ExceptT () m ())
-> QErr
-> ExceptT () m (SubscriberDetails CohortKey)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestId -> Maybe OperationType -> QErr -> ExceptT () m ()
preExecErr RequestId
requestId (OperationType -> Maybe OperationType
forall a. a -> Maybe a
Just OperationType
gqlOpType))
case [ActionId] -> Maybe (NonEmpty ActionId)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty (HashSet ActionId -> [ActionId]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList HashSet ActionId
actionIds) of
Maybe (NonEmpty ActionId)
Nothing -> do
Logger Hasura -> QueryLog -> ExceptT () m ()
forall (m :: * -> *).
MonadQueryLog m =>
Logger Hasura -> QueryLog -> m ()
logQueryLog Logger Hasura
logger (QueryLog -> ExceptT () m ()) -> QueryLog -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$ GQLReqUnparsed
-> Maybe (RootFieldAlias, GeneratedQuery)
-> RequestId
-> QueryLogKind
-> QueryLog
QueryLog GQLReqUnparsed
q Maybe (RootFieldAlias, GeneratedQuery)
forall a. Maybe a
Nothing RequestId
requestId QueryLogKind
QueryLogKindDatabase
() -> ExceptT () m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just NonEmpty ActionId
nonEmptyActionIds -> do
Logger Hasura -> QueryLog -> ExceptT () m ()
forall (m :: * -> *).
MonadQueryLog m =>
Logger Hasura -> QueryLog -> m ()
logQueryLog Logger Hasura
logger (QueryLog -> ExceptT () m ()) -> QueryLog -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$ GQLReqUnparsed
-> Maybe (RootFieldAlias, GeneratedQuery)
-> RequestId
-> QueryLogKind
-> QueryLog
QueryLog GQLReqUnparsed
q Maybe (RootFieldAlias, GeneratedQuery)
forall a. Maybe a
Nothing RequestId
requestId QueryLogKind
QueryLogKindAction
IO () -> ExceptT () m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT () m ()) -> IO () -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$ do
let asyncActionQueryLive :: LiveAsyncActionQuery
asyncActionQueryLive =
LiveAsyncActionQueryOnSource -> LiveAsyncActionQuery
ES.LAAQOnSourceDB (LiveAsyncActionQueryOnSource -> LiveAsyncActionQuery)
-> LiveAsyncActionQueryOnSource -> LiveAsyncActionQuery
forall a b. (a -> b) -> a -> b
$
SubscriberDetails CohortKey
-> HashMap ActionId ActionLogResponse
-> (SubscriberDetails CohortKey
-> HashMap ActionId ActionLogResponse
-> IO (Maybe (SubscriberDetails CohortKey)))
-> LiveAsyncActionQueryOnSource
ES.LiveAsyncActionQueryOnSource SubscriberDetails CohortKey
lqId HashMap ActionId ActionLogResponse
actionLogMap ((SubscriberDetails CohortKey
-> HashMap ActionId ActionLogResponse
-> IO (Maybe (SubscriberDetails CohortKey)))
-> LiveAsyncActionQueryOnSource)
-> (SubscriberDetails CohortKey
-> HashMap ActionId ActionLogResponse
-> IO (Maybe (SubscriberDetails CohortKey)))
-> LiveAsyncActionQueryOnSource
forall a b. (a -> b) -> a -> b
$
ParameterizedQueryHash
-> RequestId
-> (HashMap ActionId ActionLogResponse
-> ExceptT QErr IO (SourceName, SubscriptionQueryPlan))
-> SubscriberDetails CohortKey
-> HashMap ActionId ActionLogResponse
-> IO (Maybe (SubscriberDetails CohortKey))
restartLiveQuery ParameterizedQueryHash
parameterizedQueryHash RequestId
requestId HashMap ActionId ActionLogResponse
-> ExceptT QErr IO (SourceName, SubscriptionQueryPlan)
liveQueryBuilder
onUnexpectedException :: QErr -> IO ()
onUnexpectedException QErr
err = do
RequestId -> QErr -> IO ()
sendError RequestId
requestId QErr
err
WSServerEnv -> WSConn -> OperationId -> IO () -> IO ()
stopOperation WSServerEnv
serverEnv WSConn
wsConn OperationId
opId (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
AsyncActionSubscriptionState
-> OperationId
-> NonEmpty ActionId
-> (QErr -> IO ())
-> LiveAsyncActionQuery
-> IO ()
ES.addAsyncActionLiveQuery
(SubscriptionsState -> AsyncActionSubscriptionState
ES._ssAsyncActions SubscriptionsState
subscriptionsState)
OperationId
opId
NonEmpty ActionId
nonEmptyActionIds
QErr -> IO ()
onUnexpectedException
LiveAsyncActionQuery
asyncActionQueryLive
E.SEOnSourceDB (E.SSStreaming RootFieldAlias
rootFieldName (SourceName, SubscriptionQueryPlan)
streamQueryBuilder) -> do
IO () -> ExceptT () m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT () m ()) -> IO () -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$ RootFieldAlias
-> (SourceName, SubscriptionQueryPlan)
-> ParameterizedQueryHash
-> RequestId
-> IO ()
startStreamingQuery RootFieldAlias
rootFieldName (SourceName, SubscriptionQueryPlan)
streamQueryBuilder ParameterizedQueryHash
parameterizedQueryHash RequestId
requestId
IO () -> ExceptT () m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT () m ()) -> IO () -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$ OpDetail
-> Maybe RequestId -> Maybe ParameterizedQueryHash -> IO ()
logOpEv OpDetail
ODStarted (RequestId -> Maybe RequestId
forall a. a -> Maybe a
Just RequestId
requestId) (ParameterizedQueryHash -> Maybe ParameterizedQueryHash
forall a. a -> Maybe a
Just ParameterizedQueryHash
parameterizedQueryHash)
where
sendDataMsg :: DataMsg -> ServerMsg
sendDataMsg = WSActions WSConnData -> DataMsg -> ServerMsg
forall a. WSActions a -> DataMsg -> ServerMsg
WS._wsaGetDataMessageType WSActions WSConnData
onMessageActions
closeConnAction :: WSCloseConnAction WSConnData
closeConnAction = WSActions WSConnData -> WSCloseConnAction WSConnData
forall a. WSActions a -> WSCloseConnAction a
WS._wsaConnectionCloseAction WSActions WSConnData
onMessageActions
postExecErrAction :: WSPostExecErrMessageAction WSConnData
postExecErrAction = WSActions WSConnData -> WSPostExecErrMessageAction WSConnData
forall a. WSActions a -> WSPostExecErrMessageAction a
WS._wsaPostExecErrMessageAction WSActions WSConnData
onMessageActions
fmtErrorMessage :: [Value] -> Value
fmtErrorMessage = WSActions WSConnData -> [Value] -> Value
forall a. WSActions a -> [Value] -> Value
WS._wsaErrorMsgFormat WSActions WSConnData
onMessageActions
getExecStepActionWithActionInfo :: [ActionsInfo] -> ExecutionStep -> [ActionsInfo]
getExecStepActionWithActionInfo [ActionsInfo]
acc ExecutionStep
execStep = case ExecutionStep
execStep of
E.ExecStepAction ActionExecutionPlan
_ ActionsInfo
actionInfo Maybe RemoteJoins
_remoteJoins -> ActionsInfo
actionInfo ActionsInfo -> [ActionsInfo] -> [ActionsInfo]
forall a. a -> [a] -> [a]
: [ActionsInfo]
acc
ExecutionStep
_ -> [ActionsInfo]
acc
doQErr ::
Monad n =>
ExceptT QErr n a ->
ExceptT (Either GQExecError QErr) n a
doQErr :: ExceptT QErr n a -> ExceptT (Either GQExecError QErr) n a
doQErr = (QErr -> Either GQExecError QErr)
-> ExceptT QErr n a -> ExceptT (Either GQExecError QErr) n a
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT QErr -> Either GQExecError QErr
forall a b. b -> Either a b
Right
withErr ::
forall e f n a.
Monad n =>
(e -> f) ->
(ExceptT e (ExceptT f n) a -> ExceptT e (ExceptT f n) a) ->
ExceptT f n a ->
ExceptT f n a
withErr :: (e -> f)
-> (ExceptT e (ExceptT f n) a -> ExceptT e (ExceptT f n) a)
-> ExceptT f n a
-> ExceptT f n a
withErr e -> f
embed ExceptT e (ExceptT f n) a -> ExceptT e (ExceptT f n) a
f ExceptT f n a
action = do
Either e a
res <- ExceptT e (ExceptT f n) a -> ExceptT f n (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT e (ExceptT f n) a -> ExceptT f n (Either e a))
-> ExceptT e (ExceptT f n) a -> ExceptT f n (Either e a)
forall a b. (a -> b) -> a -> b
$ ExceptT e (ExceptT f n) a -> ExceptT e (ExceptT f n) a
f (ExceptT e (ExceptT f n) a -> ExceptT e (ExceptT f n) a)
-> ExceptT e (ExceptT f n) a -> ExceptT e (ExceptT f n) a
forall a b. (a -> b) -> a -> b
$ ExceptT f n a -> ExceptT e (ExceptT f n) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ExceptT f n a
action
Either e a -> (e -> ExceptT f n a) -> ExceptT f n a
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
onLeft Either e a
res (f -> ExceptT f n a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (f -> ExceptT f n a) -> (e -> f) -> e -> ExceptT f n a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> f
embed)
forWithKey :: InsOrdHashMap k a
-> (k -> a -> ExceptT (Either GQExecError QErr) (ExceptT () m) b)
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) (InsOrdHashMap k b)
forWithKey = ((k -> a -> ExceptT (Either GQExecError QErr) (ExceptT () m) b)
-> InsOrdHashMap k a
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) (InsOrdHashMap k b))
-> InsOrdHashMap k a
-> (k -> a -> ExceptT (Either GQExecError QErr) (ExceptT () m) b)
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) (InsOrdHashMap k b)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (k -> a -> ExceptT (Either GQExecError QErr) (ExceptT () m) b)
-> InsOrdHashMap k a
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) (InsOrdHashMap k b)
forall (f :: * -> *) k a b.
Applicative f =>
(k -> a -> f b) -> InsOrdHashMap k a -> f (InsOrdHashMap k b)
OMap.traverseWithKey
telemTransport :: Transport
telemTransport = Transport
Telem.WebSocket
handleResult ::
forall a.
RequestId ->
G.OperationType ->
Either (Either GQExecError QErr) a ->
(a -> ExceptT () m ()) ->
ExceptT () m ()
handleResult :: RequestId
-> OperationType
-> Either (Either GQExecError QErr) a
-> (a -> ExceptT () m ())
-> ExceptT () m ()
handleResult RequestId
requestId OperationType
gqlOpType Either (Either GQExecError QErr) a
r a -> ExceptT () m ()
f = case Either (Either GQExecError QErr) a
r of
Left (Left GQExecError
err) -> OperationType -> GQExecError -> ExceptT () m ()
postExecErr' OperationType
gqlOpType GQExecError
err
Left (Right QErr
err) -> RequestId -> OperationType -> QErr -> ExceptT () m ()
postExecErr RequestId
requestId OperationType
gqlOpType QErr
err
Right a
results -> a -> ExceptT () m ()
f a
results
sendResultFromFragments :: QueryType
-> ExceptT () m DiffTime
-> RequestId
-> Either
(Either GQExecError QErr)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
-> Maybe OperationName
-> ParameterizedQueryHash
-> OperationType
-> ExceptT () m ()
sendResultFromFragments QueryType
telemQueryType ExceptT () m DiffTime
timerTot RequestId
requestId Either
(Either GQExecError QErr)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
r Maybe OperationName
opName ParameterizedQueryHash
pqh OperationType
gqlOpType =
RequestId
-> OperationType
-> Either
(Either GQExecError QErr)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
-> (InsOrdHashMap RootFieldAlias AnnotatedResponsePart
-> ExceptT () m ())
-> ExceptT () m ()
forall a.
RequestId
-> OperationType
-> Either (Either GQExecError QErr) a
-> (a -> ExceptT () m ())
-> ExceptT () m ()
handleResult RequestId
requestId OperationType
gqlOpType Either
(Either GQExecError QErr)
(InsOrdHashMap RootFieldAlias AnnotatedResponsePart)
r \InsOrdHashMap RootFieldAlias AnnotatedResponsePart
results -> do
let telemLocality :: Locality
telemLocality = (AnnotatedResponsePart -> Locality)
-> InsOrdHashMap RootFieldAlias AnnotatedResponsePart -> Locality
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap AnnotatedResponsePart -> Locality
arpLocality InsOrdHashMap RootFieldAlias AnnotatedResponsePart
results
telemTimeIO :: Seconds
telemTimeIO = DiffTime -> Seconds
forall x y. (Duration x, Duration y) => x -> y
convertDuration (DiffTime -> Seconds) -> DiffTime -> Seconds
forall a b. (a -> b) -> a -> b
$ InsOrdHashMap RootFieldAlias DiffTime -> DiffTime
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (InsOrdHashMap RootFieldAlias DiffTime -> DiffTime)
-> InsOrdHashMap RootFieldAlias DiffTime -> DiffTime
forall a b. (a -> b) -> a -> b
$ (AnnotatedResponsePart -> DiffTime)
-> InsOrdHashMap RootFieldAlias AnnotatedResponsePart
-> InsOrdHashMap RootFieldAlias DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AnnotatedResponsePart -> DiffTime
arpTimeIO InsOrdHashMap RootFieldAlias AnnotatedResponsePart
results
DiffTime
totalTime <- ExceptT () m DiffTime
timerTot
let telemTimeTot :: Seconds
telemTimeTot = DiffTime -> Seconds
Seconds DiffTime
totalTime
EncJSON
-> Maybe OperationName
-> ParameterizedQueryHash
-> SubscriptionMetadata
-> ExceptT () m ()
sendSuccResp (InsOrdHashMap RootFieldAlias AnnotatedResponsePart -> EncJSON
encodeAnnotatedResponseParts InsOrdHashMap RootFieldAlias AnnotatedResponsePart
results) Maybe OperationName
opName ParameterizedQueryHash
pqh (SubscriptionMetadata -> ExceptT () m ())
-> SubscriptionMetadata -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$
DiffTime -> SubscriptionMetadata
ES.SubscriptionMetadata (DiffTime -> SubscriptionMetadata)
-> DiffTime -> SubscriptionMetadata
forall a b. (a -> b) -> a -> b
$ InsOrdHashMap RootFieldAlias DiffTime -> DiffTime
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (InsOrdHashMap RootFieldAlias DiffTime -> DiffTime)
-> InsOrdHashMap RootFieldAlias DiffTime -> DiffTime
forall a b. (a -> b) -> a -> b
$ (AnnotatedResponsePart -> DiffTime)
-> InsOrdHashMap RootFieldAlias AnnotatedResponsePart
-> InsOrdHashMap RootFieldAlias DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AnnotatedResponsePart -> DiffTime
arpTimeIO InsOrdHashMap RootFieldAlias AnnotatedResponsePart
results
RequestDimensions -> RequestTimings -> ExceptT () m ()
forall (m :: * -> *).
MonadIO m =>
RequestDimensions -> RequestTimings -> m ()
Telem.recordTimingMetric RequestDimensions :: QueryType -> Locality -> Transport -> RequestDimensions
Telem.RequestDimensions {Transport
Locality
QueryType
telemLocality :: Locality
telemQueryType :: QueryType
$sel:telemTransport:RequestDimensions :: Transport
$sel:telemLocality:RequestDimensions :: Locality
$sel:telemQueryType:RequestDimensions :: QueryType
telemTransport :: Transport
..} RequestTimings :: Seconds -> Seconds -> RequestTimings
Telem.RequestTimings {Seconds
telemTimeTot :: Seconds
telemTimeIO :: Seconds
$sel:telemTimeTot:RequestTimings :: Seconds
$sel:telemTimeIO:RequestTimings :: Seconds
..}
IO () -> ExceptT () m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT () m ()) -> IO () -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$ DiffTime -> OperationType -> IO ()
recordGQLQuerySuccess DiffTime
totalTime OperationType
gqlOpType
runRemoteGQ ::
RequestId ->
GQLReqUnparsed ->
RootFieldAlias ->
UserInfo ->
[HTTP.Header] ->
RemoteSchemaInfo ->
ResultCustomizer ->
GQLReqOutgoing ->
Maybe RJ.RemoteJoins ->
ExceptT (Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart
runRemoteGQ :: RequestId
-> GQLReqUnparsed
-> RootFieldAlias
-> UserInfo
-> [Header]
-> RemoteSchemaInfo
-> ResultCustomizer
-> GQLReqOutgoing
-> Maybe RemoteJoins
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart
runRemoteGQ RequestId
requestId GQLReqUnparsed
reqUnparsed RootFieldAlias
fieldName UserInfo
userInfo [Header]
reqHdrs RemoteSchemaInfo
rsi ResultCustomizer
resultCustomizer GQLReqOutgoing
gqlReq Maybe RemoteJoins
remoteJoins = do
(DiffTime
telemTimeIO_DT, [Header]
_respHdrs, ByteString
resp) <-
ExceptT QErr (ExceptT () m) (DiffTime, [Header], ByteString)
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(DiffTime, [Header], ByteString)
forall (n :: * -> *) a.
Monad n =>
ExceptT QErr n a -> ExceptT (Either GQExecError QErr) n a
doQErr (ExceptT QErr (ExceptT () m) (DiffTime, [Header], ByteString)
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(DiffTime, [Header], ByteString))
-> ExceptT QErr (ExceptT () m) (DiffTime, [Header], ByteString)
-> ExceptT
(Either GQExecError QErr)
(ExceptT () m)
(DiffTime, [Header], ByteString)
forall a b. (a -> b) -> a -> b
$
Environment
-> Manager
-> UserInfo
-> [Header]
-> ValidatedRemoteSchemaDef
-> GQLReqOutgoing
-> ExceptT QErr (ExceptT () m) (DiffTime, [Header], ByteString)
forall (m :: * -> *).
(MonadIO m, MonadError QErr m, MonadTrace m) =>
Environment
-> Manager
-> UserInfo
-> [Header]
-> ValidatedRemoteSchemaDef
-> GQLReqOutgoing
-> m (DiffTime, [Header], ByteString)
E.execRemoteGQ Environment
env Manager
httpMgr UserInfo
userInfo [Header]
reqHdrs (RemoteSchemaInfo -> ValidatedRemoteSchemaDef
rsDef RemoteSchemaInfo
rsi) GQLReqOutgoing
gqlReq
Value
value <- (m (Either (Either GQExecError QErr) Value)
-> ExceptT () m (Either (Either GQExecError QErr) Value))
-> ExceptT (Either GQExecError QErr) m Value
-> ExceptT (Either GQExecError QErr) (ExceptT () m) Value
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT m (Either (Either GQExecError QErr) Value)
-> ExceptT () m (Either (Either GQExecError QErr) Value)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT (Either GQExecError QErr) m Value
-> ExceptT (Either GQExecError QErr) (ExceptT () m) Value)
-> ExceptT (Either GQExecError QErr) m Value
-> ExceptT (Either GQExecError QErr) (ExceptT () m) Value
forall a b. (a -> b) -> a -> b
$ RootFieldAlias
-> ResultCustomizer
-> ByteString
-> ExceptT (Either GQExecError QErr) m Value
forall (m :: * -> *).
Monad m =>
RootFieldAlias
-> ResultCustomizer
-> ByteString
-> ExceptT (Either GQExecError QErr) m Value
extractFieldFromResponse RootFieldAlias
fieldName ResultCustomizer
resultCustomizer ByteString
resp
EncJSON
finalResponse <-
ExceptT QErr (ExceptT () m) EncJSON
-> ExceptT (Either GQExecError QErr) (ExceptT () m) EncJSON
forall (n :: * -> *) a.
Monad n =>
ExceptT QErr n a -> ExceptT (Either GQExecError QErr) n a
doQErr (ExceptT QErr (ExceptT () m) EncJSON
-> ExceptT (Either GQExecError QErr) (ExceptT () m) EncJSON)
-> ExceptT QErr (ExceptT () m) EncJSON
-> ExceptT (Either GQExecError QErr) (ExceptT () m) EncJSON
forall a b. (a -> b) -> a -> b
$
RequestId
-> Logger Hasura
-> Environment
-> Manager
-> [Header]
-> UserInfo
-> EncJSON
-> Maybe RemoteJoins
-> GQLReqUnparsed
-> ExceptT QErr (ExceptT () m) EncJSON
forall (m :: * -> *).
(MonadError QErr m, MonadIO m, MonadQueryTags m, MonadQueryLog m,
MonadTrace m) =>
RequestId
-> Logger Hasura
-> Environment
-> Manager
-> [Header]
-> UserInfo
-> EncJSON
-> Maybe RemoteJoins
-> GQLReqUnparsed
-> m EncJSON
RJ.processRemoteJoins
RequestId
requestId
Logger Hasura
logger
Environment
env
Manager
httpMgr
[Header]
reqHdrs
UserInfo
userInfo
(Value -> EncJSON
encJFromOrderedValue Value
value)
Maybe RemoteJoins
remoteJoins
GQLReqUnparsed
reqUnparsed
AnnotatedResponsePart
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart
forall (m :: * -> *) a. Monad m => a -> m a
return (AnnotatedResponsePart
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart)
-> AnnotatedResponsePart
-> ExceptT
(Either GQExecError QErr) (ExceptT () m) AnnotatedResponsePart
forall a b. (a -> b) -> a -> b
$ DiffTime
-> Locality -> EncJSON -> [Header] -> AnnotatedResponsePart
AnnotatedResponsePart DiffTime
telemTimeIO_DT Locality
Telem.Remote EncJSON
finalResponse []
WSServerEnv
Logger Hasura
logger
SubscriptionsState
subscriptionsState
IO (SchemaCache, SchemaCacheVer)
getSchemaCache
Manager
httpMgr
CorsPolicy
_
SQLGenCtx
sqlGenCtx
ReadOnlyMode
readOnlyMode
WSServer
_
Bool
enableAL
KeepAliveDelay
_keepAliveDelay
ServerMetrics
_serverMetrics
PrometheusMetrics
prometheusMetrics = WSServerEnv
serverEnv
gqlMetrics :: GraphQLRequestMetrics
gqlMetrics = PrometheusMetrics -> GraphQLRequestMetrics
pmGraphQLRequestMetrics PrometheusMetrics
prometheusMetrics
WSConnData TVar WSConnState
userInfoR OperationMap
opMap ErrRespType
errRespTy GraphQLQueryType
queryType = WSConn -> WSConnData
forall a. WSConn a -> a
WS.getData WSConn
wsConn
logOpEv :: OpDetail
-> Maybe RequestId -> Maybe ParameterizedQueryHash -> IO ()
logOpEv OpDetail
opTy Maybe RequestId
reqId Maybe ParameterizedQueryHash
parameterizedQueryHash =
let queryToLog :: Maybe GQLReqUnparsed
queryToLog = Maybe GQLReqUnparsed
-> Maybe GQLReqUnparsed -> Bool -> Maybe GQLReqUnparsed
forall a. a -> a -> Bool -> a
bool Maybe GQLReqUnparsed
forall a. Maybe a
Nothing (GQLReqUnparsed -> Maybe GQLReqUnparsed
forall a. a -> Maybe a
Just GQLReqUnparsed
q) (EngineLogType Hasura -> HashSet (EngineLogType Hasura) -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
Set.member EngineLogType Hasura
L.ELTQueryLog HashSet (EngineLogType Hasura)
enabledLogTypes)
in Logger Hasura -> WSConn -> WSEvent -> IO ()
forall (m :: * -> *).
MonadIO m =>
Logger Hasura -> WSConn -> WSEvent -> m ()
logWSEvent Logger Hasura
logger WSConn
wsConn (WSEvent -> IO ()) -> WSEvent -> IO ()
forall a b. (a -> b) -> a -> b
$
OperationDetails -> WSEvent
EOperation (OperationDetails -> WSEvent) -> OperationDetails -> WSEvent
forall a b. (a -> b) -> a -> b
$
OperationId
-> Maybe RequestId
-> Maybe OperationName
-> OpDetail
-> Maybe GQLReqUnparsed
-> Maybe ParameterizedQueryHash
-> OperationDetails
OperationDetails OperationId
opId Maybe RequestId
reqId (GQLReqUnparsed -> Maybe OperationName
forall a. GQLReq a -> Maybe OperationName
_grOperationName GQLReqUnparsed
q) OpDetail
opTy Maybe GQLReqUnparsed
queryToLog Maybe ParameterizedQueryHash
parameterizedQueryHash
getErrFn :: ErrRespType -> Bool -> QErr -> Value
getErrFn ErrRespType
ERTLegacy = Bool -> QErr -> Value
encodeQErr
getErrFn ErrRespType
ERTGraphqlCompliant = Bool -> QErr -> Value
encodeGQLErr
sendStartErr :: Text -> ExceptT () m ()
sendStartErr Text
e = do
let errFn :: Bool -> QErr -> Value
errFn = ErrRespType -> Bool -> QErr -> Value
getErrFn ErrRespType
errRespTy
WSConn -> ServerMsg -> ExceptT () m ()
forall (m :: * -> *). MonadIO m => WSConn -> ServerMsg -> m ()
sendMsg WSConn
wsConn (ServerMsg -> ExceptT () m ()) -> ServerMsg -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$
ErrorMsg -> ServerMsg
SMErr (ErrorMsg -> ServerMsg) -> ErrorMsg -> ServerMsg
forall a b. (a -> b) -> a -> b
$ OperationId -> Value -> ErrorMsg
ErrorMsg OperationId
opId (Value -> ErrorMsg) -> Value -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ Bool -> QErr -> Value
errFn Bool
False (QErr -> Value) -> QErr -> Value
forall a b. (a -> b) -> a -> b
$ Code -> Text -> QErr
err400 Code
StartFailed Text
e
IO () -> ExceptT () m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT () m ()) -> IO () -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$ OpDetail
-> Maybe RequestId -> Maybe ParameterizedQueryHash -> IO ()
logOpEv (Text -> OpDetail
ODProtoErr Text
e) Maybe RequestId
forall a. Maybe a
Nothing Maybe ParameterizedQueryHash
forall a. Maybe a
Nothing
IO () -> ExceptT () m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT () m ()) -> IO () -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$ Maybe OperationType -> IO ()
reportGQLQueryError Maybe OperationType
forall a. Maybe a
Nothing
IO () -> ExceptT () m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT () m ()) -> IO () -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$ WSCloseConnAction WSConnData
closeConnAction WSConn
wsConn OperationId
opId (Text -> String
T.unpack Text
e)
sendCompleted :: Maybe RequestId -> Maybe ParameterizedQueryHash -> IO ()
sendCompleted Maybe RequestId
reqId Maybe ParameterizedQueryHash
paramQueryHash = do
WSConn -> ServerMsg -> IO ()
forall (m :: * -> *). MonadIO m => WSConn -> ServerMsg -> m ()
sendMsg WSConn
wsConn (CompletionMsg -> ServerMsg
SMComplete (CompletionMsg -> ServerMsg)
-> (OperationId -> CompletionMsg) -> OperationId -> ServerMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OperationId -> CompletionMsg
CompletionMsg (OperationId -> ServerMsg) -> OperationId -> ServerMsg
forall a b. (a -> b) -> a -> b
$ OperationId
opId)
OpDetail
-> Maybe RequestId -> Maybe ParameterizedQueryHash -> IO ()
logOpEv OpDetail
ODCompleted Maybe RequestId
reqId Maybe ParameterizedQueryHash
paramQueryHash
postExecErr :: RequestId -> G.OperationType -> QErr -> ExceptT () m ()
postExecErr :: RequestId -> OperationType -> QErr -> ExceptT () m ()
postExecErr RequestId
reqId OperationType
gqlOpType QErr
qErr = do
let errFn :: QErr -> Value
errFn = ErrRespType -> Bool -> QErr -> Value
getErrFn ErrRespType
errRespTy Bool
False
IO () -> ExceptT () m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT () m ()) -> IO () -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$ OpDetail
-> Maybe RequestId -> Maybe ParameterizedQueryHash -> IO ()
logOpEv (QErr -> OpDetail
ODQueryErr QErr
qErr) (RequestId -> Maybe RequestId
forall a. a -> Maybe a
Just RequestId
reqId) Maybe ParameterizedQueryHash
forall a. Maybe a
Nothing
OperationType -> GQExecError -> ExceptT () m ()
postExecErr' OperationType
gqlOpType (GQExecError -> ExceptT () m ()) -> GQExecError -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$ [Value] -> GQExecError
GQExecError ([Value] -> GQExecError) -> [Value] -> GQExecError
forall a b. (a -> b) -> a -> b
$ Value -> [Value]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> [Value]) -> Value -> [Value]
forall a b. (a -> b) -> a -> b
$ QErr -> Value
errFn QErr
qErr
postExecErr' :: G.OperationType -> GQExecError -> ExceptT () m ()
postExecErr' :: OperationType -> GQExecError -> ExceptT () m ()
postExecErr' OperationType
gqlOpType GQExecError
qErr =
IO () -> ExceptT () m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT () m ()) -> IO () -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$ do
Maybe OperationType -> IO ()
reportGQLQueryError (OperationType -> Maybe OperationType
forall a. a -> Maybe a
Just OperationType
gqlOpType)
WSPostExecErrMessageAction WSConnData
postExecErrAction WSConn
wsConn OperationId
opId GQExecError
qErr
preExecErr :: RequestId -> Maybe OperationType -> QErr -> ExceptT () m ()
preExecErr RequestId
reqId Maybe OperationType
mGqlOpType QErr
qErr = do
IO () -> ExceptT () m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT () m ()) -> IO () -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$ Maybe OperationType -> IO ()
reportGQLQueryError Maybe OperationType
mGqlOpType
IO () -> ExceptT () m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT () m ()) -> IO () -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$ RequestId -> QErr -> IO ()
sendError RequestId
reqId QErr
qErr
sendError :: RequestId -> QErr -> IO ()
sendError RequestId
reqId QErr
qErr = do
let errFn :: Bool -> QErr -> Value
errFn = ErrRespType -> Bool -> QErr -> Value
getErrFn ErrRespType
errRespTy
OpDetail
-> Maybe RequestId -> Maybe ParameterizedQueryHash -> IO ()
logOpEv (QErr -> OpDetail
ODQueryErr QErr
qErr) (RequestId -> Maybe RequestId
forall a. a -> Maybe a
Just RequestId
reqId) Maybe ParameterizedQueryHash
forall a. Maybe a
Nothing
let err :: Value
err = case ErrRespType
errRespTy of
ErrRespType
ERTLegacy -> Bool -> QErr -> Value
errFn Bool
False QErr
qErr
ErrRespType
ERTGraphqlCompliant -> [Value] -> Value
fmtErrorMessage [Bool -> QErr -> Value
errFn Bool
False QErr
qErr]
WSConn -> ServerMsg -> IO ()
forall (m :: * -> *). MonadIO m => WSConn -> ServerMsg -> m ()
sendMsg WSConn
wsConn (ErrorMsg -> ServerMsg
SMErr (ErrorMsg -> ServerMsg) -> ErrorMsg -> ServerMsg
forall a b. (a -> b) -> a -> b
$ OperationId -> Value -> ErrorMsg
ErrorMsg OperationId
opId Value
err)
sendSuccResp ::
EncJSON ->
Maybe OperationName ->
ParameterizedQueryHash ->
ES.SubscriptionMetadata ->
ExceptT () m ()
sendSuccResp :: EncJSON
-> Maybe OperationName
-> ParameterizedQueryHash
-> SubscriptionMetadata
-> ExceptT () m ()
sendSuccResp EncJSON
encJson Maybe OperationName
opName ParameterizedQueryHash
queryHash =
WSConn
-> ServerMsg
-> Maybe OperationName
-> Maybe ParameterizedQueryHash
-> SubscriptionMetadata
-> ExceptT () m ()
forall (m :: * -> *).
MonadIO m =>
WSConn
-> ServerMsg
-> Maybe OperationName
-> Maybe ParameterizedQueryHash
-> SubscriptionMetadata
-> m ()
sendMsgWithMetadata
WSConn
wsConn
(DataMsg -> ServerMsg
sendDataMsg (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
$ ByteString -> GQResponse
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> GQResponse) -> ByteString -> GQResponse
forall a b. (a -> b) -> a -> b
$ EncJSON -> ByteString
encJToLBS EncJSON
encJson)
Maybe OperationName
opName
(ParameterizedQueryHash -> Maybe ParameterizedQueryHash
forall a. a -> Maybe a
Just ParameterizedQueryHash
queryHash)
withComplete :: ExceptT () m () -> ExceptT () m a
withComplete :: ExceptT () m () -> ExceptT () m a
withComplete ExceptT () m ()
action = do
ExceptT () m ()
action
IO () -> ExceptT () m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT () m ()) -> IO () -> ExceptT () m ()
forall a b. (a -> b) -> a -> b
$ Maybe RequestId -> Maybe ParameterizedQueryHash -> IO ()
sendCompleted Maybe RequestId
forall a. Maybe a
Nothing Maybe ParameterizedQueryHash
forall a. Maybe a
Nothing
() -> ExceptT () m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ()
restartLiveQuery :: ParameterizedQueryHash
-> RequestId
-> (HashMap ActionId ActionLogResponse
-> ExceptT QErr IO (SourceName, SubscriptionQueryPlan))
-> SubscriberDetails CohortKey
-> HashMap ActionId ActionLogResponse
-> IO (Maybe (SubscriberDetails CohortKey))
restartLiveQuery ParameterizedQueryHash
parameterizedQueryHash RequestId
requestId HashMap ActionId ActionLogResponse
-> ExceptT QErr IO (SourceName, SubscriptionQueryPlan)
liveQueryBuilder SubscriberDetails CohortKey
lqId HashMap ActionId ActionLogResponse
actionLogMap = do
Logger Hasura
-> ServerMetrics
-> PrometheusMetrics
-> SubscriptionsState
-> SubscriberDetails CohortKey
-> IO ()
ES.removeLiveQuery Logger Hasura
logger (WSServerEnv -> ServerMetrics
_wseServerMetrics WSServerEnv
serverEnv) (WSServerEnv -> PrometheusMetrics
_wsePrometheusMetrics WSServerEnv
serverEnv) SubscriptionsState
subscriptionsState SubscriberDetails CohortKey
lqId
(QErr -> Maybe (SubscriberDetails CohortKey))
-> (SubscriberDetails CohortKey
-> Maybe (SubscriberDetails CohortKey))
-> Either QErr (SubscriberDetails CohortKey)
-> Maybe (SubscriberDetails CohortKey)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe (SubscriberDetails CohortKey)
-> QErr -> Maybe (SubscriberDetails CohortKey)
forall a b. a -> b -> a
const Maybe (SubscriberDetails CohortKey)
forall a. Maybe a
Nothing) SubscriberDetails CohortKey -> Maybe (SubscriberDetails CohortKey)
forall a. a -> Maybe a
Just (Either QErr (SubscriberDetails CohortKey)
-> Maybe (SubscriberDetails CohortKey))
-> IO (Either QErr (SubscriberDetails CohortKey))
-> IO (Maybe (SubscriberDetails CohortKey))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (HashMap ActionId ActionLogResponse
-> ExceptT QErr IO (SourceName, SubscriptionQueryPlan))
-> ParameterizedQueryHash
-> RequestId
-> HashMap ActionId ActionLogResponse
-> IO (Either QErr (SubscriberDetails CohortKey))
startLiveQuery HashMap ActionId ActionLogResponse
-> ExceptT QErr IO (SourceName, SubscriptionQueryPlan)
liveQueryBuilder ParameterizedQueryHash
parameterizedQueryHash RequestId
requestId HashMap ActionId ActionLogResponse
actionLogMap
startLiveQuery :: (HashMap ActionId ActionLogResponse
-> ExceptT QErr IO (SourceName, SubscriptionQueryPlan))
-> ParameterizedQueryHash
-> RequestId
-> HashMap ActionId ActionLogResponse
-> IO (Either QErr (SubscriberDetails CohortKey))
startLiveQuery HashMap ActionId ActionLogResponse
-> ExceptT QErr IO (SourceName, SubscriptionQueryPlan)
liveQueryBuilder ParameterizedQueryHash
parameterizedQueryHash RequestId
requestId HashMap ActionId ActionLogResponse
actionLogMap = do
Either QErr (SourceName, SubscriptionQueryPlan)
liveQueryE <- ExceptT QErr IO (SourceName, SubscriptionQueryPlan)
-> IO (Either QErr (SourceName, SubscriptionQueryPlan))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT QErr IO (SourceName, SubscriptionQueryPlan)
-> IO (Either QErr (SourceName, SubscriptionQueryPlan)))
-> ExceptT QErr IO (SourceName, SubscriptionQueryPlan)
-> IO (Either QErr (SourceName, SubscriptionQueryPlan))
forall a b. (a -> b) -> a -> b
$ HashMap ActionId ActionLogResponse
-> ExceptT QErr IO (SourceName, SubscriptionQueryPlan)
liveQueryBuilder HashMap ActionId ActionLogResponse
actionLogMap
Either QErr (SourceName, SubscriptionQueryPlan)
-> ((SourceName, SubscriptionQueryPlan)
-> IO (SubscriberDetails CohortKey))
-> IO (Either QErr (SubscriberDetails CohortKey))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Either QErr (SourceName, SubscriptionQueryPlan)
liveQueryE (((SourceName, SubscriptionQueryPlan)
-> IO (SubscriberDetails CohortKey))
-> IO (Either QErr (SubscriberDetails CohortKey)))
-> ((SourceName, SubscriptionQueryPlan)
-> IO (SubscriberDetails CohortKey))
-> IO (Either QErr (SubscriberDetails CohortKey))
forall a b. (a -> b) -> a -> b
$ \(SourceName
sourceName, E.SubscriptionQueryPlan AnyBackend MultiplexedSubscriptionQueryPlan
exists) -> do
let !opName :: Maybe OperationName
opName = GQLReqUnparsed -> Maybe OperationName
forall a. GQLReq a -> Maybe OperationName
_grOperationName GQLReqUnparsed
q
subscriberMetadata :: SubscriberMetadata
subscriberMetadata = WSId
-> OperationId
-> Maybe OperationName
-> RequestId
-> SubscriberMetadata
ES.mkSubscriberMetadata (WSConn -> WSId
forall a. WSConn a -> WSId
WS.getWSId WSConn
wsConn) OperationId
opId Maybe OperationName
opName RequestId
requestId
!SubscriberDetails CohortKey
lqId <- IO (SubscriberDetails CohortKey)
-> IO (SubscriberDetails CohortKey)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (SubscriberDetails CohortKey)
-> IO (SubscriberDetails CohortKey))
-> IO (SubscriberDetails CohortKey)
-> IO (SubscriberDetails CohortKey)
forall a b. (a -> b) -> a -> b
$ AnyBackend MultiplexedSubscriptionQueryPlan
-> (forall (b :: BackendType).
BackendTransport b =>
MultiplexedSubscriptionQueryPlan b
-> IO (SubscriberDetails CohortKey))
-> IO (SubscriberDetails CohortKey)
forall (c :: BackendType -> Constraint) (i :: BackendType -> *) r.
AllBackendsSatisfy c =>
AnyBackend i -> (forall (b :: BackendType). c b => i b -> r) -> r
AB.dispatchAnyBackend @BackendTransport
AnyBackend MultiplexedSubscriptionQueryPlan
exists
\(E.MultiplexedSubscriptionQueryPlan SubscriptionQueryPlan b (MultiplexedQuery b)
liveQueryPlan) ->
Logger Hasura
-> ServerMetrics
-> PrometheusMetrics
-> SubscriberMetadata
-> SubscriptionsState
-> SourceName
-> ParameterizedQueryHash
-> Maybe OperationName
-> RequestId
-> SubscriptionQueryPlan b (MultiplexedQuery b)
-> OnChange
-> IO (SubscriberDetails CohortKey)
forall (b :: BackendType).
BackendTransport b =>
Logger Hasura
-> ServerMetrics
-> PrometheusMetrics
-> SubscriberMetadata
-> SubscriptionsState
-> SourceName
-> ParameterizedQueryHash
-> Maybe OperationName
-> RequestId
-> SubscriptionQueryPlan b (MultiplexedQuery b)
-> OnChange
-> IO (SubscriberDetails CohortKey)
ES.addLiveQuery
Logger Hasura
logger
(WSServerEnv -> ServerMetrics
_wseServerMetrics WSServerEnv
serverEnv)
(WSServerEnv -> PrometheusMetrics
_wsePrometheusMetrics WSServerEnv
serverEnv)
SubscriberMetadata
subscriberMetadata
SubscriptionsState
subscriptionsState
SourceName
sourceName
ParameterizedQueryHash
parameterizedQueryHash
Maybe OperationName
opName
RequestId
requestId
SubscriptionQueryPlan b (MultiplexedQuery b)
liveQueryPlan
(Maybe OperationName
-> ParameterizedQueryHash -> Maybe Name -> OnChange
onChange Maybe OperationName
opName ParameterizedQueryHash
parameterizedQueryHash (Maybe Name -> OnChange) -> Maybe Name -> OnChange
forall a b. (a -> b) -> a -> b
$ SubscriptionQueryPlan b (MultiplexedQuery b) -> Maybe Name
forall (b :: BackendType) q.
SubscriptionQueryPlan b q -> Maybe Name
ES._sqpNamespace SubscriptionQueryPlan b (MultiplexedQuery b)
liveQueryPlan)
IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String
String
-> (SubscriberDetails CohortKey, Maybe OperationName) -> IO ()
forall a. String -> a -> IO ()
$assertNFHere (SubscriberDetails CohortKey
lqId, Maybe OperationName
opName)
STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
(SubscriberType, Maybe OperationName)
-> OperationId -> OperationMap -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
STMMap.insert (SubscriberDetails CohortKey -> SubscriberType
LiveQuerySubscriber SubscriberDetails CohortKey
lqId, Maybe OperationName
opName) OperationId
opId OperationMap
opMap
SubscriberDetails CohortKey -> IO (SubscriberDetails CohortKey)
forall (f :: * -> *) a. Applicative f => a -> f a
pure SubscriberDetails CohortKey
lqId
startStreamingQuery :: RootFieldAlias
-> (SourceName, SubscriptionQueryPlan)
-> ParameterizedQueryHash
-> RequestId
-> IO ()
startStreamingQuery RootFieldAlias
rootFieldName (SourceName
sourceName, E.SubscriptionQueryPlan AnyBackend MultiplexedSubscriptionQueryPlan
exists) ParameterizedQueryHash
parameterizedQueryHash RequestId
requestId = do
let !opName :: Maybe OperationName
opName = GQLReqUnparsed -> Maybe OperationName
forall a. GQLReq a -> Maybe OperationName
_grOperationName GQLReqUnparsed
q
subscriberMetadata :: SubscriberMetadata
subscriberMetadata = WSId
-> OperationId
-> Maybe OperationName
-> RequestId
-> SubscriberMetadata
ES.mkSubscriberMetadata (WSConn -> WSId
forall a. WSConn a -> WSId
WS.getWSId WSConn
wsConn) OperationId
opId Maybe OperationName
opName RequestId
requestId
SubscriberDetails (CohortKey, TVar CursorVariableValues)
streamSubscriberId <- IO (SubscriberDetails (CohortKey, TVar CursorVariableValues))
-> IO (SubscriberDetails (CohortKey, TVar CursorVariableValues))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (SubscriberDetails (CohortKey, TVar CursorVariableValues))
-> IO (SubscriberDetails (CohortKey, TVar CursorVariableValues)))
-> IO (SubscriberDetails (CohortKey, TVar CursorVariableValues))
-> IO (SubscriberDetails (CohortKey, TVar CursorVariableValues))
forall a b. (a -> b) -> a -> b
$ AnyBackend MultiplexedSubscriptionQueryPlan
-> (forall (b :: BackendType).
BackendTransport b =>
MultiplexedSubscriptionQueryPlan b
-> IO (SubscriberDetails (CohortKey, TVar CursorVariableValues)))
-> IO (SubscriberDetails (CohortKey, TVar CursorVariableValues))
forall (c :: BackendType -> Constraint) (i :: BackendType -> *) r.
AllBackendsSatisfy c =>
AnyBackend i -> (forall (b :: BackendType). c b => i b -> r) -> r
AB.dispatchAnyBackend @BackendTransport
AnyBackend MultiplexedSubscriptionQueryPlan
exists
\(E.MultiplexedSubscriptionQueryPlan SubscriptionQueryPlan b (MultiplexedQuery b)
streamQueryPlan) ->
Logger Hasura
-> ServerMetrics
-> PrometheusMetrics
-> SubscriberMetadata
-> SubscriptionsState
-> SourceName
-> ParameterizedQueryHash
-> Maybe OperationName
-> RequestId
-> Name
-> SubscriptionQueryPlan b (MultiplexedQuery b)
-> OnChange
-> IO (SubscriberDetails (CohortKey, TVar CursorVariableValues))
forall (b :: BackendType).
BackendTransport b =>
Logger Hasura
-> ServerMetrics
-> PrometheusMetrics
-> SubscriberMetadata
-> SubscriptionsState
-> SourceName
-> ParameterizedQueryHash
-> Maybe OperationName
-> RequestId
-> Name
-> SubscriptionQueryPlan b (MultiplexedQuery b)
-> OnChange
-> IO (SubscriberDetails (CohortKey, TVar CursorVariableValues))
ES.addStreamSubscriptionQuery
Logger Hasura
logger
(WSServerEnv -> ServerMetrics
_wseServerMetrics WSServerEnv
serverEnv)
(WSServerEnv -> PrometheusMetrics
_wsePrometheusMetrics WSServerEnv
serverEnv)
SubscriberMetadata
subscriberMetadata
SubscriptionsState
subscriptionsState
SourceName
sourceName
ParameterizedQueryHash
parameterizedQueryHash
Maybe OperationName
opName
RequestId
requestId
(RootFieldAlias -> Name
_rfaAlias RootFieldAlias
rootFieldName)
SubscriptionQueryPlan b (MultiplexedQuery b)
streamQueryPlan
(Maybe OperationName
-> ParameterizedQueryHash -> Maybe Name -> OnChange
onChange Maybe OperationName
opName ParameterizedQueryHash
parameterizedQueryHash (Maybe Name -> OnChange) -> Maybe Name -> OnChange
forall a b. (a -> b) -> a -> b
$ SubscriptionQueryPlan b (MultiplexedQuery b) -> Maybe Name
forall (b :: BackendType) q.
SubscriptionQueryPlan b q -> Maybe Name
ES._sqpNamespace SubscriptionQueryPlan b (MultiplexedQuery b)
streamQueryPlan)
IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String
String
-> (SubscriberDetails (CohortKey, TVar CursorVariableValues),
Maybe OperationName)
-> IO ()
forall a. String -> a -> IO ()
$assertNFHere (SubscriberDetails (CohortKey, TVar CursorVariableValues)
streamSubscriberId, Maybe OperationName
opName)
STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
(SubscriberType, Maybe OperationName)
-> OperationId -> OperationMap -> STM ()
forall key value.
(Eq key, Hashable key) =>
value -> key -> Map key value -> STM ()
STMMap.insert (SubscriberDetails (CohortKey, TVar CursorVariableValues)
-> SubscriberType
StreamingQuerySubscriber SubscriberDetails (CohortKey, TVar CursorVariableValues)
streamSubscriberId, Maybe OperationName
opName) OperationId
opId OperationMap
opMap
() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
onChange :: Maybe OperationName -> ParameterizedQueryHash -> Maybe Name -> ES.OnChange
onChange :: Maybe OperationName
-> ParameterizedQueryHash -> Maybe Name -> OnChange
onChange Maybe OperationName
opName ParameterizedQueryHash
queryHash Maybe Name
namespace = \case
Right (ES.SubscriptionResponse ByteString
bs DiffTime
dTime) ->
WSConn
-> ServerMsg
-> Maybe OperationName
-> Maybe ParameterizedQueryHash
-> SubscriptionMetadata
-> IO ()
forall (m :: * -> *).
MonadIO m =>
WSConn
-> ServerMsg
-> Maybe OperationName
-> Maybe ParameterizedQueryHash
-> SubscriptionMetadata
-> m ()
sendMsgWithMetadata
WSConn
wsConn
(DataMsg -> ServerMsg
sendDataMsg (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
$ ByteString -> GQResponse
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> GQResponse) -> ByteString -> GQResponse
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString)
-> (Name -> ByteString -> ByteString)
-> Maybe Name
-> ByteString
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString -> ByteString
LBS.fromStrict Name -> ByteString -> ByteString
wrapNamespace Maybe Name
namespace ByteString
bs)
Maybe OperationName
opName
(ParameterizedQueryHash -> Maybe ParameterizedQueryHash
forall a. a -> Maybe a
Just ParameterizedQueryHash
queryHash)
(DiffTime -> SubscriptionMetadata
ES.SubscriptionMetadata DiffTime
dTime)
Either GQExecError SubscriptionResponse
resp ->
WSConn -> ServerMsg -> IO ()
forall (m :: * -> *). MonadIO m => WSConn -> ServerMsg -> m ()
sendMsg WSConn
wsConn (ServerMsg -> IO ()) -> ServerMsg -> IO ()
forall a b. (a -> b) -> a -> b
$
DataMsg -> ServerMsg
sendDataMsg (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
$ ByteString -> ByteString
LBS.fromStrict (ByteString -> ByteString)
-> (SubscriptionResponse -> ByteString)
-> SubscriptionResponse
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SubscriptionResponse -> ByteString
ES._lqrPayload (SubscriptionResponse -> ByteString)
-> Either GQExecError SubscriptionResponse -> GQResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either GQExecError SubscriptionResponse
resp
wrapNamespace :: Name -> ByteString -> LBS.ByteString
wrapNamespace :: Name -> ByteString -> ByteString
wrapNamespace Name
namespace ByteString
bs =
EncJSON -> ByteString
encJToLBS (EncJSON -> ByteString) -> EncJSON -> ByteString
forall a b. (a -> b) -> a -> b
$ [(Text, EncJSON)] -> EncJSON
encJFromAssocList [(Name -> Text
unName Name
namespace, ByteString -> EncJSON
encJFromBS ByteString
bs)]
catchAndIgnore :: ExceptT () m () -> m ()
catchAndIgnore :: ExceptT () m () -> m ()
catchAndIgnore ExceptT () m ()
m = m (Either () ()) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Either () ()) -> m ()) -> m (Either () ()) -> m ()
forall a b. (a -> b) -> a -> b
$ ExceptT () m () -> m (Either () ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT () m ()
m
reportGQLQueryError :: Maybe G.OperationType -> IO ()
reportGQLQueryError :: Maybe OperationType -> IO ()
reportGQLQueryError = \case
Maybe OperationType
Nothing ->
IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Counter -> IO ()
Prometheus.Counter.inc (GraphQLRequestMetrics -> Counter
gqlRequestsUnknownFailure GraphQLRequestMetrics
gqlMetrics)
Just OperationType
opType -> case OperationType
opType of
OperationType
G.OperationTypeQuery ->
IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Counter -> IO ()
Prometheus.Counter.inc (GraphQLRequestMetrics -> Counter
gqlRequestsQueryFailure GraphQLRequestMetrics
gqlMetrics)
OperationType
G.OperationTypeMutation ->
IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Counter -> IO ()
Prometheus.Counter.inc (GraphQLRequestMetrics -> Counter
gqlRequestsMutationFailure GraphQLRequestMetrics
gqlMetrics)
OperationType
G.OperationTypeSubscription ->
() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
recordGQLQuerySuccess :: DiffTime -> G.OperationType -> IO ()
recordGQLQuerySuccess :: DiffTime -> OperationType -> IO ()
recordGQLQuerySuccess DiffTime
totalTime = \case
OperationType
G.OperationTypeQuery -> IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Counter -> IO ()
Prometheus.Counter.inc (GraphQLRequestMetrics -> Counter
gqlRequestsQuerySuccess GraphQLRequestMetrics
gqlMetrics)
Histogram -> Double -> IO ()
Prometheus.Histogram.observe (GraphQLRequestMetrics -> Histogram
gqlExecutionTimeSecondsQuery GraphQLRequestMetrics
gqlMetrics) (DiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac DiffTime
totalTime)
OperationType
G.OperationTypeMutation -> IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Counter -> IO ()
Prometheus.Counter.inc (GraphQLRequestMetrics -> Counter
gqlRequestsMutationSuccess GraphQLRequestMetrics
gqlMetrics)
Histogram -> Double -> IO ()
Prometheus.Histogram.observe (GraphQLRequestMetrics -> Histogram
gqlExecutionTimeSecondsMutation GraphQLRequestMetrics
gqlMetrics) (DiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac DiffTime
totalTime)
OperationType
G.OperationTypeSubscription ->
() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
onMessage ::
( MonadIO m,
UserAuthentication (Tracing.TraceT m),
E.MonadGQLExecutionCheck m,
MonadQueryLog m,
Tracing.HasReporter m,
MonadExecuteQuery m,
MC.MonadBaseControl IO m,
MonadMetadataStorage (MetadataStorageT m),
EB.MonadQueryTags m,
HasResourceLimits m
) =>
Env.Environment ->
HashSet (L.EngineLogType L.Hasura) ->
AuthMode ->
WSServerEnv ->
WSConn ->
LBS.ByteString ->
WS.WSActions WSConnData ->
m ()
onMessage :: Environment
-> HashSet (EngineLogType Hasura)
-> AuthMode
-> WSServerEnv
-> WSConn
-> ByteString
-> WSActions WSConnData
-> m ()
onMessage Environment
env HashSet (EngineLogType Hasura)
enabledLogTypes AuthMode
authMode WSServerEnv
serverEnv WSConn
wsConn ByteString
msgRaw WSActions WSConnData
onMessageActions = Text -> TraceT m () -> m ()
forall (m :: * -> *) a.
(HasReporter m, MonadIO m) =>
Text -> TraceT m a -> m a
Tracing.runTraceT Text
"websocket" do
case ByteString -> Either String ClientMsg
forall a. FromJSON a => ByteString -> Either String a
J.eitherDecode ByteString
msgRaw of
Left String
e -> do
let err :: ConnErrMsg
err = Text -> ConnErrMsg
ConnErrMsg (Text -> ConnErrMsg) -> Text -> ConnErrMsg
forall a b. (a -> b) -> a -> b
$ Text
"parsing ClientMessage failed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e
Logger Hasura -> WSConn -> WSEvent -> TraceT m ()
forall (m :: * -> *).
MonadIO m =>
Logger Hasura -> WSConn -> WSEvent -> m ()
logWSEvent Logger Hasura
logger WSConn
wsConn (WSEvent -> TraceT m ()) -> WSEvent -> TraceT m ()
forall a b. (a -> b) -> a -> b
$ ConnErrMsg -> WSEvent
EConnErr ConnErrMsg
err
IO () -> TraceT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TraceT m ()) -> IO () -> TraceT m ()
forall a b. (a -> b) -> a -> b
$ WSOnErrorMessageAction WSConnData
onErrAction WSConn
wsConn ConnErrMsg
err Maybe String
WS.onClientMessageParseErrorText
Right ClientMsg
msg -> case ClientMsg
msg of
CMConnInit Maybe ConnParams
params ->
Logger Hasura
-> Manager
-> WSConn
-> AuthMode
-> Maybe ConnParams
-> WSOnErrorMessageAction WSConnData
-> WSKeepAliveMessageAction WSConnData
-> TraceT m ()
forall (m :: * -> *).
(MonadIO m, UserAuthentication (TraceT m)) =>
Logger Hasura
-> Manager
-> WSConn
-> AuthMode
-> Maybe ConnParams
-> WSOnErrorMessageAction WSConnData
-> WSKeepAliveMessageAction WSConnData
-> TraceT m ()
onConnInit
Logger Hasura
logger
(WSServerEnv -> Manager
_wseHManager WSServerEnv
serverEnv)
WSConn
wsConn
AuthMode
authMode
Maybe ConnParams
params
WSOnErrorMessageAction WSConnData
onErrAction
WSKeepAliveMessageAction WSConnData
keepAliveMessageAction
CMStart StartMsg
startMsg -> Environment
-> HashSet (EngineLogType Hasura)
-> WSServerEnv
-> WSConn
-> StartMsg
-> WSActions WSConnData
-> TraceT m ()
forall (m :: * -> *).
(MonadIO m, MonadGQLExecutionCheck m, MonadQueryLog m,
MonadTrace m, MonadExecuteQuery m, MonadBaseControl IO m,
MonadMetadataStorage (MetadataStorageT m), MonadQueryTags m,
HasResourceLimits m) =>
Environment
-> HashSet (EngineLogType Hasura)
-> WSServerEnv
-> WSConn
-> StartMsg
-> WSActions WSConnData
-> m ()
onStart Environment
env HashSet (EngineLogType Hasura)
enabledLogTypes WSServerEnv
serverEnv WSConn
wsConn StartMsg
startMsg WSActions WSConnData
onMessageActions
CMStop StopMsg
stopMsg -> WSServerEnv -> WSConn -> StopMsg -> TraceT m ()
forall (m :: * -> *).
MonadIO m =>
WSServerEnv -> WSConn -> StopMsg -> m ()
onStop WSServerEnv
serverEnv WSConn
wsConn StopMsg
stopMsg
CMPing Maybe PingPongPayload
mPayload -> WSConn -> Maybe PingPongPayload -> TraceT m ()
forall (m :: * -> *).
MonadIO m =>
WSConn -> Maybe PingPongPayload -> m ()
onPing WSConn
wsConn Maybe PingPongPayload
mPayload
CMPong Maybe PingPongPayload
mPayload -> WSConn -> Maybe PingPongPayload -> TraceT m ()
forall (m :: * -> *).
MonadIO m =>
WSConn -> Maybe PingPongPayload -> m ()
onPong WSConn
wsConn Maybe PingPongPayload
mPayload
ClientMsg
CMConnTerm -> IO () -> TraceT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TraceT m ()) -> IO () -> TraceT m ()
forall a b. (a -> b) -> a -> b
$ WSConn -> ByteString -> IO ()
forall a. WSConn a -> ByteString -> IO ()
WS.closeConn WSConn
wsConn ByteString
"GQL_CONNECTION_TERMINATE received"
where
logger :: Logger Hasura
logger = WSServerEnv -> Logger Hasura
_wseLogger WSServerEnv
serverEnv
onErrAction :: WSOnErrorMessageAction WSConnData
onErrAction = WSActions WSConnData -> WSOnErrorMessageAction WSConnData
forall a. WSActions a -> WSOnErrorMessageAction a
WS._wsaOnErrorMessageAction WSActions WSConnData
onMessageActions
keepAliveMessageAction :: WSKeepAliveMessageAction WSConnData
keepAliveMessageAction = WSActions WSConnData -> WSKeepAliveMessageAction WSConnData
forall a. WSActions a -> WSKeepAliveMessageAction a
WS._wsaKeepAliveAction WSActions WSConnData
onMessageActions
onPing :: (MonadIO m) => WSConn -> Maybe PingPongPayload -> m ()
onPing :: WSConn -> Maybe PingPongPayload -> m ()
onPing WSConn
wsConn Maybe PingPongPayload
mPayload =
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ WSConn -> ServerMsg -> IO ()
forall (m :: * -> *). MonadIO m => WSConn -> ServerMsg -> m ()
sendMsg WSConn
wsConn (Maybe PingPongPayload -> ServerMsg
SMPong Maybe PingPongPayload
mPayload)
onPong :: (MonadIO m) => WSConn -> Maybe PingPongPayload -> m ()
onPong :: WSConn -> Maybe PingPongPayload -> m ()
onPong WSConn
wsConn Maybe PingPongPayload
mPayload = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ case Maybe PingPongPayload
mPayload of
Just PingPongPayload
message ->
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PingPongPayload
message PingPongPayload -> PingPongPayload -> Bool
forall a. Eq a => a -> a -> Bool
/= PingPongPayload
keepAliveMessage) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
WSConn -> ServerMsg -> IO ()
forall (m :: * -> *). MonadIO m => WSConn -> ServerMsg -> m ()
sendMsg WSConn
wsConn (Maybe PingPongPayload -> ServerMsg
SMPing Maybe PingPongPayload
mPayload)
Maybe PingPongPayload
Nothing -> WSConn -> ServerMsg -> IO ()
forall (m :: * -> *). MonadIO m => WSConn -> ServerMsg -> m ()
sendMsg WSConn
wsConn (ServerMsg -> IO ()) -> ServerMsg -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe PingPongPayload -> ServerMsg
SMPing Maybe PingPongPayload
forall a. Maybe a
Nothing
onStop :: (MonadIO m) => WSServerEnv -> WSConn -> StopMsg -> m ()
onStop :: WSServerEnv -> WSConn -> StopMsg -> m ()
onStop WSServerEnv
serverEnv WSConn
wsConn (StopMsg OperationId
opId) = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
WSServerEnv -> WSConn -> OperationId -> IO () -> IO ()
stopOperation WSServerEnv
serverEnv WSConn
wsConn OperationId
opId (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Logger Hasura
-> forall a (m :: * -> *).
(ToEngineLog a Hasura, MonadIO m) =>
a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
(ToEngineLog a impl, MonadIO m) =>
a -> m ()
L.unLogger Logger Hasura
logger (UnstructuredLog -> IO ()) -> UnstructuredLog -> IO ()
forall a b. (a -> b) -> a -> b
$
LogLevel -> SerializableBlob -> UnstructuredLog
L.UnstructuredLog LogLevel
L.LevelDebug (SerializableBlob -> UnstructuredLog)
-> SerializableBlob -> UnstructuredLog
forall a b. (a -> b) -> a -> b
$
String -> SerializableBlob
forall a. IsString a => String -> a
fromString (String -> SerializableBlob) -> String -> SerializableBlob
forall a b. (a -> b) -> a -> b
$
String
"Received STOP for an operation that we have no record for: "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show (OperationId -> Text
unOperationId OperationId
opId)
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" (could be a query/mutation operation or a misbehaving client or a bug)"
where
logger :: Logger Hasura
logger = WSServerEnv -> Logger Hasura
_wseLogger WSServerEnv
serverEnv
stopOperation :: WSServerEnv -> WSConn -> OperationId -> IO () -> IO ()
stopOperation :: WSServerEnv -> WSConn -> OperationId -> IO () -> IO ()
stopOperation WSServerEnv
serverEnv WSConn
wsConn OperationId
opId IO ()
logWhenOpNotExist = do
Maybe (SubscriberType, Maybe OperationName)
opM <- IO (Maybe (SubscriberType, Maybe OperationName))
-> IO (Maybe (SubscriberType, Maybe OperationName))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (SubscriberType, Maybe OperationName))
-> IO (Maybe (SubscriberType, Maybe OperationName)))
-> IO (Maybe (SubscriberType, Maybe OperationName))
-> IO (Maybe (SubscriberType, Maybe OperationName))
forall a b. (a -> b) -> a -> b
$ STM (Maybe (SubscriberType, Maybe OperationName))
-> IO (Maybe (SubscriberType, Maybe OperationName))
forall a. STM a -> IO a
STM.atomically (STM (Maybe (SubscriberType, Maybe OperationName))
-> IO (Maybe (SubscriberType, Maybe OperationName)))
-> STM (Maybe (SubscriberType, Maybe OperationName))
-> IO (Maybe (SubscriberType, Maybe OperationName))
forall a b. (a -> b) -> a -> b
$ OperationId
-> OperationMap
-> STM (Maybe (SubscriberType, Maybe OperationName))
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM (Maybe value)
STMMap.lookup OperationId
opId OperationMap
opMap
case Maybe (SubscriberType, Maybe OperationName)
opM of
Just (SubscriberType
subscriberDetails, Maybe OperationName
opNameM) -> do
Logger Hasura -> WSConn -> WSEvent -> IO ()
forall (m :: * -> *).
MonadIO m =>
Logger Hasura -> WSConn -> WSEvent -> m ()
logWSEvent Logger Hasura
logger WSConn
wsConn (WSEvent -> IO ()) -> WSEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ OperationDetails -> WSEvent
EOperation (OperationDetails -> WSEvent) -> OperationDetails -> WSEvent
forall a b. (a -> b) -> a -> b
$ Maybe OperationName -> OperationDetails
opDet Maybe OperationName
opNameM
case SubscriberType
subscriberDetails of
LiveQuerySubscriber SubscriberDetails CohortKey
lqId ->
Logger Hasura
-> ServerMetrics
-> PrometheusMetrics
-> SubscriptionsState
-> SubscriberDetails CohortKey
-> IO ()
ES.removeLiveQuery Logger Hasura
logger (WSServerEnv -> ServerMetrics
_wseServerMetrics WSServerEnv
serverEnv) (WSServerEnv -> PrometheusMetrics
_wsePrometheusMetrics WSServerEnv
serverEnv) SubscriptionsState
subscriptionState SubscriberDetails CohortKey
lqId
StreamingQuerySubscriber SubscriberDetails (CohortKey, TVar CursorVariableValues)
streamSubscriberId ->
Logger Hasura
-> ServerMetrics
-> PrometheusMetrics
-> SubscriptionsState
-> SubscriberDetails (CohortKey, TVar CursorVariableValues)
-> IO ()
ES.removeStreamingQuery Logger Hasura
logger (WSServerEnv -> ServerMetrics
_wseServerMetrics WSServerEnv
serverEnv) (WSServerEnv -> PrometheusMetrics
_wsePrometheusMetrics WSServerEnv
serverEnv) SubscriptionsState
subscriptionState SubscriberDetails (CohortKey, TVar CursorVariableValues)
streamSubscriberId
Maybe (SubscriberType, Maybe OperationName)
Nothing -> IO ()
logWhenOpNotExist
STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ OperationId -> OperationMap -> STM ()
forall key value.
(Eq key, Hashable key) =>
key -> Map key value -> STM ()
STMMap.delete OperationId
opId OperationMap
opMap
where
logger :: Logger Hasura
logger = WSServerEnv -> Logger Hasura
_wseLogger WSServerEnv
serverEnv
subscriptionState :: SubscriptionsState
subscriptionState = WSServerEnv -> SubscriptionsState
_wseSubscriptionState WSServerEnv
serverEnv
opMap :: OperationMap
opMap = WSConnData -> OperationMap
_wscOpMap (WSConnData -> OperationMap) -> WSConnData -> OperationMap
forall a b. (a -> b) -> a -> b
$ WSConn -> WSConnData
forall a. WSConn a -> a
WS.getData WSConn
wsConn
opDet :: Maybe OperationName -> OperationDetails
opDet Maybe OperationName
n = OperationId
-> Maybe RequestId
-> Maybe OperationName
-> OpDetail
-> Maybe GQLReqUnparsed
-> Maybe ParameterizedQueryHash
-> OperationDetails
OperationDetails OperationId
opId Maybe RequestId
forall a. Maybe a
Nothing Maybe OperationName
n OpDetail
ODStopped Maybe GQLReqUnparsed
forall a. Maybe a
Nothing Maybe ParameterizedQueryHash
forall a. Maybe a
Nothing
onConnInit ::
(MonadIO m, UserAuthentication (Tracing.TraceT m)) =>
L.Logger L.Hasura ->
HTTP.Manager ->
WSConn ->
AuthMode ->
Maybe ConnParams ->
WS.WSOnErrorMessageAction WSConnData ->
WS.WSKeepAliveMessageAction WSConnData ->
Tracing.TraceT m ()
onConnInit :: Logger Hasura
-> Manager
-> WSConn
-> AuthMode
-> Maybe ConnParams
-> WSOnErrorMessageAction WSConnData
-> WSKeepAliveMessageAction WSConnData
-> TraceT m ()
onConnInit Logger Hasura
logger Manager
manager WSConn
wsConn AuthMode
authMode Maybe ConnParams
connParamsM WSOnErrorMessageAction WSConnData
onConnInitErrAction WSKeepAliveMessageAction WSConnData
keepAliveMessageAction = do
WSConnState
connState <- IO WSConnState -> TraceT m WSConnState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (TVar WSConnState -> IO WSConnState
forall a. TVar a -> IO a
STM.readTVarIO (WSConnData -> TVar WSConnState
_wscUser (WSConnData -> TVar WSConnState) -> WSConnData -> TVar WSConnState
forall a b. (a -> b) -> a -> b
$ WSConn -> WSConnData
forall a. WSConn a -> a
WS.getData WSConn
wsConn))
case WSConnState -> Either Text IpAddress
getIpAddress WSConnState
connState of
Left Text
err -> Text -> TraceT m ()
unexpectedInitError Text
err
Right IpAddress
ipAddress -> do
let headers :: [Header]
headers = WSConnState -> [Header]
mkHeaders WSConnState
connState
Either QErr (UserInfo, Maybe UTCTime, [Header])
res <- Logger Hasura
-> Manager
-> [Header]
-> AuthMode
-> Maybe ReqsText
-> TraceT m (Either QErr (UserInfo, Maybe UTCTime, [Header]))
forall (m :: * -> *).
UserAuthentication m =>
Logger Hasura
-> Manager
-> [Header]
-> AuthMode
-> Maybe ReqsText
-> m (Either QErr (UserInfo, Maybe UTCTime, [Header]))
resolveUserInfo Logger Hasura
logger Manager
manager [Header]
headers AuthMode
authMode Maybe ReqsText
forall a. Maybe a
Nothing
case Either QErr (UserInfo, Maybe UTCTime, [Header])
res of
Left QErr
e -> do
let !initErr :: WSConnState
initErr = Text -> WSConnState
CSInitError (Text -> WSConnState) -> Text -> WSConnState
forall a b. (a -> b) -> a -> b
$ QErr -> Text
qeError QErr
e
IO () -> TraceT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TraceT m ()) -> IO () -> TraceT m ()
forall a b. (a -> b) -> a -> b
$ do
String
String -> WSConnState -> IO ()
forall a. String -> a -> IO ()
$assertNFHere WSConnState
initErr
STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar WSConnState -> WSConnState -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar (WSConnData -> TVar WSConnState
_wscUser (WSConnData -> TVar WSConnState) -> WSConnData -> TVar WSConnState
forall a b. (a -> b) -> a -> b
$ WSConn -> WSConnData
forall a. WSConn a -> a
WS.getData WSConn
wsConn) WSConnState
initErr
let connErr :: ConnErrMsg
connErr = Text -> ConnErrMsg
ConnErrMsg (Text -> ConnErrMsg) -> Text -> ConnErrMsg
forall a b. (a -> b) -> a -> b
$ QErr -> Text
qeError QErr
e
Logger Hasura -> WSConn -> WSEvent -> TraceT m ()
forall (m :: * -> *).
MonadIO m =>
Logger Hasura -> WSConn -> WSEvent -> m ()
logWSEvent Logger Hasura
logger WSConn
wsConn (WSEvent -> TraceT m ()) -> WSEvent -> TraceT m ()
forall a b. (a -> b) -> a -> b
$ ConnErrMsg -> WSEvent
EConnErr ConnErrMsg
connErr
IO () -> TraceT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TraceT m ()) -> IO () -> TraceT m ()
forall a b. (a -> b) -> a -> b
$ WSOnErrorMessageAction WSConnData
onConnInitErrAction WSConn
wsConn ConnErrMsg
connErr Maybe String
WS.onConnInitErrorText
Right (UserInfo
userInfo, Maybe UTCTime
expTimeM, [Header]
_authHeaders) -> do
let !csInit :: WSConnState
csInit = WsClientState -> WSConnState
CSInitialised (WsClientState -> WSConnState) -> WsClientState -> WSConnState
forall a b. (a -> b) -> a -> b
$ UserInfo -> Maybe UTCTime -> [Header] -> IpAddress -> WsClientState
WsClientState UserInfo
userInfo Maybe UTCTime
expTimeM [Header]
paramHeaders IpAddress
ipAddress
IO () -> TraceT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TraceT m ()) -> IO () -> TraceT m ()
forall a b. (a -> b) -> a -> b
$ do
String
String -> WSConnState -> IO ()
forall a. String -> a -> IO ()
$assertNFHere WSConnState
csInit
STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar WSConnState -> WSConnState -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar (WSConnData -> TVar WSConnState
_wscUser (WSConnData -> TVar WSConnState) -> WSConnData -> TVar WSConnState
forall a b. (a -> b) -> a -> b
$ WSConn -> WSConnData
forall a. WSConn a -> a
WS.getData WSConn
wsConn) WSConnState
csInit
WSConn -> ServerMsg -> TraceT m ()
forall (m :: * -> *). MonadIO m => WSConn -> ServerMsg -> m ()
sendMsg WSConn
wsConn ServerMsg
SMConnAck
IO () -> TraceT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TraceT m ()) -> IO () -> TraceT m ()
forall a b. (a -> b) -> a -> b
$ WSKeepAliveMessageAction WSConnData
keepAliveMessageAction WSConn
wsConn
where
unexpectedInitError :: Text -> TraceT m ()
unexpectedInitError Text
e = do
let connErr :: ConnErrMsg
connErr = Text -> ConnErrMsg
ConnErrMsg Text
e
Logger Hasura -> WSConn -> WSEvent -> TraceT m ()
forall (m :: * -> *).
MonadIO m =>
Logger Hasura -> WSConn -> WSEvent -> m ()
logWSEvent Logger Hasura
logger WSConn
wsConn (WSEvent -> TraceT m ()) -> WSEvent -> TraceT m ()
forall a b. (a -> b) -> a -> b
$ ConnErrMsg -> WSEvent
EConnErr ConnErrMsg
connErr
IO () -> TraceT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TraceT m ()) -> IO () -> TraceT m ()
forall a b. (a -> b) -> a -> b
$ WSOnErrorMessageAction WSConnData
onConnInitErrAction WSConn
wsConn ConnErrMsg
connErr Maybe String
WS.onConnInitErrorText
getIpAddress :: WSConnState -> Either Text IpAddress
getIpAddress = \case
CSNotInitialised WsHeaders
_ IpAddress
ip -> IpAddress -> Either Text IpAddress
forall (m :: * -> *) a. Monad m => a -> m a
return IpAddress
ip
CSInitialised WsClientState {[Header]
Maybe UTCTime
UserInfo
IpAddress
wscsIpAddress :: IpAddress
wscsReqHeaders :: [Header]
wscsTokenExpTime :: Maybe UTCTime
wscsUserInfo :: UserInfo
wscsIpAddress :: WsClientState -> IpAddress
wscsReqHeaders :: WsClientState -> [Header]
wscsTokenExpTime :: WsClientState -> Maybe UTCTime
wscsUserInfo :: WsClientState -> UserInfo
..} -> IpAddress -> Either Text IpAddress
forall (m :: * -> *) a. Monad m => a -> m a
return IpAddress
wscsIpAddress
CSInitError Text
e -> Text -> Either Text IpAddress
forall a b. a -> Either a b
Left Text
e
mkHeaders :: WSConnState -> [Header]
mkHeaders WSConnState
st =
[Header]
paramHeaders [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++ WSConnState -> [Header]
getClientHdrs WSConnState
st
paramHeaders :: [Header]
paramHeaders =
[ (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> CI ByteString) -> ByteString -> CI ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
h, Text -> ByteString
TE.encodeUtf8 Text
v)
| (Text
h, Text
v) <- TracingMetadata
-> (HashMap Text Text -> TracingMetadata)
-> Maybe (HashMap Text Text)
-> TracingMetadata
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] HashMap Text Text -> TracingMetadata
forall k v. HashMap k v -> [(k, v)]
Map.toList (Maybe (HashMap Text Text) -> TracingMetadata)
-> Maybe (HashMap Text Text) -> TracingMetadata
forall a b. (a -> b) -> a -> b
$ Maybe ConnParams
connParamsM Maybe ConnParams
-> (ConnParams -> Maybe (HashMap Text Text))
-> Maybe (HashMap Text Text)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConnParams -> Maybe (HashMap Text Text)
_cpHeaders
]
getClientHdrs :: WSConnState -> [Header]
getClientHdrs WSConnState
st = case WSConnState
st of
CSNotInitialised WsHeaders
h IpAddress
_ -> WsHeaders -> [Header]
unWsHeaders WsHeaders
h
WSConnState
_ -> []
onClose ::
MonadIO m =>
L.Logger L.Hasura ->
ServerMetrics ->
PrometheusMetrics ->
ES.SubscriptionsState ->
WSConn ->
m ()
onClose :: Logger Hasura
-> ServerMetrics
-> PrometheusMetrics
-> SubscriptionsState
-> WSConn
-> m ()
onClose Logger Hasura
logger ServerMetrics
serverMetrics PrometheusMetrics
prometheusMetrics SubscriptionsState
subscriptionsState WSConn
wsConn = do
Logger Hasura -> WSConn -> WSEvent -> m ()
forall (m :: * -> *).
MonadIO m =>
Logger Hasura -> WSConn -> WSEvent -> m ()
logWSEvent Logger Hasura
logger WSConn
wsConn WSEvent
EClosed
[(OperationId, (SubscriberType, Maybe OperationName))]
operations <- IO [(OperationId, (SubscriberType, Maybe OperationName))]
-> m [(OperationId, (SubscriberType, Maybe OperationName))]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(OperationId, (SubscriberType, Maybe OperationName))]
-> m [(OperationId, (SubscriberType, Maybe OperationName))])
-> IO [(OperationId, (SubscriberType, Maybe OperationName))]
-> m [(OperationId, (SubscriberType, Maybe OperationName))]
forall a b. (a -> b) -> a -> b
$ STM [(OperationId, (SubscriberType, Maybe OperationName))]
-> IO [(OperationId, (SubscriberType, Maybe OperationName))]
forall a. STM a -> IO a
STM.atomically (STM [(OperationId, (SubscriberType, Maybe OperationName))]
-> IO [(OperationId, (SubscriberType, Maybe OperationName))])
-> STM [(OperationId, (SubscriberType, Maybe OperationName))]
-> IO [(OperationId, (SubscriberType, Maybe OperationName))]
forall a b. (a -> b) -> a -> b
$ ListT STM (OperationId, (SubscriberType, Maybe OperationName))
-> STM [(OperationId, (SubscriberType, Maybe OperationName))]
forall (m :: * -> *) a. Monad m => ListT m a -> m [a]
ListT.toList (ListT STM (OperationId, (SubscriberType, Maybe OperationName))
-> STM [(OperationId, (SubscriberType, Maybe OperationName))])
-> ListT STM (OperationId, (SubscriberType, Maybe OperationName))
-> STM [(OperationId, (SubscriberType, Maybe OperationName))]
forall a b. (a -> b) -> a -> b
$ OperationMap
-> ListT STM (OperationId, (SubscriberType, Maybe OperationName))
forall key value. Map key value -> ListT STM (key, value)
STMMap.listT OperationMap
opMap
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
[(OperationId, (SubscriberType, Maybe OperationName))]
-> ((OperationId, (SubscriberType, Maybe OperationName)) -> IO ())
-> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(OperationId, (SubscriberType, Maybe OperationName))]
operations (((OperationId, (SubscriberType, Maybe OperationName)) -> IO ())
-> IO ())
-> ((OperationId, (SubscriberType, Maybe OperationName)) -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(OperationId
_, (SubscriberType
subscriber, Maybe OperationName
_)) ->
case SubscriberType
subscriber of
LiveQuerySubscriber SubscriberDetails CohortKey
lqId -> Logger Hasura
-> ServerMetrics
-> PrometheusMetrics
-> SubscriptionsState
-> SubscriberDetails CohortKey
-> IO ()
ES.removeLiveQuery Logger Hasura
logger ServerMetrics
serverMetrics PrometheusMetrics
prometheusMetrics SubscriptionsState
subscriptionsState SubscriberDetails CohortKey
lqId
StreamingQuerySubscriber SubscriberDetails (CohortKey, TVar CursorVariableValues)
streamSubscriberId -> Logger Hasura
-> ServerMetrics
-> PrometheusMetrics
-> SubscriptionsState
-> SubscriberDetails (CohortKey, TVar CursorVariableValues)
-> IO ()
ES.removeStreamingQuery Logger Hasura
logger ServerMetrics
serverMetrics PrometheusMetrics
prometheusMetrics SubscriptionsState
subscriptionsState SubscriberDetails (CohortKey, TVar CursorVariableValues)
streamSubscriberId
where
opMap :: OperationMap
opMap = WSConnData -> OperationMap
_wscOpMap (WSConnData -> OperationMap) -> WSConnData -> OperationMap
forall a b. (a -> b) -> a -> b
$ WSConn -> WSConnData
forall a. WSConn a -> a
WS.getData WSConn
wsConn