{-# LANGUAGE CPP #-}

module Hasura.Server.App
  ( APIResp (JSONResp, RawResp),
    ConsoleRenderer (..),
    Handler,
    HandlerCtx (hcReqHeaders, hcServerCtx, hcUser),
    HasuraApp (HasuraApp),
    MonadConfigApiHandler (..),
    MonadMetadataApiAuthorization (..),
    ServerCtx (scManager, scLoggingSettings, scEnabledAPIs),
    boolToText,
    configApiGetHandler,
    isAdminSecretSet,
    mkGetHandler,
    mkSpockAction,
    mkWaiApp,
    onlyAdmin,
    renderHtmlTemplate,
  )
where

import Control.Concurrent.Async.Lifted.Safe qualified as LA
import Control.Exception (IOException, try)
import Control.Monad.Stateless
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Trans.Control qualified as MTC
import Data.Aeson hiding (json)
import Data.Aeson qualified as J
import Data.Aeson.Key qualified as K
import Data.Aeson.KeyMap qualified as KM
import Data.ByteString.Char8 qualified as B8
import Data.ByteString.Lazy qualified as BL
import Data.CaseInsensitive qualified as CI
import Data.Environment qualified as Env
import Data.HashMap.Strict qualified as M
import Data.HashSet qualified as S
import Data.String (fromString)
import Data.Text qualified as T
import Data.Text.Conversions (convertText)
import Data.Text.Extended
import Data.Text.Lazy qualified as LT
import Data.Text.Lazy.Encoding qualified as TL
import GHC.Stats.Extended qualified as RTS
import Hasura.Backends.DataConnector.API (openApiSchema)
import Hasura.Backends.Postgres.Execute.Types
import Hasura.Base.Error
import Hasura.EncJSON
import Hasura.GraphQL.Execute qualified as E
import Hasura.GraphQL.Execute.Backend qualified as EB
import Hasura.GraphQL.Execute.Subscription.Options qualified as ES
import Hasura.GraphQL.Execute.Subscription.Poll qualified as ES
import Hasura.GraphQL.Execute.Subscription.State qualified as ES
import Hasura.GraphQL.Explain qualified as GE
import Hasura.GraphQL.Logging (MonadQueryLog)
import Hasura.GraphQL.Schema.NamingCase
import Hasura.GraphQL.Schema.Options qualified as Options
import Hasura.GraphQL.Transport.HTTP qualified as GH
import Hasura.GraphQL.Transport.HTTP.Protocol qualified as GH
import Hasura.GraphQL.Transport.WSServerApp qualified as WS
import Hasura.GraphQL.Transport.WebSocket.Server qualified as WS
import Hasura.HTTP
import Hasura.Logging qualified as L
import Hasura.Metadata.Class
import Hasura.Prelude hiding (get, put)
import Hasura.RQL.DDL.Schema
import Hasura.RQL.Types.Common
import Hasura.RQL.Types.Endpoint as EP
import Hasura.RQL.Types.SchemaCache
import Hasura.RQL.Types.Source
import Hasura.SQL.Backend
import Hasura.Server.API.Config (runGetConfig)
import Hasura.Server.API.Metadata
import Hasura.Server.API.PGDump qualified as PGD
import Hasura.Server.API.Query
import Hasura.Server.API.V2Query qualified as V2Q
import Hasura.Server.Auth (AuthMode (..), UserAuthentication (..))
import Hasura.Server.Compression
import Hasura.Server.Cors
import Hasura.Server.Init
import Hasura.Server.Limits
import Hasura.Server.Logging
import Hasura.Server.Metrics (ServerMetrics)
import Hasura.Server.Middleware (corsMiddleware)
import Hasura.Server.OpenAPI (buildOpenAPI)
import Hasura.Server.Prometheus (PrometheusMetrics)
import Hasura.Server.Rest
import Hasura.Server.SchemaCacheRef
  ( SchemaCacheRef,
    getSchemaCache,
    readSchemaCacheRef,
    withSchemaCacheUpdate,
  )
import Hasura.Server.Types
import Hasura.Server.Utils
import Hasura.Server.Version
import Hasura.Session
import Hasura.Tracing qualified as Tracing
import Network.HTTP.Client qualified as HTTP
import Network.HTTP.Types qualified as HTTP
import Network.Mime (defaultMimeLookup)
import Network.Wai.Extended qualified as Wai
import Network.Wai.Handler.WebSockets.Custom qualified as WSC
import Network.WebSockets qualified as WS
import System.FilePath (joinPath, takeFileName)
import System.Mem (performMajorGC)
import System.Metrics qualified as EKG
import System.Metrics.Json qualified as EKG
import Text.Mustache qualified as M
import Web.Spock.Core ((<//>))
import Web.Spock.Core qualified as Spock

data ServerCtx = ServerCtx
  { ServerCtx -> Logger Hasura
scLogger :: !(L.Logger L.Hasura),
    ServerCtx -> SchemaCacheRef
scCacheRef :: !SchemaCacheRef,
    ServerCtx -> AuthMode
scAuthMode :: !AuthMode,
    ServerCtx -> Manager
scManager :: !HTTP.Manager,
    ServerCtx -> SQLGenCtx
scSQLGenCtx :: !SQLGenCtx,
    ServerCtx -> HashSet API
scEnabledAPIs :: !(S.HashSet API),
    ServerCtx -> InstanceId
scInstanceId :: !InstanceId,
    ServerCtx -> SubscriptionsState
scSubscriptionState :: !ES.SubscriptionsState,
    ServerCtx -> Bool
scEnableAllowlist :: !Bool,
    ServerCtx -> Store EmptyMetrics
scEkgStore :: !(EKG.Store EKG.EmptyMetrics),
    ServerCtx -> ResponseInternalErrorsConfig
scResponseInternalErrorsConfig :: !ResponseInternalErrorsConfig,
    ServerCtx -> Environment
scEnvironment :: !Env.Environment,
    ServerCtx -> RemoteSchemaPermissions
scRemoteSchemaPermsCtx :: !Options.RemoteSchemaPermissions,
    ServerCtx -> InferFunctionPermissions
scFunctionPermsCtx :: !Options.InferFunctionPermissions,
    ServerCtx -> MaintenanceMode ()
scEnableMaintenanceMode :: !(MaintenanceMode ()),
    ServerCtx -> HashSet ExperimentalFeature
scExperimentalFeatures :: !(S.HashSet ExperimentalFeature),
    ServerCtx -> LoggingSettings
scLoggingSettings :: !LoggingSettings,
    ServerCtx -> EventingMode
scEventingMode :: !EventingMode,
    ServerCtx -> ReadOnlyMode
scEnableReadOnlyMode :: !ReadOnlyMode,
    ServerCtx -> Maybe NamingCase
scDefaultNamingConvention :: !(Maybe NamingCase),
    ServerCtx -> PrometheusMetrics
scPrometheusMetrics :: !PrometheusMetrics
  }

data HandlerCtx = HandlerCtx
  { HandlerCtx -> ServerCtx
hcServerCtx :: !ServerCtx,
    HandlerCtx -> UserInfo
hcUser :: !UserInfo,
    HandlerCtx -> [Header]
hcReqHeaders :: ![HTTP.Header],
    HandlerCtx -> RequestId
hcRequestId :: !RequestId,
    HandlerCtx -> IpAddress
hcSourceIpAddress :: !Wai.IpAddress
  }

type Handler m = ReaderT HandlerCtx (MetadataStorageT m)

data APIResp
  = JSONResp !(HttpResponse EncJSON)
  | RawResp !(HttpResponse BL.ByteString)

-- | API request handlers for different endpoints
data APIHandler m a where
  -- | A simple GET request
  AHGet :: !(Handler m (HttpLogMetadata m, APIResp)) -> APIHandler m void
  -- | A simple POST request that expects a request body from which an 'a' can be extracted
  AHPost :: !(a -> Handler m (HttpLogMetadata m, APIResp)) -> APIHandler m a
  -- | A general GraphQL request (query or mutation) for which the content of the query
  -- is made available to the handler for authentication.
  -- This is a more specific version of the 'AHPost' constructor.
  AHGraphQLRequest :: !(GH.ReqsText -> Handler m (HttpLogMetadata m, APIResp)) -> APIHandler m GH.ReqsText

boolToText :: Bool -> Text
boolToText :: Bool -> Text
boolToText = Text -> Text -> Bool -> Text
forall a. a -> a -> Bool -> a
bool Text
"false" Text
"true"

isAdminSecretSet :: AuthMode -> Text
isAdminSecretSet :: AuthMode -> Text
isAdminSecretSet AuthMode
AMNoAuth = Bool -> Text
boolToText Bool
False
isAdminSecretSet AuthMode
_ = Bool -> Text
boolToText Bool
True

mkGetHandler :: Handler m (HttpLogMetadata m, APIResp) -> APIHandler m ()
mkGetHandler :: Handler m (HttpLogMetadata m, APIResp) -> APIHandler m ()
mkGetHandler = Handler m (HttpLogMetadata m, APIResp) -> APIHandler m ()
forall (m :: * -> *) void.
Handler m (HttpLogMetadata m, APIResp) -> APIHandler m void
AHGet

mkPostHandler :: (a -> Handler m (HttpLogMetadata m, APIResp)) -> APIHandler m a
mkPostHandler :: (a -> Handler m (HttpLogMetadata m, APIResp)) -> APIHandler m a
mkPostHandler = (a -> Handler m (HttpLogMetadata m, APIResp)) -> APIHandler m a
forall a (m :: * -> *).
(a -> Handler m (HttpLogMetadata m, APIResp)) -> APIHandler m a
AHPost

mkGQLRequestHandler :: (GH.ReqsText -> Handler m (HttpLogMetadata m, APIResp)) -> APIHandler m GH.ReqsText
mkGQLRequestHandler :: (ReqsText -> Handler m (HttpLogMetadata m, APIResp))
-> APIHandler m ReqsText
mkGQLRequestHandler = (ReqsText -> Handler m (HttpLogMetadata m, APIResp))
-> APIHandler m ReqsText
forall (m :: * -> *).
(ReqsText -> Handler m (HttpLogMetadata m, APIResp))
-> APIHandler m ReqsText
AHGraphQLRequest

mkAPIRespHandler :: (Functor m) => (a -> Handler m (HttpResponse EncJSON)) -> (a -> Handler m APIResp)
mkAPIRespHandler :: (a -> Handler m (HttpResponse EncJSON)) -> a -> Handler m APIResp
mkAPIRespHandler = ((Handler m (HttpResponse EncJSON) -> Handler m APIResp)
-> (a -> Handler m (HttpResponse EncJSON))
-> a
-> Handler m APIResp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Handler m (HttpResponse EncJSON) -> Handler m APIResp)
 -> (a -> Handler m (HttpResponse EncJSON))
 -> a
 -> Handler m APIResp)
-> ((HttpResponse EncJSON -> APIResp)
    -> Handler m (HttpResponse EncJSON) -> Handler m APIResp)
-> (HttpResponse EncJSON -> APIResp)
-> (a -> Handler m (HttpResponse EncJSON))
-> a
-> Handler m APIResp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HttpResponse EncJSON -> APIResp)
-> Handler m (HttpResponse EncJSON) -> Handler m APIResp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) HttpResponse EncJSON -> APIResp
JSONResp

mkGQLAPIRespHandler ::
  (Functor m) =>
  (a -> Handler m (b, (HttpResponse EncJSON))) ->
  (a -> Handler m (b, APIResp))
mkGQLAPIRespHandler :: (a -> Handler m (b, HttpResponse EncJSON))
-> a -> Handler m (b, APIResp)
mkGQLAPIRespHandler = ((Handler m (b, HttpResponse EncJSON) -> Handler m (b, APIResp))
-> (a -> Handler m (b, HttpResponse EncJSON))
-> a
-> Handler m (b, APIResp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Handler m (b, HttpResponse EncJSON) -> Handler m (b, APIResp))
 -> (a -> Handler m (b, HttpResponse EncJSON))
 -> a
 -> Handler m (b, APIResp))
-> ((HttpResponse EncJSON -> APIResp)
    -> Handler m (b, HttpResponse EncJSON) -> Handler m (b, APIResp))
-> (HttpResponse EncJSON -> APIResp)
-> (a -> Handler m (b, HttpResponse EncJSON))
-> a
-> Handler m (b, APIResp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((b, HttpResponse EncJSON) -> (b, APIResp))
-> Handler m (b, HttpResponse EncJSON) -> Handler m (b, APIResp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((b, HttpResponse EncJSON) -> (b, APIResp))
 -> Handler m (b, HttpResponse EncJSON) -> Handler m (b, APIResp))
-> ((HttpResponse EncJSON -> APIResp)
    -> (b, HttpResponse EncJSON) -> (b, APIResp))
-> (HttpResponse EncJSON -> APIResp)
-> Handler m (b, HttpResponse EncJSON)
-> Handler m (b, APIResp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HttpResponse EncJSON -> APIResp)
-> (b, HttpResponse EncJSON) -> (b, APIResp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) HttpResponse EncJSON -> APIResp
JSONResp

isMetadataEnabled :: ServerCtx -> Bool
isMetadataEnabled :: ServerCtx -> Bool
isMetadataEnabled ServerCtx
sc = API -> HashSet API -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member API
METADATA (HashSet API -> Bool) -> HashSet API -> Bool
forall a b. (a -> b) -> a -> b
$ ServerCtx -> HashSet API
scEnabledAPIs ServerCtx
sc

isGraphQLEnabled :: ServerCtx -> Bool
isGraphQLEnabled :: ServerCtx -> Bool
isGraphQLEnabled ServerCtx
sc = API -> HashSet API -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member API
GRAPHQL (HashSet API -> Bool) -> HashSet API -> Bool
forall a b. (a -> b) -> a -> b
$ ServerCtx -> HashSet API
scEnabledAPIs ServerCtx
sc

isPGDumpEnabled :: ServerCtx -> Bool
isPGDumpEnabled :: ServerCtx -> Bool
isPGDumpEnabled ServerCtx
sc = API -> HashSet API -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member API
PGDUMP (HashSet API -> Bool) -> HashSet API -> Bool
forall a b. (a -> b) -> a -> b
$ ServerCtx -> HashSet API
scEnabledAPIs ServerCtx
sc

isConfigEnabled :: ServerCtx -> Bool
isConfigEnabled :: ServerCtx -> Bool
isConfigEnabled ServerCtx
sc = API -> HashSet API -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member API
CONFIG (HashSet API -> Bool) -> HashSet API -> Bool
forall a b. (a -> b) -> a -> b
$ ServerCtx -> HashSet API
scEnabledAPIs ServerCtx
sc

isDeveloperAPIEnabled :: ServerCtx -> Bool
isDeveloperAPIEnabled :: ServerCtx -> Bool
isDeveloperAPIEnabled ServerCtx
sc = API -> HashSet API -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member API
DEVELOPER (HashSet API -> Bool) -> HashSet API -> Bool
forall a b. (a -> b) -> a -> b
$ ServerCtx -> HashSet API
scEnabledAPIs ServerCtx
sc

-- {-# SCC parseBody #-}
parseBody :: (FromJSON a, MonadError QErr m) => BL.ByteString -> m (Value, a)
parseBody :: ByteString -> m (Value, a)
parseBody ByteString
reqBody =
  case ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
eitherDecode' ByteString
reqBody of
    Left String
e -> Code -> Text -> m (Value, a)
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
InvalidJSON (String -> Text
T.pack String
e)
    Right Value
jVal -> (Value
jVal,) (a -> (Value, a)) -> m a -> m (Value, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> m a
forall a (m :: * -> *). (FromJSON a, QErrM m) => Value -> m a
decodeValue Value
jVal

onlyAdmin :: (MonadError QErr m, MonadReader HandlerCtx m) => m ()
onlyAdmin :: m ()
onlyAdmin = do
  RoleName
uRole <- (HandlerCtx -> RoleName) -> m RoleName
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (UserInfo -> RoleName
_uiRole (UserInfo -> RoleName)
-> (HandlerCtx -> UserInfo) -> HandlerCtx -> RoleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> UserInfo
hcUser)
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RoleName
uRole RoleName -> RoleName -> Bool
forall a. Eq a => a -> a -> Bool
== RoleName
adminRoleName) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    Code -> Text -> m ()
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
AccessDenied Text
"You have to be an admin to access this endpoint"

setHeader :: MonadIO m => HTTP.Header -> Spock.ActionT m ()
setHeader :: Header -> ActionT m ()
setHeader (HeaderName
headerName, ByteString
headerValue) =
  Text -> Text -> ActionT m ()
forall (m :: * -> *) ctx.
MonadIO m =>
Text -> Text -> ActionCtxT ctx m ()
Spock.setHeader (ByteString -> Text
bsToTxt (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ HeaderName -> ByteString
forall s. CI s -> s
CI.original HeaderName
headerName) (ByteString -> Text
bsToTxt ByteString
headerValue)

-- | Typeclass representing the metadata API authorization effect
class (Monad m) => MonadMetadataApiAuthorization m where
  authorizeV1QueryApi ::
    RQLQuery -> HandlerCtx -> m (Either QErr ())

  authorizeV1MetadataApi ::
    RQLMetadata -> HandlerCtx -> m (Either QErr ())

  authorizeV2QueryApi ::
    V2Q.RQLQuery -> HandlerCtx -> m (Either QErr ())

instance MonadMetadataApiAuthorization m => MonadMetadataApiAuthorization (ReaderT r m) where
  authorizeV1QueryApi :: RQLQuery -> HandlerCtx -> ReaderT r m (Either QErr ())
authorizeV1QueryApi RQLQuery
q HandlerCtx
hc = m (Either QErr ()) -> ReaderT r m (Either QErr ())
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either QErr ()) -> ReaderT r m (Either QErr ()))
-> m (Either QErr ()) -> ReaderT r m (Either QErr ())
forall a b. (a -> b) -> a -> b
$ RQLQuery -> HandlerCtx -> m (Either QErr ())
forall (m :: * -> *).
MonadMetadataApiAuthorization m =>
RQLQuery -> HandlerCtx -> m (Either QErr ())
authorizeV1QueryApi RQLQuery
q HandlerCtx
hc
  authorizeV1MetadataApi :: RQLMetadata -> HandlerCtx -> ReaderT r m (Either QErr ())
authorizeV1MetadataApi RQLMetadata
q HandlerCtx
hc = m (Either QErr ()) -> ReaderT r m (Either QErr ())
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either QErr ()) -> ReaderT r m (Either QErr ()))
-> m (Either QErr ()) -> ReaderT r m (Either QErr ())
forall a b. (a -> b) -> a -> b
$ RQLMetadata -> HandlerCtx -> m (Either QErr ())
forall (m :: * -> *).
MonadMetadataApiAuthorization m =>
RQLMetadata -> HandlerCtx -> m (Either QErr ())
authorizeV1MetadataApi RQLMetadata
q HandlerCtx
hc
  authorizeV2QueryApi :: RQLQuery -> HandlerCtx -> ReaderT r m (Either QErr ())
authorizeV2QueryApi RQLQuery
q HandlerCtx
hc = m (Either QErr ()) -> ReaderT r m (Either QErr ())
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either QErr ()) -> ReaderT r m (Either QErr ()))
-> m (Either QErr ()) -> ReaderT r m (Either QErr ())
forall a b. (a -> b) -> a -> b
$ RQLQuery -> HandlerCtx -> m (Either QErr ())
forall (m :: * -> *).
MonadMetadataApiAuthorization m =>
RQLQuery -> HandlerCtx -> m (Either QErr ())
authorizeV2QueryApi RQLQuery
q HandlerCtx
hc

instance MonadMetadataApiAuthorization m => MonadMetadataApiAuthorization (MetadataStorageT m) where
  authorizeV1QueryApi :: RQLQuery -> HandlerCtx -> MetadataStorageT m (Either QErr ())
authorizeV1QueryApi RQLQuery
q HandlerCtx
hc = m (Either QErr ()) -> MetadataStorageT m (Either QErr ())
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either QErr ()) -> MetadataStorageT m (Either QErr ()))
-> m (Either QErr ()) -> MetadataStorageT m (Either QErr ())
forall a b. (a -> b) -> a -> b
$ RQLQuery -> HandlerCtx -> m (Either QErr ())
forall (m :: * -> *).
MonadMetadataApiAuthorization m =>
RQLQuery -> HandlerCtx -> m (Either QErr ())
authorizeV1QueryApi RQLQuery
q HandlerCtx
hc
  authorizeV1MetadataApi :: RQLMetadata -> HandlerCtx -> MetadataStorageT m (Either QErr ())
authorizeV1MetadataApi RQLMetadata
q HandlerCtx
hc = m (Either QErr ()) -> MetadataStorageT m (Either QErr ())
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either QErr ()) -> MetadataStorageT m (Either QErr ()))
-> m (Either QErr ()) -> MetadataStorageT m (Either QErr ())
forall a b. (a -> b) -> a -> b
$ RQLMetadata -> HandlerCtx -> m (Either QErr ())
forall (m :: * -> *).
MonadMetadataApiAuthorization m =>
RQLMetadata -> HandlerCtx -> m (Either QErr ())
authorizeV1MetadataApi RQLMetadata
q HandlerCtx
hc
  authorizeV2QueryApi :: RQLQuery -> HandlerCtx -> MetadataStorageT m (Either QErr ())
authorizeV2QueryApi RQLQuery
q HandlerCtx
hc = m (Either QErr ()) -> MetadataStorageT m (Either QErr ())
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either QErr ()) -> MetadataStorageT m (Either QErr ()))
-> m (Either QErr ()) -> MetadataStorageT m (Either QErr ())
forall a b. (a -> b) -> a -> b
$ RQLQuery -> HandlerCtx -> m (Either QErr ())
forall (m :: * -> *).
MonadMetadataApiAuthorization m =>
RQLQuery -> HandlerCtx -> m (Either QErr ())
authorizeV2QueryApi RQLQuery
q HandlerCtx
hc

instance MonadMetadataApiAuthorization m => MonadMetadataApiAuthorization (Tracing.TraceT m) where
  authorizeV1QueryApi :: RQLQuery -> HandlerCtx -> TraceT m (Either QErr ())
authorizeV1QueryApi RQLQuery
q HandlerCtx
hc = m (Either QErr ()) -> TraceT m (Either QErr ())
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either QErr ()) -> TraceT m (Either QErr ()))
-> m (Either QErr ()) -> TraceT m (Either QErr ())
forall a b. (a -> b) -> a -> b
$ RQLQuery -> HandlerCtx -> m (Either QErr ())
forall (m :: * -> *).
MonadMetadataApiAuthorization m =>
RQLQuery -> HandlerCtx -> m (Either QErr ())
authorizeV1QueryApi RQLQuery
q HandlerCtx
hc
  authorizeV1MetadataApi :: RQLMetadata -> HandlerCtx -> TraceT m (Either QErr ())
authorizeV1MetadataApi RQLMetadata
q HandlerCtx
hc = m (Either QErr ()) -> TraceT m (Either QErr ())
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either QErr ()) -> TraceT m (Either QErr ()))
-> m (Either QErr ()) -> TraceT m (Either QErr ())
forall a b. (a -> b) -> a -> b
$ RQLMetadata -> HandlerCtx -> m (Either QErr ())
forall (m :: * -> *).
MonadMetadataApiAuthorization m =>
RQLMetadata -> HandlerCtx -> m (Either QErr ())
authorizeV1MetadataApi RQLMetadata
q HandlerCtx
hc
  authorizeV2QueryApi :: RQLQuery -> HandlerCtx -> TraceT m (Either QErr ())
authorizeV2QueryApi RQLQuery
q HandlerCtx
hc = m (Either QErr ()) -> TraceT m (Either QErr ())
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either QErr ()) -> TraceT m (Either QErr ()))
-> m (Either QErr ()) -> TraceT m (Either QErr ())
forall a b. (a -> b) -> a -> b
$ RQLQuery -> HandlerCtx -> m (Either QErr ())
forall (m :: * -> *).
MonadMetadataApiAuthorization m =>
RQLQuery -> HandlerCtx -> m (Either QErr ())
authorizeV2QueryApi RQLQuery
q HandlerCtx
hc

-- | The config API (/v1alpha1/config) handler
class Monad m => MonadConfigApiHandler m where
  runConfigApiHandler ::
    ServerCtx ->
    -- | console assets directory
    Maybe Text ->
    Spock.SpockCtxT () m ()

-- instance (MonadIO m, UserAuthentication m, HttpLog m, Tracing.HasReporter m) => MonadConfigApiHandler (Tracing.TraceT m) where
--   runConfigApiHandler = configApiGetHandler

mapActionT ::
  (Monad m, Monad n) =>
  (m (MTC.StT (Spock.ActionCtxT ()) a) -> n (MTC.StT (Spock.ActionCtxT ()) a)) ->
  Spock.ActionT m a ->
  Spock.ActionT n a
mapActionT :: (m (StT (ActionCtxT ()) a) -> n (StT (ActionCtxT ()) a))
-> ActionT m a -> ActionT n a
mapActionT m (StT (ActionCtxT ()) a) -> n (StT (ActionCtxT ()) a)
f ActionT m a
tma = n (Either ActionInterupt a, ResponseState, ()) -> ActionT n a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
m (StT t a) -> t m a
MTC.restoreT (n (Either ActionInterupt a, ResponseState, ()) -> ActionT n a)
-> ((Either ActionInterupt a, ResponseState, ())
    -> n (Either ActionInterupt a, ResponseState, ()))
-> (Either ActionInterupt a, ResponseState, ())
-> ActionT n a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either ActionInterupt a, ResponseState, ())
-> n (Either ActionInterupt a, ResponseState, ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Either ActionInterupt a, ResponseState, ()) -> ActionT n a)
-> ActionCtxT () n (Either ActionInterupt a, ResponseState, ())
-> ActionT n a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Run (ActionCtxT ())
 -> n (Either ActionInterupt a, ResponseState, ()))
-> ActionCtxT () n (Either ActionInterupt a, ResponseState, ())
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
(Run t -> m a) -> t m a
MTC.liftWith (\Run (ActionCtxT ())
run -> m (StT (ActionCtxT ()) a) -> n (StT (ActionCtxT ()) a)
f (ActionT m a -> m (StT (ActionCtxT ()) a)
Run (ActionCtxT ())
run ActionT m a
tma))

mkSpockAction ::
  (MonadIO m, MonadBaseControl IO m, FromJSON a, UserAuthentication (Tracing.TraceT m), HttpLog m, Tracing.HasReporter m, HasResourceLimits m) =>
  ServerCtx ->
  -- | `QErr` JSON encoder function
  (Bool -> QErr -> Value) ->
  -- | `QErr` modifier
  (QErr -> QErr) ->
  APIHandler (Tracing.TraceT m) a ->
  Spock.ActionT m ()
