{-# LANGUAGE QuasiQuotes #-}

module Hasura.GraphQL.Execute.Action
  ( fetchActionLogResponses,
    runActionExecution,
    asyncActionsProcessor,
    resolveActionExecution,
    resolveActionMutationAsync,
    resolveAsyncActionQuery,
    insertActionTx,
    fetchUndeliveredActionEventsTx,
    setActionStatusTx,
    fetchActionResponseTx,
    clearActionDataTx,
    setProcessingActionLogsToPendingTx,
    LockedActionIdArray (..),
    module Types,
  )
where

import Control.Concurrent.Async.Lifted.Safe qualified as LA
import Control.Concurrent.Extended (Forever (..), sleep)
import Control.Concurrent.STM qualified as STM
import Control.Exception (try)
import Control.Lens
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Aeson qualified as J
import Data.Aeson.Key qualified as K
import Data.Aeson.KeyMap qualified as KM
import Data.Aeson.Ordered qualified as AO
import Data.ByteString.Lazy qualified as BL
import Data.CaseInsensitive qualified as CI
import Data.Environment qualified as Env
import Data.Has
import Data.HashMap.Strict qualified as HashMap
import Data.SerializableBlob qualified as SB
import Data.Set (Set)
import Data.Text.Extended
import Data.Text.NonEmpty
import Database.PG.Query qualified as PG
import Hasura.App.State
import Hasura.Backends.Postgres.Connection.MonadTx
import Hasura.Backends.Postgres.Execute.Prepare
import Hasura.Backends.Postgres.Execute.Types
import Hasura.Backends.Postgres.SQL.DML qualified as S
import Hasura.Backends.Postgres.SQL.Types
import Hasura.Backends.Postgres.SQL.Value (PGScalarValue (..))
import Hasura.Backends.Postgres.Translate.Select qualified as RS
import Hasura.Backends.Postgres.Translate.Select.Internal.Helpers (selectToSelectWith, toQuery)
import Hasura.Backends.Postgres.Types.Function qualified as TF
import Hasura.Base.Error
import Hasura.EncJSON
import Hasura.Eventing.Common
import Hasura.Function.Cache
import Hasura.GraphQL.Execute.Action.Types as Types
import Hasura.GraphQL.Parser.Name qualified as GName
import Hasura.GraphQL.Transport.HTTP.Protocol as GH
import Hasura.HTTP
import Hasura.Logging qualified as L
import Hasura.Metadata.Class
import Hasura.Name qualified as Name
import Hasura.Prelude
import Hasura.RQL.DDL.Headers (makeHeadersFromConf, toHeadersConf)
import Hasura.RQL.DDL.Webhook.Transform
import Hasura.RQL.IR.Action qualified as IR
import Hasura.RQL.IR.BoolExp
import Hasura.RQL.IR.Select qualified as RS
import Hasura.RQL.IR.Value qualified as IR
import Hasura.RQL.Types.Action
import Hasura.RQL.Types.BackendType
import Hasura.RQL.Types.Column
import Hasura.RQL.Types.Common
import Hasura.RQL.Types.ComputedField
import Hasura.RQL.Types.CustomTypes
import Hasura.RQL.Types.Eventing
import Hasura.RQL.Types.Headers (HeaderConf)
import Hasura.RQL.Types.Roles (adminRoleName)
import Hasura.RQL.Types.Schema.Options qualified as Options
import Hasura.RQL.Types.SchemaCache
import Hasura.Server.Init.Config (OptionalInterval (..))
import Hasura.Server.Prometheus (PrometheusMetrics (..))
import Hasura.Server.Utils
  ( mkClientHeadersForward,
    mkSetCookieHeaders,
  )
import Hasura.Session (SessionVariables, UserInfo, _uiRole, _uiSession)
import Hasura.Tracing qualified as Tracing
import Language.GraphQL.Draft.Syntax qualified as G
import Network.HTTP.Client.Transformable qualified as HTTP
import Network.Wreq qualified as Wreq
import Refined (unrefine)
import System.Metrics.Prometheus.Counter as Prometheus.Counter

fetchActionLogResponses ::
  (MonadError QErr m, MonadMetadataStorage m, Foldable t) =>
  t ActionId ->
  m (ActionLogResponseMap, Bool)
fetchActionLogResponses :: forall (m :: * -> *) (t :: * -> *).
(MonadError QErr m, MonadMetadataStorage m, Foldable t) =>
t ActionId -> m (ActionLogResponseMap, Bool)
fetchActionLogResponses t ActionId
actionIds = do
  [(ActionId, ActionLogResponse)]
responses <- [ActionId]
-> (ActionId -> m (ActionId, ActionLogResponse))
-> m [(ActionId, ActionLogResponse)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (t ActionId -> [ActionId]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t ActionId
actionIds) ((ActionId -> m (ActionId, ActionLogResponse))
 -> m [(ActionId, ActionLogResponse)])
-> (ActionId -> m (ActionId, ActionLogResponse))
-> m [(ActionId, ActionLogResponse)]
forall a b. (a -> b) -> a -> b
$ \ActionId
actionId ->
    (ActionId
actionId,)
      (ActionLogResponse -> (ActionId, ActionLogResponse))
-> m ActionLogResponse -> m (ActionId, ActionLogResponse)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Either QErr ActionLogResponse) -> m ActionLogResponse
forall e (m :: * -> *) a. MonadError e m => m (Either e a) -> m a
liftEitherM (ActionId -> m (Either QErr ActionLogResponse)
forall (m :: * -> *).
MonadMetadataStorage m =>
ActionId -> m (Either QErr ActionLogResponse)
fetchActionResponse ActionId
actionId)
  -- An action is said to be completed/processed iff response is captured from webhook or
  -- in case any exception occured in calling webhook.
  let isActionComplete :: ActionLogResponse -> Bool
isActionComplete ActionLogResponse {Maybe Value
UTCTime
SessionVariables
ActionId
_alrId :: ActionId
_alrCreatedAt :: UTCTime
_alrResponsePayload :: Maybe Value
_alrErrors :: Maybe Value
_alrSessionVariables :: SessionVariables
_alrId :: ActionLogResponse -> ActionId
_alrCreatedAt :: ActionLogResponse -> UTCTime
_alrResponsePayload :: ActionLogResponse -> Maybe Value
_alrErrors :: ActionLogResponse -> Maybe Value
_alrSessionVariables :: ActionLogResponse -> SessionVariables
..} =
        Maybe Value -> Bool
forall a. Maybe a -> Bool
isJust Maybe Value
_alrResponsePayload Bool -> Bool -> Bool
|| Maybe Value -> Bool
forall a. Maybe a -> Bool
isJust Maybe Value
_alrErrors
  (ActionLogResponseMap, Bool) -> m (ActionLogResponseMap, Bool)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(ActionId, ActionLogResponse)] -> ActionLogResponseMap
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList [(ActionId, ActionLogResponse)]
responses, ((ActionId, ActionLogResponse) -> Bool)
-> [(ActionId, ActionLogResponse)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ActionLogResponse -> Bool
isActionComplete (ActionLogResponse -> Bool)
-> ((ActionId, ActionLogResponse) -> ActionLogResponse)
-> (ActionId, ActionLogResponse)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ActionId, ActionLogResponse) -> ActionLogResponse
forall a b. (a, b) -> b
snd) [(ActionId, ActionLogResponse)]
responses)

runActionExecution ::
  ( MonadIO m,
    MonadBaseControl IO m,
    MonadError QErr m,
    Tracing.MonadTrace m,
    MonadMetadataStorage m
  ) =>
  UserInfo ->
  ActionExecutionPlan ->
  m (DiffTime, (EncJSON, Maybe HTTP.ResponseHeaders))
runActionExecution :: forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadError QErr m, MonadTrace m,
 MonadMetadataStorage m) =>
UserInfo
-> ActionExecutionPlan
-> m (DiffTime, (EncJSON, Maybe ResponseHeaders))
runActionExecution UserInfo
userInfo ActionExecutionPlan
aep =
  m (EncJSON, Maybe ResponseHeaders)
-> m (DiffTime, (EncJSON, Maybe ResponseHeaders))
forall (m :: * -> *) a. MonadIO m => m a -> m (DiffTime, a)
withElapsedTime (m (EncJSON, Maybe ResponseHeaders)
 -> m (DiffTime, (EncJSON, Maybe ResponseHeaders)))
-> m (EncJSON, Maybe ResponseHeaders)
-> m (DiffTime, (EncJSON, Maybe ResponseHeaders))
forall a b. (a -> b) -> a -> b
$ case ActionExecutionPlan
aep of
    AEPSync ActionExecution
e -> (ResponseHeaders -> Maybe ResponseHeaders)
-> (EncJSON, ResponseHeaders) -> (EncJSON, Maybe ResponseHeaders)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ResponseHeaders -> Maybe ResponseHeaders
forall a. a -> Maybe a
Just ((EncJSON, ResponseHeaders) -> (EncJSON, Maybe ResponseHeaders))
-> m (EncJSON, ResponseHeaders)
-> m (EncJSON, Maybe ResponseHeaders)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ActionExecution
-> forall (m :: * -> *).
   (MonadIO m, MonadBaseControl IO m, MonadError QErr m,
    MonadTrace m) =>
   m (EncJSON, ResponseHeaders)
unActionExecution ActionExecution
e
    AEPAsyncQuery (AsyncActionQueryExecutionPlan ActionId
actionId AsyncActionQueryExecution (UnpreparedValue ('Postgres 'Vanilla))
execution) -> do
      ActionLogResponse
actionLogResponse <- m (Either QErr ActionLogResponse) -> m ActionLogResponse
forall e (m :: * -> *) a. MonadError e m => m (Either e a) -> m a
liftEitherM (m (Either QErr ActionLogResponse) -> m ActionLogResponse)
-> m (Either QErr ActionLogResponse) -> m ActionLogResponse
forall a b. (a -> b) -> a -> b
$ ActionId -> m (Either QErr ActionLogResponse)
forall (m :: * -> *).
MonadMetadataStorage m =>
ActionId -> m (Either QErr ActionLogResponse)
fetchActionResponse ActionId
actionId
      (,Maybe ResponseHeaders
forall a. Maybe a
Nothing) (EncJSON -> (EncJSON, Maybe ResponseHeaders))
-> m EncJSON -> m (EncJSON, Maybe ResponseHeaders)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case AsyncActionQueryExecution (UnpreparedValue ('Postgres 'Vanilla))
execution of
        AAQENoRelationships ActionLogResponse -> Either QErr EncJSON
f -> Either QErr EncJSON -> m EncJSON
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either QErr EncJSON -> m EncJSON)
-> Either QErr EncJSON -> m EncJSON
forall a b. (a -> b) -> a -> b
$ ActionLogResponse -> Either QErr EncJSON
f ActionLogResponse
actionLogResponse
        AAQEOnSourceDB SourceConfig ('Postgres 'Vanilla)
srcConfig (AsyncActionQuerySourceExecution SourceName
_ JsonAggSelect
jsonAggSelect ActionLogResponse
-> AnnSimpleSelectG
     ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla))
f) -> do
          let selectAST :: AnnSimpleSelectG
  ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla))
selectAST = ActionLogResponse
-> AnnSimpleSelectG
     ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla))
f ActionLogResponse
actionLogResponse
          AnnSelectG
  ('Postgres 'Vanilla) (AnnFieldG ('Postgres 'Vanilla) Void) SQLExp
selectResolved <- (UnpreparedValue ('Postgres 'Vanilla) -> m SQLExp)
-> AnnSimpleSelectG
     ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla))
-> m (AnnSelectG
        ('Postgres 'Vanilla) (AnnFieldG ('Postgres 'Vanilla) Void) SQLExp)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b)
-> AnnSelectG
     ('Postgres 'Vanilla) (AnnFieldG ('Postgres 'Vanilla) Void) a
-> f (AnnSelectG
        ('Postgres 'Vanilla) (AnnFieldG ('Postgres 'Vanilla) Void) b)
traverse (UserInfo -> UnpreparedValue ('Postgres 'Vanilla) -> m SQLExp
forall (m :: * -> *) (pgKind :: PostgresKind).
MonadError QErr m =>
UserInfo -> UnpreparedValue ('Postgres pgKind) -> m SQLExp
prepareWithoutPlan UserInfo
userInfo) AnnSimpleSelectG
  ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla))
selectAST
          let querySQL :: Query
querySQL = SelectWithG TopLevelCTE -> Query
toQuery (SelectWithG TopLevelCTE -> Query)
-> SelectWithG TopLevelCTE -> Query
forall a b. (a -> b) -> a -> b
$ Writer CustomSQLCTEs Select -> SelectWithG TopLevelCTE
selectToSelectWith (Writer CustomSQLCTEs Select -> SelectWithG TopLevelCTE)
-> Writer CustomSQLCTEs Select -> SelectWithG TopLevelCTE
forall a b. (a -> b) -> a -> b
$ JsonAggSelect
-> AnnSimpleSelect ('Postgres 'Vanilla)
-> Writer CustomSQLCTEs Select
forall (pgKind :: PostgresKind) (m :: * -> *).
(Backend ('Postgres pgKind), PostgresAnnotatedFieldJSON pgKind,
 MonadWriter CustomSQLCTEs m) =>
JsonAggSelect -> AnnSimpleSelect ('Postgres pgKind) -> m Select
RS.mkSQLSelect JsonAggSelect
jsonAggSelect AnnSimpleSelect ('Postgres 'Vanilla)
AnnSelectG
  ('Postgres 'Vanilla) (AnnFieldG ('Postgres 'Vanilla) Void) SQLExp
selectResolved
          m (Either QErr EncJSON) -> m EncJSON
forall e (m :: * -> *) a. MonadError e m => m (Either e a) -> m a
liftEitherM (m (Either QErr EncJSON) -> m EncJSON)
-> m (Either QErr EncJSON) -> m EncJSON
forall a b. (a -> b) -> a -> b
$ ExceptT QErr m EncJSON -> m (Either QErr EncJSON)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT QErr m EncJSON -> m (Either QErr EncJSON))
-> ExceptT QErr m EncJSON -> m (Either QErr EncJSON)
forall a b. (a -> b) -> a -> b
$ PGExecCtx -> PGExecCtxInfo -> RunTx
_pecRunTx (PGSourceConfig -> PGExecCtx
_pscExecCtx SourceConfig ('Postgres 'Vanilla)
PGSourceConfig
srcConfig) (PGExecTxType -> PGExecFrom -> PGExecCtxInfo
PGExecCtxInfo (TxAccess -> Maybe TxIsolation -> PGExecTxType
Tx TxAccess
PG.ReadOnly Maybe TxIsolation
forall a. Maybe a
Nothing) PGExecFrom
InternalRawQuery) (TxET QErr m EncJSON -> ExceptT QErr m EncJSON)
-> TxET QErr m EncJSON -> ExceptT QErr m EncJSON
forall a b. (a -> b) -> a -> b
$ TxE QErr EncJSON -> TxET QErr m EncJSON
forall a. TxE QErr a -> TxET QErr m a
forall (m :: * -> *) a. MonadTx m => TxE QErr a -> m a
liftTx (TxE QErr EncJSON -> TxET QErr m EncJSON)
-> TxE QErr EncJSON -> TxET QErr m EncJSON
forall a b. (a -> b) -> a -> b
$ Query -> [PrepArg] -> TxE QErr EncJSON
asSingleRowJsonResp Query
querySQL []
    AEPAsyncMutation ActionId
actionId -> (EncJSON, Maybe ResponseHeaders)
-> m (EncJSON, Maybe ResponseHeaders)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EncJSON, Maybe ResponseHeaders)
 -> m (EncJSON, Maybe ResponseHeaders))
-> (EncJSON, Maybe ResponseHeaders)
-> m (EncJSON, Maybe ResponseHeaders)
forall a b. (a -> b) -> a -> b
$ (,Maybe ResponseHeaders
forall a. Maybe a
Nothing) (EncJSON -> (EncJSON, Maybe ResponseHeaders))
-> EncJSON -> (EncJSON, Maybe ResponseHeaders)
forall a b. (a -> b) -> a -> b
$ Text -> EncJSON
forall a. ToJSON a => a -> EncJSON
encJFromJValue (Text -> EncJSON) -> Text -> EncJSON
forall a b. (a -> b) -> a -> b
$ ActionId -> Text
actionIdToText ActionId
actionId

-- | This function is generally used on the result of 'selectQuerySQL',
-- 'selectAggregateQuerySQL' or 'connectionSelectSQL' to run said query and get
-- back the resulting JSON.
asSingleRowJsonResp ::
  PG.Query ->
  [PG.PrepArg] ->
  PG.TxE QErr EncJSON
asSingleRowJsonResp :: Query -> [PrepArg] -> TxE QErr EncJSON
asSingleRowJsonResp Query
query [PrepArg]
args =
  Identity EncJSON -> EncJSON
forall a. Identity a -> a
runIdentity
    (Identity EncJSON -> EncJSON)
-> (SingleRow (Identity EncJSON) -> Identity EncJSON)
-> SingleRow (Identity EncJSON)
-> EncJSON
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SingleRow (Identity EncJSON) -> Identity EncJSON
forall a. SingleRow a -> a
PG.getRow
    (SingleRow (Identity EncJSON) -> EncJSON)
-> TxET QErr IO (SingleRow (Identity EncJSON)) -> TxE QErr EncJSON
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PGTxErr -> QErr)
-> Query
-> [PrepArg]
-> Bool
-> TxET QErr IO (SingleRow (Identity EncJSON))
forall (m :: * -> *) a e.
(MonadIO m, FromRes a) =>
(PGTxErr -> e) -> Query -> [PrepArg] -> Bool -> TxET e m a
PG.rawQE PGTxErr -> QErr
dmlTxErrorHandler Query
query [PrepArg]
args Bool
True

