{-# LANGUAGE ViewPatterns #-}

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

import Data.HashMap.Strict.Extended qualified as HashMap
import Data.HashSet qualified as HS
import Data.List.NonEmpty qualified as NE
import Data.Text.Extended
import Hasura.GraphQL.Parser.Name qualified as GName
import Hasura.Name qualified as Name
import Hasura.Prelude hiding (first)
import Hasura.RQL.Types.Common
import Hasura.RemoteSchema.Metadata
import Hasura.RemoteSchema.SchemaCache.Types
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 (Int -> ValidationError -> ShowS
[ValidationError] -> ShowS
ValidationError -> String
(Int -> ValidationError -> ShowS)
-> (ValidationError -> String)
-> ([ValidationError] -> ShowS)
-> Show ValidationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValidationError -> ShowS
showsPrec :: Int -> ValidationError -> ShowS
$cshow :: ValidationError -> String
show :: ValidationError -> String
$cshowList :: [ValidationError] -> ShowS
showList :: [ValidationError] -> ShowS
Show, ValidationError -> ValidationError -> Bool
(ValidationError -> ValidationError -> Bool)
-> (ValidationError -> ValidationError -> Bool)
-> Eq ValidationError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ValidationError -> ValidationError -> Bool
== :: ValidationError -> ValidationError -> Bool
$c/= :: ValidationError -> ValidationError -> Bool
/= :: ValidationError -> ValidationError -> Bool
Eq)

errorToText :: ValidationError -> Text
errorToText :: ValidationError -> Text
errorToText = \case
  RemoteSchemaNotFound RemoteSchemaName
name ->
    Text
"remote schema with name " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RemoteSchemaName
name RemoteSchemaName -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" not found"
  CouldntFindRemoteField Name
name Name
ty ->
    Text
"remote field with name " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
name Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" and type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
ty Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" not found"
  FieldNotFoundInRemoteSchema Name
name ->
    Text
"field with name " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
name Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" not found in remote schema"
  NoSuchArgumentForRemote Name
name ->
    Text
"argument with name " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
name Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" not found in remote schema"
  MissingRequiredArgument Name
name ->
    Text
"required argument with name " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
name Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" is missing"
  TypeNotFound Name
ty ->
    Text
"type with name " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
ty Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" not found"
  JoinFieldNonExistent (LHSIdentifier Text
lhs) FieldName
fieldName HashSet FieldName
allowedJoinFields ->
    let helpText :: Text
helpText =
          case [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([Text] -> Maybe (NonEmpty Text))
-> [Text] -> Maybe (NonEmpty Text)
forall a b. (a -> b) -> a -> b
$ (FieldName -> Text) -> [FieldName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map FieldName -> Text
forall t. ToTxt t => t -> Text
dquote ([FieldName] -> [Text]) -> [FieldName] -> [Text]
forall a b. (a -> b) -> a -> b
$ HashSet FieldName -> [FieldName]
forall a. HashSet a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList HashSet FieldName
allowedJoinFields of
            Maybe (NonEmpty Text)
Nothing -> Text
""
            Just NonEmpty Text
allowedFields -> Text
", the allowed fields are " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> NonEmpty Text -> Text
englishList Text
"or" NonEmpty Text
allowedFields
     in Text
"field with name "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FieldName
fieldName
          FieldName -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
"is not provided by the lhs entity"
          Text -> Text -> Text
forall t. ToTxt t => Text -> t -> Text
<>> Text
lhs
          Text -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
"for defining a join condition"
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
helpText
  ExpectedTypeButGot GType
expTy GType
actualTy ->
    Text
"expected type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GType -> Name
G.getBaseType GType
expTy Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" but got " Text -> Name -> Text
forall t. ToTxt t => Text -> t -> Text
<>> GType -> Name
G.getBaseType GType
actualTy
  InvalidType GType
ty Text
err ->
    Text
"type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GType -> Name
G.getBaseType GType
ty Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
err
  InvalidVariable Name
var HashSet Name
_ ->
    Text
"variable " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
var Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" is not found"
  ValidationError
NullNotAllowedHere ->
    Text
"null is not allowed here"
  InvalidGTypeForStripping GType
ty ->
    Text
"type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GType -> Name
G.getBaseType GType
ty Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" is invalid for stripping"
  ValidationError
UnsupportedMultipleElementLists ->
    Text
"multiple elements in list value is not supported"
  ValidationError
UnsupportedEnum ->
    Text
"enum value is not supported"
  InvalidGraphQLName Text
t ->
    Text
t Text -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" is not a valid GraphQL identifier"
  IDTypeJoin Name
typeName ->
    Text
"Only ID, Int, uuid or String scalar types can be joined to the ID type, but received " Text -> Name -> Text
forall t. ToTxt t => Text -> t -> Text
<>> Name
typeName
  CannotGenerateGraphQLTypeName Name
typeName ->
    Text
"the name of the scalar type "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
forall t. ToTxt t => t -> Text
toTxt Name
typeName
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not a valid GraphQL identifier, "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" 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) ->
  HashMap.HashMap FieldName joinField ->
  m (HashMap.HashMap FieldName joinField, RemoteSchemaFieldInfo)
validateToSchemaRelationship :: forall (m :: * -> *) joinField.
MonadError ValidationError m =>
ToSchemaRelationshipDef
-> LHSIdentifier
-> RelName
-> (RemoteSchemaInfo, IntrospectionResult)
-> HashMap FieldName joinField
-> m (HashMap FieldName joinField, RemoteSchemaFieldInfo)
validateToSchemaRelationship ToSchemaRelationshipDef
schema LHSIdentifier
lhsIdentifier RelName
name (RemoteSchemaInfo
remoteSchemaInfo, IntrospectionResult
introspectionResult) HashMap FieldName joinField
lhsJoinFields = do
  let remoteSchemaName :: RemoteSchemaName
remoteSchemaName = ToSchemaRelationshipDef -> RemoteSchemaName
_trrdRemoteSchema ToSchemaRelationshipDef
schema
  [(FieldName, joinField)]
requiredLHSJoinFields <- [FieldName]
-> (FieldName -> m (FieldName, joinField))
-> m [(FieldName, joinField)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (HashSet FieldName -> [FieldName]
forall a. HashSet a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (HashSet FieldName -> [FieldName])
-> HashSet FieldName -> [FieldName]
forall a b. (a -> b) -> a -> b
$ ToSchemaRelationshipDef -> HashSet FieldName
_trrdLhsFields ToSchemaRelationshipDef
schema) ((FieldName -> m (FieldName, joinField))
 -> m [(FieldName, joinField)])
-> (FieldName -> m (FieldName, joinField))
-> m [(FieldName, joinField)]
forall a b. (a -> b) -> a -> b
$ \FieldName
fieldName -> do
    (joinField -> (FieldName, joinField))
-> m joinField -> m (FieldName, joinField)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FieldName
fieldName,)
      (m joinField -> m (FieldName, joinField))
-> m joinField -> m (FieldName, joinField)
forall a b. (a -> b) -> a -> b
$ Maybe joinField -> m joinField -> m joinField
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
onNothing (FieldName -> HashMap FieldName joinField -> Maybe joinField
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup FieldName
fieldName HashMap FieldName joinField
lhsJoinFields)
      (m joinField -> m joinField) -> m joinField -> m joinField
forall a b. (a -> b) -> a -> b
$ ValidationError -> m joinField
forall a. ValidationError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
      (ValidationError -> m joinField) -> ValidationError -> m joinField
forall a b. (a -> b) -> a -> b
$ LHSIdentifier -> FieldName -> HashSet FieldName -> ValidationError
JoinFieldNonExistent LHSIdentifier
lhsIdentifier FieldName
fieldName
      (HashSet FieldName -> ValidationError)
-> HashSet FieldName -> ValidationError
forall a b. (a -> b) -> a -> b
$ HashMap FieldName joinField -> HashSet FieldName
forall k a. HashMap k a -> HashSet k
HashMap.keysSet HashMap FieldName joinField
lhsJoinFields
  HashMap Name joinField
hasuraFieldsVariablesMap <-
    ([(Name, joinField)] -> HashMap Name joinField)
-> m [(Name, joinField)] -> m (HashMap Name joinField)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Name, joinField)] -> HashMap Name joinField
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList (m [(Name, joinField)] -> m (HashMap Name joinField))
-> m [(Name, joinField)] -> m (HashMap Name joinField)
forall a b. (a -> b) -> a -> b
$ [(FieldName, joinField)]
-> ((FieldName, joinField) -> m (Name, joinField))
-> m [(Name, joinField)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(FieldName, joinField)]
requiredLHSJoinFields (((FieldName, joinField) -> m (Name, joinField))
 -> m [(Name, joinField)])