mkSpockAction :: ServerCtx
-> (Bool -> QErr -> Value)
-> (QErr -> QErr)
-> APIHandler (TraceT m) a
-> ActionT m ()
mkSpockAction serverCtx :: ServerCtx
serverCtx@ServerCtx {Bool
Maybe NamingCase
HashSet ExperimentalFeature
HashSet API
Logger Hasura
RemoteSchemaPermissions
InferFunctionPermissions
Environment
Store EmptyMetrics
PrometheusMetrics
Manager
SQLGenCtx
EventingMode
ReadOnlyMode
MaintenanceMode ()
InstanceId
LoggingSettings
SchemaCacheRef
AuthMode
ResponseInternalErrorsConfig
SubscriptionsState
scPrometheusMetrics :: PrometheusMetrics
scDefaultNamingConvention :: Maybe NamingCase
scEnableReadOnlyMode :: ReadOnlyMode
scEventingMode :: EventingMode
scLoggingSettings :: LoggingSettings
scExperimentalFeatures :: HashSet ExperimentalFeature
scEnableMaintenanceMode :: MaintenanceMode ()
scFunctionPermsCtx :: InferFunctionPermissions
scRemoteSchemaPermsCtx :: RemoteSchemaPermissions
scEnvironment :: Environment
scResponseInternalErrorsConfig :: ResponseInternalErrorsConfig
scEkgStore :: Store EmptyMetrics
scEnableAllowlist :: Bool
scSubscriptionState :: SubscriptionsState
scInstanceId :: InstanceId
scEnabledAPIs :: HashSet API
scSQLGenCtx :: SQLGenCtx
scManager :: Manager
scAuthMode :: AuthMode
scCacheRef :: SchemaCacheRef
scLogger :: Logger Hasura
scPrometheusMetrics :: ServerCtx -> PrometheusMetrics
scDefaultNamingConvention :: ServerCtx -> Maybe NamingCase
scEnableReadOnlyMode :: ServerCtx -> ReadOnlyMode
scEventingMode :: ServerCtx -> EventingMode
scExperimentalFeatures :: ServerCtx -> HashSet ExperimentalFeature
scEnableMaintenanceMode :: ServerCtx -> MaintenanceMode ()
scFunctionPermsCtx :: ServerCtx -> InferFunctionPermissions
scRemoteSchemaPermsCtx :: ServerCtx -> RemoteSchemaPermissions
scEnvironment :: ServerCtx -> Environment
scResponseInternalErrorsConfig :: ServerCtx -> ResponseInternalErrorsConfig
scEkgStore :: ServerCtx -> Store EmptyMetrics
scEnableAllowlist :: ServerCtx -> Bool
scSubscriptionState :: ServerCtx -> SubscriptionsState
scInstanceId :: ServerCtx -> InstanceId
scSQLGenCtx :: ServerCtx -> SQLGenCtx
scAuthMode :: ServerCtx -> AuthMode
scCacheRef :: ServerCtx -> SchemaCacheRef
scLogger :: ServerCtx -> Logger Hasura
scEnabledAPIs :: ServerCtx -> HashSet API
scLoggingSettings :: ServerCtx -> LoggingSettings
scManager :: ServerCtx -> Manager
..} Bool -> QErr -> Value
qErrEncoder QErr -> QErr
qErrModifier APIHandler (TraceT m) a
apiHandler = do
  Request
req <- ActionCtxT () m Request
forall (m :: * -> *) ctx. MonadIO m => ActionCtxT ctx m Request
Spock.request
  let origHeaders :: [Header]
origHeaders = Request -> [Header]
Wai.requestHeaders Request
req
      ipAddress :: IpAddress
ipAddress = Request -> IpAddress
Wai.getSourceFromFallback Request
req
      pathInfo :: ByteString
pathInfo = Request -> ByteString
Wai.rawPathInfo Request
req

  -- Bytes are actually read from the socket here. Time this.
  (DiffTime
ioWaitTime, ByteString
reqBody) <- ActionCtxT () m ByteString
-> ActionCtxT () m (DiffTime, ByteString)
forall (m :: * -> *) a. MonadIO m => m a -> m (DiffTime, a)
withElapsedTime (ActionCtxT () m ByteString
 -> ActionCtxT () m (DiffTime, ByteString))
-> ActionCtxT () m ByteString
-> ActionCtxT () m (DiffTime, ByteString)
forall a b. (a -> b) -> a -> b
$ IO ByteString -> ActionCtxT () m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ActionCtxT () m ByteString)
-> IO ByteString -> ActionCtxT () m ByteString
forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
Wai.strictRequestBody Request
req

  (RequestId
requestId, [Header]
headers) <- [Header] -> ActionCtxT () m (RequestId, [Header])
forall (m :: * -> *).
MonadIO m =>
[Header] -> m (RequestId, [Header])
getRequestId [Header]
origHeaders
  Maybe TraceContext
tracingCtx <- IO (Maybe TraceContext) -> ActionCtxT () m (Maybe TraceContext)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe TraceContext) -> ActionCtxT () m (Maybe TraceContext))
-> IO (Maybe TraceContext) -> ActionCtxT () m (Maybe TraceContext)
forall a b. (a -> b) -> a -> b
$ [Header] -> IO (Maybe TraceContext)
Tracing.extractHttpContext [Header]
headers
  ResourceLimits
handlerLimit <- m ResourceLimits -> ActionCtxT () m ResourceLimits
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m ResourceLimits
forall (m :: * -> *). HasResourceLimits m => m ResourceLimits
askHTTPHandlerLimit

  let runTraceT ::
        forall m a.
        (MonadIO m, Tracing.HasReporter m) =>
        Tracing.TraceT m a ->
        m a
      runTraceT :: TraceT m a -> m a
runTraceT =
        (Text -> TraceT m a -> m a)
-> (TraceContext -> Text -> TraceT m a -> m a)
-> Maybe TraceContext
-> Text
-> TraceT m a
-> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          Text -> TraceT m a -> m a
forall (m :: * -> *) a.
(HasReporter m, MonadIO m) =>
Text -> TraceT m a -> m a
Tracing.runTraceT
          TraceContext -> Text -> TraceT m a -> m a
forall (m :: * -> *) a.
(MonadIO m, HasReporter m) =>
TraceContext -> Text -> TraceT m a -> m a
Tracing.runTraceTInContext
          Maybe TraceContext
tracingCtx
          (String -> Text
forall a. IsString a => String -> a
fromString (ByteString -> String
B8.unpack ByteString
pathInfo))

      runHandler ::
        MonadBaseControl IO m =>
        HandlerCtx ->
        ReaderT HandlerCtx (MetadataStorageT m) a ->
        m (Either QErr a)
      runHandler :: HandlerCtx
-> ReaderT HandlerCtx (MetadataStorageT m) a -> m (Either QErr a)
runHandler HandlerCtx
handlerCtx ReaderT HandlerCtx (MetadataStorageT m) a
handler =
        MetadataStorageT m a -> m (Either QErr a)
forall (m :: * -> *) a. MetadataStorageT m a -> m (Either QErr a)
runMetadataStorageT (MetadataStorageT m a -> m (Either QErr a))
-> MetadataStorageT m a -> m (Either QErr a)
forall a b. (a -> b) -> a -> b
$ (ReaderT HandlerCtx (MetadataStorageT m) a
 -> HandlerCtx -> MetadataStorageT m a)
-> HandlerCtx
-> ReaderT HandlerCtx (MetadataStorageT m) a
-> MetadataStorageT m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT HandlerCtx (MetadataStorageT m) a
-> HandlerCtx -> MetadataStorageT m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT HandlerCtx
handlerCtx (ReaderT HandlerCtx (MetadataStorageT m) a -> MetadataStorageT m a)
-> ReaderT HandlerCtx (MetadataStorageT m) a
-> MetadataStorageT 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
handlerLimit (ReaderT HandlerCtx (MetadataStorageT m) a
 -> ReaderT HandlerCtx (MetadataStorageT m) a)
-> ReaderT HandlerCtx (MetadataStorageT m) a
-> ReaderT HandlerCtx (MetadataStorageT m) a
forall a b. (a -> b) -> a -> b
$ ReaderT HandlerCtx (MetadataStorageT m) a
handler

      getInfo :: Maybe ReqsText
-> ActionCtxT () (TraceT m) (UserInfo, [Header], HandlerCtx, Bool)
getInfo Maybe ReqsText
parsedRequest = do
        Either QErr (UserInfo, Maybe UTCTime, [Header])
authenticationResp <- TraceT m (Either QErr (UserInfo, Maybe UTCTime, [Header]))
-> ActionCtxT
     () (TraceT m) (Either QErr (UserInfo, Maybe UTCTime, [Header]))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (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
scLogger Manager
scManager [Header]
headers AuthMode
scAuthMode Maybe ReqsText
parsedRequest)
        (UserInfo, Maybe UTCTime, [Header])
authInfo <- Either QErr (UserInfo, Maybe UTCTime, [Header])
-> (QErr
    -> ActionCtxT () (TraceT m) (UserInfo, Maybe UTCTime, [Header]))
-> ActionCtxT () (TraceT m) (UserInfo, Maybe UTCTime, [Header])
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
onLeft Either QErr (UserInfo, Maybe UTCTime, [Header])
authenticationResp (Maybe UserInfo
-> RequestId
-> Request
-> (ByteString, Maybe Value)
-> Bool
-> [Header]
-> QErr
-> ActionCtxT () (TraceT m) (UserInfo, Maybe UTCTime, [Header])
forall (m :: * -> *) ctx a.
(MonadIO m, HttpLog m) =>
Maybe UserInfo
-> RequestId
-> Request
-> (ByteString, Maybe Value)
-> Bool
-> [Header]
-> QErr
-> ActionCtxT ctx m a
logErrorAndResp Maybe UserInfo
forall a. Maybe a
Nothing RequestId
requestId Request
req (ByteString
reqBody, Maybe Value
forall a. Maybe a
Nothing) Bool
False [Header]
origHeaders (QErr
 -> ActionCtxT () (TraceT m) (UserInfo, Maybe UTCTime, [Header]))
-> (QErr -> QErr)
-> QErr
-> ActionCtxT () (TraceT m) (UserInfo, Maybe UTCTime, [Header])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QErr -> QErr
qErrModifier)
        let (UserInfo
userInfo, Maybe UTCTime
_, [Header]
authHeaders) = (UserInfo, Maybe UTCTime, [Header])
authInfo
        (UserInfo, [Header], HandlerCtx, Bool)
-> ActionCtxT () (TraceT m) (UserInfo, [Header], HandlerCtx, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ( UserInfo
userInfo,
            [Header]
authHeaders,
            ServerCtx
-> UserInfo -> [Header] -> RequestId -> IpAddress -> HandlerCtx
HandlerCtx ServerCtx
serverCtx UserInfo
userInfo [Header]
headers RequestId
requestId IpAddress
ipAddress,
            RoleName -> ResponseInternalErrorsConfig -> Bool
shouldIncludeInternal (UserInfo -> RoleName
_uiRole UserInfo
userInfo) ResponseInternalErrorsConfig
scResponseInternalErrorsConfig
          )

  (TraceT m (StT (ActionCtxT ()) ()) -> m (StT (ActionCtxT ()) ()))
-> ActionT (TraceT m) () -> ActionT m ()
forall (m :: * -> *) (n :: * -> *) a.
(Monad m, Monad n) =>
(m (StT (ActionCtxT ()) a) -> n (StT (ActionCtxT ()) a))
-> ActionT m a -> ActionT n a
mapActionT TraceT m (StT (ActionCtxT ()) ()) -> m (StT (ActionCtxT ()) ())
forall (m :: * -> *) a.
(MonadIO m, HasReporter m) =>
TraceT m a -> m a
runTraceT (ActionT (TraceT m) () -> ActionT m ())
-> ActionT (TraceT m) () -> ActionT m ()
forall a b. (a -> b) -> a -> b
$ do
    -- Add the request ID to the tracing metadata so that we
    -- can correlate requests and traces
    TraceT m () -> ActionT (TraceT m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TraceT m () -> ActionT (TraceT m) ())
-> TraceT m () -> ActionT (TraceT m) ()
forall a b. (a -> b) -> a -> b
$ TracingMetadata -> TraceT m ()
forall (m :: * -> *). MonadTrace m => TracingMetadata -> m ()
Tracing.attachMetadata [(Text
"request_id", RequestId -> Text
unRequestId RequestId
requestId)]

    (DiffTime
serviceTime, (Either
  QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp)
result, UserInfo
userInfo, [Header]
authHeaders, Bool
includeInternal, Maybe Value
queryJSON)) <- ActionCtxT
  ()
  (TraceT m)
  (Either
     QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp),
   UserInfo, [Header], Bool, Maybe Value)
-> ActionCtxT
     ()
     (TraceT m)
     (DiffTime,
      (Either
         QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp),
       UserInfo, [Header], Bool, Maybe Value))
forall (m :: * -> *) a. MonadIO m => m a -> m (DiffTime, a)
withElapsedTime (ActionCtxT
   ()
   (TraceT m)
   (Either
      QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp),
    UserInfo, [Header], Bool, Maybe Value)
 -> ActionCtxT
      ()
      (TraceT m)
      (DiffTime,
       (Either
          QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp),
        UserInfo, [Header], Bool, Maybe Value)))
-> ActionCtxT
     ()
     (TraceT m)
     (Either
        QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp),
      UserInfo, [Header], Bool, Maybe Value)
-> ActionCtxT
     ()
     (TraceT m)
     (DiffTime,
      (Either
         QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp),
       UserInfo, [Header], Bool, Maybe Value))
forall a b. (a -> b) -> a -> b
$ case APIHandler (TraceT m) a
apiHandler of
      -- in the case of a simple get/post we don't have to send the webhook anything
      AHGet Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
handler -> do
        (UserInfo
userInfo, [Header]
authHeaders, HandlerCtx
handlerState, Bool
includeInternal) <- Maybe ReqsText
-> ActionCtxT () (TraceT m) (UserInfo, [Header], HandlerCtx, Bool)
getInfo Maybe ReqsText
forall a. Maybe a
Nothing
        Either
  QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp)
res <- TraceT
  m
  (Either
     QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp))
-> ActionCtxT
     ()
     (TraceT m)
     (Either
        QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TraceT
   m
   (Either
      QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp))
 -> ActionCtxT
      ()
      (TraceT m)
      (Either
         QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp)))
-> TraceT
     m
     (Either
        QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp))
-> ActionCtxT
     ()
     (TraceT m)
     (Either
        QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp))
forall a b. (a -> b) -> a -> b
$ HandlerCtx
-> ReaderT
     HandlerCtx
     (MetadataStorageT (TraceT m))
     ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp)
-> TraceT
     m
     (Either
        QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp))
forall (m :: * -> *) a.
MonadBaseControl IO m =>
HandlerCtx
-> ReaderT HandlerCtx (MetadataStorageT m) a -> m (Either QErr a)
runHandler HandlerCtx
handlerState ReaderT
  HandlerCtx
  (MetadataStorageT (TraceT m))
  ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp)
Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
handler
        (Either
   QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp),
 UserInfo, [Header], Bool, Maybe Value)
-> ActionCtxT
     ()
     (TraceT m)
     (Either
        QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp),
      UserInfo, [Header], Bool, Maybe Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
  QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp)
res, UserInfo
userInfo, [Header]
authHeaders, Bool
includeInternal, Maybe Value
forall a. Maybe a
Nothing)
      AHPost a -> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
handler -> do
        (UserInfo
userInfo, [Header]
authHeaders, HandlerCtx
handlerState, Bool
includeInternal) <- Maybe ReqsText
-> ActionCtxT () (TraceT m) (UserInfo, [Header], HandlerCtx, Bool)
getInfo Maybe ReqsText
forall a. Maybe a
Nothing
        (Value
queryJSON, a
parsedReq) <-
          Except QErr (Value, a) -> Either QErr (Value, a)
forall e a. Except e a -> Either e a
runExcept (ByteString -> Except QErr (Value, a)
forall a (m :: * -> *).
(FromJSON a, MonadError QErr m) =>
ByteString -> m (Value, a)
parseBody ByteString
reqBody) Either QErr (Value, a)
-> (QErr -> ActionCtxT () (TraceT m) (Value, a))
-> ActionCtxT () (TraceT m) (Value, a)
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
`onLeft` \QErr
e ->
            Maybe UserInfo
-> RequestId
-> Request
-> (ByteString, Maybe Value)
-> Bool
-> [Header]
-> QErr
-> ActionCtxT () (TraceT m) (Value, a)
forall (m :: * -> *) ctx a.
(MonadIO m, HttpLog m) =>
Maybe UserInfo
-> RequestId
-> Request
-> (ByteString, Maybe Value)
-> Bool
-> [Header]
-> QErr
-> ActionCtxT ctx m a
logErrorAndResp (UserInfo -> Maybe UserInfo
forall a. a -> Maybe a
Just UserInfo
userInfo) RequestId
requestId Request
req (ByteString
reqBody, Maybe Value
forall a. Maybe a
Nothing) Bool
includeInternal [Header]
origHeaders (QErr -> ActionCtxT () (TraceT m) (Value, a))
-> QErr -> ActionCtxT () (TraceT m) (Value, a)
forall a b. (a -> b) -> a -> b
$ QErr -> QErr
qErrModifier QErr
e
        Either
  QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp)
res <- TraceT
  m
  (Either
     QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp))
-> ActionCtxT
     ()
     (TraceT m)
     (Either
        QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TraceT
   m
   (Either
      QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp))
 -> ActionCtxT
      ()
      (TraceT m)
      (Either
         QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp)))
-> TraceT
     m
     (Either
        QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp))
-> ActionCtxT
     ()
     (TraceT m)
     (Either
        QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp))
forall a b. (a -> b) -> a -> b
$ HandlerCtx
-> ReaderT
     HandlerCtx
     (MetadataStorageT (TraceT m))
     ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp)
-> TraceT
     m
     (Either
        QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp))
forall (m :: * -> *) a.
MonadBaseControl IO m =>
HandlerCtx
-> ReaderT HandlerCtx (MetadataStorageT m) a -> m (Either QErr a)
runHandler HandlerCtx
handlerState (ReaderT
   HandlerCtx
   (MetadataStorageT (TraceT m))
   ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp)
 -> TraceT
      m
      (Either
         QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp)))
-> ReaderT
     HandlerCtx
     (MetadataStorageT (TraceT m))
     ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp)
-> TraceT
     m
     (Either
        QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp))
forall a b. (a -> b) -> a -> b
$ a -> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
handler a
parsedReq
        (Either
   QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp),
 UserInfo, [Header], Bool, Maybe Value)
-> ActionCtxT
     ()
     (TraceT m)
     (Either
        QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp),
      UserInfo, [Header], Bool, Maybe Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
  QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp)
res, UserInfo
userInfo, [Header]
authHeaders, Bool
includeInternal, Value -> Maybe Value
forall a. a -> Maybe a
Just Value
queryJSON)
      -- in this case we parse the request _first_ and then send the request to the webhook for auth
      AHGraphQLRequest ReqsText
-> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
handler -> do
        (Value
queryJSON, ReqsText
parsedReq) <-
          Except QErr (Value, ReqsText) -> Either QErr (Value, ReqsText)
forall e a. Except e a -> Either e a
runExcept (ByteString -> Except QErr (Value, ReqsText)
forall a (m :: * -> *).
(FromJSON a, MonadError QErr m) =>
ByteString -> m (Value, a)
parseBody ByteString
reqBody) Either QErr (Value, ReqsText)
-> (QErr -> ActionCtxT () (TraceT m) (Value, ReqsText))
-> ActionCtxT () (TraceT m) (Value, ReqsText)
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
`onLeft` \QErr
e -> do
            -- if the request fails to parse, call the webhook without a request body
            -- TODO should we signal this to the webhook somehow?
            (UserInfo
userInfo, [Header]
_, HandlerCtx
_, Bool
_) <- Maybe ReqsText
-> ActionCtxT () (TraceT m) (UserInfo, [Header], HandlerCtx, Bool)
getInfo Maybe ReqsText
forall a. Maybe a
Nothing
            Maybe UserInfo
-> RequestId
-> Request
-> (ByteString, Maybe Value)
-> Bool
-> [Header]
-> QErr
-> ActionCtxT () (TraceT m) (Value, ReqsText)
forall (m :: * -> *) ctx a.
(MonadIO m, HttpLog m) =>
Maybe UserInfo
-> RequestId
-> Request
-> (ByteString, Maybe Value)
-> Bool
-> [Header]
-> QErr
-> ActionCtxT ctx m a
logErrorAndResp (UserInfo -> Maybe UserInfo
forall a. a -> Maybe a
Just UserInfo
userInfo) RequestId
requestId Request
req (ByteString
reqBody, Maybe Value
forall a. Maybe a
Nothing) Bool
False [Header]
origHeaders (QErr -> ActionCtxT () (TraceT m) (Value, ReqsText))
-> QErr -> ActionCtxT () (TraceT m) (Value, ReqsText)
forall a b. (a -> b) -> a -> b
$ QErr -> QErr
qErrModifier QErr
e
        (UserInfo
userInfo, [Header]
authHeaders, HandlerCtx
handlerState, Bool
includeInternal) <- Maybe ReqsText
-> ActionCtxT () (TraceT m) (UserInfo, [Header], HandlerCtx, Bool)
getInfo (ReqsText -> Maybe ReqsText
forall a. a -> Maybe a
Just ReqsText
parsedReq)

        Either
  QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp)
res <- TraceT
  m
  (Either
     QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp))
-> ActionCtxT
     ()
     (TraceT m)
     (Either
        QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TraceT
   m
   (Either
      QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp))
 -> ActionCtxT
      ()
      (TraceT m)
      (Either
         QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp)))
-> TraceT
     m
     (Either
        QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp))
-> ActionCtxT
     ()
     (TraceT m)
     (Either
        QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp))
forall a b. (a -> b) -> a -> b
$ HandlerCtx
-> ReaderT
     HandlerCtx
     (MetadataStorageT (TraceT m))
     ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp)
-> TraceT
     m
     (Either
        QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp))
forall (m :: * -> *) a.
MonadBaseControl IO m =>
HandlerCtx
-> ReaderT HandlerCtx (MetadataStorageT m) a -> m (Either QErr a)
runHandler HandlerCtx
handlerState (ReaderT
   HandlerCtx
   (MetadataStorageT (TraceT m))
   ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp)
 -> TraceT
      m
      (Either
         QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp)))
-> ReaderT
     HandlerCtx
     (MetadataStorageT (TraceT m))
     ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp)
-> TraceT
     m
     (Either
        QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp))
forall a b. (a -> b) -> a -> b
$ ReqsText
-> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
handler ReqsText
parsedReq
        (Either
   QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp),
 UserInfo, [Header], Bool, Maybe Value)
-> ActionCtxT
     ()
     (TraceT m)
     (Either
        QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp),
      UserInfo, [Header], Bool, Maybe Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
  QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp)
res, UserInfo
userInfo, [Header]
authHeaders, Bool
includeInternal, Value -> Maybe Value
forall a. a -> Maybe a
Just Value
queryJSON)

    -- apply the error modifier
    let modResult :: Either
  QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp)
modResult = (QErr -> QErr)
-> Either
     QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp)
-> Either
     QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp)
forall a a' b. (a -> a') -> Either a b -> Either a' b
fmapL QErr -> QErr
qErrModifier Either
  QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp)
result

    -- log and return result
    case Either
  QErr ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp)
modResult of
      Left QErr
err ->
        Maybe UserInfo
-> RequestId
-> Request
-> (ByteString, Maybe Value)
-> Bool
-> [Header]
-> QErr
-> ActionT (TraceT m) ()
forall (m :: * -> *) ctx a.
(MonadIO m, HttpLog m) =>
Maybe UserInfo
-> RequestId
-> Request
-> (ByteString, Maybe Value)
-> Bool
-> [Header]
-> QErr
-> ActionCtxT ctx m a
logErrorAndResp (UserInfo -> Maybe UserInfo
forall a. a -> Maybe a
Just UserInfo
userInfo) RequestId
requestId Request
req (ByteString
reqBody, Maybe Value
queryJSON) Bool
includeInternal [Header]
headers QErr
err
      Right ((CommonHttpLogMetadata, ExtraHttpLogMetadata m)
httpLoggingMetadata, APIResp
res) ->
        Maybe UserInfo
-> RequestId
-> Request
-> (ByteString, Maybe Value)
-> APIResp
-> Maybe (DiffTime, DiffTime)
-> [Header]
-> [Header]
-> (CommonHttpLogMetadata, ExtraHttpLogMetadata m)
-> ActionT (TraceT m) ()
logSuccessAndResp (UserInfo -> Maybe UserInfo
forall a. a -> Maybe a
Just UserInfo
userInfo) RequestId
requestId Request
req (ByteString
reqBody, Maybe Value
queryJSON) APIResp
res ((DiffTime, DiffTime) -> Maybe (DiffTime, DiffTime)
forall a. a -> Maybe a
Just (DiffTime
ioWaitTime, DiffTime
serviceTime)) [Header]
origHeaders [Header]
authHeaders (CommonHttpLogMetadata, ExtraHttpLogMetadata m)
httpLoggingMetadata
  where
    logErrorAndResp ::
      (MonadIO m, HttpLog m) =>
      Maybe UserInfo ->
      RequestId ->
      Wai.Request ->
      (BL.ByteString, Maybe Value) ->
      Bool ->
      [HTTP.Header] ->
      QErr ->
      Spock.ActionCtxT ctx m a
    logErrorAndResp :: Maybe UserInfo
-> RequestId
-> Request
-> (ByteString, Maybe Value)
-> Bool
-> [Header]
-> QErr
-> ActionCtxT ctx m a
logErrorAndResp Maybe UserInfo
userInfo RequestId
reqId Request
waiReq (ByteString, Maybe Value)
req Bool
includeInternal [Header]
headers QErr
qErr = do
      m () -> ActionCtxT ctx m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ActionCtxT ctx m ()) -> m () -> ActionCtxT ctx m ()
forall a b. (a -> b) -> a -> b
$ Logger Hasura
-> LoggingSettings
-> Maybe UserInfo
-> RequestId
-> Request
-> (ByteString, Maybe Value)
-> QErr
-> [Header]
-> m ()
forall (m :: * -> *).
HttpLog m =>
Logger Hasura
-> LoggingSettings
-> Maybe UserInfo
-> RequestId
-> Request
-> (ByteString, Maybe Value)
-> QErr
-> [Header]
-> m ()
logHttpError Logger Hasura
scLogger LoggingSettings
scLoggingSettings Maybe UserInfo
userInfo RequestId
reqId Request
waiReq (ByteString, Maybe Value)
req QErr
qErr [Header]
headers
      Status -> ActionCtxT ctx m ()