-- | Synchronously execute webhook handler and resolve response to action "output"
resolveActionExecution ::
  HTTP.Manager ->
  Env.Environment ->
  L.Logger L.Hasura ->
  PrometheusMetrics ->
  IR.AnnActionExecution Void ->
  ActionExecContext ->
  Maybe GQLQueryText ->
  ActionExecution
resolveActionExecution :: Manager
-> Environment
-> Logger Hasura
-> PrometheusMetrics
-> AnnActionExecution Void
-> ActionExecContext
-> Maybe GQLQueryText
-> ActionExecution
resolveActionExecution Manager
httpManager Environment
env Logger Hasura
logger PrometheusMetrics
prometheusMetrics IR.AnnActionExecution {Bool
ActionFieldsG Void
[HeaderConf]
Maybe RequestTransform
Maybe MetadataResponseTransform
Value
ActionOutputFields
EnvRecord ResolvedWebhook
Timeout
GraphQLType
ActionName
_aaeName :: ActionName
_aaeOutputType :: GraphQLType
_aaeFields :: ActionFieldsG Void
_aaePayload :: Value
_aaeOutputFields :: ActionOutputFields
_aaeWebhook :: EnvRecord ResolvedWebhook
_aaeHeaders :: [HeaderConf]
_aaeForwardClientHeaders :: Bool
_aaeTimeOut :: Timeout
_aaeRequestTransform :: Maybe RequestTransform
_aaeResponseTransform :: Maybe MetadataResponseTransform
_aaeName :: forall r. AnnActionExecution r -> ActionName
_aaeOutputType :: forall r. AnnActionExecution r -> GraphQLType
_aaeFields :: forall r. AnnActionExecution r -> ActionFieldsG r
_aaePayload :: forall r. AnnActionExecution r -> Value
_aaeOutputFields :: forall r. AnnActionExecution r -> ActionOutputFields
_aaeWebhook :: forall r. AnnActionExecution r -> EnvRecord ResolvedWebhook
_aaeHeaders :: forall r. AnnActionExecution r -> [HeaderConf]
_aaeForwardClientHeaders :: forall r. AnnActionExecution r -> Bool
_aaeTimeOut :: forall r. AnnActionExecution r -> Timeout
_aaeRequestTransform :: forall r. AnnActionExecution r -> Maybe RequestTransform
_aaeResponseTransform :: forall r. AnnActionExecution r -> Maybe MetadataResponseTransform
..} ActionExecContext {ResponseHeaders
SessionVariables
_aecHeaders :: ResponseHeaders
_aecSessionVariables :: SessionVariables
_aecHeaders :: ActionExecContext -> ResponseHeaders
_aecSessionVariables :: ActionExecContext -> SessionVariables
..} Maybe GQLQueryText
gqlQueryText =
  (forall (m :: * -> *).
 (MonadIO m, MonadBaseControl IO m, MonadError QErr m,
  MonadTrace m) =>
 m (EncJSON, ResponseHeaders))
-> ActionExecution
ActionExecution ((forall (m :: * -> *).
  (MonadIO m, MonadBaseControl IO m, MonadError QErr m,
   MonadTrace m) =>
  m (EncJSON, ResponseHeaders))
 -> ActionExecution)
-> (forall (m :: * -> *).
    (MonadIO m, MonadBaseControl IO m, MonadError QErr m,
     MonadTrace m) =>
    m (EncJSON, ResponseHeaders))
-> ActionExecution
forall a b. (a -> b) -> a -> b
$ (Value -> EncJSON)
-> (Value, ResponseHeaders) -> (EncJSON, ResponseHeaders)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Value -> EncJSON
encJFromOrderedValue (Value -> EncJSON) -> (Value -> Value) -> Value -> EncJSON
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActionFieldsG Void
-> GraphQLType -> ActionOutputFields -> Bool -> Value -> Value
makeActionResponseNoRelations ActionFieldsG Void
_aaeFields GraphQLType
_aaeOutputType ActionOutputFields
_aaeOutputFields Bool
True) ((Value, ResponseHeaders) -> (EncJSON, ResponseHeaders))
-> m (Value, ResponseHeaders) -> m (EncJSON, ResponseHeaders)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Value, ResponseHeaders)
forall (m :: * -> *).
(MonadIO m, MonadError QErr m, MonadTrace m) =>
m (Value, ResponseHeaders)
runWebhook
  where
    handlerPayload :: ActionWebhookPayload
handlerPayload = ActionContext
-> SessionVariables
-> Value
-> Maybe GQLQueryText
-> ActionWebhookPayload
ActionWebhookPayload (ActionName -> ActionContext
ActionContext ActionName
_aaeName) SessionVariables
_aecSessionVariables Value
_aaePayload Maybe GQLQueryText
gqlQueryText

    runWebhook ::
      (MonadIO m, MonadError QErr m, Tracing.MonadTrace m) =>
      m (ActionWebhookResponse, HTTP.ResponseHeaders)
    runWebhook :: forall (m :: * -> *).
(MonadIO m, MonadError QErr m, MonadTrace m) =>
m (Value, ResponseHeaders)
runWebhook =
      -- TODO: do we need to add the logger as a reader? can't we just give it as an argument?
      (ReaderT (Logger Hasura) m (Value, ResponseHeaders)
 -> Logger Hasura -> m (Value, ResponseHeaders))
-> Logger Hasura
-> ReaderT (Logger Hasura) m (Value, ResponseHeaders)
-> m (Value, ResponseHeaders)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (Logger Hasura) m (Value, ResponseHeaders)
-> Logger Hasura -> m (Value, ResponseHeaders)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Logger Hasura
logger
        (ReaderT (Logger Hasura) m (Value, ResponseHeaders)
 -> m (Value, ResponseHeaders))
-> ReaderT (Logger Hasura) m (Value, ResponseHeaders)
-> m (Value, ResponseHeaders)
forall a b. (a -> b) -> a -> b
$ Environment
-> Manager
-> PrometheusMetrics
-> GraphQLType
-> ActionOutputFields
-> ResponseHeaders
-> [HeaderConf]
-> Bool
-> EnvRecord ResolvedWebhook
-> ActionWebhookPayload
-> Timeout
-> Maybe RequestTransform
-> Maybe MetadataResponseTransform
-> ReaderT (Logger Hasura) m (Value, ResponseHeaders)
forall (m :: * -> *) r.
(MonadIO m, MonadError QErr m, MonadTrace m, MonadReader r m,
 Has (Logger Hasura) r) =>
Environment
-> Manager
-> PrometheusMetrics
-> GraphQLType
-> ActionOutputFields
-> ResponseHeaders
-> [HeaderConf]
-> Bool
-> EnvRecord ResolvedWebhook
-> ActionWebhookPayload
-> Timeout
-> Maybe RequestTransform
-> Maybe MetadataResponseTransform
-> m (Value, ResponseHeaders)
callWebhook
          Environment
env
          Manager
httpManager
          PrometheusMetrics
prometheusMetrics
          GraphQLType
_aaeOutputType
          ActionOutputFields
_aaeOutputFields
          ResponseHeaders
_aecHeaders
          [HeaderConf]
_aaeHeaders
          Bool
_aaeForwardClientHeaders
          EnvRecord ResolvedWebhook
_aaeWebhook
          ActionWebhookPayload
handlerPayload
          Timeout
_aaeTimeOut
          Maybe RequestTransform
_aaeRequestTransform
          Maybe MetadataResponseTransform
_aaeResponseTransform

throwUnexpected :: (MonadError QErr m) => Text -> m ()
throwUnexpected :: forall (m :: * -> *). MonadError QErr m => Text -> m ()
throwUnexpected = Code -> Text -> m ()
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
Unexpected

-- Webhook response object should conform to action output fields
validateResponseObject :: (MonadError QErr m) => KM.KeyMap J.Value -> IR.ActionOutputFields -> m ()
validateResponseObject :: forall (m :: * -> *).
MonadError QErr m =>
KeyMap Value -> ActionOutputFields -> m ()
validateResponseObject KeyMap Value
obj ActionOutputFields
outputField = do
  -- Note: Fields not specified in the output are ignored
  m (HashMap Name ()) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
    (m (HashMap Name ()) -> m ()) -> m (HashMap Name ()) -> m ()
forall a b. (a -> b) -> a -> b
$ ((Name -> GType -> m ())
 -> ActionOutputFields -> m (HashMap Name ()))
-> ActionOutputFields
-> (Name -> GType -> m ())
-> m (HashMap Name ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Name -> GType -> m ())
-> ActionOutputFields -> m (HashMap Name ())
forall (f :: * -> *) k v1 v2.
Applicative f =>
(k -> v1 -> f v2) -> HashMap k v1 -> f (HashMap k v2)
HashMap.traverseWithKey ActionOutputFields
outputField
    ((Name -> GType -> m ()) -> m (HashMap Name ()))
-> (Name -> GType -> m ()) -> m (HashMap Name ())
forall a b. (a -> b) -> a -> b
$ \Name
fieldName GType
fieldTy ->
      -- When field is non-nullable, it has to present in the response with no null value
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GType -> Bool
G.isNullable GType
fieldTy) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ case Key -> KeyMap Value -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup (Text -> Key
K.fromText (Text -> Key) -> Text -> Key
forall a b. (a -> b) -> a -> b
$ Name -> Text
G.unName Name
fieldName) KeyMap Value
obj of
        Maybe Value
Nothing ->
          Text -> m ()
forall (m :: * -> *). MonadError QErr m => Text -> m ()
throwUnexpected
            (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"field "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
fieldName
            Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" expected in webhook response, but not found"
        Just Value
v ->
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Value
v Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
J.Null)
            (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *). MonadError QErr m => Text -> m ()
throwUnexpected
            (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"expecting not null value for field "
            Text -> Name -> Text
forall t. ToTxt t => Text -> t -> Text
<>> Name
fieldName

-- Validates the webhook response against the output type
validateResponse :: (MonadError QErr m) => J.Value -> GraphQLType -> IR.ActionOutputFields -> m ()
validateResponse :: forall (m :: * -> *).
MonadError QErr m =>
Value -> GraphQLType -> ActionOutputFields -> m ()
validateResponse Value
webhookResponse' GraphQLType
outputType ActionOutputFields
outputF =
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GType -> ActionOutputFields -> Bool
isCustomScalar (GraphQLType -> GType
unGraphQLType GraphQLType
outputType) ActionOutputFields
outputF) do
    case (Value
webhookResponse', GraphQLType
outputType) of
      (Value
J.Null, GraphQLType
_) -> do
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GraphQLType -> Bool
isNullableType GraphQLType
outputType) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *). MonadError QErr m => Text -> m ()
throwUnexpected Text
"got null for the action webhook response"
      (J.Number Scientific
_, (GraphQLType (G.TypeNamed Nullability
_ Name
name))) -> do
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GName._Int Bool -> Bool -> Bool
|| Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GName._Float)
          (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *). MonadError QErr m => Text -> m ()
throwUnexpected
          (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"got scalar String for the action webhook response, expecting "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
G.unName Name
name
      (J.Bool Bool
_, (GraphQLType (G.TypeNamed Nullability
_ Name
name))) -> do
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GName._Boolean)
          (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *). MonadError QErr m => Text -> m ()
throwUnexpected
          (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"got scalar Boolean for the action webhook response, expecting "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
G.unName Name
name
      (J.String Text
_, (GraphQLType (G.TypeNamed Nullability
_ Name
name))) -> do
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GName._String Bool -> Bool -> Bool
|| Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GName._ID)
          (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *). MonadError QErr m => Text -> m ()
throwUnexpected
          (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"got scalar String for the action webhook response, expecting "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
G.unName Name
name
      (J.Array Array
_, (GraphQLType (G.TypeNamed Nullability
_ Name
name))) -> Text -> m ()
forall (m :: * -> *). MonadError QErr m => Text -> m ()
throwUnexpected (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"got array for the action webhook response, expecting " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
G.unName Name
name
      (J.Array Array
objs, (GraphQLType (G.TypeList Nullability
_ GType
outputType''))) -> do
        (Value -> m ()) -> Array -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\Value
o -> Value -> GraphQLType -> ActionOutputFields -> m ()
forall (m :: * -> *).
MonadError QErr m =>
Value -> GraphQLType -> ActionOutputFields -> m ()
validateResponse Value
o (GType -> GraphQLType
GraphQLType GType
outputType'') ActionOutputFields
outputF) Array
objs
      ((J.Object KeyMap Value
obj), (GraphQLType (G.TypeNamed Nullability
_ Name
name))) -> do
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Bool
isInBuiltScalar (Name -> Text
G.unName Name
name))
          (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *). MonadError QErr m => Text -> m ()
