{-# LANGUAGE ViewPatterns #-}

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

import Data.HashMap.Strict qualified as HM
import Data.HashSet qualified as HS
import Data.Text.Extended
import Hasura.Prelude hiding (first)
import Hasura.RQL.Types.Backend
import Hasura.RQL.Types.Column
import Hasura.RQL.Types.Common
import Hasura.RQL.Types.ComputedField
import Hasura.RQL.Types.RemoteRelationship
import Hasura.RQL.Types.RemoteSchema
import Hasura.RQL.Types.SchemaCache
import Hasura.SQL.Backend
import Language.GraphQL.Draft.Syntax qualified as G

-- | An error validating the remote relationship.
data ValidationError (b :: BackendType)
  = RemoteSchemaNotFound !RemoteSchemaName
  | CouldntFindRemoteField !G.Name !G.Name
  | FieldNotFoundInRemoteSchema !G.Name
  | NoSuchArgumentForRemote !G.Name
  | MissingRequiredArgument !G.Name
  | TypeNotFound !G.Name
  | TableNotFound !(TableName b)
  | TableFieldNonexistent !(TableName b) !FieldName
  | TableFieldNotSupported !FieldName
  | TableComputedFieldWithInputArgs !FieldName !(FunctionName b)
  | ExpectedTypeButGot !G.GType !G.GType
  | InvalidType !G.GType !Text
  | InvalidVariable !G.Name !(HM.HashMap G.Name (DBJoinField b))
  | NullNotAllowedHere
  | InvalidGTypeForStripping !G.GType
  | UnsupportedMultipleElementLists
  | UnsupportedEnum
  | UnsupportedTableComputedField !(TableName b) !ComputedFieldName
  | InvalidGraphQLName !Text
  | IDTypeJoin !G.Name
  | -- | 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 !(ScalarType b)

deriving instance Backend b => Eq (ValidationError b)

errorToText :: Backend b => ValidationError b -> 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"
  TableNotFound name ->
    "table with name " <> name <<> " not found"
  TableFieldNonexistent table fieldName ->
    "field with name " <> fieldName <<> " not found in table " <>> table
  TableFieldNotSupported fieldName ->
    "field with name " <> fieldName <<> " not supported; only columns and scalar computed fields"
  TableComputedFieldWithInputArgs fieldName function ->
    "computed field " <> fieldName <<> " is associated with SQL function " <> function
      <<> " has input arguments other than table row type and hasura session"
  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"
  UnsupportedTableComputedField tableName fieldName ->
    "computed field " <> fieldName <<> " returns set of " <> tableName <<> ", 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.
validateRemoteSchemaRelationship ::
  forall b m.
  (Backend b, MonadError (ValidationError b) m) =>
  RemoteSchemaRelationshipDef ->
  TableName b ->
  RemoteRelationshipName ->
  SourceName ->
  (RemoteSchemaInfo, IntrospectionResult) ->
  FieldInfoMap (FieldInfo b) ->
  m (RemoteSchemaFieldInfo b)
validateRemoteSchemaRelationship schema table name source (remoteSchemaInfo, introspectionResult) fields = do
  let remoteSchemaName = _rrdRemoteSchemaName schema
  hasuraFields <- forM (toList $ _rrdHasuraFields schema) $ \fieldName -> do
    fieldInfo <- onNothing (HM.lookup fieldName fields) $ throwError $ TableFieldNonexistent table fieldName
    case fieldInfo of
      FIColumn columnInfo -> pure $ JoinColumn columnInfo
      FIComputedField ComputedFieldInfo {..} -> do
        scalarType <- case _cfiReturnType of
          CFRScalar ty -> pure ty
          CFRSetofTable {} -> throwError $ UnsupportedTableComputedField table _cfiName
        let ComputedFieldFunction {..} = _cfiFunction
        case toList _cffInputArgs of
          [] ->
            pure $
              JoinComputedField $
                ScalarComputedField
                  _cfiXComputedFieldInfo
                  _cfiName
                  _cffName
                  _cffTableArgument
                  _cffSessionArgument
                  scalarType
          _ -> throwError $ TableComputedFieldWithInputArgs fieldName _cffName
      _ -> throwError $ TableFieldNotSupported fieldName
  hasuraFieldsVariablesMap <-
    fmap HM.fromList $ for hasuraFields $ \field -> (,field) <$> hasuraFieldToVariable field
  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 $ _rrdRemoteField schema)
  pure $
    RemoteSchemaFieldInfo
      { _rfiName = name,
        _rfiParamMap = leafParamMap,
        _rfiHasuraFields = HS.fromList hasuraFields,
        _rfiRemoteFields = _rrdRemoteField schema,
        _rfiRemoteSchema = remoteSchemaInfo,
        -- adding the new input types after stripping the values of the
        -- schema document
        _rfiInputValueDefinitions = HM.elems leafTypeMap,
        _rfiRemoteSchemaName = remoteSchemaName,
        _rfiTable = (table, source)
      }
  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 ::
      HashMap G.Name (DBJoinField b) ->
      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
                  table
                  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 ::
  (Backend b) =>
  RemoteRelationshipName ->
  TableName b ->
  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 b))
    (HM.HashMap G.Name RemoteSchemaInputValueDefinition)