forall (m :: * -> *) ctx.
MonadIO m =>
Status -> ActionCtxT ctx m ()
Spock.setStatus (Status -> ActionCtxT ctx m ()) -> Status -> ActionCtxT ctx m ()
forall a b. (a -> b) -> a -> b
$ QErr -> Status
qeStatus QErr
qErr
      Value -> ActionCtxT ctx m a
forall a (m :: * -> *) ctx b.
(ToJSON a, MonadIO m) =>
a -> ActionCtxT ctx m b
Spock.json (Value -> ActionCtxT ctx m a) -> Value -> ActionCtxT ctx m a
forall a b. (a -> b) -> a -> b
$ Bool -> QErr -> Value
qErrEncoder Bool
includeInternal QErr
qErr

    logSuccessAndResp :: Maybe UserInfo
-> RequestId
-> Request
-> (ByteString, Maybe Value)
-> APIResp
-> Maybe (DiffTime, DiffTime)
-> [Header]
-> [Header]
-> (CommonHttpLogMetadata, ExtraHttpLogMetadata m)
-> ActionT (TraceT m) ()
logSuccessAndResp Maybe UserInfo
userInfo RequestId
reqId Request
waiReq (ByteString, Maybe Value)
req APIResp
result Maybe (DiffTime, DiffTime)
qTime [Header]
reqHeaders [Header]
authHdrs (CommonHttpLogMetadata, ExtraHttpLogMetadata m)
httpLoggingMetadata = do
      let (ByteString
respBytes, [Header]
respHeaders) = case APIResp
result of
            JSONResp (HttpResponse EncJSON
encJson [Header]
h) -> (EncJSON -> ByteString
encJToLBS EncJSON
encJson, Header -> [Header]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Header
jsonHeader [Header] -> [Header] -> [Header]
forall a. Semigroup a => a -> a -> a
<> [Header]
h)
            RawResp (HttpResponse ByteString
rawBytes [Header]
h) -> (ByteString
rawBytes, [Header]
h)
          (ByteString
compressedResp, Maybe Header
mEncodingHeader, Maybe CompressionType
mCompressionType) = [Header]
-> ByteString -> (ByteString, Maybe Header, Maybe CompressionType)
compressResponse (Request -> [Header]
Wai.requestHeaders Request
waiReq) ByteString
respBytes
          encodingHeader :: [Header]
encodingHeader = Maybe Header -> [Header] -> [Header]
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
onNothing Maybe Header
mEncodingHeader []
          reqIdHeader :: Header
reqIdHeader = (HeaderName
forall a. IsString a => a
requestIdHeader, Text -> ByteString
txtToBs (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ RequestId -> Text
unRequestId RequestId
reqId)
          allRespHeaders :: [Header]
allRespHeaders = Header -> [Header]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Header
reqIdHeader [Header] -> [Header] -> [Header]
forall a. Semigroup a => a -> a -> a
<> [Header]
encodingHeader [Header] -> [Header] -> [Header]
forall a. Semigroup a => a -> a -> a
<> [Header]
respHeaders [Header] -> [Header] -> [Header]
forall a. Semigroup a => a -> a -> a
<> [Header]
authHdrs
      TraceT m () -> ActionT (TraceT m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TraceT m () -> ActionT (TraceT m) ())
-> TraceT m () -> ActionT (TraceT m) ()
forall a b. (a -> b) -> a -> b
$ Logger Hasura
-> LoggingSettings
-> Maybe UserInfo
-> RequestId
-> Request
-> (ByteString, Maybe Value)
-> ByteString
-> ByteString
-> Maybe (DiffTime, DiffTime)
-> Maybe CompressionType
-> [Header]
-> HttpLogMetadata (TraceT m)
-> TraceT m ()
forall (m :: * -> *).
HttpLog m =>
Logger Hasura
-> LoggingSettings
-> Maybe UserInfo
-> RequestId
-> Request
-> (ByteString, Maybe Value)
-> ByteString
-> ByteString
-> Maybe (DiffTime, DiffTime)
-> Maybe CompressionType
-> [Header]
-> HttpLogMetadata m
-> m ()
logHttpSuccess Logger Hasura
scLogger LoggingSettings
scLoggingSettings Maybe UserInfo
userInfo RequestId
reqId Request
waiReq (ByteString, Maybe Value)
req ByteString
respBytes ByteString
compressedResp Maybe (DiffTime, DiffTime)
qTime Maybe CompressionType
mCompressionType [Header]
reqHeaders (CommonHttpLogMetadata, ExtraHttpLogMetadata m)
HttpLogMetadata (TraceT m)
httpLoggingMetadata
      (Header -> ActionT (TraceT m) ())
-> [Header] -> ActionT (TraceT m) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Header -> ActionT (TraceT m) ()
forall (m :: * -> *). MonadIO m => Header -> ActionT m ()
setHeader [Header]
allRespHeaders
      ByteString -> ActionT (TraceT m) ()
forall (m :: * -> *) ctx a.
MonadIO m =>
ByteString -> ActionCtxT ctx m a
Spock.lazyBytes ByteString
compressedResp

v1QueryHandler ::
  ( MonadIO m,
    MonadBaseControl IO m,
    MonadMetadataApiAuthorization m,
    Tracing.MonadTrace m,
    MonadReader HandlerCtx m,
    MonadMetadataStorage m,
    MonadResolveSource m,
    EB.MonadQueryTags m
  ) =>
  RQLQuery ->
  m (HttpResponse EncJSON)
v1QueryHandler :: RQLQuery -> m (HttpResponse EncJSON)
v1QueryHandler RQLQuery
query = do
  (m (Either QErr ()) -> m ()
forall e (m :: * -> *) a. MonadError e m => m (Either e a) -> m a
liftEitherM (m (Either QErr ()) -> m ())
-> (HandlerCtx -> m (Either QErr ())) -> HandlerCtx -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RQLQuery -> HandlerCtx -> m (Either QErr ())
forall (m :: * -> *).
MonadMetadataApiAuthorization m =>
RQLQuery -> HandlerCtx -> m (Either QErr ())
authorizeV1QueryApi RQLQuery
query) (HandlerCtx -> m ()) -> m HandlerCtx -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m HandlerCtx
forall r (m :: * -> *). MonadReader r m => m r
ask
  SchemaCacheRef
scRef <- (HandlerCtx -> SchemaCacheRef) -> m SchemaCacheRef
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> SchemaCacheRef
scCacheRef (ServerCtx -> SchemaCacheRef)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> SchemaCacheRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
  Logger Hasura
logger <- (HandlerCtx -> Logger Hasura) -> m (Logger Hasura)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> Logger Hasura
scLogger (ServerCtx -> Logger Hasura)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> Logger Hasura
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
  EncJSON
res <- m EncJSON -> m EncJSON -> Bool -> m EncJSON
forall a. a -> a -> Bool -> a
bool ((EncJSON, RebuildableSchemaCache) -> EncJSON
forall a b. (a, b) -> a
fst ((EncJSON, RebuildableSchemaCache) -> EncJSON)
-> m (EncJSON, RebuildableSchemaCache) -> m EncJSON
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Logger Hasura -> m (EncJSON, RebuildableSchemaCache)
action Logger Hasura
logger)) (SchemaCacheRef
-> Logger Hasura
-> Maybe (TVar Bool)
-> m (EncJSON, RebuildableSchemaCache)
-> m EncJSON
forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m) =>
SchemaCacheRef
-> Logger Hasura
-> Maybe (TVar Bool)
-> m (a, RebuildableSchemaCache)
-> m a
withSchemaCacheUpdate SchemaCacheRef
scRef Logger Hasura
logger Maybe (TVar Bool)
forall a. Maybe a
Nothing (Logger Hasura -> m (EncJSON, RebuildableSchemaCache)
action Logger Hasura
logger)) (Bool -> m EncJSON) -> Bool -> m EncJSON
forall a b. (a -> b) -> a -> b
$ RQLQuery -> Bool
queryModifiesSchemaCache RQLQuery
query
  HttpResponse EncJSON -> m (HttpResponse EncJSON)
forall (m :: * -> *) a. Monad m => a -> m a
return (HttpResponse EncJSON -> m (HttpResponse EncJSON))
-> HttpResponse EncJSON -> m (HttpResponse EncJSON)
forall a b. (a -> b) -> a -> b
$ EncJSON -> [Header] -> HttpResponse EncJSON
forall a. a -> [Header] -> HttpResponse a
HttpResponse EncJSON
res []
  where
    action :: Logger Hasura -> m (EncJSON, RebuildableSchemaCache)
action Logger Hasura
logger = do
      UserInfo
userInfo <- (HandlerCtx -> UserInfo) -> m UserInfo
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks HandlerCtx -> UserInfo
hcUser
      SchemaCacheRef
scRef <- (HandlerCtx -> SchemaCacheRef) -> m SchemaCacheRef
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> SchemaCacheRef
scCacheRef (ServerCtx -> SchemaCacheRef)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> SchemaCacheRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
      RebuildableSchemaCache
schemaCache <- IO RebuildableSchemaCache -> m RebuildableSchemaCache
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RebuildableSchemaCache -> m RebuildableSchemaCache)
-> IO RebuildableSchemaCache -> m RebuildableSchemaCache
forall a b. (a -> b) -> a -> b
$ (RebuildableSchemaCache, SchemaCacheVer) -> RebuildableSchemaCache
forall a b. (a, b) -> a
fst ((RebuildableSchemaCache, SchemaCacheVer)
 -> RebuildableSchemaCache)
-> IO (RebuildableSchemaCache, SchemaCacheVer)
-> IO RebuildableSchemaCache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaCacheRef -> IO (RebuildableSchemaCache, SchemaCacheVer)
readSchemaCacheRef SchemaCacheRef
scRef
      Manager
httpMgr <- (HandlerCtx -> Manager) -> m Manager
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> Manager
scManager (ServerCtx -> Manager)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> Manager
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
      SQLGenCtx
sqlGenCtx <- (HandlerCtx -> SQLGenCtx) -> m SQLGenCtx
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> SQLGenCtx
scSQLGenCtx (ServerCtx -> SQLGenCtx)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> SQLGenCtx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
      InstanceId
instanceId <- (HandlerCtx -> InstanceId) -> m InstanceId
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> InstanceId
scInstanceId (ServerCtx -> InstanceId)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> InstanceId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
      Environment
env <- (HandlerCtx -> Environment) -> m Environment
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> Environment
scEnvironment (ServerCtx -> Environment)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> Environment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
      RemoteSchemaPermissions
remoteSchemaPermsCtx <- (HandlerCtx -> RemoteSchemaPermissions)
-> m RemoteSchemaPermissions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> RemoteSchemaPermissions
scRemoteSchemaPermsCtx (ServerCtx -> RemoteSchemaPermissions)
-> (HandlerCtx -> ServerCtx)
-> HandlerCtx
-> RemoteSchemaPermissions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
      InferFunctionPermissions
functionPermsCtx <- (HandlerCtx -> InferFunctionPermissions)
-> m InferFunctionPermissions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> InferFunctionPermissions
scFunctionPermsCtx (ServerCtx -> InferFunctionPermissions)
-> (HandlerCtx -> ServerCtx)
-> HandlerCtx
-> InferFunctionPermissions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
      MaintenanceMode ()
maintenanceMode <- (HandlerCtx -> MaintenanceMode ()) -> m (MaintenanceMode ())
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> MaintenanceMode ()
scEnableMaintenanceMode (ServerCtx -> MaintenanceMode ())
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> MaintenanceMode ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
      HashSet ExperimentalFeature
experimentalFeatures <- (HandlerCtx -> HashSet ExperimentalFeature)
-> m (HashSet ExperimentalFeature)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> HashSet ExperimentalFeature
scExperimentalFeatures (ServerCtx -> HashSet ExperimentalFeature)
-> (HandlerCtx -> ServerCtx)
-> HandlerCtx
-> HashSet ExperimentalFeature
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
      EventingMode
eventingMode <- (HandlerCtx -> EventingMode) -> m EventingMode
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> EventingMode
scEventingMode (ServerCtx -> EventingMode)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> EventingMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
      ReadOnlyMode
readOnlyMode <- (HandlerCtx -> ReadOnlyMode) -> m ReadOnlyMode
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> ReadOnlyMode
scEnableReadOnlyMode (ServerCtx -> ReadOnlyMode)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> ReadOnlyMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
      Maybe NamingCase
defaultNamingCase <- (HandlerCtx -> Maybe NamingCase) -> m (Maybe NamingCase)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> Maybe NamingCase
scDefaultNamingConvention (ServerCtx -> Maybe NamingCase)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> Maybe NamingCase
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
      let serverConfigCtx :: ServerConfigCtx
serverConfigCtx =
            InferFunctionPermissions
-> RemoteSchemaPermissions
-> SQLGenCtx
-> MaintenanceMode ()
-> HashSet ExperimentalFeature
-> EventingMode
-> ReadOnlyMode
-> Maybe NamingCase
-> ServerConfigCtx
ServerConfigCtx
              InferFunctionPermissions
functionPermsCtx
              RemoteSchemaPermissions
remoteSchemaPermsCtx
              SQLGenCtx
sqlGenCtx
              MaintenanceMode ()
maintenanceMode
              HashSet ExperimentalFeature
experimentalFeatures
              EventingMode
eventingMode
              ReadOnlyMode
readOnlyMode
              Maybe NamingCase
defaultNamingCase
      Environment
-> Logger Hasura
-> InstanceId
-> UserInfo
-> RebuildableSchemaCache
-> Manager
-> ServerConfigCtx
-> RQLQuery
-> m (EncJSON, RebuildableSchemaCache)
forall (m :: * -> *).
(MonadIO m, MonadTrace m, MonadBaseControl IO m,
 MonadMetadataStorage m, MonadResolveSource m, MonadQueryTags m) =>
Environment
-> Logger Hasura
-> InstanceId
-> UserInfo
-> RebuildableSchemaCache
-> Manager
-> ServerConfigCtx
-> RQLQuery
-> m (EncJSON, RebuildableSchemaCache)
runQuery
        Environment
env
        Logger Hasura
logger
        InstanceId
instanceId
        UserInfo
userInfo
        RebuildableSchemaCache
schemaCache
        Manager
httpMgr
        ServerConfigCtx
serverConfigCtx
        RQLQuery
query

v1MetadataHandler ::
  ( MonadIO m,
    MonadBaseControl IO m,
    MonadReader HandlerCtx m,
    Tracing.MonadTrace m,
    MonadMetadataStorage m,
    MonadResolveSource m,
    MonadMetadataApiAuthorization m
  ) =>
  RQLMetadata ->
  m (HttpResponse EncJSON)
v1MetadataHandler :: RQLMetadata -> m (HttpResponse EncJSON)
v1MetadataHandler RQLMetadata
query = Text -> m (HttpResponse EncJSON) -> m (HttpResponse EncJSON)
forall (m :: * -> *) a. MonadTrace m => Text -> m a -> m a
Tracing.trace Text
"Metadata" (m (HttpResponse EncJSON) -> m (HttpResponse EncJSON))
-> m (HttpResponse EncJSON) -> m (HttpResponse EncJSON)
forall a b. (a -> b) -> a -> b
$ do
  (m (Either QErr ()) -> m ()
forall e (m :: * -> *) a. MonadError e m => m (Either e a) -> m a
liftEitherM (m (Either QErr ()) -> m ())
-> (HandlerCtx -> m (Either QErr ())) -> HandlerCtx -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RQLMetadata -> HandlerCtx -> m (Either QErr ())
forall (m :: * -> *).
MonadMetadataApiAuthorization m =>
RQLMetadata -> HandlerCtx -> m (Either QErr ())
authorizeV1MetadataApi RQLMetadata
query) (HandlerCtx -> m ()) -> m HandlerCtx -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m HandlerCtx
forall r (m :: * -> *). MonadReader r m => m r
ask
  UserInfo
userInfo <- (HandlerCtx -> UserInfo) -> m UserInfo
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks HandlerCtx -> UserInfo
hcUser
  SchemaCacheRef
scRef <- (HandlerCtx -> SchemaCacheRef) -> m SchemaCacheRef
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> SchemaCacheRef
scCacheRef (ServerCtx -> SchemaCacheRef)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> SchemaCacheRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
  RebuildableSchemaCache
schemaCache <- IO RebuildableSchemaCache -> m RebuildableSchemaCache
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RebuildableSchemaCache -> m RebuildableSchemaCache)
-> IO RebuildableSchemaCache -> m RebuildableSchemaCache
forall a b. (a -> b) -> a -> b
$ (RebuildableSchemaCache, SchemaCacheVer) -> RebuildableSchemaCache
forall a b. (a, b) -> a
fst ((RebuildableSchemaCache, SchemaCacheVer)
 -> RebuildableSchemaCache)
-> IO (RebuildableSchemaCache, SchemaCacheVer)
-> IO RebuildableSchemaCache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaCacheRef -> IO (RebuildableSchemaCache, SchemaCacheVer)
readSchemaCacheRef SchemaCacheRef
scRef
  Manager
httpMgr <- (HandlerCtx -> Manager) -> m Manager
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> Manager
scManager (ServerCtx -> Manager)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> Manager
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
  SQLGenCtx
_sccSQLGenCtx <- (HandlerCtx -> SQLGenCtx) -> m SQLGenCtx
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> SQLGenCtx
scSQLGenCtx (ServerCtx -> SQLGenCtx)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> SQLGenCtx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
  Environment
env <- (HandlerCtx -> Environment) -> m Environment
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> Environment
scEnvironment (ServerCtx -> Environment)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> Environment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
  InstanceId
instanceId <- (HandlerCtx -> InstanceId) -> m InstanceId
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> InstanceId
scInstanceId (ServerCtx -> InstanceId)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> InstanceId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
  Logger Hasura
logger <- (HandlerCtx -> Logger Hasura) -> m (Logger Hasura)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> Logger Hasura
scLogger (ServerCtx -> Logger Hasura)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> Logger Hasura
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
  RemoteSchemaPermissions
_sccRemoteSchemaPermsCtx <- (HandlerCtx -> RemoteSchemaPermissions)
-> m RemoteSchemaPermissions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> RemoteSchemaPermissions
scRemoteSchemaPermsCtx (ServerCtx -> RemoteSchemaPermissions)
-> (HandlerCtx -> ServerCtx)
-> HandlerCtx
-> RemoteSchemaPermissions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
  InferFunctionPermissions
_sccFunctionPermsCtx <- (HandlerCtx -> InferFunctionPermissions)
-> m InferFunctionPermissions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> InferFunctionPermissions
scFunctionPermsCtx (ServerCtx -> InferFunctionPermissions)
-> (HandlerCtx -> ServerCtx)
-> HandlerCtx
-> InferFunctionPermissions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
  HashSet ExperimentalFeature
_sccExperimentalFeatures <- (HandlerCtx -> HashSet ExperimentalFeature)
-> m (HashSet ExperimentalFeature)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> HashSet ExperimentalFeature
scExperimentalFeatures (ServerCtx -> HashSet ExperimentalFeature)
-> (HandlerCtx -> ServerCtx)
-> HandlerCtx
-> HashSet ExperimentalFeature
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
  MaintenanceMode ()
_sccMaintenanceMode <- (HandlerCtx -> MaintenanceMode ()) -> m (MaintenanceMode ())
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> MaintenanceMode ()
scEnableMaintenanceMode (ServerCtx -> MaintenanceMode ())
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> MaintenanceMode ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
  EventingMode
_sccEventingMode <- (HandlerCtx -> EventingMode) -> m EventingMode
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> EventingMode
scEventingMode (ServerCtx -> EventingMode)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> EventingMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
  ReadOnlyMode
_sccReadOnlyMode <- (HandlerCtx -> ReadOnlyMode) -> m ReadOnlyMode
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> ReadOnlyMode
scEnableReadOnlyMode (ServerCtx -> ReadOnlyMode)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> ReadOnlyMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
  Maybe NamingCase
_sccDefaultNamingConvention <- (HandlerCtx -> Maybe NamingCase) -> m (Maybe NamingCase)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> Maybe NamingCase
scDefaultNamingConvention (ServerCtx -> Maybe NamingCase)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> Maybe NamingCase
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
  let serverConfigCtx :: ServerConfigCtx
serverConfigCtx = ServerConfigCtx :: InferFunctionPermissions
-> RemoteSchemaPermissions
-> SQLGenCtx
-> MaintenanceMode ()
-> HashSet ExperimentalFeature
-> EventingMode
-> ReadOnlyMode
-> Maybe NamingCase
-> ServerConfigCtx
ServerConfigCtx {Maybe NamingCase
HashSet ExperimentalFeature
RemoteSchemaPermissions
InferFunctionPermissions
SQLGenCtx
EventingMode
ReadOnlyMode
MaintenanceMode ()
_sccDefaultNamingConvention :: Maybe NamingCase
_sccReadOnlyMode :: ReadOnlyMode
_sccEventingMode :: EventingMode
_sccExperimentalFeatures :: HashSet ExperimentalFeature
_sccMaintenanceMode :: MaintenanceMode ()
_sccSQLGenCtx :: SQLGenCtx
_sccRemoteSchemaPermsCtx :: RemoteSchemaPermissions
_sccFunctionPermsCtx :: InferFunctionPermissions
_sccDefaultNamingConvention :: Maybe NamingCase
_sccReadOnlyMode :: ReadOnlyMode
_sccEventingMode :: EventingMode
_sccMaintenanceMode :: MaintenanceMode ()
_sccExperimentalFeatures :: HashSet ExperimentalFeature
_sccFunctionPermsCtx :: InferFunctionPermissions
_sccRemoteSchemaPermsCtx :: RemoteSchemaPermissions
_sccSQLGenCtx :: SQLGenCtx
..}
  EncJSON
r <-
    SchemaCacheRef
-> Logger Hasura
-> Maybe (TVar Bool)
-> m (EncJSON, RebuildableSchemaCache)
-> m EncJSON
forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m) =>
SchemaCacheRef
-> Logger Hasura
-> Maybe (TVar Bool)
-> m (a, RebuildableSchemaCache)
-> m a
withSchemaCacheUpdate
      SchemaCacheRef
scRef
      Logger Hasura
logger
      Maybe (TVar Bool)
forall a. Maybe a
Nothing
      (m (EncJSON, RebuildableSchemaCache) -> m EncJSON)
-> m (EncJSON, RebuildableSchemaCache) -> m EncJSON
forall a b. (a -> b) -> a -> b
$ Environment
-> Logger Hasura
-> InstanceId
-> UserInfo
-> Manager
-> ServerConfigCtx
-> RebuildableSchemaCache
-> RQLMetadata
-> m (EncJSON, RebuildableSchemaCache)
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadTrace m,
 MonadMetadataStorage m, MonadResolveSource m) =>
Environment
-> Logger Hasura
-> InstanceId
-> UserInfo
-> Manager
-> ServerConfigCtx
-> RebuildableSchemaCache
-> RQLMetadata
-> m (EncJSON, RebuildableSchemaCache)
runMetadataQuery
        Environment
env
        Logger Hasura
logger
        InstanceId
instanceId
        UserInfo
userInfo
        Manager
httpMgr
        ServerConfigCtx
serverConfigCtx
        RebuildableSchemaCache
schemaCache
        RQLMetadata
query
  HttpResponse EncJSON -> m (HttpResponse EncJSON)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HttpResponse EncJSON -> m (HttpResponse EncJSON))
-> HttpResponse EncJSON -> m (HttpResponse EncJSON)
forall a b. (a -> b) -> a -> b
$ EncJSON -> [Header] -> HttpResponse EncJSON
forall a. a -> [Header] -> HttpResponse a
HttpResponse EncJSON
r []

v2QueryHandler ::
  ( MonadIO m,
    MonadBaseControl IO m,
    MonadMetadataApiAuthorization m,
    Tracing.MonadTrace m,
    MonadReader HandlerCtx m,
    MonadMetadataStorage m,
    MonadResolveSource m,
    EB.MonadQueryTags m
  ) =>
  V2Q.RQLQuery ->
  m (HttpResponse EncJSON)
v2QueryHandler :: RQLQuery -> m (HttpResponse EncJSON)
v2QueryHandler RQLQuery
query = Text -> m (HttpResponse EncJSON) -> m (HttpResponse EncJSON)
forall (m :: * -> *) a. MonadTrace m => Text -> m a -> m a
Tracing.trace Text
"v2 Query" (m (HttpResponse EncJSON) -> m (HttpResponse EncJSON))
-> m (HttpResponse EncJSON) -> m (HttpResponse EncJSON)
forall a b. (a -> b) -> a -> b
$ do
  (m (Either QErr ()) -> m ()
forall e (m :: * -> *) a. MonadError e m => m (Either e a) -> m a
liftEitherM (m (Either QErr ()) -> m ())
-> (HandlerCtx -> m (Either QErr ())) -> HandlerCtx -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RQLQuery -> HandlerCtx -> m (Either QErr ())
forall (m :: * -> *).
MonadMetadataApiAuthorization m =>
RQLQuery -> HandlerCtx -> m (Either QErr ())
authorizeV2QueryApi RQLQuery
query) (HandlerCtx -> m ()) -> m HandlerCtx -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m HandlerCtx
forall r (m :: * -> *). MonadReader r m => m r
ask
  SchemaCacheRef
scRef <- (HandlerCtx -> SchemaCacheRef) -> m SchemaCacheRef
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> SchemaCacheRef
scCacheRef (ServerCtx -> SchemaCacheRef)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> SchemaCacheRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
  Logger Hasura
logger <- (HandlerCtx -> Logger Hasura) -> m (Logger Hasura)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> Logger Hasura
scLogger (ServerCtx -> Logger Hasura)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> Logger Hasura
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
  EncJSON
res <-
    m EncJSON -> m EncJSON -> Bool -> m EncJSON
forall a. a -> a -> Bool -> a
bool ((EncJSON, RebuildableSchemaCache) -> EncJSON
forall a b. (a, b) -> a
fst ((EncJSON, RebuildableSchemaCache) -> EncJSON)
-> m (EncJSON, RebuildableSchemaCache) -> m EncJSON
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (EncJSON, RebuildableSchemaCache)
dbAction) (SchemaCacheRef
-> Logger Hasura
-> Maybe (TVar Bool)
-> m (EncJSON, RebuildableSchemaCache)
-> m EncJSON
forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m) =>
SchemaCacheRef
-> Logger Hasura
-> Maybe (TVar Bool)
-> m (a, RebuildableSchemaCache)
-> m a
withSchemaCacheUpdate SchemaCacheRef
scRef Logger Hasura
logger Maybe (TVar Bool)
forall a. Maybe a
Nothing m (EncJSON, RebuildableSchemaCache)
dbAction) (Bool -> m EncJSON) -> Bool -> m EncJSON
forall a b. (a -> b) -> a -> b
$
      RQLQuery -> Bool
V2Q.queryModifiesSchema RQLQuery
query
  HttpResponse EncJSON -> m (HttpResponse EncJSON)