throwUnexpected
          (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"got object for the action webhook response, expecting "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
G.unName Name
name
        KeyMap Value -> ActionOutputFields -> m ()
forall (m :: * -> *).
MonadError QErr m =>
KeyMap Value -> ActionOutputFields -> m ()
validateResponseObject KeyMap Value
obj ActionOutputFields
outputF
      (Value
_, (GraphQLType (G.TypeList Nullability
_ GType
_))) ->
        Text -> m ()
forall (m :: * -> *). MonadError QErr m => Text -> m ()
throwUnexpected (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"expecting array for the action webhook response"

-- | Build action response from the Webhook JSON response when there are no relationships defined
makeActionResponseNoRelations :: IR.ActionFields -> GraphQLType -> IR.ActionOutputFields -> Bool -> ActionWebhookResponse -> AO.Value
makeActionResponseNoRelations :: ActionFieldsG Void
-> GraphQLType -> ActionOutputFields -> Bool -> Value -> Value
makeActionResponseNoRelations ActionFieldsG Void
annFields GraphQLType
outputType ActionOutputFields
outputF Bool
shouldCheckOutputField Value
webhookResponse =
  let mkResponseObject :: IR.ActionFields -> KM.KeyMap J.Value -> AO.Value
      mkResponseObject :: ActionFieldsG Void -> KeyMap Value -> Value
mkResponseObject ActionFieldsG Void
fields KeyMap Value
obj =
        [(Text, Value)] -> Value
AO.object
          ([(Text, Value)] -> Value) -> [(Text, Value)] -> Value
forall a b. (a -> b) -> a -> b
$ (((FieldName, ActionFieldG Void) -> Maybe (Text, Value))
 -> ActionFieldsG Void -> [(Text, Value)])
-> ActionFieldsG Void
-> ((FieldName, ActionFieldG Void) -> Maybe (Text, Value))
-> [(Text, Value)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((FieldName, ActionFieldG Void) -> Maybe (Text, Value))
-> ActionFieldsG Void -> [(Text, Value)]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe ActionFieldsG Void
fields
          (((FieldName, ActionFieldG Void) -> Maybe (Text, Value))
 -> [(Text, Value)])
-> ((FieldName, ActionFieldG Void) -> Maybe (Text, Value))
-> [(Text, Value)]
forall a b. (a -> b) -> a -> b
$ \(FieldName
fieldName, ActionFieldG Void
annField) ->
            let fieldText :: Text
fieldText = FieldName -> Text
getFieldNameTxt FieldName
fieldName
             in (Text
fieldText,) (Value -> (Text, Value)) -> Maybe Value -> Maybe (Text, Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case ActionFieldG Void
annField of
                  IR.ACFExpression Text
t -> Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Text -> Value
AO.String Text
t
                  IR.ACFScalar Name
fname -> Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Value -> (Value -> Value) -> Maybe Value -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
AO.Null Value -> Value
forall a. ToJSON a => a -> Value
AO.toOrdered (Key -> KeyMap Value -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup (Text -> Key
K.fromText (Text -> Key) -> Text -> Key
forall a b. (a -> b) -> a -> b
$ Name -> Text
G.unName Name
fname) KeyMap Value
obj)
                  IR.ACFNestedObject Name
_ ActionFieldsG Void
nestedFields -> do
                    let mkValue :: J.Value -> Maybe AO.Value
                        mkValue :: Value -> Maybe Value
mkValue = \case
                          J.Object KeyMap Value
o -> Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ ActionFieldsG Void -> KeyMap Value -> Value
mkResponseObject ActionFieldsG Void
nestedFields KeyMap Value
o
                          J.Array Array
a -> Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ [Value] -> Value
AO.array ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ (Value -> Maybe Value) -> [Value] -> [Value]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe Value -> Maybe Value
mkValue ([Value] -> [Value]) -> [Value] -> [Value]
forall a b. (a -> b) -> a -> b
$ Array -> [Value]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
a
                          Value
J.Null -> Value -> Maybe Value
forall a. a -> Maybe a
Just Value
AO.Null
                          Value
_ -> Maybe Value
forall a. Maybe a
Nothing
                    Key -> KeyMap Value -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup (Text -> Key
K.fromText Text
fieldText) KeyMap Value
obj Maybe Value -> (Value -> Maybe Value) -> Maybe Value
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Maybe Value
mkValue
      mkResponseArray :: J.Value -> AO.Value
      mkResponseArray :: Value -> Value
mkResponseArray = \case
        (J.Object KeyMap Value
o) -> ActionFieldsG Void -> KeyMap Value -> Value
mkResponseObject ActionFieldsG Void
annFields KeyMap Value
o
        Value
x -> Value -> Value
forall a. ToJSON a => a -> Value
AO.toOrdered Value
x
   in -- NOTE (Sam): This case would still not allow for aliased fields to be
      -- a part of the response. Also, seeing that none of the other `annField`
      -- types would be caught in the example, I've chosen to leave it as it is.
      -- NOTE: (Pranshi) Bool here is applied to specify if we want to check ActionOutputFields
      -- (in async actions, we have object types, which need to be validated
      -- and ActionOutputField information is not present in `resolveAsyncActionQuery` -
      -- so added a boolean which will make sure that the response is validated)
      if (GType -> ActionOutputFields -> Bool)
-> GType -> ActionOutputFields -> Bool
gTypeContains GType -> ActionOutputFields -> Bool
isCustomScalar (GraphQLType -> GType
unGraphQLType GraphQLType
outputType) ActionOutputFields
outputF Bool -> Bool -> Bool
&& Bool
shouldCheckOutputField
        then Value -> Value
forall a. ToJSON a => a -> Value
AO.toOrdered (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ Value -> Value
forall a. ToJSON a => a -> Value
J.toJSON Value
webhookResponse
        else case Value
webhookResponse of
          J.Array Array
objs -> [Value] -> Value
AO.array ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ Vector Value -> [Value]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Vector Value -> [Value]) -> Vector Value -> [Value]
forall a b. (a -> b) -> a -> b
$ (Value -> Value) -> Array -> Vector Value
forall a b. (a -> b) -> Vector a -> Vector b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Value
mkResponseArray Array
objs
          J.Object KeyMap Value
obj ->
            ActionFieldsG Void -> KeyMap Value -> Value
mkResponseObject ActionFieldsG Void
annFields KeyMap Value
obj
          Value
J.Null -> Value
AO.Null
          Value
_ -> Value -> Value
forall a. ToJSON a => a -> Value
AO.toOrdered (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ Value -> Value
forall a. ToJSON a => a -> Value
J.toJSON Value
webhookResponse

gTypeContains :: (G.GType -> IR.ActionOutputFields -> Bool) -> G.GType -> IR.ActionOutputFields -> Bool
gTypeContains :: (GType -> ActionOutputFields -> Bool)
-> GType -> ActionOutputFields -> Bool
gTypeContains GType -> ActionOutputFields -> Bool
fun GType
gType ActionOutputFields
aof = case GType
gType of
  t :: GType
t@(G.TypeNamed Nullability
_ Name
_) -> GType -> ActionOutputFields -> Bool
fun GType
t ActionOutputFields
aof
  (G.TypeList Nullability
_ GType
expectedType) -> (GType -> ActionOutputFields -> Bool)
-> GType -> ActionOutputFields -> Bool
gTypeContains GType -> ActionOutputFields -> Bool
fun GType
expectedType ActionOutputFields
aof

isCustomScalar :: G.GType -> IR.ActionOutputFields -> Bool
isCustomScalar :: GType -> ActionOutputFields -> Bool
isCustomScalar (G.TypeNamed Nullability
_ Name
name) ActionOutputFields
outputF = Maybe PGScalarType -> Bool
forall a. Maybe a -> Bool
isJust (Text -> [(Text, PGScalarType)] -> Maybe PGScalarType
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Name -> Text
G.unName Name
name) [(Text, PGScalarType)]
pgScalarTranslations) Bool -> Bool -> Bool
|| (ActionOutputFields -> Bool
forall k v. HashMap k v -> Bool
HashMap.null ActionOutputFields
outputF Bool -> Bool -> Bool
&& (Bool -> Bool
not (Text -> Bool
isInBuiltScalar (Name -> Text
G.unName Name
name))))
isCustomScalar (G.TypeList Nullability
_ GType
_) ActionOutputFields
_ = Bool
False

{- Note: [Async action architecture]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In async actions, acquiring the action result is deferred. The async action mutation is made to
initiate the action which returns an UUID. The UUID is used to query/subsribe for actions response.

On mutation, the server makes an action log record in the metadata storage with request headers
and input arguments. The `asyncActionsProcessor` background thread processes the async actions by executing
the webhook handler and writing back the response payload or errors if any in the metadata storage.

When an async action query/subscription is made, the server fetches the relavent data from the
metadata storage. See Note [Resolving async action query] below.
-}

-- | Resolve asynchronous action mutation which returns only the action uuid
resolveActionMutationAsync ::
  (MonadMetadataStorage m, MonadError QErr m) =>
  IR.AnnActionMutationAsync ->
  [HTTP.Header] ->
  SessionVariables ->
  m ActionId
resolveActionMutationAsync :: forall (m :: * -> *).
(MonadMetadataStorage m, MonadError QErr m) =>
AnnActionMutationAsync
-> ResponseHeaders -> SessionVariables -> m ActionId
resolveActionMutationAsync AnnActionMutationAsync
annAction ResponseHeaders
reqHeaders SessionVariables
sessionVariables =
  m (Either QErr ActionId) -> m ActionId
forall e (m :: * -> *) a. MonadError e m => m (Either e a) -> m a
liftEitherM (m (Either QErr ActionId) -> m ActionId)
-> m (Either QErr ActionId) -> m ActionId
forall a b. (a -> b) -> a -> b
$ ActionName
-> SessionVariables
-> ResponseHeaders
-> Value
-> m (Either QErr ActionId)
forall (m :: * -> *).
MonadMetadataStorage m =>
ActionName
-> SessionVariables
-> ResponseHeaders
-> Value
-> m (Either QErr ActionId)
insertAction ActionName
actionName SessionVariables
sessionVariables ResponseHeaders
reqHeaders Value
inputArgs
  where
    IR.AnnActionMutationAsync ActionName
actionName Bool
_ Value
inputArgs = AnnActionMutationAsync
annAction

{- Note: [Resolving async action query]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Resolving async action query happens in two steps;

1. Fetching webhook response from the metadata storage:
  In this step, using @'fetchActionResponse' method of @'MonadMetadataStorage' type class, we fetch
  the webhook response of any async action mutation (See Note [Async action architecture] for more)

2. Generating client response:
  Generation of appropriate client response happens in two ways based on the availibility of
  relationships on action output object type.

    a. With relationships:- If there are any relationships defined to tables in a source,
       we need to join the rows from the tables. So, we'll generate a SELECT SQL statement from
       a table built virtually from action webhook response fetched in the Step 1 and joining it
       with appropriate tables. Then, we execute this SQL in the source database.

         SELECT .... FROM pg_catalog.jsonb_to_recordset('action webhook response')
         JOIN .... (SELECT ... FROM <source relationship table>)

    b. Without relationships:- In this case, we'll build the response purely in Haskell code from
       the action webhook response fetched in the Step 1.
-}

-- TODO: Add tracing here? Avoided now because currently the function is pure

-- | See Note: [Resolving async action query]
resolveAsyncActionQuery ::
  UserInfo ->
  IR.AnnActionAsyncQuery ('Postgres 'Vanilla) Void ->
  AsyncActionQueryExecution (IR.UnpreparedValue ('Postgres 'Vanilla))
resolveAsyncActionQuery :: UserInfo
-> AnnActionAsyncQuery ('Postgres 'Vanilla) Void
-> AsyncActionQueryExecution (UnpreparedValue ('Postgres 'Vanilla))
resolveAsyncActionQuery UserInfo
userInfo AnnActionAsyncQuery ('Postgres 'Vanilla) Void
annAction =
  case ActionSourceInfo ('Postgres 'Vanilla)
actionSource of
    ActionSourceInfo ('Postgres 'Vanilla)
IR.ASINoSource -> (ActionLogResponse -> Either QErr EncJSON)
-> AsyncActionQueryExecution (UnpreparedValue ('Postgres 'Vanilla))
forall v.
(ActionLogResponse -> Either QErr EncJSON)
-> AsyncActionQueryExecution v
AAQENoRelationships \ActionLogResponse
actionLogResponse -> Except QErr EncJSON -> Either QErr EncJSON
forall e a. Except e a -> Either e a
runExcept do
      let ActionLogResponse {Maybe Value
UTCTime
SessionVariables
ActionId
_alrId :: ActionLogResponse -> ActionId
_alrCreatedAt :: ActionLogResponse -> UTCTime
_alrResponsePayload :: ActionLogResponse -> Maybe Value
_alrErrors :: ActionLogResponse -> Maybe Value
_alrSessionVariables :: ActionLogResponse -> SessionVariables
_alrId :: ActionId
_alrCreatedAt :: UTCTime
_alrResponsePayload :: Maybe Value
_alrErrors :: Maybe Value
_alrSessionVariables :: SessionVariables
..} = ActionLogResponse
actionLogResponse
      [(Text, Value)]
resolvedFields <- [(FieldName, AsyncActionQueryFieldG Void)]
-> ((FieldName, AsyncActionQueryFieldG Void)
    -> ExceptT QErr Identity (Text, Value))
-> ExceptT QErr Identity [(Text, Value)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(FieldName, AsyncActionQueryFieldG Void)]
asyncFields (((FieldName, AsyncActionQueryFieldG Void)
  -> ExceptT QErr Identity (Text, Value))
 -> ExceptT QErr Identity [(Text, Value)])
-> ((FieldName, AsyncActionQueryFieldG Void)
    -> ExceptT QErr Identity (Text, Value))
-> ExceptT QErr Identity [(Text, Value)]
forall a b. (a -> b) -> a -> b
$ \(FieldName
fieldName, AsyncActionQueryFieldG Void
fld) -> do
        let fieldText :: Text
fieldText = FieldName -> Text
getFieldNameTxt FieldName
fieldName
        (Text
fieldText,) (Value -> (Text, Value))
-> ExceptT QErr Identity Value
-> ExceptT QErr Identity (Text, Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case AsyncActionQueryFieldG Void
fld of
          IR.AsyncTypename Text
t -> Value -> ExceptT QErr Identity Value
forall a. a -> ExceptT QErr Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> ExceptT QErr Identity Value)
-> Value -> ExceptT QErr Identity Value
forall a b. (a -> b) -> a -> b
$ Text -> Value
AO.String Text
t
          IR.AsyncOutput ActionFieldsG Void
annFields ->
            Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
AO.Null (Maybe Value -> Value)
-> ExceptT QErr Identity (Maybe Value)
-> ExceptT QErr Identity Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Value
-> (Value -> ExceptT QErr Identity Value)
-> ExceptT QErr Identity (Maybe Value)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM
              Maybe Value
_alrResponsePayload
              \Value
response -> ActionFieldsG Void
-> GraphQLType -> ActionOutputFields -> Bool -> Value -> Value
makeActionResponseNoRelations ActionFieldsG Void
annFields GraphQLType
outputType ActionOutputFields
forall k v. HashMap k v
HashMap.empty Bool
False (Value -> Value)
-> ExceptT QErr Identity Value -> ExceptT QErr Identity Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> ExceptT QErr Identity Value
forall a (m :: * -> *). (FromJSON a, QErrM m) => Value -> m a
decodeValue Value
response
          AsyncActionQueryFieldG Void
IR.AsyncId -> Value -> ExceptT QErr Identity Value
forall a. a -> ExceptT QErr Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> ExceptT QErr Identity Value)
-> Value -> ExceptT QErr Identity Value
forall a b. (a -> b) -> a -> b
$ Text -> Value
AO.String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ ActionId -> Text
actionIdToText ActionId
actionId
          AsyncActionQueryFieldG Void
IR.AsyncCreatedAt -> Value -> ExceptT QErr Identity Value
forall a. a -> ExceptT QErr Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> ExceptT QErr Identity Value)
-> Value -> ExceptT QErr Identity Value
forall a b. (a -> b) -> a -> b
$ Value -> Value
forall a. ToJSON a => a -> Value
AO.toOrdered (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ UTCTime -> Value
forall a. ToJSON a => a -> Value
J.toJSON UTCTime
_alrCreatedAt
          AsyncActionQueryFieldG Void
IR.AsyncErrors -> Value -> ExceptT QErr Identity Value
forall a. a -> ExceptT QErr Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> ExceptT QErr Identity Value)
-> Value -> ExceptT QErr Identity Value
forall a b. (a -> b) -> a -> b
$ Value -> Value
forall a. ToJSON a => a -> Value
AO.toOrdered (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ Maybe Value -> Value
forall a. ToJSON a => a -> Value
J.toJSON Maybe Value
_alrErrors
      EncJSON -> Except QErr EncJSON
forall a. a -> ExceptT QErr Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EncJSON -> Except QErr EncJSON) -> EncJSON -> Except QErr EncJSON
forall a b. (a -> b) -> a -> b
$ Value -> EncJSON
encJFromOrderedValue (Value -> EncJSON) -> Value -> EncJSON
forall a b. (a -> b) -> a -> b
$ [(Text, Value)] -> Value
AO.object [(Text, Value)]
resolvedFields
    IR.ASISource SourceName
sourceName SourceConfig ('Postgres 'Vanilla)
sourceConfig ->
      let jsonAggSelect :: JsonAggSelect
jsonAggSelect = GraphQLType -> JsonAggSelect
mkJsonAggSelect GraphQLType
outputType
       in SourceConfig ('Postgres 'Vanilla)
-> AsyncActionQuerySourceExecution
     (UnpreparedValue ('Postgres 'Vanilla))
-> AsyncActionQueryExecution (UnpreparedValue ('Postgres 'Vanilla))
forall v.
SourceConfig ('Postgres 'Vanilla)
-> AsyncActionQuerySourceExecution v -> AsyncActionQueryExecution v
AAQEOnSourceDB SourceConfig ('Postgres 'Vanilla)
sourceConfig
            (AsyncActionQuerySourceExecution
   (UnpreparedValue ('Postgres 'Vanilla))
 -> AsyncActionQueryExecution
      (UnpreparedValue ('Postgres 'Vanilla)))
-> AsyncActionQuerySourceExecution
     (UnpreparedValue ('Postgres 'Vanilla))
-> AsyncActionQueryExecution (UnpreparedValue ('Postgres 'Vanilla))
forall a b. (a -> b) -> a -> b
$ SourceName
-> JsonAggSelect
-> (ActionLogResponse
    -> AnnSimpleSelectG
         ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla)))
-> AsyncActionQuerySourceExecution
     (UnpreparedValue ('Postgres 'Vanilla))
forall v.
SourceName
-> JsonAggSelect
-> (ActionLogResponse
    -> AnnSimpleSelectG ('Postgres 'Vanilla) Void v)
-> AsyncActionQuerySourceExecution v
AsyncActionQuerySourceExecution SourceName
sourceName JsonAggSelect
jsonAggSelect
            ((ActionLogResponse
  -> AnnSimpleSelectG
       ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla)))
 -> AsyncActionQuerySourceExecution
      (UnpreparedValue ('Postgres 'Vanilla)))
-> (ActionLogResponse
    -> AnnSimpleSelectG
         ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla)))
-> AsyncActionQuerySourceExecution
     (UnpreparedValue ('Postgres 'Vanilla))
forall a b. (a -> b) -> a -> b
$ \ActionLogResponse
actionLogResponse ->
              let annotatedFields :: [(FieldName,
  AnnFieldG
    ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla)))]
annotatedFields =
                    [(FieldName, AsyncActionQueryFieldG Void)]
asyncFields [(FieldName, AsyncActionQueryFieldG Void)]
-> ((FieldName, AsyncActionQueryFieldG Void)
    -> (FieldName,
        AnnFieldG
          ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla))))
-> [(FieldName,
     AnnFieldG
       ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla)))]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (AsyncActionQueryFieldG Void
 -> AnnFieldG
      ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla)))
-> (FieldName, AsyncActionQueryFieldG Void)
-> (FieldName,
    AnnFieldG
      ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla)))
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second \case
                      IR.AsyncTypename Text
t -> Text
-> AnnFieldG
     ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla))
forall (b :: BackendType) r v. Text -> AnnFieldG b r v
RS.AFExpression Text
t
                      IR.AsyncOutput ActionFieldsG Void
annFields ->
                        XComputedField ('Postgres 'Vanilla)
-> ComputedFieldName
-> ComputedFieldSelect
     ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla))
-> AnnFieldG
     ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla))
forall (b :: BackendType) r v.
XComputedField b
-> ComputedFieldName
-> ComputedFieldSelect b r v
-> AnnFieldG b r v
RS.AFComputedField () (NonEmptyText -> ComputedFieldName
ComputedFieldName [nonEmptyTextQQ|__action_computed_field|])
                          (ComputedFieldSelect
   ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla))
 -> AnnFieldG
      ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla)))
-> ComputedFieldSelect
     ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla))
-> AnnFieldG
     ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla))
forall a b. (a -> b) -> a -> b
$ JsonAggSelect
-> AnnSimpleSelectG
     ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla))
-> ComputedFieldSelect
     ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla))
forall (b :: BackendType) r v.
JsonAggSelect
-> AnnSimpleSelectG b r v -> ComputedFieldSelect b r v
RS.CFSTable JsonAggSelect
jsonAggSelect
                          (AnnSimpleSelectG
   ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla))
 -> ComputedFieldSelect
      ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla)))
-> AnnSimpleSelectG
     ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla))
-> ComputedFieldSelect
     ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla))
forall a b. (a -> b) -> a -> b
$ ArgumentExp (UnpreparedValue ('Postgres 'Vanilla))
-> GraphQLType
-> [(PGCol, PGScalarType)]
-> ActionFieldsG Void
-> StringifyNumbers
-> AnnSimpleSelectG
     ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla))
forall v.
ArgumentExp v
-> GraphQLType
-> [(PGCol, PGScalarType)]
-> ActionFieldsG Void
-> StringifyNumbers
-> AnnSimpleSelectG ('Postgres 'Vanilla) Void v
processOutputSelectionSet ArgumentExp (UnpreparedValue ('Postgres 'Vanilla))
forall a. ArgumentExp a
TF.AEActionResponsePayload GraphQLType
outputType [(Column ('Postgres 'Vanilla), ScalarType ('Postgres 'Vanilla))]
[(PGCol, PGScalarType)]
definitionList ActionFieldsG Void
annFields StringifyNumbers
stringifyNumerics
                      AsyncActionQueryFieldG Void
IR.AsyncId -> (Column ('Postgres 'Vanilla), ScalarType ('Postgres 'Vanilla))
-> AnnFieldG
     ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla))
forall {backend :: BackendType} {r} {v}.
(Column backend, ScalarType backend) -> AnnFieldG backend r v
mkAnnFldFromPGCol (Column ('Postgres 'Vanilla), ScalarType ('Postgres 'Vanilla))
(PGCol, PGScalarType)
idColumn
                      AsyncActionQueryFieldG Void
