mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-17 04:24:35 +03:00
b3a4855fbb
[GDC-714]: https://hasurahq.atlassian.net/browse/GDC-714?atlOrigin=eyJpIjoiNWRkNTljNzYxNjVmNDY3MDlhMDU5Y2ZhYzA5YTRkZjUiLCJwIjoiZ2l0aHViLWNvbS1KU1cifQ PR-URL: https://github.com/hasura/graphql-engine-mono/pull/7623 GitOrigin-RevId: 676682343bc9aa54e1ed6553ebdf39756cfd7b5d
389 lines
16 KiB
Haskell
389 lines
16 KiB
Haskell
module Hasura.Backends.DataConnector.Plan.MutationPlan
|
|
( mkMutationPlan,
|
|
)
|
|
where
|
|
|
|
import Control.Monad.Trans.Writer.CPS qualified as CPS
|
|
import Data.Aeson qualified as J
|
|
import Data.Aeson.Encoding qualified as JE
|
|
import Data.Has (Has, modifier)
|
|
import Data.HashMap.Strict qualified as HashMap
|
|
import Data.Text.Extended (toTxt)
|
|
import Hasura.Backends.DataConnector.API qualified as API
|
|
import Hasura.Backends.DataConnector.Adapter.Types
|
|
import Hasura.Backends.DataConnector.Adapter.Types.Mutations
|
|
import Hasura.Backends.DataConnector.Plan.Common
|
|
import Hasura.Backends.DataConnector.Plan.QueryPlan (reshapeAnnFields, translateAnnFields)
|
|
import Hasura.Base.Error (Code (..), QErr, throw400, throw500)
|
|
import Hasura.Prelude
|
|
import Hasura.RQL.IR.BoolExp (GBoolExp (..))
|
|
import Hasura.RQL.IR.Delete
|
|
import Hasura.RQL.IR.Insert hiding (Single)
|
|
import Hasura.RQL.IR.Returning
|
|
import Hasura.RQL.IR.Root
|
|
import Hasura.RQL.IR.Select
|
|
import Hasura.RQL.IR.Update
|
|
import Hasura.RQL.IR.Update.Batch
|
|
import Hasura.RQL.IR.Value
|
|
import Hasura.RQL.Types.Column
|
|
import Hasura.RQL.Types.Common
|
|
import Hasura.SQL.Backend (BackendType (..))
|
|
import Hasura.Session (SessionVariables)
|
|
import Language.GraphQL.Draft.Syntax qualified as G
|
|
import Witch qualified
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
newtype TableInsertSchemas = TableInsertSchemas
|
|
{unTableInsertSchemas :: HashMap API.TableName (HashMap API.FieldName API.InsertFieldSchema)}
|
|
deriving stock (Eq, Show)
|
|
|
|
instance Semigroup TableInsertSchemas where
|
|
(TableInsertSchemas l) <> (TableInsertSchemas r) = TableInsertSchemas $ HashMap.unionWith HashMap.union l r
|
|
|
|
instance Monoid TableInsertSchemas where
|
|
mempty = TableInsertSchemas mempty
|
|
|
|
recordTableInsertSchema ::
|
|
( Has TableInsertSchemas writerOutput,
|
|
Monoid writerOutput,
|
|
MonadError QErr m
|
|
) =>
|
|
API.TableName ->
|
|
HashMap API.FieldName API.InsertFieldSchema ->
|
|
CPS.WriterT writerOutput m ()
|
|
recordTableInsertSchema tableName fieldSchemas =
|
|
let newTableSchema = TableInsertSchemas $ HashMap.singleton tableName fieldSchemas
|
|
in CPS.tell $ modifier (const newTableSchema) mempty
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
mkMutationPlan ::
|
|
MonadError QErr m =>
|
|
SessionVariables ->
|
|
MutationDB 'DataConnector Void (UnpreparedValue 'DataConnector) ->
|
|
m (Plan API.MutationRequest API.MutationResponse)
|
|
mkMutationPlan sessionVariables mutationDB = do
|
|
request <- translateMutationDB sessionVariables mutationDB
|
|
pure $ Plan request (reshapeResponseToMutationGqlShape mutationDB)
|
|
|
|
translateMutationDB ::
|
|
MonadError QErr m =>
|
|
SessionVariables ->
|
|
MutationDB 'DataConnector Void (UnpreparedValue 'DataConnector) ->
|
|
m API.MutationRequest
|
|
translateMutationDB sessionVariables = \case
|
|
MDBInsert insert -> do
|
|
(insertOperation, (tableRelationships, tableInsertSchemas)) <- CPS.runWriterT $ translateInsert sessionVariables insert
|
|
let apiTableRelationships = uncurry API.TableRelationships <$> HashMap.toList (unTableRelationships tableRelationships)
|
|
let apiTableInsertSchema = uncurry API.TableInsertSchema <$> HashMap.toList (unTableInsertSchemas tableInsertSchemas)
|
|
pure $
|
|
API.MutationRequest
|
|
{ _mrTableRelationships = apiTableRelationships,
|
|
_mrInsertSchema = apiTableInsertSchema,
|
|
_mrOperations = [API.InsertOperation insertOperation]
|
|
}
|
|
MDBUpdate update -> do
|
|
(updateOperations, tableRelationships) <- CPS.runWriterT $ translateUpdate sessionVariables update
|
|
let apiTableRelationships = uncurry API.TableRelationships <$> HashMap.toList (unTableRelationships tableRelationships)
|
|
pure $
|
|
API.MutationRequest
|
|
{ _mrTableRelationships = apiTableRelationships,
|
|
_mrInsertSchema = [],
|
|
_mrOperations = API.UpdateOperation <$> updateOperations
|
|
}
|
|
MDBDelete delete -> do
|
|
(deleteOperation, tableRelationships) <- CPS.runWriterT $ translateDelete sessionVariables delete
|
|
let apiTableRelationships = uncurry API.TableRelationships <$> HashMap.toList (unTableRelationships tableRelationships)
|
|
pure $
|
|
API.MutationRequest
|
|
{ _mrTableRelationships = apiTableRelationships,
|
|
_mrInsertSchema = [],
|
|
_mrOperations = [API.DeleteOperation deleteOperation]
|
|
}
|
|
MDBFunction _returnsSet _select ->
|
|
throw400 NotSupported "translateMutationDB: function mutations not implemented for the Data Connector backend."
|
|
|
|
translateInsert ::
|
|
MonadError QErr m =>
|
|
SessionVariables ->
|
|
AnnotatedInsert 'DataConnector Void (UnpreparedValue 'DataConnector) ->
|
|
CPS.WriterT (TableRelationships, TableInsertSchemas) m API.InsertMutationOperation
|
|
translateInsert sessionVariables AnnotatedInsert {..} = do
|
|
rows <- traverse (translateInsertRow sessionVariables tableName _aiTableColumns _aiPresetValues) _aiInsertObject
|
|
postInsertCheck <- translateBoolExpToExpression sessionVariables tableName insertCheckCondition
|
|
returningFields <- translateMutationOutputToReturningFields sessionVariables tableName _aiOutput
|
|
pure $
|
|
API.InsertMutationOperation
|
|
{ API._imoTable = tableName,
|
|
API._imoRows = rows,
|
|
API._imoPostInsertCheck = postInsertCheck,
|
|
API._imoReturningFields = HashMap.mapKeys (API.FieldName . getFieldNameTxt) returningFields
|
|
}
|
|
where
|
|
tableName = Witch.from _aiTableName
|
|
-- Update check condition must be used once upserts are supported
|
|
(insertCheckCondition, _updateCheckCondition) = _aiCheckCondition
|
|
AnnotatedInsertData {..} = _aiData
|
|
|
|
translateInsertRow ::
|
|
( Has TableInsertSchemas writerOutput,
|
|
Monoid writerOutput,
|
|
MonadError QErr m
|
|
) =>
|
|
SessionVariables ->
|
|
API.TableName ->
|
|
[ColumnInfo 'DataConnector] ->
|
|
HashMap ColumnName (UnpreparedValue 'DataConnector) ->
|
|
AnnotatedInsertRow 'DataConnector (UnpreparedValue 'DataConnector) ->
|
|
CPS.WriterT writerOutput m API.RowObject
|
|
translateInsertRow sessionVariables tableName tableColumns defaultColumnValues insertRow = do
|
|
columnSchemasAndValues <- lift $ forM (HashMap.toList columnUnpreparedValues) $ \(columnName, columnValue) -> do
|
|
fieldName <-
|
|
case find (\ColumnInfo {..} -> ciColumn == columnName) tableColumns of
|
|
Just ColumnInfo {..} -> pure . API.FieldName $ G.unName ciName
|
|
Nothing -> throw500 $ "Can't find column " <> toTxt columnName <> " in table schema for " <> API.tableNameToText tableName
|
|
preparedLiteral <- prepareLiteral sessionVariables columnValue
|
|
|
|
(scalarType, value) <-
|
|
case preparedLiteral of
|
|
ValueLiteral scalarType value -> pure (scalarType, value)
|
|
ArrayLiteral _scalarType _values -> throw400 NotSupported "translateInsertRow: Array literals are not supported as column insert values"
|
|
|
|
let columnInsertSchema = API.ColumnInsertSchema (Witch.from columnName) (Witch.from scalarType)
|
|
pure (fieldName, columnInsertSchema, value)
|
|
|
|
let fieldSchemas =
|
|
columnSchemasAndValues
|
|
& fmap (\(fieldName, columnInsertSchema, _) -> (fieldName, API.ColumnInsert columnInsertSchema))
|
|
& HashMap.fromList
|
|
recordTableInsertSchema tableName fieldSchemas
|
|
|
|
let rowObject =
|
|
columnSchemasAndValues
|
|
& fmap (\(fieldName, _, value) -> (fieldName, API.mkColumnInsertFieldValue value))
|
|
& HashMap.fromList
|
|
& API.RowObject
|
|
|
|
pure rowObject
|
|
where
|
|
columnUnpreparedValues :: HashMap ColumnName (UnpreparedValue 'DataConnector)
|
|
columnUnpreparedValues = HashMap.union rowColumnValues defaultColumnValues
|
|
|
|
rowColumnValues :: HashMap ColumnName (UnpreparedValue 'DataConnector)
|
|
rowColumnValues =
|
|
insertRow
|
|
& fmap (\(AIColumn columnNameAndValue) -> columnNameAndValue)
|
|
& HashMap.fromList
|
|
|
|
translateUpdate ::
|
|
MonadError QErr m =>
|
|
SessionVariables ->
|
|
AnnotatedUpdateG 'DataConnector Void (UnpreparedValue 'DataConnector) ->
|
|
CPS.WriterT TableRelationships m [API.UpdateMutationOperation]
|
|
translateUpdate sessionVariables annUpdate@AnnotatedUpdateG {..} = do
|
|
case _auUpdateVariant of
|
|
SingleBatch batch -> (: []) <$> translateUpdateBatch sessionVariables annUpdate batch
|
|
MultipleBatches batches -> traverse (translateUpdateBatch sessionVariables annUpdate) batches
|
|
|
|
translateUpdateBatch ::
|
|
MonadError QErr m =>
|
|
SessionVariables ->
|
|
AnnotatedUpdateG 'DataConnector Void (UnpreparedValue 'DataConnector) ->
|
|
UpdateBatch 'DataConnector UpdateOperator (UnpreparedValue 'DataConnector) ->
|
|
CPS.WriterT TableRelationships m API.UpdateMutationOperation
|
|
translateUpdateBatch sessionVariables AnnotatedUpdateG {..} UpdateBatch {..} = do
|
|
updates <- lift $ translateUpdateOperations sessionVariables _ubOperations
|
|
whereExp <- translateBoolExpToExpression sessionVariables tableName (BoolAnd [_auUpdatePermissions, _ubWhere])
|
|
postUpdateCheck <- translateBoolExpToExpression sessionVariables tableName _auCheck
|
|
returningFields <- translateMutationOutputToReturningFields sessionVariables tableName _auOutput
|
|
|
|
pure $
|
|
API.UpdateMutationOperation
|
|
{ API._umoTable = tableName,
|
|
API._umoWhere = whereExp,
|
|
API._umoUpdates = updates,
|
|
API._umoPostUpdateCheck = postUpdateCheck,
|
|
API._umoReturningFields = HashMap.mapKeys (API.FieldName . getFieldNameTxt) returningFields
|
|
}
|
|
where
|
|
tableName = Witch.from _auTable
|
|
|
|
translateUpdateOperations ::
|
|
forall m.
|
|
MonadError QErr m =>
|
|
SessionVariables ->
|
|
HashMap ColumnName (UpdateOperator (UnpreparedValue 'DataConnector)) ->
|
|
m [API.RowUpdate]
|
|
translateUpdateOperations sessionVariables columnUpdates =
|
|
forM (HashMap.toList columnUpdates) $ \(columnName, updateOperator) -> do
|
|
let (mkRowUpdate, value) =
|
|
case updateOperator of
|
|
UpdateSet value' -> (API.SetColumn, value')
|
|
UpdateCustomOperator operatorName value' -> (API.CustomUpdateColumnOperator operatorName, value')
|
|
(scalarType, literalValue) <- prepareAndExtractLiteralValue value
|
|
let operatorValue = API.RowColumnOperatorValue (Witch.from columnName) literalValue (Witch.from scalarType)
|
|
pure $ mkRowUpdate operatorValue
|
|
where
|
|
prepareAndExtractLiteralValue :: UnpreparedValue 'DataConnector -> m (ScalarType, J.Value)
|
|
prepareAndExtractLiteralValue unpreparedValue = do
|
|
preparedLiteral <- prepareLiteral sessionVariables unpreparedValue
|
|
case preparedLiteral of
|
|
ValueLiteral scalarType value -> pure (scalarType, value)
|
|
ArrayLiteral _scalarType _values -> throw400 NotSupported "translateUpdateOperations: Array literals are not supported as column update values"
|
|
|
|
translateDelete ::
|
|
MonadError QErr m =>
|
|
SessionVariables ->
|
|
AnnDelG 'DataConnector Void (UnpreparedValue 'DataConnector) ->
|
|
CPS.WriterT TableRelationships m API.DeleteMutationOperation
|
|
translateDelete sessionVariables AnnDel {..} = do
|
|
whereExp <- translateBoolExpToExpression sessionVariables tableName (BoolAnd [permissionFilter, whereClause])
|
|
returningFields <- translateMutationOutputToReturningFields sessionVariables tableName _adOutput
|
|
pure $
|
|
API.DeleteMutationOperation
|
|
{ API._dmoTable = tableName,
|
|
API._dmoWhere = whereExp,
|
|
API._dmoReturningFields = HashMap.mapKeys (API.FieldName . getFieldNameTxt) returningFields
|
|
}
|
|
where
|
|
tableName = Witch.from _adTable
|
|
(permissionFilter, whereClause) = _adWhere
|
|
|
|
translateMutationOutputToReturningFields ::
|
|
( MonadError QErr m,
|
|
Has TableRelationships writerOutput,
|
|
Monoid writerOutput
|
|
) =>
|
|
SessionVariables ->
|
|
API.TableName ->
|
|
MutationOutputG 'DataConnector Void (UnpreparedValue 'DataConnector) ->
|
|
CPS.WriterT writerOutput m (HashMap FieldName API.Field)
|
|
translateMutationOutputToReturningFields sessionVariables tableName = \case
|
|
MOutSinglerowObject annFields ->
|
|
translateAnnFields sessionVariables noPrefix tableName annFields
|
|
MOutMultirowFields mutFields ->
|
|
HashMap.unions <$> traverse (uncurry $ translateMutField sessionVariables tableName) mutFields
|
|
|
|
translateMutField ::
|
|
( MonadError QErr m,
|
|
Has TableRelationships writerOutput,
|
|
Monoid writerOutput
|
|
) =>
|
|
SessionVariables ->
|
|
API.TableName ->
|
|
FieldName ->
|
|
MutFldG 'DataConnector Void (UnpreparedValue 'DataConnector) ->
|
|
CPS.WriterT writerOutput m (HashMap FieldName API.Field)
|
|
translateMutField sessionVariables tableName fieldName = \case
|
|
MCount ->
|
|
-- All mutation operations in a request return their affected rows count.
|
|
-- The count can just be added to the response JSON during agent response reshaping
|
|
pure mempty
|
|
MExp _text ->
|
|
-- We ignore literal text fields (we don't send them to the data connector agent)
|
|
-- and add them back to the response JSON when we reshape what the agent returns
|
|
-- to us
|
|
pure mempty
|
|
MRet annFields ->
|
|
translateAnnFields sessionVariables (prefixWith fieldName) tableName annFields
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
reshapeResponseToMutationGqlShape ::
|
|
MonadError QErr m =>
|
|
MutationDB 'DataConnector Void v ->
|
|
API.MutationResponse ->
|
|
m J.Encoding
|
|
reshapeResponseToMutationGqlShape mutationDb mutationResponse = do
|
|
case mutationDb of
|
|
MDBInsert AnnotatedInsert {..} ->
|
|
reshapeOutputForSingleBatchOperation _aiOutput mutationResponse
|
|
MDBUpdate AnnotatedUpdateG {..} ->
|
|
case _auUpdateVariant of
|
|
SingleBatch _batch ->
|
|
reshapeOutputForSingleBatchOperation _auOutput mutationResponse
|
|
MultipleBatches batches ->
|
|
let outputs = replicate (length batches) _auOutput
|
|
in reshapeOutputForMultipleBatchOperation outputs mutationResponse
|
|
MDBDelete AnnDel {..} ->
|
|
reshapeOutputForSingleBatchOperation _adOutput mutationResponse
|
|
MDBFunction _returnsSet _select ->
|
|
throw400 NotSupported "reshapeResponseToMutationGqlShape: function mutations not implemented for the Data Connector backend."
|
|
|
|
reshapeOutputForSingleBatchOperation ::
|
|
MonadError QErr m =>
|
|
MutationOutputG 'DataConnector Void v ->
|
|
API.MutationResponse ->
|
|
m J.Encoding
|
|
reshapeOutputForSingleBatchOperation mutationOutput API.MutationResponse {..} = do
|
|
mutationOperationResult <-
|
|
listToMaybe _mrOperationResults
|
|
`onNothing` throw500 "Unable to find expected mutation operation results"
|
|
reshapeMutationOutput mutationOutput mutationOperationResult
|
|
|
|
reshapeOutputForMultipleBatchOperation ::
|
|
MonadError QErr m =>
|
|
[MutationOutputG 'DataConnector Void v] ->
|
|
API.MutationResponse ->
|
|
m J.Encoding
|
|
reshapeOutputForMultipleBatchOperation mutationOutputs API.MutationResponse {..} = do
|
|
unless (operationResultCount >= requiredResultCount) $
|
|
throw500 ("Data Connector agent returned " <> tshow operationResultCount <> " mutation operation results where at least " <> tshow requiredResultCount <> " was expected")
|
|
|
|
reshapedResults <-
|
|
zip mutationOutputs _mrOperationResults
|
|
& traverse (uncurry reshapeMutationOutput)
|
|
|
|
pure $ JE.list id reshapedResults
|
|
where
|
|
requiredResultCount = length mutationOutputs
|
|
operationResultCount = length _mrOperationResults
|
|
|
|
reshapeMutationOutput ::
|
|
MonadError QErr m =>
|
|
MutationOutputG 'DataConnector Void v ->
|
|
API.MutationOperationResults ->
|
|
m J.Encoding
|
|
reshapeMutationOutput mutationOutput mutationOperationResults =
|
|
case mutationOutput of
|
|
MOutSinglerowObject annFields -> reshapeReturningRows Single noPrefix annFields mutationOperationResults
|
|
MOutMultirowFields mutFields -> reshapeMutFields mutFields mutationOperationResults
|
|
|
|
reshapeReturningRows ::
|
|
MonadError QErr m =>
|
|
Cardinality ->
|
|
FieldPrefix ->
|
|
AnnFieldsG 'DataConnector Void v ->
|
|
API.MutationOperationResults ->
|
|
m J.Encoding
|
|
reshapeReturningRows cardinality fieldNamePrefix annFields API.MutationOperationResults {..} =
|
|
case cardinality of
|
|
Single ->
|
|
case rows of
|
|
[] -> pure $ J.toEncoding J.Null
|
|
[singleRow] -> reshapeAnnFields fieldNamePrefix annFields singleRow
|
|
_multipleRows ->
|
|
throw500 "Data Connector agent returned multiple rows in a mutation operation result when only one was expected"
|
|
Many -> do
|
|
reshapedRows <- traverse (reshapeAnnFields fieldNamePrefix annFields) rows
|
|
pure $ JE.list id reshapedRows
|
|
where
|
|
rows = fromMaybe mempty _morReturning
|
|
|
|
reshapeMutFields ::
|
|
MonadError QErr m =>
|
|
MutFldsG 'DataConnector Void v ->
|
|
API.MutationOperationResults ->
|
|
m J.Encoding
|
|
reshapeMutFields mutFields mutationOperationResults@API.MutationOperationResults {..} = do
|
|
reshapedMutFields <- forM mutFields $ \(fieldName@(FieldName fieldNameText), mutField) -> do
|
|
reshapedFieldValue <-
|
|
case mutField of
|
|
MCount -> pure $ JE.int _morAffectedRows
|
|
MExp literalText -> pure $ JE.text literalText
|
|
MRet annFields -> reshapeReturningRows Many (prefixWith fieldName) annFields mutationOperationResults
|
|
pure (fieldNameText, reshapedFieldValue)
|
|
|
|
pure $ encodeAssocListAsObject reshapedMutFields
|