forall (m :: * -> *) a. Monad m => a -> m a
return (HttpResponse EncJSON -> m (HttpResponse EncJSON))
-> HttpResponse EncJSON -> m (HttpResponse EncJSON)
forall a b. (a -> b) -> a -> b
$ EncJSON -> [Header] -> HttpResponse EncJSON
forall a. a -> [Header] -> HttpResponse a
HttpResponse EncJSON
res []
  where
    -- Hit postgres
    dbAction :: m (EncJSON, RebuildableSchemaCache)
dbAction = do
      UserInfo
userInfo <- (HandlerCtx -> UserInfo) -> m UserInfo
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks HandlerCtx -> UserInfo
hcUser
      SchemaCacheRef
scRef <- (HandlerCtx -> SchemaCacheRef) -> m SchemaCacheRef
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> SchemaCacheRef
scCacheRef (ServerCtx -> SchemaCacheRef)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> SchemaCacheRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
      RebuildableSchemaCache
schemaCache <- IO RebuildableSchemaCache -> m RebuildableSchemaCache
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RebuildableSchemaCache -> m RebuildableSchemaCache)
-> IO RebuildableSchemaCache -> m RebuildableSchemaCache
forall a b. (a -> b) -> a -> b
$ (RebuildableSchemaCache, SchemaCacheVer) -> RebuildableSchemaCache
forall a b. (a, b) -> a
fst ((RebuildableSchemaCache, SchemaCacheVer)
 -> RebuildableSchemaCache)
-> IO (RebuildableSchemaCache, SchemaCacheVer)
-> IO RebuildableSchemaCache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaCacheRef -> IO (RebuildableSchemaCache, SchemaCacheVer)
readSchemaCacheRef SchemaCacheRef
scRef
      Manager
httpMgr <- (HandlerCtx -> Manager) -> m Manager
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> Manager
scManager (ServerCtx -> Manager)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> Manager
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
      SQLGenCtx
sqlGenCtx <- (HandlerCtx -> SQLGenCtx) -> m SQLGenCtx
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> SQLGenCtx
scSQLGenCtx (ServerCtx -> SQLGenCtx)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> SQLGenCtx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
      InstanceId
instanceId <- (HandlerCtx -> InstanceId) -> m InstanceId
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> InstanceId
scInstanceId (ServerCtx -> InstanceId)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> InstanceId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
      Environment
env <- (HandlerCtx -> Environment) -> m Environment
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> Environment
scEnvironment (ServerCtx -> Environment)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> Environment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
      RemoteSchemaPermissions
remoteSchemaPermsCtx <- (HandlerCtx -> RemoteSchemaPermissions)
-> m RemoteSchemaPermissions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> RemoteSchemaPermissions
scRemoteSchemaPermsCtx (ServerCtx -> RemoteSchemaPermissions)
-> (HandlerCtx -> ServerCtx)
-> HandlerCtx
-> RemoteSchemaPermissions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
      HashSet ExperimentalFeature
experimentalFeatures <- (HandlerCtx -> HashSet ExperimentalFeature)
-> m (HashSet ExperimentalFeature)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> HashSet ExperimentalFeature
scExperimentalFeatures (ServerCtx -> HashSet ExperimentalFeature)
-> (HandlerCtx -> ServerCtx)
-> HandlerCtx
-> HashSet ExperimentalFeature
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
      InferFunctionPermissions
functionPermsCtx <- (HandlerCtx -> InferFunctionPermissions)
-> m InferFunctionPermissions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> InferFunctionPermissions
scFunctionPermsCtx (ServerCtx -> InferFunctionPermissions)
-> (HandlerCtx -> ServerCtx)
-> HandlerCtx
-> InferFunctionPermissions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
      MaintenanceMode ()
maintenanceMode <- (HandlerCtx -> MaintenanceMode ()) -> m (MaintenanceMode ())
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> MaintenanceMode ()
scEnableMaintenanceMode (ServerCtx -> MaintenanceMode ())
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> MaintenanceMode ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
      EventingMode
eventingMode <- (HandlerCtx -> EventingMode) -> m EventingMode
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> EventingMode
scEventingMode (ServerCtx -> EventingMode)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> EventingMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
      ReadOnlyMode
readOnlyMode <- (HandlerCtx -> ReadOnlyMode) -> m ReadOnlyMode
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> ReadOnlyMode
scEnableReadOnlyMode (ServerCtx -> ReadOnlyMode)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> ReadOnlyMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
      Maybe NamingCase
defaultNamingCase <- (HandlerCtx -> Maybe NamingCase) -> m (Maybe NamingCase)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> Maybe NamingCase
scDefaultNamingConvention (ServerCtx -> Maybe NamingCase)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> Maybe NamingCase
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
      let serverConfigCtx :: ServerConfigCtx
serverConfigCtx =
            InferFunctionPermissions
-> RemoteSchemaPermissions
-> SQLGenCtx
-> MaintenanceMode ()
-> HashSet ExperimentalFeature
-> EventingMode
-> ReadOnlyMode
-> Maybe NamingCase
-> ServerConfigCtx
ServerConfigCtx
              InferFunctionPermissions
functionPermsCtx
              RemoteSchemaPermissions
remoteSchemaPermsCtx
              SQLGenCtx
sqlGenCtx
              MaintenanceMode ()
maintenanceMode
              HashSet ExperimentalFeature
experimentalFeatures
              EventingMode
eventingMode
              ReadOnlyMode
readOnlyMode
              Maybe NamingCase
defaultNamingCase

      Environment
-> InstanceId
-> UserInfo
-> RebuildableSchemaCache
-> Manager
-> ServerConfigCtx
-> RQLQuery
-> m (EncJSON, RebuildableSchemaCache)
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadTrace m,
 MonadMetadataStorage m, MonadResolveSource m, MonadQueryTags m) =>
Environment
-> InstanceId
-> UserInfo
-> RebuildableSchemaCache
-> Manager
-> ServerConfigCtx
-> RQLQuery
-> m (EncJSON, RebuildableSchemaCache)
V2Q.runQuery Environment
env InstanceId
instanceId UserInfo
userInfo RebuildableSchemaCache
schemaCache Manager
httpMgr ServerConfigCtx
serverConfigCtx RQLQuery
query

v1Alpha1GQHandler ::
  ( MonadIO m,
    MonadBaseControl IO m,
    E.MonadGQLExecutionCheck m,
    MonadQueryLog m,
    Tracing.MonadTrace m,
    GH.MonadExecuteQuery m,
    MonadError QErr m,
    MonadReader HandlerCtx m,
    HttpLog m,
    MonadMetadataStorage (MetadataStorageT m),
    EB.MonadQueryTags m,
    HasResourceLimits m
  ) =>
  E.GraphQLQueryType ->
  GH.GQLBatchedReqs (GH.GQLReq GH.GQLQueryText) ->
  m (HttpLogMetadata m, HttpResponse EncJSON)
v1Alpha1GQHandler :: GraphQLQueryType
-> ReqsText -> m (HttpLogMetadata m, HttpResponse EncJSON)
v1Alpha1GQHandler GraphQLQueryType
queryType ReqsText
query = do
  UserInfo
userInfo <- (HandlerCtx -> UserInfo) -> m UserInfo
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks HandlerCtx -> UserInfo
hcUser
  [Header]
reqHeaders <- (HandlerCtx -> [Header]) -> m [Header]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks HandlerCtx -> [Header]
hcReqHeaders
  IpAddress
ipAddress <- (HandlerCtx -> IpAddress) -> m IpAddress
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks HandlerCtx -> IpAddress
hcSourceIpAddress
  RequestId
requestId <- (HandlerCtx -> RequestId) -> m RequestId
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks HandlerCtx -> RequestId
hcRequestId
  Logger Hasura
logger <- (HandlerCtx -> Logger Hasura) -> m (Logger Hasura)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> Logger Hasura
scLogger (ServerCtx -> Logger Hasura)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> Logger Hasura
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
  ResponseInternalErrorsConfig
responseErrorsConfig <- (HandlerCtx -> ResponseInternalErrorsConfig)
-> m ResponseInternalErrorsConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> ResponseInternalErrorsConfig
scResponseInternalErrorsConfig (ServerCtx -> ResponseInternalErrorsConfig)
-> (HandlerCtx -> ServerCtx)
-> HandlerCtx
-> ResponseInternalErrorsConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
  Environment
env <- (HandlerCtx -> Environment) -> m Environment
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> Environment
scEnvironment (ServerCtx -> Environment)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> Environment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)

  ExecutionCtx
execCtx <- m ExecutionCtx
forall (m :: * -> *).
(MonadIO m, MonadReader HandlerCtx m) =>
m ExecutionCtx
mkExecutionContext

  (ReaderT ExecutionCtx m (HttpLogMetadata m, HttpResponse EncJSON)
 -> ExecutionCtx -> m (HttpLogMetadata m, HttpResponse EncJSON))
-> ExecutionCtx
-> ReaderT ExecutionCtx m (HttpLogMetadata m, HttpResponse EncJSON)
-> m (HttpLogMetadata m, HttpResponse EncJSON)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT ExecutionCtx m (HttpLogMetadata m, HttpResponse EncJSON)
-> ExecutionCtx -> m (HttpLogMetadata m, HttpResponse EncJSON)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ExecutionCtx
execCtx (ReaderT ExecutionCtx m (HttpLogMetadata m, HttpResponse EncJSON)
 -> m (HttpLogMetadata m, HttpResponse EncJSON))
-> ReaderT ExecutionCtx m (HttpLogMetadata m, HttpResponse EncJSON)
-> m (HttpLogMetadata m, HttpResponse EncJSON)
forall a b. (a -> b) -> a -> b
$
    Environment
-> Logger Hasura
-> RequestId
-> ResponseInternalErrorsConfig
-> UserInfo
-> IpAddress
-> [Header]
-> GraphQLQueryType
-> ReqsText
-> ReaderT
     ExecutionCtx
     m
     (HttpLogMetadata (ReaderT ExecutionCtx m), HttpResponse EncJSON)
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadError QErr m,
 MonadReader ExecutionCtx m, MonadGQLExecutionCheck m,
 MonadQueryLog m, MonadTrace m, MonadExecuteQuery m, HttpLog m,
 MonadMetadataStorage (MetadataStorageT m), MonadQueryTags m,
 HasResourceLimits m) =>
Environment
-> Logger Hasura
-> RequestId
-> ResponseInternalErrorsConfig
-> UserInfo
-> IpAddress
-> [Header]
-> GraphQLQueryType
-> ReqsText
-> m (HttpLogMetadata m, HttpResponse EncJSON)
GH.runGQBatched Environment
env Logger Hasura
logger RequestId
requestId ResponseInternalErrorsConfig
responseErrorsConfig UserInfo
userInfo IpAddress
ipAddress [Header]
reqHeaders GraphQLQueryType
queryType ReqsText
query

mkExecutionContext ::
  ( MonadIO m,
    MonadReader HandlerCtx m
  ) =>
  m E.ExecutionCtx
mkExecutionContext :: m ExecutionCtx
mkExecutionContext = do
  Manager
manager <- (HandlerCtx -> Manager) -> m Manager
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> Manager
scManager (ServerCtx -> Manager)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> Manager
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
  SchemaCacheRef
scRef <- (HandlerCtx -> SchemaCacheRef) -> m SchemaCacheRef
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> SchemaCacheRef
scCacheRef (ServerCtx -> SchemaCacheRef)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> SchemaCacheRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
  (RebuildableSchemaCache
sc, SchemaCacheVer
scVer) <- IO (RebuildableSchemaCache, SchemaCacheVer)
-> m (RebuildableSchemaCache, SchemaCacheVer)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (RebuildableSchemaCache, SchemaCacheVer)
 -> m (RebuildableSchemaCache, SchemaCacheVer))
-> IO (RebuildableSchemaCache, SchemaCacheVer)
-> m (RebuildableSchemaCache, SchemaCacheVer)
forall a b. (a -> b) -> a -> b
$ SchemaCacheRef -> IO (RebuildableSchemaCache, SchemaCacheVer)
readSchemaCacheRef SchemaCacheRef
scRef
  SQLGenCtx
sqlGenCtx <- (HandlerCtx -> SQLGenCtx) -> m SQLGenCtx
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> SQLGenCtx
scSQLGenCtx (ServerCtx -> SQLGenCtx)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> SQLGenCtx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
  Bool
enableAL <- (HandlerCtx -> Bool) -> m Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> Bool
scEnableAllowlist (ServerCtx -> Bool)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
  Logger Hasura
logger <- (HandlerCtx -> Logger Hasura) -> m (Logger Hasura)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> Logger Hasura
scLogger (ServerCtx -> Logger Hasura)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> Logger Hasura
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
  ReadOnlyMode
readOnlyMode <- (HandlerCtx -> ReadOnlyMode) -> m ReadOnlyMode
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> ReadOnlyMode
scEnableReadOnlyMode (ServerCtx -> ReadOnlyMode)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> ReadOnlyMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
  PrometheusMetrics
prometheusMetrics <- (HandlerCtx -> PrometheusMetrics) -> m PrometheusMetrics
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> PrometheusMetrics
scPrometheusMetrics (ServerCtx -> PrometheusMetrics)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> PrometheusMetrics
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
  ExecutionCtx -> m ExecutionCtx
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExecutionCtx -> m ExecutionCtx) -> ExecutionCtx -> m ExecutionCtx
forall a b. (a -> b) -> a -> b
$ Logger Hasura
-> SQLGenCtx
-> SchemaCache
-> SchemaCacheVer
-> Manager
-> Bool
-> ReadOnlyMode
-> PrometheusMetrics
-> ExecutionCtx
E.ExecutionCtx Logger Hasura
logger SQLGenCtx
sqlGenCtx (RebuildableSchemaCache -> SchemaCache
lastBuiltSchemaCache RebuildableSchemaCache
sc) SchemaCacheVer
scVer Manager
manager Bool
enableAL ReadOnlyMode
readOnlyMode PrometheusMetrics
prometheusMetrics

v1GQHandler ::
  ( MonadIO m,
    MonadBaseControl IO m,
    E.MonadGQLExecutionCheck m,
    MonadQueryLog m,
    Tracing.MonadTrace m,
    GH.MonadExecuteQuery m,
    HttpLog m,
    MonadError QErr m,
    MonadReader HandlerCtx m,
    MonadMetadataStorage (MetadataStorageT m),
    EB.MonadQueryTags m,
    HasResourceLimits m
  ) =>
  GH.GQLBatchedReqs (GH.GQLReq GH.GQLQueryText) ->
  m (HttpLogMetadata m, HttpResponse EncJSON)
v1GQHandler :: ReqsText -> m (HttpLogMetadata m, HttpResponse EncJSON)
v1GQHandler = GraphQLQueryType
-> ReqsText -> m (HttpLogMetadata m, HttpResponse EncJSON)
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadGQLExecutionCheck m,
 MonadQueryLog m, MonadTrace m, MonadExecuteQuery m,
 MonadError QErr m, MonadReader HandlerCtx m, HttpLog m,
 MonadMetadataStorage (MetadataStorageT m), MonadQueryTags m,
 HasResourceLimits m) =>
GraphQLQueryType
-> ReqsText -> m (HttpLogMetadata m, HttpResponse EncJSON)
v1Alpha1GQHandler GraphQLQueryType
E.QueryHasura

v1GQRelayHandler ::
  ( MonadIO m,
    MonadBaseControl IO m,
    E.MonadGQLExecutionCheck m,
    MonadQueryLog m,
    Tracing.MonadTrace m,
    HttpLog m,
    GH.MonadExecuteQuery m,
    MonadError QErr m,
    MonadReader HandlerCtx m,
    MonadMetadataStorage (MetadataStorageT m),
    EB.MonadQueryTags m,
    HasResourceLimits m
  ) =>
  GH.GQLBatchedReqs (GH.GQLReq GH.GQLQueryText) ->
  m (HttpLogMetadata m, HttpResponse EncJSON)
v1GQRelayHandler :: ReqsText -> m (HttpLogMetadata m, HttpResponse EncJSON)
v1GQRelayHandler = GraphQLQueryType
-> ReqsText -> m (HttpLogMetadata m, HttpResponse EncJSON)
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadGQLExecutionCheck m,
 MonadQueryLog m, MonadTrace m, MonadExecuteQuery m,
 MonadError QErr m, MonadReader HandlerCtx m, HttpLog m,
 MonadMetadataStorage (MetadataStorageT m), MonadQueryTags m,
 HasResourceLimits m) =>
GraphQLQueryType
-> ReqsText -> m (HttpLogMetadata m, HttpResponse EncJSON)
v1Alpha1GQHandler GraphQLQueryType
E.QueryRelay

gqlExplainHandler ::
  forall m.
  ( MonadIO m,
    MonadBaseControl IO m,
    MonadError QErr m,
    MonadReader HandlerCtx m,
    MonadMetadataStorage (MetadataStorageT m),
    EB.MonadQueryTags m
  ) =>
  GE.GQLExplain ->
  m (HttpResponse EncJSON)
gqlExplainHandler :: GQLExplain -> m (HttpResponse EncJSON)
gqlExplainHandler GQLExplain
query = do
  m ()
forall (m :: * -> *).
(MonadError QErr m, MonadReader HandlerCtx m) =>
m ()
onlyAdmin
  SchemaCacheRef
scRef <- (HandlerCtx -> SchemaCacheRef) -> m SchemaCacheRef
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> SchemaCacheRef
scCacheRef (ServerCtx -> SchemaCacheRef)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> SchemaCacheRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
  SchemaCache
sc <- IO SchemaCache -> m SchemaCache
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SchemaCache -> m SchemaCache)
-> IO SchemaCache -> m SchemaCache
forall a b. (a -> b) -> a -> b
$ SchemaCacheRef -> IO SchemaCache
getSchemaCache SchemaCacheRef
scRef
  EncJSON
res <- SchemaCache -> GQLExplain -> m EncJSON
forall (m :: * -> *).
(MonadError QErr m, MonadIO m, MonadBaseControl IO m,
 MonadMetadataStorage (MetadataStorageT m), MonadQueryTags m) =>
SchemaCache -> GQLExplain -> m EncJSON
GE.explainGQLQuery SchemaCache
sc GQLExplain
query
  HttpResponse EncJSON -> m (HttpResponse EncJSON)
forall (m :: * -> *) a. Monad m => a -> m a
return (HttpResponse EncJSON -> m (HttpResponse EncJSON))
-> HttpResponse EncJSON -> m (HttpResponse EncJSON)
forall a b. (a -> b) -> a -> b
$ EncJSON -> [Header] -> HttpResponse EncJSON
forall a. a -> [Header] -> HttpResponse a
HttpResponse EncJSON
res []

v1Alpha1PGDumpHandler :: (MonadIO m, MonadError QErr m, MonadReader HandlerCtx m) => PGD.PGDumpReqBody -> m APIResp
v1Alpha1PGDumpHandler :: PGDumpReqBody -> m APIResp
v1Alpha1PGDumpHandler PGDumpReqBody
b = do
  m ()
forall (m :: * -> *).
(MonadError QErr m, MonadReader HandlerCtx m) =>
m ()
onlyAdmin
  SchemaCacheRef
scRef <- (HandlerCtx -> SchemaCacheRef) -> m SchemaCacheRef
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> SchemaCacheRef
scCacheRef (ServerCtx -> SchemaCacheRef)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> SchemaCacheRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
  SchemaCache
sc <- IO SchemaCache -> m SchemaCache
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SchemaCache -> m SchemaCache)
-> IO SchemaCache -> m SchemaCache
forall a b. (a -> b) -> a -> b
$ SchemaCacheRef -> IO SchemaCache
getSchemaCache SchemaCacheRef
scRef
  let sources :: SourceCache
sources = SchemaCache -> SourceCache
scSources SchemaCache
sc
      sourceName :: SourceName
sourceName = PGDumpReqBody -> SourceName
PGD.prbSource PGDumpReqBody
b
      sourceConfig :: Maybe PGSourceConfig
sourceConfig = HasTag ('Postgres 'Vanilla) =>
BackendSourceInfo -> Maybe (SourceConfig ('Postgres 'Vanilla))
forall (b :: BackendType).
HasTag b =>
BackendSourceInfo -> Maybe (SourceConfig b)
unsafeSourceConfiguration @('Postgres 'Vanilla) (BackendSourceInfo -> Maybe PGSourceConfig)
-> Maybe BackendSourceInfo -> Maybe PGSourceConfig
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SourceName -> SourceCache -> Maybe BackendSourceInfo
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup SourceName
sourceName SourceCache
sources
  ConnInfo
ci <-
    (PGSourceConfig -> ConnInfo)
-> Maybe PGSourceConfig -> Maybe ConnInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PGSourceConfig -> ConnInfo
_pscConnInfo Maybe PGSourceConfig
sourceConfig
      Maybe ConnInfo -> m ConnInfo -> m ConnInfo
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
`onNothing` Code -> Text -> m ConnInfo
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
NotFound (Text
"source " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SourceName
sourceName SourceName -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" not found")
  ByteString
output <- PGDumpReqBody -> ConnInfo -> m ByteString
forall (m :: * -> *).
(MonadError QErr m, MonadIO m) =>
PGDumpReqBody -> ConnInfo -> m ByteString
PGD.execPGDump PGDumpReqBody
b ConnInfo
ci
  APIResp -> m APIResp
forall (m :: * -> *) a. Monad m => a -> m a
return (APIResp -> m APIResp) -> APIResp -> m APIResp
forall a b. (a -> b) -> a -> b
$ HttpResponse ByteString -> APIResp
RawResp (HttpResponse ByteString -> APIResp)
-> HttpResponse ByteString -> APIResp
forall a b. (a -> b) -> a -> b
$ ByteString -> [Header] -> HttpResponse ByteString
forall a. a -> [Header] -> HttpResponse a
HttpResponse ByteString
output [Header
sqlHeader]

consoleAssetsHandler ::
  (MonadIO m, HttpLog m) =>
  L.Logger L.Hasura ->
  LoggingSettings ->
  Text ->
  FilePath ->
  Spock.ActionT m ()
consoleAssetsHandler :: Logger Hasura -> LoggingSettings -> Text -> String -> ActionT m ()
consoleAssetsHandler Logger Hasura
logger LoggingSettings
loggingSettings Text
dir String
path = do
  Request
req <- ActionCtxT () m Request
forall (m :: * -> *) ctx. MonadIO m => ActionCtxT ctx m Request
Spock.request
  let reqHeaders :: [Header]
reqHeaders = Request -> [Header]
Wai.requestHeaders Request
req
  -- '..' in paths need not be handed as it is resolved in the url by
  -- spock's routing. we get the expanded path.
  Either IOException ByteString
eFileContents <-
    IO (Either IOException ByteString)
-> ActionCtxT () m (Either IOException ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException ByteString)
 -> ActionCtxT () m (Either IOException ByteString))
-> IO (Either IOException ByteString)
-> ActionCtxT () m (Either IOException ByteString)
forall a b. (a -> b) -> a -> b
$
      IO ByteString -> IO (Either IOException ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO ByteString -> IO (Either IOException ByteString))
-> IO ByteString -> IO (Either IOException ByteString)
forall a b. (a -> b) -> a -> b
$
        String -> IO ByteString
BL.readFile (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$
          [String] -> String
joinPath [Text -> String
T.unpack Text
dir, String
path]
  (IOException -> ActionT m ())
-> (ByteString -> ActionT m ())
-> Either IOException ByteString
-> ActionT m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Header] -> IOException -> ActionT m ()
forall (m :: * -> *).
(MonadIO m, HttpLog m) =>
[Header] -> IOException -> ActionT m ()
onError [Header]
reqHeaders) ByteString -> ActionT m ()
onSuccess Either IOException ByteString
eFileContents
  where
    onSuccess :: ByteString -> ActionT m ()
onSuccess ByteString
c = do
      (Header -> ActionT m ()) -> [Header] -> ActionT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Header -> ActionT m ()
forall (m :: * -> *). MonadIO m => Header -> ActionT m ()
setHeader [Header]
headers
      ByteString -> ActionT m ()
forall (m :: * -> *) ctx a.
MonadIO m =>
ByteString -> ActionCtxT ctx m a
Spock.lazyBytes ByteString
c
    onError :: (MonadIO m, HttpLog m) => [HTTP.Header] -> IOException -> Spock.ActionT m ()
    onError :: [Header] -> IOException -> ActionT m ()
onError [Header]
hdrs = Logger Hasura
-> LoggingSettings -> [Header] -> QErr -> ActionT m ()
forall (m :: * -> *).
(MonadIO m, HttpLog m) =>
Logger Hasura
-> LoggingSettings -> [Header] -> QErr -> ActionT m ()
raiseGenericApiError Logger Hasura
logger LoggingSettings
loggingSettings [Header]
hdrs (QErr -> ActionT m ())
-> (IOException -> QErr) -> IOException -> ActionT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Code -> Text -> QErr
err404 Code
NotFound (Text -> QErr) -> (IOException -> Text) -> IOException -> QErr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> Text
forall a. Show a => a -> Text
tshow
    fn :: Text
fn = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String
takeFileName String
path
    -- set gzip header if the filename ends with .gz
    (Text
fileName, [Header]
encHeader) = case Text -> Text -> Maybe Text
T.stripSuffix Text
".gz" Text
fn of
      Just Text
v -> (Text
v, [Header
gzipHeader])
      Maybe Text
Nothing -> (Text
fn, [])
    mimeType :: ByteString
mimeType = Text -> ByteString
defaultMimeLookup Text
fileName
    headers :: [Header]
headers = (HeaderName
"Content-Type", ByteString
mimeType) Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [Header]
encHeader

class (Monad m) => ConsoleRenderer m where
  renderConsole :: Text -> AuthMode -> Bool -> Maybe Text -> m (Either String Text)

instance ConsoleRenderer m => ConsoleRenderer (Tracing.TraceT m) where
  renderConsole :: Text
-> AuthMode -> Bool -> Maybe Text -> TraceT m (Either String Text)
renderConsole Text
a AuthMode
b Bool
c Maybe Text
d = m (Either String Text) -> TraceT m (Either String Text)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either String Text) -> TraceT m (Either String Text))
-> m (Either String Text) -> TraceT m (Either String Text)
forall a b. (a -> b) -> a -> b
$ Text -> AuthMode -> Bool -> Maybe Text -> m (Either String Text)
forall (m :: * -> *).
ConsoleRenderer m =>
Text -> AuthMode -> Bool -> Maybe Text -> m (Either String Text)
renderConsole Text
a AuthMode
b Bool
c Maybe Text
d

renderHtmlTemplate :: M.Template -> Value -> Either String Text
renderHtmlTemplate :: Template -> Value -> Either String Text
renderHtmlTemplate Template
template Value
jVal =
  Either String Text