IR.AsyncCreatedAt -> (Column ('Postgres 'Vanilla), ScalarType ('Postgres 'Vanilla))
-> AnnFieldG
     ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla))
forall {backend :: BackendType} {r} {v}.
(Column backend, ScalarType backend) -> AnnFieldG backend r v
mkAnnFldFromPGCol (Column ('Postgres 'Vanilla), ScalarType ('Postgres 'Vanilla))
(PGCol, PGScalarType)
createdAtColumn
                      AsyncActionQueryFieldG Void
IR.AsyncErrors -> (Column ('Postgres 'Vanilla), ScalarType ('Postgres 'Vanilla))
-> AnnFieldG
     ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla))
forall {backend :: BackendType} {r} {v}.
(Column backend, ScalarType backend) -> AnnFieldG backend r v
mkAnnFldFromPGCol (Column ('Postgres 'Vanilla), ScalarType ('Postgres 'Vanilla))
(PGCol, PGScalarType)
errorsColumn

                  jsonbToRecordSet :: QualifiedObject FunctionName
jsonbToRecordSet = SchemaName -> FunctionName -> QualifiedObject FunctionName
forall a. SchemaName -> a -> QualifiedObject a
QualifiedObject SchemaName
"pg_catalog" (FunctionName -> QualifiedObject FunctionName)
-> FunctionName -> QualifiedObject FunctionName
forall a b. (a -> b) -> a -> b
$ Text -> FunctionName
FunctionName Text
"jsonb_to_recordset"
                  actionLogInput :: UnpreparedValue ('Postgres 'Vanilla)
actionLogInput =
                    Provenance
-> ColumnValue ('Postgres 'Vanilla)
-> UnpreparedValue ('Postgres 'Vanilla)
forall (b :: BackendType).
Provenance -> ColumnValue b -> UnpreparedValue b
IR.UVParameter Provenance
IR.FreshVar
                      (ColumnValue ('Postgres 'Vanilla)
 -> UnpreparedValue ('Postgres 'Vanilla))
-> ColumnValue ('Postgres 'Vanilla)
-> UnpreparedValue ('Postgres 'Vanilla)
forall a b. (a -> b) -> a -> b
$ ColumnType ('Postgres 'Vanilla)
-> ScalarValue ('Postgres 'Vanilla)
-> ColumnValue ('Postgres 'Vanilla)
forall (b :: BackendType).
ColumnType b -> ScalarValue b -> ColumnValue b
ColumnValue (ScalarType ('Postgres 'Vanilla) -> ColumnType ('Postgres 'Vanilla)
forall (b :: BackendType). ScalarType b -> ColumnType b
ColumnScalar ScalarType ('Postgres 'Vanilla)
PGScalarType
PGJSONB)
                      (ScalarValue ('Postgres 'Vanilla)
 -> ColumnValue ('Postgres 'Vanilla))
-> ScalarValue ('Postgres 'Vanilla)
-> ColumnValue ('Postgres 'Vanilla)
forall a b. (a -> b) -> a -> b
$ JSONB -> PGScalarValue
PGValJSONB
                      (JSONB -> PGScalarValue) -> JSONB -> PGScalarValue
forall a b. (a -> b) -> a -> b
$ Value -> JSONB
PG.JSONB
                      (Value -> JSONB) -> Value -> JSONB
forall a b. (a -> b) -> a -> b
$ [ActionLogResponse] -> Value
forall a. ToJSON a => a -> Value
J.toJSON [ActionLogResponse
actionLogResponse]
                  functionArgs :: FunctionArgsExpG
  (ArgumentExp (UnpreparedValue ('Postgres 'Vanilla)))
functionArgs = [ArgumentExp (UnpreparedValue ('Postgres 'Vanilla))]
-> HashMap
     Text (ArgumentExp (UnpreparedValue ('Postgres 'Vanilla)))
-> FunctionArgsExpG
     (ArgumentExp (UnpreparedValue ('Postgres 'Vanilla)))
forall a. [a] -> HashMap Text a -> FunctionArgsExpG a
FunctionArgsExp [UnpreparedValue ('Postgres 'Vanilla)
-> ArgumentExp (UnpreparedValue ('Postgres 'Vanilla))
forall a. a -> ArgumentExp a
TF.AEInput UnpreparedValue ('Postgres 'Vanilla)
actionLogInput] HashMap Text (ArgumentExp (UnpreparedValue ('Postgres 'Vanilla)))
forall a. Monoid a => a
mempty
                  tableFromExp :: SelectFromG
  ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
tableFromExp =
                    FunctionName ('Postgres 'Vanilla)
-> FunctionArgsExp
     ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
-> Maybe
     [(Column ('Postgres 'Vanilla), ScalarType ('Postgres 'Vanilla))]
-> SelectFromG
     ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
forall (b :: BackendType) v.
FunctionName b
-> FunctionArgsExp b v
-> Maybe [(Column b, ScalarType b)]
-> SelectFromG b v
RS.FromFunction FunctionName ('Postgres 'Vanilla)
QualifiedObject FunctionName
jsonbToRecordSet FunctionArgsExp
  ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
FunctionArgsExpG
  (ArgumentExp (UnpreparedValue ('Postgres 'Vanilla)))
functionArgs
                      (Maybe
   [(Column ('Postgres 'Vanilla), ScalarType ('Postgres 'Vanilla))]
 -> SelectFromG
      ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla)))
-> Maybe
     [(Column ('Postgres 'Vanilla), ScalarType ('Postgres 'Vanilla))]
-> SelectFromG
     ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
forall a b. (a -> b) -> a -> b
$ [(PGCol, PGScalarType)] -> Maybe [(PGCol, PGScalarType)]
forall a. a -> Maybe a
Just
                        [(PGCol, PGScalarType)
idColumn, (PGCol, PGScalarType)
createdAtColumn, (PGCol, PGScalarType)
responsePayloadColumn, (PGCol, PGScalarType)
errorsColumn, (PGCol, PGScalarType)
sessionVarsColumn]
                  tableArguments :: SelectArgsG
  ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
tableArguments =
                    SelectArgsG
  ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
forall (backend :: BackendType) v. SelectArgsG backend v
RS.noSelectArgs
                      { $sel:_saWhere:SelectArgs :: Maybe
  (AnnBoolExp
     ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla)))
RS._saWhere = AnnBoolExp
  ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
-> Maybe
     (AnnBoolExp
        ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla)))
forall a. a -> Maybe a
Just AnnBoolExp
  ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
tableBoolExpression
                      }
                  tablePermissions :: TablePermG b v
tablePermissions = AnnBoolExp b v -> Maybe Int -> TablePermG b v
forall (b :: BackendType) v.
AnnBoolExp b v -> Maybe Int -> TablePermG b v
RS.TablePerm AnnBoolExp b v
forall (backend :: BackendType) scalar. AnnBoolExp backend scalar
annBoolExpTrue Maybe Int
forall a. Maybe a
Nothing
               in [(FieldName,
  AnnFieldG
    ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla)))]
-> SelectFromG
     ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
-> TablePermG
     ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
-> SelectArgsG
     ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
-> StringifyNumbers
-> Maybe NamingCase
-> AnnSimpleSelectG
     ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla))
forall (b :: BackendType) (f :: * -> *) v.
Fields (f v)
-> SelectFromG b v
-> TablePermG b v
-> SelectArgsG b v
-> StringifyNumbers
-> Maybe NamingCase
-> AnnSelectG b f v
RS.AnnSelectG [(FieldName,
  AnnFieldG
    ('Postgres 'Vanilla) Void (UnpreparedValue ('Postgres 'Vanilla)))]
annotatedFields SelectFromG
  ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
tableFromExp TablePermG
  ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
forall {b :: BackendType} {v}. TablePermG b v
tablePermissions SelectArgsG
  ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
tableArguments StringifyNumbers
stringifyNumerics Maybe NamingCase
forall a. Maybe a
Nothing
  where
    IR.AnnActionAsyncQuery ActionName
_ ActionId
actionId GraphQLType
outputType [(FieldName, AsyncActionQueryFieldG Void)]
asyncFields [(Column ('Postgres 'Vanilla), ScalarType ('Postgres 'Vanilla))]
definitionList StringifyNumbers
stringifyNumerics Bool
_ ActionSourceInfo ('Postgres 'Vanilla)
actionSource = AnnActionAsyncQuery ('Postgres 'Vanilla) Void
annAction

    idColumn :: (PGCol, PGScalarType)
idColumn = (Text -> PGCol
unsafePGCol Text
"id", PGScalarType
PGUUID)
    responsePayloadColumn :: (PGCol, PGScalarType)
responsePayloadColumn = (Text -> PGCol
unsafePGCol Text
TF.actionResponsePayloadColumn, PGScalarType
PGJSONB)
    createdAtColumn :: (PGCol, PGScalarType)
createdAtColumn = (Text -> PGCol
unsafePGCol Text
"created_at", PGScalarType
PGTimeStampTZ)
    errorsColumn :: (PGCol, PGScalarType)
errorsColumn = (Text -> PGCol
unsafePGCol Text
"errors", PGScalarType
PGJSONB)
    sessionVarsColumn :: (PGCol, PGScalarType)
sessionVarsColumn = (Text -> PGCol
unsafePGCol Text
"session_variables", PGScalarType
PGJSONB)

    mkAnnFldFromPGCol :: (Column backend, ScalarType backend) -> AnnFieldG backend r v
mkAnnFldFromPGCol (Column backend
column', ScalarType backend
columnType) =
      Column backend
-> ColumnType backend
-> AnnRedactionExp backend v
-> Maybe (ScalarSelectionArguments backend)
-> AnnFieldG backend r v
forall (backend :: BackendType) v r.
Column backend
-> ColumnType backend
-> AnnRedactionExp backend v
-> Maybe (ScalarSelectionArguments backend)
-> AnnFieldG backend r v
RS.mkAnnColumnField Column backend
column' (ScalarType backend -> ColumnType backend
forall (b :: BackendType). ScalarType b -> ColumnType b
ColumnScalar ScalarType backend
columnType) AnnRedactionExp backend v
forall (b :: BackendType) v. AnnRedactionExp b v
NoRedaction Maybe (ScalarSelectionArguments backend)
forall a. Maybe a
Nothing

    tableBoolExpression :: AnnBoolExp
  ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
tableBoolExpression =
      let actionIdColumnInfo :: ColumnInfo ('Postgres 'Vanilla)
actionIdColumnInfo =
            ColumnInfo
              { ciColumn :: Column ('Postgres 'Vanilla)
ciColumn = (PGCol, PGScalarType) -> PGCol
forall a b. (a, b) -> a
fst (PGCol, PGScalarType)
idColumn,
                ciName :: Name
ciName = Name
Name._id,
                ciPosition :: Int
ciPosition = Int
0,
                ciType :: ColumnType ('Postgres 'Vanilla)
ciType = ScalarType ('Postgres 'Vanilla) -> ColumnType ('Postgres 'Vanilla)
forall (b :: BackendType). ScalarType b -> ColumnType b
ColumnScalar ((PGCol, PGScalarType) -> PGScalarType
forall a b. (a, b) -> b
snd (PGCol, PGScalarType)
idColumn),
                ciIsNullable :: Bool
ciIsNullable = Bool
False,
                ciDescription :: Maybe Description
ciDescription = Maybe Description
forall a. Maybe a
Nothing,
                ciMutability :: ColumnMutability
ciMutability = Bool -> Bool -> ColumnMutability
ColumnMutability Bool
False Bool
False
              }
          actionIdColumnEq :: AnnBoolExp
  ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
actionIdColumnEq = AnnBoolExpFld
  ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
-> AnnBoolExp
     ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
forall (backend :: BackendType) field.
field -> GBoolExp backend field
BoolField (AnnBoolExpFld
   ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
 -> AnnBoolExp
      ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla)))
-> AnnBoolExpFld
     ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
-> AnnBoolExp
     ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
forall a b. (a -> b) -> a -> b
$ ColumnInfo ('Postgres 'Vanilla)
-> [OpExpG
      ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))]
-> AnnBoolExpFld
     ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
forall (backend :: BackendType) leaf.
ColumnInfo backend
-> [OpExpG backend leaf] -> AnnBoolExpFld backend leaf
AVColumn ColumnInfo ('Postgres 'Vanilla)
actionIdColumnInfo [ComparisonNullability
-> UnpreparedValue ('Postgres 'Vanilla)
-> OpExpG
     ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
forall (backend :: BackendType) field.
ComparisonNullability -> field -> OpExpG backend field
AEQ ComparisonNullability
NonNullableComparison (UnpreparedValue ('Postgres 'Vanilla)
 -> OpExpG
      ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla)))
-> UnpreparedValue ('Postgres 'Vanilla)
-> OpExpG
     ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
forall a b. (a -> b) -> a -> b
$ SQLExpression ('Postgres 'Vanilla)
-> UnpreparedValue ('Postgres 'Vanilla)
forall (b :: BackendType). SQLExpression b -> UnpreparedValue b
IR.UVLiteral (SQLExpression ('Postgres 'Vanilla)
 -> UnpreparedValue ('Postgres 'Vanilla))
-> SQLExpression ('Postgres 'Vanilla)
-> UnpreparedValue ('Postgres 'Vanilla)
forall a b. (a -> b) -> a -> b
$ Text -> SQLExp
S.SELit (Text -> SQLExp) -> Text -> SQLExp
forall a b. (a -> b) -> a -> b
$ ActionId -> Text
actionIdToText ActionId
actionId]
          -- TODO: avoid using ColumnInfo
          sessionVarsColumnInfo :: ColumnInfo ('Postgres 'Vanilla)
sessionVarsColumnInfo =
            ColumnInfo
              { ciColumn :: Column ('Postgres 'Vanilla)
ciColumn = Text -> PGCol
unsafePGCol Text
"session_variables",
                ciName :: Name
ciName = Name
Name._session_variables,
                ciPosition :: Int
ciPosition = Int
0,
                ciType :: ColumnType ('Postgres 'Vanilla)
ciType = ScalarType ('Postgres 'Vanilla) -> ColumnType ('Postgres 'Vanilla)
forall (b :: BackendType). ScalarType b -> ColumnType b
ColumnScalar ((PGCol, PGScalarType) -> PGScalarType
forall a b. (a, b) -> b
snd (PGCol, PGScalarType)
sessionVarsColumn),
                ciIsNullable :: Bool
ciIsNullable = Bool
True,
                ciDescription :: Maybe Description
ciDescription = Maybe Description
forall a. Maybe a
Nothing,
                ciMutability :: ColumnMutability
ciMutability = Bool -> Bool -> ColumnMutability
ColumnMutability Bool
False Bool
False
              }
          sessionVarValue :: UnpreparedValue ('Postgres 'Vanilla)
sessionVarValue =
            Provenance
-> ColumnValue ('Postgres 'Vanilla)
-> UnpreparedValue ('Postgres 'Vanilla)
forall (b :: BackendType).
Provenance -> ColumnValue b -> UnpreparedValue b
IR.UVParameter Provenance
IR.FreshVar
              (ColumnValue ('Postgres 'Vanilla)
 -> UnpreparedValue ('Postgres 'Vanilla))
-> ColumnValue ('Postgres 'Vanilla)
-> UnpreparedValue ('Postgres 'Vanilla)
forall a b. (a -> b) -> a -> b
$ ColumnType ('Postgres 'Vanilla)
-> ScalarValue ('Postgres 'Vanilla)
-> ColumnValue ('Postgres 'Vanilla)
forall (b :: BackendType).
ColumnType b -> ScalarValue b -> ColumnValue b
ColumnValue (ScalarType ('Postgres 'Vanilla) -> ColumnType ('Postgres 'Vanilla)
forall (b :: BackendType). ScalarType b -> ColumnType b
ColumnScalar ScalarType ('Postgres 'Vanilla)
PGScalarType
PGJSONB)
              (ScalarValue ('Postgres 'Vanilla)
 -> ColumnValue ('Postgres 'Vanilla))
-> ScalarValue ('Postgres 'Vanilla)
-> ColumnValue ('Postgres 'Vanilla)
forall a b. (a -> b) -> a -> b
$ JSONB -> PGScalarValue
PGValJSONB
              (JSONB -> PGScalarValue) -> JSONB -> PGScalarValue
forall a b. (a -> b) -> a -> b
$ Value -> JSONB
PG.JSONB
              (Value -> JSONB) -> Value -> JSONB
forall a b. (a -> b) -> a -> b
$ SessionVariables -> Value
forall a. ToJSON a => a -> Value
J.toJSON
              (SessionVariables -> Value) -> SessionVariables -> Value
forall a b. (a -> b) -> a -> b
$ UserInfo -> SessionVariables
_uiSession UserInfo
userInfo
          sessionVarsColumnEq :: AnnBoolExp
  ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
sessionVarsColumnEq = AnnBoolExpFld
  ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
-> AnnBoolExp
     ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
forall (backend :: BackendType) field.
field -> GBoolExp backend field
BoolField (AnnBoolExpFld
   ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
 -> AnnBoolExp
      ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla)))
-> AnnBoolExpFld
     ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
-> AnnBoolExp
     ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
forall a b. (a -> b) -> a -> b
$ ColumnInfo ('Postgres 'Vanilla)
-> [OpExpG
      ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))]
-> AnnBoolExpFld
     ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