stripInMap rrName table types schemaArguments providedArguments =
  fmap
    (HM.mapMaybe id)
    ( HM.traverseWithKey
        ( \name remoteInpValDef@(RemoteSchemaInputValueDefinition inpValInfo _preset) ->
            case HM.lookup name providedArguments of
              Nothing -> pure $ Just remoteInpValDef
              Just value -> do
                maybeNewGType <- stripValue rrName table 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 ::
  (Backend b) =>
  RemoteRelationshipName ->
  TableName b ->
  RemoteSchemaIntrospection ->
  G.GType ->
  G.Value G.Name ->
  StateT
    (HashMap G.Name (G.TypeDefinition [G.Name] RemoteSchemaInputValueDefinition))
    (Either (ValidationError b))
    (Maybe G.GType)
stripValue name table 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 table types gtype gvalue
        _ -> lift (Left UnsupportedMultipleElementLists)
    G.VObject keyPairs ->
      fmap Just (stripObject name table types gtype keyPairs)

-- | Produce a new type for the list, or strip it entirely.
stripList ::
  (Backend b) =>
  RemoteRelationshipName ->
  TableName b ->
  RemoteSchemaIntrospection ->
  G.GType ->
  G.Value G.Name ->
  StateT
    (HashMap G.Name (G.TypeDefinition [G.Name] RemoteSchemaInputValueDefinition))
    (Either (ValidationError b))
    (Maybe G.GType)
stripList name table types originalOuterGType value =
  case originalOuterGType of
    G.TypeList nullability innerGType -> do
      maybeNewInnerGType <- stripValue name table 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 ::
  forall b.
  Backend b =>
  RemoteRelationshipName ->
  TableName b ->
  RemoteSchemaIntrospection ->
  G.GType ->
  HashMap G.Name (G.Value G.Name) ->
  StateT
    (HashMap G.Name (G.TypeDefinition [G.Name] RemoteSchemaInputValueDefinition))
    (Either (ValidationError b))
    G.GType
stripObject name table 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 =
                renameNamedType
                  (renameTypeForRelationship @b name table)
                  originalNamedType
          newSchemaArguments <-
            stripInMap
              name
              table
              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. (from master)
renameTypeForRelationship :: Backend b => RemoteRelationshipName -> TableName b -> Text -> Text
renameTypeForRelationship rrName table text =
  text <> "_remote_rel_" <> name
  where
    name = toTxt table <> remoteRelationshipNameToText rrName

-- | Rename a type.
renameNamedType :: (Text -> Text) -> G.Name -> G.Name
renameNamedType rename =
  G.unsafeMkName . rename . G.unName

-- | Convert a field name to a variable name.
hasuraFieldToVariable ::
  (Backend b, MonadError (ValidationError b) m) =>
  DBJoinField b ->
  m G.Name
hasuraFieldToVariable hasuraField = do
  let fieldText = case hasuraField of
        JoinColumn columnInfo -> toTxt $ pgiColumn columnInfo
        JoinComputedField computedFieldInfo -> toTxt $ _scfName computedFieldInfo
  G.mkName fieldText `onNothing` throwError (InvalidGraphQLName fieldText)

-- | Lookup the field in the schema.
lookupField ::
  (MonadError (ValidationError b) 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 ::
  (Backend b, MonadError (ValidationError b) m) =>
  HM.HashMap G.Name RemoteSchemaInputValueDefinition ->
  HM.HashMap G.Name (G.Value G.Name) ->
  HM.HashMap G.Name (DBJoinField b) ->
  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 ::
  (Backend b, MonadError (ValidationError b) m) =>
  HM.HashMap G.Name (DBJoinField b) ->
  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 permittedVariables)
        Just fieldInfo -> do
          namedType <- dbJoinFieldToNamedType fieldInfo
          isTypeCoercible (mkGraphQLType namedType) expectedGType
    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 b) 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.litName "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 b) m) =>
  G.GType ->
  m ()
assertListType actualType =
  unless
    (G.isListType actualType)
    (throwError $ InvalidType actualType "is not a list type")

-- | Convert a field info to a named type, if possible.
dbJoinFieldToNamedType ::
  forall b m.
  (Backend b, MonadError (ValidationError b) m) =>
  DBJoinField b ->
  m G.Name
dbJoinFieldToNamedType hasuraField = do
  scalarType <- case hasuraField of
    JoinColumn pci -> case pgiType pci of
      ColumnScalar scalarType -> pure scalarType
      _ -> throwError UnsupportedEnum
    JoinComputedField cfi -> pure $ _scfType cfi
  -- CFRScalar scalarType -> pure scalarType
  -- CFRSetofTable table  -> throwError $ UnsupportedTableComputedField table $ _cfiName cfi
  onLeft (scalarTypeGraphQLName @b scalarType) $
    const $ throwError $ CannotGenerateGraphQLTypeName scalarType

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)