-> Either String Text -> Bool -> Either String Text
forall a. a -> a -> Bool -> a
bool (String -> Either String Text
forall a b. a -> Either a b
Left String
errMsg) (Text -> Either String Text
forall a b. b -> Either a b
Right Text
res) (Bool -> Either String Text) -> Bool -> Either String Text
forall a b. (a -> b) -> a -> b
$ [SubstitutionError] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SubstitutionError]
errs
  where
    errMsg :: String
errMsg = String
"template rendering failed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [SubstitutionError] -> String
forall a. Show a => a -> String
show [SubstitutionError]
errs
    ([SubstitutionError]
errs, Text
res) = Template -> Value -> ([SubstitutionError], Text)
forall k.
ToMustache k =>
Template -> k -> ([SubstitutionError], Text)
M.checkedSubstitute Template
template Value
jVal

-- | Default implementation of the 'MonadConfigApiHandler'
configApiGetHandler ::
  forall m.
  (MonadIO m, MonadBaseControl IO m, UserAuthentication (Tracing.TraceT m), HttpLog m, Tracing.HasReporter m, HasResourceLimits m) =>
  ServerCtx ->
  Maybe Text ->
  Spock.SpockCtxT () m ()
configApiGetHandler :: ServerCtx -> Maybe Text -> SpockCtxT () m ()
configApiGetHandler serverCtx :: ServerCtx
serverCtx@ServerCtx {Bool
Maybe NamingCase
HashSet ExperimentalFeature
HashSet API
Logger Hasura
RemoteSchemaPermissions
InferFunctionPermissions
Environment
Store EmptyMetrics
PrometheusMetrics
Manager
SQLGenCtx
EventingMode
ReadOnlyMode
MaintenanceMode ()
InstanceId
LoggingSettings
SchemaCacheRef
AuthMode
ResponseInternalErrorsConfig
SubscriptionsState
scPrometheusMetrics :: PrometheusMetrics
scDefaultNamingConvention :: Maybe NamingCase
scEnableReadOnlyMode :: ReadOnlyMode
scEventingMode :: EventingMode
scLoggingSettings :: LoggingSettings
scExperimentalFeatures :: HashSet ExperimentalFeature
scEnableMaintenanceMode :: MaintenanceMode ()
scFunctionPermsCtx :: InferFunctionPermissions
scRemoteSchemaPermsCtx :: RemoteSchemaPermissions
scEnvironment :: Environment
scResponseInternalErrorsConfig :: ResponseInternalErrorsConfig
scEkgStore :: Store EmptyMetrics
scEnableAllowlist :: Bool
scSubscriptionState :: SubscriptionsState
scInstanceId :: InstanceId
scEnabledAPIs :: HashSet API
scSQLGenCtx :: SQLGenCtx
scManager :: Manager
scAuthMode :: AuthMode
scCacheRef :: SchemaCacheRef
scLogger :: Logger Hasura
scPrometheusMetrics :: ServerCtx -> PrometheusMetrics
scDefaultNamingConvention :: ServerCtx -> Maybe NamingCase
scEnableReadOnlyMode :: ServerCtx -> ReadOnlyMode
scEventingMode :: ServerCtx -> EventingMode
scExperimentalFeatures :: ServerCtx -> HashSet ExperimentalFeature
scEnableMaintenanceMode :: ServerCtx -> MaintenanceMode ()
scFunctionPermsCtx :: ServerCtx -> InferFunctionPermissions
scRemoteSchemaPermsCtx :: ServerCtx -> RemoteSchemaPermissions
scEnvironment :: ServerCtx -> Environment
scResponseInternalErrorsConfig :: ServerCtx -> ResponseInternalErrorsConfig
scEkgStore :: ServerCtx -> Store EmptyMetrics
scEnableAllowlist :: ServerCtx -> Bool
scSubscriptionState :: ServerCtx -> SubscriptionsState
scInstanceId :: ServerCtx -> InstanceId
scSQLGenCtx :: ServerCtx -> SQLGenCtx
scAuthMode :: ServerCtx -> AuthMode
scCacheRef :: ServerCtx -> SchemaCacheRef
scLogger :: ServerCtx -> Logger Hasura
scEnabledAPIs :: ServerCtx -> HashSet API
scLoggingSettings :: ServerCtx -> LoggingSettings
scManager :: ServerCtx -> Manager
..} Maybe Text
consoleAssetsDir =
  Path '[] 'Open
-> HVectElim '[] (ActionCtxT () m ()) -> SpockCtxT () m ()
forall (xs :: [*]) (t :: * -> (* -> *) -> * -> *) (m :: * -> *)
       (ps :: PathState) ctx.
(HasRep xs, RouteM t, Monad m) =>
Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
Spock.get Path '[] 'Open
"v1alpha1/config" (HVectElim '[] (ActionCtxT () m ()) -> SpockCtxT () m ())
-> HVectElim '[] (ActionCtxT () m ()) -> SpockCtxT () m ()
forall a b. (a -> b) -> a -> b
$
    ServerCtx
-> (Bool -> QErr -> Value)
-> (QErr -> QErr)
-> APIHandler (TraceT m) ()
-> ActionCtxT () m ()
forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m, FromJSON a,
 UserAuthentication (TraceT m), HttpLog m, HasReporter m,
 HasResourceLimits m) =>
ServerCtx
-> (Bool -> QErr -> Value)
-> (QErr -> QErr)
-> APIHandler (TraceT m) a
-> ActionT m ()
mkSpockAction ServerCtx
serverCtx Bool -> QErr -> Value
encodeQErr QErr -> QErr
forall a. a -> a
id (APIHandler (TraceT m) () -> ActionCtxT () m ())
-> APIHandler (TraceT m) () -> ActionCtxT () m ()
forall a b. (a -> b) -> a -> b
$
      Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
-> APIHandler (TraceT m) ()
forall (m :: * -> *).
Handler m (HttpLogMetadata m, APIResp) -> APIHandler m ()
mkGetHandler (Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
 -> APIHandler (TraceT m) ())
-> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
-> APIHandler (TraceT m) ()
forall a b. (a -> b) -> a -> b
$ do
        ReaderT HandlerCtx (MetadataStorageT (TraceT m)) ()
forall (m :: * -> *).
(MonadError QErr m, MonadReader HandlerCtx m) =>
m ()
onlyAdmin
        let res :: ServerConfig
res =
              InferFunctionPermissions
-> RemoteSchemaPermissions
-> AuthMode
-> Bool
-> LiveQueriesOptions
-> LiveQueriesOptions
-> Maybe Text
-> HashSet ExperimentalFeature
-> ServerConfig
runGetConfig
                InferFunctionPermissions
scFunctionPermsCtx
                RemoteSchemaPermissions
scRemoteSchemaPermsCtx
                AuthMode
scAuthMode
                Bool
scEnableAllowlist
                (SubscriptionsState -> LiveQueriesOptions
ES._ssLiveQueryOptions (SubscriptionsState -> LiveQueriesOptions)
-> SubscriptionsState -> LiveQueriesOptions
forall a b. (a -> b) -> a -> b
$ SubscriptionsState
scSubscriptionState)
                (SubscriptionsState -> LiveQueriesOptions
ES._ssStreamQueryOptions (SubscriptionsState -> LiveQueriesOptions)
-> SubscriptionsState -> LiveQueriesOptions
forall a b. (a -> b) -> a -> b
$ SubscriptionsState
scSubscriptionState)
                Maybe Text
consoleAssetsDir
                HashSet ExperimentalFeature
scExperimentalFeatures
        ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp)
-> ReaderT
     HandlerCtx
     (MetadataStorageT (TraceT m))
     ((CommonHttpLogMetadata, ExtraHttpLogMetadata m), APIResp)
forall (m :: * -> *) a. Monad m => a -> m a
return (HttpLog m => (CommonHttpLogMetadata, ExtraHttpLogMetadata m)
forall (m :: * -> *). HttpLog m => HttpLogMetadata m
emptyHttpLogMetadata @m, HttpResponse EncJSON -> APIResp
JSONResp (HttpResponse EncJSON -> APIResp)
-> HttpResponse EncJSON -> APIResp
forall a b. (a -> b) -> a -> b
$ EncJSON -> [Header] -> HttpResponse EncJSON
forall a. a -> [Header] -> HttpResponse a
HttpResponse (ServerConfig -> EncJSON
forall a. ToJSON a => a -> EncJSON
encJFromJValue ServerConfig
res) [])

data HasuraApp = HasuraApp
  { HasuraApp -> Application
_hapApplication :: !Wai.Application,
    HasuraApp -> SchemaCacheRef
_hapSchemaRef :: !SchemaCacheRef,
    HasuraApp -> AsyncActionSubscriptionState
_hapAsyncActionSubscriptionState :: !ES.AsyncActionSubscriptionState,
    HasuraApp -> IO ()
_hapShutdownWsServer :: !(IO ())
  }

-- TODO: Put Env into ServerCtx?

mkWaiApp ::
  forall m.
  ( MonadIO m,
    MonadFix m,
    MonadStateless IO m,
    LA.Forall (LA.Pure m),
    ConsoleRenderer m,
    HttpLog m,
    UserAuthentication (Tracing.TraceT m),
    MonadMetadataApiAuthorization m,
    E.MonadGQLExecutionCheck m,
    MonadConfigApiHandler m,
    MonadQueryLog m,
    WS.MonadWSLog m,
    Tracing.HasReporter m,
    GH.MonadExecuteQuery m,
    HasResourceLimits m,
    MonadMetadataStorage (MetadataStorageT m),
    MonadResolveSource m,
    EB.MonadQueryTags m
  ) =>
  (ServerCtx -> Spock.SpockT m ()) ->
  -- | Set of environment variables for reference in UIs
  Env.Environment ->
  -- | a 'L.Hasura' specific logger
  L.Logger L.Hasura ->
  SQLGenCtx ->
  -- | is AllowList enabled - TODO: change this boolean to sumtype
  Bool ->
  -- | HTTP manager so that we can re-use sessions
  HTTP.Manager ->
  -- | 'AuthMode' in which the application should operate in
  AuthMode ->
  CorsConfig ->
  -- | is console enabled - TODO: better type
  Bool ->
  -- | filepath to the console static assets directory - TODO: better type
  Maybe Text ->
  -- | is telemetry enabled
  Bool ->
  -- | each application, when run, gets an 'InstanceId'. this is used at various places including
  -- schema syncing and telemetry
  InstanceId ->
  -- | set of the enabled 'API's
  S.HashSet API ->
  ES.LiveQueriesOptions ->
  ES.StreamQueriesOptions ->
  ResponseInternalErrorsConfig ->
  Maybe ES.SubscriptionPostPollHook ->
  SchemaCacheRef ->
  EKG.Store EKG.EmptyMetrics ->
  ServerMetrics ->
  PrometheusMetrics ->
  Options.RemoteSchemaPermissions ->
  Options.InferFunctionPermissions ->
  WS.ConnectionOptions ->
  KeepAliveDelay ->
  MaintenanceMode () ->
  EventingMode ->
  ReadOnlyMode ->
  -- | Set of the enabled experimental features
  S.HashSet ExperimentalFeature ->
  S.HashSet (L.EngineLogType L.Hasura) ->
  WSConnectionInitTimeout ->
  -- | is metadata query logging in http-log enabled
  MetadataQueryLoggingMode ->
  -- | default naming convention
  Maybe NamingCase ->
  m HasuraApp
mkWaiApp :: (ServerCtx -> SpockT m ())
-> Environment
-> Logger Hasura
-> SQLGenCtx
-> Bool
-> Manager
-> AuthMode
-> CorsConfig
-> Bool
-> Maybe Text
-> Bool
-> InstanceId
-> HashSet API
-> LiveQueriesOptions
-> LiveQueriesOptions
-> ResponseInternalErrorsConfig
-> Maybe SubscriptionPostPollHook
-> SchemaCacheRef
-> Store EmptyMetrics
-> ServerMetrics
-> PrometheusMetrics
-> RemoteSchemaPermissions
-> InferFunctionPermissions
-> ConnectionOptions
-> KeepAliveDelay
-> MaintenanceMode ()
-> EventingMode
-> ReadOnlyMode
-> HashSet ExperimentalFeature
-> HashSet (EngineLogType Hasura)
-> WSConnectionInitTimeout
-> MetadataQueryLoggingMode
-> Maybe NamingCase
-> m HasuraApp
mkWaiApp
  ServerCtx -> SpockT m ()
setupHook
  Environment
env
  Logger Hasura
logger
  SQLGenCtx
sqlGenCtx
  Bool
enableAL
  Manager
httpManager
  AuthMode
mode
  CorsConfig
corsCfg
  Bool
enableConsole
  Maybe Text
consoleAssetsDir
  Bool
enableTelemetry
  InstanceId
instanceId
  HashSet API
apis
  LiveQueriesOptions
lqOpts
  LiveQueriesOptions
streamQOpts
  ResponseInternalErrorsConfig
responseErrorsConfig
  Maybe SubscriptionPostPollHook
liveQueryHook
  SchemaCacheRef
schemaCacheRef
  Store EmptyMetrics
ekgStore
  ServerMetrics
serverMetrics
  PrometheusMetrics
prometheusMetrics
  RemoteSchemaPermissions
enableRSPermsCtx
  InferFunctionPermissions
functionPermsCtx
  ConnectionOptions
connectionOptions
  KeepAliveDelay
keepAliveDelay
  MaintenanceMode ()
maintenanceMode
  EventingMode
eventingMode
  ReadOnlyMode
readOnlyMode
  HashSet ExperimentalFeature
experimentalFeatures
  HashSet (EngineLogType Hasura)
enabledLogTypes
  WSConnectionInitTimeout
wsConnInitTimeout
  MetadataQueryLoggingMode
enableMetadataQueryLogging
  Maybe NamingCase
defaultNC = do
    let getSchemaCache' :: IO (SchemaCache, SchemaCacheVer)
getSchemaCache' = (RebuildableSchemaCache -> SchemaCache)
-> (RebuildableSchemaCache, SchemaCacheVer)
-> (SchemaCache, SchemaCacheVer)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first RebuildableSchemaCache -> SchemaCache
lastBuiltSchemaCache ((RebuildableSchemaCache, SchemaCacheVer)
 -> (SchemaCache, SchemaCacheVer))
-> IO (RebuildableSchemaCache, SchemaCacheVer)
-> IO (SchemaCache, SchemaCacheVer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaCacheRef -> IO (RebuildableSchemaCache, SchemaCacheVer)
readSchemaCacheRef SchemaCacheRef
schemaCacheRef

    let corsPolicy :: CorsPolicy
corsPolicy = CorsConfig -> CorsPolicy
mkDefaultCorsPolicy CorsConfig
corsCfg
        postPollHook :: SubscriptionPostPollHook
postPollHook = SubscriptionPostPollHook
-> Maybe SubscriptionPostPollHook -> SubscriptionPostPollHook
forall a. a -> Maybe a -> a
fromMaybe (Logger Hasura -> SubscriptionPostPollHook
ES.defaultSubscriptionPostPollHook Logger Hasura
logger) Maybe SubscriptionPostPollHook
liveQueryHook

    SubscriptionsState
subscriptionsState <- IO SubscriptionsState -> m SubscriptionsState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SubscriptionsState -> m SubscriptionsState)
-> IO SubscriptionsState -> m SubscriptionsState
forall a b. (a -> b) -> a -> b
$ LiveQueriesOptions
-> LiveQueriesOptions
-> SubscriptionPostPollHook
-> IO SubscriptionsState
ES.initSubscriptionsState LiveQueriesOptions
lqOpts LiveQueriesOptions
streamQOpts SubscriptionPostPollHook
postPollHook

    WSServerEnv
wsServerEnv <-
      Logger Hasura
-> SubscriptionsState
-> IO (SchemaCache, SchemaCacheVer)
-> Manager
-> CorsPolicy
-> SQLGenCtx
-> ReadOnlyMode
-> Bool
-> KeepAliveDelay
-> ServerMetrics
-> PrometheusMetrics
-> m WSServerEnv
forall (m :: * -> *).
MonadIO m =>
Logger Hasura
-> SubscriptionsState
-> IO (SchemaCache, SchemaCacheVer)
-> Manager
-> CorsPolicy
-> SQLGenCtx
-> ReadOnlyMode
-> Bool
-> KeepAliveDelay
-> ServerMetrics
-> PrometheusMetrics
-> m WSServerEnv
WS.createWSServerEnv
        Logger Hasura
logger
        SubscriptionsState
subscriptionsState
        IO (SchemaCache, SchemaCacheVer)
getSchemaCache'
        Manager
httpManager
        CorsPolicy
corsPolicy
        SQLGenCtx
sqlGenCtx
        ReadOnlyMode
readOnlyMode
        Bool
enableAL
        KeepAliveDelay
keepAliveDelay
        ServerMetrics
serverMetrics
        PrometheusMetrics
prometheusMetrics

    let serverCtx :: ServerCtx
serverCtx =
          ServerCtx :: Logger Hasura
-> SchemaCacheRef
-> AuthMode
-> Manager
-> SQLGenCtx
-> HashSet API
-> InstanceId
-> SubscriptionsState
-> Bool
-> Store EmptyMetrics
-> ResponseInternalErrorsConfig
-> Environment
-> RemoteSchemaPermissions
-> InferFunctionPermissions
-> MaintenanceMode ()
-> HashSet ExperimentalFeature
-> LoggingSettings
-> EventingMode
-> ReadOnlyMode
-> Maybe NamingCase
-> PrometheusMetrics
-> ServerCtx
ServerCtx
            { scLogger :: Logger Hasura
scLogger = Logger Hasura
logger,
              scCacheRef :: SchemaCacheRef
scCacheRef = SchemaCacheRef
schemaCacheRef,
              scAuthMode :: AuthMode
scAuthMode = AuthMode
mode,
              scManager :: Manager
scManager = Manager
httpManager,
              scSQLGenCtx :: SQLGenCtx
scSQLGenCtx = SQLGenCtx
sqlGenCtx,
              scEnabledAPIs :: HashSet API
scEnabledAPIs = HashSet API
apis,
              scInstanceId :: InstanceId
scInstanceId = InstanceId
instanceId,
              scSubscriptionState :: SubscriptionsState
scSubscriptionState = SubscriptionsState
subscriptionsState,
              scEnableAllowlist :: Bool
scEnableAllowlist = Bool
enableAL,
              scEkgStore :: Store EmptyMetrics
scEkgStore = Store EmptyMetrics
ekgStore,
              scEnvironment :: Environment
scEnvironment = Environment
env,
              scResponseInternalErrorsConfig :: ResponseInternalErrorsConfig
scResponseInternalErrorsConfig = ResponseInternalErrorsConfig
responseErrorsConfig,
              scRemoteSchemaPermsCtx :: RemoteSchemaPermissions
scRemoteSchemaPermsCtx = RemoteSchemaPermissions
enableRSPermsCtx,
              scFunctionPermsCtx :: InferFunctionPermissions
scFunctionPermsCtx = InferFunctionPermissions
functionPermsCtx,
              scEnableMaintenanceMode :: MaintenanceMode ()
scEnableMaintenanceMode = MaintenanceMode ()
maintenanceMode,
              scExperimentalFeatures :: HashSet ExperimentalFeature
scExperimentalFeatures = HashSet ExperimentalFeature
experimentalFeatures,
              scLoggingSettings :: LoggingSettings
scLoggingSettings = HashSet (EngineLogType Hasura)
-> MetadataQueryLoggingMode -> LoggingSettings
LoggingSettings HashSet (EngineLogType Hasura)
enabledLogTypes MetadataQueryLoggingMode
enableMetadataQueryLogging,
              scEventingMode :: EventingMode
scEventingMode = EventingMode
eventingMode,
              scEnableReadOnlyMode :: ReadOnlyMode
scEnableReadOnlyMode = ReadOnlyMode
readOnlyMode,
              scDefaultNamingConvention :: Maybe NamingCase
scDefaultNamingConvention = Maybe NamingCase
defaultNC,
              scPrometheusMetrics :: PrometheusMetrics
scPrometheusMetrics = PrometheusMetrics
prometheusMetrics
            }

    Application
spockApp <- ((forall a. m a -> IO a) -> IO Application) -> m Application
forall (b :: * -> *) (m :: * -> *) c.
MonadStateless b m =>
((forall a. m a -> b a) -> b c) -> m c
liftWithStateless (((forall a. m a -> IO a) -> IO Application) -> m Application)
-> ((forall a. m a -> IO a) -> IO Application) -> m Application
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
lowerIO ->
      IO Middleware -> IO Application
Spock.spockAsApp (IO Middleware -> IO Application)
-> IO Middleware -> IO Application
forall a b. (a -> b) -> a -> b
$
        (forall a. m a -> IO a) -> SpockT m () -> IO Middleware
forall (m :: * -> *).
MonadIO m =>
(forall a. m a -> IO a) -> SpockT m () -> IO Middleware
Spock.spockT forall a. m a -> IO a
lowerIO (SpockT m () -> IO Middleware) -> SpockT m () -> IO Middleware
forall a b. (a -> b) -> a -> b
$
          (ServerCtx -> SpockT m ())
-> CorsConfig
-> ServerCtx
-> Bool
-> Maybe Text
-> Bool
-> SpockT m ()
forall (m :: * -> *).
(MonadIO m, MonadFix m, MonadBaseControl IO m, ConsoleRenderer m,
 HttpLog m, UserAuthentication (TraceT m),
 MonadMetadataApiAuthorization m, MonadGQLExecutionCheck m,
 MonadConfigApiHandler m, MonadQueryLog m, HasReporter m,
 MonadExecuteQuery m, MonadMetadataStorage (MetadataStorageT m),
 HasResourceLimits m, MonadResolveSource m, MonadQueryTags m) =>
(ServerCtx -> SpockT m ())
-> CorsConfig
-> ServerCtx
-> Bool
-> Maybe Text
-> Bool
-> SpockT m ()
httpApp ServerCtx -> SpockT m ()
setupHook CorsConfig
corsCfg ServerCtx
serverCtx Bool
enableConsole Maybe Text
consoleAssetsDir Bool
enableTelemetry

    let wsServerApp :: HasuraServerApp m
wsServerApp = Environment
-> HashSet (EngineLogType Hasura)
-> AuthMode
-> WSServerEnv
-> WSConnectionInitTimeout
-> HasuraServerApp m
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, Forall (Pure m),
 UserAuthentication (TraceT m), MonadGQLExecutionCheck m,
 MonadWSLog m, MonadQueryLog m, HasReporter m, MonadExecuteQuery m,
 MonadMetadataStorage (MetadataStorageT m), MonadQueryTags m,
 HasResourceLimits m) =>
Environment
-> HashSet (EngineLogType Hasura)
-> AuthMode
-> WSServerEnv
-> WSConnectionInitTimeout
-> HasuraServerApp m
WS.createWSServerApp Environment
env HashSet (EngineLogType Hasura)
enabledLogTypes AuthMode
mode WSServerEnv
wsServerEnv WSConnectionInitTimeout
wsConnInitTimeout -- TODO: Lyndon: Can we pass environment through wsServerEnv?
        stopWSServer :: IO ()
stopWSServer = WSServerEnv -> IO ()
WS.stopWSServerApp WSServerEnv
wsServerEnv

    Application
waiApp <- ((forall a. m a -> IO a) -> IO Application) -> m Application
forall (b :: * -> *) (m :: * -> *) c.
MonadStateless b m =>
((forall a. m a -> b a) -> b c) -> m c
liftWithStateless (((forall a. m a -> IO a) -> IO Application) -> m Application)
-> ((forall a. m a -> IO a) -> IO Application) -> m Application
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
lowerIO ->
      Application -> IO Application
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Application -> IO Application) -> Application -> IO Application
forall a b. (a -> b) -> a -> b
$ ConnectionOptions
-> (IpAddress -> PendingConnection -> IO ()) -> Middleware
WSC.websocketsOr ConnectionOptions
connectionOptions (\IpAddress
ip PendingConnection
conn -> m () -> IO ()
forall a. m a -> IO a
lowerIO (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ HasuraServerApp m
wsServerApp IpAddress
ip PendingConnection
conn) Application
spockApp

    HasuraApp -> m HasuraApp
forall (m :: * -> *) a. Monad m => a -> m a
return (HasuraApp -> m HasuraApp) -> HasuraApp -> m HasuraApp
forall a b. (a -> b) -> a -> b
$ Application
-> SchemaCacheRef
-> AsyncActionSubscriptionState
-> IO ()
-> HasuraApp
HasuraApp Application
waiApp SchemaCacheRef
schemaCacheRef (SubscriptionsState -> AsyncActionSubscriptionState
ES._ssAsyncActions SubscriptionsState
subscriptionsState) IO ()
stopWSServer

httpApp ::
  forall m.
  ( MonadIO m,
    MonadFix m,
    MonadBaseControl IO m,
    ConsoleRenderer m,
    HttpLog m,
    UserAuthentication (Tracing.TraceT m),
    MonadMetadataApiAuthorization m,
    E.MonadGQLExecutionCheck m,
    MonadConfigApiHandler m,
    MonadQueryLog m,
    Tracing.HasReporter m,
    GH.MonadExecuteQuery m,
    MonadMetadataStorage (MetadataStorageT m),
    HasResourceLimits m,
    MonadResolveSource m,
    EB.MonadQueryTags m
  ) =>
  (ServerCtx -> Spock.SpockT m ()) ->
  CorsConfig ->
  ServerCtx ->
  Bool ->
  Maybe Text ->
  Bool ->
  Spock.SpockT m ()
httpApp :: (ServerCtx -> SpockT m ())
-> CorsConfig
-> ServerCtx
-> Bool
-> Maybe Text
-> Bool
-> SpockT m ()
httpApp ServerCtx -> SpockT m ()
setupHook CorsConfig
corsCfg ServerCtx
serverCtx Bool
enableConsole Maybe Text
consoleAssetsDir Bool
enableTelemetry = do
  -- Additional spock action to run
  ServerCtx -> SpockT m ()
setupHook ServerCtx
serverCtx

  -- cors middleware
  Bool -> SpockT m () -> SpockT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CorsConfig -> Bool
isCorsDisabled CorsConfig
corsCfg) (SpockT m () -> SpockT m ()) -> SpockT m () -> SpockT m ()
forall a b. (a -> b) -> a -> b
$
    Middleware -> SpockT m ()
forall (t :: * -> (* -> *) -> * -> *) (m :: * -> *) ctx.
(RouteM t, Monad m) =>
Middleware -> t ctx m ()
Spock.middleware (Middleware -> SpockT m ()) -> Middleware -> SpockT m ()
forall a b. (a -> b) -> a -> b
$ CorsPolicy -> Middleware
corsMiddleware (CorsConfig -> CorsPolicy
mkDefaultCorsPolicy CorsConfig
corsCfg)

  -- API Console and Root Dir
  Bool -> SpockT m () -> SpockT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