forall (backend :: BackendType) leaf.
ColumnInfo backend
-> [OpExpG backend leaf] -> AnnBoolExpFld backend leaf
AVColumn ColumnInfo ('Postgres 'Vanilla)
sessionVarsColumnInfo [ComparisonNullability
-> UnpreparedValue ('Postgres 'Vanilla)
-> OpExpG
     ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
forall (backend :: BackendType) field.
ComparisonNullability -> field -> OpExpG backend field
AEQ ComparisonNullability
NonNullableComparison UnpreparedValue ('Postgres 'Vanilla)
sessionVarValue]
       in -- For non-admin roles, accessing an async action's response should be allowed only for the user
          -- who initiated the action through mutation. The action's response is accessible for a query/subscription
          -- only when it's session variables are equal to that of action's.
          if (RoleName
adminRoleName RoleName -> RoleName -> Bool
forall a. Eq a => a -> a -> Bool
== (UserInfo -> RoleName
_uiRole UserInfo
userInfo))
            then AnnBoolExp
  ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
actionIdColumnEq
            else [AnnBoolExp
   ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))]
-> AnnBoolExp
     ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
forall (backend :: BackendType) field.
[GBoolExp backend field] -> GBoolExp backend field
BoolAnd [AnnBoolExp
  ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
actionIdColumnEq, AnnBoolExp
  ('Postgres 'Vanilla) (UnpreparedValue ('Postgres 'Vanilla))
sessionVarsColumnEq]

-- | Process async actions from hdb_catalog.hdb_action_log table. This functions is executed in a background thread.
-- See Note [Async action architecture] above
asyncActionsProcessor ::
  forall m.
  ( HasAppEnv m,
    MonadIO m,
    MonadBaseControl IO m,
    LA.Forall (LA.Pure m),
    MonadMetadataStorage m,
    Tracing.MonadTrace m
  ) =>
  IO Env.Environment ->
  L.Logger L.Hasura ->
  IO SchemaCache ->
  IO OptionalInterval ->
  STM.TVar (Set LockedActionEventId) ->
  Maybe GH.GQLQueryText ->
  m (Forever m)
asyncActionsProcessor :: forall (m :: * -> *).
(HasAppEnv m, MonadIO m, MonadBaseControl IO m, Forall (Pure m),
 MonadMetadataStorage m, MonadTrace m) =>
IO Environment
-> Logger Hasura
-> IO SchemaCache
-> IO OptionalInterval
-> TVar (Set LockedActionEventId)
-> Maybe GQLQueryText
-> m (Forever m)
asyncActionsProcessor IO Environment
getEnvHook Logger Hasura
logger IO SchemaCache
getSCFromRef' IO OptionalInterval
getFetchInterval TVar (Set LockedActionEventId)
lockedActionEvents Maybe GQLQueryText
gqlQueryText =
  Forever m -> m (Forever m)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
    (Forever m -> m (Forever m)) -> Forever m -> m (Forever m)
forall a b. (a -> b) -> a -> b
$ () -> (() -> m ()) -> Forever m
forall (m :: * -> *) a. a -> (a -> m a) -> Forever m
Forever ()
    ((() -> m ()) -> Forever m) -> (() -> m ()) -> Forever m
forall a b. (a -> b) -> a -> b
$ m () -> () -> m ()
forall a b. a -> b -> a
const
    (m () -> () -> m ()) -> m () -> () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      OptionalInterval
fetchInterval <- IO OptionalInterval -> m OptionalInterval
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO OptionalInterval
getFetchInterval
      case OptionalInterval
fetchInterval of
        -- async actions processor thread is a polling thread, so we sleep
        -- for a second in case the fetch interval is not provided and try to
        -- get it in the next iteration. If the fetch interval is available,
        -- we check for async actions to process.
        OptionalInterval
Skip -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DiffTime -> IO ()
sleep (DiffTime -> IO ()) -> DiffTime -> IO ()
forall a b. (a -> b) -> a -> b
$ Seconds -> DiffTime
seconds Seconds
1
        Interval Refined NonNegative Milliseconds
sleepTime -> do
          ActionCache
actionCache <- SchemaCache -> ActionCache
scActions (SchemaCache -> ActionCache) -> m SchemaCache -> m ActionCache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO SchemaCache -> m SchemaCache
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO SchemaCache
getSCFromRef'
          let asyncActions :: ActionCache
asyncActions =
                (ActionInfo -> Bool) -> ActionCache -> ActionCache
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HashMap.filter ((ActionType -> ActionType -> Bool
forall a. Eq a => a -> a -> Bool
== ActionMutationKind -> ActionType
ActionMutation ActionMutationKind
ActionAsynchronous) (ActionType -> Bool)
-> (ActionInfo -> ActionType) -> ActionInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ActionInfo
-> Getting ActionType ActionInfo ActionType -> ActionType
forall s a. s -> Getting a s a -> a
^. (ResolvedActionDefinition
 -> Const ActionType ResolvedActionDefinition)
-> ActionInfo -> Const ActionType ActionInfo
Lens' ActionInfo ResolvedActionDefinition
aiDefinition ((ResolvedActionDefinition
  -> Const ActionType ResolvedActionDefinition)
 -> ActionInfo -> Const ActionType ActionInfo)
-> ((ActionType -> Const ActionType ActionType)
    -> ResolvedActionDefinition
    -> Const ActionType ResolvedActionDefinition)
-> Getting ActionType ActionInfo ActionType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ActionType -> Const ActionType ActionType)
-> ResolvedActionDefinition
-> Const ActionType ResolvedActionDefinition
forall arg webhook (f :: * -> *).
Functor f =>
(ActionType -> f ActionType)
-> ActionDefinition arg webhook -> f (ActionDefinition arg webhook)
adType)) ActionCache
actionCache
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ActionCache -> Bool
forall k v. HashMap k v -> Bool
HashMap.null ActionCache
asyncActions) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            -- fetch undelivered action events only when there's at least
            -- one async action present in the schema cache
            Either QErr [ActionLogItem]
asyncInvocationsE <- m (Either QErr [ActionLogItem])
forall (m :: * -> *).
MonadMetadataStorage m =>
m (Either QErr [ActionLogItem])
fetchUndeliveredActionEvents
            [ActionLogItem]
asyncInvocations <- IO [ActionLogItem] -> m [ActionLogItem]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [ActionLogItem] -> m [ActionLogItem])
-> IO [ActionLogItem] -> m [ActionLogItem]
forall a b. (a -> b) -> a -> b
$ Either QErr [ActionLogItem]
-> (QErr -> IO [ActionLogItem]) -> IO [ActionLogItem]
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
onLeft Either QErr [ActionLogItem]
asyncInvocationsE QErr -> IO [ActionLogItem]
forall a. Monoid a => a
mempty
            -- save the actions that are currently fetched from the DB to
            -- be processed in a TVar (Set LockedActionEventId) and when
            -- the action is processed we remove it from the set. This set
            -- is maintained because on shutdown of the graphql-engine, we
            -- would like to wait for a certain time (see `--graceful-shutdown-time`)
            -- during which to complete all the in-flight actions. So, when this
            -- locked action events set TVar is empty, it will mean that there are
            -- no events that are in the 'processing' state
            [LockedActionEventId] -> TVar (Set LockedActionEventId) -> m ()
forall (m :: * -> *).
MonadIO m =>
[LockedActionEventId] -> TVar (Set LockedActionEventId) -> m ()
saveLockedEvents ((ActionLogItem -> LockedActionEventId)
-> [ActionLogItem] -> [LockedActionEventId]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> LockedActionEventId
EventId (Text -> LockedActionEventId)
-> (ActionLogItem -> Text) -> ActionLogItem -> LockedActionEventId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActionId -> Text
actionIdToText (ActionId -> Text)
-> (ActionLogItem -> ActionId) -> ActionLogItem -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActionLogItem -> ActionId
_aliId) [ActionLogItem]
asyncInvocations) TVar (Set LockedActionEventId)
lockedActionEvents
            (ActionLogItem -> m ()) -> [ActionLogItem] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, MonadBaseControl IO m, Forall (Pure m)) =>
(a -> m b) -> t a -> m ()
LA.mapConcurrently_ (ActionCache -> ActionLogItem -> m ()
callHandler ActionCache
actionCache) [ActionLogItem]
asyncInvocations
          IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DiffTime -> IO ()
sleep (DiffTime -> IO ()) -> DiffTime -> IO ()
forall a b. (a -> b) -> a -> b
$ Milliseconds -> DiffTime
milliseconds (Refined NonNegative Milliseconds -> Milliseconds
forall {k} (p :: k) x. Refined p x -> x
unrefine Refined NonNegative Milliseconds
sleepTime)
  where
    callHandler :: ActionCache -> ActionLogItem -> m ()
    callHandler :: ActionCache -> ActionLogItem -> m ()
callHandler ActionCache
actionCache ActionLogItem
actionLogItem =
      SamplingPolicy -> Text -> m () -> m ()
forall (m :: * -> *) a.
(MonadIO m, MonadTrace m) =>
SamplingPolicy -> Text -> m a -> m a
Tracing.newTrace SamplingPolicy
Tracing.sampleAlways Text
"async actions processor" do
        let ActionLogItem
              ActionId
actionId
              ActionName
actionName
              ResponseHeaders
reqHeaders
              SessionVariables
sessionVariables
              Value
inputPayload = ActionLogItem
actionLogItem
        case ActionName -> ActionCache -> Maybe ActionInfo
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup ActionName
actionName ActionCache
actionCache of
          Maybe ActionInfo
Nothing -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Just ActionInfo
actionInfo -> do
            let definition :: ResolvedActionDefinition
definition = ActionInfo -> ResolvedActionDefinition
_aiDefinition ActionInfo
actionInfo
                outputFields :: ActionOutputFields
outputFields = AnnotatedOutputType -> ActionOutputFields
IR.getActionOutputFields (AnnotatedOutputType -> ActionOutputFields)
-> AnnotatedOutputType -> ActionOutputFields
forall a b. (a -> b) -> a -> b
$ (GType, AnnotatedOutputType) -> AnnotatedOutputType
forall a b. (a, b) -> b
snd ((GType, AnnotatedOutputType) -> AnnotatedOutputType)
-> (GType, AnnotatedOutputType) -> AnnotatedOutputType
forall a b. (a -> b) -> a -> b
$ ActionInfo -> (GType, AnnotatedOutputType)
_aiOutputType ActionInfo
actionInfo
                webhookUrl :: EnvRecord ResolvedWebhook
webhookUrl = ResolvedActionDefinition -> EnvRecord ResolvedWebhook
forall arg webhook. ActionDefinition arg webhook -> webhook
_adHandler ResolvedActionDefinition
definition
                forwardClientHeaders :: Bool
forwardClientHeaders = ResolvedActionDefinition -> Bool
forall arg webhook. ActionDefinition arg webhook -> Bool
_adForwardClientHeaders ResolvedActionDefinition
definition
                confHeaders :: [HeaderConf]
confHeaders = ResolvedActionDefinition -> [HeaderConf]
forall arg webhook. ActionDefinition arg webhook -> [HeaderConf]
_adHeaders ResolvedActionDefinition
definition
                timeout :: Timeout
timeout = ResolvedActionDefinition -> Timeout
forall arg webhook. ActionDefinition arg webhook -> Timeout
_adTimeout ResolvedActionDefinition
definition
                outputType :: GraphQLType
outputType = ResolvedActionDefinition -> GraphQLType
forall arg webhook. ActionDefinition arg webhook -> GraphQLType
_adOutputType ResolvedActionDefinition
definition
                actionContext :: ActionContext
actionContext = ActionName -> ActionContext
ActionContext ActionName
actionName
                metadataRequestTransform :: Maybe RequestTransform
metadataRequestTransform = ResolvedActionDefinition -> Maybe RequestTransform
forall arg webhook.
ActionDefinition arg webhook -> Maybe RequestTransform
_adRequestTransform ResolvedActionDefinition
definition
                metadataResponseTransform :: Maybe MetadataResponseTransform
metadataResponseTransform = ResolvedActionDefinition -> Maybe MetadataResponseTransform
forall arg webhook.
ActionDefinition arg webhook -> Maybe MetadataResponseTransform
_adResponseTransform ResolvedActionDefinition
definition
            Either QErr (Value, ResponseHeaders)
eitherRes <- do
              Environment
env <- IO Environment -> m Environment
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Environment
getEnvHook
              AppEnv {Int
Maybe Text
Maybe PGPool
Maybe (CredentialCache AgentLicenseKey)
SamplingPolicy
HostPreference
Manager
TxIsolation
ConnParams
PGPool
Refined NonNegative Seconds
TMVar MetadataResourceVersion
ConnectionOptions
CheckFeatureFlag
ServerMetrics
EventingMode
ReadOnlyMode
MaintenanceMode ()
InstanceId
PrometheusMetrics
ShutdownLatch
LoggingSettings
LockedEventsCtx
WSConnectionInitTimeout
KeepAliveDelay
OptionalInterval
Port
SubscriptionsState
Loggers
appEnvPort :: Port
appEnvHost :: HostPreference
appEnvMetadataDbPool :: PGPool
appEnvIntrospectionDbPool :: Maybe PGPool
appEnvManager :: Manager
appEnvLoggers :: Loggers
appEnvMetadataVersionRef :: TMVar MetadataResourceVersion
appEnvInstanceId :: InstanceId
appEnvEnableMaintenanceMode :: MaintenanceMode ()
appEnvLoggingSettings :: LoggingSettings
appEnvEventingMode :: EventingMode
appEnvEnableReadOnlyMode :: ReadOnlyMode
appEnvServerMetrics :: ServerMetrics
appEnvShutdownLatch :: ShutdownLatch
appEnvMetaVersionRef :: TMVar MetadataResourceVersion
appEnvPrometheusMetrics :: PrometheusMetrics
appEnvTraceSamplingPolicy :: SamplingPolicy
appEnvSubscriptionState :: SubscriptionsState
appEnvLockedEventsCtx :: LockedEventsCtx
appEnvConnParams :: ConnParams
appEnvTxIso :: TxIsolation
appEnvConsoleAssetsDir :: Maybe Text
appEnvConsoleSentryDsn :: Maybe Text
appEnvConnectionOptions :: ConnectionOptions
appEnvWebSocketKeepAlive :: KeepAliveDelay
appEnvWebSocketConnectionInitTimeout :: WSConnectionInitTimeout
appEnvGracefulShutdownTimeout :: Refined NonNegative Seconds
appEnvSchemaPollInterval :: OptionalInterval
appEnvCheckFeatureFlag :: CheckFeatureFlag
appEnvLicenseKeyCache :: Maybe (CredentialCache AgentLicenseKey)
appEnvMaxTotalHeaderLength :: Int
appEnvPort :: AppEnv -> Port
appEnvHost :: AppEnv -> HostPreference
appEnvMetadataDbPool :: AppEnv -> PGPool
appEnvIntrospectionDbPool :: AppEnv -> Maybe PGPool
appEnvManager :: AppEnv -> Manager
appEnvLoggers :: AppEnv -> Loggers
appEnvMetadataVersionRef :: AppEnv -> TMVar MetadataResourceVersion
appEnvInstanceId :: AppEnv -> InstanceId
appEnvEnableMaintenanceMode :: AppEnv -> MaintenanceMode ()
appEnvLoggingSettings :: AppEnv -> LoggingSettings
appEnvEventingMode :: AppEnv -> EventingMode
appEnvEnableReadOnlyMode :: AppEnv -> ReadOnlyMode
appEnvServerMetrics :: AppEnv -> ServerMetrics
appEnvShutdownLatch :: AppEnv -> ShutdownLatch
appEnvMetaVersionRef :: AppEnv -> TMVar MetadataResourceVersion
appEnvPrometheusMetrics :: AppEnv -> PrometheusMetrics
appEnvTraceSamplingPolicy :: AppEnv -> SamplingPolicy
appEnvSubscriptionState :: AppEnv -> SubscriptionsState
appEnvLockedEventsCtx :: AppEnv -> LockedEventsCtx
appEnvConnParams :: AppEnv -> ConnParams
appEnvTxIso :: AppEnv -> TxIsolation
appEnvConsoleAssetsDir :: AppEnv -> Maybe Text
appEnvConsoleSentryDsn :: AppEnv -> Maybe Text
appEnvConnectionOptions :: AppEnv -> ConnectionOptions
appEnvWebSocketKeepAlive :: AppEnv -> KeepAliveDelay
appEnvWebSocketConnectionInitTimeout :: AppEnv -> WSConnectionInitTimeout
appEnvGracefulShutdownTimeout :: AppEnv -> Refined NonNegative Seconds
appEnvSchemaPollInterval :: AppEnv -> OptionalInterval
appEnvCheckFeatureFlag :: AppEnv -> CheckFeatureFlag
appEnvLicenseKeyCache :: AppEnv -> Maybe (CredentialCache AgentLicenseKey)
appEnvMaxTotalHeaderLength :: AppEnv -> Int
..} <- m AppEnv
forall (m :: * -> *). HasAppEnv m => m AppEnv
askAppEnv
              ExceptT QErr m (Value, ResponseHeaders)
-> m (Either QErr (Value, ResponseHeaders))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
                (ExceptT QErr m (Value, ResponseHeaders)
 -> m (Either QErr (Value, ResponseHeaders)))
-> ExceptT QErr m (Value, ResponseHeaders)
-> m (Either QErr (Value, ResponseHeaders))
forall a b. (a -> b) -> a -> b
$ (ReaderT (Logger Hasura) (ExceptT QErr m) (Value, ResponseHeaders)
 -> Logger Hasura -> ExceptT QErr m (Value, ResponseHeaders))
-> Logger Hasura
-> ReaderT
     (Logger Hasura) (ExceptT QErr m) (Value, ResponseHeaders)
-> ExceptT QErr m (Value, ResponseHeaders)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (Logger Hasura) (ExceptT QErr m) (Value, ResponseHeaders)
-> Logger Hasura -> ExceptT QErr m (Value, ResponseHeaders)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Logger Hasura
logger
                (ReaderT (Logger Hasura) (ExceptT QErr m) (Value, ResponseHeaders)
 -> ExceptT QErr m (Value, ResponseHeaders))
-> ReaderT
     (Logger Hasura) (ExceptT QErr m) (Value, ResponseHeaders)
