graphql-engine/server/src-lib/Hasura/Backends/Postgres/DDL/ComputedField.hs

-- | Postgres DDL ComputedField
--
-- How to build the 'ComputedFieldInfo' for a field.
--
-- See 'Hasura.RQL.Types.Metadata.Backend'.
module Hasura.Backends.Postgres.DDL.ComputedField
  ( buildComputedFieldInfo,
  )
where

import Control.Monad.Validate qualified as MV
import Data.HashSet qualified as S
import Data.Sequence qualified as Seq
import Data.Text.Extended
import Hasura.Backends.Postgres.DDL.Function
import Hasura.Backends.Postgres.SQL.Types
import Hasura.Base.Error
import Hasura.Prelude
import Hasura.RQL.Types.Common (Comment (..))
import Hasura.RQL.Types.ComputedField
import Hasura.RQL.Types.Function
import Hasura.SQL.Backend
import Hasura.SQL.Types
import Hasura.Server.Utils
import Language.GraphQL.Draft.Syntax qualified as G

data ComputedFieldValidateError
  = CFVENotValidGraphQLName !ComputedFieldName
  | CFVEInvalidTableArgument !InvalidTableArgument
  | CFVEInvalidSessionArgument !InvalidSessionArgument
  | CFVENotBaseReturnType !PGScalarType
  | CFVEReturnTableNotFound !QualifiedTable
  | CFVENoInputArguments
  | CFVEFunctionVolatile
  deriving (Show, Eq)

data InvalidTableArgument
  = ITANotFound !FunctionArgName
  | ITANotComposite !FunctionTableArgument
  | ITANotTable !QualifiedTable !FunctionTableArgument
  deriving (Show, Eq)

data InvalidSessionArgument
  = ISANotFound !FunctionArgName
  | ISANotJSON !FunctionSessionArgument
  deriving (Show, Eq)

showError :: QualifiedFunction -> ComputedFieldValidateError -> Text
showError qf = \case
  CFVENotValidGraphQLName computedField ->
    computedField <<> " is not valid GraphQL name"
  CFVEInvalidTableArgument (ITANotFound argName) ->
    argName <<> " is not an input argument of the function " <>> qf
  CFVEInvalidTableArgument (ITANotComposite functionArg) ->
    showFunctionTableArgument functionArg <> " is not COMPOSITE type"
  CFVEInvalidTableArgument (ITANotTable ty functionArg) ->
    showFunctionTableArgument functionArg <> " of type " <> ty
      <<> " is not the table to which the computed field is being added"
  CFVEInvalidSessionArgument (ISANotFound argName) ->
    argName <<> " is not an input argument of the function " <>> qf
  CFVEInvalidSessionArgument (ISANotJSON functionArg) ->
    showFunctionSessionArgument functionArg <> " is not of type JSON"
  CFVENotBaseReturnType scalarType ->
    "the function " <> qf <<> " returning type " <> toSQLTxt scalarType
      <> " is not a BASE type"
  CFVEReturnTableNotFound table ->
    "the function " <> qf <<> " returning set of table " <> table
      <<> " is not tracked or not found in database"
  CFVENoInputArguments ->
    "the function " <> qf <<> " has no input arguments"
  CFVEFunctionVolatile ->
    "the function " <> qf <<> " is of type VOLATILE; cannot be added as a computed field"
  where
    showFunctionTableArgument = \case
      FTAFirst -> "first argument of the function " <>> qf
      FTANamed argName _ -> argName <<> " argument of the function " <>> qf
    showFunctionSessionArgument = \case
      FunctionSessionArgument argName _ -> argName <<> " argument of the function " <>> qf