enableConsole Bool -> Bool -> Bool
&& Bool
enableMetadata) SpockT m ()
serveApiConsole

  -- Health check endpoint with logs
  let healthzAction :: ActionCtxT () m ()
healthzAction = do
        let errorMsg :: Text
errorMsg = Text
"ERROR"
        MetadataStorageT (ActionCtxT () m) ()
-> ActionCtxT () m (Either QErr ())
forall (m :: * -> *) a. MetadataStorageT m a -> m (Either QErr a)
runMetadataStorageT MetadataStorageT (ActionCtxT () m) ()
forall (m :: * -> *). MonadMetadataStorage m => m ()
checkMetadataStorageHealth ActionCtxT () m (Either QErr ())
-> (Either QErr () -> ActionCtxT () m ()) -> ActionCtxT () m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left QErr
err -> do
            -- error running the health check
            QErr -> ActionCtxT () m ()
logError QErr
err
            Status -> ActionCtxT () m ()
forall (m :: * -> *) ctx.
MonadIO m =>
Status -> ActionCtxT ctx m ()
Spock.setStatus Status
HTTP.status500 ActionCtxT () m () -> ActionCtxT () m () -> ActionCtxT () m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> ActionCtxT () m ()
forall (m :: * -> *) ctx a. MonadIO m => Text -> ActionCtxT ctx m a
Spock.text Text
errorMsg
          Right ()
_ -> do
            -- healthy
            SchemaCache
sc <- IO SchemaCache -> ActionCtxT () m SchemaCache
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SchemaCache -> ActionCtxT () m SchemaCache)
-> IO SchemaCache -> ActionCtxT () m SchemaCache
forall a b. (a -> b) -> a -> b
$ SchemaCacheRef -> IO SchemaCache
getSchemaCache (SchemaCacheRef -> IO SchemaCache)
-> SchemaCacheRef -> IO SchemaCache
forall a b. (a -> b) -> a -> b
$ ServerCtx -> SchemaCacheRef
scCacheRef ServerCtx
serverCtx
            let responseText :: Text
responseText =
                  if [InconsistentMetadata] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (SchemaCache -> [InconsistentMetadata]
scInconsistentObjs SchemaCache
sc)
                    then Text
"OK"
                    else Text
"WARN: inconsistent objects in schema"
            Text -> ActionCtxT () m ()
logSuccess Text
responseText
            Status -> ActionCtxT () m ()
forall (m :: * -> *) ctx.
MonadIO m =>
Status -> ActionCtxT ctx m ()
Spock.setStatus Status
HTTP.status200 ActionCtxT () m () -> ActionCtxT () m () -> ActionCtxT () m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> ActionCtxT () m ()
forall (m :: * -> *) ctx a. MonadIO m => Text -> ActionCtxT ctx m a
Spock.text (Text -> Text
LT.toStrict Text
responseText)

  Path '[] 'Open -> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall (xs :: [*]) (t :: * -> (* -> *) -> * -> *) (m :: * -> *)
       (ps :: PathState) ctx.
(HasRep xs, RouteM t, Monad m) =>
Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
Spock.get Path '[] 'Open
"healthz" ActionCtxT () m ()
HVectElim '[] (ActionCtxT () m ())
healthzAction

  -- This is an alternative to `healthz` (See issue #6958)
  Path '[] 'Open -> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall (xs :: [*]) (t :: * -> (* -> *) -> * -> *) (m :: * -> *)
       (ps :: PathState) ctx.
(HasRep xs, RouteM t, Monad m) =>
Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
Spock.get Path '[] 'Open
"hasura/healthz" ActionCtxT () m ()
HVectElim '[] (ActionCtxT () m ())
healthzAction

  Path '[] 'Open -> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall (xs :: [*]) (t :: * -> (* -> *) -> * -> *) (m :: * -> *)
       (ps :: PathState) ctx.
(HasRep xs, RouteM t, Monad m) =>
Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
Spock.get Path '[] 'Open
"v1/version" (HVectElim '[] (ActionCtxT () m ()) -> SpockT m ())
-> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> ActionCtxT () m ()
logSuccess (Text -> ActionCtxT () m ()) -> Text -> ActionCtxT () m ()
forall a b. (a -> b) -> a -> b
$ Text
"version: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Version -> Text
forall a b. (ToText a, FromText b) => a -> b
convertText Version
currentVersion
    Header -> ActionCtxT () m ()
forall (m :: * -> *). MonadIO m => Header -> ActionT m ()
setHeader Header
jsonHeader
    ByteString -> ActionCtxT () m ()
forall (m :: * -> *) ctx a.
MonadIO m =>
ByteString -> ActionCtxT ctx m a
Spock.lazyBytes (ByteString -> ActionCtxT () m ())
-> ByteString -> ActionCtxT () m ()
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [Key
"version" Key -> Version -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Version
currentVersion]

  let customEndpointHandler ::
        forall n.
        ( MonadIO n,
          MonadBaseControl IO n,
          E.MonadGQLExecutionCheck n,
          MonadQueryLog n,
          GH.MonadExecuteQuery n,
          MonadMetadataStorage (MetadataStorageT n),
          HttpLog n,
          EB.MonadQueryTags n,
          HasResourceLimits n
        ) =>
        RestRequest Spock.SpockMethod ->
        Handler (Tracing.TraceT n) (HttpLogMetadata n, APIResp)
      customEndpointHandler :: RestRequest SpockMethod
-> Handler (TraceT n) (HttpLogMetadata n, APIResp)
customEndpointHandler RestRequest SpockMethod
restReq = do
        SchemaCacheRef
scRef <- (HandlerCtx -> SchemaCacheRef)
-> ReaderT HandlerCtx (MetadataStorageT (TraceT n)) SchemaCacheRef
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> SchemaCacheRef
scCacheRef (ServerCtx -> SchemaCacheRef)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> SchemaCacheRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
        EndpointTrie GQLQueryWithText
endpoints <- IO (EndpointTrie GQLQueryWithText)
-> ReaderT
     HandlerCtx
     (MetadataStorageT (TraceT n))
     (EndpointTrie GQLQueryWithText)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (EndpointTrie GQLQueryWithText)
 -> ReaderT
      HandlerCtx
      (MetadataStorageT (TraceT n))
      (EndpointTrie GQLQueryWithText))
-> IO (EndpointTrie GQLQueryWithText)
-> ReaderT
     HandlerCtx
     (MetadataStorageT (TraceT n))
     (EndpointTrie GQLQueryWithText)
forall a b. (a -> b) -> a -> b
$ SchemaCache -> EndpointTrie GQLQueryWithText
scEndpoints (SchemaCache -> EndpointTrie GQLQueryWithText)
-> IO SchemaCache -> IO (EndpointTrie GQLQueryWithText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaCacheRef -> IO SchemaCache
getSchemaCache SchemaCacheRef
scRef
        ExecutionCtx
execCtx <- ReaderT HandlerCtx (MetadataStorageT (TraceT n)) ExecutionCtx
forall (m :: * -> *).
(MonadIO m, MonadReader HandlerCtx m) =>
m ExecutionCtx
mkExecutionContext
        Environment
env <- (HandlerCtx -> Environment)
-> ReaderT HandlerCtx (MetadataStorageT (TraceT n)) Environment
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerCtx -> Environment
scEnvironment (ServerCtx -> Environment)
-> (HandlerCtx -> ServerCtx) -> HandlerCtx -> Environment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerCtx -> ServerCtx
hcServerCtx)
        RequestId
requestId <- (HandlerCtx -> RequestId)
-> ReaderT HandlerCtx (MetadataStorageT (TraceT n)) RequestId
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks HandlerCtx -> RequestId
hcRequestId
        UserInfo
userInfo <- (HandlerCtx -> UserInfo)
-> ReaderT HandlerCtx (MetadataStorageT (TraceT n)) UserInfo
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks HandlerCtx -> UserInfo
hcUser
        [Header]
reqHeaders <- (HandlerCtx -> [Header])
-> ReaderT HandlerCtx (MetadataStorageT (TraceT n)) [Header]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks HandlerCtx -> [Header]
hcReqHeaders
        IpAddress
ipAddress <- (HandlerCtx -> IpAddress)
-> ReaderT HandlerCtx (MetadataStorageT (TraceT n)) IpAddress
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks HandlerCtx -> IpAddress
hcSourceIpAddress

        RestRequest EndpointMethod
req <-
          RestRequest SpockMethod
restReq RestRequest SpockMethod
-> (RestRequest SpockMethod
    -> ReaderT
         HandlerCtx
         (MetadataStorageT (TraceT n))
         (RestRequest EndpointMethod))
-> ReaderT
     HandlerCtx
     (MetadataStorageT (TraceT n))
     (RestRequest EndpointMethod)
forall a b. a -> (a -> b) -> b
& (SpockMethod
 -> ReaderT HandlerCtx (MetadataStorageT (TraceT n)) EndpointMethod)
-> RestRequest SpockMethod
-> ReaderT
     HandlerCtx
     (MetadataStorageT (TraceT n))
     (RestRequest EndpointMethod)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse \case
            Spock.MethodStandard (Spock.HttpMethod StdMethod
m) -> case StdMethod
m of
              StdMethod
Spock.GET -> EndpointMethod
-> ReaderT HandlerCtx (MetadataStorageT (TraceT n)) EndpointMethod
forall (f :: * -> *) a. Applicative f => a -> f a
pure EndpointMethod
EP.GET
              StdMethod
Spock.POST -> EndpointMethod
-> ReaderT HandlerCtx (MetadataStorageT (TraceT n)) EndpointMethod
forall (f :: * -> *) a. Applicative f => a -> f a
pure EndpointMethod
EP.POST
              StdMethod
Spock.PUT -> EndpointMethod
-> ReaderT HandlerCtx (MetadataStorageT (TraceT n)) EndpointMethod
forall (f :: * -> *) a. Applicative f => a -> f a
pure EndpointMethod
EP.PUT
              StdMethod
Spock.DELETE -> EndpointMethod
-> ReaderT HandlerCtx (MetadataStorageT (TraceT n)) EndpointMethod
forall (f :: * -> *) a. Applicative f => a -> f a
pure EndpointMethod
EP.DELETE
              StdMethod
Spock.PATCH -> EndpointMethod
-> ReaderT HandlerCtx (MetadataStorageT (TraceT n)) EndpointMethod
forall (f :: * -> *) a. Applicative f => a -> f a
pure EndpointMethod
EP.PATCH
              StdMethod
other -> Code
-> Text
-> ReaderT HandlerCtx (MetadataStorageT (TraceT n)) EndpointMethod
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
BadRequest (Text
 -> ReaderT HandlerCtx (MetadataStorageT (TraceT n)) EndpointMethod)
-> Text
-> ReaderT HandlerCtx (MetadataStorageT (TraceT n)) EndpointMethod
forall a b. (a -> b) -> a -> b
$ Text
"Method " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> StdMethod -> Text
forall a. Show a => a -> Text
tshow StdMethod
other Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" not supported."
            SpockMethod
_ -> Code
-> Text
-> ReaderT HandlerCtx (MetadataStorageT (TraceT n)) EndpointMethod
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
BadRequest (Text
 -> ReaderT HandlerCtx (MetadataStorageT (TraceT n)) EndpointMethod)
-> Text
-> ReaderT HandlerCtx (MetadataStorageT (TraceT n)) EndpointMethod
forall a b. (a -> b) -> a -> b
$ Text
"Nonstandard method not allowed for REST endpoints"
        (HttpResponse EncJSON -> APIResp)
-> (HttpLogMetadata n, HttpResponse EncJSON)
-> (HttpLogMetadata n, APIResp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HttpResponse EncJSON -> APIResp
JSONResp ((HttpLogMetadata n, HttpResponse EncJSON)
 -> (HttpLogMetadata n, APIResp))
-> ReaderT
     HandlerCtx
     (MetadataStorageT (TraceT n))
     (HttpLogMetadata n, HttpResponse EncJSON)
-> Handler (TraceT n) (HttpLogMetadata n, APIResp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Environment
-> ExecutionCtx
-> RequestId
-> UserInfo
-> [Header]
-> IpAddress
-> RestRequest EndpointMethod
-> EndpointTrie GQLQueryWithText
-> ReaderT
     HandlerCtx
     (MetadataStorageT (TraceT n))
     (HttpLogMetadata
        (ReaderT HandlerCtx (MetadataStorageT (TraceT n))),
      HttpResponse EncJSON)
forall (m :: * -> *).
(MonadIO m, MonadError QErr m, MonadTrace m, MonadBaseControl IO m,
 MonadGQLExecutionCheck m, MonadQueryLog m, MonadExecuteQuery m,
 MonadMetadataStorage (MetadataStorageT m), HttpLog m,
 MonadQueryTags m, HasResourceLimits m) =>
Environment
-> ExecutionCtx
-> RequestId
-> UserInfo
-> [Header]
-> IpAddress
-> RestRequest EndpointMethod
-> EndpointTrie GQLQueryWithText
-> m (HttpLogMetadata m, HttpResponse EncJSON)
runCustomEndpoint Environment
env ExecutionCtx
execCtx RequestId
requestId UserInfo
userInfo [Header]
reqHeaders IpAddress
ipAddress RestRequest EndpointMethod
req EndpointTrie GQLQueryWithText
endpoints

  -- See Issue #291 for discussion around restified feature
  Path '[Text] 'Closed
-> HVectElim '[Text] (ActionCtxT () m ()) -> SpockT m ()
forall (xs :: [*]) (t :: * -> (* -> *) -> * -> *) (m :: * -> *)
       (ps :: PathState) ctx.
(HasRep xs, RouteM t, Monad m) =>
Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
Spock.hookRouteAll (Path '[] 'Open
"api" Path '[] 'Open -> Path '[] 'Open -> Path (Append '[] '[]) 'Open
forall (as :: [*]) (bs :: [*]) (ps :: PathState).
Path as 'Open -> Path bs ps -> Path (Append as bs) ps
<//> Path '[] 'Open
"rest" Path '[] 'Open
-> Path '[Text] 'Closed -> Path (Append '[] '[Text]) 'Closed
forall (as :: [*]) (bs :: [*]) (ps :: PathState).
Path as 'Open -> Path bs ps -> Path (Append as bs) ps
<//> Path '[Text] 'Closed
Spock.wildcard) (HVectElim '[Text] (ActionCtxT () m ()) -> SpockT m ())
-> HVectElim '[Text] (ActionCtxT () m ()) -> SpockT m ()
forall a b. (a -> b) -> a -> b
$ \Text
wildcard -> do
    TracingMetadata
queryParams <- ActionCtxT () m TracingMetadata
forall (m :: * -> *) ctx.
MonadIO m =>
ActionCtxT ctx m TracingMetadata
Spock.params
    ByteString
body <- ActionCtxT () m ByteString
forall (m :: * -> *) ctx. MonadIO m => ActionCtxT ctx m ByteString
Spock.body
    SpockMethod
method <- ActionCtxT () m SpockMethod
forall (m :: * -> *) ctx. MonadIO m => ActionCtxT ctx m SpockMethod
Spock.reqMethod

    -- This is where we decode the json encoded body args. They
    -- are treated as if they came from query arguments, but allow
    -- us to pass non-scalar values.
    let bodyParams :: [(Text, Value)]
bodyParams = case ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
J.decodeStrict ByteString
body of
          Just (J.Object Object
o) -> (Pair -> (Text, Value)) -> [Pair] -> [(Text, Value)]
forall a b. (a -> b) -> [a] -> [b]
map ((Key -> Text) -> Pair -> (Text, Value)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Key -> Text
K.toText) ([Pair] -> [(Text, Value)]) -> [Pair] -> [(Text, Value)]
forall a b. (a -> b) -> a -> b
$ Object -> [Pair]
forall v. KeyMap v -> [(Key, v)]
KM.toList Object
o
          Maybe Value
_ -> []
        allParams :: [(Text, Either Text Value)]
allParams = (Text -> Either Text Value)
-> (Text, Text) -> (Text, Either Text Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Either Text Value
forall a b. a -> Either a b
Left ((Text, Text) -> (Text, Either Text Value))
-> TracingMetadata -> [(Text, Either Text Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TracingMetadata
queryParams [(Text, Either Text Value)]
-> [(Text, Either Text Value)] -> [(Text, Either Text Value)]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Value -> Either Text Value)
-> (Text, Value) -> (Text, Either Text Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Either Text Value
forall a b. b -> Either a b
Right ((Text, Value) -> (Text, Either Text Value))
-> [(Text, Value)] -> [(Text, Either Text Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Value)]
bodyParams

    (Bool -> QErr -> Value)
-> (QErr -> QErr) -> APIHandler (TraceT m) () -> ActionCtxT () m ()
forall a (n :: * -> *).
(FromJSON a, MonadIO n, MonadBaseControl IO n,
 UserAuthentication (TraceT n), HttpLog n, HasReporter n,
 HasResourceLimits n) =>
(Bool -> QErr -> Value)
-> (QErr -> QErr) -> APIHandler (TraceT n) a -> ActionT n ()
spockAction Bool -> QErr -> Value
encodeQErr QErr -> QErr
forall a. a -> a
id (APIHandler (TraceT m) () -> ActionCtxT () m ())
-> APIHandler (TraceT m) () -> ActionCtxT () m ()
forall a b. (a -> b) -> a -> b
$ do
      -- TODO: Are we actually able to use mkGetHandler in this situation? POST handler seems to do some work that we might want to avoid.
      Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
-> APIHandler (TraceT m) ()
forall (m :: * -> *).
Handler m (HttpLogMetadata m, APIResp) -> APIHandler m ()
mkGetHandler (Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
 -> APIHandler (TraceT m) ())
-> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
-> APIHandler (TraceT m) ()
forall a b. (a -> b) -> a -> b
$ RestRequest SpockMethod
-> Handler (TraceT m) (HttpLogMetadata m, APIResp)
forall (n :: * -> *).
(MonadIO n, MonadBaseControl IO n, MonadGQLExecutionCheck n,
 MonadQueryLog n, MonadExecuteQuery n,
 MonadMetadataStorage (MetadataStorageT n), HttpLog n,
 MonadQueryTags n, HasResourceLimits n) =>
RestRequest SpockMethod
-> Handler (TraceT n) (HttpLogMetadata n, APIResp)
customEndpointHandler (Text
-> SpockMethod
-> [(Text, Either Text Value)]
-> RestRequest SpockMethod
forall method.
Text -> method -> [(Text, Either Text Value)] -> RestRequest method
RestRequest Text
wildcard SpockMethod
method [(Text, Either Text Value)]
allParams)

  Bool -> SpockT m () -> SpockT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
enableMetadata (SpockT m () -> SpockT m ()) -> SpockT m () -> SpockT m ()
forall a b. (a -> b) -> a -> b
$ do
    Path '[] 'Open -> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall (xs :: [*]) (t :: * -> (* -> *) -> * -> *) (m :: * -> *)
       (ps :: PathState) ctx.
(HasRep xs, RouteM t, Monad m) =>
Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
Spock.post Path '[] 'Open
"v1/graphql/explain" ActionCtxT () m ()
HVectElim '[] (ActionCtxT () m ())
gqlExplainAction

    Path '[] 'Open -> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall (xs :: [*]) (t :: * -> (* -> *) -> * -> *) (m :: * -> *)
       (ps :: PathState) ctx.
(HasRep xs, RouteM t, Monad m) =>
Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
Spock.post Path '[] 'Open
"v1alpha1/graphql/explain" ActionCtxT () m ()
HVectElim '[] (ActionCtxT () m ())
gqlExplainAction

    Path '[] 'Open -> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall (xs :: [*]) (t :: * -> (* -> *) -> * -> *) (m :: * -> *)
       (ps :: PathState) ctx.
(HasRep xs, RouteM t, Monad m) =>
Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
Spock.post Path '[] 'Open
"v1/query" (HVectElim '[] (ActionCtxT () m ()) -> SpockT m ())
-> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall a b. (a -> b) -> a -> b
$
      (Bool -> QErr -> Value)
-> (QErr -> QErr)
-> APIHandler (TraceT m) RQLQuery
-> ActionCtxT () m ()
forall a (n :: * -> *).
(FromJSON a, MonadIO n, MonadBaseControl IO n,
 UserAuthentication (TraceT n), HttpLog n, HasReporter n,
 HasResourceLimits n) =>
(Bool -> QErr -> Value)
-> (QErr -> QErr) -> APIHandler (TraceT n) a -> ActionT n ()
spockAction Bool -> QErr -> Value
encodeQErr QErr -> QErr
forall a. a -> a
id (APIHandler (TraceT m) RQLQuery -> ActionCtxT () m ())
-> APIHandler (TraceT m) RQLQuery -> ActionCtxT () m ()
forall a b. (a -> b) -> a -> b
$ do
        (RQLQuery
 -> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp))
-> APIHandler (TraceT m) RQLQuery
forall a (m :: * -> *).
(a -> Handler m (HttpLogMetadata m, APIResp)) -> APIHandler m a
mkPostHandler ((RQLQuery
  -> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp))
 -> APIHandler (TraceT m) RQLQuery)
-> (RQLQuery
    -> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp))
-> APIHandler (TraceT m) RQLQuery
forall a b. (a -> b) -> a -> b
$ (APIResp -> (HttpLogMetadata m, APIResp))
-> ReaderT HandlerCtx (MetadataStorageT (TraceT m)) APIResp
-> Handler (TraceT m) (HttpLogMetadata m, APIResp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HttpLog m => HttpLogMetadata m
forall (m :: * -> *). HttpLog m => HttpLogMetadata m
emptyHttpLogMetadata @m,) (ReaderT HandlerCtx (MetadataStorageT (TraceT m)) APIResp
 -> Handler (TraceT m) (HttpLogMetadata m, APIResp))
-> (RQLQuery
    -> ReaderT HandlerCtx (MetadataStorageT (TraceT m)) APIResp)
-> RQLQuery
-> Handler (TraceT m) (HttpLogMetadata m, APIResp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RQLQuery -> Handler (TraceT m) (HttpResponse EncJSON))
-> RQLQuery
-> ReaderT HandlerCtx (MetadataStorageT (TraceT m)) APIResp
forall (m :: * -> *) a.
Functor m =>
(a -> Handler m (HttpResponse EncJSON)) -> a -> Handler m APIResp
mkAPIRespHandler RQLQuery -> Handler (TraceT m) (HttpResponse EncJSON)
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadMetadataApiAuthorization m,
 MonadTrace m, MonadReader HandlerCtx m, MonadMetadataStorage m,
 MonadResolveSource m, MonadQueryTags m) =>
RQLQuery -> m (HttpResponse EncJSON)
v1QueryHandler

    Path '[] 'Open -> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall (xs :: [*]) (t :: * -> (* -> *) -> * -> *) (m :: * -> *)
       (ps :: PathState) ctx.
(HasRep xs, RouteM t, Monad m) =>
Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
Spock.post Path '[] 'Open
"v1/metadata" (HVectElim '[] (ActionCtxT () m ()) -> SpockT m ())
-> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall a b. (a -> b) -> a -> b
$
      (Bool -> QErr -> Value)
-> (QErr -> QErr)
-> APIHandler (TraceT m) RQLMetadata
-> ActionCtxT () m ()
forall a (n :: * -> *).
(FromJSON a, MonadIO n, MonadBaseControl IO n,
 UserAuthentication (TraceT n), HttpLog n, HasReporter n,
 HasResourceLimits n) =>
(Bool -> QErr -> Value)
-> (QErr -> QErr) -> APIHandler (TraceT n) a -> ActionT n ()
spockAction Bool -> QErr -> Value
encodeQErr QErr -> QErr
forall a. a -> a
id (APIHandler (TraceT m) RQLMetadata -> ActionCtxT () m ())
-> APIHandler (TraceT m) RQLMetadata -> ActionCtxT () m ()
forall a b. (a -> b) -> a -> b
$
        (RQLMetadata
 -> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp))
-> APIHandler (TraceT m) RQLMetadata
forall a (m :: * -> *).
(a -> Handler m (HttpLogMetadata m, APIResp)) -> APIHandler m a
mkPostHandler ((RQLMetadata
  -> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp))
 -> APIHandler (TraceT m) RQLMetadata)
-> (RQLMetadata
    -> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp))
-> APIHandler (TraceT m) RQLMetadata
forall a b. (a -> b) -> a -> b
$ (APIResp -> (HttpLogMetadata m, APIResp))
-> ReaderT HandlerCtx (MetadataStorageT (TraceT m)) APIResp
-> Handler (TraceT m) (HttpLogMetadata m, APIResp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HttpLog m => HttpLogMetadata m
forall (m :: * -> *). HttpLog m => HttpLogMetadata m
emptyHttpLogMetadata @m,) (ReaderT HandlerCtx (MetadataStorageT (TraceT m)) APIResp
 -> Handler (TraceT m) (HttpLogMetadata m, APIResp))
-> (RQLMetadata
    -> ReaderT HandlerCtx (MetadataStorageT (TraceT m)) APIResp)
-> RQLMetadata
-> Handler (TraceT m) (HttpLogMetadata m, APIResp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RQLMetadata -> Handler (TraceT m) (HttpResponse EncJSON))
-> RQLMetadata
-> ReaderT HandlerCtx (MetadataStorageT (TraceT m)) APIResp
forall (m :: * -> *) a.
Functor m =>
(a -> Handler m (HttpResponse EncJSON)) -> a -> Handler m APIResp
mkAPIRespHandler RQLMetadata -> Handler (TraceT m) (HttpResponse EncJSON)
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadReader HandlerCtx m,
 MonadTrace m, MonadMetadataStorage m, MonadResolveSource m,
 MonadMetadataApiAuthorization m) =>
RQLMetadata -> m (HttpResponse EncJSON)
v1MetadataHandler

    Path '[] 'Open -> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall (xs :: [*]) (t :: * -> (* -> *) -> * -> *) (m :: * -> *)
       (ps :: PathState) ctx.
(HasRep xs, RouteM t, Monad m) =>
Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
Spock.post Path '[] 'Open
"v2/query" (HVectElim '[] (ActionCtxT () m ()) -> SpockT m ())
-> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall a b. (a -> b) -> a -> b
$
      (Bool -> QErr -> Value)
-> (QErr -> QErr)
-> APIHandler (TraceT m) RQLQuery
-> ActionCtxT () m ()
forall a (n :: * -> *).
(FromJSON a, MonadIO n, MonadBaseControl IO n,
 UserAuthentication (TraceT n), HttpLog n, HasReporter n,
 HasResourceLimits n) =>
(Bool -> QErr -> Value)
-> (QErr -> QErr) -> APIHandler (TraceT n) a -> ActionT n ()
spockAction Bool -> QErr -> Value
encodeQErr QErr -> QErr
forall a. a -> a
id (APIHandler (TraceT m) RQLQuery -> ActionCtxT () m ())
-> APIHandler (TraceT m) RQLQuery -> ActionCtxT () m ()
forall a b. (a -> b) -> a -> b
$
        (RQLQuery
 -> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp))
-> APIHandler (TraceT m) RQLQuery
forall a (m :: * -> *).
(a -> Handler m (HttpLogMetadata m, APIResp)) -> APIHandler m a
mkPostHandler ((RQLQuery
  -> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp))
 -> APIHandler (TraceT m) RQLQuery)
