graphql-engine/server/src-lib/Hasura/RQL/DDL/RemoteRelationship/Validate.hs

{-# LANGUAGE ViewPatterns #-}

-- | Validate input queries against remote schemas.
module Hasura.RQL.DDL.RemoteRelationship.Validate
  ( validateToSchemaRelationship,
    errorToText,
  )
where

import Data.HashMap.Strict.Extended qualified as HM
import Data.HashSet qualified as HS
import Data.List.NonEmpty qualified as NE
import Data.Text.Extended
import Hasura.GraphQL.Parser.Constants qualified as G
import Hasura.Prelude hiding (first)
import Hasura.RQL.Types.Common
import Hasura.RQL.Types.Relationships.Remote
import Hasura.RQL.Types.Relationships.ToSchema
import Hasura.RQL.Types.RemoteSchema
import Hasura.RQL.Types.SchemaCache
import Hasura.Server.Utils (englishList)
import Language.GraphQL.Draft.Syntax qualified as G

-- | An error validating the remote relationship.
data ValidationError
  = RemoteSchemaNotFound !RemoteSchemaName
  | CouldntFindRemoteField !G.Name !G.Name
  | FieldNotFoundInRemoteSchema !G.Name
  | NoSuchArgumentForRemote !G.Name
  | MissingRequiredArgument !G.Name
  | TypeNotFound !G.Name
  | JoinFieldNonExistent !LHSIdentifier !FieldName !(HS.HashSet FieldName)
  | ExpectedTypeButGot !G.GType !G.GType
  | InvalidType !G.GType !Text
  | InvalidVariable !G.Name !(HS.HashSet G.Name)
  | NullNotAllowedHere
  | InvalidGTypeForStripping !G.GType
  | UnsupportedMultipleElementLists
  | UnsupportedEnum
  | InvalidGraphQLName !Text
  | IDTypeJoin !G.Name
  | -- | TODO: Can this be made not reachable?
    -- This is the case where the type of the columns that are mapped do not
    -- have a graphql representation. This case is probably not reachable as
    -- having a db type which can't be representable in GraphQL should definitely
    -- fail the entire schema generation process
    CannotGenerateGraphQLTypeName !G.Name
  deriving (Show, Eq)

errorToText :: ValidationError -> Text
errorToText = \case
  RemoteSchemaNotFound name ->
    "remote schema with name " <> name <<> " not found"
  CouldntFindRemoteField name ty ->
    "remote field with name " <> name <<> " and type " <> ty <<> " not found"
  FieldNotFoundInRemoteSchema name ->
    "field with name " <> name <<> " not found in remote schema"
  NoSuchArgumentForRemote name ->
    "argument with name " <> name <<> " not found in remote schema"
  MissingRequiredArgument name ->
    "required argument with name " <> name <<> " is missing"
  TypeNotFound ty ->
    "type with name " <> ty <<> " not found"
  JoinFieldNonExistent (LHSIdentifier lhs) fieldName allowedJoinFields ->
    let helpText =
          case NE.nonEmpty $ map dquote $ toList allowedJoinFields of
            Nothing -> ""
            Just allowedFields -> ", the allowed fields are " <> englishList "or" allowedFields
     in "field with name " <> fieldName <<> "is not provided by the lhs entity" <>> lhs
          <<> "for defining a join condition" <> helpText
  ExpectedTypeButGot expTy actualTy ->
    "expected type " <> G.getBaseType expTy <<> " but got " <>> G.getBaseType actualTy
  InvalidType ty err ->
    "type " <> G.getBaseType ty <<> err
  InvalidVariable var _ ->
    "variable " <> var <<> " is not found"
  NullNotAllowedHere ->
    "null is not allowed here"
  InvalidGTypeForStripping ty ->
    "type " <> G.getBaseType ty <<> " is invalid for stripping"
  UnsupportedMultipleElementLists ->
    "multiple elements in list value is not supported"
  UnsupportedEnum ->
    "enum value is not supported"
  InvalidGraphQLName t ->
    t <<> " is not a valid GraphQL identifier"
  IDTypeJoin typeName ->
    "Only ID, Int, uuid or String scalar types can be joined to the ID type, but received " <>> typeName
  CannotGenerateGraphQLTypeName typeName ->
    "the name of the scalar type " <> toTxt typeName
      <> " is not a valid GraphQL identifier, "
      <> " so columns of such type cannot be used in a remote schema mapping "

-- | Validate a remote schema relationship given a context.
validateToSchemaRelationship ::
  (MonadError ValidationError m) =>
  ToSchemaRelationshipDef ->
  LHSIdentifier ->
  RelName ->
  (RemoteSchemaInfo, IntrospectionResult) ->
  HM.HashMap FieldName joinField ->
  m (HM.HashMap FieldName joinField, RemoteSchemaFieldInfo)
validateToSchemaRelationship schema lhsIdentifier name (remoteSchemaInfo, introspectionResult) lhsJoinFields = do
  let remoteSchemaName = _trrdRemoteSchema schema
  requiredLHSJoinFields <- forM (toList $ _trrdLhsFields schema) $ \fieldName -> do
    fmap (fieldName,) $
      onNothing (HM.lookup fieldName lhsJoinFields) $
        throwError $ JoinFieldNonExistent lhsIdentifier fieldName $ HM.keysSet lhsJoinFields
  hasuraFieldsVariablesMap <-
    fmap HM.fromList $ for requiredLHSJoinFields $ \(fieldName, field) -> (,field) <$> hasuraFieldToVariable fieldName
  let schemaDoc = irDoc introspectionResult
      queryRootName = irQueryRoot introspectionResult
  queryRoot <-
    onNothing (lookupObject schemaDoc queryRootName) $
      throwError $ FieldNotFoundInRemoteSchema queryRootName
  (_, (leafParamMap, leafTypeMap)) <-
    foldlM
      (buildRelationshipTypeInfo hasuraFieldsVariablesMap schemaDoc)
      (queryRoot, (mempty, mempty))
      (unRemoteFields $ _trrdRemoteField schema)
  pure $
    (HM.fromList requiredLHSJoinFields,) $
      RemoteSchemaFieldInfo
        { _rrfiName = name,
          _rrfiParamMap = leafParamMap,
          _rrfiRemoteFields = _trrdRemoteField schema,
          _rrfiRemoteSchema = remoteSchemaInfo,
          -- adding the new input types after stripping the values of the
          -- schema document
          _rrfiInputValueDefinitions = HM.elems leafTypeMap,
          _rrfiRemoteSchemaName = remoteSchemaName,
          _rrfiLHSIdentifier = lhsIdentifier
        }
  where
    getObjTyInfoFromField ::
      RemoteSchemaIntrospection ->
      G.FieldDefinition RemoteSchemaInputValueDefinition ->
      Maybe (G.ObjectTypeDefinition RemoteSchemaInputValueDefinition)
    getObjTyInfoFromField schemaDoc field =
      let baseTy = G.getBaseType (G._fldType field)
       in lookupObject schemaDoc baseTy

    isValidType schemaDoc field =
      let baseTy = G.getBaseType (G._fldType field)
       in case lookupType schemaDoc baseTy of
            Just (G.TypeDefinitionScalar _) -> True
            Just (G.TypeDefinitionInterface _) -> True
            Just (G.TypeDefinitionUnion _) -> True
            Just (G.TypeDefinitionEnum _) -> True
            _ -> False

    buildRelationshipTypeInfo ::
      (MonadError ValidationError m) =>
      HashMap G.Name joinField ->
      RemoteSchemaIntrospection ->
      ( G.ObjectTypeDefinition RemoteSchemaInputValueDefinition,
        ( HashMap G.Name RemoteSchemaInputValueDefinition,
          HashMap G.Name (G.TypeDefinition [G.Name] RemoteSchemaInputValueDefinition)
        )
      ) ->
      FieldCall ->
      m
        ( G.ObjectTypeDefinition RemoteSchemaInputValueDefinition,
          ( HashMap G.Name RemoteSchemaInputValueDefinition,
            HashMap G.Name (G.TypeDefinition [G.Name] RemoteSchemaInputValueDefinition)
          )
        )
    buildRelationshipTypeInfo hasuraFieldsVariablesMap schemaDoc (objTyInfo, (_, typeMap)) fieldCall = do
      objFldDefinition <- lookupField (fcName fieldCall) objTyInfo
      let providedArguments = getRemoteArguments $ fcArguments fieldCall
      validateRemoteArguments
        (mapFromL (G._ivdName . _rsitdDefinition) (G._fldArgumentsDefinition objFldDefinition))
        providedArguments
        hasuraFieldsVariablesMap
        schemaDoc
      let eitherParamAndTypeMap =
            runStateT
              ( stripInMap
                  name
                  lhsIdentifier
                  schemaDoc
                  (mapFromL (G._ivdName . _rsitdDefinition) (G._fldArgumentsDefinition objFldDefinition))
                  providedArguments
              )
              typeMap
      (newParamMap, newTypeMap) <- onLeft eitherParamAndTypeMap throwError
      innerObjTyInfo <-
        onNothing (getObjTyInfoFromField schemaDoc objFldDefinition) $
          bool
            ( throwError $
                InvalidType (G._fldType objFldDefinition) "only output type is expected"
            )
            (pure objTyInfo)
            (isValidType schemaDoc objFldDefinition)
      pure
        ( innerObjTyInfo,
          (newParamMap, newTypeMap)
        )

-- | Return a map with keys deleted whose template argument is
-- specified as an atomic (variable, constant), keys which are kept
-- have their values modified by 'stripObject' or 'stripList'.
-- This function creates the 'HashMap G.Name G.InputValueDefinition' which modifies
-- the original input parameters (if any) of the remote node/table being used. Only
-- list or object types are preserved and other types are stripped off. The object or
-- list types are preserved because they can be merged, if any arguments are
-- provided by the user while querying a remote join field.
stripInMap ::
  RelName ->
  LHSIdentifier ->
  RemoteSchemaIntrospection ->
  HM.HashMap G.Name RemoteSchemaInputValueDefinition ->
  HM.HashMap G.Name (G.Value G.Name) ->
  StateT
    (HashMap G.Name (G.TypeDefinition [G.Name] RemoteSchemaInputValueDefinition))
    (Either ValidationError)
    (HM.HashMap G.Name RemoteSchemaInputValueDefinition)
stripInMap relName lhsIdentifier types schemaArguments providedArguments =
  fmap HM.catMaybes $
    HM.traverseWithKey
      ( \name remoteInpValDef@(RemoteSchemaInputValueDefinition inpValInfo _preset) ->
          case HM.lookup name providedArguments of
            Nothing -> pure $ Just remoteInpValDef
            Just value -> do
              maybeNewGType <- stripValue relName lhsIdentifier types (G._ivdType inpValInfo) value
              pure $
                fmap
                  ( \newGType ->
                      let newInpValInfo = inpValInfo {G._ivdType = newGType}
                       in RemoteSchemaInputValueDefinition newInpValInfo Nothing
                  )
                  maybeNewGType
      )
      schemaArguments

-- | Strip a value type completely, or modify it, if the given value
-- is atomic-ish.
stripValue ::
  RelName ->
  LHSIdentifier ->
  RemoteSchemaIntrospection ->
  G.GType ->
  G.Value G.Name ->
  StateT
    (HashMap G.Name (G.TypeDefinition [G.Name] RemoteSchemaInputValueDefinition))
    (Either ValidationError)
    (Maybe G.GType)
stripValue name lhsIdentifier types gtype value = do
  case value of
    G.VVariable {} -> pure Nothing
    G.VInt {} -> pure Nothing
    G.VFloat {} -> pure Nothing
    G.VString {} -> pure Nothing
    G.VBoolean {} -> pure Nothing
    G.VNull {} -> pure Nothing
    G.VEnum {} -> pure Nothing
    G.VList values ->
      case values of
        [] -> pure Nothing
        [gvalue] -> stripList name lhsIdentifier types gtype gvalue
        _ -> lift (Left UnsupportedMultipleElementLists)
    G.VObject keyPairs ->
      fmap Just (stripObject name lhsIdentifier types gtype keyPairs)

-- | Produce a new type for the list, or strip it entirely.
stripList ::
  RelName ->
  LHSIdentifier ->
  RemoteSchemaIntrospection ->
  G.GType ->
  G.Value G.Name ->
  StateT
    (HashMap G.Name (G.TypeDefinition [G.Name] RemoteSchemaInputValueDefinition))
    (Either ValidationError)
    (Maybe G.GType)
stripList name lhsIdentifier types originalOuterGType value =
  case originalOuterGType of
    G.TypeList nullability innerGType -> do
      maybeNewInnerGType <- stripValue name lhsIdentifier types innerGType value
      pure (G.TypeList nullability <$> maybeNewInnerGType)
    _ -> lift (Left (InvalidGTypeForStripping originalOuterGType))

-- | Produce a new type for the given InpValInfo, modified by
-- 'stripInMap'. Objects can't be deleted entirely, just keys of an
-- object.
stripObject ::
  RelName ->
  LHSIdentifier ->
  RemoteSchemaIntrospection ->
  G.GType ->
  HashMap G.Name (G.Value G.Name) ->
  StateT
    (HashMap G.Name (G.TypeDefinition [G.Name] RemoteSchemaInputValueDefinition))
    (Either ValidationError)
    G.GType
stripObject name lhsIdentifier schemaDoc originalGtype templateArguments =
  case originalGtype of
    G.TypeNamed nullability originalNamedType ->
      case lookupType schemaDoc (G.getBaseType originalGtype) of
        Just (G.TypeDefinitionInputObject originalInpObjTyInfo) -> do
          let originalSchemaArguments =
                mapFromL (G._ivdName . _rsitdDefinition) $ G._iotdValueDefinitions originalInpObjTyInfo
          newNamedType <-
            renameTypeForRelationship name lhsIdentifier originalNamedType
          newSchemaArguments <-
            stripInMap
              name
              lhsIdentifier
              schemaDoc
              originalSchemaArguments
              templateArguments
          let newInpObjTyInfo =
                originalInpObjTyInfo
                  { G._iotdValueDefinitions = HM.elems newSchemaArguments,
                    G._iotdName = newNamedType
                  }
              newGtype = G.TypeNamed nullability newNamedType
          modify (HM.insert newNamedType (G.TypeDefinitionInputObject newInpObjTyInfo))
          pure newGtype
        _ -> lift (Left (InvalidGTypeForStripping originalGtype))
    _ -> lift (Left (InvalidGTypeForStripping originalGtype))

-- | Produce a new name for a type, used when stripping the schema
-- types for a remote relationship.
-- TODO: Consider a separator character to avoid conflicts.
renameTypeForRelationship ::
  MonadError ValidationError m =>
  RelName ->
  LHSIdentifier ->
  G.Name ->
  m G.Name
renameTypeForRelationship (relNameToTxt -> relTxt) lhsIdentifier name = do
  lhsName <-
    lhsIdentifierToGraphQLName lhsIdentifier
      `onNothing` throwError (InvalidGraphQLName $ getLHSIdentifier lhsIdentifier)
  relName <-
    G.mkName relTxt
      `onNothing` throwError (InvalidGraphQLName relTxt)
  pure $
    name <> G.__remote_rel_ <> lhsName <> relName

-- | Convert a field name to a variable name.
hasuraFieldToVariable ::
  (MonadError ValidationError m) =>
  FieldName ->
  m G.Name
hasuraFieldToVariable (FieldName fieldText) = do
  G.mkName fieldText `onNothing` throwError (InvalidGraphQLName fieldText)

-- | Lookup the field in the schema.
lookupField ::
  (MonadError ValidationError m) =>
  G.Name ->
  G.ObjectTypeDefinition RemoteSchemaInputValueDefinition ->
  m (G.FieldDefinition RemoteSchemaInputValueDefinition)
lookupField name objFldInfo = viaObject objFldInfo
  where
    viaObject =
      maybe (throwError (CouldntFindRemoteField name $ G._otdName objFldInfo)) pure
        . lookup name
        . HM.toList
        . mapFromL G._fldName
        . G._otdFieldsDefinition

-- | Validate remote input arguments against the remote schema.
validateRemoteArguments ::
  (MonadError ValidationError m) =>
  HM.HashMap G.Name RemoteSchemaInputValueDefinition ->
  HM.HashMap G.Name (G.Value G.Name) ->
  HM.HashMap G.Name joinField ->
  RemoteSchemaIntrospection ->
  m ()
validateRemoteArguments expectedArguments providedArguments permittedVariables schemaDocument = do
  traverse_ validateProvided (HM.toList providedArguments)
  where
    -- Not neccessary to validate if all required args are provided in the relationship
    -- traverse validateExpected (HM.toList expectedArguments)

    validateProvided (providedName, providedValue) =
      case HM.lookup providedName expectedArguments of
        Nothing -> throwError (NoSuchArgumentForRemote providedName)
        Just (G._ivdType . _rsitdDefinition -> expectedType) ->
          validateType permittedVariables providedValue expectedType schemaDocument

unwrapGraphQLType :: G.GType -> G.GType
unwrapGraphQLType = \case
  G.TypeList _ lt -> lt
  nt -> nt

-- | Validate a value against a type.
validateType ::
  (MonadError ValidationError m) =>
  HM.HashMap G.Name joinField ->
  G.Value G.Name ->
  G.GType ->
  RemoteSchemaIntrospection ->
  m ()
validateType permittedVariables value expectedGType schemaDocument =
  case value of
    G.VVariable variable ->
      case HM.lookup variable permittedVariables of
        Nothing -> throwError (InvalidVariable variable $ HM.keysSet permittedVariables)
        -- TODO: check whether the type of lhs join field is allowed
        Just _lhsJoinField -> pure ()
    G.VInt {} -> do
      let intScalarGType = mkGraphQLType intScalar
      isTypeCoercible intScalarGType expectedGType
    G.VFloat {} -> do
      let floatScalarGType = mkGraphQLType floatScalar
      isTypeCoercible floatScalarGType expectedGType
    G.VBoolean {} -> do
      let boolScalarGType = mkGraphQLType boolScalar
      isTypeCoercible boolScalarGType expectedGType
    G.VNull -> throwError NullNotAllowedHere
    G.VString {} -> do
      let stringScalarGType = mkGraphQLType stringScalar
      isTypeCoercible stringScalarGType expectedGType
    G.VEnum _ -> throwError UnsupportedEnum
    G.VList values -> do
      case values of
        [] -> pure ()
        [_] -> pure ()
        _ -> throwError UnsupportedMultipleElementLists
      assertListType expectedGType
      for_
        values
        ( \val ->
            validateType permittedVariables val (unwrapGraphQLType expectedGType) schemaDocument
        )
    G.VObject values ->
      for_
        (HM.toList values)
        ( \(name, val) ->
            let expectedNamedType = G.getBaseType expectedGType
             in case lookupType schemaDocument expectedNamedType of
                  Nothing -> throwError $ TypeNotFound expectedNamedType
                  Just typeInfo ->
                    case typeInfo of
                      G.TypeDefinitionInputObject inpObjTypeInfo ->
                        let objectTypeDefnsMap =
                              mapFromL (G._ivdName . _rsitdDefinition) $ G._iotdValueDefinitions inpObjTypeInfo
                         in case HM.lookup name objectTypeDefnsMap of
                              Nothing -> throwError $ NoSuchArgumentForRemote name
                              Just (G._ivdType . _rsitdDefinition -> expectedType) ->
                                validateType permittedVariables val expectedType schemaDocument
                      _ -> do
                        throwError $ InvalidType (mkGraphQLType name) "not an input object type"
        )
  where
    mkGraphQLType =
      G.TypeNamed (G.Nullability False)

isTypeCoercible ::
  (MonadError ValidationError m) =>
  G.GType ->
  G.GType ->
  m ()
isTypeCoercible actualType expectedType =
  -- The GraphQL spec says that, a singleton type can be coerced into  an array
  -- type. Which means that if the 'actualType' is a singleton type, like
  -- 'Int' we should be able to join this with a remote node, which expects an
  -- input argument of type '[Int]'
  -- http://spec.graphql.org/June2018/#sec-Type-System.List
  let (actualBaseType, actualNestingLevel) = getBaseTyWithNestedLevelsCount actualType
      (expectedBaseType, expectedNestingLevel) = getBaseTyWithNestedLevelsCount expectedType
   in if
          | expectedBaseType == G._ID ->
            bool
              (throwError $ IDTypeJoin actualBaseType)
              (pure ())
              -- Check under `Input Coercion` https://spec.graphql.org/June2018/#sec-ID
              -- We can also include the `ID` type in the below list but it will be
              -- extraneous because at the time of writing this, we don't generate
              -- the `ID` type in the DB schema
              ( G.unName actualBaseType
                  `elem` ["ID", "Int", "String", "bigint", "smallint", "uuid"]
              )
          | actualBaseType /= expectedBaseType -> raiseValidationError
          -- we cannot coerce two types with different nesting levels,
          -- for example, we cannot coerce [Int] to [[Int]]
          | (actualNestingLevel == expectedNestingLevel || actualNestingLevel == 0) -> pure ()
          | otherwise -> raiseValidationError
  where
    raiseValidationError = throwError $ ExpectedTypeButGot expectedType actualType

assertListType ::
  (MonadError ValidationError m) =>
  G.GType ->
  m ()
assertListType actualType =
  unless
    (G.isListType actualType)
    (throwError $ InvalidType actualType "is not a list type")

getBaseTyWithNestedLevelsCount :: G.GType -> (G.Name, Int)
getBaseTyWithNestedLevelsCount ty = go ty 0
  where
    go :: G.GType -> Int -> (G.Name, Int)
    go gType ctr =
      case gType of
        G.TypeNamed _ n -> (n, ctr)
        G.TypeList _ gType' -> go gType' (ctr + 1)