{-# LANGUAGE TemplateHaskell #-}

-- | Postgres Execute Mutation
--
-- Generic combinators for translating and excecuting IR mutation statements.
-- Used by the specific mutation modules, e.g. 'Hasura.Backends.Postgres.Execute.Insert'.
--
-- See 'Hasura.Backends.Postgres.Instances.Execute'.
module Hasura.Backends.Postgres.Execute.Mutation
  ( MutateResp (..),
    --
    execDeleteQuery,
    execInsertQuery,
    execUpdateQuery,
    --
    executeMutationOutputQuery,
    mutateAndFetchCols,
    --
    ValidateInputPayloadVersion,
    validateInputPayloadVersion,
    ValidateInputErrorResponse (..),
    HttpHandlerLog (..),
    ValidateInsertInputLog (..),
    InsertValidationPayloadMap,
    validateUpdateMutation,
    validateDeleteMutation,
    validateMutation,
  )
where

import Control.Exception (try)
import Control.Lens qualified as Lens
import Control.Monad.Writer (runWriter)
import Data.Aeson
import Data.Aeson qualified as J
import Data.Aeson.Key qualified as J
import Data.Aeson.TH qualified as J
import Data.Environment qualified as Env
import Data.HashMap.Strict qualified as HashMap
import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap
import Data.Sequence qualified as DS
import Database.PG.Query qualified as PG
import Hasura.Backends.Postgres.Connection
import Hasura.Backends.Postgres.SQL.DML qualified as S
import Hasura.Backends.Postgres.SQL.Types hiding (TableName)
import Hasura.Backends.Postgres.SQL.Value
import Hasura.Backends.Postgres.Translate.Delete
import Hasura.Backends.Postgres.Translate.Insert
import Hasura.Backends.Postgres.Translate.Mutation
import Hasura.Backends.Postgres.Translate.Returning
import Hasura.Backends.Postgres.Translate.Select
import Hasura.Backends.Postgres.Translate.Select.Internal.Helpers (customSQLToTopLevelCTEs, toQuery)
import Hasura.Backends.Postgres.Translate.Update
import Hasura.Backends.Postgres.Types.Update qualified as Postgres
import Hasura.Base.Error
import Hasura.EncJSON
import Hasura.GraphQL.Parser.Internal.Convert
import Hasura.GraphQL.Parser.Variable qualified as G
import Hasura.HTTP
import Hasura.Logging qualified as L
import Hasura.Prelude
import Hasura.QueryTags
import Hasura.RQL.DDL.Headers
import Hasura.RQL.IR qualified as IR
import Hasura.RQL.IR.BoolExp
import Hasura.RQL.IR.Delete
import Hasura.RQL.IR.Insert
import Hasura.RQL.IR.Returning
import Hasura.RQL.IR.Select
import Hasura.RQL.IR.Update
import Hasura.RQL.Types.Backend
import Hasura.RQL.Types.BackendType
import Hasura.RQL.Types.Column
import Hasura.RQL.Types.Common
import Hasura.RQL.Types.Headers (HeaderConf)
import Hasura.RQL.Types.NamingCase (NamingCase)
import Hasura.RQL.Types.Permission
import Hasura.RQL.Types.Schema.Options qualified as Options
import Hasura.Server.Utils
import Hasura.Session
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

data MutateResp (b :: BackendType) a = MutateResp
  { forall (b :: BackendType) a. MutateResp b a -> Int
_mrAffectedRows :: Int,
    forall (b :: BackendType) a. MutateResp b a -> [ColumnValues b a]
_mrReturningColumns :: [ColumnValues b a]
  }
  deriving ((forall x. MutateResp b a -> Rep (MutateResp b a) x)
-> (forall x. Rep (MutateResp b a) x -> MutateResp b a)
-> Generic (MutateResp b a)
forall x. Rep (MutateResp b a) x -> MutateResp b a
forall x. MutateResp b a -> Rep (MutateResp b a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (b :: BackendType) a x.
Rep (MutateResp b a) x -> MutateResp b a
forall (b :: BackendType) a x.
MutateResp b a -> Rep (MutateResp b a) x
$cfrom :: forall (b :: BackendType) a x.
MutateResp b a -> Rep (MutateResp b a) x
from :: forall x. MutateResp b a -> Rep (MutateResp b a) x
$cto :: forall (b :: BackendType) a x.
Rep (MutateResp b a) x -> MutateResp b a
to :: forall x. Rep (MutateResp b a) x -> MutateResp b a
Generic)

deriving instance (Backend b, Show a) => Show (MutateResp b a)

deriving instance (Backend b, Eq a) => Eq (MutateResp b a)

instance (Backend b, ToJSON a) => ToJSON (MutateResp b a) where
  toJSON :: MutateResp b a -> Value
toJSON = Options -> MutateResp b a -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
hasuraJSON

instance (Backend b, FromJSON a) => FromJSON (MutateResp b a) where
  parseJSON :: Value -> Parser (MutateResp b a)
parseJSON = Options -> Value -> Parser (MutateResp b a)
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
hasuraJSON

data Mutation (b :: BackendType) = Mutation
  { forall (b :: BackendType). Mutation b -> QualifiedTable
_mTable :: QualifiedTable,
    forall (b :: BackendType). Mutation b -> (MutationCTE, Seq PrepArg)
_mQuery :: (MutationCTE, DS.Seq PG.PrepArg),
    forall (b :: BackendType). Mutation b -> MutationOutput b
_mOutput :: MutationOutput b,
    forall (b :: BackendType). Mutation b -> [ColumnInfo b]
_mCols :: [ColumnInfo b],
    forall (b :: BackendType). Mutation b -> StringifyNumbers
_mStrfyNum :: Options.StringifyNumbers,
    forall (b :: BackendType). Mutation b -> Maybe NamingCase
_mNamingConvention :: Maybe NamingCase
  }

mkMutation ::
  UserInfo ->
  QualifiedTable ->
  (MutationCTE, DS.Seq PG.PrepArg) ->
  MutationOutput ('Postgres pgKind) ->
  [ColumnInfo ('Postgres pgKind)] ->
  Options.StringifyNumbers ->
  Maybe NamingCase ->
  Mutation ('Postgres pgKind)
mkMutation :: forall (pgKind :: PostgresKind).
UserInfo
-> QualifiedTable
-> (MutationCTE, Seq PrepArg)
-> MutationOutput ('Postgres pgKind)
-> [ColumnInfo ('Postgres pgKind)]
-> StringifyNumbers
-> Maybe NamingCase
-> Mutation ('Postgres pgKind)
mkMutation UserInfo
_userInfo QualifiedTable
table (MutationCTE, Seq PrepArg)
query MutationOutput ('Postgres pgKind)
output [ColumnInfo ('Postgres pgKind)]
allCols StringifyNumbers
strfyNum Maybe NamingCase
tCase =
  QualifiedTable
-> (MutationCTE, Seq PrepArg)
-> MutationOutput ('Postgres pgKind)
-> [ColumnInfo ('Postgres pgKind)]
-> StringifyNumbers
-> Maybe NamingCase
-> Mutation ('Postgres pgKind)
forall (b :: BackendType).
QualifiedTable
-> (MutationCTE, Seq PrepArg)
-> MutationOutput b
-> [ColumnInfo b]
-> StringifyNumbers
-> Maybe NamingCase
-> Mutation b
Mutation QualifiedTable
table (MutationCTE, Seq PrepArg)
query MutationOutput ('Postgres pgKind)
output [ColumnInfo ('Postgres pgKind)]
allCols StringifyNumbers
strfyNum Maybe NamingCase
tCase

runMutation ::
  ( MonadTx m,
    Backend ('Postgres pgKind),
    PostgresAnnotatedFieldJSON pgKind,
    MonadReader QueryTagsComment m
  ) =>
  Mutation ('Postgres pgKind) ->
  m EncJSON
runMutation :: forall (m :: * -> *) (pgKind :: PostgresKind).
(MonadTx m, Backend ('Postgres pgKind),
 PostgresAnnotatedFieldJSON pgKind,
 MonadReader QueryTagsComment m) =>
Mutation ('Postgres pgKind) -> m EncJSON
runMutation Mutation ('Postgres pgKind)
mut =
  m EncJSON -> m EncJSON -> Bool -> m EncJSON
forall a. a -> a -> Bool -> a
bool (Mutation ('Postgres pgKind) -> m EncJSON
forall (m :: * -> *) (pgKind :: PostgresKind).
(MonadTx m, Backend ('Postgres pgKind),
 PostgresAnnotatedFieldJSON pgKind,
 MonadReader QueryTagsComment m) =>
Mutation ('Postgres pgKind) -> m EncJSON
mutateAndReturn Mutation ('Postgres pgKind)
mut) (Mutation ('Postgres pgKind) -> m EncJSON
forall (pgKind :: PostgresKind) (m :: * -> *).
(MonadTx m, Backend ('Postgres pgKind),
 PostgresAnnotatedFieldJSON pgKind,
 MonadReader QueryTagsComment m) =>
Mutation ('Postgres pgKind) -> m EncJSON
mutateAndSel Mutation ('Postgres pgKind)
mut)
    (Bool -> m EncJSON) -> Bool -> m EncJSON
forall a b. (a -> b) -> a -> b
$ MutationOutputG ('Postgres pgKind) Void SQLExp -> Bool
forall (backend :: BackendType) r a.
MutationOutputG backend r a -> Bool
hasNestedFld
    (MutationOutputG ('Postgres pgKind) Void SQLExp -> Bool)
-> MutationOutputG ('Postgres pgKind) Void SQLExp -> Bool
forall a b. (a -> b) -> a -> b
$ Mutation ('Postgres pgKind) -> MutationOutput ('Postgres pgKind)
forall (b :: BackendType). Mutation b -> MutationOutput b
_mOutput Mutation ('Postgres pgKind)
mut

mutateAndReturn ::
  ( MonadTx m,
    Backend ('Postgres pgKind),
    PostgresAnnotatedFieldJSON pgKind,
    MonadReader QueryTagsComment m
  ) =>
  Mutation ('Postgres pgKind) ->
  m EncJSON
mutateAndReturn :: forall (m :: * -> *) (pgKind :: PostgresKind).
(MonadTx m, Backend ('Postgres pgKind),
 PostgresAnnotatedFieldJSON pgKind,
 MonadReader QueryTagsComment m) =>
Mutation ('Postgres pgKind) -> m EncJSON
mutateAndReturn (Mutation QualifiedTable
qt (MutationCTE
cte, Seq PrepArg
p) MutationOutput ('Postgres pgKind)
mutationOutput [ColumnInfo ('Postgres pgKind)]
allCols StringifyNumbers
strfyNum Maybe NamingCase
tCase) =
  QualifiedTable
-> [ColumnInfo ('Postgres pgKind)]
-> Maybe Int
-> MutationCTE
-> MutationOutput ('Postgres pgKind)
-> StringifyNumbers
-> Maybe NamingCase
-> [PrepArg]
-> m EncJSON
forall (pgKind :: PostgresKind) (m :: * -> *).
(MonadTx m, Backend ('Postgres pgKind),
 PostgresAnnotatedFieldJSON pgKind,
 MonadReader QueryTagsComment m) =>
QualifiedTable
-> [ColumnInfo ('Postgres pgKind)]
-> Maybe Int
-> MutationCTE
-> MutationOutput ('Postgres pgKind)
-> StringifyNumbers
-> Maybe NamingCase
-> [PrepArg]
-> m EncJSON
executeMutationOutputQuery QualifiedTable
qt [ColumnInfo ('Postgres pgKind)]
allCols Maybe Int
forall a. Maybe a
Nothing MutationCTE
cte MutationOutput ('Postgres pgKind)
mutationOutput StringifyNumbers
strfyNum Maybe NamingCase
tCase (Seq PrepArg -> [PrepArg]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq PrepArg
p)

execUpdateQuery ::
  forall pgKind m.
  ( MonadTx m,
    Backend ('Postgres pgKind),
    PostgresAnnotatedFieldJSON pgKind,
    MonadReader QueryTagsComment m
  ) =>
  Options.StringifyNumbers ->
  Maybe NamingCase ->
  UserInfo ->
  (AnnotatedUpdate ('Postgres pgKind), DS.Seq PG.PrepArg) ->
  m EncJSON
execUpdateQuery :: forall (pgKind :: PostgresKind) (m :: * -> *).
(MonadTx m, Backend ('Postgres pgKind),
 PostgresAnnotatedFieldJSON pgKind,
 MonadReader QueryTagsComment m) =>
StringifyNumbers
-> Maybe NamingCase
-> UserInfo
-> (AnnotatedUpdate ('Postgres pgKind), Seq PrepArg)
-> m EncJSON
execUpdateQuery StringifyNumbers
strfyNum Maybe NamingCase
tCase UserInfo
userInfo (AnnotatedUpdate ('Postgres pgKind)
u, Seq PrepArg
p) =
  case UpdateCTE
updateCTE of
    Update TopLevelCTE
singleUpdate -> TopLevelCTE -> m EncJSON
runCTE TopLevelCTE
singleUpdate
    MultiUpdate [TopLevelCTE]
ctes -> [EncJSON] -> EncJSON
encJFromList ([EncJSON] -> EncJSON) -> m [EncJSON] -> m EncJSON
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TopLevelCTE -> m EncJSON) -> [TopLevelCTE] -> m [EncJSON]
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) -> [a] -> f [b]
traverse TopLevelCTE -> m EncJSON
runCTE [TopLevelCTE]
ctes
  where
    updateCTE :: UpdateCTE
    updateCTE :: UpdateCTE
updateCTE = AnnotatedUpdate ('Postgres pgKind) -> UpdateCTE
forall (pgKind :: PostgresKind).
Backend ('Postgres pgKind) =>
AnnotatedUpdate ('Postgres pgKind) -> UpdateCTE
mkUpdateCTE AnnotatedUpdate ('Postgres pgKind)
u

    runCTE :: S.TopLevelCTE -> m EncJSON
    runCTE :: TopLevelCTE -> m EncJSON
runCTE TopLevelCTE
cte =
      Mutation ('Postgres pgKind) -> m EncJSON
forall (m :: * -> *) (pgKind :: PostgresKind).
(MonadTx m, Backend ('Postgres pgKind),
 PostgresAnnotatedFieldJSON pgKind,
 MonadReader QueryTagsComment m) =>
Mutation ('Postgres pgKind) -> m EncJSON
runMutation
        (UserInfo
-> QualifiedTable
-> (MutationCTE, Seq PrepArg)
-> MutationOutput ('Postgres pgKind)
-> [ColumnInfo ('Postgres pgKind)]
-> StringifyNumbers
-> Maybe NamingCase
-> Mutation ('Postgres pgKind)
forall (pgKind :: PostgresKind).
UserInfo
-> QualifiedTable
-> (MutationCTE, Seq PrepArg)
-> MutationOutput ('Postgres pgKind)
-> [ColumnInfo ('Postgres pgKind)]
-> StringifyNumbers
-> Maybe NamingCase
-> Mutation ('Postgres pgKind)
mkMutation UserInfo
userInfo (AnnotatedUpdateG ('Postgres pgKind) Void SQLExp
-> TableName ('Postgres pgKind)
forall (b :: BackendType) r v.
AnnotatedUpdateG b r v -> TableName b
_auTable AnnotatedUpdate ('Postgres pgKind)
AnnotatedUpdateG ('Postgres pgKind) Void SQLExp
u) (TopLevelCTE -> MutationCTE
MCCheckConstraint TopLevelCTE
cte, Seq PrepArg
p) (AnnotatedUpdateG ('Postgres pgKind) Void SQLExp
-> MutationOutputG ('Postgres pgKind) Void SQLExp
forall (b :: BackendType) r v.
AnnotatedUpdateG b r v -> MutationOutputG b r v
_auOutput AnnotatedUpdate ('Postgres pgKind)
AnnotatedUpdateG ('Postgres pgKind) Void SQLExp
u) (AnnotatedUpdateG ('Postgres pgKind) Void SQLExp
-> [ColumnInfo ('Postgres pgKind)]
forall (b :: BackendType) r v.
AnnotatedUpdateG b r v -> [ColumnInfo b]
_auAllCols AnnotatedUpdate ('Postgres pgKind)
AnnotatedUpdateG ('Postgres pgKind) Void SQLExp
u) StringifyNumbers
strfyNum Maybe NamingCase
tCase)

execDeleteQuery ::
  forall pgKind m.
  ( MonadTx m,
    Backend ('Postgres pgKind),
    PostgresAnnotatedFieldJSON pgKind,
    MonadReader QueryTagsComment m
  ) =>
  Options.StringifyNumbers ->
  Maybe NamingCase ->
  UserInfo ->
  (AnnDel ('Postgres pgKind), DS.Seq PG.PrepArg) ->
  m EncJSON
execDeleteQuery :: forall (pgKind :: PostgresKind) (m :: * -> *).
(MonadTx m, Backend ('Postgres pgKind),
 PostgresAnnotatedFieldJSON pgKind,
 MonadReader QueryTagsComment m) =>
StringifyNumbers
-> Maybe NamingCase
-> UserInfo
-> (AnnDel ('Postgres pgKind), Seq PrepArg)
-> m EncJSON
execDeleteQuery StringifyNumbers
strfyNum Maybe NamingCase
tCase UserInfo
userInfo (AnnDel ('Postgres pgKind)
u, Seq PrepArg
p) =
  Mutation ('Postgres pgKind) -> m EncJSON
forall (m :: * -> *) (pgKind :: PostgresKind).
(MonadTx m, Backend ('Postgres pgKind),
 PostgresAnnotatedFieldJSON pgKind,
 MonadReader QueryTagsComment m) =>
Mutation ('Postgres pgKind) -> m EncJSON
runMutation
    (UserInfo
-> QualifiedTable
-> (MutationCTE, Seq PrepArg)
-> MutationOutput ('Postgres pgKind)
-> [ColumnInfo ('Postgres pgKind)]
-> StringifyNumbers
-> Maybe NamingCase
-> Mutation ('Postgres pgKind)
forall (pgKind :: PostgresKind).
UserInfo
-> QualifiedTable
-> (MutationCTE, Seq PrepArg)
-> MutationOutput ('Postgres pgKind)
-> [ColumnInfo ('Postgres pgKind)]
-> StringifyNumbers
-> Maybe NamingCase
-> Mutation ('Postgres pgKind)
mkMutation UserInfo
userInfo (AnnDelG ('Postgres pgKind) Void SQLExp
-> TableName ('Postgres pgKind)
forall (b :: BackendType) r v. AnnDelG b r v -> TableName b
_adTable AnnDel ('Postgres pgKind)
AnnDelG ('Postgres pgKind) Void SQLExp
u) (SQLDelete -> MutationCTE
MCDelete SQLDelete
delete, Seq PrepArg
p) (AnnDelG ('Postgres pgKind) Void SQLExp
-> MutationOutputG ('Postgres pgKind) Void SQLExp
forall (b :: BackendType) r v.
AnnDelG b r v -> MutationOutputG b r v
_adOutput AnnDel ('Postgres pgKind)
AnnDelG ('Postgres pgKind) Void SQLExp
u) (AnnDelG ('Postgres pgKind) Void SQLExp
-> [ColumnInfo ('Postgres pgKind)]
forall (b :: BackendType) r v. AnnDelG b r v -> [ColumnInfo b]
_adAllCols AnnDel ('Postgres pgKind)
AnnDelG ('Postgres pgKind) Void SQLExp
u) StringifyNumbers
strfyNum Maybe NamingCase
tCase)
  where
    delete :: SQLDelete
delete = AnnDel ('Postgres pgKind) -> SQLDelete
forall (pgKind :: PostgresKind).
Backend ('Postgres pgKind) =>
AnnDel ('Postgres pgKind) -> SQLDelete
mkDelete AnnDel ('Postgres pgKind)
u

execInsertQuery ::
  ( MonadTx m,
    Backend ('Postgres pgKind),
    PostgresAnnotatedFieldJSON pgKind,
    MonadReader QueryTagsComment m
  ) =>
  Options.StringifyNumbers ->
  Maybe NamingCase ->
  UserInfo ->
  (InsertQueryP1 ('Postgres pgKind), DS.Seq PG.PrepArg) ->
  m EncJSON
execInsertQuery :: forall (m :: * -> *) (pgKind :: PostgresKind).
(MonadTx m, Backend ('Postgres pgKind),
 PostgresAnnotatedFieldJSON pgKind,
 MonadReader QueryTagsComment m) =>
StringifyNumbers
-> Maybe NamingCase
-> UserInfo
-> (InsertQueryP1 ('Postgres pgKind), Seq PrepArg)
-> m EncJSON
execInsertQuery StringifyNumbers
strfyNum Maybe NamingCase
tCase UserInfo
userInfo (InsertQueryP1 ('Postgres pgKind)
u, Seq PrepArg
p) =
  Mutation ('Postgres pgKind) -> m EncJSON
forall (m :: * -> *) (pgKind :: PostgresKind).
(MonadTx m, Backend ('Postgres pgKind),
 PostgresAnnotatedFieldJSON pgKind,
 MonadReader QueryTagsComment m) =>
Mutation ('Postgres pgKind) -> m EncJSON
runMutation
    (UserInfo
-> QualifiedTable
-> (MutationCTE, Seq PrepArg)
-> MutationOutput ('Postgres pgKind)
-> [ColumnInfo ('Postgres pgKind)]
-> StringifyNumbers
-> Maybe NamingCase
-> Mutation ('Postgres pgKind)
forall (pgKind :: PostgresKind).
UserInfo
-> QualifiedTable
-> (MutationCTE, Seq PrepArg)
-> MutationOutput ('Postgres pgKind)
-> [ColumnInfo ('Postgres pgKind)]
-> StringifyNumbers
-> Maybe NamingCase
-> Mutation ('Postgres pgKind)
mkMutation UserInfo
userInfo (InsertQueryP1 ('Postgres pgKind) -> TableName ('Postgres pgKind)
forall (b :: BackendType). InsertQueryP1 b -> TableName b
iqp1Table InsertQueryP1 ('Postgres pgKind)
u) (TopLevelCTE -> MutationCTE
MCCheckConstraint TopLevelCTE
insertCTE, Seq PrepArg
p) (InsertQueryP1 ('Postgres pgKind)
-> MutationOutput ('Postgres pgKind)
forall (b :: BackendType). InsertQueryP1 b -> MutationOutput b
iqp1Output InsertQueryP1 ('Postgres pgKind)
u) (InsertQueryP1 ('Postgres pgKind) -> [ColumnInfo ('Postgres pgKind)]
forall (b :: BackendType). InsertQueryP1 b -> [ColumnInfo b]
iqp1AllCols InsertQueryP1 ('Postgres pgKind)
u) StringifyNumbers
strfyNum Maybe NamingCase
tCase)
  where
    insertCTE :: TopLevelCTE
insertCTE = InsertQueryP1 ('Postgres pgKind) -> TopLevelCTE
forall (pgKind :: PostgresKind).
Backend ('Postgres pgKind) =>
InsertQueryP1 ('Postgres pgKind) -> TopLevelCTE
mkInsertCTE InsertQueryP1 ('Postgres pgKind)
u

{- Note: [Prepared statements in Mutations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The SQL statements we generate for mutations seem to include the actual values
in the statements in some cases which pretty much makes them unfit for reuse
(Handling relationships in the returning clause is the source of this
complexity). Further, `PGConn` has an internal cache which maps a statement to
a 'prepared statement id' on Postgres. As we prepare more and more single-use
SQL statements we end up leaking memory both on graphql-engine and Postgres
till the connection is closed. So a simpler but very crude fix is to not use
prepared statements for mutations. The performance of insert mutations
shouldn't be affected but updates and delete mutations with complex boolean
conditions **might** see some degradation.
-}

mutateAndSel ::
  forall pgKind m.
  ( MonadTx m,
    Backend ('Postgres pgKind),
    PostgresAnnotatedFieldJSON pgKind,
    MonadReader QueryTagsComment m
  ) =>
  Mutation ('Postgres pgKind) ->
  m EncJSON
mutateAndSel :: forall (pgKind :: PostgresKind) (m :: * -> *).
(MonadTx m, Backend ('Postgres pgKind),
 PostgresAnnotatedFieldJSON pgKind,
 MonadReader QueryTagsComment m) =>
Mutation ('Postgres pgKind) -> m EncJSON
mutateAndSel (Mutation QualifiedTable
qt (MutationCTE, Seq PrepArg)
q MutationOutput ('Postgres pgKind)
mutationOutput [ColumnInfo ('Postgres pgKind)]
allCols StringifyNumbers
strfyNum Maybe NamingCase
tCase) = do
  -- Perform mutation and fetch unique columns
  MutateResp Int
_ [ColumnValues ('Postgres pgKind) TxtEncodedVal]
columnVals <- TxE QErr (MutateResp ('Postgres pgKind) TxtEncodedVal)
-> m (MutateResp ('Postgres pgKind) TxtEncodedVal)
forall a. TxE QErr a -> m a
forall (m :: * -> *) a. MonadTx m => TxE QErr a -> m a
liftTx (TxE QErr (MutateResp ('Postgres pgKind) TxtEncodedVal)
 -> m (MutateResp ('Postgres pgKind) TxtEncodedVal))
-> TxE QErr (MutateResp ('Postgres pgKind) TxtEncodedVal)
-> m (MutateResp ('Postgres pgKind) TxtEncodedVal)
forall a b. (a -> b) -> a -> b
$ QualifiedTable
-> [ColumnInfo ('Postgres pgKind)]
-> (MutationCTE, Seq PrepArg)
-> StringifyNumbers
-> Maybe NamingCase
-> TxE QErr (MutateResp ('Postgres pgKind) TxtEncodedVal)
forall (pgKind :: PostgresKind).
(Backend ('Postgres pgKind), PostgresAnnotatedFieldJSON pgKind) =>
QualifiedTable
-> [ColumnInfo ('Postgres pgKind)]
-> (MutationCTE, Seq PrepArg)
-> StringifyNumbers
-> Maybe NamingCase
-> TxE QErr (MutateResp ('Postgres pgKind) TxtEncodedVal)
mutateAndFetchCols QualifiedTable
qt [ColumnInfo ('Postgres pgKind)]
allCols (MutationCTE, Seq PrepArg)
q StringifyNumbers
strfyNum Maybe NamingCase
tCase
  Select
select <- QualifiedTable
-> [ColumnInfo ('Postgres pgKind)]
-> [ColumnValues ('Postgres pgKind) TxtEncodedVal]
-> m Select
forall (pgKind :: PostgresKind) (m :: * -> *).
MonadError QErr m =>
QualifiedTable
-> [ColumnInfo ('Postgres pgKind)]
-> [ColumnValues ('Postgres pgKind) TxtEncodedVal]
-> m Select
mkSelectExpFromColumnValues QualifiedTable
qt [ColumnInfo ('Postgres pgKind)]
allCols [ColumnValues ('Postgres pgKind) TxtEncodedVal]
columnVals
  -- Perform select query and fetch returning fields
  QualifiedTable
-> [ColumnInfo ('Postgres pgKind)]
-> Maybe Int
-> MutationCTE
-> MutationOutput ('Postgres pgKind)
-> StringifyNumbers
-> Maybe NamingCase
-> [PrepArg]
-> m EncJSON
forall (pgKind :: PostgresKind) (m :: * -> *).
(MonadTx m, Backend ('Postgres pgKind),
 PostgresAnnotatedFieldJSON pgKind,
 MonadReader QueryTagsComment m) =>
QualifiedTable
-> [ColumnInfo ('Postgres pgKind)]
-> Maybe Int
-> MutationCTE
-> MutationOutput ('Postgres pgKind)
-> StringifyNumbers
-> Maybe NamingCase
-> [PrepArg]
-> m EncJSON
executeMutationOutputQuery
    QualifiedTable
qt
    [ColumnInfo ('Postgres pgKind)]
allCols
    Maybe Int
forall a. Maybe a
Nothing
    (Select -> MutationCTE
MCSelectValues Select
select)
    MutationOutput ('Postgres pgKind)
mutationOutput
    StringifyNumbers
strfyNum
    Maybe NamingCase
tCase
    []

withCheckPermission :: (MonadError QErr m) => m (a, Bool) -> m a
withCheckPermission :: forall (m :: * -> *) a. MonadError QErr m => m (a, Bool) -> m a
withCheckPermission m (a, Bool)
sqlTx = do
  (a
rawResponse, Bool
checkConstraint) <- m (a, Bool)
sqlTx
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
checkConstraint
    (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Code -> Text -> m ()
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
PermissionError
    (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"check constraint of an insert/update permission has failed"
  a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
rawResponse

executeMutationOutputQuery ::
  forall pgKind m.
  ( MonadTx m,
    Backend ('Postgres pgKind),
    PostgresAnnotatedFieldJSON pgKind,
    MonadReader QueryTagsComment m
  ) =>
  QualifiedTable ->
  [ColumnInfo ('Postgres pgKind)] ->
  Maybe Int ->
  MutationCTE ->
  MutationOutput ('Postgres pgKind) ->
  Options.StringifyNumbers ->
  Maybe NamingCase ->
  -- | Prepared params
  [PG.PrepArg] ->
  m EncJSON
executeMutationOutputQuery :: forall (pgKind :: PostgresKind) (m :: * -> *).
(MonadTx m, Backend ('Postgres pgKind),
 PostgresAnnotatedFieldJSON pgKind,
 MonadReader QueryTagsComment m) =>
QualifiedTable
-> [ColumnInfo ('Postgres pgKind)]
-> Maybe Int
-> MutationCTE
-> MutationOutput ('Postgres pgKind)
-> StringifyNumbers
-> Maybe NamingCase
-> [PrepArg]
-> m EncJSON
executeMutationOutputQuery QualifiedTable
qt [ColumnInfo ('Postgres pgKind)]
allCols Maybe Int
preCalAffRows MutationCTE
cte MutationOutput ('Postgres pgKind)
mutOutput StringifyNumbers
strfyNum Maybe NamingCase
tCase [PrepArg]
prepArgs = do
  QueryTagsComment
queryTags <- m QueryTagsComment
forall r (m :: * -> *). MonadReader r m => m r
ask
  let queryTx :: (PG.FromRes a) => m a
      queryTx :: forall a. FromRes a => m a
queryTx = do
        let selectWith :: SelectWith
selectWith = QualifiedTable
-> [ColumnInfo ('Postgres pgKind)]
-> Maybe Int
-> MutationCTE
-> MutationOutput ('Postgres pgKind)
-> StringifyNumbers
-> Maybe NamingCase
-> SelectWith
forall (pgKind :: PostgresKind).
(Backend ('Postgres pgKind), PostgresAnnotatedFieldJSON pgKind) =>
QualifiedTable
-> [ColumnInfo ('Postgres pgKind)]
-> Maybe Int
-> MutationCTE
-> MutationOutput ('Postgres pgKind)
-> StringifyNumbers
-> Maybe NamingCase
-> SelectWith
mkMutationOutputExp QualifiedTable
qt [ColumnInfo ('Postgres pgKind)]
allCols Maybe Int
preCalAffRows MutationCTE
cte MutationOutput ('Postgres pgKind)
mutOutput StringifyNumbers
strfyNum Maybe NamingCase
tCase
            query :: Query
query = SelectWith -> Query
toQuery SelectWith
selectWith
            queryWithQueryTags :: Query
queryWithQueryTags = Query
query {getQueryText :: Text
PG.getQueryText = (Query -> Text
PG.getQueryText Query
query) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (QueryTagsComment -> Text
_unQueryTagsComment QueryTagsComment
queryTags)}
        -- See Note [Prepared statements in Mutations]
        TxE QErr a -> m a
forall a. TxE QErr a -> m a
forall (m :: * -> *) a. MonadTx m => TxE QErr a -> m a
liftTx ((PGTxErr -> QErr) -> Query -> [PrepArg] -> Bool -> TxE QErr a
forall (m :: * -> *) a e.
(MonadIO m, FromRes a) =>
(PGTxErr -> e) -> Query -> [PrepArg] -> Bool -> TxET e m a
PG.rawQE PGTxErr -> QErr
dmlTxErrorHandler Query
queryWithQueryTags [PrepArg]
prepArgs Bool
False)

  if MutationCTE -> Bool
checkPermissionRequired MutationCTE
cte
    then m (EncJSON, Bool) -> m EncJSON
forall (m :: * -> *) a. MonadError QErr m => m (a, Bool) -> m a
withCheckPermission (m (EncJSON, Bool) -> m EncJSON) -> m (EncJSON, Bool) -> m EncJSON
forall a b. (a -> b) -> a -> b
$ SingleRow (EncJSON, Bool) -> (EncJSON, Bool)
forall a. SingleRow a -> a
PG.getRow (SingleRow (EncJSON, Bool) -> (EncJSON, Bool))
-> m (SingleRow (EncJSON, Bool)) -> m (EncJSON, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (SingleRow (EncJSON, Bool))
forall a. FromRes a => m a
queryTx
    else 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)
-> m (SingleRow (Identity EncJSON)) -> m EncJSON
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (SingleRow (Identity EncJSON))
forall a. FromRes a => m a
queryTx

mutateAndFetchCols ::
  forall pgKind.
  (Backend ('Postgres pgKind), PostgresAnnotatedFieldJSON pgKind) =>
  QualifiedTable ->
  [ColumnInfo ('Postgres pgKind)] ->
  (MutationCTE, DS.Seq PG.PrepArg) ->
  Options.StringifyNumbers ->
  Maybe NamingCase ->
  PG.TxE QErr (MutateResp ('Postgres pgKind) TxtEncodedVal)
mutateAndFetchCols :: forall (pgKind :: PostgresKind).
(Backend ('Postgres pgKind), PostgresAnnotatedFieldJSON pgKind) =>
QualifiedTable
-> [ColumnInfo ('Postgres pgKind)]
-> (MutationCTE, Seq PrepArg)
-> StringifyNumbers
-> Maybe NamingCase
-> TxE QErr (MutateResp ('Postgres pgKind) TxtEncodedVal)
mutateAndFetchCols QualifiedTable
qt [ColumnInfo ('Postgres pgKind)]
cols (MutationCTE
cte, Seq PrepArg
p) StringifyNumbers
strfyNum Maybe NamingCase
tCase = do
  let mutationTx :: (PG.FromRes a) => PG.TxE QErr a
      mutationTx :: forall a. FromRes a => TxE QErr a
mutationTx =
        -- See Note [Prepared statements in Mutations]
        (PGTxErr -> QErr) -> Query -> [PrepArg] -> Bool -> TxET QErr IO a
forall (m :: * -> *) a e.
(MonadIO m, FromRes a) =>
(PGTxErr -> e) -> Query -> [PrepArg] -> Bool -> TxET e m a
PG.rawQE PGTxErr -> QErr
dmlTxErrorHandler Query
sqlText (Seq PrepArg -> [PrepArg]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq PrepArg
p) Bool
False

  if MutationCTE -> Bool
checkPermissionRequired MutationCTE
cte
    then TxET QErr IO (MutateResp ('Postgres pgKind) TxtEncodedVal, Bool)
-> TxE QErr (MutateResp ('Postgres pgKind) TxtEncodedVal)
forall (m :: * -> *) a. MonadError QErr m => m (a, Bool) -> m a
withCheckPermission (TxET QErr IO (MutateResp ('Postgres pgKind) TxtEncodedVal, Bool)
 -> TxE QErr (MutateResp ('Postgres pgKind) TxtEncodedVal))
-> TxET QErr IO (MutateResp ('Postgres pgKind) TxtEncodedVal, Bool)
-> TxE QErr (MutateResp ('Postgres pgKind) TxtEncodedVal)
forall a b. (a -> b) -> a -> b
$ ((ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal)
 -> MutateResp ('Postgres pgKind) TxtEncodedVal)
-> (ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal), Bool)
-> (MutateResp ('Postgres pgKind) TxtEncodedVal, Bool)
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 ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal)
-> MutateResp ('Postgres pgKind) TxtEncodedVal
forall a. ViaJSON a -> a
PG.getViaJSON ((ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal), Bool)
 -> (MutateResp ('Postgres pgKind) TxtEncodedVal, Bool))
-> (SingleRow
      (ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal), Bool)
    -> (ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal), Bool))
-> SingleRow
     (ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal), Bool)
-> (MutateResp ('Postgres pgKind) TxtEncodedVal, Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SingleRow
  (ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal), Bool)
-> (ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal), Bool)
forall a. SingleRow a -> a
PG.getRow) (SingleRow
   (ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal), Bool)
 -> (MutateResp ('Postgres pgKind) TxtEncodedVal, Bool))
-> TxET
     QErr
     IO
     (SingleRow
        (ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal), Bool))
-> TxET QErr IO (MutateResp ('Postgres pgKind) TxtEncodedVal, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxET
  QErr
  IO
  (SingleRow
     (ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal), Bool))
forall a. FromRes a => TxE QErr a
mutationTx
    else (ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal)
-> MutateResp ('Postgres pgKind) TxtEncodedVal
forall a. ViaJSON a -> a
PG.getViaJSON (ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal)
 -> MutateResp ('Postgres pgKind) TxtEncodedVal)
-> (SingleRow
      (Identity (ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal)))
    -> ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal))
-> SingleRow
     (Identity (ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal)))
-> MutateResp ('Postgres pgKind) TxtEncodedVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal))
-> ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal)
forall a. Identity a -> a
runIdentity (Identity (ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal))
 -> ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal))
-> (SingleRow
      (Identity (ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal)))
    -> Identity
         (ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal)))
-> SingleRow
     (Identity (ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal)))
-> ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SingleRow
  (Identity (ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal)))
-> Identity (ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal))
forall a. SingleRow a -> a
PG.getRow) (SingleRow
   (Identity (ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal)))
 -> MutateResp ('Postgres pgKind) TxtEncodedVal)
-> TxET
     QErr
     IO
     (SingleRow
        (Identity (ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal))))
-> TxE QErr (MutateResp ('Postgres pgKind) TxtEncodedVal)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxET
  QErr
  IO
  (SingleRow
     (Identity (ViaJSON (MutateResp ('Postgres pgKind) TxtEncodedVal))))
forall a. FromRes a => TxE QErr a
mutationTx
  where
    rawAlias :: TableAlias
rawAlias = Text -> TableAlias
S.mkTableAlias (Text -> TableAlias) -> Text -> TableAlias
forall a b. (a -> b) -> a -> b
$ Text
"mutres__" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> QualifiedTable -> Text
forall a. ToTxt a => QualifiedObject a -> Text
qualifiedObjectToText QualifiedTable
qt
    rawIdentifier :: TableIdentifier
rawIdentifier = TableAlias -> TableIdentifier
S.tableAliasToIdentifier TableAlias
rawAlias
    tabFrom :: SelectFromG ('Postgres pgKind) SQLExp
tabFrom = FIIdentifier -> SelectFromG ('Postgres pgKind) SQLExp
forall (b :: BackendType) v. FIIdentifier -> SelectFromG b v
FromIdentifier (FIIdentifier -> SelectFromG ('Postgres pgKind) SQLExp)
-> FIIdentifier -> SelectFromG ('Postgres pgKind) SQLExp
forall a b. (a -> b) -> a -> b
$ Text -> FIIdentifier
FIIdentifier (TableIdentifier -> Text
unTableIdentifier TableIdentifier
rawIdentifier)
    tabPerm :: TablePermG b v
tabPerm = AnnBoolExp b v -> Maybe Int -> TablePermG b v
forall (b :: BackendType) v.
AnnBoolExp b v -> Maybe Int -> TablePermG b v
TablePerm AnnBoolExp b v
forall (backend :: BackendType) scalar. AnnBoolExp backend scalar
annBoolExpTrue Maybe Int
forall a. Maybe a
Nothing
    selFlds :: [(FieldName, AnnFieldG ('Postgres pgKind) Void SQLExp)]
selFlds = ((ColumnInfo ('Postgres pgKind)
  -> (FieldName, AnnFieldG ('Postgres pgKind) Void SQLExp))
 -> [ColumnInfo ('Postgres pgKind)]
 -> [(FieldName, AnnFieldG ('Postgres pgKind) Void SQLExp)])
-> [ColumnInfo ('Postgres pgKind)]
-> (ColumnInfo ('Postgres pgKind)
    -> (FieldName, AnnFieldG ('Postgres pgKind) Void SQLExp))
-> [(FieldName, AnnFieldG ('Postgres pgKind) Void SQLExp)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ColumnInfo ('Postgres pgKind)
 -> (FieldName, AnnFieldG ('Postgres pgKind) Void SQLExp))
-> [ColumnInfo ('Postgres pgKind)]
-> [(FieldName, AnnFieldG ('Postgres pgKind) Void SQLExp)]
forall a b. (a -> b) -> [a] -> [b]
map [ColumnInfo ('Postgres pgKind)]
cols
      ((ColumnInfo ('Postgres pgKind)
  -> (FieldName, AnnFieldG ('Postgres pgKind) Void SQLExp))
 -> [(FieldName, AnnFieldG ('Postgres pgKind) Void SQLExp)])
-> (ColumnInfo ('Postgres pgKind)
    -> (FieldName, AnnFieldG ('Postgres pgKind) Void SQLExp))
-> [(FieldName, AnnFieldG ('Postgres pgKind) Void SQLExp)]
forall a b. (a -> b) -> a -> b
$ \ColumnInfo ('Postgres pgKind)
ci -> (forall (b :: BackendType). Backend b => Column b -> FieldName
fromCol @('Postgres pgKind) (Column ('Postgres pgKind) -> FieldName)
-> Column ('Postgres pgKind) -> FieldName
forall a b. (a -> b) -> a -> b
$ ColumnInfo ('Postgres pgKind) -> Column ('Postgres pgKind)
forall (b :: BackendType). ColumnInfo b -> Column b
ciColumn ColumnInfo ('Postgres pgKind)
ci, ColumnInfo ('Postgres pgKind)
-> AnnFieldG ('Postgres pgKind) Void SQLExp
forall (backend :: BackendType) r v.
ColumnInfo backend -> AnnFieldG backend r v
mkAnnColumnFieldAsText ColumnInfo ('Postgres pgKind)
ci)

    sqlText :: Query
sqlText = SelectWith -> Query
toQuery SelectWith
selectWith

    select :: Select
select =
      Select
S.mkSelect
        { selExtr :: [Extractor]
S.selExtr =
            SQLExp -> Maybe ColumnAlias -> Extractor
S.Extractor SQLExp
extrExp Maybe ColumnAlias
forall a. Maybe a
Nothing
              Extractor -> [Extractor] -> [Extractor]
forall a. a -> [a] -> [a]
: [Extractor] -> [Extractor] -> Bool -> [Extractor]
forall a. a -> a -> Bool -> a
bool [] [SQLExp -> Maybe ColumnAlias -> Extractor
S.Extractor SQLExp
checkErrExp Maybe ColumnAlias
forall a. Maybe a
Nothing] (MutationCTE -> Bool
checkPermissionRequired MutationCTE
cte)
        }

    selectWith :: SelectWith
selectWith =
      [(TableAlias, TopLevelCTE)] -> Select -> SelectWith
forall statement.
[(TableAlias, statement)] -> Select -> SelectWithG statement
S.SelectWith
        ( [(TableAlias
rawAlias, MutationCTE -> TopLevelCTE
getMutationCTE MutationCTE
cte)]
            [(TableAlias, TopLevelCTE)]
-> [(TableAlias, TopLevelCTE)] -> [(TableAlias, TopLevelCTE)]
forall a. Semigroup a => a -> a -> a
<> CustomSQLCTEs -> [(TableAlias, TopLevelCTE)]
customSQLToTopLevelCTEs CustomSQLCTEs
customSQLCTEs
        )
        Select
select

    checkErrExp :: SQLExp
checkErrExp = TableIdentifier -> SQLExp
mkCheckErrorExp TableIdentifier
rawIdentifier
    extrExp :: SQLExp
extrExp =
      [SQLExp] -> SQLExp
S.applyJsonBuildObj
        [ Text -> SQLExp
S.SELit Text
"affected_rows",
          SQLExp
affRowsSel,
          Text -> SQLExp
S.SELit Text
"returning_columns",
          SQLExp
colSel
        ]

    affRowsSel :: SQLExp
affRowsSel =
      Select -> SQLExp
S.SESelect
        (Select -> SQLExp) -> Select -> SQLExp
forall a b. (a -> b) -> a -> b
$ Select
S.mkSelect
          { selExtr :: [Extractor]
S.selExtr = [SQLExp -> Maybe ColumnAlias -> Extractor
S.Extractor SQLExp
S.countStar Maybe ColumnAlias
forall a. Maybe a
Nothing],
            selFrom :: Maybe FromExp
S.selFrom = FromExp -> Maybe FromExp
forall a. a -> Maybe a
Just (FromExp -> Maybe FromExp) -> FromExp -> Maybe FromExp
forall a b. (a -> b) -> a -> b
$ [FromItem] -> FromExp
S.FromExp [TableIdentifier -> FromItem
S.FIIdentifier TableIdentifier
rawIdentifier]
          }

    (SQLExp
colSel, CustomSQLCTEs
customSQLCTEs) =
      Writer CustomSQLCTEs SQLExp -> (SQLExp, CustomSQLCTEs)
forall w a. Writer w a -> (a, w)
runWriter
        (Writer CustomSQLCTEs SQLExp -> (SQLExp, CustomSQLCTEs))
-> Writer CustomSQLCTEs SQLExp -> (SQLExp, CustomSQLCTEs)
forall a b. (a -> b) -> a -> b
$ Select -> SQLExp
S.SESelect
        (Select -> SQLExp)
-> WriterT CustomSQLCTEs Identity Select
-> Writer CustomSQLCTEs SQLExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JsonAggSelect
-> AnnSimpleSelect ('Postgres pgKind)
-> WriterT CustomSQLCTEs Identity Select
forall (pgKind :: PostgresKind) (m :: * -> *).
(Backend ('Postgres pgKind), PostgresAnnotatedFieldJSON pgKind,
 MonadWriter CustomSQLCTEs m) =>
JsonAggSelect -> AnnSimpleSelect ('Postgres pgKind) -> m Select
mkSQLSelect
          JsonAggSelect
JASMultipleRows
          ( [(FieldName, AnnFieldG ('Postgres pgKind) Void SQLExp)]
-> SelectFromG ('Postgres pgKind) SQLExp
-> TablePermG ('Postgres pgKind) SQLExp
-> SelectArgsG ('Postgres pgKind) SQLExp
-> StringifyNumbers
-> Maybe NamingCase
-> AnnSelectG
     ('Postgres pgKind) (AnnFieldG ('Postgres pgKind) Void) SQLExp
forall (b :: BackendType) (f :: * -> *) v.
Fields (f v)
-> SelectFromG b v
-> TablePermG b v
-> SelectArgsG b v
-> StringifyNumbers
-> Maybe NamingCase
-> AnnSelectG b f v
AnnSelectG [(FieldName, AnnFieldG ('Postgres pgKind) Void SQLExp)]
selFlds SelectFromG ('Postgres pgKind) SQLExp
tabFrom TablePermG ('Postgres pgKind) SQLExp
forall {b :: BackendType} {v}. TablePermG b v
tabPerm SelectArgsG ('Postgres pgKind) SQLExp
forall (backend :: BackendType) v. SelectArgsG backend v
noSelectArgs StringifyNumbers
strfyNum Maybe NamingCase
tCase
          )

-------------- Validating insert input using external HTTP webhook -----------------------
type ValidateInputPayloadVersion = Int

validateInputPayloadVersion :: ValidateInputPayloadVersion
validateInputPayloadVersion :: Int
validateInputPayloadVersion = Int
1

newtype ValidateInputErrorResponse = ValidateInputErrorResponse {ValidateInputErrorResponse -> Text
_vierMessage :: Text}
  deriving (Int -> ValidateInputErrorResponse -> ShowS
[ValidateInputErrorResponse] -> ShowS
ValidateInputErrorResponse -> String
(Int -> ValidateInputErrorResponse -> ShowS)
-> (ValidateInputErrorResponse -> String)
-> ([ValidateInputErrorResponse] -> ShowS)
-> Show ValidateInputErrorResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValidateInputErrorResponse -> ShowS
showsPrec :: Int -> ValidateInputErrorResponse -> ShowS
$cshow :: ValidateInputErrorResponse -> String
show :: ValidateInputErrorResponse -> String
$cshowList :: [ValidateInputErrorResponse] -> ShowS
showList :: [ValidateInputErrorResponse] -> ShowS
Show, ValidateInputErrorResponse -> ValidateInputErrorResponse -> Bool
(ValidateInputErrorResponse -> ValidateInputErrorResponse -> Bool)
-> (ValidateInputErrorResponse
    -> ValidateInputErrorResponse -> Bool)
-> Eq ValidateInputErrorResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ValidateInputErrorResponse -> ValidateInputErrorResponse -> Bool
== :: ValidateInputErrorResponse -> ValidateInputErrorResponse -> Bool
$c/= :: ValidateInputErrorResponse -> ValidateInputErrorResponse -> Bool
/= :: ValidateInputErrorResponse -> ValidateInputErrorResponse -> Bool
Eq)

$(J.deriveJSON hasuraJSON ''ValidateInputErrorResponse)

data HttpHandlerLog = HttpHandlerLog
  { HttpHandlerLog -> Text
_hhlUrl :: Text,
    HttpHandlerLog -> Value
_hhlRequest :: J.Value,
    HttpHandlerLog -> [HeaderConf]
_hhlRequestHeaders :: [HeaderConf],
    HttpHandlerLog -> Value
_hhlResponse :: J.Value,
    HttpHandlerLog -> Int
_hhlResponseStatus :: Int
  }
  deriving (Int -> HttpHandlerLog -> ShowS
[HttpHandlerLog] -> ShowS
HttpHandlerLog -> String
(Int -> HttpHandlerLog -> ShowS)
-> (HttpHandlerLog -> String)
-> ([HttpHandlerLog] -> ShowS)
-> Show HttpHandlerLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HttpHandlerLog -> ShowS
showsPrec :: Int -> HttpHandlerLog -> ShowS
$cshow :: HttpHandlerLog -> String
show :: HttpHandlerLog -> String
$cshowList :: [HttpHandlerLog] -> ShowS
showList :: [HttpHandlerLog] -> ShowS
Show)

$(J.deriveToJSON hasuraJSON ''HttpHandlerLog)

data ValidateInsertInputLog
  = VIILHttpHandler HttpHandlerLog

instance J.ToJSON ValidateInsertInputLog where
  toJSON :: ValidateInsertInputLog -> Value
toJSON (VIILHttpHandler HttpHandlerLog
httpHandlerLog) =
    [Pair] -> Value
J.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [Key
"type" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= (String
"http" :: String), Key
"details" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= HttpHandlerLog -> Value
forall a. ToJSON a => a -> Value
J.toJSON HttpHandlerLog
httpHandlerLog]

instance L.ToEngineLog ValidateInsertInputLog L.Hasura where
  toEngineLog :: ValidateInsertInputLog -> (LogLevel, EngineLogType Hasura, Value)
toEngineLog ValidateInsertInputLog
ahl = (LogLevel
L.LevelInfo, EngineLogType Hasura
L.ELTValidateInputLog, ValidateInsertInputLog -> Value
forall a. ToJSON a => a -> Value
J.toJSON ValidateInsertInputLog
ahl)

-- | Map of table name and the value that is being inserted for that table
-- This map is helpful for collecting all the insert mutation arguments for the
-- nested tables and then sending them all at onve to the input validation webhook.
type InsertValidationPayloadMap pgKind = InsOrdHashMap.InsOrdHashMap (TableName ('Postgres pgKind)) ([IR.AnnotatedInsertRow ('Postgres pgKind) (IR.UnpreparedValue ('Postgres pgKind))], (ValidateInput ResolvedWebhook))

validateUpdateMutation ::
  forall pgKind m.
  (MonadError QErr m, MonadIO m, Tracing.MonadTrace m) =>
  Env.Environment ->
  HTTP.Manager ->
  L.Logger L.Hasura ->
  UserInfo ->
  ResolvedWebhook ->
  [HeaderConf] ->
  Timeout ->
  Bool ->
  [HTTP.Header] ->
  IR.AnnotatedUpdateG ('Postgres pgKind) Void (IR.UnpreparedValue ('Postgres pgKind)) ->
  Maybe (HashMap G.Name (G.Value G.Variable)) ->
  m ()
validateUpdateMutation :: forall (pgKind :: PostgresKind) (m :: * -> *).
(MonadError QErr m, MonadIO m, MonadTrace m) =>
Environment
-> Manager
-> Logger Hasura
-> UserInfo
-> ResolvedWebhook
-> [HeaderConf]
-> Timeout
-> Bool
-> [Header]
-> AnnotatedUpdateG
     ('Postgres pgKind) Void (UnpreparedValue ('Postgres pgKind))
-> Maybe (HashMap Name (Value Variable))
-> m ()
validateUpdateMutation Environment
env Manager
manager Logger Hasura
logger UserInfo
userInfo ResolvedWebhook
resolvedWebHook [HeaderConf]
confHeaders Timeout
timeout Bool
forwardClientHeaders [Header]
reqHeaders AnnotatedUpdateG
  ('Postgres pgKind) Void (UnpreparedValue ('Postgres pgKind))
updateOperation Maybe (HashMap Name (Value Variable))
maybeSelSetArgs = do
  Value
inputData <-
    case Maybe (HashMap Name (Value Variable))
maybeSelSetArgs of
      Just HashMap Name (Value Variable)
arguments -> do
        case (AnnotatedUpdateG
  ('Postgres pgKind) Void (UnpreparedValue ('Postgres pgKind))
-> UpdateVariant
     ('Postgres pgKind) (UnpreparedValue ('Postgres pgKind))
forall (b :: BackendType) r v.
AnnotatedUpdateG b r v -> UpdateVariant b v
IR._auUpdateVariant AnnotatedUpdateG
  ('Postgres pgKind) Void (UnpreparedValue ('Postgres pgKind))
updateOperation) of
          -- Mutation arguments for single update (eg: update_customer) are
          -- present as seperate root fields of the selection set.
          -- eg:
          Postgres.SingleBatch UpdateBatch
  ('Postgres pgKind)
  UpdateOpExpression
  (UnpreparedValue ('Postgres pgKind))
_ -> do
            -- this constructs something like: {"_set":{"name": {"_eq": "abc"}}, "where":{"id":{"_eq":10}}}
            let singleBatchinputVal :: Value
singleBatchinputVal =
                  [Pair] -> Value
J.object
                    ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ ((Name, Value Variable) -> Pair)
-> [(Name, Value Variable)] -> [Pair]
forall a b. (a -> b) -> [a] -> [b]
map
                      (\(Name
k, Value Variable
v) -> Text -> Key
J.fromText (Name -> Text
G.unName Name
k) Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= Value Variable -> Value
graphQLToJSON Value Variable
v)
                      (HashMap Name (Value Variable) -> [(Name, Value Variable)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList (HashMap Name (Value Variable) -> [(Name, Value Variable)])
-> HashMap Name (Value Variable) -> [(Name, Value Variable)]
forall a b. (a -> b) -> a -> b
$ HashMap Name (Value Variable)
arguments)
            Value -> m Value
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pair] -> Value
J.object [Key
"input" Key -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= [Value
singleBatchinputVal]])
          -- Mutation arguments for multiple updates (eg:
          -- update_customer_many) are present in the "updates" field of the
          -- selection set.
          -- Look for "updates" field and get the mutation arguments from it.
          -- eg: {"updates": [{"_set":{"id":{"_eq":10}}, "where":{"name":{"_eq":"abc"}}}]}
          Postgres.MultipleBatches [UpdateBatch
   ('Postgres pgKind)
   UpdateOpExpression
   (UnpreparedValue ('Postgres pgKind))]
_ -> do
            case (Name -> HashMap Name (Value Variable) -> Maybe (Value Variable)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup $$(G.litName "updates") HashMap Name (Value Variable)
arguments) of
              Maybe (Value Variable)
Nothing -> Value -> m Value
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Value
J.Null
              Just Value Variable
val -> (Value -> m Value
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
J.object [Key
"input" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= Value Variable -> Value
graphQLToJSON Value Variable
val])
      Maybe (HashMap Name (Value Variable))
Nothing -> Value -> m Value
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
J.Null
  Environment
-> Manager
-> Logger Hasura
-> UserInfo
-> ResolvedWebhook
-> [HeaderConf]
-> Timeout
-> Bool
-> [Header]
-> Value
-> m ()
forall (m :: * -> *).
(MonadError QErr m, MonadIO m, MonadTrace m) =>
Environment
-> Manager
-> Logger Hasura
-> UserInfo
-> ResolvedWebhook
-> [HeaderConf]
-> Timeout
-> Bool
-> [Header]
-> Value
-> m ()
validateMutation Environment
env Manager
manager Logger Hasura
logger UserInfo
userInfo ResolvedWebhook
resolvedWebHook [HeaderConf]
confHeaders Timeout
timeout Bool
forwardClientHeaders [Header]
reqHeaders Value
inputData

validateDeleteMutation ::
  forall m pgKind.
  (MonadError QErr m, MonadIO m, Tracing.MonadTrace m) =>
  Env.Environment ->
  HTTP.Manager ->
  L.Logger L.Hasura ->
  UserInfo ->
  ResolvedWebhook ->
  [HeaderConf] ->
  Timeout ->
  Bool ->
  [HTTP.Header] ->
  IR.AnnDelG ('Postgres pgKind) Void (IR.UnpreparedValue ('Postgres pgKind)) ->
  Maybe (HashMap G.Name (G.Value G.Variable)) ->
  m ()
validateDeleteMutation :: forall (m :: * -> *) (pgKind :: PostgresKind).
(MonadError QErr m, MonadIO m, MonadTrace m) =>
Environment
-> Manager
-> Logger Hasura
-> UserInfo
-> ResolvedWebhook
-> [HeaderConf]
-> Timeout
-> Bool
-> [Header]
-> AnnDelG
     ('Postgres pgKind) Void (UnpreparedValue ('Postgres pgKind))
-> Maybe (HashMap Name (Value Variable))
-> m ()
validateDeleteMutation Environment
env Manager
manager Logger Hasura
logger UserInfo
userInfo ResolvedWebhook
resolvedWebHook [HeaderConf]
confHeaders Timeout
timeout Bool
forwardClientHeaders [Header]
reqHeaders AnnDelG
  ('Postgres pgKind) Void (UnpreparedValue ('Postgres pgKind))
deleteOperation Maybe (HashMap Name (Value Variable))
maybeSelSetArgs = do
  Value
inputData <-
    case Maybe (HashMap Name (Value Variable))
maybeSelSetArgs of
      Just HashMap Name (Value Variable)
arguments -> do
        -- this constructs something like: {"where":{"id":{"_eq":10}}}
        let deleteInputVal :: Value
deleteInputVal =
              [Pair] -> Value
J.object
                ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ ((Name, Value Variable) -> Pair)
-> [(Name, Value Variable)] -> [Pair]
forall a b. (a -> b) -> [a] -> [b]
map
                  (\(Name
k, Value Variable
v) -> Text -> Key
J.fromText (Name -> Text
G.unName Name
k) Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= Value Variable -> Value
graphQLToJSON Value Variable
v)
                  (HashMap Name (Value Variable) -> [(Name, Value Variable)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList (HashMap Name (Value Variable) -> [(Name, Value Variable)])
-> HashMap Name (Value Variable) -> [(Name, Value Variable)]
forall a b. (a -> b) -> a -> b
$ HashMap Name (Value Variable)
arguments)
        if (AnnDelG
  ('Postgres pgKind) Void (UnpreparedValue ('Postgres pgKind))
-> Bool
forall (b :: BackendType) r v. AnnDelG b r v -> Bool
_adIsDeleteByPk AnnDelG
  ('Postgres pgKind) Void (UnpreparedValue ('Postgres pgKind))
deleteOperation)
          then -- If the delete operation is delete_<table>_by_pk, then we need to
          -- include the pk_columns field manually in the input payload. This
          -- is needed, because unlike the update mutation, the pk_columns for
          -- `delete_<table>_by_pk` is not present in the mutation arguments.
          -- for eg: the `delete_<table>_by_pk` looks like:
          --
          -- mutation DeleteCustomerByPk {
          --   delete_customer_by_pk(id: 1) {
          --     id
          --    }
          -- }
          do
            let deleteInputValByPk :: Value
deleteInputValByPk = [Pair] -> Value
J.object [Key
"pk_columns" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= Value
deleteInputVal]
            Value -> m Value
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pair] -> Value
J.object [Key
"input" Key -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= [Value
deleteInputValByPk]])
          else Value -> m Value
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pair] -> Value
J.object [Key
"input" Key -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= [Value
deleteInputVal]])
      Maybe (HashMap Name (Value Variable))
Nothing -> Value -> m Value
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
J.Null
  Environment
-> Manager
-> Logger Hasura
-> UserInfo
-> ResolvedWebhook
-> [HeaderConf]
-> Timeout
-> Bool
-> [Header]
-> Value
-> m ()
forall (m :: * -> *).
(MonadError QErr m, MonadIO m, MonadTrace m) =>
Environment
-> Manager
-> Logger Hasura
-> UserInfo
-> ResolvedWebhook
-> [HeaderConf]
-> Timeout
-> Bool
-> [Header]
-> Value
-> m ()
validateMutation Environment
env Manager
manager Logger Hasura
logger UserInfo
userInfo ResolvedWebhook
resolvedWebHook [HeaderConf]
confHeaders Timeout
timeout Bool
forwardClientHeaders [Header]
reqHeaders Value
inputData

validateMutation ::
  forall m.
  ( MonadError QErr m,
    MonadIO m,
    Tracing.MonadTrace m
  ) =>
  Env.Environment ->
  HTTP.Manager ->
  L.Logger L.Hasura ->
  UserInfo ->
  ResolvedWebhook ->
  [HeaderConf] ->
  Timeout ->
  Bool ->
  [HTTP.Header] ->
  J.Value ->
  m ()
validateMutation :: forall (m :: * -> *).
(MonadError QErr m, MonadIO m, MonadTrace m) =>
Environment
-> Manager
-> Logger Hasura
-> UserInfo
-> ResolvedWebhook
-> [HeaderConf]
-> Timeout
-> Bool
-> [Header]
-> Value
-> m ()
validateMutation Environment
env Manager
manager Logger Hasura
logger UserInfo
userInfo (ResolvedWebhook Text
urlText) [HeaderConf]
confHeaders Timeout
timeout Bool
forwardClientHeaders [Header]
reqHeaders Value
inputData = do
  let requestBody :: Value
requestBody =
        [Pair] -> Value
J.object
          [ Key
"version" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= Int
validateInputPayloadVersion,
            Key
"session_variables" Key -> SessionVariables -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= UserInfo -> SessionVariables
_uiSession UserInfo
userInfo,
            Key
"role" Key -> RoleName -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= UserInfo -> RoleName
_uiRole UserInfo
userInfo,
            Key
"data" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= Value
inputData
          ]
  [Header]
resolvedConfHeaders <- Environment -> [HeaderConf] -> m [Header]
forall (m :: * -> *).
MonadError QErr m =>
Environment -> [HeaderConf] -> m [Header]
makeHeadersFromConf Environment
env [HeaderConf]
confHeaders
  let clientHeaders :: [Header]
clientHeaders = if Bool
forwardClientHeaders then [Header] -> [Header]
mkClientHeadersForward [Header]
reqHeaders else [Header]
forall a. Monoid a => a
mempty
      -- Using HashMap to avoid duplicate headers between configuration headers
      -- and client headers where configuration headers are preferred
      hdrs :: [Header]
hdrs = (HashMap HeaderName ByteString -> [Header]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList (HashMap HeaderName ByteString -> [Header])
-> ([Header] -> HashMap HeaderName ByteString)
-> [Header]
-> [Header]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Header] -> HashMap HeaderName ByteString
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList) ([Header]
resolvedConfHeaders [Header] -> [Header] -> [Header]
forall a. Semigroup a => a -> a -> a
<> [Header]
defaultHeaders [Header] -> [Header] -> [Header]
forall a. Semigroup a => a -> a -> a
<> [Header]
clientHeaders)
  Request
initRequest <- 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
urlText
  let request :: Request
request =
        Request
initRequest
          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
Lens.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 [Header] [Header]
-> [Header] -> Request -> Request
forall s t a b. ASetter s t a b -> b -> s -> t
Lens.set ASetter Request Request [Header] [Header]
Lens' Request [Header]
HTTP.headers [Header]
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
Lens.set ASetter Request Request RequestBody RequestBody
Lens' Request RequestBody
HTTP.body (ByteString -> RequestBody
HTTP.RequestBodyLBS (ByteString -> RequestBody) -> ByteString -> RequestBody
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
J.encode Value
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
Lens.set ASetter Request Request ResponseTimeout ResponseTimeout
Lens' Request ResponseTimeout
HTTP.timeout (Int -> ResponseTimeout
HTTP.responseTimeoutMicro (Timeout -> Int
unTimeout Timeout
timeout Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000)) -- (default: 10 seconds)
  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
request ((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

  case Either HttpException (Response ByteString)
httpResponse of
    Left HttpException
e ->
      Text -> Value -> m ()
forall (m :: * -> *) a. QErrM m => Text -> Value -> m a
throw500WithDetail Text
"http exception when validating input data"
        (Value -> m ()) -> Value -> m ()
forall a b. (a -> b) -> a -> b
$ HttpException -> Value
forall a. ToJSON a => a -> Value
J.toJSON
        (HttpException -> Value) -> HttpException -> Value
forall a b. (a -> b) -> a -> b
$ HttpException -> HttpException
HttpException HttpException
e
    Right Response ByteString
response -> do
      let responseStatus :: Status
responseStatus = Response ByteString
response Response ByteString
-> Getting Status (Response ByteString) Status -> Status
forall s a. s -> Getting a s a -> a
Lens.^. Getting Status (Response ByteString) Status
forall body (f :: * -> *).
Functor f =>
(Status -> f Status) -> Response body -> f (Response body)
Wreq.responseStatus
          responseBody :: ByteString
responseBody = Response ByteString
response Response ByteString
-> Getting ByteString (Response ByteString) ByteString
-> ByteString
forall s a. s -> Getting a s a -> a
Lens.^. Getting ByteString (Response ByteString) ByteString
forall body0 body1 (f :: * -> *).
Functor f =>
(body0 -> f body1) -> Response body0 -> f (Response body1)
Wreq.responseBody
          responseBodyForLogging :: Value
responseBodyForLogging = Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe (Text -> Value
J.String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
lbsToTxt ByteString
responseBody) (Maybe Value -> Value) -> Maybe Value -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
J.decode' ByteString
responseBody
      -- Log the details of the HTTP webhook call
      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 (ValidateInsertInputLog -> m ()) -> ValidateInsertInputLog -> m ()
forall a b. (a -> b) -> a -> b
$ HttpHandlerLog -> ValidateInsertInputLog
VIILHttpHandler (HttpHandlerLog -> ValidateInsertInputLog)
-> HttpHandlerLog -> ValidateInsertInputLog
forall a b. (a -> b) -> a -> b
$ Text -> Value -> [HeaderConf] -> Value -> Int -> HttpHandlerLog
HttpHandlerLog Text
urlText Value
requestBody [HeaderConf]
confHeaders Value
responseBodyForLogging (Status -> Int
HTTP.statusCode Status
responseStatus)
      if
        | Status -> Bool
HTTP.statusIsSuccessful Status
responseStatus -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        | Status
responseStatus Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
HTTP.status400 -> do
            ValidateInputErrorResponse Text
errorMessage <-
              ByteString -> Either String ValidateInputErrorResponse
forall a. FromJSON a => ByteString -> Either String a
J.eitherDecode ByteString
responseBody Either String ValidateInputErrorResponse
-> (String -> m ValidateInputErrorResponse)
-> m ValidateInputErrorResponse
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
`onLeft` \String
e ->
                Text -> Value -> m ValidateInputErrorResponse
forall (m :: * -> *) a. QErrM m => Text -> Value -> m a
throw500WithDetail Text
"received invalid response from input validation webhook"
                  (Value -> m ValidateInputErrorResponse)
-> Value -> m ValidateInputErrorResponse
forall a b. (a -> b) -> a -> b
$ String -> Value
forall a. ToJSON a => a -> Value
J.toJSON
                  (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ String
"invalid response: "
                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
e
            Code -> Text -> m ()
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
ValidationFailed Text
errorMessage
        | 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 200 or 400 status code, but found "
                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Status -> Int
HTTP.statusCode Status
responseStatus)
            Text -> Value -> m ()
forall (m :: * -> *) a. QErrM m => Text -> Value -> m a
throw500WithDetail Text
"internal error when validating input data" Value
err