-> ExceptT QErr m (Value, ResponseHeaders)
forall a b. (a -> b) -> a -> b
$ Environment
-> Manager
-> PrometheusMetrics
-> GraphQLType
-> ActionOutputFields
-> ResponseHeaders
-> [HeaderConf]
-> Bool
-> EnvRecord ResolvedWebhook
-> ActionWebhookPayload
-> Timeout
-> Maybe RequestTransform
-> Maybe MetadataResponseTransform
-> ReaderT
     (Logger Hasura) (ExceptT QErr m) (Value, ResponseHeaders)
forall (m :: * -> *) r.
(MonadIO m, MonadError QErr m, MonadTrace m, MonadReader r m,
 Has (Logger Hasura) r) =>
Environment
-> Manager
-> PrometheusMetrics
-> GraphQLType
-> ActionOutputFields
-> ResponseHeaders
-> [HeaderConf]
-> Bool
-> EnvRecord ResolvedWebhook
-> ActionWebhookPayload
-> Timeout
-> Maybe RequestTransform
-> Maybe MetadataResponseTransform
-> m (Value, ResponseHeaders)
callWebhook
                  Environment
env
                  Manager
appEnvManager
                  PrometheusMetrics
appEnvPrometheusMetrics
                  GraphQLType
outputType
                  ActionOutputFields
outputFields
                  ResponseHeaders
reqHeaders
                  [HeaderConf]
confHeaders
                  Bool
forwardClientHeaders
                  EnvRecord ResolvedWebhook
webhookUrl
                  (ActionContext
-> SessionVariables
-> Value
-> Maybe GQLQueryText
-> ActionWebhookPayload
ActionWebhookPayload ActionContext
actionContext SessionVariables
sessionVariables Value
inputPayload Maybe GQLQueryText
gqlQueryText)
                  Timeout
timeout
                  Maybe RequestTransform
metadataRequestTransform
                  Maybe MetadataResponseTransform
metadataResponseTransform
            Either QErr ()
resE <-
              ActionId -> AsyncActionStatus -> m (Either QErr ())
forall (m :: * -> *).
MonadMetadataStorage m =>
ActionId -> AsyncActionStatus -> m (Either QErr ())
setActionStatus ActionId
actionId (AsyncActionStatus -> m (Either QErr ()))
-> AsyncActionStatus -> m (Either QErr ())
forall a b. (a -> b) -> a -> b
$ case Either QErr (Value, ResponseHeaders)
eitherRes of
                Left QErr
e -> QErr -> AsyncActionStatus
AASError QErr
e
                Right (Value
responsePayload, ResponseHeaders
_) -> Value -> AsyncActionStatus
AASCompleted (Value -> AsyncActionStatus) -> Value -> AsyncActionStatus
forall a b. (a -> b) -> a -> b
$ Value -> Value
forall a. ToJSON a => a -> Value
J.toJSON Value
responsePayload
            LockedActionEventId -> TVar (Set LockedActionEventId) -> m ()
forall (m :: * -> *).
MonadIO m =>
LockedActionEventId -> TVar (Set LockedActionEventId) -> m ()
removeEventFromLockedEvents (Text -> LockedActionEventId
EventId (ActionId -> Text
actionIdToText ActionId
actionId)) TVar (Set LockedActionEventId)
lockedActionEvents
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Either QErr () -> (QErr -> IO ()) -> IO ()
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
onLeft Either QErr ()
resE QErr -> IO ()
forall a. Monoid a => a
mempty

callWebhook ::
  forall m r.
  ( MonadIO m,
    MonadError QErr m,
    Tracing.MonadTrace m,
    MonadReader r m,
    Has (L.Logger L.Hasura) r
  ) =>
  Env.Environment ->
  HTTP.Manager ->
  PrometheusMetrics ->
  GraphQLType ->
  IR.ActionOutputFields ->
  [HTTP.Header] ->
  [HeaderConf] ->
  Bool ->
  EnvRecord ResolvedWebhook ->
  ActionWebhookPayload ->
  Timeout ->
  Maybe RequestTransform ->
  Maybe MetadataResponseTransform ->
  m (ActionWebhookResponse, HTTP.ResponseHeaders)
callWebhook :: forall (m :: * -> *) r.
(MonadIO m, MonadError QErr m, MonadTrace m, MonadReader r m,
 Has (Logger Hasura) r) =>
Environment
-> Manager
-> PrometheusMetrics
-> GraphQLType
-> ActionOutputFields
-> ResponseHeaders
-> [HeaderConf]
-> Bool
-> EnvRecord ResolvedWebhook
-> ActionWebhookPayload
-> Timeout
-> Maybe RequestTransform
-> Maybe MetadataResponseTransform
-> m (Value, ResponseHeaders)
callWebhook
  Environment
env
  Manager
manager
  PrometheusMetrics
prometheusMetrics
  GraphQLType
outputType
  ActionOutputFields
outputFields
  ResponseHeaders
reqHeaders
  [HeaderConf]
confHeaders
  Bool
forwardClientHeaders
  EnvRecord ResolvedWebhook
resolvedWebhook
  ActionWebhookPayload
actionWebhookPayload
  Timeout
timeoutSeconds
  Maybe RequestTransform
metadataRequestTransform
  Maybe MetadataResponseTransform
metadataResponseTransform = do
    ResponseHeaders
resolvedConfHeaders <- Environment -> [HeaderConf] -> m ResponseHeaders
forall (m :: * -> *).
MonadError QErr m =>
Environment -> [HeaderConf] -> m ResponseHeaders
makeHeadersFromConf Environment
env [HeaderConf]
confHeaders
    let clientHeaders :: ResponseHeaders
clientHeaders = if Bool
forwardClientHeaders then ResponseHeaders -> ResponseHeaders
mkClientHeadersForward ResponseHeaders
reqHeaders else ResponseHeaders
forall a. Monoid a => a
mempty
        -- Using HashMap to avoid duplicate headers between configuration headers
        -- and client headers where configuration headers are preferred
        hdrs :: ResponseHeaders
hdrs = (HashMap HeaderName ByteString -> ResponseHeaders
forall k v. HashMap k v -> [(k, v)]
HashMap.toList (HashMap HeaderName ByteString -> ResponseHeaders)
-> (ResponseHeaders -> HashMap HeaderName ByteString)
-> ResponseHeaders
-> ResponseHeaders
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResponseHeaders -> HashMap HeaderName ByteString
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList) (ResponseHeaders
resolvedConfHeaders ResponseHeaders -> ResponseHeaders -> ResponseHeaders
forall a. Semigroup a => a -> a -> a
<> ResponseHeaders
defaultHeaders ResponseHeaders -> ResponseHeaders -> ResponseHeaders
forall a. Semigroup a => a -> a -> a
<> ResponseHeaders
clientHeaders)
        postPayload :: Value
postPayload = ActionWebhookPayload -> Value
forall a. ToJSON a => a -> Value
J.toJSON ActionWebhookPayload
actionWebhookPayload
        requestBody :: ByteString
requestBody = Value -> ByteString
forall a. ToJSON a => a -> ByteString
J.encode Value
postPayload
        requestBodySize :: Int64
requestBodySize = ByteString -> Int64
BL.length ByteString
requestBody
        responseTimeout :: ResponseTimeout
responseTimeout = Int -> ResponseTimeout
HTTP.responseTimeoutMicro (Int -> ResponseTimeout) -> Int -> ResponseTimeout
forall a b. (a -> b) -> a -> b
$ (Timeout -> Int
unTimeout Timeout
timeoutSeconds) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000
        (EnvRecord Text
webhookEnvName ResolvedWebhook
resolvedWebhookValue) = EnvRecord ResolvedWebhook
resolvedWebhook
        webhookUrl :: Text
webhookUrl = ResolvedWebhook -> Text
unResolvedWebhook ResolvedWebhook
resolvedWebhookValue
        sessionVars :: Maybe SessionVariables
sessionVars = SessionVariables -> Maybe SessionVariables
forall a. a -> Maybe a
Just (SessionVariables -> Maybe SessionVariables)
-> SessionVariables -> Maybe SessionVariables
forall a b. (a -> b) -> a -> b
$ ActionWebhookPayload -> SessionVariables
_awpSessionVariables ActionWebhookPayload
actionWebhookPayload

    Request
initReq <- IO Request -> m Request
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Request -> m Request) -> IO Request -> m Request
forall a b. (a -> b) -> a -> b
$ Text -> IO Request
forall (m :: * -> *). MonadThrow m => Text -> m Request
HTTP.mkRequestThrow Text
webhookUrl

    let req :: Request
req =
          Request
initReq
            Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& ASetter Request Request ByteString ByteString
-> ByteString -> Request -> Request
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Request Request ByteString ByteString
Lens' Request ByteString
HTTP.method ByteString
"POST"
            Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& ASetter Request Request ResponseHeaders ResponseHeaders
-> ResponseHeaders -> Request -> Request
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Request Request ResponseHeaders ResponseHeaders
Lens' Request ResponseHeaders
HTTP.headers ResponseHeaders
hdrs
            Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& ASetter Request Request RequestBody RequestBody
-> RequestBody -> Request -> Request
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Request Request RequestBody RequestBody
Lens' Request RequestBody
HTTP.body (ByteString -> RequestBody
HTTP.RequestBodyLBS ByteString
requestBody)
            Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& ASetter Request Request ResponseTimeout ResponseTimeout
-> ResponseTimeout -> Request -> Request
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Request Request ResponseTimeout ResponseTimeout
Lens' Request ResponseTimeout
HTTP.timeout ResponseTimeout
responseTimeout

    (Maybe Request
transformedReq, Maybe Int64
transformedReqSize, Maybe (Request -> RequestContext)
reqTransformCtx) <- case Maybe RequestTransform
metadataRequestTransform of
      Maybe RequestTransform
Nothing -> (Maybe Request, Maybe Int64, Maybe (Request -> RequestContext))
-> m (Maybe Request, Maybe Int64,
      Maybe (Request -> RequestContext))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Request
forall a. Maybe a
Nothing, Maybe Int64
forall a. Maybe a
Nothing, Maybe (Request -> RequestContext)
forall a. Maybe a
Nothing)
      Just RequestTransform {TemplatingEngine
Version
RequestFields (WithOptional TransformFn)
version :: Version
requestFields :: RequestFields (WithOptional TransformFn)
templateEngine :: TemplatingEngine
version :: RequestTransform -> Version
requestFields :: RequestTransform -> RequestFields (WithOptional TransformFn)
templateEngine :: RequestTransform -> TemplatingEngine
..} ->
        let reqTransformCtx :: Request -> RequestContext
reqTransformCtx = (RequestTransformCtx -> RequestContext)
-> (Request -> RequestTransformCtx) -> Request -> RequestContext
forall a b. (a -> b) -> (Request -> a) -> Request -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RequestTransformCtx -> RequestContext
mkRequestContext ((Request -> RequestTransformCtx) -> Request -> RequestContext)
-> (Request -> RequestTransformCtx) -> Request -> RequestContext
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe SessionVariables
-> TemplatingEngine
-> Request
-> RequestTransformCtx
mkReqTransformCtx Text
webhookUrl Maybe SessionVariables
sessionVars TemplatingEngine
templateEngine
         in case (Request -> RequestContext)
-> RequestFields (WithOptional TransformFn)
-> Request
-> Either TransformErrorBundle Request
forall (m :: * -> *).
MonadError TransformErrorBundle m =>
(Request -> RequestContext)
-> RequestFields (WithOptional TransformFn) -> Request -> m Request
applyRequestTransform Request -> RequestContext
reqTransformCtx RequestFields (WithOptional TransformFn)
requestFields Request
req of
              Left TransformErrorBundle
err -> do
                -- Log The Transformation Error
                Logger Hasura
logger :: L.Logger L.Hasura <- (r -> Logger Hasura) -> m (Logger Hasura)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> Logger Hasura
forall a t. Has a t => t -> a
getter
                Logger Hasura
-> forall a (m :: * -> *).
   (ToEngineLog a Hasura, MonadIO m) =>
   a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
   (ToEngineLog a impl, MonadIO m) =>
   a -> m ()
L.unLogger Logger Hasura
logger (UnstructuredLog -> m ()) -> UnstructuredLog -> m ()
forall a b. (a -> b) -> a -> b
$ LogLevel -> SerializableBlob -> UnstructuredLog
L.UnstructuredLog LogLevel
L.LevelError (ByteString -> SerializableBlob
SB.fromLBS (ByteString -> SerializableBlob) -> ByteString -> SerializableBlob
forall a b. (a -> b) -> a -> b
$ TransformErrorBundle -> ByteString
forall a. ToJSON a => a -> ByteString
J.encode TransformErrorBundle
err)

                -- Throw an exception with the Transformation Error
                Text
-> Value
-> m (Maybe Request, Maybe Int64,
      Maybe (Request -> RequestContext))
forall (m :: * -> *) a. QErrM m => Text -> Value -> m a
throw500WithDetail Text
"Request Transformation Failed" (Value
 -> m (Maybe Request, Maybe Int64,
       Maybe (Request -> RequestContext)))
-> Value
-> m (Maybe Request, Maybe Int64,
      Maybe (Request -> RequestContext))
forall a b. (a -> b) -> a -> b
$ TransformErrorBundle -> Value
forall a. ToJSON a => a -> Value
J.toJSON TransformErrorBundle
err
              Right Request
transformedReq ->
                let transformedPayloadSize :: Int64
transformedPayloadSize = Request -> Int64
HTTP.getReqSize Request
transformedReq
                 in (Maybe Request, Maybe Int64, Maybe (Request -> RequestContext))
-> m (Maybe Request, Maybe Int64,
      Maybe (Request -> RequestContext))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Request -> Maybe Request
forall a. a -> Maybe a
Just Request
transformedReq, Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Int64
transformedPayloadSize, (Request -> RequestContext) -> Maybe (Request -> RequestContext)
forall a. a -> Maybe a
Just Request -> RequestContext
reqTransformCtx)

    let actualReq :: Request
actualReq = Request -> Maybe Request -> Request
forall a. a -> Maybe a -> a
fromMaybe Request
req Maybe Request
transformedReq
        actualSize :: Int64
actualSize = Int64 -> Maybe Int64 -> Int64
forall a. a -> Maybe a -> a
fromMaybe Int64
requestBodySize Maybe Int64
transformedReqSize

    Either HttpException (Response ByteString)
httpResponse <-
      Request
-> (Request -> m (Either HttpException (Response ByteString)))
-> m (Either HttpException (Response ByteString))
forall (m :: * -> *) a.
(MonadIO m, MonadTrace m) =>
Request -> (Request -> m a) -> m a
Tracing.traceHTTPRequest Request
actualReq ((Request -> m (Either HttpException (Response ByteString)))
 -> m (Either HttpException (Response ByteString)))
-> (Request -> m (Either HttpException (Response ByteString)))
-> m (Either HttpException (Response ByteString))
forall a b. (a -> b) -> a -> b
$ \Request
request ->
        IO (Either HttpException (Response ByteString))
-> m (Either HttpException (Response ByteString))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either HttpException (Response ByteString))
 -> m (Either HttpException (Response ByteString)))
-> (IO (Response ByteString)
    -> IO (Either HttpException (Response ByteString)))
-> IO (Response ByteString)
-> m (Either HttpException (Response ByteString))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Response ByteString)
-> IO (Either HttpException (Response ByteString))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Response ByteString)
 -> m (Either HttpException (Response ByteString)))
-> IO (Response ByteString)
-> m (Either HttpException (Response ByteString))
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
HTTP.httpLbs Request
request Manager
manager

    let requestInfo :: ActionRequestInfo
requestInfo = Text -> Value -> [HeaderConf] -> Maybe Request -> ActionRequestInfo
ActionRequestInfo Text
webhookEnvName Value
postPayload ([HeaderConf]
confHeaders [HeaderConf] -> [HeaderConf] -> [HeaderConf]
forall a. Semigroup a => a -> a -> a
<> ResponseHeaders -> [HeaderConf]
toHeadersConf ResponseHeaders
clientHeaders) Maybe Request
transformedReq

    case Either HttpException (Response ByteString)
httpResponse of
      Left HttpException
e ->
        Text -> Value -> m (Value, ResponseHeaders)
forall (m :: * -> *) a. QErrM m => Text -> Value -> m a
throw500WithDetail Text
"http exception when calling webhook"
          (Value -> m (Value, ResponseHeaders))
-> Value -> m (Value, ResponseHeaders)
forall a b. (a -> b) -> a -> b
$ ActionInternalError -> Value
forall a. ToJSON a => a -> Value
J.toJSON
          (ActionInternalError -> Value) -> ActionInternalError -> Value
forall a b. (a -> b) -> a -> b
$ Value
-> ActionRequestInfo
-> Maybe ActionResponseInfo
-> ActionInternalError
ActionInternalError (ShowErrorInfo -> HttpException -> Value
getHttpExceptionJson (Bool -> ShowErrorInfo
ShowErrorInfo Bool
True) (HttpException -> Value) -> HttpException -> Value
forall a b. (a -> b) -> a -> b
$ HttpException -> HttpException
HttpException HttpException
e) ActionRequestInfo
requestInfo Maybe ActionResponseInfo
forall a. Maybe a
Nothing
      Right Response ByteString
responseWreq -> do
        -- TODO(SOLOMON): Remove 'wreq'
        let responseBody :: ByteString
responseBody = Response ByteString
responseWreq Response ByteString
-> Getting ByteString (Response ByteString) ByteString
-> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString (Response ByteString) ByteString
forall body0 body1 (f :: * -> *).
Functor f =>
(body0 -> f body1) -> Response body0 -> f (Response body1)
Wreq.responseBody
            responseBodySize :: Int64