-> ((FieldName, joinField) -> m (Name, joinField))
-> m [(Name, joinField)]
forall a b. (a -> b) -> a -> b
$ \(FieldName
fieldName, joinField
field) -> (,joinField
field) (Name -> (Name, joinField)) -> m Name -> m (Name, joinField)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldName -> m Name
forall (m :: * -> *).
MonadError ValidationError m =>
FieldName -> m Name
hasuraFieldToVariable FieldName
fieldName
  let schemaDoc :: RemoteSchemaIntrospection
schemaDoc = IntrospectionResult -> RemoteSchemaIntrospection
irDoc IntrospectionResult
introspectionResult
      queryRootName :: Name
queryRootName = IntrospectionResult -> Name
irQueryRoot IntrospectionResult
introspectionResult
  ObjectTypeDefinition RemoteSchemaInputValueDefinition
queryRoot <-
    Maybe (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
onNothing (RemoteSchemaIntrospection
-> Name
-> Maybe (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
lookupObject RemoteSchemaIntrospection
schemaDoc Name
queryRootName)
      (m (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
 -> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition))
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
forall a b. (a -> b) -> a -> b
$ ValidationError
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
forall a. ValidationError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
      (ValidationError
 -> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition))
-> ValidationError
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
forall a b. (a -> b) -> a -> b
$ Name -> ValidationError
FieldNotFoundInRemoteSchema Name
queryRootName
  (ObjectTypeDefinition RemoteSchemaInputValueDefinition
_, (HashMap Name RemoteSchemaInputValueDefinition
leafParamMap, HashMap
  Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
leafTypeMap)) <-
    ((ObjectTypeDefinition RemoteSchemaInputValueDefinition,
  (HashMap Name RemoteSchemaInputValueDefinition,
   HashMap
     Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)))
 -> FieldCall
 -> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition,
       (HashMap Name RemoteSchemaInputValueDefinition,
        HashMap
          Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))))
-> (ObjectTypeDefinition RemoteSchemaInputValueDefinition,
    (HashMap Name RemoteSchemaInputValueDefinition,
     HashMap
       Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)))
-> NonEmpty FieldCall
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition,
      (HashMap Name RemoteSchemaInputValueDefinition,
       HashMap
         Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM
      (HashMap Name joinField
-> RemoteSchemaIntrospection
-> (ObjectTypeDefinition RemoteSchemaInputValueDefinition,
    (HashMap Name RemoteSchemaInputValueDefinition,
     HashMap
       Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)))
-> FieldCall
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition,
      (HashMap Name RemoteSchemaInputValueDefinition,
       HashMap
         Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)))
forall (m :: * -> *) joinField.
MonadError ValidationError m =>
HashMap Name joinField
-> RemoteSchemaIntrospection
-> (ObjectTypeDefinition RemoteSchemaInputValueDefinition,
    (HashMap Name RemoteSchemaInputValueDefinition,
     HashMap
       Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)))
-> FieldCall
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition,
      (HashMap Name RemoteSchemaInputValueDefinition,
       HashMap
         Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)))
buildRelationshipTypeInfo HashMap Name joinField
hasuraFieldsVariablesMap RemoteSchemaIntrospection
schemaDoc)
      (ObjectTypeDefinition RemoteSchemaInputValueDefinition
queryRoot, (HashMap Name RemoteSchemaInputValueDefinition
forall a. Monoid a => a
mempty, HashMap
  Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
forall a. Monoid a => a
mempty))
      (RemoteFields -> NonEmpty FieldCall
unRemoteFields (RemoteFields -> NonEmpty FieldCall)
-> RemoteFields -> NonEmpty FieldCall
forall a b. (a -> b) -> a -> b
$ ToSchemaRelationshipDef -> RemoteFields
_trrdRemoteField ToSchemaRelationshipDef
schema)
  (HashMap FieldName joinField, RemoteSchemaFieldInfo)
-> m (HashMap FieldName joinField, RemoteSchemaFieldInfo)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ((HashMap FieldName joinField, RemoteSchemaFieldInfo)
 -> m (HashMap FieldName joinField, RemoteSchemaFieldInfo))
-> (HashMap FieldName joinField, RemoteSchemaFieldInfo)
-> m (HashMap FieldName joinField, RemoteSchemaFieldInfo)
forall a b. (a -> b) -> a -> b
$ ( [(FieldName, joinField)] -> HashMap FieldName joinField
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList [(FieldName, joinField)]
requiredLHSJoinFields,
        RemoteSchemaFieldInfo
          { _rrfiName :: RelName
_rrfiName = RelName
name,
            _rrfiParamMap :: HashMap Name RemoteSchemaInputValueDefinition
_rrfiParamMap = HashMap Name RemoteSchemaInputValueDefinition
leafParamMap,
            _rrfiRemoteFields :: RemoteFields
_rrfiRemoteFields = ToSchemaRelationshipDef -> RemoteFields
_trrdRemoteField ToSchemaRelationshipDef
schema,
            _rrfiRemoteSchema :: RemoteSchemaInfo
_rrfiRemoteSchema = RemoteSchemaInfo
remoteSchemaInfo,
            -- adding the new input types after stripping the values of the
            -- schema document
            _rrfiInputValueDefinitions :: [TypeDefinition [Name] RemoteSchemaInputValueDefinition]
_rrfiInputValueDefinitions = HashMap
  Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
-> [TypeDefinition [Name] RemoteSchemaInputValueDefinition]
forall k v. HashMap k v -> [v]
HashMap.elems HashMap
  Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
leafTypeMap,
            _rrfiRemoteSchemaName :: RemoteSchemaName
_rrfiRemoteSchemaName = RemoteSchemaName
remoteSchemaName,
            _rrfiLHSIdentifier :: LHSIdentifier
_rrfiLHSIdentifier = LHSIdentifier
lhsIdentifier
          }
      )
  where
    getObjTyInfoFromField ::
      RemoteSchemaIntrospection ->
      G.FieldDefinition RemoteSchemaInputValueDefinition ->
      Maybe (G.ObjectTypeDefinition RemoteSchemaInputValueDefinition)
    getObjTyInfoFromField :: RemoteSchemaIntrospection
