mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-17 12:31:52 +03:00
ce052f0b1b
PR-URL: https://github.com/hasura/graphql-engine-mono/pull/2717 GitOrigin-RevId: 7c17fa41e5df2cfbc49e0ce2a1f78b3627de7051
389 lines
17 KiB
Haskell
389 lines
17 KiB
Haskell
module Hasura.GraphQL.Schema.Action
|
|
( actionExecute,
|
|
actionAsyncMutation,
|
|
actionAsyncQuery,
|
|
)
|
|
where
|
|
|
|
import Data.Aeson qualified as J
|
|
import Data.Has
|
|
import Data.HashMap.Strict qualified as Map
|
|
import Data.Text.Extended
|
|
import Data.Text.NonEmpty
|
|
import Hasura.Backends.Postgres.SQL.Types
|
|
import Hasura.Backends.Postgres.Types.Column
|
|
import Hasura.Base.Error
|
|
import Hasura.GraphQL.Parser
|
|
( FieldParser,
|
|
InputFieldsParser,
|
|
Kind (..),
|
|
Parser,
|
|
UnpreparedValue (..),
|
|
)
|
|
import Hasura.GraphQL.Parser qualified as P
|
|
import Hasura.GraphQL.Parser.Class
|
|
import Hasura.GraphQL.Parser.Internal.Parser qualified as P
|
|
import Hasura.GraphQL.Schema.Backend
|
|
import Hasura.GraphQL.Schema.Common
|
|
import Hasura.GraphQL.Schema.Select
|
|
import Hasura.Prelude
|
|
import Hasura.RQL.DML.Internal qualified as RQL
|
|
import Hasura.RQL.IR.Select qualified as RQL
|
|
import Hasura.RQL.Types
|
|
import Hasura.Session
|
|
import Language.GraphQL.Draft.Syntax qualified as G
|
|
|
|
-- | actionExecute is used to execute either a query action or a synchronous
|
|
-- mutation action. A query action or a synchronous mutation action accepts
|
|
-- the field name and input arguments and a selectionset. The
|
|
-- input argument and selectionset types are defined by the user.
|
|
--
|
|
--
|
|
-- > action_name(action_input_arguments) {
|
|
-- > col1: col1_type
|
|
-- > col2: col2_type
|
|
-- > }
|
|
actionExecute ::
|
|
forall r m n.
|
|
MonadBuildSchema ('Postgres 'Vanilla) r m n =>
|
|
NonObjectTypeMap ->
|
|
ActionInfo ->
|
|
m (Maybe (FieldParser n (AnnActionExecution ('Postgres 'Vanilla) (RQL.RemoteSelect UnpreparedValue) (UnpreparedValue ('Postgres 'Vanilla)))))
|
|
actionExecute nonObjectTypeMap actionInfo = runMaybeT do
|
|
roleName <- askRoleName
|
|
guard (roleName == adminRoleName || roleName `Map.member` permissions)
|
|
let fieldName = unActionName actionName
|
|
description = G.Description <$> comment
|
|
inputArguments <- lift $ actionInputArguments nonObjectTypeMap $ _adArguments definition
|
|
selectionSet <- lift $ actionOutputFields outputType outputObject
|
|
stringifyNum <- asks $ qcStringifyNum . getter
|
|
pure $
|
|
P.subselection fieldName description inputArguments selectionSet
|
|
<&> \(argsJson, fields) ->
|
|
AnnActionExecution
|
|
{ _aaeName = actionName,
|
|
_aaeFields = fields,
|
|
_aaePayload = argsJson,
|
|
_aaeOutputType = _adOutputType definition,
|
|
_aaeOutputFields = getActionOutputFields outputObject,
|
|
_aaeDefinitionList = mkDefinitionList outputObject,
|
|
_aaeWebhook = _adHandler definition,
|
|
_aaeHeaders = _adHeaders definition,
|
|
_aaeForwardClientHeaders = _adForwardClientHeaders definition,
|
|
_aaeStrfyNum = stringifyNum,
|
|
_aaeTimeOut = _adTimeout definition,
|
|
_aaeSource = getActionSourceInfo outputObject,
|
|
_aaeRequestTransform = _adRequestTransform definition
|
|
}
|
|
where
|
|
ActionInfo actionName (outputType, outputObject) definition permissions _ comment = actionInfo
|
|
|
|
-- | actionAsyncMutation is used to execute a asynchronous mutation action. An
|
|
-- asynchronous action expects the field name and the input arguments to the
|
|
-- action. A selectionset is *not* expected. An action ID (UUID) will be
|
|
-- returned after performing the action
|
|
--
|
|
-- > action_name(action_input_arguments)
|
|
actionAsyncMutation ::
|
|
forall m n r.
|
|
(MonadSchema n m, MonadTableInfo r m, MonadRole r m) =>
|
|
NonObjectTypeMap ->
|
|
ActionInfo ->
|
|
m (Maybe (FieldParser n AnnActionMutationAsync))
|
|
actionAsyncMutation nonObjectTypeMap actionInfo = runMaybeT do
|
|
roleName <- lift askRoleName
|
|
guard $ roleName == adminRoleName || roleName `Map.member` permissions
|
|
inputArguments <- lift $ actionInputArguments nonObjectTypeMap $ _adArguments definition
|
|
let fieldName = unActionName actionName
|
|
description = G.Description <$> comment
|
|
pure $
|
|
P.selection fieldName description inputArguments actionIdParser
|
|
<&> AnnActionMutationAsync actionName forwardClientHeaders
|
|
where
|
|
ActionInfo actionName _ definition permissions forwardClientHeaders comment = actionInfo
|
|
|
|
-- | actionAsyncQuery is used to query/subscribe to the result of an
|
|
-- asynchronous mutation action. The only input argument to an
|
|
-- asynchronous mutation action is the action ID (UUID) and a selection
|
|
-- set is expected, the selection set contains 4 fields namely 'id',
|
|
-- 'created_at','errors' and 'output'. The result of the action can be queried
|
|
-- through the 'output' field.
|
|
--
|
|
-- > action_name (id: UUID!) {
|
|
-- > id: UUID!
|
|
-- > created_at: timestampz!
|
|
-- > errors: JSON
|
|
-- > output: user_defined_type!
|
|
-- > }
|
|
actionAsyncQuery ::
|
|
forall r m n.
|
|
MonadBuildSchema ('Postgres 'Vanilla) r m n =>
|
|
ActionInfo ->
|
|
m (Maybe (FieldParser n (AnnActionAsyncQuery ('Postgres 'Vanilla) (RQL.RemoteSelect UnpreparedValue) (UnpreparedValue ('Postgres 'Vanilla)))))
|
|
actionAsyncQuery actionInfo = runMaybeT do
|
|
roleName <- askRoleName
|
|
guard $ roleName == adminRoleName || roleName `Map.member` permissions
|
|
actionOutputParser <- lift $ actionOutputFields outputType outputObject
|
|
createdAtFieldParser <-
|
|
lift $ columnParser @('Postgres 'Vanilla) (ColumnScalar PGTimeStampTZ) (G.Nullability False)
|
|
errorsFieldParser <-
|
|
lift $ columnParser @('Postgres 'Vanilla) (ColumnScalar PGJSON) (G.Nullability True)
|
|
|
|
let fieldName = unActionName actionName
|
|
description = G.Description <$> comment
|
|
actionIdInputField =
|
|
P.field idFieldName (Just idFieldDescription) actionIdParser
|
|
allFieldParsers =
|
|
let idField = P.selection_ idFieldName (Just idFieldDescription) actionIdParser $> AsyncId
|
|
createdAtField =
|
|
P.selection_
|
|
$$(G.litName "created_at")
|
|
(Just "the time at which this action was created")
|
|
createdAtFieldParser
|
|
$> AsyncCreatedAt
|
|
errorsField =
|
|
P.selection_
|
|
$$(G.litName "errors")
|
|
(Just "errors related to the invocation")
|
|
errorsFieldParser
|
|
$> AsyncErrors
|
|
outputField =
|
|
P.subselection_
|
|
$$(G.litName "output")
|
|
(Just "the output fields of this action")
|
|
actionOutputParser
|
|
<&> AsyncOutput
|
|
in [idField, createdAtField, errorsField, outputField]
|
|
selectionSet =
|
|
let outputTypeName = unActionName actionName
|
|
desc = G.Description $ "fields of action: " <>> actionName
|
|
in P.selectionSet outputTypeName (Just desc) allFieldParsers
|
|
<&> parsedSelectionsToFields AsyncTypename
|
|
|
|
stringifyNum <- asks $ qcStringifyNum . getter
|
|
pure $
|
|
P.subselection fieldName description actionIdInputField selectionSet
|
|
<&> \(idArg, fields) ->
|
|
AnnActionAsyncQuery
|
|
{ _aaaqName = actionName,
|
|
_aaaqActionId = idArg,
|
|
_aaaqOutputType = _adOutputType definition,
|
|
_aaaqFields = fields,
|
|
_aaaqDefinitionList = mkDefinitionList outputObject,
|
|
_aaaqStringifyNum = stringifyNum,
|
|
_aaaqForwardClientHeaders = forwardClientHeaders,
|
|
_aaaqSource = getActionSourceInfo outputObject
|
|
}
|
|
where
|
|
ActionInfo actionName (outputType, outputObject) definition permissions forwardClientHeaders comment = actionInfo
|
|
idFieldName = $$(G.litName "id")
|
|
idFieldDescription = "the unique id of an action"
|
|
|
|
-- | Async action's unique id
|
|
actionIdParser ::
|
|
MonadParse n => Parser 'Both n ActionId
|
|
actionIdParser = ActionId <$> P.uuid
|
|
|
|
actionOutputFields ::
|
|
forall r m n.
|
|
MonadBuildSchema ('Postgres 'Vanilla) r m n =>
|
|
G.GType ->
|
|
AnnotatedObjectType ->
|
|
m (Parser 'Output n (AnnotatedFields ('Postgres 'Vanilla)))
|
|
actionOutputFields outputType annotatedObject = do
|
|
let outputObject = _aotDefinition annotatedObject
|
|
scalarOrEnumFields = map outputFieldParser $ toList $ _otdFields outputObject
|
|
relationshipFields <- forM (_otdRelationships outputObject) $ traverse relationshipFieldParser
|
|
let allFieldParsers =
|
|
scalarOrEnumFields
|
|
<> maybe [] (concat . catMaybes . toList) relationshipFields
|
|
outputTypeName = unObjectTypeName $ _otdName outputObject
|
|
outputTypeDescription = _otdDescription outputObject
|
|
pure $
|
|
outputParserModifier outputType $
|
|
P.selectionSet outputTypeName outputTypeDescription allFieldParsers
|
|
<&> parsedSelectionsToFields RQL.AFExpression
|
|
where
|
|
outputParserModifier :: G.GType -> Parser 'Output n a -> Parser 'Output n a
|
|
outputParserModifier = \case
|
|
G.TypeNamed (G.Nullability True) _ -> P.nullableParser
|
|
G.TypeNamed (G.Nullability False) _ -> P.nonNullableParser
|
|
G.TypeList (G.Nullability True) t -> P.nullableParser . P.multiple . outputParserModifier t
|
|
G.TypeList (G.Nullability False) t -> P.nonNullableParser . P.multiple . outputParserModifier t
|
|
|
|
outputFieldParser ::
|
|
ObjectFieldDefinition (G.GType, AnnotatedObjectFieldType) ->
|
|
FieldParser n (AnnotatedField ('Postgres 'Vanilla))
|
|
outputFieldParser (ObjectFieldDefinition name _ description (gType, objectFieldType)) =
|
|
let fieldName = unObjectFieldName name
|
|
selection = P.selection_ fieldName description $ case objectFieldType of
|
|
AOFTScalar def -> customScalarParser def
|
|
AOFTEnum def -> customEnumParser def
|
|
in P.wrapFieldParser gType selection $> RQL.mkAnnColumnField (unsafePGCol $ G.unName fieldName) (ColumnScalar PGJSON) Nothing Nothing
|
|
|
|
relationshipFieldParser ::
|
|
TypeRelationship (TableInfo ('Postgres 'Vanilla)) (ColumnInfo ('Postgres 'Vanilla)) ->
|
|
m (Maybe [FieldParser n (AnnotatedField ('Postgres 'Vanilla))])
|
|
relationshipFieldParser (TypeRelationship relName relType sourceName tableInfo fieldMapping) = runMaybeT do
|
|
let tableName = _tciName $ _tiCoreInfo tableInfo
|
|
fieldName = unRelationshipName relName
|
|
tableRelName = RelName $ mkNonEmptyTextUnsafe $ G.unName fieldName
|
|
columnMapping = Map.fromList $ do
|
|
(k, v) <- Map.toList fieldMapping
|
|
pure (unsafePGCol $ G.unName $ unObjectFieldName k, pgiColumn v)
|
|
roleName <- lift askRoleName
|
|
tablePerms <- hoistMaybe $ RQL.getPermInfoMaybe roleName PASelect tableInfo
|
|
case relType of
|
|
ObjRel -> do
|
|
let desc = Just $ G.Description "An object relationship"
|
|
selectionSetParser <- lift $ tableSelectionSet sourceName tableInfo tablePerms
|
|
pure $
|
|
pure $
|
|
P.nonNullableField $
|
|
P.subselection_ fieldName desc selectionSetParser
|
|
<&> \fields ->
|
|
RQL.AFObjectRelation $
|
|
RQL.AnnRelationSelectG tableRelName columnMapping $
|
|
RQL.AnnObjectSelectG fields tableName $
|
|
(fmap partialSQLExpToUnpreparedValue <$> spiFilter tablePerms)
|
|
ArrRel -> do
|
|
let desc = Just $ G.Description "An array relationship"
|
|
otherTableParser <- lift $ selectTable sourceName tableInfo fieldName desc tablePerms
|
|
let arrayRelField =
|
|
otherTableParser <&> \selectExp ->
|
|
RQL.AFArrayRelation $
|
|
RQL.ASSimple $ RQL.AnnRelationSelectG tableRelName columnMapping selectExp
|
|
relAggFieldName = fieldName <> $$(G.litName "_aggregate")
|
|
relAggDesc = Just $ G.Description "An aggregate relationship"
|
|
tableAggField <- lift $ selectTableAggregate sourceName tableInfo relAggFieldName relAggDesc tablePerms
|
|
pure $
|
|
catMaybes
|
|
[ Just arrayRelField,
|
|
fmap (RQL.AFArrayRelation . RQL.ASAggregate . RQL.AnnRelationSelectG tableRelName columnMapping) <$> tableAggField
|
|
]
|
|
|
|
mkDefinitionList :: AnnotatedObjectType -> [(PGCol, ScalarType ('Postgres 'Vanilla))]
|
|
mkDefinitionList AnnotatedObjectType {..} =
|
|
flip map (toList _otdFields) $ \ObjectFieldDefinition {..} ->
|
|
(unsafePGCol . G.unName . unObjectFieldName $ _ofdName,) $
|
|
case Map.lookup _ofdName fieldReferences of
|
|
Nothing -> fieldTypeToScalarType $ snd _ofdType
|
|
Just columnInfo -> unsafePGColumnToBackend $ pgiType columnInfo
|
|
where
|
|
ObjectTypeDefinition {..} = _aotDefinition
|
|
fieldReferences =
|
|
Map.unions $ map _trFieldMapping $ maybe [] toList _otdRelationships
|
|
|
|
actionInputArguments ::
|
|
forall m n r.
|
|
(MonadSchema n m, MonadTableInfo r m) =>
|
|
NonObjectTypeMap ->
|
|
[ArgumentDefinition (G.GType, NonObjectCustomType)] ->
|
|
m (InputFieldsParser n J.Value)
|
|
actionInputArguments nonObjectTypeMap arguments = do
|
|
argumentParsers <- for arguments $ \argument -> do
|
|
let ArgumentDefinition argumentName (gType, nonObjectType) argumentDescription = argument
|
|
name = unArgumentName argumentName
|
|
(name,) <$> argumentParser name argumentDescription gType nonObjectType
|
|
pure $ J.Object <$> inputFieldsToObject argumentParsers
|
|
where
|
|
inputFieldsToObject ::
|
|
[(G.Name, InputFieldsParser n (Maybe J.Value))] ->
|
|
InputFieldsParser n J.Object
|
|
inputFieldsToObject inputFields =
|
|
let mkTuple (name, parser) = fmap (G.unName name,) <$> parser
|
|
in Map.fromList . catMaybes <$> traverse mkTuple inputFields
|
|
|
|
argumentParser ::
|
|
G.Name ->
|
|
Maybe G.Description ->
|
|
G.GType ->
|
|
NonObjectCustomType ->
|
|
m (InputFieldsParser n (Maybe J.Value))
|
|
argumentParser name description gType nonObjectType = do
|
|
let mkResult :: forall k. ('Input P.<: k) => Parser k n J.Value -> InputFieldsParser n (Maybe J.Value)
|
|
mkResult = mkArgumentInputFieldParser name description gType
|
|
case nonObjectType of
|
|
-- scalar and enum parsers are not recursive and need not be memoized
|
|
NOCTScalar def -> pure $ mkResult $ customScalarParser def
|
|
NOCTEnum def -> pure $ mkResult $ customEnumParser def
|
|
-- input objects however may recursively contain one another
|
|
NOCTInputObject (InputObjectTypeDefinition (InputObjectTypeName objectName) objectDesc inputFields) ->
|
|
mkResult <$> memoizeOn 'actionInputArguments objectName do
|
|
inputFieldsParsers <- forM
|
|
(toList inputFields)
|
|
\(InputObjectFieldDefinition (InputObjectFieldName fieldName) fieldDesc (GraphQLType fieldType)) -> do
|
|
nonObjectFieldType <-
|
|
Map.lookup (G.getBaseType fieldType) nonObjectTypeMap
|
|
`onNothing` throw500 "object type for a field found in custom input object type"
|
|
(fieldName,) <$> argumentParser fieldName fieldDesc fieldType nonObjectFieldType
|
|
pure $
|
|
P.object objectName objectDesc $
|
|
J.Object <$> inputFieldsToObject inputFieldsParsers
|
|
|
|
mkArgumentInputFieldParser ::
|
|
forall m k.
|
|
(MonadParse m, 'Input P.<: k) =>
|
|
G.Name ->
|
|
Maybe G.Description ->
|
|
G.GType ->
|
|
Parser k m J.Value ->
|
|
InputFieldsParser m (Maybe J.Value)
|
|
mkArgumentInputFieldParser name description gType parser =
|
|
if G.isNullable gType
|
|
then P.fieldOptional name description modifiedParser
|
|
else Just <$> P.field name description modifiedParser
|
|
where
|
|
modifiedParser = parserModifier gType parser
|
|
|
|
parserModifier ::
|
|
G.GType -> Parser k m J.Value -> Parser k m J.Value
|
|
parserModifier = \case
|
|
G.TypeNamed nullable _ -> nullableModifier nullable
|
|
G.TypeList nullable ty ->
|
|
nullableModifier nullable . fmap J.toJSON . P.list . parserModifier ty
|
|
where
|
|
nullableModifier =
|
|
bool (fmap J.toJSON) (fmap J.toJSON . P.nullable) . G.unNullability
|
|
|
|
customScalarParser ::
|
|
MonadParse m =>
|
|
AnnotatedScalarType ->
|
|
Parser 'Both m J.Value
|
|
customScalarParser = \case
|
|
ASTCustom ScalarTypeDefinition {..} ->
|
|
if
|
|
| _stdName == idScalar -> J.toJSON <$> P.identifier
|
|
| _stdName == intScalar -> J.toJSON <$> P.int
|
|
| _stdName == floatScalar -> J.toJSON <$> P.float
|
|
| _stdName == stringScalar -> J.toJSON <$> P.string
|
|
| _stdName == boolScalar -> J.toJSON <$> P.boolean
|
|
| otherwise -> P.jsonScalar _stdName _stdDescription
|
|
ASTReusedScalar name pgScalarType ->
|
|
let schemaType = P.NonNullable $ P.TNamed $ P.mkDefinition name Nothing P.TIScalar
|
|
in P.Parser
|
|
{ pType = schemaType,
|
|
pParser =
|
|
P.valueToJSON (P.toGraphQLType schemaType)
|
|
>=> either
|
|
(parseErrorWith ParseFailed . qeError)
|
|
(pure . scalarValueToJSON @('Postgres 'Vanilla))
|
|
. parseScalarValue @('Postgres 'Vanilla) pgScalarType
|
|
}
|
|
|
|
customEnumParser ::
|
|
MonadParse m =>
|
|
EnumTypeDefinition ->
|
|
Parser 'Both m J.Value
|
|
customEnumParser (EnumTypeDefinition typeName description enumValues) =
|
|
let enumName = unEnumTypeName typeName
|
|
enumValueDefinitions =
|
|
enumValues <&> \enumValue ->
|
|
let valueName = G.unEnumValue $ _evdValue enumValue
|
|
in (,J.toJSON valueName) $
|
|
P.mkDefinition
|
|
valueName
|
|
(_evdDescription enumValue)
|
|
P.EnumValueInfo
|
|
in P.enum enumName description enumValueDefinitions
|