responseBodySize = ByteString -> Int64
BL.length ByteString
responseBody
            actionName :: ActionName
actionName = ActionContext -> ActionName
_acName (ActionContext -> ActionName) -> ActionContext -> ActionName
forall a b. (a -> b) -> a -> b
$ ActionWebhookPayload -> ActionContext
_awpAction ActionWebhookPayload
actionWebhookPayload
            responseStatus :: Status
responseStatus = Response ByteString
responseWreq Response ByteString
-> Getting Status (Response ByteString) Status -> Status
forall s a. s -> Getting a s a -> a
^. Getting Status (Response ByteString) Status
forall body (f :: * -> *).
Functor f =>
(Status -> f Status) -> Response body -> f (Response body)
Wreq.responseStatus
            mkResponseInfo :: Value -> ActionResponseInfo
mkResponseInfo Value
respBody =
              Int -> Value -> [HeaderConf] -> ActionResponseInfo
ActionResponseInfo (Status -> Int
HTTP.statusCode Status
responseStatus) Value
respBody
                ([HeaderConf] -> ActionResponseInfo)
-> [HeaderConf] -> ActionResponseInfo
forall a b. (a -> b) -> a -> b
$ ResponseHeaders -> [HeaderConf]
toHeadersConf
                (ResponseHeaders -> [HeaderConf])
-> ResponseHeaders -> [HeaderConf]
forall a b. (a -> b) -> a -> b
$ Response ByteString
responseWreq
                Response ByteString
-> Getting ResponseHeaders (Response ByteString) ResponseHeaders
-> ResponseHeaders
forall s a. s -> Getting a s a -> a
^. Getting ResponseHeaders (Response ByteString) ResponseHeaders
forall body (f :: * -> *).
Functor f =>
(ResponseHeaders -> f ResponseHeaders)
-> Response body -> f (Response body)
Wreq.responseHeaders

        ByteString
transformedResponseBody <- case Maybe MetadataResponseTransform
metadataResponseTransform of
          Maybe MetadataResponseTransform
Nothing -> ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
responseBody
          Just MetadataResponseTransform
metadataResponseTransform' ->
            let responseTransform :: ResponseTransform
responseTransform = MetadataResponseTransform -> ResponseTransform
mkResponseTransform MetadataResponseTransform
metadataResponseTransform'
                engine :: TemplatingEngine
engine = ResponseTransform -> TemplatingEngine
respTransformTemplateEngine ResponseTransform
responseTransform
                responseTransformCtx :: ResponseTransformCtx
responseTransformCtx = Maybe RequestContext
-> Maybe SessionVariables
-> TemplatingEngine
-> ByteString
-> Int
-> ResponseTransformCtx
buildRespTransformCtx (Maybe (Request -> RequestContext)
reqTransformCtx Maybe (Request -> RequestContext)
-> Maybe Request -> Maybe RequestContext
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Request -> Maybe Request
forall a. a -> Maybe a
Just Request
actualReq) Maybe SessionVariables
sessionVars TemplatingEngine
engine (Response ByteString -> ByteString
forall body. Response body -> body
HTTP.responseBody Response ByteString
responseWreq) (Status -> Int
HTTP.statusCode Status
responseStatus)
             in ResponseTransform
-> ResponseTransformCtx -> Either TransformErrorBundle ByteString
applyResponseTransform ResponseTransform
responseTransform ResponseTransformCtx
responseTransformCtx Either TransformErrorBundle ByteString
-> (TransformErrorBundle -> m ByteString) -> m ByteString
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
`onLeft` \TransformErrorBundle
err -> do
                  -- Log The Response Transformation Error
                  Logger Hasura
logger :: L.Logger L.Hasura <- (r -> Logger Hasura) -> m (Logger Hasura)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> Logger Hasura
forall a t. Has a t => t -> a
getter
                  Logger Hasura
-> forall a (m :: * -> *).
   (ToEngineLog a Hasura, MonadIO m) =>
   a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
   (ToEngineLog a impl, MonadIO m) =>
   a -> m ()
L.unLogger Logger Hasura
logger (UnstructuredLog -> m ()) -> UnstructuredLog -> m ()
forall a b. (a -> b) -> a -> b
$ LogLevel -> SerializableBlob -> UnstructuredLog
L.UnstructuredLog LogLevel
L.LevelError (ByteString -> SerializableBlob
SB.fromLBS (ByteString -> SerializableBlob) -> ByteString -> SerializableBlob
forall a b. (a -> b) -> a -> b
$ TransformErrorBundle -> ByteString
forall a. ToJSON a => a -> ByteString
J.encode TransformErrorBundle
err)

                  -- Throw an exception with the Transformation Error
                  Text -> Value -> m ByteString
forall (m :: * -> *) a. QErrM m => Text -> Value -> m a
throw500WithDetail Text
"Response Transformation Failed" (Value -> m ByteString) -> Value -> m ByteString
forall a b. (a -> b) -> a -> b
$ TransformErrorBundle -> Value
forall a. ToJSON a => a -> Value
J.toJSON TransformErrorBundle
err

        -- log the request and response to/from the action handler
        IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          Counter -> Int64 -> IO ()
Prometheus.Counter.add
            (PrometheusMetrics -> Counter
pmActionBytesSent PrometheusMetrics
prometheusMetrics)
            Int64
actualSize
          Counter -> Int64 -> IO ()
Prometheus.Counter.add
            (PrometheusMetrics -> Counter
pmActionBytesReceived PrometheusMetrics
prometheusMetrics)
            Int64
responseBodySize
        Logger Hasura
logger :: (L.Logger L.Hasura) <- (r -> Logger Hasura) -> m (Logger Hasura)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> Logger Hasura
forall a t. Has a t => t -> a
getter
        Logger Hasura
-> forall a (m :: * -> *).
   (ToEngineLog a Hasura, MonadIO m) =>
   a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
   (ToEngineLog a impl, MonadIO m) =>
   a -> m ()
L.unLogger Logger Hasura
logger (ActionHandlerLog -> m ()) -> ActionHandlerLog -> m ()
forall a b. (a -> b) -> a -> b
$ Request
-> Maybe Request
-> Int64
-> Maybe Int64
-> Int64
-> ActionName
-> ActionHandlerLog
ActionHandlerLog Request
req Maybe Request
transformedReq Int64
requestBodySize Maybe Int64
transformedReqSize Int64
responseBodySize ActionName
actionName

        case ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
J.eitherDecode ByteString
transformedResponseBody of
          Left String
e -> do
            let responseInfo :: ActionResponseInfo
responseInfo = Value -> ActionResponseInfo
mkResponseInfo (Value -> ActionResponseInfo) -> Value -> ActionResponseInfo
forall a b. (a -> b) -> a -> b
$ Text -> Value
J.String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
bsToTxt (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.toStrict ByteString
responseBody
            Text -> Value -> m (Value, ResponseHeaders)
forall (m :: * -> *) a. QErrM m => Text -> Value -> m a
throw500WithDetail Text
"not a valid json response from webhook"
              (Value -> m (Value, ResponseHeaders))
-> Value -> m (Value, ResponseHeaders)
forall a b. (a -> b) -> a -> b
$ ActionInternalError -> Value
forall a. ToJSON a => a -> Value
J.toJSON
              (ActionInternalError -> Value) -> ActionInternalError -> Value
forall a b. (a -> b) -> a -> b
$ Value
-> ActionRequestInfo
-> Maybe ActionResponseInfo
-> ActionInternalError
ActionInternalError (String -> Value
forall a. ToJSON a => a -> Value
J.toJSON (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ String
"invalid json: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
e) ActionRequestInfo
requestInfo
              (Maybe ActionResponseInfo -> ActionInternalError)
-> Maybe ActionResponseInfo -> ActionInternalError
forall a b. (a -> b) -> a -> b
$ ActionResponseInfo -> Maybe ActionResponseInfo
forall a. a -> Maybe a
Just ActionResponseInfo
responseInfo
          Right Value
responseValue -> do
            let responseInfo :: ActionResponseInfo
responseInfo = Value -> ActionResponseInfo
mkResponseInfo Value
responseValue
                addInternalToErr :: QErr -> QErr
addInternalToErr QErr
e =
                  let actionInternalError :: Value
actionInternalError =
                        ActionInternalError -> Value
forall a. ToJSON a => a -> Value
J.toJSON
                          (ActionInternalError -> Value) -> ActionInternalError -> Value
forall a b. (a -> b) -> a -> b
$ Value
-> ActionRequestInfo
-> Maybe ActionResponseInfo
-> ActionInternalError
ActionInternalError (Text -> Value
J.String Text
"unexpected response") ActionRequestInfo
requestInfo
                          (Maybe ActionResponseInfo -> ActionInternalError)
-> Maybe ActionResponseInfo -> ActionInternalError
forall a b. (a -> b) -> a -> b
$ ActionResponseInfo -> Maybe ActionResponseInfo
forall a. a -> Maybe a
Just ActionResponseInfo
responseInfo
                   in QErr
e {qeInternal :: Maybe QErrExtra
qeInternal = QErrExtra -> Maybe QErrExtra
forall a. a -> Maybe a
Just (QErrExtra -> Maybe QErrExtra) -> QErrExtra -> Maybe QErrExtra
forall a b. (a -> b) -> a -> b
$ Value -> QErrExtra
ExtraInternal Value
actionInternalError}

            if
              | Status -> Bool
HTTP.statusIsSuccessful Status
responseStatus -> do
                  (QErr -> QErr)
-> m (Value, ResponseHeaders) -> m (Value, ResponseHeaders)
forall (m :: * -> *) a. QErrM m => (QErr -> QErr) -> m a -> m a
modifyQErr QErr -> QErr
addInternalToErr (m (Value, ResponseHeaders) -> m (Value, ResponseHeaders))
-> m (Value, ResponseHeaders) -> m (Value, ResponseHeaders)
forall a b. (a -> b) -> a -> b
$ do
                    Value
webhookResponse <- Value -> m Value
forall a (m :: * -> *). (FromJSON a, QErrM m) => Value -> m a
decodeValue Value
responseValue
                    Value -> GraphQLType -> ActionOutputFields -> m ()
forall (m :: * -> *).
MonadError QErr m =>
Value -> GraphQLType -> ActionOutputFields -> m ()
validateResponse Value
responseValue GraphQLType
outputType ActionOutputFields
outputFields
                    (Value, ResponseHeaders) -> m (Value, ResponseHeaders)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value
webhookResponse, Response ByteString -> ResponseHeaders
forall a. Response a -> ResponseHeaders
mkSetCookieHeaders Response ByteString
responseWreq)
              | Status -> Bool
HTTP.statusIsClientError Status
responseStatus -> do
                  ActionWebhookErrorResponse Text
message Maybe Text
maybeCode Maybe Value
maybeExtensions <-
                    (QErr -> QErr)
-> m ActionWebhookErrorResponse -> m ActionWebhookErrorResponse
forall (m :: * -> *) a. QErrM m => (QErr -> QErr) -> m a -> m a
modifyQErr QErr -> QErr
addInternalToErr (m ActionWebhookErrorResponse -> m ActionWebhookErrorResponse)
-> m ActionWebhookErrorResponse -> m ActionWebhookErrorResponse
forall a b. (a -> b) -> a -> b
$ Value -> m ActionWebhookErrorResponse
forall a (m :: * -> *). (FromJSON a, QErrM m) => Value -> m a
decodeValue Value
responseValue
                  let code :: Code
code = Code -> (Text -> Code) -> Maybe Text -> Code
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Code
Unexpected Text -> Code
ActionWebhookCode Maybe Text
maybeCode
                      qErr :: QErr
qErr = JSONPath -> Status -> Text -> Code -> Maybe QErrExtra -> QErr
QErr [] Status
responseStatus Text
message Code
code (Value -> QErrExtra
ExtraExtensions (Value -> QErrExtra) -> Maybe Value -> Maybe QErrExtra
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Value
maybeExtensions)
                  QErr -> m (Value, ResponseHeaders)
forall a. QErr -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError QErr
qErr
              | Bool
otherwise -> do
                  let err :: Value
err =
                        String -> Value
forall a. ToJSON a => a -> Value
J.toJSON
                          (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ String
"expecting 2xx or 4xx status code, but found "
                          String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Status -> Int
HTTP.statusCode Status
responseStatus)
                  Text -> Value -> m (Value, ResponseHeaders)
forall (m :: * -> *) a. QErrM m => Text -> Value -> m a
throw500WithDetail Text
"internal error"
                    (Value -> m (Value, ResponseHeaders))
-> Value -> m (Value, ResponseHeaders)
forall a b. (a -> b) -> a -> b
$ ActionInternalError -> Value
forall a. ToJSON a => a -> Value
J.toJSON
                    (ActionInternalError -> Value) -> ActionInternalError -> Value
forall a b. (a -> b) -> a -> b
$ Value
-> ActionRequestInfo
-> Maybe ActionResponseInfo
-> ActionInternalError
ActionInternalError Value
err ActionRequestInfo
requestInfo
                    (Maybe ActionResponseInfo -> ActionInternalError)
-> Maybe ActionResponseInfo -> ActionInternalError
forall a b. (a -> b) -> a -> b
$ ActionResponseInfo -> Maybe ActionResponseInfo
forall a. a -> Maybe a
Just ActionResponseInfo
responseInfo

processOutputSelectionSet ::
  TF.ArgumentExp v ->
  GraphQLType ->
  [(PGCol, PGScalarType)] ->
  IR.ActionFields ->
  Options.StringifyNumbers ->
  RS.AnnSimpleSelectG ('Postgres 'Vanilla) Void v
processOutputSelectionSet :: forall v.
ArgumentExp v
-> GraphQLType
-> [(PGCol, PGScalarType)]
-> ActionFieldsG Void
-> StringifyNumbers
-> AnnSimpleSelectG ('Postgres 'Vanilla) Void v
processOutputSelectionSet ArgumentExp v
tableRowInput GraphQLType
actionOutputType [(PGCol, PGScalarType)]
definitionList ActionFieldsG Void
actionFields StringifyNumbers
strfyNum =
  Fields (AnnFieldG ('Postgres 'Vanilla) Void v)
-> SelectFromG ('Postgres 'Vanilla) v
-> TablePermG ('Postgres 'Vanilla) v
-> SelectArgsG ('Postgres 'Vanilla) v
-> StringifyNumbers
-> Maybe NamingCase
-> AnnSelectG
     ('Postgres 'Vanilla) (AnnFieldG ('Postgres 'Vanilla) Void) v
forall (b :: BackendType) (f :: * -> *) v.
Fields (f v)
-> SelectFromG b v
-> TablePermG b v
-> SelectArgsG b v
-> StringifyNumbers
-> Maybe NamingCase
-> AnnSelectG b f v
RS.AnnSelectG Fields (AnnFieldG ('Postgres 'Vanilla) Void v)
annotatedFields SelectFromG ('Postgres 'Vanilla) v
selectFrom TablePermG ('Postgres 'Vanilla) v
forall {b :: BackendType} {v}. TablePermG b v
RS.noTablePermissions SelectArgsG ('Postgres 'Vanilla) v
forall (backend :: BackendType) v. SelectArgsG backend v
RS.noSelectArgs StringifyNumbers
strfyNum Maybe NamingCase
forall a. Maybe a
Nothing
  where
    annotatedFields :: Fields (AnnFieldG ('Postgres 'Vanilla) Void v)
annotatedFields = (ActionFieldG Void -> AnnFieldG ('Postgres 'Vanilla) Void v)
-> (FieldName, ActionFieldG Void)
-> (FieldName, AnnFieldG ('Postgres 'Vanilla) Void v)
forall a b. (a -> b) -> (FieldName, a) -> (FieldName, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ActionFieldG Void -> AnnFieldG ('Postgres 'Vanilla) Void v
forall v.
ActionFieldG Void -> AnnFieldG ('Postgres 'Vanilla) Void v
actionFieldToAnnField ((FieldName, ActionFieldG Void)
 -> (FieldName, AnnFieldG ('Postgres 'Vanilla) Void v))
-> ActionFieldsG Void
-> Fields (AnnFieldG ('Postgres 'Vanilla) Void v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ActionFieldsG Void
actionFields
    jsonbToPostgresRecordFunction :: QualifiedObject FunctionName
jsonbToPostgresRecordFunction =
      SchemaName -> FunctionName -> QualifiedObject FunctionName
forall a. SchemaName -> a -> QualifiedObject a
QualifiedObject SchemaName
"pg_catalog"
        (FunctionName -> QualifiedObject FunctionName)
-> FunctionName -> QualifiedObject FunctionName
forall a b. (a -> b) -> a -> b
$ Text -> FunctionName
FunctionName
        (Text -> FunctionName) -> Text -> FunctionName
forall a b. (a -> b) -> a -> b
$ if GraphQLType -> Bool
isListType GraphQLType
actionOutputType
          then Text
"jsonb_to_recordset" -- Multirow array response
          else Text
"jsonb_to_record" -- Single object response
    functionArgs :: FunctionArgsExpG (ArgumentExp v)
functionArgs = [ArgumentExp v]
-> HashMap Text (ArgumentExp v) -> FunctionArgsExpG (ArgumentExp v)
forall a. [a] -> HashMap Text a -> FunctionArgsExpG a
FunctionArgsExp [ArgumentExp v
tableRowInput] HashMap Text (ArgumentExp v)
forall a. Monoid a => a
mempty
    selectFrom :: SelectFromG ('Postgres 'Vanilla) v
selectFrom = FunctionName ('Postgres 'Vanilla)
-> FunctionArgsExp ('Postgres 'Vanilla) v
-> Maybe
     [(Column ('Postgres 'Vanilla), ScalarType ('Postgres 'Vanilla))]
-> SelectFromG ('Postgres 'Vanilla) v
forall (b :: BackendType) v.
FunctionName b
-> FunctionArgsExp b v
-> Maybe [(Column b, ScalarType b)]
-> SelectFromG b v
RS.FromFunction FunctionName ('Postgres 'Vanilla)
QualifiedObject FunctionName
jsonbToPostgresRecordFunction FunctionArgsExp ('Postgres 'Vanilla) v
FunctionArgsExpG (ArgumentExp v)
functionArgs (Maybe
   [(Column ('Postgres 'Vanilla), ScalarType ('Postgres 'Vanilla))]
 -> SelectFromG ('Postgres 'Vanilla) v)
-> Maybe
     [(Column ('Postgres 'Vanilla), ScalarType ('Postgres 'Vanilla))]
-> SelectFromG ('Postgres 'Vanilla) v
forall a b. (a -> b) -> a -> b
$ [(PGCol, PGScalarType)] -> Maybe [(PGCol, PGScalarType)]
forall a. a -> Maybe a
Just [(PGCol, PGScalarType)]
definitionList

actionFieldToAnnField :: IR.ActionFieldG Void -> RS.AnnFieldG ('Postgres 'Vanilla) Void v
actionFieldToAnnField :: forall v.
ActionFieldG Void -> AnnFieldG ('Postgres 'Vanilla) Void v
actionFieldToAnnField = \case
  IR.ACFScalar Name
asf -> Column ('Postgres 'Vanilla)
-> ColumnType ('Postgres 'Vanilla)
-> AnnRedactionExp ('Postgres 'Vanilla) v
-> Maybe (ScalarSelectionArguments ('Postgres 'Vanilla))
-> AnnFieldG ('Postgres 'Vanilla) Void v
forall (backend :: BackendType) v r.
Column backend
-> ColumnType backend
-> AnnRedactionExp backend v
-> Maybe (ScalarSelectionArguments backend)
-> AnnFieldG backend r v
RS.mkAnnColumnField (Text -> PGCol
unsafePGCol (Text -> PGCol) -> Text -> PGCol
forall a b. (a -> b) -> a -> b
$ Name -> Text
forall a. ToTxt a => a -> Text
toTxt Name
asf) (ScalarType ('Postgres 'Vanilla) -> ColumnType ('Postgres 'Vanilla)
forall (b :: BackendType). ScalarType b -> ColumnType b
ColumnScalar ScalarType ('Postgres 'Vanilla)
PGScalarType
PGJSON) AnnRedactionExp ('Postgres 'Vanilla) v
forall (b :: BackendType) v. AnnRedactionExp b v
NoRedaction Maybe (ScalarSelectionArguments ('Postgres 'Vanilla))
Maybe ColumnOp
forall a. Maybe a
Nothing
  IR.ACFExpression Text
txt -> Text -> AnnFieldG ('Postgres 'Vanilla) Void v
forall (b :: BackendType) r v. Text -> AnnFieldG b r v
RS.AFExpression Text
txt
  IR.ACFNestedObject Name
fieldName ActionFieldsG Void
_ -> Column ('Postgres 'Vanilla)
-> ColumnType ('Postgres 'Vanilla)
-> AnnRedactionExp ('Postgres 'Vanilla) v
-> Maybe (ScalarSelectionArguments ('Postgres 'Vanilla))
-> AnnFieldG ('Postgres 'Vanilla) Void v
forall (backend :: BackendType) v r.
Column backend
-> ColumnType backend
-> AnnRedactionExp backend v
-> Maybe (ScalarSelectionArguments backend)
-> AnnFieldG backend r v
RS.mkAnnColumnField (Text -> PGCol
unsafePGCol (Text -> PGCol) -> Text -> PGCol
forall a b. (a -> b) -> a -> b
$ Name -> Text
forall a. ToTxt a => a -> Text
toTxt Name
fieldName) (ScalarType ('Postgres 'Vanilla) -> ColumnType ('Postgres 'Vanilla)
forall (b :: BackendType). ScalarType b -> ColumnType b
ColumnScalar ScalarType ('Postgres 'Vanilla)
PGScalarType
PGJSON) AnnRedactionExp ('Postgres 'Vanilla) v
forall (b :: BackendType) v. AnnRedactionExp b v
NoRedaction Maybe (ScalarSelectionArguments ('Postgres 'Vanilla))
Maybe ColumnOp
forall a. Maybe a
Nothing

mkJsonAggSelect :: GraphQLType -> JsonAggSelect
mkJsonAggSelect :: GraphQLType -> JsonAggSelect
mkJsonAggSelect =
  JsonAggSelect -> JsonAggSelect -> Bool -> JsonAggSelect
forall a. a -> a -> Bool -> a
bool JsonAggSelect
JASSingleObject JsonAggSelect
JASMultipleRows (Bool -> JsonAggSelect)
-> (GraphQLType -> Bool) -> GraphQLType -> JsonAggSelect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GraphQLType -> Bool
isListType

insertActionTx ::
  ActionName ->
  SessionVariables ->
  [HTTP.Header] ->
  J.Value ->
  PG.TxE QErr ActionId
insertActionTx :: ActionName
-> SessionVariables
-> ResponseHeaders
-> Value
-> TxE QErr ActionId
insertActionTx ActionName
actionName SessionVariables
sessionVariables ResponseHeaders
httpHeaders Value
inputArgsPayload =
  Identity ActionId -> ActionId
forall a. Identity a -> a
runIdentity
    (Identity ActionId -> ActionId)
-> (SingleRow (Identity ActionId) -> Identity ActionId)
-> SingleRow (Identity ActionId)
-> ActionId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SingleRow (Identity ActionId) -> Identity ActionId
forall a. SingleRow a -> a
PG.getRow
    (SingleRow (Identity ActionId) -> ActionId)
-> TxET QErr IO (SingleRow (Identity ActionId))
-> TxE QErr ActionId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PGTxErr -> QErr)
-> Query
-> (ActionName, ViaJSON SessionVariables,
    ViaJSON (HashMap Text Text), ViaJSON Value, Text)
-> Bool
-> TxET QErr IO (SingleRow (Identity ActionId))
forall (m :: * -> *) a r e.
(MonadIO m, FromRes a, ToPrepArgs r) =>
(PGTxErr -> e) -> Query -> r -> Bool -> TxET e m a
PG.withQE
      PGTxErr -> QErr
defaultTxErrorHandler
      [PG.sql|
    INSERT INTO
        "hdb_catalog"."hdb_action_log"
        ("action_name", "session_variables", "request_headers", "input_payload", "status")
    VALUES
        ($1, $2, $3, $4, $5)
    RETURNING "id"
   |]
      ( ActionName
actionName,
        SessionVariables -> ViaJSON SessionVariables
forall a. a -> ViaJSON a
PG.ViaJSON SessionVariables
sessionVariables,
        HashMap Text Text -> ViaJSON (HashMap Text Text)
forall a. a -> ViaJSON a
PG.ViaJSON (HashMap Text Text -> ViaJSON (HashMap Text Text))
-> HashMap Text Text -> ViaJSON (HashMap Text Text)
forall a b. (a -> b) -> a -> b
$ ResponseHeaders -> HashMap Text Text
toHeadersMap ResponseHeaders
httpHeaders,
        Value -> ViaJSON Value
forall a. a -> ViaJSON a
PG.ViaJSON Value
inputArgsPayload,
        Text
"created" :: Text
      )
      Bool
False
  where
    toHeadersMap :: ResponseHeaders -> HashMap Text Text
toHeadersMap = [(Text, Text)] -> HashMap Text Text
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ([(Text, Text)] -> HashMap Text Text)
-> (ResponseHeaders -> [(Text, Text)])
-> ResponseHeaders
-> HashMap Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((HeaderName, ByteString) -> (Text, Text))
-> ResponseHeaders -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> Text
bsToTxt (ByteString -> Text)
-> (HeaderName -> ByteString) -> HeaderName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> ByteString
forall s. CI s -> s
CI.original) (HeaderName -> Text)
-> (ByteString -> Text) -> (HeaderName, ByteString) -> (Text, Text)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ByteString -> Text
bsToTxt)

