graphql-engine/server/src-lib/Hasura/GraphQL/Schema/Action.hs

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)

  outputTypeName <- P.mkTypename $ unActionName actionName
  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 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
  outputTypeName <- P.mkTypename $ unObjectTypeName $ _otdName outputObject
  let allFieldParsers =
        scalarOrEnumFields
          <> maybe [] (concat . catMaybes . toList) relationshipFields
      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