-> (RQLQuery
    -> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp))
-> APIHandler (TraceT m) RQLQuery
forall a b. (a -> b) -> a -> b
$ (APIResp -> (HttpLogMetadata m, APIResp))
-> ReaderT HandlerCtx (MetadataStorageT (TraceT m)) APIResp
-> Handler (TraceT m) (HttpLogMetadata m, APIResp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HttpLog m => HttpLogMetadata m
forall (m :: * -> *). HttpLog m => HttpLogMetadata m
emptyHttpLogMetadata @m,) (ReaderT HandlerCtx (MetadataStorageT (TraceT m)) APIResp
 -> Handler (TraceT m) (HttpLogMetadata m, APIResp))
-> (RQLQuery
    -> ReaderT HandlerCtx (MetadataStorageT (TraceT m)) APIResp)
-> RQLQuery
-> Handler (TraceT m) (HttpLogMetadata m, APIResp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RQLQuery -> Handler (TraceT m) (HttpResponse EncJSON))
-> RQLQuery
-> ReaderT HandlerCtx (MetadataStorageT (TraceT m)) APIResp
forall (m :: * -> *) a.
Functor m =>
(a -> Handler m (HttpResponse EncJSON)) -> a -> Handler m APIResp
mkAPIRespHandler RQLQuery -> Handler (TraceT m) (HttpResponse EncJSON)
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadMetadataApiAuthorization m,
 MonadTrace m, MonadReader HandlerCtx m, MonadMetadataStorage m,
 MonadResolveSource m, MonadQueryTags m) =>
RQLQuery -> m (HttpResponse EncJSON)
v2QueryHandler

  Bool -> SpockT m () -> SpockT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
enablePGDump (SpockT m () -> SpockT m ()) -> SpockT m () -> SpockT m ()
forall a b. (a -> b) -> a -> b
$
    Path '[] 'Open -> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall (xs :: [*]) (t :: * -> (* -> *) -> * -> *) (m :: * -> *)
       (ps :: PathState) ctx.
(HasRep xs, RouteM t, Monad m) =>
Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
Spock.post Path '[] 'Open
"v1alpha1/pg_dump" (HVectElim '[] (ActionCtxT () m ()) -> SpockT m ())
-> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall a b. (a -> b) -> a -> b
$
      (Bool -> QErr -> Value)
-> (QErr -> QErr)
-> APIHandler (TraceT m) PGDumpReqBody
-> ActionCtxT () m ()
forall a (n :: * -> *).
(FromJSON a, MonadIO n, MonadBaseControl IO n,
 UserAuthentication (TraceT n), HttpLog n, HasReporter n,
 HasResourceLimits n) =>
(Bool -> QErr -> Value)
-> (QErr -> QErr) -> APIHandler (TraceT n) a -> ActionT n ()
spockAction Bool -> QErr -> Value
encodeQErr QErr -> QErr
forall a. a -> a
id (APIHandler (TraceT m) PGDumpReqBody -> ActionCtxT () m ())
-> APIHandler (TraceT m) PGDumpReqBody -> ActionCtxT () m ()
forall a b. (a -> b) -> a -> b
$
        (PGDumpReqBody
 -> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp))
-> APIHandler (TraceT m) PGDumpReqBody
forall a (m :: * -> *).
(a -> Handler m (HttpLogMetadata m, APIResp)) -> APIHandler m a
mkPostHandler ((PGDumpReqBody
  -> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp))
 -> APIHandler (TraceT m) PGDumpReqBody)
-> (PGDumpReqBody
    -> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp))
-> APIHandler (TraceT m) PGDumpReqBody
forall a b. (a -> b) -> a -> b
$ (APIResp -> (HttpLogMetadata m, APIResp))
-> ReaderT HandlerCtx (MetadataStorageT (TraceT m)) APIResp
-> Handler (TraceT m) (HttpLogMetadata m, APIResp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HttpLog m => HttpLogMetadata m
forall (m :: * -> *). HttpLog m => HttpLogMetadata m
emptyHttpLogMetadata @m,) (ReaderT HandlerCtx (MetadataStorageT (TraceT m)) APIResp
 -> Handler (TraceT m) (HttpLogMetadata m, APIResp))
-> (PGDumpReqBody
    -> ReaderT HandlerCtx (MetadataStorageT (TraceT m)) APIResp)
-> PGDumpReqBody
-> Handler (TraceT m) (HttpLogMetadata m, APIResp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PGDumpReqBody
-> ReaderT HandlerCtx (MetadataStorageT (TraceT m)) APIResp
forall (m :: * -> *).
(MonadIO m, MonadError QErr m, MonadReader HandlerCtx m) =>
PGDumpReqBody -> m APIResp
v1Alpha1PGDumpHandler

  Bool -> SpockT m () -> SpockT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
enableConfig (SpockT m () -> SpockT m ()) -> SpockT m () -> SpockT m ()
forall a b. (a -> b) -> a -> b
$ ServerCtx -> Maybe Text -> SpockT m ()
forall (m :: * -> *).
MonadConfigApiHandler m =>
ServerCtx -> Maybe Text -> SpockCtxT () m ()
runConfigApiHandler ServerCtx
serverCtx Maybe Text
consoleAssetsDir

  Bool -> SpockT m () -> SpockT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
enableGraphQL (SpockT m () -> SpockT m ()) -> SpockT m () -> SpockT m ()
forall a b. (a -> b) -> a -> b
$ do
    Path '[] 'Open -> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall (xs :: [*]) (t :: * -> (* -> *) -> * -> *) (m :: * -> *)
       (ps :: PathState) ctx.
(HasRep xs, RouteM t, Monad m) =>
Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
Spock.post Path '[] 'Open
"v1alpha1/graphql" (HVectElim '[] (ActionCtxT () m ()) -> SpockT m ())
-> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall a b. (a -> b) -> a -> b
$
      (Bool -> QErr -> Value)
-> (QErr -> QErr)
-> APIHandler (TraceT m) ReqsText
-> ActionCtxT () m ()
forall a (n :: * -> *).
(FromJSON a, MonadIO n, MonadBaseControl IO n,
 UserAuthentication (TraceT n), HttpLog n, HasReporter n,
 HasResourceLimits n) =>
(Bool -> QErr -> Value)
-> (QErr -> QErr) -> APIHandler (TraceT n) a -> ActionT n ()
spockAction Bool -> QErr -> Value
GH.encodeGQErr QErr -> QErr
forall a. a -> a
id (APIHandler (TraceT m) ReqsText -> ActionCtxT () m ())
-> APIHandler (TraceT m) ReqsText -> ActionCtxT () m ()
forall a b. (a -> b) -> a -> b
$
        (ReqsText
 -> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp))
-> APIHandler (TraceT m) ReqsText
forall (m :: * -> *).
(ReqsText -> Handler m (HttpLogMetadata m, APIResp))
-> APIHandler m ReqsText
mkGQLRequestHandler ((ReqsText
  -> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp))
 -> APIHandler (TraceT m) ReqsText)
-> (ReqsText
    -> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp))
-> APIHandler (TraceT m) ReqsText
forall a b. (a -> b) -> a -> b
$ (ReqsText
 -> Handler (TraceT m) (HttpLogMetadata m, HttpResponse EncJSON))
-> ReqsText -> Handler (TraceT m) (HttpLogMetadata m, APIResp)
forall (m :: * -> *) a b.
Functor m =>
(a -> Handler m (b, HttpResponse EncJSON))
-> a -> Handler m (b, APIResp)
mkGQLAPIRespHandler ((ReqsText
  -> Handler (TraceT m) (HttpLogMetadata m, HttpResponse EncJSON))
 -> ReqsText -> Handler (TraceT m) (HttpLogMetadata m, APIResp))
-> (ReqsText
    -> Handler (TraceT m) (HttpLogMetadata m, HttpResponse EncJSON))
-> ReqsText
-> Handler (TraceT m) (HttpLogMetadata m, APIResp)
forall a b. (a -> b) -> a -> b
$ GraphQLQueryType
-> ReqsText
-> ReaderT
     HandlerCtx
     (MetadataStorageT (TraceT m))
     (HttpLogMetadata
        (ReaderT HandlerCtx (MetadataStorageT (TraceT m))),
      HttpResponse EncJSON)
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadGQLExecutionCheck m,
 MonadQueryLog m, MonadTrace m, MonadExecuteQuery m,
 MonadError QErr m, MonadReader HandlerCtx m, HttpLog m,
 MonadMetadataStorage (MetadataStorageT m), MonadQueryTags m,
 HasResourceLimits m) =>
GraphQLQueryType
-> ReqsText -> m (HttpLogMetadata m, HttpResponse EncJSON)
v1Alpha1GQHandler GraphQLQueryType
E.QueryHasura

    Path '[] 'Open -> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall (xs :: [*]) (t :: * -> (* -> *) -> * -> *) (m :: * -> *)
       (ps :: PathState) ctx.
(HasRep xs, RouteM t, Monad m) =>
Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
Spock.post Path '[] 'Open
"v1/graphql" (HVectElim '[] (ActionCtxT () m ()) -> SpockT m ())
-> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall a b. (a -> b) -> a -> b
$
      (Bool -> QErr -> Value)
-> (QErr -> QErr)
-> APIHandler (TraceT m) ReqsText
-> ActionCtxT () m ()
forall a (n :: * -> *).
(FromJSON a, MonadIO n, MonadBaseControl IO n,
 UserAuthentication (TraceT n), HttpLog n, HasReporter n,
 HasResourceLimits n) =>
(Bool -> QErr -> Value)
-> (QErr -> QErr) -> APIHandler (TraceT n) a -> ActionT n ()
spockAction Bool -> QErr -> Value
GH.encodeGQErr QErr -> QErr
allMod200 (APIHandler (TraceT m) ReqsText -> ActionCtxT () m ())
-> APIHandler (TraceT m) ReqsText -> ActionCtxT () m ()
forall a b. (a -> b) -> a -> b
$
        (ReqsText
 -> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp))
-> APIHandler (TraceT m) ReqsText
forall (m :: * -> *).
(ReqsText -> Handler m (HttpLogMetadata m, APIResp))
-> APIHandler m ReqsText
mkGQLRequestHandler ((ReqsText
  -> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp))
 -> APIHandler (TraceT m) ReqsText)
-> (ReqsText
    -> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp))
-> APIHandler (TraceT m) ReqsText
forall a b. (a -> b) -> a -> b
$ (ReqsText
 -> Handler (TraceT m) (HttpLogMetadata m, HttpResponse EncJSON))
-> ReqsText -> Handler (TraceT m) (HttpLogMetadata m, APIResp)
forall (m :: * -> *) a b.
Functor m =>
(a -> Handler m (b, HttpResponse EncJSON))
-> a -> Handler m (b, APIResp)
mkGQLAPIRespHandler ReqsText
-> Handler (TraceT m) (HttpLogMetadata m, HttpResponse EncJSON)
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadGQLExecutionCheck m,
 MonadQueryLog m, MonadTrace m, MonadExecuteQuery m, HttpLog m,
 MonadError QErr m, MonadReader HandlerCtx m,
 MonadMetadataStorage (MetadataStorageT m), MonadQueryTags m,
 HasResourceLimits m) =>
ReqsText -> m (HttpLogMetadata m, HttpResponse EncJSON)
v1GQHandler

    Path '[] 'Open -> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall (xs :: [*]) (t :: * -> (* -> *) -> * -> *) (m :: * -> *)
       (ps :: PathState) ctx.
(HasRep xs, RouteM t, Monad m) =>
Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
Spock.post Path '[] 'Open
"v1beta1/relay" (HVectElim '[] (ActionCtxT () m ()) -> SpockT m ())
-> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall a b. (a -> b) -> a -> b
$
      (Bool -> QErr -> Value)
-> (QErr -> QErr)
-> APIHandler (TraceT m) ReqsText
-> ActionCtxT () m ()
forall a (n :: * -> *).
(FromJSON a, MonadIO n, MonadBaseControl IO n,
 UserAuthentication (TraceT n), HttpLog n, HasReporter n,
 HasResourceLimits n) =>
(Bool -> QErr -> Value)
-> (QErr -> QErr) -> APIHandler (TraceT n) a -> ActionT n ()
spockAction Bool -> QErr -> Value
GH.encodeGQErr QErr -> QErr
allMod200 (APIHandler (TraceT m) ReqsText -> ActionCtxT () m ())
-> APIHandler (TraceT m) ReqsText -> ActionCtxT () m ()
forall a b. (a -> b) -> a -> b
$
        (ReqsText
 -> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp))
-> APIHandler (TraceT m) ReqsText
forall (m :: * -> *).
(ReqsText -> Handler m (HttpLogMetadata m, APIResp))
-> APIHandler m ReqsText
mkGQLRequestHandler ((ReqsText
  -> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp))
 -> APIHandler (TraceT m) ReqsText)
-> (ReqsText
    -> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp))
-> APIHandler (TraceT m) ReqsText
forall a b. (a -> b) -> a -> b
$ (ReqsText
 -> Handler (TraceT m) (HttpLogMetadata m, HttpResponse EncJSON))
-> ReqsText -> Handler (TraceT m) (HttpLogMetadata m, APIResp)
forall (m :: * -> *) a b.
Functor m =>
(a -> Handler m (b, HttpResponse EncJSON))
-> a -> Handler m (b, APIResp)
mkGQLAPIRespHandler ((ReqsText
  -> Handler (TraceT m) (HttpLogMetadata m, HttpResponse EncJSON))
 -> ReqsText -> Handler (TraceT m) (HttpLogMetadata m, APIResp))
-> (ReqsText
    -> Handler (TraceT m) (HttpLogMetadata m, HttpResponse EncJSON))
-> ReqsText
-> Handler (TraceT m) (HttpLogMetadata m, APIResp)
forall a b. (a -> b) -> a -> b
$ ReqsText
-> Handler (TraceT m) (HttpLogMetadata m, HttpResponse EncJSON)
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadGQLExecutionCheck m,
 MonadQueryLog m, MonadTrace m, HttpLog m, MonadExecuteQuery m,
 MonadError QErr m, MonadReader HandlerCtx m,
 MonadMetadataStorage (MetadataStorageT m), MonadQueryTags m,
 HasResourceLimits m) =>
ReqsText -> m (HttpLogMetadata m, HttpResponse EncJSON)
v1GQRelayHandler

  -- This exposes some simple RTS stats when we run with `+RTS -T`. We want
  -- this to be available even when developer APIs are not compiled in, to
  -- support benchmarking.
  -- See: https://hackage.haskell.org/package/base/docs/GHC-Stats.html
  Bool
exposeRtsStats <- IO Bool -> SpockCtxT () m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Bool
RTS.getRTSStatsEnabled
  Bool -> SpockT m () -> SpockT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exposeRtsStats (SpockT m () -> SpockT m ()) -> SpockT m () -> SpockT m ()
forall a b. (a -> b) -> a -> b
$ do
    Path '[] 'Open -> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall (xs :: [*]) (t :: * -> (* -> *) -> * -> *) (m :: * -> *)
       (ps :: PathState) ctx.
(HasRep xs, RouteM t, Monad m) =>
Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
Spock.get Path '[] 'Open
"dev/rts_stats" (HVectElim '[] (ActionCtxT () m ()) -> SpockT m ())
-> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall a b. (a -> b) -> a -> b
$ do
      -- This ensures the live_bytes and other counters from GCDetails are fresh:
      IO () -> ActionCtxT () m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
performMajorGC
      RTSStats
stats <- IO RTSStats -> ActionCtxT () m RTSStats
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO RTSStats
RTS.getRTSStats
      RTSStats -> ActionCtxT () m ()
forall a (m :: * -> *) ctx b.
(ToJSON a, MonadIO m) =>
a -> ActionCtxT ctx m b
Spock.json RTSStats
stats

  Bool -> SpockT m () -> SpockT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ServerCtx -> Bool
isDeveloperAPIEnabled ServerCtx
serverCtx) (SpockT m () -> SpockT m ()) -> SpockT m () -> SpockT m ()
forall a b. (a -> b) -> a -> b
$ do
    Path '[] 'Open -> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall (xs :: [*]) (t :: * -> (* -> *) -> * -> *) (m :: * -> *)
       (ps :: PathState) ctx.
(HasRep xs, RouteM t, Monad m) =>
Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
Spock.get Path '[] 'Open
"dev/ekg" (HVectElim '[] (ActionCtxT () m ()) -> SpockT m ())
-> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall a b. (a -> b) -> a -> b
$
      (Bool -> QErr -> Value)
-> (QErr -> QErr) -> APIHandler (TraceT m) () -> ActionCtxT () m ()
forall a (n :: * -> *).
(FromJSON a, MonadIO n, MonadBaseControl IO n,
 UserAuthentication (TraceT n), HttpLog n, HasReporter n,
 HasResourceLimits n) =>
(Bool -> QErr -> Value)
-> (QErr -> QErr) -> APIHandler (TraceT n) a -> ActionT n ()
spockAction Bool -> QErr -> Value
encodeQErr QErr -> QErr
forall a. a -> a
id (APIHandler (TraceT m) () -> ActionCtxT () m ())
-> APIHandler (TraceT m) () -> ActionCtxT () m ()
forall a b. (a -> b) -> a -> b
$
        Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
-> APIHandler (TraceT m) ()
forall (m :: * -> *).
Handler m (HttpLogMetadata m, APIResp) -> APIHandler m ()
mkGetHandler (Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
 -> APIHandler (TraceT m) ())
-> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
-> APIHandler (TraceT m) ()
forall a b. (a -> b) -> a -> b
$ do
          ReaderT HandlerCtx (MetadataStorageT (TraceT m)) ()
forall (m :: * -> *).
(MonadError QErr m, MonadReader HandlerCtx m) =>
m ()
onlyAdmin
          Sample
respJ <- IO Sample
-> ReaderT HandlerCtx (MetadataStorageT (TraceT m)) Sample
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Sample
 -> ReaderT HandlerCtx (MetadataStorageT (TraceT m)) Sample)
-> IO Sample
-> ReaderT HandlerCtx (MetadataStorageT (TraceT m)) Sample
forall a b. (a -> b) -> a -> b
$ Store EmptyMetrics -> IO Sample
forall (metrics :: Symbol -> MetricType -> * -> *).
Store metrics -> IO Sample
EKG.sampleAll (Store EmptyMetrics -> IO Sample)
-> Store EmptyMetrics -> IO Sample
forall a b. (a -> b) -> a -> b
$ ServerCtx -> Store EmptyMetrics
scEkgStore ServerCtx
serverCtx
          (HttpLogMetadata m, APIResp)
-> Handler (TraceT m) (HttpLogMetadata m, APIResp)
forall (m :: * -> *) a. Monad m => a -> m a
return (HttpLog m => HttpLogMetadata m
forall (m :: * -> *). HttpLog m => HttpLogMetadata m
emptyHttpLogMetadata @m, HttpResponse EncJSON -> APIResp
JSONResp (HttpResponse EncJSON -> APIResp)
-> HttpResponse EncJSON -> APIResp
forall a b. (a -> b) -> a -> b
$ EncJSON -> [Header] -> HttpResponse EncJSON
forall a. a -> [Header] -> HttpResponse a
HttpResponse (Value -> EncJSON
forall a. ToJSON a => a -> EncJSON
encJFromJValue (Value -> EncJSON) -> Value -> EncJSON
forall a b. (a -> b) -> a -> b
$ Sample -> Value
EKG.sampleToJson Sample
respJ) [])
    -- This deprecated endpoint used to show the query plan cache pre-PDV.
    -- Eventually this endpoint can be removed.
    Path '[] 'Open -> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall (xs :: [*]) (t :: * -> (* -> *) -> * -> *) (m :: * -> *)
       (ps :: PathState) ctx.