fetchUndeliveredActionEventsTx :: PG.TxE QErr [ActionLogItem]
fetchUndeliveredActionEventsTx :: TxE QErr [ActionLogItem]
fetchUndeliveredActionEventsTx =
  ((ActionId, ActionName, ViaJSON (HashMap Text Text),
  ViaJSON SessionVariables, ViaJSON Value)
 -> ActionLogItem)
-> [(ActionId, ActionName, ViaJSON (HashMap Text Text),
     ViaJSON SessionVariables, ViaJSON Value)]
-> [ActionLogItem]
forall a b. (a -> b) -> [a] -> [b]
map (ActionId, ActionName, ViaJSON (HashMap Text Text),
 ViaJSON SessionVariables, ViaJSON Value)
-> ActionLogItem
mapEvent
    ([(ActionId, ActionName, ViaJSON (HashMap Text Text),
   ViaJSON SessionVariables, ViaJSON Value)]
 -> [ActionLogItem])
-> TxET
     QErr
     IO
     [(ActionId, ActionName, ViaJSON (HashMap Text Text),
       ViaJSON SessionVariables, ViaJSON Value)]
-> TxE QErr [ActionLogItem]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PGTxErr -> QErr)
-> Query
-> ()
-> Bool
-> TxET
     QErr
     IO
     [(ActionId, ActionName, ViaJSON (HashMap Text Text),
       ViaJSON SessionVariables, ViaJSON Value)]
forall (m :: * -> *) a r e.
(MonadIO m, FromRes a, ToPrepArgs r) =>
(PGTxErr -> e) -> Query -> r -> Bool -> TxET e m a
PG.withQE
      PGTxErr -> QErr
defaultTxErrorHandler
      [PG.sql|
    update hdb_catalog.hdb_action_log set status = 'processing'
    where
      id in (
        select id from hdb_catalog.hdb_action_log
        where status = 'created'
        for update skip locked limit 10
      )
    returning
      id, action_name, request_headers::json, session_variables::json, input_payload::json
  |]
      ()
      Bool
False
  where
    mapEvent :: (ActionId, ActionName, ViaJSON (HashMap Text Text),
 ViaJSON SessionVariables, ViaJSON Value)
-> ActionLogItem
mapEvent
      ( ActionId
actionId,
        ActionName
actionName,
        PG.ViaJSON HashMap Text Text
headersMap,
        PG.ViaJSON SessionVariables
sessionVariables,
        PG.ViaJSON Value
inputPayload
        ) =
        ActionId
-> ActionName
-> ResponseHeaders
-> SessionVariables
-> Value
-> ActionLogItem
ActionLogItem ActionId
actionId ActionName
actionName (HashMap Text Text -> ResponseHeaders
fromHeadersMap HashMap Text Text
headersMap) SessionVariables
sessionVariables Value
inputPayload

    fromHeadersMap :: HashMap Text Text -> ResponseHeaders
fromHeadersMap = ((Text, Text) -> (HeaderName, ByteString))
-> [(Text, Text)] -> ResponseHeaders
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> HeaderName)
-> (Text -> ByteString) -> Text -> HeaderName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
txtToBs) (Text -> HeaderName)
-> (Text -> ByteString) -> (Text, Text) -> (HeaderName, ByteString)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Text -> ByteString
txtToBs) ([(Text, Text)] -> ResponseHeaders)
-> (HashMap Text Text -> [(Text, Text)])
-> HashMap Text Text
-> ResponseHeaders
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text Text -> [(Text, Text)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList

setActionStatusTx :: ActionId -> AsyncActionStatus -> PG.TxE QErr ()
setActionStatusTx :: ActionId -> AsyncActionStatus -> TxE QErr ()
setActionStatusTx ActionId
actionId = \case
  AASCompleted Value
responsePayload ->
    (PGTxErr -> QErr)
-> Query -> (ViaJSON Value, ActionId) -> Bool -> TxE QErr ()
forall (m :: * -> *) r e.
(MonadIO m, ToPrepArgs r) =>
(PGTxErr -> e) -> Query -> r -> Bool -> TxET e m ()
PG.unitQE
      PGTxErr -> QErr
defaultTxErrorHandler
      [PG.sql|
      update hdb_catalog.hdb_action_log
      set response_payload = $1, status = 'completed'
      where id = $2
    |]
      (Value -> ViaJSON Value
forall a. a -> ViaJSON a
PG.ViaJSON Value
responsePayload, ActionId
actionId)
      Bool
False
  AASError QErr
qerr ->
    (PGTxErr -> QErr)
-> Query -> (ViaJSON QErr, ActionId) -> Bool -> TxE QErr ()
forall (m :: * -> *) r e.
(MonadIO m, ToPrepArgs r) =>
(PGTxErr -> e) -> Query -> r -> Bool -> TxET e m ()
PG.unitQE
      PGTxErr -> QErr
defaultTxErrorHandler
      [PG.sql|
      update hdb_catalog.hdb_action_log
      set errors = $1, status = 'error'
      where id = $2
    |]
      (QErr -> ViaJSON QErr
forall a. a -> ViaJSON a
PG.ViaJSON QErr
qerr, ActionId
actionId)
      Bool
False

fetchActionResponseTx :: ActionId -> PG.TxE QErr ActionLogResponse
fetchActionResponseTx :: ActionId -> TxE QErr ActionLogResponse
fetchActionResponseTx ActionId
actionId = do
  (UTCTime
ca, Maybe (ViaJSON Value)
rp, Maybe (ViaJSON Value)
errs, PG.ViaJSON SessionVariables
sessVars) <-
    SingleRow
  (UTCTime, Maybe (ViaJSON Value), Maybe (ViaJSON Value),
   ViaJSON SessionVariables)
-> (UTCTime, Maybe (ViaJSON Value), Maybe (ViaJSON Value),
    ViaJSON SessionVariables)
forall a. SingleRow a -> a
PG.getRow
      (SingleRow
   (UTCTime, Maybe (ViaJSON Value), Maybe (ViaJSON Value),
    ViaJSON SessionVariables)
 -> (UTCTime, Maybe (ViaJSON Value), Maybe (ViaJSON Value),
     ViaJSON SessionVariables))
-> TxET
     QErr
     IO
     (SingleRow
        (UTCTime, Maybe (ViaJSON Value), Maybe (ViaJSON Value),
         ViaJSON SessionVariables))
-> TxET
     QErr
     IO
     (UTCTime, Maybe (ViaJSON Value), Maybe (ViaJSON Value),
      ViaJSON SessionVariables)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PGTxErr -> QErr)
-> Query
-> Identity ActionId
-> Bool
-> TxET
     QErr
     IO
     (SingleRow
        (UTCTime, Maybe (ViaJSON Value), Maybe (ViaJSON Value),
         ViaJSON SessionVariables))
forall (m :: * -> *) a r e.
(MonadIO m, FromRes a, ToPrepArgs r) =>
(PGTxErr -> e) -> Query -> r -> Bool -> TxET e m a
PG.withQE
        PGTxErr -> QErr
defaultTxErrorHandler
        [PG.sql|
     SELECT created_at, response_payload::json, errors::json, session_variables::json
       FROM hdb_catalog.hdb_action_log
      WHERE id = $1
    |]
        (ActionId -> Identity ActionId
forall a. a -> Identity a
Identity ActionId
actionId)
        Bool
True
  ActionLogResponse -> TxE QErr ActionLogResponse
forall a. a -> TxET QErr IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ActionLogResponse -> TxE QErr ActionLogResponse)
-> ActionLogResponse -> TxE QErr ActionLogResponse
forall a b. (a -> b) -> a -> b
$ ActionId
-> UTCTime
-> Maybe Value
-> Maybe Value
-> SessionVariables
-> ActionLogResponse
ActionLogResponse ActionId
actionId UTCTime
ca (ViaJSON Value -> Value
forall a. ViaJSON a -> a
PG.getViaJSON (ViaJSON Value -> Value) -> Maybe (ViaJSON Value) -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (ViaJSON Value)
rp) (ViaJSON Value -> Value
forall a. ViaJSON a -> a
PG.getViaJSON (ViaJSON Value -> Value) -> Maybe (ViaJSON Value) -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (ViaJSON Value)
errs) SessionVariables
sessVars

clearActionDataTx :: ActionName -> PG.TxE QErr ()
clearActionDataTx :: ActionName -> TxE QErr ()
clearActionDataTx ActionName
actionName =
  (PGTxErr -> QErr)
-> Query -> Identity ActionName -> Bool -> TxE QErr ()
forall (m :: * -> *) r e.
(MonadIO m, ToPrepArgs r) =>
(PGTxErr -> e) -> Query -> r -> Bool -> TxET e m ()
PG.unitQE
    PGTxErr -> QErr
defaultTxErrorHandler
    [PG.sql|
      DELETE FROM hdb_catalog.hdb_action_log
        WHERE action_name = $1
      |]
    (ActionName -> Identity ActionName
forall a. a -> Identity a
Identity ActionName
actionName)
    Bool
True

setProcessingActionLogsToPendingTx :: LockedActionIdArray -> PG.TxE QErr ()
setProcessingActionLogsToPendingTx :: LockedActionIdArray -> TxE QErr ()
setProcessingActionLogsToPendingTx LockedActionIdArray
lockedActions =
  (PGTxErr -> QErr)
-> Query -> Identity LockedActionIdArray -> Bool -> TxE QErr ()
forall (m :: * -> *) r e.
(MonadIO m, ToPrepArgs r) =>
(PGTxErr -> e) -> Query -> r -> Bool -> TxET e m ()
PG.unitQE
    PGTxErr -> QErr
defaultTxErrorHandler
    [PG.sql|
    UPDATE hdb_catalog.hdb_action_log
    SET status = 'created'
    WHERE status = 'processing' AND id = ANY($1::uuid[])
  |]
    (LockedActionIdArray -> Identity LockedActionIdArray
forall a. a -> Identity a
Identity LockedActionIdArray
lockedActions)
    Bool
False