-> FieldDefinition RemoteSchemaInputValueDefinition
-> Maybe (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
getObjTyInfoFromField RemoteSchemaIntrospection
schemaDoc FieldDefinition RemoteSchemaInputValueDefinition
field =
      let baseTy :: Name
baseTy = GType -> Name
G.getBaseType (FieldDefinition RemoteSchemaInputValueDefinition -> GType
forall inputType. FieldDefinition inputType -> GType
G._fldType FieldDefinition RemoteSchemaInputValueDefinition
field)
       in RemoteSchemaIntrospection
-> Name
-> Maybe (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
lookupObject RemoteSchemaIntrospection
schemaDoc Name
baseTy

    isValidType :: RemoteSchemaIntrospection -> FieldDefinition inputType -> Bool
isValidType RemoteSchemaIntrospection
schemaDoc FieldDefinition inputType
field =
      let baseTy :: Name
baseTy = GType -> Name
G.getBaseType (FieldDefinition inputType -> GType
forall inputType. FieldDefinition inputType -> GType
G._fldType FieldDefinition inputType
field)
       in case RemoteSchemaIntrospection
-> Name
-> Maybe (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
lookupType RemoteSchemaIntrospection
schemaDoc Name
baseTy of
            Just (G.TypeDefinitionScalar ScalarTypeDefinition
_) -> Bool
True
            Just (G.TypeDefinitionInterface InterfaceTypeDefinition [Name] RemoteSchemaInputValueDefinition
_) -> Bool
True
            Just (G.TypeDefinitionUnion UnionTypeDefinition
_) -> Bool
True
            Just (G.TypeDefinitionEnum EnumTypeDefinition
_) -> Bool
True
            Maybe (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
_ -> Bool
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 :: forall (m :: * -> *) joinField.
MonadError ValidationError m =>
HashMap Name joinField
-> RemoteSchemaIntrospection
-> (ObjectTypeDefinition RemoteSchemaInputValueDefinition,
    (HashMap Name RemoteSchemaInputValueDefinition,
     HashMap
       Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)))
-> FieldCall
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition,
      (HashMap Name RemoteSchemaInputValueDefinition,
       HashMap
         Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)))
buildRelationshipTypeInfo HashMap Name joinField
hasuraFieldsVariablesMap RemoteSchemaIntrospection
schemaDoc (ObjectTypeDefinition RemoteSchemaInputValueDefinition
objTyInfo, (HashMap Name RemoteSchemaInputValueDefinition
_, HashMap
  Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
typeMap)) FieldCall
fieldCall = do
      FieldDefinition RemoteSchemaInputValueDefinition
objFldDefinition <- Name
-> ObjectTypeDefinition RemoteSchemaInputValueDefinition
-> m (FieldDefinition RemoteSchemaInputValueDefinition)
forall (m :: * -> *).
MonadError ValidationError m =>
Name
-> ObjectTypeDefinition RemoteSchemaInputValueDefinition
-> m (FieldDefinition RemoteSchemaInputValueDefinition)
lookupField (FieldCall -> Name
fcName FieldCall
fieldCall) ObjectTypeDefinition RemoteSchemaInputValueDefinition
objTyInfo
      let providedArguments :: HashMap Name (Value Name)
providedArguments = RemoteArguments -> HashMap Name (Value Name)
getRemoteArguments (RemoteArguments -> HashMap Name (Value Name))
-> RemoteArguments -> HashMap Name (Value Name)
forall a b. (a -> b) -> a -> b
$ FieldCall -> RemoteArguments
fcArguments FieldCall
fieldCall
      HashMap Name RemoteSchemaInputValueDefinition
-> HashMap Name (Value Name)
-> HashMap Name joinField
-> RemoteSchemaIntrospection
-> m ()
forall (m :: * -> *) joinField.
MonadError ValidationError m =>
HashMap Name RemoteSchemaInputValueDefinition
-> HashMap Name (Value Name)
-> HashMap Name joinField
-> RemoteSchemaIntrospection
-> m ()
validateRemoteArguments
        ((RemoteSchemaInputValueDefinition -> Name)
-> [RemoteSchemaInputValueDefinition]
-> HashMap Name RemoteSchemaInputValueDefinition
forall k a. Hashable k => (a -> k) -> [a] -> HashMap k a
mapFromL (InputValueDefinition -> Name
G._ivdName (InputValueDefinition -> Name)
-> (RemoteSchemaInputValueDefinition -> InputValueDefinition)
-> RemoteSchemaInputValueDefinition
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteSchemaInputValueDefinition -> InputValueDefinition
_rsitdDefinition) (FieldDefinition RemoteSchemaInputValueDefinition
-> [RemoteSchemaInputValueDefinition]
forall inputType.
FieldDefinition inputType -> ArgumentsDefinition inputType
G._fldArgumentsDefinition FieldDefinition RemoteSchemaInputValueDefinition
objFldDefinition))
        HashMap Name (Value Name)
providedArguments
        HashMap Name joinField
hasuraFieldsVariablesMap
        RemoteSchemaIntrospection
schemaDoc
      let eitherParamAndTypeMap :: Either
  ValidationError
  (HashMap Name RemoteSchemaInputValueDefinition,
   HashMap
     Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
eitherParamAndTypeMap =
            StateT
  (HashMap
     Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
  (Either ValidationError)
  (HashMap Name RemoteSchemaInputValueDefinition)
-> HashMap
     Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
-> Either
     ValidationError
     (HashMap Name RemoteSchemaInputValueDefinition,
      HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT
              ( RelName
-> LHSIdentifier
-> RemoteSchemaIntrospection
-> HashMap Name RemoteSchemaInputValueDefinition
-> HashMap Name (Value Name)
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (HashMap Name RemoteSchemaInputValueDefinition)
stripInMap
                  RelName
name
                  LHSIdentifier
lhsIdentifier
                  RemoteSchemaIntrospection
schemaDoc
                  ((RemoteSchemaInputValueDefinition -> Name)
-> [RemoteSchemaInputValueDefinition]
-> HashMap Name RemoteSchemaInputValueDefinition
forall k a. Hashable k => (a -> k) -> [a] -> HashMap k a
mapFromL (InputValueDefinition -> Name
G._ivdName (InputValueDefinition -> Name)
-> (RemoteSchemaInputValueDefinition -> InputValueDefinition)
-> RemoteSchemaInputValueDefinition
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteSchemaInputValueDefinition -> InputValueDefinition
_rsitdDefinition) (FieldDefinition RemoteSchemaInputValueDefinition
-> [RemoteSchemaInputValueDefinition]
forall inputType.
FieldDefinition inputType -> ArgumentsDefinition inputType
G._fldArgumentsDefinition FieldDefinition RemoteSchemaInputValueDefinition
objFldDefinition))
                  HashMap Name (Value Name)
providedArguments
              )
              HashMap
  Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
typeMap
      (HashMap Name RemoteSchemaInputValueDefinition
newParamMap, HashMap
  Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
newTypeMap) <- Either
  ValidationError
  (HashMap Name RemoteSchemaInputValueDefinition,
   HashMap
     Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
-> (ValidationError
    -> m (HashMap Name RemoteSchemaInputValueDefinition,
          HashMap
            Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)))
-> m (HashMap Name RemoteSchemaInputValueDefinition,
      HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
onLeft Either
  ValidationError
  (HashMap Name RemoteSchemaInputValueDefinition,
   HashMap
     Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
eitherParamAndTypeMap ValidationError
-> m (HashMap Name RemoteSchemaInputValueDefinition,
      HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
forall a. ValidationError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
      ObjectTypeDefinition RemoteSchemaInputValueDefinition
innerObjTyInfo <-
        Maybe (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
onNothing (RemoteSchemaIntrospection
-> FieldDefinition RemoteSchemaInputValueDefinition
-> Maybe (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
getObjTyInfoFromField RemoteSchemaIntrospection
schemaDoc FieldDefinition RemoteSchemaInputValueDefinition
objFldDefinition)
          (m (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
 -> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition))
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
forall a b. (a -> b) -> a -> b
$ m (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
-> Bool
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
forall a. a -> a -> Bool -> a
bool
            ( ValidationError
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
forall a. ValidationError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
                (ValidationError
 -> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition))
-> ValidationError
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
forall a b. (a -> b) -> a -> b
$ GType -> Text -> ValidationError
InvalidType (FieldDefinition RemoteSchemaInputValueDefinition -> GType
forall inputType. FieldDefinition inputType -> GType
G._fldType FieldDefinition RemoteSchemaInputValueDefinition
objFldDefinition) Text
"only output type is expected"
            )
            (ObjectTypeDefinition RemoteSchemaInputValueDefinition
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ObjectTypeDefinition RemoteSchemaInputValueDefinition
objTyInfo)
            (RemoteSchemaIntrospection
-> FieldDefinition RemoteSchemaInputValueDefinition -> Bool
forall {inputType}.
RemoteSchemaIntrospection -> FieldDefinition inputType -> Bool
isValidType RemoteSchemaIntrospection
schemaDoc FieldDefinition RemoteSchemaInputValueDefinition
objFldDefinition)
      (ObjectTypeDefinition RemoteSchemaInputValueDefinition,
 (HashMap Name RemoteSchemaInputValueDefinition,
  HashMap
    Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)))
-> m (ObjectTypeDefinition RemoteSchemaInputValueDefinition,
      (HashMap Name RemoteSchemaInputValueDefinition,
       HashMap
         Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( ObjectTypeDefinition RemoteSchemaInputValueDefinition
innerObjTyInfo,
          (HashMap Name RemoteSchemaInputValueDefinition
newParamMap, HashMap
  Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
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 ->
  HashMap.HashMap G.Name RemoteSchemaInputValueDefinition ->
  HashMap.HashMap G.Name (G.Value G.Name) ->
  StateT
    (HashMap G.Name (G.TypeDefinition [G.Name] RemoteSchemaInputValueDefinition))
    (Either ValidationError)
    (HashMap.HashMap G.Name RemoteSchemaInputValueDefinition)
stripInMap :: RelName
-> LHSIdentifier
-> RemoteSchemaIntrospection
-> HashMap Name RemoteSchemaInputValueDefinition
-> HashMap Name (Value Name)
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (HashMap Name RemoteSchemaInputValueDefinition)
stripInMap RelName
relName LHSIdentifier
lhsIdentifier RemoteSchemaIntrospection
types HashMap Name RemoteSchemaInputValueDefinition
schemaArguments HashMap Name (Value Name)
providedArguments =
  (HashMap Name (Maybe RemoteSchemaInputValueDefinition)
 -> HashMap Name RemoteSchemaInputValueDefinition)
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (HashMap Name (Maybe RemoteSchemaInputValueDefinition))
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (HashMap Name RemoteSchemaInputValueDefinition)
forall a b.
(a -> b)
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     a
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HashMap Name (Maybe RemoteSchemaInputValueDefinition)
-> HashMap Name RemoteSchemaInputValueDefinition
forall a. HashMap Name (Maybe a) -> HashMap Name a
forall (f :: * -> *) a. Filterable f => f (Maybe a) -> f a
catMaybes
    (StateT
   (HashMap
      Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
   (Either ValidationError)
   (HashMap Name (Maybe RemoteSchemaInputValueDefinition))
 -> StateT
      (HashMap
         Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
      (Either ValidationError)
      (HashMap Name RemoteSchemaInputValueDefinition))
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (HashMap Name (Maybe RemoteSchemaInputValueDefinition))
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (HashMap Name RemoteSchemaInputValueDefinition)
forall a b. (a -> b) -> a -> b
$ (Name
 -> RemoteSchemaInputValueDefinition
 -> StateT
      (HashMap
         Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
      (Either ValidationError)
      (Maybe RemoteSchemaInputValueDefinition))
-> HashMap Name RemoteSchemaInputValueDefinition
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (HashMap Name (Maybe RemoteSchemaInputValueDefinition))
forall (f :: * -> *) k v1 v2.
Applicative f =>
(k -> v1 -> f v2) -> HashMap k v1 -> f (HashMap k v2)
HashMap.traverseWithKey
      ( \Name
name remoteInpValDef :: RemoteSchemaInputValueDefinition
remoteInpValDef@(RemoteSchemaInputValueDefinition InputValueDefinition
inpValInfo Maybe (Value RemoteSchemaVariable)
_preset) ->
          case Name -> HashMap Name (Value Name) -> Maybe (Value Name)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
name HashMap Name (Value Name)
providedArguments of
            Maybe (Value Name)
Nothing -> Maybe RemoteSchemaInputValueDefinition
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (Maybe RemoteSchemaInputValueDefinition)
forall a.
a
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe RemoteSchemaInputValueDefinition
 -> StateT
      (HashMap
         Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
      (Either ValidationError)
      (Maybe RemoteSchemaInputValueDefinition))
-> Maybe RemoteSchemaInputValueDefinition
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (Maybe RemoteSchemaInputValueDefinition)
forall a b. (a -> b) -> a -> b
$ RemoteSchemaInputValueDefinition
-> Maybe RemoteSchemaInputValueDefinition
forall a. a -> Maybe a
Just RemoteSchemaInputValueDefinition
remoteInpValDef
            Just Value Name
value -> do
              Maybe GType
maybeNewGType <- RelName
-> LHSIdentifier
-> RemoteSchemaIntrospection
-> GType
-> Value Name
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (Maybe GType)
stripValue RelName
relName LHSIdentifier
lhsIdentifier RemoteSchemaIntrospection
types (InputValueDefinition -> GType
G._ivdType InputValueDefinition
inpValInfo) Value Name
value
              Maybe RemoteSchemaInputValueDefinition
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (Maybe RemoteSchemaInputValueDefinition)
forall a.
a
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                (Maybe RemoteSchemaInputValueDefinition
 -> StateT
      (HashMap
         Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
      (Either ValidationError)
      (Maybe RemoteSchemaInputValueDefinition))
-> Maybe RemoteSchemaInputValueDefinition
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (Maybe RemoteSchemaInputValueDefinition)
forall a b. (a -> b) -> a -> b
$ (GType -> RemoteSchemaInputValueDefinition)
-> Maybe GType -> Maybe RemoteSchemaInputValueDefinition
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                  ( \GType
newGType ->
                      let newInpValInfo :: InputValueDefinition
newInpValInfo = InputValueDefinition
inpValInfo {_ivdType :: GType
G._ivdType = GType
newGType}
                       in InputValueDefinition
-> Maybe (Value RemoteSchemaVariable)
-> RemoteSchemaInputValueDefinition
RemoteSchemaInputValueDefinition InputValueDefinition
newInpValInfo Maybe (Value RemoteSchemaVariable)
forall a. Maybe a
Nothing
                  )
                  Maybe GType
maybeNewGType
      )
      HashMap Name RemoteSchemaInputValueDefinition
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 :: RelName
-> LHSIdentifier
-> RemoteSchemaIntrospection
-> GType
-> Value Name
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (Maybe GType)
stripValue RelName
name LHSIdentifier
lhsIdentifier RemoteSchemaIntrospection
types GType
gtype Value Name
value = do
  case Value Name
value of
    G.VVariable {} -> Maybe GType
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (Maybe GType)
forall a.
a
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe GType
forall a. Maybe a
Nothing
    G.VInt {} -> Maybe GType
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (Maybe GType)
forall a.
a
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe GType
forall a. Maybe a
Nothing
    G.VFloat {} -> Maybe GType
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (Maybe GType)
forall a.
a
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe GType
forall a. Maybe a
Nothing
    G.VString {} -> Maybe GType
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (Maybe GType)
forall a.
a
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe GType
forall a. Maybe a
Nothing
    G.VBoolean {} -> Maybe GType
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (Maybe GType)
forall a.
a
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe GType
forall a. Maybe a
Nothing
    G.VNull {} -> Maybe GType
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (Maybe GType)
forall a.
a
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe GType
forall a. Maybe a
Nothing
    G.VEnum {} -> Maybe GType
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (Maybe GType)
forall a.
a
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe GType
forall a. Maybe a
Nothing
    G.VList [Value Name]
values ->
      case [Value Name]
values of
        [] -> Maybe GType
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (Maybe GType)
forall a.
a
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe GType
forall a. Maybe a
Nothing
        [Value Name
gvalue] -> RelName
-> LHSIdentifier
-> RemoteSchemaIntrospection
-> GType
-> Value Name
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (Maybe GType)
stripList RelName
name LHSIdentifier
lhsIdentifier RemoteSchemaIntrospection
types GType
gtype Value Name
gvalue
        [Value Name]
_ -> Either ValidationError (Maybe GType)
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (Maybe GType)
forall (m :: * -> *) a.
Monad m =>
m a
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     m
     a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ValidationError -> Either ValidationError (Maybe GType)
forall a b. a -> Either a b
Left ValidationError
UnsupportedMultipleElementLists)
    G.VObject HashMap Name (Value Name)
keyPairs ->
      (GType -> Maybe GType)
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     GType
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (Maybe GType)
forall a b.
(a -> b)
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     a
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GType -> Maybe GType
forall a. a -> Maybe a
Just (RelName
-> LHSIdentifier
-> RemoteSchemaIntrospection
-> GType
-> HashMap Name (Value Name)
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     GType
stripObject RelName
name LHSIdentifier
lhsIdentifier RemoteSchemaIntrospection
types GType
gtype HashMap Name (Value Name)
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 :: RelName
-> LHSIdentifier
-> RemoteSchemaIntrospection
-> GType
-> Value Name
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (Maybe GType)
stripList RelName
name LHSIdentifier
lhsIdentifier RemoteSchemaIntrospection
types GType
originalOuterGType Value Name
value =
  case GType
originalOuterGType of
    G.TypeList Nullability
nullability GType
innerGType -> do
      Maybe GType
maybeNewInnerGType <- RelName
-> LHSIdentifier
-> RemoteSchemaIntrospection
-> GType
-> Value Name
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (Maybe GType)
stripValue RelName
name LHSIdentifier
lhsIdentifier RemoteSchemaIntrospection
types GType
innerGType Value Name
value
      Maybe GType
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (Maybe GType)
forall a.
a
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Nullability -> GType -> GType
G.TypeList Nullability
nullability (GType -> GType) -> Maybe GType -> Maybe GType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe GType
maybeNewInnerGType)
    GType
_ -> Either ValidationError (Maybe GType)
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (Maybe GType)
forall (m :: * -> *) a.
Monad m =>
m a
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     m
     a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ValidationError -> Either ValidationError (Maybe GType)
forall a b. a -> Either a b
Left (GType -> ValidationError
InvalidGTypeForStripping GType
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 :: RelName
-> LHSIdentifier
-> RemoteSchemaIntrospection
-> GType
-> HashMap Name (Value Name)
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     GType
stripObject RelName
name LHSIdentifier
lhsIdentifier RemoteSchemaIntrospection
schemaDoc GType
originalGtype HashMap Name (Value Name)
templateArguments =
  case GType
originalGtype of
    G.TypeNamed Nullability
nullability Name
originalNamedType ->
      case RemoteSchemaIntrospection
-> Name
-> Maybe (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
lookupType RemoteSchemaIntrospection
schemaDoc (GType -> Name
G.getBaseType GType
originalGtype) of
        Just (G.TypeDefinitionInputObject InputObjectTypeDefinition RemoteSchemaInputValueDefinition
originalInpObjTyInfo) -> do
          let originalSchemaArguments :: HashMap Name RemoteSchemaInputValueDefinition
originalSchemaArguments =
                (RemoteSchemaInputValueDefinition -> Name)
-> [RemoteSchemaInputValueDefinition]
-> HashMap Name RemoteSchemaInputValueDefinition
forall k a. Hashable k => (a -> k) -> [a] -> HashMap k a
mapFromL (InputValueDefinition -> Name
G._ivdName (InputValueDefinition -> Name)
-> (RemoteSchemaInputValueDefinition -> InputValueDefinition)
-> RemoteSchemaInputValueDefinition
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteSchemaInputValueDefinition -> InputValueDefinition
_rsitdDefinition) ([RemoteSchemaInputValueDefinition]
 -> HashMap Name RemoteSchemaInputValueDefinition)
-> [RemoteSchemaInputValueDefinition]
-> HashMap Name RemoteSchemaInputValueDefinition
forall a b. (a -> b) -> a -> b
$ InputObjectTypeDefinition RemoteSchemaInputValueDefinition
-> [RemoteSchemaInputValueDefinition]
forall inputType.
InputObjectTypeDefinition inputType -> [inputType]
G._iotdValueDefinitions InputObjectTypeDefinition RemoteSchemaInputValueDefinition
originalInpObjTyInfo
          Name
newNamedType <-
            RelName
-> LHSIdentifier
-> Name
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     Name
forall (m :: * -> *).
MonadError ValidationError m =>
RelName -> LHSIdentifier -> Name -> m Name
renameTypeForRelationship RelName
name LHSIdentifier
lhsIdentifier Name
originalNamedType
          HashMap Name RemoteSchemaInputValueDefinition
newSchemaArguments <-
            RelName
-> LHSIdentifier
-> RemoteSchemaIntrospection
-> HashMap Name RemoteSchemaInputValueDefinition
-> HashMap Name (Value Name)
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     (HashMap Name RemoteSchemaInputValueDefinition)
stripInMap
              RelName
name
              LHSIdentifier
lhsIdentifier
              RemoteSchemaIntrospection
schemaDoc
              HashMap Name RemoteSchemaInputValueDefinition
originalSchemaArguments
              HashMap Name (Value Name)
templateArguments
          let newInpObjTyInfo :: InputObjectTypeDefinition RemoteSchemaInputValueDefinition
newInpObjTyInfo =
                InputObjectTypeDefinition RemoteSchemaInputValueDefinition
originalInpObjTyInfo
                  { _iotdValueDefinitions :: [RemoteSchemaInputValueDefinition]
G._iotdValueDefinitions = HashMap Name RemoteSchemaInputValueDefinition
-> [RemoteSchemaInputValueDefinition]
forall k v. HashMap k v -> [v]
HashMap.elems HashMap Name RemoteSchemaInputValueDefinition
newSchemaArguments,
                    _iotdName :: Name
G._iotdName = Name
newNamedType
                  }
              newGtype :: GType
newGtype = Nullability -> Name -> GType
G.TypeNamed Nullability
nullability Name
newNamedType
          (HashMap
   Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
 -> HashMap
      Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Name
-> TypeDefinition [Name] RemoteSchemaInputValueDefinition
-> HashMap
     Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
-> HashMap
     Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Name
newNamedType (InputObjectTypeDefinition RemoteSchemaInputValueDefinition
-> TypeDefinition [Name] RemoteSchemaInputValueDefinition
forall possibleTypes inputType.
InputObjectTypeDefinition inputType
-> TypeDefinition possibleTypes inputType
G.TypeDefinitionInputObject InputObjectTypeDefinition RemoteSchemaInputValueDefinition
newInpObjTyInfo))
          GType
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     GType
forall a.
a
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GType
newGtype
        Maybe (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
_ -> Either ValidationError GType
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     GType
forall (m :: * -> *) a.
Monad m =>
m a
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     m
     a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ValidationError -> Either ValidationError GType
forall a b. a -> Either a b
Left (GType -> ValidationError
InvalidGTypeForStripping GType
originalGtype))
    GType
_ -> Either ValidationError GType
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     (Either ValidationError)
     GType
forall (m :: * -> *) a.
Monad m =>
m a
-> StateT
     (HashMap
        Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
     m
     a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ValidationError -> Either ValidationError GType
forall a b. a -> Either a b
Left (GType -> ValidationError
InvalidGTypeForStripping GType
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 :: forall (m :: * -> *).
MonadError ValidationError m =>
RelName -> LHSIdentifier -> Name -> m Name
renameTypeForRelationship (RelName -> Text
relNameToTxt -> Text
relTxt) LHSIdentifier
lhsIdentifier Name
name = do
  Name
lhsName <-
    LHSIdentifier -> Maybe Name
lhsIdentifierToGraphQLName LHSIdentifier
lhsIdentifier
      Maybe Name -> m Name -> m Name
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
`onNothing` ValidationError -> m Name
forall a. ValidationError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> ValidationError
InvalidGraphQLName (Text -> ValidationError) -> Text -> ValidationError
forall a b. (a -> b) -> a -> b
$ LHSIdentifier -> Text
getLHSIdentifier LHSIdentifier
lhsIdentifier)
  Name
relName <-
    Text -> Maybe Name
G.mkName Text
relTxt
      Maybe Name -> m Name -> m Name
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
`onNothing` ValidationError -> m Name
forall a. ValidationError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> ValidationError
InvalidGraphQLName Text
relTxt)
  Name -> m Name
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Name -> m Name) -> Name -> m Name
forall a b. (a -> b) -> a -> b
$ Name
name
    Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
Name.__remote_rel_
    Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
lhsName
    Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
relName

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

-- | Lookup the field in the schema.
lookupField ::
  (MonadError ValidationError m) =>
  G.Name ->
  G.ObjectTypeDefinition RemoteSchemaInputValueDefinition ->
  m (G.FieldDefinition RemoteSchemaInputValueDefinition)
lookupField :: forall (m :: * -> *).
MonadError ValidationError m =>
Name
-> ObjectTypeDefinition RemoteSchemaInputValueDefinition
-> m (FieldDefinition RemoteSchemaInputValueDefinition)
lookupField Name
name ObjectTypeDefinition RemoteSchemaInputValueDefinition
objFldInfo = ObjectTypeDefinition RemoteSchemaInputValueDefinition
-> m (FieldDefinition RemoteSchemaInputValueDefinition)
viaObject ObjectTypeDefinition RemoteSchemaInputValueDefinition
objFldInfo
  where
    viaObject :: ObjectTypeDefinition RemoteSchemaInputValueDefinition
-> m (FieldDefinition RemoteSchemaInputValueDefinition)
viaObject =
      m (FieldDefinition RemoteSchemaInputValueDefinition)
-> (FieldDefinition RemoteSchemaInputValueDefinition
    -> m (FieldDefinition RemoteSchemaInputValueDefinition))
-> Maybe (FieldDefinition RemoteSchemaInputValueDefinition)
-> m (FieldDefinition RemoteSchemaInputValueDefinition)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ValidationError
-> m (FieldDefinition RemoteSchemaInputValueDefinition)
forall a. ValidationError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Name -> Name -> ValidationError
CouldntFindRemoteField Name
name (Name -> ValidationError) -> Name -> ValidationError
forall a b. (a -> b) -> a -> b
$ ObjectTypeDefinition RemoteSchemaInputValueDefinition -> Name
forall inputType. ObjectTypeDefinition inputType -> Name
G._otdName ObjectTypeDefinition RemoteSchemaInputValueDefinition
objFldInfo)) FieldDefinition RemoteSchemaInputValueDefinition
-> m (FieldDefinition RemoteSchemaInputValueDefinition)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (Maybe (FieldDefinition RemoteSchemaInputValueDefinition)
 -> m (FieldDefinition RemoteSchemaInputValueDefinition))
-> (ObjectTypeDefinition RemoteSchemaInputValueDefinition
    -> Maybe (FieldDefinition RemoteSchemaInputValueDefinition))
-> ObjectTypeDefinition RemoteSchemaInputValueDefinition
-> m (FieldDefinition RemoteSchemaInputValueDefinition)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name
-> [(Name, FieldDefinition RemoteSchemaInputValueDefinition)]
-> Maybe (FieldDefinition RemoteSchemaInputValueDefinition)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
name
        ([(Name, FieldDefinition RemoteSchemaInputValueDefinition)]
 -> Maybe (FieldDefinition RemoteSchemaInputValueDefinition))
-> (ObjectTypeDefinition RemoteSchemaInputValueDefinition
    -> [(Name, FieldDefinition RemoteSchemaInputValueDefinition)])
-> ObjectTypeDefinition RemoteSchemaInputValueDefinition
-> Maybe (FieldDefinition RemoteSchemaInputValueDefinition)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Name (FieldDefinition RemoteSchemaInputValueDefinition)
-> [(Name, FieldDefinition RemoteSchemaInputValueDefinition)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList
        (HashMap Name (FieldDefinition RemoteSchemaInputValueDefinition)
 -> [(Name, FieldDefinition RemoteSchemaInputValueDefinition)])
-> (ObjectTypeDefinition RemoteSchemaInputValueDefinition
    -> HashMap Name (FieldDefinition RemoteSchemaInputValueDefinition))
-> ObjectTypeDefinition RemoteSchemaInputValueDefinition
-> [(Name, FieldDefinition RemoteSchemaInputValueDefinition)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldDefinition RemoteSchemaInputValueDefinition -> Name)
-> [FieldDefinition RemoteSchemaInputValueDefinition]
-> HashMap Name (FieldDefinition RemoteSchemaInputValueDefinition)
forall k a. Hashable k => (a -> k) -> [a] -> HashMap k a
mapFromL FieldDefinition RemoteSchemaInputValueDefinition -> Name
forall inputType. FieldDefinition inputType -> Name
G._fldName
        ([FieldDefinition RemoteSchemaInputValueDefinition]
 -> HashMap Name (FieldDefinition RemoteSchemaInputValueDefinition))
-> (ObjectTypeDefinition RemoteSchemaInputValueDefinition
    -> [FieldDefinition RemoteSchemaInputValueDefinition])
-> ObjectTypeDefinition RemoteSchemaInputValueDefinition
-> HashMap Name (FieldDefinition RemoteSchemaInputValueDefinition)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjectTypeDefinition RemoteSchemaInputValueDefinition
-> [FieldDefinition RemoteSchemaInputValueDefinition]
forall inputType.
ObjectTypeDefinition inputType -> [FieldDefinition inputType]
G._otdFieldsDefinition

-- | Validate remote input arguments against the remote schema.
validateRemoteArguments ::
  (MonadError ValidationError m) =>
  HashMap.HashMap G.Name RemoteSchemaInputValueDefinition ->
  HashMap.HashMap G.Name (G.Value G.Name) ->
  HashMap.HashMap G.Name joinField ->
  RemoteSchemaIntrospection ->
  m ()
validateRemoteArguments :: forall (m :: * -> *) joinField.
MonadError ValidationError m =>
HashMap Name RemoteSchemaInputValueDefinition
-> HashMap Name (Value Name)
-> HashMap Name joinField
-> RemoteSchemaIntrospection
-> m ()
validateRemoteArguments HashMap Name RemoteSchemaInputValueDefinition
expectedArguments HashMap Name (Value Name)
providedArguments HashMap Name joinField
permittedVariables RemoteSchemaIntrospection
schemaDocument = do
  ((Name, Value Name) -> m ()) -> [(Name, Value Name)] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Name, Value Name) -> m ()
validateProvided (HashMap Name (Value Name) -> [(Name, Value Name)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Name (Value Name)
providedArguments)
  where
    -- Not neccessary to validate if all required args are provided in the relationship
    -- traverse validateExpected (HashMap.toList expectedArguments)

    validateProvided :: (Name, Value Name) -> m ()
validateProvided (Name
providedName, Value Name
providedValue) =
      case Name
-> HashMap Name RemoteSchemaInputValueDefinition
-> Maybe RemoteSchemaInputValueDefinition
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
providedName HashMap Name RemoteSchemaInputValueDefinition
expectedArguments of
        Maybe RemoteSchemaInputValueDefinition
Nothing -> ValidationError -> m ()
forall a. ValidationError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Name -> ValidationError
NoSuchArgumentForRemote Name
providedName)
        Just (InputValueDefinition -> GType
G._ivdType (InputValueDefinition -> GType)
-> (RemoteSchemaInputValueDefinition -> InputValueDefinition)
-> RemoteSchemaInputValueDefinition
-> GType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteSchemaInputValueDefinition -> InputValueDefinition
_rsitdDefinition -> GType
expectedType) ->
          HashMap Name joinField
-> Value Name -> GType -> RemoteSchemaIntrospection -> m ()
forall (m :: * -> *) joinField.
MonadError ValidationError m =>
HashMap Name joinField
-> Value Name -> GType -> RemoteSchemaIntrospection -> m ()
validateType HashMap Name joinField
permittedVariables Value Name
providedValue GType
expectedType RemoteSchemaIntrospection
schemaDocument

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

-- | Validate a value against a type.
validateType ::
  (MonadError ValidationError m) =>
  HashMap.HashMap G.Name joinField ->
  G.Value G.Name ->
  G.GType ->
  RemoteSchemaIntrospection ->
  m ()
validateType :: forall (m :: * -> *) joinField.
MonadError ValidationError m =>
HashMap Name joinField
-> Value Name -> GType -> RemoteSchemaIntrospection -> m ()
validateType HashMap Name joinField
permittedVariables Value Name
value GType
expectedGType RemoteSchemaIntrospection
schemaDocument =
  case Value Name
value of
    G.VVariable Name
variable ->
      case Name -> HashMap Name joinField -> Maybe joinField
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
variable HashMap Name joinField
permittedVariables of
        Maybe joinField
Nothing -> ValidationError -> m ()
forall a. ValidationError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Name -> HashSet Name -> ValidationError
InvalidVariable Name
variable (HashSet Name -> ValidationError)
-> HashSet Name -> ValidationError
forall a b. (a -> b) -> a -> b
$ HashMap Name joinField -> HashSet Name
forall k a. HashMap k a -> HashSet k
HashMap.keysSet HashMap Name joinField
permittedVariables)
        -- TODO: check whether the type of lhs join field is allowed
        Just joinField
_lhsJoinField -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    G.VInt {} -> do
      let intScalarGType :: GType
intScalarGType = Name -> GType
mkGraphQLType Name
GName._Int
      GType -> GType -> m ()
forall (m :: * -> *).
MonadError ValidationError m =>
GType -> GType -> m ()
isTypeCoercible GType
intScalarGType GType
expectedGType
    G.VFloat {} -> do
      let floatScalarGType :: GType
floatScalarGType = Name -> GType
mkGraphQLType Name
GName._Float
      GType -> GType -> m ()
forall (m :: * -> *).
MonadError ValidationError m =>
GType -> GType -> m ()
isTypeCoercible GType
floatScalarGType GType
expectedGType
    G.VBoolean {} -> do
      let boolScalarGType :: GType
boolScalarGType = Name -> GType
mkGraphQLType Name
GName._Boolean
      GType -> GType -> m ()
forall (m :: * -> *).
MonadError ValidationError m =>
GType -> GType -> m ()
isTypeCoercible GType
boolScalarGType GType
expectedGType
    Value Name
G.VNull -> ValidationError -> m ()
forall a. ValidationError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ValidationError
NullNotAllowedHere
    G.VString {} -> do
      let stringScalarGType :: GType
stringScalarGType = Name -> GType
mkGraphQLType Name
GName._String
      GType -> GType -> m ()
forall (m :: * -> *).
MonadError ValidationError m =>
GType -> GType -> m ()
isTypeCoercible GType
stringScalarGType GType
expectedGType
    G.VEnum EnumValue
_ -> ValidationError -> m ()
forall a. ValidationError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ValidationError
UnsupportedEnum
    G.VList [Value Name]
values -> do
      case [Value Name]
values of
        [] -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        [Value Name
_] -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        [Value Name]
_ -> ValidationError -> m ()
forall a. ValidationError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ValidationError
UnsupportedMultipleElementLists
      GType -> m ()
forall (m :: * -> *). MonadError ValidationError m => GType -> m ()
assertListType GType
expectedGType
      [Value Name] -> (Value Name -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_
        [Value Name]
values
        ( \Value Name
val ->
            HashMap Name joinField
-> Value Name -> GType -> RemoteSchemaIntrospection -> m ()
forall (m :: * -> *) joinField.
MonadError ValidationError m =>
HashMap Name joinField
-> Value Name -> GType -> RemoteSchemaIntrospection -> m ()
validateType HashMap Name joinField
permittedVariables Value Name
val (GType -> GType
unwrapGraphQLType GType
expectedGType) RemoteSchemaIntrospection
schemaDocument
        )
    G.VObject HashMap Name (Value Name)
values ->
      [(Name, Value Name)] -> ((Name, Value Name) -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_
        (HashMap Name (Value Name) -> [(Name, Value Name)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Name (Value Name)
values)
        ( \(Name
name, Value Name
val) ->
            let expectedNamedType :: Name
expectedNamedType = GType -> Name
G.getBaseType GType
expectedGType
             in case RemoteSchemaIntrospection
-> Name
-> Maybe (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
lookupType RemoteSchemaIntrospection
schemaDocument Name
expectedNamedType of
                  Maybe (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
Nothing -> ValidationError -> m ()
forall a. ValidationError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValidationError -> m ()) -> ValidationError -> m ()
forall a b. (a -> b) -> a -> b
$ Name -> ValidationError
TypeNotFound Name
expectedNamedType
                  Just TypeDefinition [Name] RemoteSchemaInputValueDefinition
typeInfo ->
                    case TypeDefinition [Name] RemoteSchemaInputValueDefinition
typeInfo of
                      G.TypeDefinitionInputObject InputObjectTypeDefinition RemoteSchemaInputValueDefinition
inpObjTypeInfo ->
                        let objectTypeDefnsMap :: HashMap Name RemoteSchemaInputValueDefinition
objectTypeDefnsMap =
                              (RemoteSchemaInputValueDefinition -> Name)
-> [RemoteSchemaInputValueDefinition]
-> HashMap Name RemoteSchemaInputValueDefinition
forall k a. Hashable k => (a -> k) -> [a] -> HashMap k a
mapFromL (InputValueDefinition -> Name
G._ivdName (InputValueDefinition -> Name)
-> (RemoteSchemaInputValueDefinition -> InputValueDefinition)
-> RemoteSchemaInputValueDefinition
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteSchemaInputValueDefinition -> InputValueDefinition
_rsitdDefinition) ([RemoteSchemaInputValueDefinition]
 -> HashMap Name RemoteSchemaInputValueDefinition)
-> [RemoteSchemaInputValueDefinition]
-> HashMap Name RemoteSchemaInputValueDefinition
forall a b. (a -> b) -> a -> b
$ InputObjectTypeDefinition RemoteSchemaInputValueDefinition
-> [RemoteSchemaInputValueDefinition]
forall inputType.
InputObjectTypeDefinition inputType -> [inputType]
G._iotdValueDefinitions InputObjectTypeDefinition RemoteSchemaInputValueDefinition
inpObjTypeInfo
                         in case Name
-> HashMap Name RemoteSchemaInputValueDefinition
-> Maybe RemoteSchemaInputValueDefinition
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
name HashMap Name RemoteSchemaInputValueDefinition
objectTypeDefnsMap of
                              Maybe RemoteSchemaInputValueDefinition
Nothing -> ValidationError -> m ()
forall a. ValidationError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValidationError -> m ()) -> ValidationError -> m ()
forall a b. (a -> b) -> a -> b
$ Name -> ValidationError
NoSuchArgumentForRemote Name
name
                              Just (InputValueDefinition -> GType
G._ivdType (InputValueDefinition -> GType)
-> (RemoteSchemaInputValueDefinition -> InputValueDefinition)
-> RemoteSchemaInputValueDefinition
-> GType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteSchemaInputValueDefinition -> InputValueDefinition
_rsitdDefinition -> GType
expectedType) ->
                                HashMap Name joinField
-> Value Name -> GType -> RemoteSchemaIntrospection -> m ()
forall (m :: * -> *) joinField.
MonadError ValidationError m =>
HashMap Name joinField
-> Value Name -> GType -> RemoteSchemaIntrospection -> m ()
validateType HashMap Name joinField
permittedVariables Value Name
val GType
expectedType RemoteSchemaIntrospection
schemaDocument
                      TypeDefinition [Name] RemoteSchemaInputValueDefinition
_ -> do
                        ValidationError -> m ()
forall a. ValidationError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValidationError -> m ()) -> ValidationError -> m ()
forall a b. (a -> b) -> a -> b
$ GType -> Text -> ValidationError
InvalidType (Name -> GType
mkGraphQLType Name
name) Text
"not an input object type"
        )
  where
    mkGraphQLType :: Name -> GType
mkGraphQLType =
      Nullability -> Name -> GType
G.TypeNamed (Bool -> Nullability
G.Nullability Bool
False)

isTypeCoercible ::
  (MonadError ValidationError m) =>
  G.GType ->
  G.GType ->
  m ()
isTypeCoercible :: forall (m :: * -> *).
MonadError ValidationError m =>
GType -> GType -> m ()
isTypeCoercible GType
actualType GType
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 (Name
actualBaseType, Int
actualNestingLevel) = GType -> (Name, Int)
getBaseTyWithNestedLevelsCount GType
actualType
      (Name
expectedBaseType, Int
expectedNestingLevel) = GType -> (Name, Int)
getBaseTyWithNestedLevelsCount GType
expectedType
   in if
        | Name
expectedBaseType Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GName._ID ->
            m () -> m () -> Bool -> m ()
forall a. a -> a -> Bool -> a
bool
              (ValidationError -> m ()
forall a. ValidationError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValidationError -> m ()) -> ValidationError -> m ()
forall a b. (a -> b) -> a -> b
$ Name -> ValidationError
IDTypeJoin Name
actualBaseType)
              (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
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
              ( Name -> Text
G.unName Name
actualBaseType
                  Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"ID", Text
"Int", Text
"String", Text
"bigint", Text
"smallint", Text
"uuid"]
              )
        | Name
actualBaseType Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
expectedBaseType -> m ()
raiseValidationError
        -- we cannot coerce two types with different nesting levels,
        -- for example, we cannot coerce [Int] to [[Int]]
        | (Int
actualNestingLevel Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
expectedNestingLevel Bool -> Bool -> Bool
|| Int
actualNestingLevel Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        | Bool
otherwise -> m ()
raiseValidationError
  where
    raiseValidationError :: m ()
raiseValidationError = ValidationError -> m ()
forall a. ValidationError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValidationError -> m ()) -> ValidationError -> m ()
forall a b. (a -> b) -> a -> b
$ GType -> GType -> ValidationError
ExpectedTypeButGot GType
expectedType GType
actualType

assertListType ::
  (MonadError ValidationError m) =>
  G.GType ->
  m ()
assertListType :: forall (m :: * -> *). MonadError ValidationError m => GType -> m ()
assertListType GType
actualType =
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
    (GType -> Bool
G.isListType GType
actualType)
    (ValidationError -> m ()
forall a. ValidationError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValidationError -> m ()) -> ValidationError -> m ()
forall a b. (a -> b) -> a -> b
$ GType -> Text -> ValidationError
InvalidType GType
actualType Text
"is not a list type")

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