(HasRep xs, RouteM t, Monad m) =>
Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
Spock.get Path '[] 'Open
"dev/plan_cache" (HVectElim '[] (ActionCtxT () m ()) -> SpockT m ())
-> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall a b. (a -> b) -> a -> b
$
      (Bool -> QErr -> Value)
-> (QErr -> QErr) -> APIHandler (TraceT m) () -> ActionCtxT () m ()
forall a (n :: * -> *).
(FromJSON a, MonadIO n, MonadBaseControl IO n,
 UserAuthentication (TraceT n), HttpLog n, HasReporter n,
 HasResourceLimits n) =>
(Bool -> QErr -> Value)
-> (QErr -> QErr) -> APIHandler (TraceT n) a -> ActionT n ()
spockAction Bool -> QErr -> Value
encodeQErr QErr -> QErr
forall a. a -> a
id (APIHandler (TraceT m) () -> ActionCtxT () m ())
-> APIHandler (TraceT m) () -> ActionCtxT () m ()
forall a b. (a -> b) -> a -> b
$
        Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
-> APIHandler (TraceT m) ()
forall (m :: * -> *).
Handler m (HttpLogMetadata m, APIResp) -> APIHandler m ()
mkGetHandler (Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
 -> APIHandler (TraceT m) ())
-> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
-> APIHandler (TraceT m) ()
forall a b. (a -> b) -> a -> b
$ do
          ReaderT HandlerCtx (MetadataStorageT (TraceT m)) ()
forall (m :: * -> *).
(MonadError QErr m, MonadReader HandlerCtx m) =>
m ()
onlyAdmin
          (HttpLogMetadata m, APIResp)
-> Handler (TraceT m) (HttpLogMetadata m, APIResp)
forall (m :: * -> *) a. Monad m => a -> m a
return (HttpLog m => HttpLogMetadata m
forall (m :: * -> *). HttpLog m => HttpLogMetadata m
emptyHttpLogMetadata @m, HttpResponse EncJSON -> APIResp
JSONResp (HttpResponse EncJSON -> APIResp)
-> HttpResponse EncJSON -> APIResp
forall a b. (a -> b) -> a -> b
$ EncJSON -> [Header] -> HttpResponse EncJSON
forall a. a -> [Header] -> HttpResponse a
HttpResponse (Value -> EncJSON
forall a. ToJSON a => a -> EncJSON
encJFromJValue Value
J.Null) [])
    Path '[] 'Open -> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall (xs :: [*]) (t :: * -> (* -> *) -> * -> *) (m :: * -> *)
       (ps :: PathState) ctx.
(HasRep xs, RouteM t, Monad m) =>
Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
Spock.get Path '[] 'Open
"dev/subscriptions" (HVectElim '[] (ActionCtxT () m ()) -> SpockT m ())
-> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall a b. (a -> b) -> a -> b
$
      (Bool -> QErr -> Value)
-> (QErr -> QErr) -> APIHandler (TraceT m) () -> ActionCtxT () m ()
forall a (n :: * -> *).
(FromJSON a, MonadIO n, MonadBaseControl IO n,
 UserAuthentication (TraceT n), HttpLog n, HasReporter n,
 HasResourceLimits n) =>
(Bool -> QErr -> Value)
-> (QErr -> QErr) -> APIHandler (TraceT n) a -> ActionT n ()
spockAction Bool -> QErr -> Value
encodeQErr QErr -> QErr
forall a. a -> a
id (APIHandler (TraceT m) () -> ActionCtxT () m ())
-> APIHandler (TraceT m) () -> ActionCtxT () m ()
forall a b. (a -> b) -> a -> b
$
        Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
-> APIHandler (TraceT m) ()
forall (m :: * -> *).
Handler m (HttpLogMetadata m, APIResp) -> APIHandler m ()
mkGetHandler (Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
 -> APIHandler (TraceT m) ())
-> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
-> APIHandler (TraceT m) ()
forall a b. (a -> b) -> a -> b
$ do
          ReaderT HandlerCtx (MetadataStorageT (TraceT m)) ()
forall (m :: * -> *).
(MonadError QErr m, MonadReader HandlerCtx m) =>
m ()
onlyAdmin
          Value
respJ <- IO Value -> ReaderT HandlerCtx (MetadataStorageT (TraceT m)) Value
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Value
 -> ReaderT HandlerCtx (MetadataStorageT (TraceT m)) Value)
-> IO Value
-> ReaderT HandlerCtx (MetadataStorageT (TraceT m)) Value
forall a b. (a -> b) -> a -> b
$ Bool -> SubscriptionsState -> IO Value
ES.dumpSubscriptionsState Bool
False (SubscriptionsState -> IO Value) -> SubscriptionsState -> IO Value
forall a b. (a -> b) -> a -> b
$ ServerCtx -> SubscriptionsState
scSubscriptionState ServerCtx
serverCtx
          (HttpLogMetadata m, APIResp)
-> Handler (TraceT m) (HttpLogMetadata m, APIResp)
forall (m :: * -> *) a. Monad m => a -> m a
return (HttpLog m => HttpLogMetadata m
forall (m :: * -> *). HttpLog m => HttpLogMetadata m
emptyHttpLogMetadata @m, HttpResponse EncJSON -> APIResp
JSONResp (HttpResponse EncJSON -> APIResp)
-> HttpResponse EncJSON -> APIResp
forall a b. (a -> b) -> a -> b
$ EncJSON -> [Header] -> HttpResponse EncJSON
forall a. a -> [Header] -> HttpResponse a
HttpResponse (Value -> EncJSON
forall a. ToJSON a => a -> EncJSON
encJFromJValue Value
respJ) [])
    Path '[] 'Open -> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall (xs :: [*]) (t :: * -> (* -> *) -> * -> *) (m :: * -> *)
       (ps :: PathState) ctx.
(HasRep xs, RouteM t, Monad m) =>
Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
Spock.get Path '[] 'Open
"dev/subscriptions/extended" (HVectElim '[] (ActionCtxT () m ()) -> SpockT m ())
-> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall a b. (a -> b) -> a -> b
$
      (Bool -> QErr -> Value)
-> (QErr -> QErr) -> APIHandler (TraceT m) () -> ActionCtxT () m ()
forall a (n :: * -> *).
(FromJSON a, MonadIO n, MonadBaseControl IO n,
 UserAuthentication (TraceT n), HttpLog n, HasReporter n,
 HasResourceLimits n) =>
(Bool -> QErr -> Value)
-> (QErr -> QErr) -> APIHandler (TraceT n) a -> ActionT n ()
spockAction Bool -> QErr -> Value
encodeQErr QErr -> QErr
forall a. a -> a
id (APIHandler (TraceT m) () -> ActionCtxT () m ())
-> APIHandler (TraceT m) () -> ActionCtxT () m ()
forall a b. (a -> b) -> a -> b
$
        Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
-> APIHandler (TraceT m) ()
forall (m :: * -> *).
Handler m (HttpLogMetadata m, APIResp) -> APIHandler m ()
mkGetHandler (Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
 -> APIHandler (TraceT m) ())
-> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
-> APIHandler (TraceT m) ()
forall a b. (a -> b) -> a -> b
$ do
          ReaderT HandlerCtx (MetadataStorageT (TraceT m)) ()
forall (m :: * -> *).
(MonadError QErr m, MonadReader HandlerCtx m) =>
m ()
onlyAdmin
          Value
respJ <- IO Value -> ReaderT HandlerCtx (MetadataStorageT (TraceT m)) Value
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Value
 -> ReaderT HandlerCtx (MetadataStorageT (TraceT m)) Value)
-> IO Value
-> ReaderT HandlerCtx (MetadataStorageT (TraceT m)) Value
forall a b. (a -> b) -> a -> b
$ Bool -> SubscriptionsState -> IO Value
ES.dumpSubscriptionsState Bool
True (SubscriptionsState -> IO Value) -> SubscriptionsState -> IO Value
forall a b. (a -> b) -> a -> b
$ ServerCtx -> SubscriptionsState
scSubscriptionState ServerCtx
serverCtx
          (HttpLogMetadata m, APIResp)
-> Handler (TraceT m) (HttpLogMetadata m, APIResp)
forall (m :: * -> *) a. Monad m => a -> m a
return (HttpLog m => HttpLogMetadata m
forall (m :: * -> *). HttpLog m => HttpLogMetadata m
emptyHttpLogMetadata @m, HttpResponse EncJSON -> APIResp
JSONResp (HttpResponse EncJSON -> APIResp)
-> HttpResponse EncJSON -> APIResp
forall a b. (a -> b) -> a -> b
$ EncJSON -> [Header] -> HttpResponse EncJSON
forall a. a -> [Header] -> HttpResponse a
HttpResponse (Value -> EncJSON
forall a. ToJSON a => a -> EncJSON
encJFromJValue Value
respJ) [])
    Path '[] 'Open -> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall (xs :: [*]) (t :: * -> (* -> *) -> * -> *) (m :: * -> *)
       (ps :: PathState) ctx.
(HasRep xs, RouteM t, Monad m) =>
Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
Spock.get Path '[] 'Open
"dev/dataconnector/schema" (HVectElim '[] (ActionCtxT () m ()) -> SpockT m ())
-> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall a b. (a -> b) -> a -> b
$
      (Bool -> QErr -> Value)
-> (QErr -> QErr) -> APIHandler (TraceT m) () -> ActionCtxT () m ()
forall a (n :: * -> *).
(FromJSON a, MonadIO n, MonadBaseControl IO n,
 UserAuthentication (TraceT n), HttpLog n, HasReporter n,
 HasResourceLimits n) =>
(Bool -> QErr -> Value)
-> (QErr -> QErr) -> APIHandler (TraceT n) a -> ActionT n ()
spockAction Bool -> QErr -> Value
encodeQErr QErr -> QErr
forall a. a -> a
id (APIHandler (TraceT m) () -> ActionCtxT () m ())
-> APIHandler (TraceT m) () -> ActionCtxT () m ()
forall a b. (a -> b) -> a -> b
$
        Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
-> APIHandler (TraceT m) ()
forall (m :: * -> *).
Handler m (HttpLogMetadata m, APIResp) -> APIHandler m ()
mkGetHandler (Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
 -> APIHandler (TraceT m) ())
-> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
-> APIHandler (TraceT m) ()
forall a b. (a -> b) -> a -> b
$ do
          ReaderT HandlerCtx (MetadataStorageT (TraceT m)) ()
forall (m :: * -> *).
(MonadError QErr m, MonadReader HandlerCtx m) =>
m ()
onlyAdmin
          (HttpLogMetadata m, APIResp)
-> Handler (TraceT m) (HttpLogMetadata m, APIResp)
forall (m :: * -> *) a. Monad m => a -> m a
return (HttpLog m => HttpLogMetadata m
forall (m :: * -> *). HttpLog m => HttpLogMetadata m
emptyHttpLogMetadata @m, HttpResponse EncJSON -> APIResp
JSONResp (HttpResponse EncJSON -> APIResp)
-> HttpResponse EncJSON -> APIResp
forall a b. (a -> b) -> a -> b
$ EncJSON -> [Header] -> HttpResponse EncJSON
forall a. a -> [Header] -> HttpResponse a
HttpResponse (OpenApi -> EncJSON
forall a. ToJSON a => a -> EncJSON
encJFromJValue OpenApi
openApiSchema) [])
  Path '[] 'Open -> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall (xs :: [*]) (t :: * -> (* -> *) -> * -> *) (m :: * -> *)
       (ps :: PathState) ctx.
(HasRep xs, RouteM t, Monad m) =>
Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
Spock.get Path '[] 'Open
"api/swagger/json" (HVectElim '[] (ActionCtxT () m ()) -> SpockT m ())
-> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall a b. (a -> b) -> a -> b
$
    (Bool -> QErr -> Value)
-> (QErr -> QErr) -> APIHandler (TraceT m) () -> ActionCtxT () m ()
forall a (n :: * -> *).
(FromJSON a, MonadIO n, MonadBaseControl IO n,
 UserAuthentication (TraceT n), HttpLog n, HasReporter n,
 HasResourceLimits n) =>
(Bool -> QErr -> Value)
-> (QErr -> QErr) -> APIHandler (TraceT n) a -> ActionT n ()
spockAction Bool -> QErr -> Value
encodeQErr QErr -> QErr
forall a. a -> a
id (APIHandler (TraceT m) () -> ActionCtxT () m ())
-> APIHandler (TraceT m) () -> ActionCtxT () m ()
forall a b. (a -> b) -> a -> b
$
      Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
-> APIHandler (TraceT m) ()
forall (m :: * -> *).
Handler m (HttpLogMetadata m, APIResp) -> APIHandler m ()
mkGetHandler (Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
 -> APIHandler (TraceT m) ())
-> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp)
-> APIHandler (TraceT m) ()
forall a b. (a -> b) -> a -> b
$ do
        ReaderT HandlerCtx (MetadataStorageT (TraceT m)) ()
forall (m :: * -> *).
(MonadError QErr m, MonadReader HandlerCtx m) =>
m ()
onlyAdmin
        SchemaCache
sc <- IO SchemaCache
-> ReaderT HandlerCtx (MetadataStorageT (TraceT m)) SchemaCache
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SchemaCache
 -> ReaderT HandlerCtx (MetadataStorageT (TraceT m)) SchemaCache)
-> IO SchemaCache
-> ReaderT HandlerCtx (MetadataStorageT (TraceT m)) SchemaCache
forall a b. (a -> b) -> a -> b
$ SchemaCacheRef -> IO SchemaCache
getSchemaCache (SchemaCacheRef -> IO SchemaCache)
-> SchemaCacheRef -> IO SchemaCache
forall a b. (a -> b) -> a -> b
$ ServerCtx -> SchemaCacheRef
scCacheRef ServerCtx
serverCtx
        OpenApi
json <- SchemaCache
-> ReaderT HandlerCtx (MetadataStorageT (TraceT m)) OpenApi
forall (m :: * -> *).
(MonadError QErr m, MonadFix m) =>
SchemaCache -> m OpenApi
buildOpenAPI SchemaCache
sc
        (HttpLogMetadata m, APIResp)
-> Handler (TraceT m) (HttpLogMetadata m, APIResp)
forall (m :: * -> *) a. Monad m => a -> m a
return (HttpLog m => HttpLogMetadata m
forall (m :: * -> *). HttpLog m => HttpLogMetadata m
emptyHttpLogMetadata @m, HttpResponse EncJSON -> APIResp
JSONResp (HttpResponse EncJSON -> APIResp)
-> HttpResponse EncJSON -> APIResp
forall a b. (a -> b) -> a -> b
$ EncJSON -> [Header] -> HttpResponse EncJSON
forall a. a -> [Header] -> HttpResponse a
HttpResponse (OpenApi -> EncJSON
forall a. ToJSON a => a -> EncJSON
encJFromJValue OpenApi
json) [])

  [StdMethod] -> (StdMethod -> SpockT m ()) -> SpockT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [StdMethod
Spock.GET, StdMethod
Spock.POST] ((StdMethod -> SpockT m ()) -> SpockT m ())
-> (StdMethod -> SpockT m ()) -> SpockT m ()
forall a b. (a -> b) -> a -> b
$ \StdMethod
m -> StdMethod -> ([Text] -> ActionCtxT () m ()) -> SpockT m ()
forall (t :: * -> (* -> *) -> * -> *) (m :: * -> *) ctx.
(RouteM t, Monad m) =>
StdMethod -> ([Text] -> ActionCtxT ctx m ()) -> t ctx m ()
Spock.hookAny StdMethod
m (([Text] -> ActionCtxT () m ()) -> SpockT m ())
-> ([Text] -> ActionCtxT () m ()) -> SpockT m ()
forall a b. (a -> b) -> a -> b
$ \[Text]
_ -> do
    Request
req <- ActionCtxT () m Request
forall (m :: * -> *) ctx. MonadIO m => ActionCtxT ctx m Request
Spock.request
    let headers :: [Header]
headers = Request -> [Header]
Wai.requestHeaders Request
req
        qErr :: QErr
qErr = Code -> Text -> QErr
err404 Code
NotFound Text
"resource does not exist"
    Logger Hasura
-> LoggingSettings -> [Header] -> QErr -> ActionCtxT () m ()
forall (m :: * -> *).
(MonadIO m, HttpLog m) =>
Logger Hasura
-> LoggingSettings -> [Header] -> QErr -> ActionT m ()
raiseGenericApiError Logger Hasura
logger (ServerCtx -> LoggingSettings
scLoggingSettings ServerCtx
serverCtx) [Header]
headers QErr
qErr
  where
    logger :: Logger Hasura
logger = ServerCtx -> Logger Hasura
scLogger ServerCtx
serverCtx

    logSuccess :: Text -> ActionCtxT () m ()
logSuccess Text
msg = do
      Request
req <- ActionCtxT () m Request
forall (m :: * -> *) ctx. MonadIO m => ActionCtxT ctx m Request
Spock.request
      ByteString
reqBody <- IO ByteString -> ActionCtxT () m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ActionCtxT () m ByteString)
-> IO ByteString -> ActionCtxT () m ByteString
forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
Wai.strictRequestBody Request
req
      let headers :: [Header]
headers = Request -> [Header]
Wai.requestHeaders Request
req
          blMsg :: ByteString
blMsg = Text -> ByteString
TL.encodeUtf8 Text
msg
      (RequestId
reqId, [Header]
_newHeaders) <- [Header] -> ActionCtxT () m (RequestId, [Header])
forall (m :: * -> *).
MonadIO m =>
[Header] -> m (RequestId, [Header])
getRequestId [Header]
headers
      m () -> ActionCtxT () m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ActionCtxT () m ()) -> m () -> ActionCtxT () m ()
forall a b. (a -> b) -> a -> b
$
        Logger Hasura
-> LoggingSettings
-> Maybe UserInfo
-> RequestId
-> Request
-> (ByteString, Maybe Value)
-> ByteString
-> ByteString
-> Maybe (DiffTime, DiffTime)
-> Maybe CompressionType
-> [Header]
-> HttpLogMetadata m
-> m ()
forall (m :: * -> *).
HttpLog m =>
Logger Hasura
-> LoggingSettings
-> Maybe UserInfo
-> RequestId
-> Request
-> (ByteString, Maybe Value)
-> ByteString
-> ByteString
-> Maybe (DiffTime, DiffTime)
-> Maybe CompressionType
-> [Header]
-> HttpLogMetadata m
-> m ()
logHttpSuccess Logger Hasura
logger (ServerCtx -> LoggingSettings
scLoggingSettings ServerCtx
serverCtx) Maybe UserInfo
forall a. Maybe a
Nothing RequestId
reqId Request
req (ByteString
reqBody, Maybe Value
forall a. Maybe a
Nothing) ByteString
blMsg ByteString
blMsg Maybe (DiffTime, DiffTime)
forall a. Maybe a
Nothing Maybe CompressionType
forall a. Maybe a
Nothing [Header]
headers (HttpLog m => HttpLogMetadata m
forall (m :: * -> *). HttpLog m => HttpLogMetadata m
emptyHttpLogMetadata @m)

    logError :: QErr -> ActionCtxT () m ()
logError QErr
err = do
      Request
req <- ActionCtxT () m Request
forall (m :: * -> *) ctx. MonadIO m => ActionCtxT ctx m Request
Spock.request
      ByteString
reqBody <- IO ByteString -> ActionCtxT () m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ActionCtxT () m ByteString)
-> IO ByteString -> ActionCtxT () m ByteString
forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
Wai.strictRequestBody Request
req
      let headers :: [Header]
headers = Request -> [Header]
Wai.requestHeaders Request
req
      (RequestId
reqId, [Header]
_newHeaders) <- [Header] -> ActionCtxT () m (RequestId, [Header])
forall (m :: * -> *).
MonadIO m =>
[Header] -> m (RequestId, [Header])
getRequestId [Header]
headers
      m () -> ActionCtxT () m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ActionCtxT () m ()) -> m () -> ActionCtxT () m ()
forall a b. (a -> b) -> a -> b
$
        Logger Hasura
-> LoggingSettings
-> Maybe UserInfo
-> RequestId
-> Request
-> (ByteString, Maybe Value)
-> QErr
-> [Header]
-> m ()
forall (m :: * -> *).
HttpLog m =>
Logger Hasura
-> LoggingSettings
-> Maybe UserInfo
-> RequestId
-> Request
-> (ByteString, Maybe Value)
-> QErr
-> [Header]
-> m ()
logHttpError Logger Hasura
logger (ServerCtx -> LoggingSettings
scLoggingSettings ServerCtx
serverCtx) Maybe UserInfo
forall a. Maybe a
Nothing RequestId
reqId Request
req (ByteString
reqBody, Maybe Value
forall a. Maybe a
Nothing) QErr
err [Header]
headers

    spockAction ::
      forall a n.
      (FromJSON a, MonadIO n, MonadBaseControl IO n, UserAuthentication (Tracing.TraceT n), HttpLog n, Tracing.HasReporter n, HasResourceLimits n) =>
      (Bool -> QErr -> Value) ->
      (QErr -> QErr) ->
      APIHandler (Tracing.TraceT n) a ->
      Spock.ActionT n ()
    spockAction :: (Bool -> QErr -> Value)
-> (QErr -> QErr) -> APIHandler (TraceT n) a -> ActionT n ()
spockAction Bool -> QErr -> Value
qErrEncoder QErr -> QErr
qErrModifier APIHandler (TraceT n) a
apiHandler = ServerCtx
-> (Bool -> QErr -> Value)
-> (QErr -> QErr)
-> APIHandler (TraceT n) a
-> ActionT n ()
forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m, FromJSON a,
 UserAuthentication (TraceT m), HttpLog m, HasReporter m,
 HasResourceLimits m) =>
ServerCtx
-> (Bool -> QErr -> Value)
-> (QErr -> QErr)
-> APIHandler (TraceT m) a
-> ActionT m ()
mkSpockAction ServerCtx
serverCtx Bool -> QErr -> Value
qErrEncoder QErr -> QErr
qErrModifier APIHandler (TraceT n) a
apiHandler

    -- all graphql errors should be of type 200
    allMod200 :: QErr -> QErr
allMod200 QErr
qe = QErr
qe {qeStatus :: Status
qeStatus = Status
HTTP.status200}
    gqlExplainAction :: ActionCtxT () m ()
gqlExplainAction = do
      (Bool -> QErr -> Value)
-> (QErr -> QErr)
-> APIHandler (TraceT m) GQLExplain
-> ActionCtxT () m ()
forall a (n :: * -> *).
(FromJSON a, MonadIO n, MonadBaseControl IO n,
 UserAuthentication (TraceT n), HttpLog n, HasReporter n,
 HasResourceLimits n) =>
(Bool -> QErr -> Value)
-> (QErr -> QErr) -> APIHandler (TraceT n) a -> ActionT n ()
spockAction Bool -> QErr -> Value
encodeQErr QErr -> QErr
forall a. a -> a
id (APIHandler (TraceT m) GQLExplain -> ActionCtxT () m ())
-> APIHandler (TraceT m) GQLExplain -> ActionCtxT () m ()
forall a b. (a -> b) -> a -> b
$
        (GQLExplain
 -> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp))
-> APIHandler (TraceT m) GQLExplain
forall a (m :: * -> *).
(a -> Handler m (HttpLogMetadata m, APIResp)) -> APIHandler m a
mkPostHandler ((GQLExplain
  -> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp))
 -> APIHandler (TraceT m) GQLExplain)
-> (GQLExplain
    -> Handler (TraceT m) (HttpLogMetadata (TraceT m), APIResp))
-> APIHandler (TraceT m) GQLExplain
forall a b. (a -> b) -> a -> b
$
          (APIResp -> (HttpLogMetadata m, APIResp))
-> ReaderT HandlerCtx (MetadataStorageT (TraceT m)) APIResp
-> Handler (TraceT m) (HttpLogMetadata m, APIResp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HttpLog m => HttpLogMetadata m
forall (m :: * -> *). HttpLog m => HttpLogMetadata m
emptyHttpLogMetadata @m,) (ReaderT HandlerCtx (MetadataStorageT (TraceT m)) APIResp
 -> Handler (TraceT m) (HttpLogMetadata m, APIResp))
-> (GQLExplain
    -> ReaderT HandlerCtx (MetadataStorageT (TraceT m)) APIResp)
-> GQLExplain
-> Handler (TraceT m) (HttpLogMetadata m, APIResp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GQLExplain -> Handler (TraceT m) (HttpResponse EncJSON))
-> GQLExplain
-> ReaderT HandlerCtx (MetadataStorageT (TraceT m)) APIResp
forall (m :: * -> *) a.
Functor m =>
(a -> Handler m (HttpResponse EncJSON)) -> a -> Handler m APIResp
mkAPIRespHandler GQLExplain -> Handler (TraceT m) (HttpResponse EncJSON)
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadError QErr m,
 MonadReader HandlerCtx m,
 MonadMetadataStorage (MetadataStorageT m), MonadQueryTags m) =>
GQLExplain -> m (HttpResponse EncJSON)
gqlExplainHandler
    enableGraphQL :: Bool
enableGraphQL = ServerCtx -> Bool
isGraphQLEnabled ServerCtx
serverCtx
    enableMetadata :: Bool
enableMetadata = ServerCtx -> Bool
isMetadataEnabled ServerCtx
serverCtx
    enablePGDump :: Bool
enablePGDump = ServerCtx -> Bool
isPGDumpEnabled ServerCtx
serverCtx
    enableConfig :: Bool
enableConfig = ServerCtx -> Bool
isConfigEnabled ServerCtx
serverCtx

    serveApiConsole :: SpockT m ()
serveApiConsole = do
      -- redirect / to /console
      Path '[] 'Open -> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall (xs :: [*]) (t :: * -> (* -> *) -> * -> *) (m :: * -> *)
       (ps :: PathState) ctx.
(HasRep xs, RouteM t, Monad m) =>
Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
Spock.get Path '[] 'Open
Spock.root (HVectElim '[] (ActionCtxT () m ()) -> SpockT m ())
-> HVectElim '[] (ActionCtxT () m ()) -> SpockT m ()
forall a b. (a -> b) -> a -> b
$ Text -> ActionCtxT () m ()
forall (m :: * -> *) ctx a. MonadIO m => Text -> ActionCtxT ctx m a
Spock.redirect Text
"console"

      -- serve static files if consoleAssetsDir is set
      Maybe Text -> (Text -> SpockT m ()) -> SpockT m ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
onJust Maybe Text
consoleAssetsDir ((Text -> SpockT m ()) -> SpockT m ())
-> (Text -> SpockT m ()) -> SpockT m ()
forall a b. (a -> b) -> a -> b
$ \Text
dir ->
        Path '[Text] 'Closed
-> HVectElim '[Text] (ActionCtxT () m ()) -> SpockT m ()
forall (xs :: [*]) (t :: * -> (* -> *) -> * -> *) (m :: * -> *)
       (ps :: PathState) ctx.
(HasRep xs, RouteM t, Monad m) =>
Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
Spock.get (Path '[] 'Open
"console/assets" Path '[] 'Open
-> Path '[Text] 'Closed -> Path (Append '[] '[Text]) 'Closed
forall (as :: [*]) (bs :: [*]) (ps :: PathState).
Path as 'Open -> Path bs ps -> Path (Append as bs) ps
<//> Path '[Text] 'Closed
Spock.wildcard) (HVectElim '[Text] (ActionCtxT () m ()) -> SpockT m ())
-> HVectElim '[Text] (ActionCtxT () m ()) -> SpockT m ()
forall a b. (a -> b) -> a -> b
$ \Text
path -> do
          Logger Hasura
-> LoggingSettings -> Text -> String -> ActionCtxT () m ()
forall (m :: * -> *).
(MonadIO m, HttpLog m) =>
Logger Hasura -> LoggingSettings -> Text -> String -> ActionT m ()
consoleAssetsHandler Logger Hasura
logger (ServerCtx -> LoggingSettings
scLoggingSettings ServerCtx
serverCtx) Text
dir (Text -> String
T.unpack Text
path)

      -- serve console html
      Path '[Text] 'Closed
-> HVectElim '[Text] (ActionCtxT () m ()) -> SpockT m ()
forall (xs :: [*]) (t :: * -> (* -> *) -> * -> *) (m :: * -> *)
       (ps :: PathState) ctx.
(HasRep xs, RouteM t, Monad m) =>
Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
Spock.get (Path '[] 'Open
"console" Path '[] 'Open
-> Path '[Text] 'Closed -> Path (Append '[] '[Text]) 'Closed
forall (as :: [*]) (bs :: [*]) (ps :: PathState).
Path as 'Open -> Path bs ps -> Path (Append as bs) ps
<//> Path '[Text] 'Closed
Spock.wildcard) (HVectElim '[Text] (ActionCtxT () m ()) -> SpockT m ())
-> HVectElim '[Text] (ActionCtxT () m ()) -> SpockT m ()
forall a b. (a -> b) -> a -> b
$ \Text
path -> do
        Request
req <- ActionCtxT () m Request
forall (m :: * -> *) ctx. MonadIO m => ActionCtxT ctx m Request
Spock.request
        let headers :: [Header]
headers = Request -> [Header]
Wai.requestHeaders Request
req
            authMode :: AuthMode
authMode = ServerCtx -> AuthMode
scAuthMode ServerCtx
serverCtx
        Either String Text
consoleHtml <- m (Either String Text) -> ActionCtxT () m (Either String Text)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either String Text) -> ActionCtxT () m (Either String Text))
-> m (Either String Text) -> ActionCtxT () m (Either String Text)
forall a b. (a -> b) -> a -> b
$ Text -> AuthMode -> Bool -> Maybe Text -> m (Either String Text)
forall (m :: * -> *).
ConsoleRenderer m =>
Text -> AuthMode -> Bool -> Maybe Text -> m (Either String Text)
renderConsole Text
path AuthMode
authMode Bool
enableTelemetry Maybe Text
consoleAssetsDir
        (String -> ActionCtxT () m ())
-> (Text -> ActionCtxT () m ())
-> Either String Text
-> ActionCtxT () m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Logger Hasura
-> LoggingSettings -> [Header] -> QErr -> ActionCtxT () m ()
forall (m :: * -> *).
(MonadIO m, HttpLog m) =>
Logger Hasura
-> LoggingSettings -> [Header] -> QErr -> ActionT m ()
raiseGenericApiError Logger Hasura
logger (ServerCtx -> LoggingSettings
scLoggingSettings ServerCtx
serverCtx) [Header]
headers (QErr -> ActionCtxT () m ())
-> (String -> QErr) -> String -> ActionCtxT () m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> QErr
internalError (Text -> QErr) -> (String -> Text) -> String -> QErr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) Text -> ActionCtxT () m ()
forall (m :: * -> *) ctx a. MonadIO m => Text -> ActionCtxT ctx m a
Spock.html Either String Text
consoleHtml

raiseGenericApiError ::
  (MonadIO m, HttpLog m) =>
  L.Logger L.Hasura ->
  LoggingSettings ->
  [HTTP.Header] ->
  QErr ->
  Spock.ActionT m ()
raiseGenericApiError :: Logger Hasura
-> LoggingSettings -> [Header] -> QErr -> ActionT m ()
raiseGenericApiError Logger Hasura
logger LoggingSettings
loggingSetting [Header]
headers QErr
qErr = do
  Request
req <- ActionCtxT () m Request
forall (m :: * -> *) ctx. MonadIO m => ActionCtxT ctx m Request
Spock.request
  ByteString
reqBody <- IO ByteString -> ActionCtxT () m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ActionCtxT () m ByteString)
-> IO ByteString -> ActionCtxT () m ByteString
forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
Wai.strictRequestBody Request
req
  (RequestId
reqId, [Header]
_newHeaders) <- [Header] -> ActionCtxT () m (RequestId, [Header])
forall (m :: * -> *).
MonadIO m =>
[Header] -> m (RequestId, [Header])
getRequestId ([Header] -> ActionCtxT () m (RequestId, [Header]))
-> [Header] -> ActionCtxT () m (RequestId, [Header])
forall a b. (a -> b) -> a -> b
$ Request -> [Header]
Wai.requestHeaders Request
req
  m () -> ActionT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ActionT m ()) -> m () -> ActionT m ()
forall a b. (a -> b) -> a -> b
$ Logger Hasura
-> LoggingSettings
-> Maybe UserInfo
-> RequestId
-> Request
-> (ByteString, Maybe Value)
-> QErr
-> [Header]
-> m ()
forall (m :: * -> *).
HttpLog m =>
Logger Hasura
-> LoggingSettings
-> Maybe UserInfo
-> RequestId
-> Request
-> (ByteString, Maybe Value)
-> QErr
-> [Header]
-> m ()
logHttpError Logger Hasura
logger LoggingSettings
loggingSetting Maybe UserInfo
forall a. Maybe a
Nothing RequestId
reqId Request
req (ByteString
reqBody, Maybe Value
forall a. Maybe a
Nothing) QErr
qErr [Header]
headers
  Header -> ActionT m ()
forall (m :: * -> *). MonadIO m => Header -> ActionT m ()
setHeader Header
jsonHeader
  Status -> ActionT m ()
forall (m :: * -> *) ctx.
MonadIO m =>
Status -> ActionCtxT ctx m ()
Spock.setStatus (Status -> ActionT m ()) -> Status -> ActionT m ()
forall a b. (a -> b) -> a -> b
$ QErr -> Status
qeStatus QErr
qErr
  ByteString -> ActionT m ()
forall (m :: * -> *) ctx a.
MonadIO m =>
ByteString -> ActionCtxT ctx m a
Spock.lazyBytes (ByteString -> ActionT m ()) -> ByteString -> ActionT m ()
forall a b. (a -> b) -> a -> b
$ QErr -> ByteString
forall a. ToJSON a => a -> ByteString
encode QErr
qErr