buildComputedFieldInfo ::
  forall pgKind m.
  (QErrM m) =>
  -- | the set of all tracked tables
  S.HashSet QualifiedTable ->
  QualifiedTable ->
  ComputedFieldName ->
  ComputedFieldDefinition ('Postgres pgKind) ->
  PGRawFunctionInfo ->
  Comment ->
  m (ComputedFieldInfo ('Postgres pgKind))
buildComputedFieldInfo trackedTables table computedField definition rawFunctionInfo comment =
  either (throw400 NotSupported . showErrors) pure =<< MV.runValidateT mkComputedFieldInfo
  where
    inputArgNames = rfiInputArgNames rawFunctionInfo
    ComputedFieldDefinition function maybeTableArg maybeSessionArg = definition
    functionReturnType =
      QualifiedPGType
        (rfiReturnTypeSchema rawFunctionInfo)
        (rfiReturnTypeName rawFunctionInfo)
        (rfiReturnTypeType rawFunctionInfo)

    computedFieldGraphQLName = G.mkName $ computedFieldNameToText computedField

    mkComputedFieldInfo ::
      MV.MonadValidate [ComputedFieldValidateError] n =>
      n (ComputedFieldInfo ('Postgres pgKind))
    mkComputedFieldInfo = do
      -- Check if computed field name is a valid GraphQL name
      unless (isJust computedFieldGraphQLName) $
        MV.dispute $ pure $ CFVENotValidGraphQLName computedField

      -- Check if function is VOLATILE
      when (rfiFunctionType rawFunctionInfo == FTVOLATILE) $
        MV.dispute $ pure CFVEFunctionVolatile

      -- Validate and resolve return type
      returnType <-
        if rfiReturnsTable rawFunctionInfo
          then do
            let returnTable = typeToTable functionReturnType
            unless (returnTable `S.member` trackedTables) $
              MV.dispute $
                pure $
                  CFVEReturnTableNotFound returnTable
            pure $ CFRSetofTable returnTable
          else do
            let scalarType = _qptName functionReturnType
            unless (isBaseType functionReturnType) $
              MV.dispute $
                pure $
                  CFVENotBaseReturnType scalarType
            pure $ CFRScalar scalarType

      -- Validate and resolve table argument
      let inputArgs =
            mkFunctionArgs
              (rfiDefaultArgs rawFunctionInfo)
              (rfiInputArgTypes rawFunctionInfo)
              inputArgNames
      tableArgument <- case maybeTableArg of
        Just argName ->
          case findWithIndex ((Just argName ==) . faName) inputArgs of
            Just (tableArg, index) -> do
              let functionTableArg = FTANamed argName index
              validateTableArgumentType functionTableArg $ faType tableArg
              pure functionTableArg
            Nothing ->
              MV.refute $ pure $ CFVEInvalidTableArgument $ ITANotFound argName
        Nothing -> do
          case inputArgs of
            [] -> MV.dispute $ pure CFVENoInputArguments
            (firstArg : _) ->
              validateTableArgumentType FTAFirst $ faType firstArg
          pure FTAFirst

      maybePGSessionArg <- sequence $ do
        argName <- maybeSessionArg
        return $ case findWithIndex ((Just argName ==) . faName) inputArgs of
          Just (sessionArg, index) -> do
            let functionSessionArg = FunctionSessionArgument argName index
            validateSessionArgumentType functionSessionArg $ faType sessionArg
            pure functionSessionArg
          Nothing ->
            MV.refute $ pure $ CFVEInvalidSessionArgument $ ISANotFound argName

      let inputArgSeq =
            Seq.fromList $
              dropTableAndSessionArgument tableArgument maybePGSessionArg inputArgs
          computedFieldFunction =
            ComputedFieldFunction function inputArgSeq tableArgument maybePGSessionArg $
              rfiDescription rawFunctionInfo

      pure $ ComputedFieldInfo @('Postgres pgKind) () computedField computedFieldFunction returnType description

    validateTableArgumentType ::
      (MV.MonadValidate [ComputedFieldValidateError] n) =>
      FunctionTableArgument ->
      QualifiedPGType ->
      n ()
    validateTableArgumentType tableArg qpt = do
      when (_qptType qpt /= PGKindComposite) $
        MV.dispute $ pure $ CFVEInvalidTableArgument $ ITANotComposite tableArg
      let typeTable = typeToTable qpt
      unless (table == typeTable) $
        MV.dispute $ pure $ CFVEInvalidTableArgument $ ITANotTable typeTable tableArg

    validateSessionArgumentType ::
      (MV.MonadValidate [ComputedFieldValidateError] n) =>
      FunctionSessionArgument ->
      QualifiedPGType ->
      n ()
    validateSessionArgumentType sessionArg qpt = do
      unless (isJSONType $ _qptName qpt) $
        MV.dispute $ pure $ CFVEInvalidSessionArgument $ ISANotJSON sessionArg

    showErrors :: [ComputedFieldValidateError] -> Text
    showErrors allErrors =
      "the computed field " <> computedField <<> " cannot be added to table "
        <> table <<> " "
        <> reasonMessage
      where
        reasonMessage = makeReasonMessage allErrors (showError function)

    dropTableAndSessionArgument ::
      FunctionTableArgument ->
      Maybe FunctionSessionArgument ->
      [FunctionArg ('Postgres pgKind)] ->
      [FunctionArg ('Postgres pgKind)]
    dropTableAndSessionArgument tableArg sessionArg inputArgs =
      let withoutTable = case tableArg of
            FTAFirst -> tail inputArgs
            FTANamed argName _ ->
              filter ((/=) (Just argName) . faName) inputArgs
          alsoWithoutSession = case sessionArg of
            Nothing -> withoutTable
            Just (FunctionSessionArgument name _) ->
              filter ((/=) (Just name) . faName) withoutTable
       in alsoWithoutSession

    description :: Maybe Text
    description =
      case comment of
        Automatic -> commentFromDatabase <|> Just autogeneratedDescription
        Explicit value -> toTxt <$> value
      where
        commentFromDatabase = getPGDescription <$> rfiDescription rawFunctionInfo
        autogeneratedDescription =
          "A computed field, executes function " <>> function