mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-17 20:41:49 +03:00
d91029ad51
### Description This PR removes all `fmapX` and `traverseX` functions from RQL.IR, favouring instead `Functor` and `Traversable` instances throughout the code. This was a relatively straightforward change, except for two small pain points: `AnnSelectG` and `AnnInsert`. Both were parametric over two types `a` and `v`, making it impossible to make them traversable functors... But it turns out that in every single use case, `a ~ f v`. By changing those types to take such an `f :: Type -> Type` as an argument instead of `a :: Type` makes it possible to make them functors. The only small difference is for `AnnIns`, I had to introduce one `Identity` transformation for one of the `f` parameters. This is relatively straightforward. ### Notes This PR fixes the most verbose BigQuery hint (`let` instead of `<- pure`). https://github.com/hasura/graphql-engine-mono/pull/1668 GitOrigin-RevId: e632263a8c559aa04aeae10dcaec915b4a81ad1a
361 lines
18 KiB
Haskell
361 lines
18 KiB
Haskell
module Hasura.GraphQL.Schema.Action
|
|
( actionExecute
|
|
, actionAsyncMutation
|
|
, actionAsyncQuery
|
|
) where
|
|
|
|
import Hasura.Prelude
|
|
|
|
import qualified Data.Aeson as J
|
|
import qualified Data.HashMap.Strict as Map
|
|
import qualified Language.GraphQL.Draft.Syntax as G
|
|
|
|
import Data.Has
|
|
import Data.Text.Extended
|
|
import Data.Text.NonEmpty
|
|
|
|
import qualified Hasura.GraphQL.Parser as P
|
|
import qualified Hasura.GraphQL.Parser.Internal.Parser as P
|
|
import qualified Hasura.RQL.DML.Internal as RQL
|
|
import qualified Hasura.RQL.IR.Select as RQL
|
|
|
|
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.Class
|
|
import Hasura.GraphQL.Schema.Backend
|
|
import Hasura.GraphQL.Schema.Common
|
|
import Hasura.GraphQL.Schema.Select
|
|
import Hasura.RQL.Types
|
|
import Hasura.Session
|
|
|
|
|
|
-- | 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) 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
|
|
}
|
|
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) 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 (RQL.AnnFieldsG ('Postgres 'Vanilla) UnpreparedValue (UnpreparedValue ('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 (RQL.AnnFieldG ('Postgres 'Vanilla) UnpreparedValue (UnpreparedValue ('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
|
|
fieldParser = \case
|
|
G.TypeNamed (G.Nullability True) _ -> P.nullableField selection
|
|
G.TypeNamed (G.Nullability False) _ -> P.nonNullableField selection
|
|
G.TypeList (G.Nullability True) t -> P.nullableField $ P.multipleField $ fieldParser t
|
|
G.TypeList (G.Nullability False) t -> P.nonNullableField $ P.multipleField $ fieldParser t
|
|
pgColumnInfo =
|
|
ColumnInfo (unsafePGCol $ G.unName fieldName) fieldName 0 (ColumnScalar PGJSON) (G.isNullable gType) Nothing
|
|
in fieldParser gType $> RQL.mkAnnColumnField pgColumnInfo Nothing Nothing
|
|
|
|
relationshipFieldParser
|
|
:: TypeRelationship (TableInfo ('Postgres 'Vanilla)) (ColumnInfo ('Postgres 'Vanilla))
|
|
-> m (Maybe [FieldParser n (RQL.AnnFieldG ('Postgres 'Vanilla) UnpreparedValue (UnpreparedValue ('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 . 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
|