diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,20 @@ # Changelog +## 0.13.0 - Unreleased Changes + +### new features + +- exposed: `Data.Morpheus.Types.GQLScalar` +- exposed: `Data.Morpheus.Types.ID` +- finished interface validation +- supports default values + +## minor changes + +- internal refactoring +- added dependency `mtl` +- validates strings as enum from JSON value + ## 0.12.0 - 21.05.2020 ## New features diff --git a/morpheus-graphql-core.cabal b/morpheus-graphql-core.cabal --- a/morpheus-graphql-core.cabal +++ b/morpheus-graphql-core.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 4a337fa1d88f2e1ca1eb76ec72c4bd0e5e91ef67626a02682384994f6731d446 +-- hash: b13e1668b9269ab28dfdd66f04b342a5bdbec82e6ba59c98c0467604df7270a6 name: morpheus-graphql-core -version: 0.12.0 +version: 0.13.0 synopsis: Morpheus GraphQL Core description: Build GraphQL APIs with your favourite functional language! category: web, graphql @@ -23,14 +23,34 @@ changelog.md README.md data-files: - test/interface/query.gql - test/schema/validation/interface/fail/schema.gql - test/schema/validation/interface/ok/schema.gql - test/simple/query.gql - test/interface/response.json - test/schema/validation/interface/fail/response.json - test/schema/validation/interface/ok/response.json - test/simple/response.json + test/api/interface/query.gql + test/api/simple/query.gql + test/schema/validation/default-value/argument/compound-ok/schema.gql + test/schema/validation/default-value/argument/missing-field/schema.gql + test/schema/validation/default-value/argument/unexpected-value/schema.gql + test/schema/validation/default-value/argument/unknown-field/schema.gql + test/schema/validation/default-value/field/compound-ok/schema.gql + test/schema/validation/default-value/field/missing-field/schema.gql + test/schema/validation/default-value/field/unexpected-value/schema.gql + test/schema/validation/default-value/field/unknown-field/schema.gql + test/schema/validation/interface/field-args/fail/schema.gql + test/schema/validation/interface/field-args/ok/schema.gql + test/schema/validation/interface/field-type/fail/schema.gql + test/schema/validation/interface/field-type/ok/schema.gql + test/api/interface/response.json + test/api/simple/response.json + test/schema/validation/default-value/argument/compound-ok/response.json + test/schema/validation/default-value/argument/missing-field/response.json + test/schema/validation/default-value/argument/unexpected-value/response.json + test/schema/validation/default-value/argument/unknown-field/response.json + test/schema/validation/default-value/field/compound-ok/response.json + test/schema/validation/default-value/field/missing-field/response.json + test/schema/validation/default-value/field/unexpected-value/response.json + test/schema/validation/default-value/field/unknown-field/response.json + test/schema/validation/interface/field-args/fail/response.json + test/schema/validation/interface/field-args/ok/response.json + test/schema/validation/interface/field-type/fail/response.json + test/schema/validation/interface/field-type/ok/response.json source-repository head type: git @@ -46,6 +66,8 @@ Data.Morpheus.Types.Internal.AST Data.Morpheus.Types.IO Data.Morpheus.Types.Internal.Resolving + Data.Morpheus.Types.GQLScalar + Data.Morpheus.Types.ID other-modules: Data.Morpheus.Error.Document.Interface Data.Morpheus.Error.Fragment @@ -73,20 +95,23 @@ Data.Morpheus.Rendering.RenderGQL Data.Morpheus.Rendering.RenderIntrospection Data.Morpheus.Schema.Directives + Data.Morpheus.Schema.DSL Data.Morpheus.Schema.Schema Data.Morpheus.Schema.SchemaAPI Data.Morpheus.Schema.TypeKind Data.Morpheus.Types.Internal.AST.Base - Data.Morpheus.Types.Internal.AST.Data + Data.Morpheus.Types.Internal.AST.DirectiveLocation Data.Morpheus.Types.Internal.AST.MergeSet Data.Morpheus.Types.Internal.AST.OrderedMap Data.Morpheus.Types.Internal.AST.Selection Data.Morpheus.Types.Internal.AST.TH + Data.Morpheus.Types.Internal.AST.TypeSystem Data.Morpheus.Types.Internal.AST.Value Data.Morpheus.Types.Internal.Resolving.Core Data.Morpheus.Types.Internal.Resolving.Resolver Data.Morpheus.Types.Internal.Validation Data.Morpheus.Types.Internal.Validation.Error + Data.Morpheus.Types.Internal.Validation.SchemaValidator Data.Morpheus.Types.Internal.Validation.Validator Data.Morpheus.Types.SelectionTree Data.Morpheus.Validation.Document.Validation @@ -108,6 +133,7 @@ , bytestring >=0.10.4 && <0.11 , hashable >=1.0.0 , megaparsec >=7.0.0 && <9.0.0 + , mtl >=2.0 && <=3.0 , scientific >=0.3.6.2 && <0.4 , template-haskell >=2.0 && <=3.0 , text >=1.2.3.0 && <1.3 @@ -131,9 +157,11 @@ aeson , base >=4.7 && <5 , bytestring >=0.10.4 && <0.11 + , directory >=1.0 , hashable >=1.0.0 , megaparsec >=7.0.0 && <9.0.0 , morpheus-graphql-core + , mtl >=2.0 && <=3.0 , scientific >=0.3.6.2 && <0.4 , tasty , tasty-hunit diff --git a/src/Data/Morpheus/Error/Document/Interface.hs b/src/Data/Morpheus/Error/Document/Interface.hs --- a/src/Data/Morpheus/Error/Document/Interface.hs +++ b/src/Data/Morpheus/Error/Document/Interface.hs @@ -1,22 +1,29 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Data.Morpheus.Error.Document.Interface ( unknownInterface, - partialImplements, + PartialImplements (..), ImplementsError (..), + Place (..), ) where import Data.Morpheus.Error.Utils (globalErrorMessage) import Data.Morpheus.Types.Internal.AST.Base - ( FieldName, + ( FieldName (..), GQLError (..), GQLErrors, - TypeName, + TypeName (..), TypeRef, msg, ) +import Data.Morpheus.Types.Internal.Validation.SchemaValidator + ( Field (..), + Interface (..), + renderField, + ) import Data.Semigroup ((<>)) unknownInterface :: TypeName -> GQLErrors @@ -29,30 +36,70 @@ { expectedType :: TypeRef, foundType :: TypeRef } - | UndefinedField + | Missing -partialImplements :: TypeName -> [(TypeName, FieldName, ImplementsError)] -> GQLErrors -partialImplements name = map impError - where - impError (interfaceName, key, errorType) = - GQLError +data Place = Place + { fieldname :: TypeName, + typename :: FieldName, + fieldArg :: Maybe (FieldName, TypeName) + } + +class PartialImplements ctx where + partialImplements :: ctx -> ImplementsError -> GQLErrors + +instance PartialImplements (Interface, FieldName) where + partialImplements (Interface interfaceName typename, fieldname) errorType = + [ GQLError { message = message, locations = [] } - where - message = - "type " - <> msg name - <> " implements Interface " - <> msg interfaceName - <> " Partially," - <> detailedMessage errorType - detailedMessage UnexpectedType {expectedType, foundType} = - " on key " - <> msg key - <> " expected type " - <> msg expectedType - <> " found " - <> msg foundType - <> "." - detailedMessage UndefinedField = " key " <> msg key <> " not found ." + ] + where + message = + "Interface field " + <> renderField interfaceName fieldname Nothing + <> detailedMessage errorType + detailedMessage UnexpectedType {expectedType, foundType} = + " expects type " + <> msg expectedType + <> " but " + <> renderField typename fieldname Nothing + <> " is type " + <> msg foundType + <> "." + detailedMessage Missing = + " expected but " + <> msg typename + <> " does not provide it." + +-- Interface field TestInterface.name expected but User does not provide it. +-- Interface field TestInterface.name expects type String! but User.name is type Int!. + +instance PartialImplements (Interface, Field) where + partialImplements (Interface interfaceName typename, Field fieldname argName) errorType = + [ GQLError + { message = message, + locations = [] + } + ] + where + -- + message = + "Interface field argument " + <> renderField interfaceName fieldname (Just argName) + <> detailedMessage errorType + detailedMessage UnexpectedType {expectedType, foundType} = + " expects type" + <> msg expectedType + <> " but " + <> renderField typename fieldname (Just argName) + <> " is type " + <> msg foundType + <> "." + detailedMessage Missing = + " expected but " + <> renderField typename fieldname Nothing + <> " does not provide it." + +-- Interface field argument TestInterface.name(id:) expected but User.name does not provide it. +-- Interface field argument TestInterface.name(id:) expects type ID but User.name(id:) is type String. diff --git a/src/Data/Morpheus/Internal/TH.hs b/src/Data/Morpheus/Internal/TH.hs --- a/src/Data/Morpheus/Internal/TH.hs +++ b/src/Data/Morpheus/Internal/TH.hs @@ -10,9 +10,7 @@ {-# LANGUAGE TypeApplications #-} module Data.Morpheus.Internal.TH - ( declareType, - tyConArgs, - Scope (..), + ( tyConArgs, apply, applyT, typeT, @@ -34,42 +32,39 @@ nameConE, nameVarP, mkTypeName, + mkFieldName, + declareTypeRef, + nameSpaceField, + nameSpaceType, + m_, + m', + isEnum, ) where -import Data.Maybe (maybe) -- MORPHEUS import Data.Morpheus.Internal.Utils ( nameSpaceField, nameSpaceType, ) import Data.Morpheus.Types.Internal.AST - ( ArgumentsDefinition (..), - ConsD (..), - DataTypeKind (..), - DataTypeKind (..), - FieldDefinition (..), - FieldName, - TypeD (..), + ( FieldName, + TypeKind (..), + TypeKind (..), TypeName (..), TypeRef (..), TypeWrapper (..), convertToHaskellName, isEnum, isOutputObject, - isSubscription, readName, ) import Data.Morpheus.Types.Internal.Resolving ( UnSubResolver, ) -import Data.Semigroup ((<>)) import Data.Text (unpack) -import GHC.Generics (Generic) import Language.Haskell.TH -type Arrow = (->) - m' :: Type m' = VarT $ mkTypeName m_ @@ -94,55 +89,10 @@ decType (Just par) = AppT typeName (VarT $ mkTypeName par) decType _ = typeName -tyConArgs :: DataTypeKind -> [TypeName] +tyConArgs :: TypeKind -> [TypeName] tyConArgs kindD | isOutputObject kindD || kindD == KindUnion = [m_] | otherwise = [] - -data Scope = CLIENT | SERVER - deriving (Eq) - -declareType :: Scope -> Bool -> Maybe DataTypeKind -> [Name] -> TypeD -> Dec -declareType scope namespace kindD derivingList TypeD {tName, tCons, tNamespace} = - DataD [] (genName tName) tVars Nothing cons $ - map derive (''Generic : derivingList) - where - genName = mkTypeName . nameSpaceType tNamespace - tVars = maybe [] (declareTyVar . tyConArgs) kindD - where - declareTyVar = map (PlainTV . mkTypeName) - defBang = Bang NoSourceUnpackedness NoSourceStrictness - derive className = DerivClause Nothing [ConT className] - cons - | scope == CLIENT && isEnum tCons = map consE tCons - | otherwise = map consR tCons - consE ConsD {cName} = NormalC (genName $ tName <> cName) [] - consR ConsD {cName, cFields} = - RecC - (genName cName) - (map declareField cFields) - where - declareField FieldDefinition {fieldName, fieldArgs, fieldType} = - (mkFieldName fName, defBang, fiType) - where - fName - | namespace = nameSpaceField tName fieldName - | otherwise = fieldName - fiType = genFieldT fieldArgs - where - --------------------------- - genFieldT ArgumentsDefinition {argumentsTypename = Just argsTypename} = - AppT - (AppT arrowType argType) - (AppT m' result) - where - argType = ConT $ mkTypeName argsTypename - arrowType = ConT ''Arrow - genFieldT _ - | (isOutputObject <$> kindD) == Just True = AppT m' result - | otherwise = result - ------------------------------------------------ - result = declareTypeRef (maybe False isSubscription kindD) fieldType apply :: Name -> [Q Exp] -> Q Exp apply n = foldl appE (conE n) diff --git a/src/Data/Morpheus/Parsing/Document/TypeSystem.hs b/src/Data/Morpheus/Parsing/Document/TypeSystem.hs --- a/src/Data/Morpheus/Parsing/Document/TypeSystem.hs +++ b/src/Data/Morpheus/Parsing/Document/TypeSystem.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Data.Morpheus.Parsing.Document.TypeSystem ( parseSchema, @@ -33,12 +34,13 @@ DataFingerprint (..), Description, IN, - Meta (..), OUT, ScalarDefinition (..), TypeContent (..), TypeDefinition (..), TypeName, + UnionMember (..), + mkUnionMember, toAny, ) import Data.Morpheus.Types.Internal.Resolving @@ -59,15 +61,14 @@ -- Description(opt) scalar Name Directives(Const)(opt) -- scalarTypeDefinition :: Maybe Description -> Parser (TypeDefinition ANY) -scalarTypeDefinition metaDescription = label "ScalarTypeDefinition" $ do +scalarTypeDefinition typeDescription = label "ScalarTypeDefinition" $ do typeName <- typeDeclaration "scalar" - metaDirectives <- optionalDirectives + typeDirectives <- optionalDirectives pure TypeDefinition - { typeName, - typeMeta = Just Meta {metaDescription, metaDirectives}, - typeFingerprint = DataFingerprint typeName [], - typeContent = DataScalar $ ScalarDefinition pure + { typeFingerprint = DataFingerprint typeName [], + typeContent = DataScalar $ ScalarDefinition pure, + .. } -- Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Objects @@ -86,18 +87,17 @@ -- Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt) -- objectTypeDefinition :: Maybe Description -> Parser (TypeDefinition OUT) -objectTypeDefinition metaDescription = label "ObjectTypeDefinition" $ do +objectTypeDefinition typeDescription = label "ObjectTypeDefinition" $ do typeName <- typeDeclaration "type" objectImplements <- optionalImplementsInterfaces - metaDirectives <- optionalDirectives + typeDirectives <- optionalDirectives objectFields <- fieldsDefinition -- build object pure TypeDefinition - { typeName, - typeMeta = Just Meta {metaDescription, metaDirectives}, - typeFingerprint = DataFingerprint typeName [], - typeContent = DataObject {objectImplements, objectFields} + { typeFingerprint = DataFingerprint typeName [], + typeContent = DataObject {objectImplements, objectFields}, + .. } optionalImplementsInterfaces :: Parser [TypeName] @@ -112,17 +112,14 @@ -- Description(opt) interface Name Directives(Const)(opt) FieldsDefinition(opt) -- interfaceTypeDefinition :: Maybe Description -> Parser (TypeDefinition OUT) -interfaceTypeDefinition metaDescription = label "InterfaceTypeDefinition" $ do +interfaceTypeDefinition typeDescription = label "InterfaceTypeDefinition" $ do typeName <- typeDeclaration "interface" - metaDirectives <- optionalDirectives - fields <- fieldsDefinition - -- build interface + typeDirectives <- optionalDirectives + typeContent <- DataInterface <$> fieldsDefinition pure TypeDefinition - { typeName, - typeMeta = Just Meta {metaDescription, metaDirectives}, - typeFingerprint = DataFingerprint typeName [], - typeContent = DataInterface fields + { typeFingerprint = DataFingerprint typeName [], + .. } -- Unions : https://graphql.github.io/graphql-spec/June2018/#sec-Unions @@ -135,20 +132,17 @@ -- UnionMemberTypes | NamedType -- unionTypeDefinition :: Maybe Description -> Parser (TypeDefinition OUT) -unionTypeDefinition metaDescription = label "UnionTypeDefinition" $ do +unionTypeDefinition typeDescription = label "UnionTypeDefinition" $ do typeName <- typeDeclaration "union" - metaDirectives <- optionalDirectives - memberTypes <- unionMemberTypes - -- build union + typeDirectives <- optionalDirectives + typeContent <- DataUnion <$> unionMemberTypes pure TypeDefinition - { typeName, - typeMeta = Just Meta {metaDescription, metaDirectives}, - typeFingerprint = DataFingerprint typeName [], - typeContent = DataUnion memberTypes + { typeFingerprint = DataFingerprint typeName [], + .. } where - unionMemberTypes = operator '=' *> parseTypeName `sepBy1` pipeLiteral + unionMemberTypes = operator '=' *> (mkUnionMember <$> parseTypeName) `sepBy1` pipeLiteral -- Enums : https://graphql.github.io/graphql-spec/June2018/#sec-Enums -- @@ -162,17 +156,14 @@ -- Description(opt) EnumValue Directives(Const)(opt) -- enumTypeDefinition :: Maybe Description -> Parser (TypeDefinition ANY) -enumTypeDefinition metaDescription = label "EnumTypeDefinition" $ do +enumTypeDefinition typeDescription = label "EnumTypeDefinition" $ do typeName <- typeDeclaration "enum" - metaDirectives <- optionalDirectives - enumValuesDefinitions <- collection enumValueDefinition - -- build enum + typeDirectives <- optionalDirectives + typeContent <- DataEnum <$> collection enumValueDefinition pure TypeDefinition - { typeName, - typeContent = DataEnum enumValuesDefinitions, - typeFingerprint = DataFingerprint typeName [], - typeMeta = Just Meta {metaDescription, metaDirectives} + { typeFingerprint = DataFingerprint typeName [], + .. } -- Input Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Input-Objects @@ -184,18 +175,16 @@ -- { InputValueDefinition(list) } -- inputObjectTypeDefinition :: Maybe Description -> Parser (TypeDefinition IN) -inputObjectTypeDefinition metaDescription = +inputObjectTypeDefinition typeDescription = label "InputObjectTypeDefinition" $ do typeName <- typeDeclaration "input" - metaDirectives <- optionalDirectives - fields <- inputFieldsDefinition + typeDirectives <- optionalDirectives + typeContent <- DataInputObject <$> inputFieldsDefinition -- build input pure TypeDefinition - { typeName, - typeContent = DataInputObject fields, - typeFingerprint = DataFingerprint typeName [], - typeMeta = Just Meta {metaDescription, metaDirectives} + { typeFingerprint = DataFingerprint typeName [], + .. } parseDataType :: Parser (TypeDefinition ANY) diff --git a/src/Data/Morpheus/Parsing/Internal/Pattern.hs b/src/Data/Morpheus/Parsing/Internal/Pattern.hs --- a/src/Data/Morpheus/Parsing/Internal/Pattern.hs +++ b/src/Data/Morpheus/Parsing/Internal/Pattern.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} module Data.Morpheus.Parsing.Internal.Pattern @@ -13,15 +12,12 @@ where -- MORPHEUS - import Data.Morpheus.Parsing.Internal.Arguments ( maybeArguments, ) import Data.Morpheus.Parsing.Internal.Internal ( Parser, - ) -import Data.Morpheus.Parsing.Internal.Internal - ( getLocation, + getLocation, ) import Data.Morpheus.Parsing.Internal.Terms ( keyword, @@ -42,20 +38,20 @@ ( ArgumentsDefinition (..), DataEnumValue (..), Directive (..), + FieldContent (..), FieldDefinition (..), FieldName, FieldsDefinition, IN, InputFieldsDefinition, - Meta (..), OUT, TypeName, Value, ) import Text.Megaparsec - ( (<|>), - label, + ( label, many, + optional, ) -- EnumValueDefinition: https://graphql.github.io/graphql-spec/June2018/#EnumValueDefinition @@ -65,14 +61,10 @@ -- enumValueDefinition :: Parser DataEnumValue enumValueDefinition = label "EnumValueDefinition" $ do - metaDescription <- optDescription + enumDescription <- optDescription enumName <- parseTypeName - metaDirectives <- optionalDirectives - return $ - DataEnumValue - { enumName, - enumMeta = Just Meta {metaDescription, metaDirectives} - } + enumDirectives <- optionalDirectives + return DataEnumValue {..} -- InputValue : https://graphql.github.io/graphql-spec/June2018/#InputValueDefinition -- @@ -81,19 +73,13 @@ -- inputValueDefinition :: Parser (FieldDefinition IN) inputValueDefinition = label "InputValueDefinition" $ do - metaDescription <- optDescription + fieldDescription <- optDescription fieldName <- parseName litAssignment -- ':' fieldType <- parseType - _ <- parseDefaultValue - metaDirectives <- optionalDirectives - pure - FieldDefinition - { fieldArgs = NoArguments, - fieldName, - fieldType, - fieldMeta = Just Meta {metaDescription, metaDirectives} - } + fieldContent <- optional (DefaultInputValue <$> parseDefaultValue) + fieldDirectives <- optionalDirectives + pure FieldDefinition {..} -- Field Arguments: https://graphql.github.io/graphql-spec/June2018/#sec-Field-Arguments -- @@ -104,7 +90,6 @@ argumentsDefinition = label "ArgumentsDefinition" $ uniqTuple inputValueDefinition - <|> pure NoArguments -- FieldsDefinition : https://graphql.github.io/graphql-spec/June2018/#FieldsDefinition -- @@ -119,19 +104,13 @@ -- fieldDefinition :: Parser (FieldDefinition OUT) fieldDefinition = label "FieldDefinition" $ do - metaDescription <- optDescription + fieldDescription <- optDescription fieldName <- parseName - fieldArgs <- argumentsDefinition + fieldContent <- optional (FieldArgs <$> argumentsDefinition) litAssignment -- ':' fieldType <- parseType - metaDirectives <- optionalDirectives - pure - FieldDefinition - { fieldName, - fieldArgs, - fieldType, - fieldMeta = Just Meta {metaDescription, metaDirectives} - } + fieldDirectives <- optionalDirectives + pure FieldDefinition {..} -- InputFieldsDefinition : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Directives -- InputFieldsDefinition: diff --git a/src/Data/Morpheus/Parsing/Internal/Value.hs b/src/Data/Morpheus/Parsing/Internal/Value.hs --- a/src/Data/Morpheus/Parsing/Internal/Value.hs +++ b/src/Data/Morpheus/Parsing/Internal/Value.hs @@ -45,7 +45,6 @@ choice, label, many, - optional, sepBy, ) import Text.Megaparsec.Char @@ -116,8 +115,8 @@ parsePrimitives = valueNull <|> booleanValue <|> valueNumber <|> enumValue <|> stringValue -parseDefaultValue :: Parser (Maybe ResolvedValue) -parseDefaultValue = optional $ do +parseDefaultValue :: Parser ResolvedValue +parseDefaultValue = do litEquals parseV where diff --git a/src/Data/Morpheus/Parsing/JSONSchema/Parse.hs b/src/Data/Morpheus/Parsing/JSONSchema/Parse.hs --- a/src/Data/Morpheus/Parsing/JSONSchema/Parse.hs +++ b/src/Data/Morpheus/Parsing/JSONSchema/Parse.hs @@ -42,10 +42,11 @@ TypeWrapper, createArgument, createEnumType, - createField, createScalarType, createType, createUnionType, + mkField, + mkObjectField, msg, toAny, toHSWrappers, @@ -93,13 +94,13 @@ parse Field {fieldName, fieldArgs, fieldType} = do fType <- fieldTypeFromJSON fieldType args <- traverse genArg fieldArgs >>= fromElems - pure $ createField (ArgumentsDefinition Nothing args) fieldName fType + pure $ mkObjectField (ArgumentsDefinition Nothing args) fieldName fType where genArg InputValue {inputName = argName, inputType = argType} = createArgument argName <$> fieldTypeFromJSON argType instance ParseJSONSchema InputValue (FieldDefinition IN) where - parse InputValue {inputName, inputType} = createField NoArguments inputName <$> fieldTypeFromJSON inputType + parse InputValue {inputName, inputType} = mkField inputName <$> fieldTypeFromJSON inputType fieldTypeFromJSON :: Type -> Eventless ([TypeWrapper], TypeName) fieldTypeFromJSON = fmap toHs . fieldTypeRec [] diff --git a/src/Data/Morpheus/Parsing/Request/Operation.hs b/src/Data/Morpheus/Parsing/Request/Operation.hs --- a/src/Data/Morpheus/Parsing/Request/Operation.hs +++ b/src/Data/Morpheus/Parsing/Request/Operation.hs @@ -60,7 +60,7 @@ (Ref variableName variablePosition) <- variable operator ':' variableType <- parseType - variableValue <- DefaultValue <$> parseDefaultValue + variableValue <- DefaultValue <$> optional parseDefaultValue pure Variable {..} -- Operations : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Operations diff --git a/src/Data/Morpheus/Rendering/RenderGQL.hs b/src/Data/Morpheus/Rendering/RenderGQL.hs --- a/src/Data/Morpheus/Rendering/RenderGQL.hs +++ b/src/Data/Morpheus/Rendering/RenderGQL.hs @@ -13,12 +13,26 @@ import Data.Text ( Text, intercalate, + pack, ) type Rendering = Text class RenderGQL a where render :: a -> Rendering + +instance RenderGQL Int where + render = pack . show + +instance RenderGQL Float where + render = pack . show + +instance RenderGQL Text where + render = pack . show + +instance RenderGQL Bool where + render True = "true" + render False = "false" renderIndent :: Rendering renderIndent = " " diff --git a/src/Data/Morpheus/Rendering/RenderIntrospection.hs b/src/Data/Morpheus/Rendering/RenderIntrospection.hs --- a/src/Data/Morpheus/Rendering/RenderIntrospection.hs +++ b/src/Data/Morpheus/Rendering/RenderIntrospection.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -19,35 +20,46 @@ -- Morpheus import Data.Morpheus.Internal.Utils - ( elems, + ( Failure, + elems, failure, + fromElems, selectBy, + selectOr, ) +import qualified Data.Morpheus.Rendering.RenderGQL as GQL (RenderGQL (..)) import Data.Morpheus.Schema.TypeKind (TypeKind (..)) +import qualified Data.Morpheus.Types.Internal.AST as AST (TypeKind (..)) import Data.Morpheus.Types.Internal.AST - ( ArgumentsDefinition (..), + ( ANY, + ArgumentsDefinition (..), DataEnumValue (..), - DataInputUnion, - DataInputUnion, - DataTypeKind (..), DataTypeWrapper (..), - DataUnion, Description, DirectiveDefinition (..), DirectiveLocation, + Directives, + FieldContent (..), FieldDefinition (..), FieldName (..), FieldsDefinition, + GQLErrors, IN, Message, - Meta (..), OUT, + Object, + ObjectEntry (..), QUERY, + RESOLVED, Schema, + TRUE, TypeContent (..), TypeDefinition (..), TypeName (..), TypeRef (..), + UnionMember (..), + VALID, + Value (..), createInputUnionFields, fieldVisibility, kindOf, @@ -57,298 +69,334 @@ toGQLWrapper, ) import Data.Morpheus.Types.Internal.Resolving - ( ResModel, + ( Context (..), + ResModel, Resolver, mkBoolean, mkList, mkNull, mkObject, mkString, + unsafeInternalContext, ) import Data.Semigroup ((<>)) import Data.Text (pack) -constRes :: Applicative m => a -> b -> m a -constRes = const . pure +type Result e m a = Resolver QUERY e m a -type Result e m a = Schema -> Resolver QUERY e m a +class + ( Monad m, + Failure Message m, + Failure GQLErrors m + ) => + WithSchema m + where + getSchema :: m Schema -class RenderSchema a where - render :: (Monad m) => a -> Schema -> Resolver QUERY e m (ResModel QUERY e m) +instance Monad m => WithSchema (Resolver QUERY e m) where + getSchema = schema <$> unsafeInternalContext -instance RenderSchema DirectiveDefinition where +selectType :: + WithSchema m => + TypeName -> + m (TypeDefinition ANY) +selectType name = + getSchema + >>= selectBy (" INTERNAL: INTROSPECTION Type not Found: \"" <> msg name <> "\"") name + +class RenderIntrospection a where + render :: + (Monad m) => + a -> + Resolver QUERY e m (ResModel QUERY e m) + +instance RenderIntrospection TypeName where + render = pure . mkString . readTypeName + +instance RenderIntrospection FieldName where + render = pure . mkString . readName + +instance RenderIntrospection Description where + render = pure . mkString + +instance RenderIntrospection TypeKind where + render = pure . mkString . pack . show + +instance RenderIntrospection a => RenderIntrospection [a] where + render ls = mkList <$> traverse render ls + +instance RenderIntrospection DirectiveDefinition where render DirectiveDefinition { directiveDefinitionName, directiveDefinitionDescription, directiveDefinitionLocations, directiveDefinitionArgs - } - schema = + } = pure $ mkObject "__Directive" - [ renderFieldName directiveDefinitionName, - renderDescription directiveDefinitionDescription, - ("locations", render directiveDefinitionLocations schema), - ("args", mkList <$> renderArguments directiveDefinitionArgs schema) + [ renderName directiveDefinitionName, + description directiveDefinitionDescription, + ("locations", render directiveDefinitionLocations), + ("args", render directiveDefinitionArgs) ] -instance RenderSchema a => RenderSchema [a] where - render ls schema = mkList <$> traverse (`render` schema) ls +instance RenderIntrospection DirectiveLocation where + render locations = pure $ mkString (pack $ show locations) -instance RenderSchema DirectiveLocation where - render locations _ = pure $ mkString (pack $ show locations) +instance RenderIntrospection (TypeDefinition a) where + render + TypeDefinition + { typeName, + typeDescription, + typeContent + } = pure $ renderContent typeContent + where + __type :: Monad m => TypeKind -> [(FieldName, Resolver QUERY e m (ResModel QUERY e m))] -> ResModel QUERY e m + __type kind = mkType kind typeName typeDescription + renderContent :: Monad m => TypeContent bool a -> ResModel QUERY e m + renderContent DataScalar {} = __type SCALAR [] + renderContent (DataEnum enums) = __type ENUM [("enumValues", render enums)] + renderContent (DataInputObject inputFiels) = + __type + INPUT_OBJECT + [("inputFields", render inputFiels)] + renderContent DataObject {objectImplements, objectFields} = + createObjectType typeName typeDescription objectImplements objectFields + renderContent (DataUnion union) = + __type + UNION + [("possibleTypes", render union)] + renderContent (DataInputUnion members) = + __type + INPUT_OBJECT + [ ( "inputFields", + render + $ createInputUnionFields typeName + $ filter visibility members + ) + ] + renderContent (DataInterface fields) = + __type + INTERFACE + [ ("fields", render fields), + ("possibleTypes", interfacePossibleTypes typeName) + ] -instance RenderSchema (TypeDefinition a) where - render TypeDefinition {typeName, typeMeta, typeContent} = __render typeContent - where - __render :: - (Monad m) => TypeContent bool a -> Schema -> Resolver QUERY e m (ResModel QUERY e m) - __render DataScalar {} = - constRes $ createLeafType SCALAR typeName typeMeta Nothing - __render (DataEnum enums) = - constRes $ - createLeafType ENUM typeName typeMeta (Just $ map createEnumValue enums) - __render (DataInputObject fields) = \lib -> - createInputObject typeName typeMeta - <$> traverse (`renderinputValue` lib) (elems fields) - __render DataObject {objectImplements, objectFields} = - pure . createObjectType typeName typeMeta objectImplements objectFields - __render (DataUnion union) = \schema -> - pure $ typeFromUnion schema (typeName, typeMeta, union) - __render (DataInputUnion members) = - renderInputUnion (typeName, typeMeta, members) - __render (DataInterface fields) = - renderInterface typeName Nothing fields +instance RenderIntrospection (UnionMember OUT) where + render UnionMember {memberName} = selectType memberName >>= render -renderFields :: Monad m => Schema -> FieldsDefinition cat -> Resolver QUERY e m [ResModel QUERY e m] -renderFields schema = traverse (`render` schema) . filter fieldVisibility . elems +instance RenderIntrospection (FieldDefinition cat) => RenderIntrospection (FieldsDefinition cat) where + render = render . filter fieldVisibility . elems -renderInterface :: - Monad m => TypeName -> Maybe Meta -> FieldsDefinition OUT -> Schema -> Resolver QUERY e m (ResModel QUERY e m) -renderInterface name meta fields schema = - pure $ - mkObject - "__Type" - [ renderKind INTERFACE, - renderName name, - description meta, - ("fields", mkList <$> renderFields schema fields), - ("possibleTypes", mkList <$> interfacePossibleTypes schema name) +instance RenderIntrospection (FieldDefinition OUT) where + render FieldDefinition {..} = + pure + $ mkObject "__Field" + $ [ renderName fieldName, + description fieldDescription, + type' fieldType, + ("args", maybe (pure $ mkList []) render fieldContent) + ] + <> renderDeprecated fieldDirectives + +instance RenderIntrospection (FieldContent TRUE OUT) where + render (FieldArgs args) = render args + +instance RenderIntrospection ArgumentsDefinition where + render ArgumentsDefinition {arguments} = mkList <$> traverse render (elems arguments) + +instance RenderIntrospection (FieldDefinition IN) where + render FieldDefinition {..} = + pure $ + mkObject + "__InputValue" + [ renderName fieldName, + description fieldDescription, + type' fieldType, + defaultValue fieldType (fmap defaultInputValue fieldContent) + ] + +instance RenderIntrospection DataEnumValue where + render DataEnumValue {enumName, enumDescription, enumDirectives} = + pure $ mkObject "__Field" $ + [ renderName enumName, + description enumDescription ] + <> renderDeprecated enumDirectives +instance RenderIntrospection TypeRef where + render TypeRef {typeConName, typeWrappers} = do + kind <- lookupKind typeConName + let currentType = mkType kind typeConName Nothing [] + pure $ foldr wrap currentType (toGQLWrapper typeWrappers) + where + wrap :: Monad m => DataTypeWrapper -> ResModel QUERY e m -> ResModel QUERY e m + wrap wrapper contentType = + mkObject + "__Type" + [ renderKind (wrapperKind wrapper), + ("ofType", pure contentType) + ] + wrapperKind ListType = LIST + wrapperKind NonNullType = NON_NULL + interfacePossibleTypes :: (Monad m) => - Schema -> TypeName -> - Resolver QUERY e m [ResModel QUERY e m] -interfacePossibleTypes schema interfaceName = sequence $ concatMap implements (elems schema) + Resolver QUERY e m (ResModel QUERY e m) +interfacePossibleTypes interfaceName = + mkList + <$> ( getSchema + >>= sequence + . concatMap implements + . elems + ) where implements typeDef@TypeDefinition {typeContent = DataObject {objectImplements}, ..} - | interfaceName `elem` objectImplements = [render typeDef schema] + | interfaceName `elem` objectImplements = [render typeDef] implements _ = [] -createEnumValue :: Monad m => DataEnumValue -> ResModel QUERY e m -createEnumValue DataEnumValue {enumName, enumMeta} = - mkObject "__Field" $ - [ renderName enumName, - description enumMeta - ] - <> renderDeprecated enumMeta - renderDeprecated :: (Monad m) => - Maybe Meta -> + Directives VALID -> [(FieldName, Resolver QUERY e m (ResModel QUERY e m))] -renderDeprecated meta = - [ ("isDeprecated", pure $ mkBoolean (isJust $ meta >>= lookupDeprecated)), - ("deprecationReason", opt (pure . mkString) (meta >>= lookupDeprecated >>= lookupDeprecatedReason)) +renderDeprecated dirs = + [ ("isDeprecated", pure $ mkBoolean (isJust $ lookupDeprecated dirs)), + ("deprecationReason", opt (pure . mkString) (lookupDeprecated dirs >>= lookupDeprecatedReason)) ] -description :: Monad m => Maybe Meta -> (FieldName, Resolver QUERY e m (ResModel QUERY e m)) -description enumMeta = renderDescription (enumMeta >>= metaDescription) - -renderDescription :: Monad m => Maybe Description -> (FieldName, Resolver QUERY e m (ResModel QUERY e m)) -renderDescription desc = ("description", opt (pure . mkString) desc) - -renderArguments :: (Monad m) => ArgumentsDefinition -> Schema -> Resolver QUERY e m [ResModel QUERY e m] -renderArguments ArgumentsDefinition {arguments} lib = traverse (`renderinputValue` lib) $ elems arguments -renderArguments NoArguments _ = pure [] - -instance RenderSchema (FieldDefinition cat) where - render field@FieldDefinition {fieldName, fieldType = TypeRef {typeConName}, fieldArgs, fieldMeta} lib = - do - kind <- renderTypeKind <$> lookupKind typeConName lib - pure - $ mkObject "__Field" - $ [ renderFieldName fieldName, - description fieldMeta, - ("args", mkList <$> renderArguments fieldArgs lib), - ("type", pure (withTypeWrapper field $ createType kind typeConName Nothing $ Just [])) - ] - <> renderDeprecated fieldMeta - -renderTypeKind :: DataTypeKind -> TypeKind -renderTypeKind KindScalar = SCALAR -renderTypeKind (KindObject _) = OBJECT -renderTypeKind KindUnion = UNION -renderTypeKind KindInputUnion = INPUT_OBJECT -renderTypeKind KindEnum = ENUM -renderTypeKind KindInputObject = INPUT_OBJECT -renderTypeKind KindList = LIST -renderTypeKind KindNonNull = NON_NULL -renderTypeKind KindInterface = INTERFACE - -lookupKind :: (Monad m) => TypeName -> Result e m DataTypeKind -lookupKind name schema = kindOf <$> selectBy ("Kind Not Found: " <> msg name) name schema - -renderinputValue :: - (Monad m) => - FieldDefinition IN -> - Result e m (ResModel QUERY e m) -renderinputValue input = fmap (createInputValueWith (fieldName input) (fieldMeta input)) . createInputObjectType input +description :: Monad m => Maybe Description -> (FieldName, Resolver QUERY e m (ResModel QUERY e m)) +description desc = ("description", opt render desc) -createInputObjectType :: - (Monad m) => FieldDefinition IN -> Result e m (ResModel QUERY e m) -createInputObjectType field@FieldDefinition {fieldType = TypeRef {typeConName}} lib = - do - kind <- renderTypeKind <$> lookupKind typeConName lib - pure $ withTypeWrapper field $ createType kind typeConName Nothing $ Just [] +lookupKind :: (Monad m) => TypeName -> Result e m TypeKind +lookupKind = fmap (renderTypeKind . kindOf) . selectType -renderInputUnion :: - (Monad m) => - (TypeName, Maybe Meta, DataInputUnion) -> - Result e m (ResModel QUERY e m) -renderInputUnion (key, meta, fields) lib = - createInputObject key meta - <$> traverse - createField - (createInputUnionFields key $ map fst $ filter snd fields) - where - createField field = - createInputValueWith (fieldName field) Nothing <$> createInputObjectType field lib +renderTypeKind :: AST.TypeKind -> TypeKind +renderTypeKind AST.KindScalar = SCALAR +renderTypeKind (AST.KindObject _) = OBJECT +renderTypeKind AST.KindUnion = UNION +renderTypeKind AST.KindInputUnion = INPUT_OBJECT +renderTypeKind AST.KindEnum = ENUM +renderTypeKind AST.KindInputObject = INPUT_OBJECT +renderTypeKind AST.KindList = LIST +renderTypeKind AST.KindNonNull = NON_NULL +renderTypeKind AST.KindInterface = INTERFACE -createLeafType :: - Monad m => +mkType :: + (Monad m, RenderIntrospection name) => TypeKind -> - TypeName -> - Maybe Meta -> - Maybe [ResModel QUERY e m] -> + name -> + Maybe Description -> + [(FieldName, Resolver QUERY e m (ResModel QUERY e m))] -> ResModel QUERY e m -createLeafType kind name meta enums = - mkObject - "__Type" - [ renderKind kind, - renderName name, - description meta, - ("enumValues", optList enums) - ] - -typeFromUnion :: Monad m => Schema -> (TypeName, Maybe Meta, DataUnion) -> ResModel QUERY e m -typeFromUnion schema (name, typeMeta, typeContent) = +mkType kind name desc etc = mkObject "__Type" - [ renderKind UNION, - renderName name, - description typeMeta, - ("possibleTypes", mkList <$> traverse (unionPossibleType schema) typeContent) - ] - -unionPossibleType :: Monad m => Schema -> TypeName -> Resolver QUERY e m (ResModel QUERY e m) -unionPossibleType schema name = - selectBy (" INTERNAL: INTROSPECTION Type not Found: \"" <> msg name <> "\"") name schema - >>= (`render` schema) + ( [ renderKind kind, + renderName name, + description desc + ] + <> etc + ) createObjectType :: - Monad m => TypeName -> Maybe Meta -> [TypeName] -> FieldsDefinition OUT -> Schema -> ResModel QUERY e m -createObjectType name meta interfaces fields schema = - mkObject - "__Type" - [ renderKind OBJECT, - renderName name, - description meta, - ("fields", mkList <$> renderFields schema fields), - ("interfaces", mkList <$> traverse (implementedInterface schema) interfaces) - ] + Monad m => TypeName -> Maybe Description -> [TypeName] -> FieldsDefinition OUT -> ResModel QUERY e m +createObjectType name desc interfaces fields = + mkType OBJECT name desc [("fields", render fields), ("interfaces", mkList <$> traverse implementedInterface interfaces)] implementedInterface :: (Monad m) => - Schema -> TypeName -> Resolver QUERY e m (ResModel QUERY e m) -implementedInterface schema name = - selectBy ("INTERNAL: cant found Interface " <> msg name) name schema - >>= __render +implementedInterface name = + selectType name + >>= renderContent where - __render typeDef@TypeDefinition {typeContent = DataInterface {}} = render typeDef schema - __render _ = failure ("Type " <> msg name <> " must be an Interface" :: Message) - -optList :: Monad m => Maybe [ResModel QUERY e m] -> Resolver QUERY e m (ResModel QUERY e m) -optList = pure . maybe mkNull mkList - -createInputObject :: - Monad m => TypeName -> Maybe Meta -> [ResModel QUERY e m] -> ResModel QUERY e m -createInputObject name meta fields = - mkObject - "__Type" - [ renderKind INPUT_OBJECT, - renderName name, - description meta, - ("inputFields", pure $ mkList fields) - ] - -createType :: - Monad m => - TypeKind -> - TypeName -> - Maybe Meta -> - Maybe [ResModel QUERY e m] -> - ResModel QUERY e m -createType kind name desc fields = - mkObject - "__Type" - [ renderKind kind, - renderName name, - description desc, - ("fields", pure $ maybe mkNull mkList fields), - ("enumValues", pure $ mkList []) - ] + renderContent typeDef@TypeDefinition {typeContent = DataInterface {}} = render typeDef + renderContent _ = failure ("Type " <> msg name <> " must be an Interface" :: Message) opt :: Monad m => (a -> Resolver QUERY e m (ResModel QUERY e m)) -> Maybe a -> Resolver QUERY e m (ResModel QUERY e m) opt f (Just x) = f x opt _ Nothing = pure mkNull -renderName :: Monad m => TypeName -> (FieldName, Resolver QUERY e m (ResModel QUERY e m)) -renderName = ("name",) . pure . mkString . readTypeName - -renderFieldName :: Monad m => FieldName -> (FieldName, Resolver QUERY e m (ResModel QUERY e m)) -renderFieldName (FieldName name) = ("name", pure $ mkString name) +renderName :: + ( RenderIntrospection name, + Monad m + ) => + name -> + (FieldName, Resolver QUERY e m (ResModel QUERY e m)) +renderName = ("name",) . render renderKind :: Monad m => TypeKind -> (FieldName, Resolver QUERY e m (ResModel QUERY e m)) -renderKind = ("kind",) . pure . mkString . pack . show +renderKind = ("kind",) . render -withTypeWrapper :: Monad m => FieldDefinition cat -> ResModel QUERY e m -> ResModel QUERY e m -withTypeWrapper FieldDefinition {fieldType = TypeRef {typeWrappers}} typ = - foldr wrapAs typ (toGQLWrapper typeWrappers) +type' :: Monad m => TypeRef -> (FieldName, Resolver QUERY e m (ResModel QUERY e m)) +type' ref = ("type", render ref) -wrapAs :: Monad m => DataTypeWrapper -> ResModel QUERY e m -> ResModel QUERY e m -wrapAs wrapper contentType = - mkObject - "__Type" - [ renderKind (kind wrapper), - ("ofType", pure contentType) - ] - where - kind ListType = LIST - kind NonNullType = NON_NULL +defaultValue :: + Monad m => + TypeRef -> + Maybe (Value RESOLVED) -> + ( FieldName, + Resolver QUERY e m (ResModel QUERY e m) + ) +defaultValue + typeRef + value = + ( "defaultValue", + opt + ( fmap + (mkString . GQL.render) + . fulfill typeRef + . Just + ) + value + ) -createInputValueWith :: - Monad m => FieldName -> Maybe Meta -> ResModel QUERY e m -> ResModel QUERY e m -createInputValueWith name meta ivType = - mkObject - "__InputValue" - [ renderFieldName name, - description meta, - ("type", pure ivType) - ] +fulfill :: + WithSchema m => + TypeRef -> + Maybe (Value RESOLVED) -> + m (Value RESOLVED) +fulfill TypeRef {typeConName} (Just (Object fields)) = + selectType typeConName + >>= \case + TypeDefinition + { typeContent = + DataInputObject {inputObjectFields} + } -> + Object + <$> ( traverse + (handleField fields) + (elems inputObjectFields) + >>= fromElems + ) + _ -> failure (msg typeConName <> "is not must be Object") +fulfill typeRef (Just (List values)) = + List <$> traverse (fulfill typeRef . Just) values +fulfill _ (Just v) = pure v +fulfill _ Nothing = pure Null + +handleField :: + WithSchema m => + Object RESOLVED -> + FieldDefinition IN -> + m (ObjectEntry RESOLVED) +handleField + fields + FieldDefinition + { fieldName, + fieldType, + fieldContent = x + } = + ObjectEntry fieldName + <$> fulfill + fieldType + ( selectOr + (fmap defaultInputValue x) + (Just . entryValue) + fieldName + fields + ) diff --git a/src/Data/Morpheus/Schema/DSL.hs b/src/Data/Morpheus/Schema/DSL.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Schema/DSL.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.Morpheus.Schema.DSL (dsl) where + +import Data.Morpheus.Error + ( gqlWarnings, + renderGQLErrors, + ) +import Data.Morpheus.Parsing.Document.TypeSystem (parseSchema) +import Data.Morpheus.Types.Internal.AST (ANY, TypeDefinition) +import Data.Morpheus.Types.Internal.Resolving + ( Eventless, + Result (..), + ) +import Data.Text + ( Text, + pack, + ) +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +dsl :: QuasiQuoter +dsl = + QuasiQuoter + { quoteExp = dslExpression . pack, + quotePat = notHandled "Patterns", + quoteType = notHandled "Types", + quoteDec = notHandled "Declarations" + } + where + notHandled things = + error $ things ++ " are not supported by the GraphQL QuasiQuoter" + +dslExpression :: Text -> Q Exp +dslExpression doc = case (parseSchema doc :: Eventless [TypeDefinition ANY]) of + Failure errors -> fail (renderGQLErrors errors) + Success {result, warnings} -> + gqlWarnings warnings >> [|result|] diff --git a/src/Data/Morpheus/Schema/Directives.hs b/src/Data/Morpheus/Schema/Directives.hs --- a/src/Data/Morpheus/Schema/Directives.hs +++ b/src/Data/Morpheus/Schema/Directives.hs @@ -10,7 +10,7 @@ DirectiveDefinition (..), DirectiveLocation (..), TypeWrapper (..), - createField, + mkField, ) defaultDirectives :: [DirectiveDefinition] @@ -33,12 +33,11 @@ directiveDefinitionLocations = [FIELD_DEFINITION, ENUM_VALUE], directiveDefinitionArgs = singleton $ - createField - NoArguments + mkField "reason" ([TypeMaybe], "String") } ] argumentsIf :: ArgumentsDefinition -argumentsIf = singleton $ createField NoArguments "if" ([], "Boolean") +argumentsIf = singleton $ mkField "if" ([], "Boolean") diff --git a/src/Data/Morpheus/Schema/Schema.hs b/src/Data/Morpheus/Schema/Schema.hs --- a/src/Data/Morpheus/Schema/Schema.hs +++ b/src/Data/Morpheus/Schema/Schema.hs @@ -10,6 +10,7 @@ module Data.Morpheus.Schema.Schema ( withSystemTypes, + systemTypes, ) where @@ -19,10 +20,9 @@ ( (<:>), singleton, ) -import Data.Morpheus.QuasiQuoter (dsl) +import Data.Morpheus.Schema.DSL (dsl) import Data.Morpheus.Types.Internal.AST ( ANY, - ArgumentsDefinition (..), DataFingerprint (..), FieldsDefinition, Message, @@ -33,9 +33,10 @@ TypeUpdater, TypeWrapper (..), createArgument, - createField, insertType, internalFingerprint, + mkField, + mkObjectField, unsafeFromFields, ) import Data.Morpheus.Types.Internal.Resolving @@ -49,18 +50,17 @@ fs <- fields <:> hiddenFields pure $ s {query = q {typeContent = DataObject inter fs}} ) - >>= (`resolveUpdates` map (insertType . internalType) schemaTypes) + >>= (`resolveUpdates` map (insertType . internalType) systemTypes) withSystemTypes _ = failure ("Query must be an Object Type" :: Message) hiddenFields :: FieldsDefinition OUT hiddenFields = unsafeFromFields - [ createField + [ mkObjectField (singleton (createArgument "name" ([], "String"))) "__type" ([TypeMaybe], "__Type"), - createField - NoArguments + mkField "__schema" ([], "__Schema") ] @@ -72,8 +72,8 @@ } = tyDef {typeFingerprint = internalFingerprint name xs} -schemaTypes :: [TypeDefinition ANY] -schemaTypes = +systemTypes :: [TypeDefinition ANY] +systemTypes = [dsl| # default scalars diff --git a/src/Data/Morpheus/Schema/SchemaAPI.hs b/src/Data/Morpheus/Schema/SchemaAPI.hs --- a/src/Data/Morpheus/Schema/SchemaAPI.hs +++ b/src/Data/Morpheus/Schema/SchemaAPI.hs @@ -11,7 +11,6 @@ where -- MORPHEUS - import Data.Morpheus.Internal.Utils ( (<:>), elems, @@ -51,28 +50,27 @@ resolveTypes :: Monad m => Schema -> Resolver QUERY e m (ResModel QUERY e m) -resolveTypes schema = mkList <$> traverse (`render` schema) (elems schema) +resolveTypes schema = mkList <$> traverse render (elems schema) -buildSchemaLinkType :: - Monad m => Maybe (TypeDefinition OUT) -> Schema -> ResModel QUERY e m -buildSchemaLinkType (Just TypeDefinition {typeName}) = createObjectType typeName Nothing [] empty -buildSchemaLinkType Nothing = const mkNull +renderOperation :: + Monad m => Maybe (TypeDefinition OUT) -> Resolver QUERY e m (ResModel QUERY e m) +renderOperation (Just TypeDefinition {typeName}) = pure $ createObjectType typeName Nothing [] empty +renderOperation Nothing = pure mkNull findType :: Monad m => TypeName -> Schema -> Resolver QUERY e m (ResModel QUERY e m) -findType name schema = selectOr (pure mkNull) (`render` schema) name schema +findType = selectOr (pure mkNull) render renderDirectives :: Monad m => - Schema -> Resolver QUERY e m (ResModel QUERY e m) -renderDirectives schema = +renderDirectives = mkList <$> traverse - (`render` schema) + render defaultDirectives schemaResolver :: @@ -84,10 +82,10 @@ mkObject "__Schema" [ ("types", resolveTypes schema), - ("queryType", pure $ buildSchemaLinkType (Just query) schema), - ("mutationType", pure $ buildSchemaLinkType mutation schema), - ("subscriptionType", pure $ buildSchemaLinkType subscription schema), - ("directives", renderDirectives schema) + ("queryType", renderOperation (Just query)), + ("mutationType", renderOperation mutation), + ("subscriptionType", renderOperation subscription), + ("directives", renderDirectives) ] schemaAPI :: Monad m => Schema -> ResModel QUERY e m diff --git a/src/Data/Morpheus/Types/GQLScalar.hs b/src/Data/Morpheus/Types/GQLScalar.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/GQLScalar.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.Morpheus.Types.GQLScalar + ( GQLScalar (..), + toScalar, + scalarToJSON, + scalarFromJSON, + ) +where + +import Control.Monad.Fail (MonadFail) +import qualified Data.Aeson as A +import Data.Morpheus.Types.Internal.AST + ( ScalarDefinition (..), + ScalarValue (..), + ValidValue, + Value (..), + replaceValue, + ) +import Data.Proxy (Proxy (..)) +import Data.Text (Text, unpack) + +toScalar :: ValidValue -> Either Text ScalarValue +toScalar (Scalar x) = pure x +toScalar _ = Left "" + +-- | GraphQL Scalar +-- +-- 'parseValue' and 'serialize' should be provided for every instances manually +class GQLScalar a where + -- | value parsing and validating + -- + -- for exhaustive pattern matching should be handled all scalar types : 'Int', 'Float', 'String', 'Boolean' + -- + -- invalid values can be reported with 'Left' constructor : + -- + -- @ + -- parseValue String _ = Left "" -- without error message + -- -- or + -- parseValue String _ = Left "Error Message" + -- @ + parseValue :: ScalarValue -> Either Text a + + -- | serialization of haskell type into scalar value + serialize :: a -> ScalarValue + + scalarValidator :: Proxy a -> ScalarDefinition + scalarValidator _ = ScalarDefinition {validateValue = validator} + where + validator value = do + scalarValue' <- toScalar value + (_ :: a) <- parseValue scalarValue' + return value + +instance GQLScalar Text where + parseValue (String x) = pure x + parseValue _ = Left "" + serialize = String + +instance GQLScalar Bool where + parseValue (Boolean x) = pure x + parseValue _ = Left "" + serialize = Boolean + +instance GQLScalar Int where + parseValue (Int x) = pure x + parseValue _ = Left "" + serialize = Int + +instance GQLScalar Float where + parseValue (Float x) = pure x + parseValue (Int x) = pure $ fromInteger $ toInteger x + parseValue _ = Left "" + serialize = Float + +scalarToJSON :: GQLScalar a => a -> A.Value +scalarToJSON = A.toJSON . serialize + +scalarFromJSON :: (Monad m, MonadFail m) => GQLScalar a => A.Value -> m a +scalarFromJSON x = case replaceValue x of + Scalar value -> either (fail . unpack) pure (parseValue value) + _ -> fail "input must be scalar value" diff --git a/src/Data/Morpheus/Types/ID.hs b/src/Data/Morpheus/Types/ID.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/ID.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Data.Morpheus.Types.ID + ( ID (..), + ) +where + +import Data.Aeson (FromJSON (..), ToJSON (..)) +import Data.Morpheus.Types.GQLScalar + ( GQLScalar (..), + scalarFromJSON, + scalarToJSON, + ) +import Data.Morpheus.Types.Internal.AST + ( ScalarValue (..), + ) +import Data.Text + ( Text, + pack, + ) +import GHC.Generics (Generic) + +-- | default GraphQL type, +-- parses only 'String' and 'Int' values, +-- serialized always as 'String' +newtype ID = ID + { unpackID :: Text + } + deriving (Show, Generic) + +instance GQLScalar ID where + parseValue (Int x) = return (ID $ pack $ show x) + parseValue (String x) = return (ID x) + parseValue _ = Left "" + serialize (ID x) = String x + +instance ToJSON ID where + toJSON = scalarToJSON + +instance FromJSON ID where + parseJSON = scalarFromJSON diff --git a/src/Data/Morpheus/Types/Internal/AST.hs b/src/Data/Morpheus/Types/Internal/AST.hs --- a/src/Data/Morpheus/Types/Internal/AST.hs +++ b/src/Data/Morpheus/Types/Internal/AST.hs @@ -61,7 +61,7 @@ TypeDefinition (..), Schema (..), DataTypeWrapper (..), - DataTypeKind (..), + TypeKind (..), DataFingerprint (..), TypeWrapper (..), TypeRef (..), @@ -70,12 +70,9 @@ QUERY, MUTATION, SUBSCRIPTION, - Meta (..), Directive (..), TypeUpdater, - TypeD (..), ConsD (..), - GQLTypeD (..), TypeCategory, DataInputUnion, VariableContent (..), @@ -110,9 +107,7 @@ insertType, lookupDeprecated, lookupDeprecatedReason, - hasArguments, lookupWith, - typeFromScalar, -- Temaplate Haskell hsTypeName, -- LOCAL @@ -142,8 +137,7 @@ toFieldName, TypeNameRef (..), isEnum, - Fields, - argumentsToFields, + Fields (..), fieldsToArguments, mkCons, mkConsEnum, @@ -151,16 +145,25 @@ DirectiveDefinitions, DirectiveDefinition (..), DirectiveLocation (..), + FieldContent (..), + fieldContentArgs, + mkField, + TypeNameTH (..), + isOutput, + mkObjectField, + UnionMember (..), + mkUnionMember, ) where import Data.HashMap.Lazy (HashMap) -- Morpheus import Data.Morpheus.Types.Internal.AST.Base -import Data.Morpheus.Types.Internal.AST.Data +import Data.Morpheus.Types.Internal.AST.DirectiveLocation (DirectiveLocation (..)) import Data.Morpheus.Types.Internal.AST.OrderedMap import Data.Morpheus.Types.Internal.AST.Selection import Data.Morpheus.Types.Internal.AST.TH +import Data.Morpheus.Types.Internal.AST.TypeSystem import Data.Morpheus.Types.Internal.AST.Value import Language.Haskell.TH.Syntax (Lift) diff --git a/src/Data/Morpheus/Types/Internal/AST/Base.hs b/src/Data/Morpheus/Types/Internal/AST/Base.hs --- a/src/Data/Morpheus/Types/Internal/AST/Base.hs +++ b/src/Data/Morpheus/Types/Internal/AST/Base.hs @@ -26,7 +26,7 @@ QUERY, MUTATION, SUBSCRIPTION, - DataTypeKind (..), + TypeKind (..), DataFingerprint (..), DataTypeWrapper (..), Token, @@ -43,7 +43,6 @@ isInput, isNullableWrapper, sysFields, - typeFromScalar, hsTypeName, toOperationType, splitDuplicates, @@ -60,6 +59,7 @@ TypeNameRef (..), convertToJSONName, convertToHaskellName, + isOutput, ) where @@ -247,7 +247,7 @@ -- Kind ----------------------------------------------------------------------------------- -data DataTypeKind +data TypeKind = KindScalar | KindObject (Maybe OperationType) | KindUnion @@ -259,22 +259,28 @@ | KindInterface deriving (Eq, Show, Lift) -isSubscription :: DataTypeKind -> Bool +isSubscription :: TypeKind -> Bool isSubscription (KindObject (Just Subscription)) = True isSubscription _ = False -isOutputObject :: DataTypeKind -> Bool +isOutputObject :: TypeKind -> Bool isOutputObject (KindObject _) = True isOutputObject KindInterface = True isOutputObject _ = False -isObject :: DataTypeKind -> Bool +isOutput :: TypeKind -> Bool +isOutput (KindObject _) = True +isOutput KindUnion = True +isOutput KindInterface = True +isOutput _ = False + +isObject :: TypeKind -> Bool isObject (KindObject _) = True isObject KindInputObject = True isObject KindInterface = True isObject _ = False -isInput :: DataTypeKind -> Bool +isInput :: TypeKind -> Bool isInput KindInputObject = True isInput _ = False @@ -344,14 +350,6 @@ sysFields :: [FieldName] sysFields = ["__typename", "__schema", "__type"] - -typeFromScalar :: TypeName -> TypeName -typeFromScalar "Boolean" = "Bool" -typeFromScalar "Int" = "Int" -typeFromScalar "Float" = "Float" -typeFromScalar "String" = "Text" -typeFromScalar "ID" = "ID" -typeFromScalar _ = "ScalarValue" hsTypeName :: TypeName -> TypeName hsTypeName "String" = "Text" diff --git a/src/Data/Morpheus/Types/Internal/AST/Data.hs b/src/Data/Morpheus/Types/Internal/AST/Data.hs deleted file mode 100644 --- a/src/Data/Morpheus/Types/Internal/AST/Data.hs +++ /dev/null @@ -1,765 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -module Data.Morpheus.Types.Internal.AST.Data - ( Arguments, - ScalarDefinition (..), - DataEnum, - FieldsDefinition, - ArgumentDefinition, - DataUnion, - ArgumentsDefinition (..), - FieldDefinition (..), - InputFieldsDefinition, - TypeContent (..), - TypeDefinition (..), - Schema (..), - DataEnumValue (..), - TypeLib, - Meta (..), - Directive (..), - TypeUpdater, - TypeCategory, - DataInputUnion, - Argument (..), - Fields, - createField, - createArgument, - createEnumType, - createScalarType, - createType, - createUnionType, - createAlias, - createInputUnionFields, - createEnumValue, - defineType, - isTypeDefined, - initTypeLib, - isFieldNullable, - insertType, - fieldVisibility, - kindOf, - toNullableField, - toListField, - isEntNode, - lookupDeprecated, - lookupDeprecatedReason, - lookupWith, - hasArguments, - unsafeFromFields, - __inputname, - updateSchema, - OUT, - IN, - ANY, - FromAny (..), - ToAny (..), - DirectiveDefinitions, - DirectiveDefinition (..), - Directives, - argumentsToFields, - fieldsToArguments, - DirectiveLocation (..), - ) -where - -import Data.HashMap.Lazy - ( HashMap, - union, - ) -import qualified Data.HashMap.Lazy as HM -import Data.List (find) --- MORPHEUS - -import Data.Morpheus.Error (globalErrorMessage) -import Data.Morpheus.Error.NameCollision - ( NameCollision (..), - ) -import Data.Morpheus.Error.Schema (nameCollisionError) -import Data.Morpheus.Internal.Utils - ( Collection (..), - KeyOf (..), - Listable (..), - Merge (..), - Selectable (..), - elems, - ) -import Data.Morpheus.Rendering.RenderGQL - ( RenderGQL (..), - renderIndent, - renderObject, - ) -import Data.Morpheus.Types.Internal.AST.Base - ( DataFingerprint (..), - DataTypeKind (..), - Description, - FieldName, - FieldName (..), - GQLError (..), - Msg (..), - Position, - Stage, - TRUE, - Token, - TypeName, - TypeRef (..), - TypeWrapper (..), - VALID, - isNullable, - isSystemTypeName, - msg, - sysFields, - toFieldName, - toOperationType, - ) -import Data.Morpheus.Types.Internal.AST.OrderedMap - ( OrderedMap, - unsafeFromValues, - ) -import Data.Morpheus.Types.Internal.AST.Value - ( ScalarValue (..), - ValidValue, - Value (..), - ) -import Data.Morpheus.Types.Internal.Resolving.Core - ( Failure (..), - LibUpdater, - resolveUpdates, - ) -import Data.Semigroup ((<>), Semigroup (..)) -import Data.Text (intercalate) -import Instances.TH.Lift () -import Language.Haskell.TH.Syntax (Lift (..)) - -type DataEnum = [DataEnumValue] - -type DataUnion = [TypeName] - -type DataInputUnion = [(TypeName, Bool)] - --- scalar ------------------------------------------------------------------- -newtype ScalarDefinition = ScalarDefinition - {validateValue :: ValidValue -> Either Token ValidValue} - -instance Show ScalarDefinition where - show _ = "ScalarDefinition" - -instance Lift ScalarDefinition where - lift _ = [|ScalarDefinition pure|] - -data Argument (valid :: Stage) = Argument - { argumentName :: FieldName, - argumentValue :: Value valid, - argumentPosition :: Position - } - deriving (Show, Eq, Lift) - -instance KeyOf (Argument stage) where - keyOf = argumentName - -instance NameCollision (Argument s) where - nameCollision _ Argument {argumentName, argumentPosition} = - GQLError - { message = "There can Be only One Argument Named " <> msg argumentName, - locations = [argumentPosition] - } - -type Arguments s = OrderedMap FieldName (Argument s) - --- directive ------------------------------------------------------------------- -data Directive (s :: Stage) = Directive - { directiveName :: FieldName, - directivePosition :: Position, - directiveArgs :: Arguments s - } - deriving (Show, Lift, Eq) - -instance KeyOf (Directive s) where - keyOf = directiveName - -type Directives s = [Directive s] - -data DirectiveDefinition = DirectiveDefinition - { directiveDefinitionName :: FieldName, - directiveDefinitionDescription :: Maybe Description, - directiveDefinitionLocations :: [DirectiveLocation], - directiveDefinitionArgs :: ArgumentsDefinition - } - deriving (Show, Lift) - -type DirectiveDefinitions = [DirectiveDefinition] - -instance KeyOf DirectiveDefinition where - keyOf = directiveDefinitionName - -instance Selectable DirectiveDefinition ArgumentDefinition where - selectOr fb f key DirectiveDefinition {directiveDefinitionArgs} = - selectOr fb f key directiveDefinitionArgs - -data DirectiveLocation - = QUERY - | MUTATION - | SUBSCRIPTION - | FIELD - | FRAGMENT_DEFINITION - | FRAGMENT_SPREAD - | INLINE_FRAGMENT - | SCHEMA - | SCALAR - | OBJECT - | FIELD_DEFINITION - | ARGUMENT_DEFINITION - | INTERFACE - | UNION - | ENUM - | ENUM_VALUE - | INPUT_OBJECT - | INPUT_FIELD_DEFINITION - deriving (Show, Eq, Lift) - -instance Msg DirectiveLocation where - msg = msg . show - -lookupDeprecated :: Meta -> Maybe (Directive VALID) -lookupDeprecated Meta {metaDirectives} = find isDeprecation metaDirectives - where - isDeprecation Directive {directiveName = "deprecated"} = True - isDeprecation _ = False - -lookupDeprecatedReason :: Directive VALID -> Maybe Description -lookupDeprecatedReason Directive {directiveArgs} = - selectOr Nothing (Just . maybeString) "reason" directiveArgs - where - maybeString :: Argument VALID -> Description - maybeString Argument {argumentValue = (Scalar (String x))} = x - maybeString _ = "can't read deprecated Reason Value" - --- META -data Meta = Meta - { metaDescription :: Maybe Description, - metaDirectives :: [Directive VALID] - } - deriving (Show, Lift) - --- ENUM VALUE -data DataEnumValue = DataEnumValue - { enumName :: TypeName, - enumMeta :: Maybe Meta - } - deriving (Show, Lift) - -instance RenderGQL DataEnumValue where - render DataEnumValue {enumName} = render enumName - --- 3.2 Schema : https://graphql.github.io/graphql-spec/June2018/#sec-Schema ---------------------------------------------------------------------------- --- SchemaDefinition : --- schema Directives[Const](opt) { RootOperationTypeDefinition(list)} --- --- RootOperationTypeDefinition : --- OperationType: NamedType - -data Schema = Schema - { types :: TypeLib, - query :: TypeDefinition 'Out, - mutation :: Maybe (TypeDefinition 'Out), - subscription :: Maybe (TypeDefinition 'Out) - } - deriving (Show) - -type TypeLib = HashMap TypeName (TypeDefinition ANY) - -instance Selectable Schema (TypeDefinition ANY) where - selectOr fb f name lib = maybe fb f (lookupDataType name lib) - -instance Listable (TypeDefinition ANY) Schema where - elems = HM.elems . typeRegister - fromElems types = case popByKey "Query" types of - (Nothing, _) -> failure (globalErrorMessage "INTERNAL: Query Not Defined") - (Just query, lib1) -> do - let (mutation, lib2) = popByKey "Mutation" lib1 - let (subscription, lib3) = popByKey "Subscription" lib2 - pure $ (foldr defineType (initTypeLib query) lib3) {mutation, subscription} - -initTypeLib :: TypeDefinition 'Out -> Schema -initTypeLib query = - Schema - { types = empty, - query = query, - mutation = Nothing, - subscription = Nothing - } - -typeRegister :: Schema -> TypeLib -typeRegister Schema {types, query, mutation, subscription} = - types - `union` HM.fromList - (concatMap fromOperation [Just query, mutation, subscription]) - -lookupDataType :: TypeName -> Schema -> Maybe (TypeDefinition ANY) -lookupDataType name = HM.lookup name . typeRegister - -isTypeDefined :: TypeName -> Schema -> Maybe DataFingerprint -isTypeDefined name lib = typeFingerprint <$> lookupDataType name lib - --- 3.4 Types : https://graphql.github.io/graphql-spec/June2018/#sec-Types -------------------------------------------------------------------------- --- TypeDefinition : --- ScalarTypeDefinition --- ObjectTypeDefinition --- InterfaceTypeDefinition --- UnionTypeDefinition --- EnumTypeDefinition --- InputObjectTypeDefinition - -data TypeDefinition (a :: TypeCategory) = TypeDefinition - { typeName :: TypeName, - typeFingerprint :: DataFingerprint, - typeMeta :: Maybe Meta, - typeContent :: TypeContent TRUE a - } - deriving (Show, Lift) - -instance KeyOf (TypeDefinition a) where - type KEY (TypeDefinition a) = TypeName - keyOf = typeName - -data TypeCategory = In | Out | Any - -type IN = 'In - -type OUT = 'Out - -type ANY = 'Any - -class ToAny a where - toAny :: a (k :: TypeCategory) -> a ANY - -instance ToAny TypeDefinition where - toAny TypeDefinition {typeContent, ..} = TypeDefinition {typeContent = toAny typeContent, ..} - -instance ToAny (TypeContent TRUE) where - toAny DataScalar {..} = DataScalar {..} - toAny DataEnum {..} = DataEnum {..} - toAny DataInputObject {..} = DataInputObject {..} - toAny DataInputUnion {..} = DataInputUnion {..} - toAny DataObject {..} = DataObject {..} - toAny DataUnion {..} = DataUnion {..} - toAny DataInterface {..} = DataInterface {..} - -class FromAny a (k :: TypeCategory) where - fromAny :: a ANY -> Maybe (a k) - -instance (FromAny (TypeContent TRUE) a) => FromAny TypeDefinition a where - fromAny TypeDefinition {typeContent, ..} = bla <$> fromAny typeContent - where - bla x = TypeDefinition {typeContent = x, ..} - -instance FromAny (TypeContent TRUE) IN where - fromAny DataScalar {..} = Just DataScalar {..} - fromAny DataEnum {..} = Just DataEnum {..} - fromAny DataInputObject {..} = Just DataInputObject {..} - fromAny DataInputUnion {..} = Just DataInputUnion {..} - fromAny _ = Nothing - -instance FromAny (TypeContent TRUE) OUT where - fromAny DataScalar {..} = Just DataScalar {..} - fromAny DataEnum {..} = Just DataEnum {..} - fromAny DataObject {..} = Just DataObject {..} - fromAny DataUnion {..} = Just DataUnion {..} - fromAny DataInterface {..} = Just DataInterface {..} - fromAny _ = Nothing - -class SelectType (c :: TypeCategory) (a :: TypeCategory) where - type IsSelected c a :: Bool - -instance SelectType ANY a where - type IsSelected ANY a = TRUE - -instance SelectType OUT OUT where - type IsSelected OUT OUT = TRUE - -instance SelectType IN IN where - type IsSelected IN IN = TRUE - -data TypeContent (b :: Bool) (a :: TypeCategory) where - DataScalar :: - { dataScalar :: ScalarDefinition - } -> - TypeContent TRUE a - DataEnum :: - { enumMembers :: DataEnum - } -> - TypeContent TRUE a - DataInputObject :: - { inputObjectFields :: FieldsDefinition IN - } -> - TypeContent (IsSelected a IN) a - DataInputUnion :: - { inputUnionMembers :: DataInputUnion - } -> - TypeContent (IsSelected a IN) a - DataObject :: - { objectImplements :: [TypeName], - objectFields :: FieldsDefinition OUT - } -> - TypeContent (IsSelected a OUT) a - DataUnion :: - { unionMembers :: DataUnion - } -> - TypeContent (IsSelected a OUT) a - DataInterface :: - { interfaceFields :: FieldsDefinition OUT - } -> - TypeContent (IsSelected a OUT) a - -deriving instance Show (TypeContent a b) - -deriving instance Lift (TypeContent a b) - -createType :: TypeName -> TypeContent TRUE a -> TypeDefinition a -createType typeName typeContent = - TypeDefinition - { typeName, - typeMeta = Nothing, - typeFingerprint = DataFingerprint typeName [], - typeContent - } - -createScalarType :: TypeName -> TypeDefinition a -createScalarType typeName = createType typeName $ DataScalar (ScalarDefinition pure) - -createEnumType :: TypeName -> [TypeName] -> TypeDefinition a -createEnumType typeName typeData = createType typeName (DataEnum enumValues) - where - enumValues = map createEnumValue typeData - -createEnumValue :: TypeName -> DataEnumValue -createEnumValue enumName = DataEnumValue {enumName, enumMeta = Nothing} - -createUnionType :: TypeName -> [TypeName] -> TypeDefinition OUT -createUnionType typeName typeData = createType typeName (DataUnion typeData) - -isEntNode :: TypeContent TRUE a -> Bool -isEntNode DataScalar {} = True -isEntNode DataEnum {} = True -isEntNode _ = False - -kindOf :: TypeDefinition a -> DataTypeKind -kindOf TypeDefinition {typeName, typeContent} = __kind typeContent - where - __kind DataScalar {} = KindScalar - __kind DataEnum {} = KindEnum - __kind DataInputObject {} = KindInputObject - __kind DataObject {} = KindObject (toOperationType typeName) - __kind DataUnion {} = KindUnion - __kind DataInputUnion {} = KindInputUnion - __kind DataInterface {} = KindInterface - -fromOperation :: Maybe (TypeDefinition OUT) -> [(TypeName, TypeDefinition ANY)] -fromOperation (Just datatype) = [(typeName datatype, toAny datatype)] -fromOperation Nothing = [] - -defineType :: TypeDefinition cat -> Schema -> Schema -defineType dt@TypeDefinition {typeName, typeContent = DataInputUnion enumKeys, typeFingerprint} lib = - lib {types = HM.insert name unionTags (HM.insert typeName (toAny dt) (types lib))} - where - name = typeName <> "Tags" - unionTags = - TypeDefinition - { typeName = name, - typeFingerprint, - typeMeta = Nothing, - typeContent = DataEnum $ map (createEnumValue . fst) enumKeys - } -defineType datatype lib = - lib {types = HM.insert (typeName datatype) (toAny datatype) (types lib)} - -insertType :: - TypeDefinition ANY -> - TypeUpdater -insertType datatype@TypeDefinition {typeName} lib = case isTypeDefined typeName lib of - Nothing -> resolveUpdates (defineType datatype lib) [] - Just fingerprint - | fingerprint == typeFingerprint datatype -> return lib - -- throw error if 2 different types has same name - | otherwise -> failure $ nameCollisionError typeName - -updateSchema :: - TypeName -> - DataFingerprint -> - [TypeUpdater] -> - (a -> TypeDefinition cat) -> - a -> - TypeUpdater -updateSchema name fingerprint stack f x lib = - case isTypeDefined name lib of - Nothing -> - resolveUpdates - (defineType (f x) lib) - stack - Just fingerprint' | fingerprint' == fingerprint -> return lib - -- throw error if 2 different types has same name - Just _ -> failure $ nameCollisionError name - -lookupWith :: Eq k => (a -> k) -> k -> [a] -> Maybe a -lookupWith f key = find ((== key) . f) - --- lookups and removes TypeDefinition from hashmap -popByKey :: TypeName -> [TypeDefinition ANY] -> (Maybe (TypeDefinition OUT), [TypeDefinition ANY]) -popByKey name types = case lookupWith typeName name types of - Just dt@TypeDefinition {typeContent = DataObject {}} -> - (fromAny dt, filter ((/= name) . typeName) types) - _ -> (Nothing, types) - -newtype Fields def = Fields - {unFields :: OrderedMap FieldName def} - deriving - ( Show, - Lift, - Functor, - Foldable, - Traversable - ) - -deriving instance (KEY def ~ FieldName, KeyOf def) => Collection def (Fields def) - -instance Merge (FieldsDefinition cat) where - merge path (Fields x) (Fields y) = Fields <$> merge path x y - -instance Selectable (Fields (FieldDefinition cat)) (FieldDefinition cat) where - selectOr fb f name (Fields lib) = selectOr fb f name lib - -unsafeFromFields :: [FieldDefinition cat] -> FieldsDefinition cat -unsafeFromFields = Fields . unsafeFromValues - -argumentsToFields :: ArgumentsDefinition -> FieldsDefinition IN -argumentsToFields = Fields . arguments - -fieldsToArguments :: FieldsDefinition IN -> ArgumentsDefinition -fieldsToArguments = ArgumentsDefinition Nothing . unFields - -instance (KEY def ~ FieldName, KeyOf def, NameCollision def) => Listable def (Fields def) where - fromElems = fmap Fields . fromElems - elems = elems . unFields - --- 3.6 Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Objects ------------------------------------------------------------------------------- --- ObjectTypeDefinition: --- Description(opt) type Name ImplementsInterfaces(opt) Directives(Const)(opt) FieldsDefinition(opt) --- --- ImplementsInterfaces --- implements &(opt) NamedType --- ImplementsInterfaces & NamedType --- --- FieldsDefinition --- { FieldDefinition(list) } --- -type FieldsDefinition cat = Fields (FieldDefinition cat) - --- FieldDefinition --- Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt) --- -data FieldDefinition (cat :: TypeCategory) = FieldDefinition - { fieldName :: FieldName, - fieldArgs :: ArgumentsDefinition, - fieldType :: TypeRef, - fieldMeta :: Maybe Meta - } - deriving (Show, Lift) - -instance KeyOf (FieldDefinition cat) where - keyOf = fieldName - -instance Selectable (FieldDefinition OUT) ArgumentDefinition where - selectOr fb f key FieldDefinition {fieldArgs} = selectOr fb f key fieldArgs - -instance NameCollision (FieldDefinition cat) where - nameCollision name _ = - GQLError - { message = "There can Be only One field Named " <> msg name, - locations = [] - } - -instance RenderGQL (FieldDefinition cat) where - render FieldDefinition {fieldName = FieldName name, fieldType, fieldArgs} = - name <> render fieldArgs <> ": " <> render fieldType - -instance RenderGQL (FieldsDefinition OUT) where - render = renderObject render . ignoreHidden . elems - -instance RenderGQL (FieldsDefinition IN) where - render = renderObject render . ignoreHidden . elems - -fieldVisibility :: FieldDefinition cat -> Bool -fieldVisibility FieldDefinition {fieldName} = fieldName `notElem` sysFields - -isFieldNullable :: FieldDefinition cat -> Bool -isFieldNullable = isNullable . fieldType - -createField :: ArgumentsDefinition -> FieldName -> ([TypeWrapper], TypeName) -> FieldDefinition cat -createField dataArguments fieldName (typeWrappers, typeConName) = - FieldDefinition - { fieldArgs = dataArguments, - fieldName, - fieldType = TypeRef {typeConName, typeWrappers, typeArgs = Nothing}, - fieldMeta = Nothing - } - -toNullableField :: FieldDefinition cat -> FieldDefinition cat -toNullableField dataField - | isNullable (fieldType dataField) = dataField - | otherwise = dataField {fieldType = nullable (fieldType dataField)} - where - nullable alias@TypeRef {typeWrappers} = - alias {typeWrappers = TypeMaybe : typeWrappers} - -toListField :: FieldDefinition cat -> FieldDefinition cat -toListField dataField = dataField {fieldType = listW (fieldType dataField)} - where - listW alias@TypeRef {typeWrappers} = - alias {typeWrappers = TypeList : typeWrappers} - --- 3.10 Input Objects: https://spec.graphql.org/June2018/#sec-Input-Objects ---------------------------------------------------------------------------- --- InputObjectTypeDefinition --- Description(opt) input Name Directives(const,opt) InputFieldsDefinition(opt) --- ---- InputFieldsDefinition --- { InputValueDefinition(list) } - -type InputFieldsDefinition = Fields InputValueDefinition - -type InputValueDefinition = FieldDefinition IN - --- 3.6.1 Field Arguments : https://graphql.github.io/graphql-spec/June2018/#sec-Field-Arguments ------------------------------------------------------------------------------------------------ --- ArgumentsDefinition: --- (InputValueDefinition(list)) - -data ArgumentsDefinition - = ArgumentsDefinition - { argumentsTypename :: Maybe TypeName, - arguments :: OrderedMap FieldName ArgumentDefinition - } - | NoArguments - deriving (Show, Lift) - -instance RenderGQL ArgumentsDefinition where - render NoArguments = "" - render arguments = "(" <> intercalate ", " (map render $ elems arguments) <> ")" - -type ArgumentDefinition = FieldDefinition IN - -instance Selectable ArgumentsDefinition ArgumentDefinition where - selectOr fb _ _ NoArguments = fb - selectOr fb f key (ArgumentsDefinition _ args) = selectOr fb f key args - -instance Collection ArgumentDefinition ArgumentsDefinition where - empty = ArgumentsDefinition Nothing empty - singleton = ArgumentsDefinition Nothing . singleton - -instance Listable ArgumentDefinition ArgumentsDefinition where - elems NoArguments = [] - elems (ArgumentsDefinition _ args) = elems args - fromElems [] = pure NoArguments - fromElems args = ArgumentsDefinition Nothing <$> fromElems args - -createArgument :: FieldName -> ([TypeWrapper], TypeName) -> FieldDefinition IN -createArgument = createField NoArguments - -hasArguments :: ArgumentsDefinition -> Bool -hasArguments NoArguments = False -hasArguments _ = True - --- https://spec.graphql.org/June2018/#InputValueDefinition --- InputValueDefinition --- Description(opt) Name: TypeDefaultValue(opt) Directives[Const](opt) --- TODO: implement inputValue - --- data InputValueDefinition = InputValueDefinition --- { inputValueName :: FieldName --- , inputValueType :: TypeRef --- , inputValueMeta :: Maybe Meta --- } deriving (Show,Lift) - -__inputname :: FieldName -__inputname = "inputname" - -createInputUnionFields :: TypeName -> [TypeName] -> [FieldDefinition IN] -createInputUnionFields name members = fieldTag : map unionField members - where - fieldTag = - FieldDefinition - { fieldName = __inputname, - fieldArgs = NoArguments, - fieldType = createAlias (name <> "Tags"), - fieldMeta = Nothing - } - unionField memberName = - FieldDefinition - { fieldArgs = NoArguments, - fieldName = toFieldName memberName, - fieldType = - TypeRef - { typeConName = memberName, - typeWrappers = [TypeMaybe], - typeArgs = Nothing - }, - fieldMeta = Nothing - } - --- --- OTHER --------------------------------------------------------------------------------------------------- - -createAlias :: TypeName -> TypeRef -createAlias typeConName = - TypeRef {typeConName, typeWrappers = [], typeArgs = Nothing} - -type TypeUpdater = LibUpdater Schema - -instance RenderGQL Schema where - render schema = intercalate "\n\n" $ map render visibleTypes - where - visibleTypes = filter (not . isSystemTypeName . typeName) (elems schema) - -instance RenderGQL (TypeDefinition a) where - render TypeDefinition {typeName, typeContent} = __render typeContent - where - __render DataInterface {interfaceFields} = "interface " <> render typeName <> render interfaceFields - __render DataScalar {} = "scalar " <> render typeName - __render (DataEnum tags) = "enum " <> render typeName <> renderObject render tags - __render (DataUnion members) = - "union " - <> render typeName - <> " =\n " - <> intercalate ("\n" <> renderIndent <> "| ") (map render members) - __render (DataInputObject fields) = "input " <> render typeName <> render fields - __render (DataInputUnion members) = "input " <> render typeName <> render fieldsDef - where - fieldsDef = unsafeFromFields fields - fields :: [FieldDefinition IN] - fields = createInputUnionFields typeName (fst <$> members :: [TypeName]) - __render DataObject {objectFields} = "type " <> render typeName <> render objectFields - -ignoreHidden :: [FieldDefinition cat] -> [FieldDefinition cat] -ignoreHidden = filter fieldVisibility diff --git a/src/Data/Morpheus/Types/Internal/AST/DirectiveLocation.hs b/src/Data/Morpheus/Types/Internal/AST/DirectiveLocation.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Internal/AST/DirectiveLocation.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE DeriveLift #-} + +module Data.Morpheus.Types.Internal.AST.DirectiveLocation (DirectiveLocation (..)) where + +import Data.Morpheus.Types.Internal.AST.Base (Msg (..)) +import Language.Haskell.TH.Syntax (Lift) + +data DirectiveLocation + = QUERY + | MUTATION + | SUBSCRIPTION + | FIELD + | FRAGMENT_DEFINITION + | FRAGMENT_SPREAD + | INLINE_FRAGMENT + | SCHEMA + | SCALAR + | OBJECT + | FIELD_DEFINITION + | ARGUMENT_DEFINITION + | INTERFACE + | UNION + | ENUM + | ENUM_VALUE + | INPUT_OBJECT + | INPUT_FIELD_DEFINITION + deriving (Show, Eq, Lift) + +instance Msg DirectiveLocation where + msg = msg . show diff --git a/src/Data/Morpheus/Types/Internal/AST/OrderedMap.hs b/src/Data/Morpheus/Types/Internal/AST/OrderedMap.hs --- a/src/Data/Morpheus/Types/Internal/AST/OrderedMap.hs +++ b/src/Data/Morpheus/Types/Internal/AST/OrderedMap.hs @@ -48,10 +48,15 @@ where ls = HM.toList x -instance Foldable (OrderedMap k) where - foldMap f OrderedMap {mapEntries} = foldMap f mapEntries +instance (Eq k, Hashable k) => Foldable (OrderedMap k) where + foldMap f = foldMap f . getElements -instance Traversable (OrderedMap k) where +getElements :: (Eq k, Hashable k) => OrderedMap k b -> [b] +getElements OrderedMap {mapKeys, mapEntries} = map takeValue mapKeys + where + takeValue key = fromMaybe (error "TODO: invalid Ordered Map") (key `HM.lookup` mapEntries) + +instance (Eq k, Hashable k) => Traversable (OrderedMap k) where traverse f (OrderedMap names values) = OrderedMap names <$> traverse f values instance (KeyOf a, Hashable k, KEY a ~ k) => Collection a (OrderedMap k a) where @@ -66,9 +71,7 @@ instance (NameCollision a, Eq k, Hashable k, k ~ KEY a) => Listable a (OrderedMap k a) where fromElems = safeFromList - elems OrderedMap {mapKeys, mapEntries} = map takeValue mapKeys - where - takeValue key = fromMaybe (error "TODO: invalid Ordered Map") (key `HM.lookup` mapEntries) + elems = getElements safeFromList :: ( Failure GQLErrors m, diff --git a/src/Data/Morpheus/Types/Internal/AST/Selection.hs b/src/Data/Morpheus/Types/Internal/AST/Selection.hs --- a/src/Data/Morpheus/Types/Internal/AST/Selection.hs +++ b/src/Data/Morpheus/Types/Internal/AST/Selection.hs @@ -58,18 +58,18 @@ msg, readName, ) -import Data.Morpheus.Types.Internal.AST.Data - ( Arguments, - Directives, - OUT, - Schema (..), - TypeDefinition (..), - ) import Data.Morpheus.Types.Internal.AST.MergeSet ( MergeSet, ) import Data.Morpheus.Types.Internal.AST.OrderedMap ( OrderedMap, + ) +import Data.Morpheus.Types.Internal.AST.TypeSystem + ( Arguments, + Directives, + OUT, + Schema (..), + TypeDefinition (..), ) import Data.Morpheus.Types.Internal.AST.Value ( ResolvedValue, diff --git a/src/Data/Morpheus/Types/Internal/AST/TH.hs b/src/Data/Morpheus/Types/Internal/AST/TH.hs --- a/src/Data/Morpheus/Types/Internal/AST/TH.hs +++ b/src/Data/Morpheus/Types/Internal/AST/TH.hs @@ -1,31 +1,26 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} module Data.Morpheus.Types.Internal.AST.TH - ( TypeD (..), - ConsD (..), + ( ConsD (..), mkCons, - GQLTypeD (..), isEnum, mkConsEnum, + TypeNameTH (..), ) where import Data.Morpheus.Internal.Utils (elems) import Data.Morpheus.Types.Internal.AST.Base - ( DataTypeKind, - FieldName, + ( FieldName, TypeName, TypeRef (..), hsTypeName, ) -import Data.Morpheus.Types.Internal.AST.Data - ( ANY, - DataEnumValue (..), +import Data.Morpheus.Types.Internal.AST.TypeSystem + ( DataEnumValue (..), FieldDefinition (..), FieldsDefinition, - Meta, - TypeDefinition, ) toHSFieldDefinition :: FieldDefinition cat -> FieldDefinition cat @@ -34,43 +29,29 @@ { fieldType = tyRef {typeConName = hsTypeName typeConName} } --- Template Haskell Types --- Document -data GQLTypeD = GQLTypeD - { typeD :: TypeD, - typeArgD :: [TypeD], - typeOriginal :: TypeDefinition ANY +data TypeNameTH = TypeNameTH + { namespace :: [FieldName], + typename :: TypeName } deriving (Show) ---- Core -data TypeD = TypeD - { tName :: TypeName, - tNamespace :: [FieldName], - tCons :: [ConsD], - tKind :: DataTypeKind, - tMeta :: Maybe Meta - } - deriving (Show) +-- Template Haskell Types -data ConsD = ConsD +data ConsD cat = ConsD { cName :: TypeName, - cFields :: [FieldDefinition ANY] + cFields :: [FieldDefinition cat] } deriving (Show) -mkCons :: TypeName -> FieldsDefinition cat -> ConsD +mkCons :: TypeName -> FieldsDefinition cat -> ConsD cat mkCons typename fields = ConsD { cName = hsTypeName typename, - cFields = map (toHSFieldDefinition . mockFieldDefinition) (elems fields) + cFields = map toHSFieldDefinition (elems fields) } -isEnum :: [ConsD] -> Bool +isEnum :: [ConsD cat] -> Bool isEnum = all (null . cFields) -mockFieldDefinition :: FieldDefinition a -> FieldDefinition b -mockFieldDefinition FieldDefinition {..} = FieldDefinition {..} - -mkConsEnum :: DataEnumValue -> ConsD +mkConsEnum :: DataEnumValue -> ConsD cat mkConsEnum DataEnumValue {enumName} = ConsD {cName = hsTypeName enumName, cFields = []} diff --git a/src/Data/Morpheus/Types/Internal/AST/TypeSystem.hs b/src/Data/Morpheus/Types/Internal/AST/TypeSystem.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Internal/AST/TypeSystem.hs @@ -0,0 +1,790 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.Morpheus.Types.Internal.AST.TypeSystem + ( Arguments, + ScalarDefinition (..), + DataEnum, + FieldsDefinition, + ArgumentDefinition, + DataUnion, + ArgumentsDefinition (..), + FieldDefinition (..), + InputFieldsDefinition, + TypeContent (..), + TypeDefinition (..), + Schema (..), + DataEnumValue (..), + TypeLib, + Directive (..), + TypeUpdater, + TypeCategory, + DataInputUnion, + Argument (..), + Fields (..), + createField, + createArgument, + createEnumType, + createScalarType, + createType, + createUnionType, + createAlias, + createInputUnionFields, + createEnumValue, + defineType, + isTypeDefined, + initTypeLib, + isFieldNullable, + insertType, + fieldVisibility, + kindOf, + toNullableField, + toListField, + isEntNode, + lookupDeprecated, + lookupDeprecatedReason, + lookupWith, + unsafeFromFields, + __inputname, + updateSchema, + OUT, + IN, + ANY, + FromAny (..), + ToAny (..), + DirectiveDefinitions, + DirectiveDefinition (..), + Directives, + fieldsToArguments, + FieldContent (..), + fieldContentArgs, + mkField, + mkObjectField, + UnionMember (..), + mkUnionMember, + ) +where + +import Data.HashMap.Lazy + ( HashMap, + union, + ) +import qualified Data.HashMap.Lazy as HM +import Data.List (find) +-- MORPHEUS + +import Data.Morpheus.Error (globalErrorMessage) +import Data.Morpheus.Error.NameCollision + ( NameCollision (..), + ) +import Data.Morpheus.Error.Schema (nameCollisionError) +import Data.Morpheus.Internal.Utils + ( Collection (..), + KeyOf (..), + Listable (..), + Merge (..), + Selectable (..), + elems, + ) +import Data.Morpheus.Rendering.RenderGQL + ( RenderGQL (..), + renderIndent, + renderObject, + ) +import Data.Morpheus.Types.Internal.AST.Base + ( DataFingerprint (..), + Description, + FALSE, + FieldName, + FieldName (..), + GQLError (..), + Msg (..), + Position, + RESOLVED, + Stage, + TRUE, + Token, + TypeKind (..), + TypeName, + TypeRef (..), + TypeWrapper (..), + VALID, + isNullable, + isSystemTypeName, + msg, + sysFields, + toFieldName, + toOperationType, + ) +import Data.Morpheus.Types.Internal.AST.DirectiveLocation (DirectiveLocation) +import Data.Morpheus.Types.Internal.AST.OrderedMap + ( OrderedMap, + unsafeFromValues, + ) +import Data.Morpheus.Types.Internal.AST.Value + ( ScalarValue (..), + ValidValue, + Value (..), + ) +import Data.Morpheus.Types.Internal.Resolving.Core + ( Failure (..), + LibUpdater, + resolveUpdates, + ) +import Data.Semigroup (Semigroup (..)) +import Data.Text (intercalate) +import Instances.TH.Lift () +import Language.Haskell.TH.Syntax (Lift (..)) + +type DataEnum = [DataEnumValue] + +mkUnionMember :: TypeName -> UnionMember cat +mkUnionMember name = UnionMember name True + +data UnionMember (cat :: TypeCategory) = UnionMember + { memberName :: TypeName, + visibility :: Bool + } + deriving (Show, Lift, Eq) + +type DataUnion = [UnionMember OUT] + +type DataInputUnion = [UnionMember IN] + +instance RenderGQL (UnionMember cat) where + render = render . memberName + +-- scalar +------------------------------------------------------------------ +newtype ScalarDefinition = ScalarDefinition + {validateValue :: ValidValue -> Either Token ValidValue} + +instance Show ScalarDefinition where + show _ = "ScalarDefinition" + +instance Lift ScalarDefinition where + lift _ = [|ScalarDefinition pure|] + +data Argument (valid :: Stage) = Argument + { argumentName :: FieldName, + argumentValue :: Value valid, + argumentPosition :: Position + } + deriving (Show, Eq, Lift) + +instance KeyOf (Argument stage) where + keyOf = argumentName + +instance NameCollision (Argument s) where + nameCollision _ Argument {argumentName, argumentPosition} = + GQLError + { message = "There can Be only One Argument Named " <> msg argumentName, + locations = [argumentPosition] + } + +type Arguments s = OrderedMap FieldName (Argument s) + +-- directive +------------------------------------------------------------------ +data Directive (s :: Stage) = Directive + { directiveName :: FieldName, + directivePosition :: Position, + directiveArgs :: Arguments s + } + deriving (Show, Lift, Eq) + +instance KeyOf (Directive s) where + keyOf = directiveName + +type Directives s = [Directive s] + +data DirectiveDefinition = DirectiveDefinition + { directiveDefinitionName :: FieldName, + directiveDefinitionDescription :: Maybe Description, + directiveDefinitionLocations :: [DirectiveLocation], + directiveDefinitionArgs :: ArgumentsDefinition + } + deriving (Show, Lift) + +type DirectiveDefinitions = [DirectiveDefinition] + +instance KeyOf DirectiveDefinition where + keyOf = directiveDefinitionName + +instance Selectable DirectiveDefinition ArgumentDefinition where + selectOr fb f key DirectiveDefinition {directiveDefinitionArgs} = + selectOr fb f key directiveDefinitionArgs + +lookupDeprecated :: [Directive VALID] -> Maybe (Directive VALID) +lookupDeprecated = find isDeprecation + where + isDeprecation Directive {directiveName = "deprecated"} = True + isDeprecation _ = False + +lookupDeprecatedReason :: Directive VALID -> Maybe Description +lookupDeprecatedReason Directive {directiveArgs} = + selectOr Nothing (Just . maybeString) "reason" directiveArgs + where + maybeString :: Argument VALID -> Description + maybeString Argument {argumentValue = (Scalar (String x))} = x + maybeString _ = "can't read deprecated Reason Value" + +-- ENUM VALUE +data DataEnumValue = DataEnumValue + { enumName :: TypeName, + enumDescription :: Maybe Description, + enumDirectives :: [Directive VALID] + } + deriving (Show, Lift) + +instance RenderGQL DataEnumValue where + render DataEnumValue {enumName} = render enumName + +-- 3.2 Schema : https://graphql.github.io/graphql-spec/June2018/#sec-Schema +--------------------------------------------------------------------------- +-- SchemaDefinition : +-- schema Directives[Const](opt) { RootOperationTypeDefinition(list)} +-- +-- RootOperationTypeDefinition : +-- OperationType: NamedType + +data Schema = Schema + { types :: TypeLib, + query :: TypeDefinition 'Out, + mutation :: Maybe (TypeDefinition 'Out), + subscription :: Maybe (TypeDefinition 'Out) + } + deriving (Show) + +type TypeLib = HashMap TypeName (TypeDefinition ANY) + +instance Selectable Schema (TypeDefinition ANY) where + selectOr fb f name lib = maybe fb f (lookupDataType name lib) + +instance Listable (TypeDefinition ANY) Schema where + elems = HM.elems . typeRegister + fromElems types = case popByKey "Query" types of + (Nothing, _) -> failure (globalErrorMessage "INTERNAL: Query Not Defined") + (Just query, lib1) -> do + let (mutation, lib2) = popByKey "Mutation" lib1 + let (subscription, lib3) = popByKey "Subscription" lib2 + pure $ (foldr defineType (initTypeLib query) lib3) {mutation, subscription} + +initTypeLib :: TypeDefinition 'Out -> Schema +initTypeLib query = + Schema + { types = empty, + query = query, + mutation = Nothing, + subscription = Nothing + } + +typeRegister :: Schema -> TypeLib +typeRegister Schema {types, query, mutation, subscription} = + types + `union` HM.fromList + (concatMap fromOperation [Just query, mutation, subscription]) + +lookupDataType :: TypeName -> Schema -> Maybe (TypeDefinition ANY) +lookupDataType name = HM.lookup name . typeRegister + +isTypeDefined :: TypeName -> Schema -> Maybe DataFingerprint +isTypeDefined name lib = typeFingerprint <$> lookupDataType name lib + +-- 3.4 Types : https://graphql.github.io/graphql-spec/June2018/#sec-Types +------------------------------------------------------------------------- +-- TypeDefinition : +-- ScalarTypeDefinition +-- ObjectTypeDefinition +-- InterfaceTypeDefinition +-- UnionTypeDefinition +-- EnumTypeDefinition +-- InputObjectTypeDefinition + +data TypeDefinition (a :: TypeCategory) = TypeDefinition + { typeName :: TypeName, + typeFingerprint :: DataFingerprint, + typeDescription :: Maybe Description, + typeDirectives :: Directives VALID, + typeContent :: TypeContent TRUE a + } + deriving (Show, Lift) + +instance KeyOf (TypeDefinition a) where + type KEY (TypeDefinition a) = TypeName + keyOf = typeName + +data TypeCategory = In | Out | Any + +type IN = 'In + +type OUT = 'Out + +type ANY = 'Any + +class ToAny a where + toAny :: a (k :: TypeCategory) -> a ANY + +instance ToAny TypeDefinition where + toAny TypeDefinition {typeContent, ..} = TypeDefinition {typeContent = toAny typeContent, ..} + +instance ToAny (TypeContent TRUE) where + toAny DataScalar {..} = DataScalar {..} + toAny DataEnum {..} = DataEnum {..} + toAny DataInputObject {..} = DataInputObject {..} + toAny DataInputUnion {..} = DataInputUnion {..} + toAny DataObject {..} = DataObject {..} + toAny DataUnion {..} = DataUnion {..} + toAny DataInterface {..} = DataInterface {..} + +instance ToAny FieldDefinition where + toAny FieldDefinition {fieldContent, ..} = FieldDefinition {fieldContent = toAny <$> fieldContent, ..} + +instance ToAny (FieldContent TRUE) where + toAny (FieldArgs x) = FieldArgs x + toAny (DefaultInputValue x) = DefaultInputValue x + +class FromAny a (k :: TypeCategory) where + fromAny :: a ANY -> Maybe (a k) + +instance (FromAny (TypeContent TRUE) a) => FromAny TypeDefinition a where + fromAny TypeDefinition {typeContent, ..} = bla <$> fromAny typeContent + where + bla x = TypeDefinition {typeContent = x, ..} + +instance FromAny (TypeContent TRUE) IN where + fromAny DataScalar {..} = Just DataScalar {..} + fromAny DataEnum {..} = Just DataEnum {..} + fromAny DataInputObject {..} = Just DataInputObject {..} + fromAny DataInputUnion {..} = Just DataInputUnion {..} + fromAny _ = Nothing + +instance FromAny (TypeContent TRUE) OUT where + fromAny DataScalar {..} = Just DataScalar {..} + fromAny DataEnum {..} = Just DataEnum {..} + fromAny DataObject {..} = Just DataObject {..} + fromAny DataUnion {..} = Just DataUnion {..} + fromAny DataInterface {..} = Just DataInterface {..} + fromAny _ = Nothing + +type family IsSelected (c :: TypeCategory) (a :: TypeCategory) :: Bool + +type instance IsSelected ANY a = TRUE + +type instance IsSelected OUT OUT = TRUE + +type instance IsSelected IN IN = TRUE + +type instance IsSelected IN OUT = FALSE + +type instance IsSelected OUT IN = FALSE + +type instance IsSelected a ANY = TRUE + +data TypeContent (b :: Bool) (a :: TypeCategory) where + DataScalar :: + { dataScalar :: ScalarDefinition + } -> + TypeContent TRUE a + DataEnum :: + { enumMembers :: DataEnum + } -> + TypeContent TRUE a + DataInputObject :: + { inputObjectFields :: FieldsDefinition IN + } -> + TypeContent (IsSelected a IN) a + DataInputUnion :: + { inputUnionMembers :: DataInputUnion + } -> + TypeContent (IsSelected a IN) a + DataObject :: + { objectImplements :: [TypeName], + objectFields :: FieldsDefinition OUT + } -> + TypeContent (IsSelected a OUT) a + DataUnion :: + { unionMembers :: DataUnion + } -> + TypeContent (IsSelected a OUT) a + DataInterface :: + { interfaceFields :: FieldsDefinition OUT + } -> + TypeContent (IsSelected a OUT) a + +deriving instance Show (TypeContent a b) + +deriving instance Lift (TypeContent a b) + +createType :: TypeName -> TypeContent TRUE a -> TypeDefinition a +createType typeName typeContent = + TypeDefinition + { typeName, + typeDescription = Nothing, + typeFingerprint = DataFingerprint typeName [], + typeDirectives = [], + typeContent + } + +createScalarType :: TypeName -> TypeDefinition a +createScalarType typeName = createType typeName $ DataScalar (ScalarDefinition pure) + +createEnumType :: TypeName -> [TypeName] -> TypeDefinition a +createEnumType typeName typeData = createType typeName (DataEnum enumValues) + where + enumValues = map createEnumValue typeData + +createEnumValue :: TypeName -> DataEnumValue +createEnumValue enumName = + DataEnumValue + { enumName, + enumDescription = Nothing, + enumDirectives = [] + } + +createUnionType :: TypeName -> [TypeName] -> TypeDefinition OUT +createUnionType typeName typeData = createType typeName (DataUnion $ map mkUnionMember typeData) + +isEntNode :: TypeContent TRUE a -> Bool +isEntNode DataScalar {} = True +isEntNode DataEnum {} = True +isEntNode _ = False + +kindOf :: TypeDefinition a -> TypeKind +kindOf TypeDefinition {typeName, typeContent} = __kind typeContent + where + __kind DataScalar {} = KindScalar + __kind DataEnum {} = KindEnum + __kind DataInputObject {} = KindInputObject + __kind DataObject {} = KindObject (toOperationType typeName) + __kind DataUnion {} = KindUnion + __kind DataInputUnion {} = KindInputUnion + __kind DataInterface {} = KindInterface + +fromOperation :: Maybe (TypeDefinition OUT) -> [(TypeName, TypeDefinition ANY)] +fromOperation (Just datatype) = [(typeName datatype, toAny datatype)] +fromOperation Nothing = [] + +defineType :: TypeDefinition cat -> Schema -> Schema +defineType dt@TypeDefinition {typeName, typeContent = DataInputUnion enumKeys, typeFingerprint} lib = + lib {types = HM.insert name unionTags (HM.insert typeName (toAny dt) (types lib))} + where + name = typeName <> "Tags" + unionTags = + TypeDefinition + { typeName = name, + typeFingerprint, + typeDescription = Nothing, + typeDirectives = [], + typeContent = DataEnum $ map (createEnumValue . memberName) enumKeys + } +defineType datatype lib = + lib {types = HM.insert (typeName datatype) (toAny datatype) (types lib)} + +insertType :: + TypeDefinition ANY -> + TypeUpdater +insertType datatype@TypeDefinition {typeName} lib = case isTypeDefined typeName lib of + Nothing -> resolveUpdates (defineType datatype lib) [] + Just fingerprint + | fingerprint == typeFingerprint datatype -> return lib + -- throw error if 2 different types has same name + | otherwise -> failure $ nameCollisionError typeName + +updateSchema :: + TypeName -> + DataFingerprint -> + [TypeUpdater] -> + (a -> TypeDefinition cat) -> + a -> + TypeUpdater +updateSchema name fingerprint stack f x lib = + case isTypeDefined name lib of + Nothing -> + resolveUpdates + (defineType (f x) lib) + stack + Just fingerprint' | fingerprint' == fingerprint -> return lib + -- throw error if 2 different types has same name + Just _ -> failure $ nameCollisionError name + +lookupWith :: Eq k => (a -> k) -> k -> [a] -> Maybe a +lookupWith f key = find ((== key) . f) + +-- lookups and removes TypeDefinition from hashmap +popByKey :: TypeName -> [TypeDefinition ANY] -> (Maybe (TypeDefinition OUT), [TypeDefinition ANY]) +popByKey name types = case lookupWith typeName name types of + Just dt@TypeDefinition {typeContent = DataObject {}} -> + (fromAny dt, filter ((/= name) . typeName) types) + _ -> (Nothing, types) + +newtype Fields def = Fields + {unFields :: OrderedMap FieldName def} + deriving + ( Show, + Lift, + Functor, + Foldable, + Traversable + ) + +deriving instance (KEY def ~ FieldName, KeyOf def) => Collection def (Fields def) + +instance Merge (FieldsDefinition cat) where + merge path (Fields x) (Fields y) = Fields <$> merge path x y + +instance Selectable (Fields (FieldDefinition cat)) (FieldDefinition cat) where + selectOr fb f name (Fields lib) = selectOr fb f name lib + +unsafeFromFields :: [FieldDefinition cat] -> FieldsDefinition cat +unsafeFromFields = Fields . unsafeFromValues + +fieldsToArguments :: FieldsDefinition IN -> ArgumentsDefinition +fieldsToArguments = ArgumentsDefinition Nothing . unFields + +instance (KEY def ~ FieldName, KeyOf def, NameCollision def) => Listable def (Fields def) where + fromElems = fmap Fields . fromElems + elems = elems . unFields + +-- 3.6 Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Objects +------------------------------------------------------------------------------ +-- ObjectTypeDefinition: +-- Description(opt) type Name ImplementsInterfaces(opt) Directives(Const)(opt) FieldsDefinition(opt) +-- +-- ImplementsInterfaces +-- implements &(opt) NamedType +-- ImplementsInterfaces & NamedType +-- +-- FieldsDefinition +-- { FieldDefinition(list) } +-- +type FieldsDefinition cat = Fields (FieldDefinition cat) + +-- FieldDefinition +-- Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt) +-- +-- https://spec.graphql.org/June2018/#InputValueDefinition +-- InputValueDefinition +-- Description(opt) Name: Type DefaultValue(opt) Directives[Const](opt) + +data FieldDefinition (cat :: TypeCategory) = FieldDefinition + { fieldName :: FieldName, + fieldDescription :: Maybe Description, + fieldType :: TypeRef, + fieldContent :: Maybe (FieldContent TRUE cat), + fieldDirectives :: [Directive VALID] + } + deriving (Show, Lift) + +data FieldContent (bool :: Bool) (cat :: TypeCategory) where + DefaultInputValue :: + { defaultInputValue :: Value RESOLVED + } -> + FieldContent (IsSelected cat IN) cat + FieldArgs :: + { fieldArgsDef :: ArgumentsDefinition + } -> + FieldContent (IsSelected cat OUT) cat + +fieldContentArgs :: FieldContent b cat -> OrderedMap FieldName ArgumentDefinition +fieldContentArgs (FieldArgs (ArgumentsDefinition _ argsD)) = argsD +fieldContentArgs _ = empty + +deriving instance Show (FieldContent bool cat) + +deriving instance Lift (FieldContent bool cat) + +instance KeyOf (FieldDefinition cat) where + keyOf = fieldName + +instance Selectable (FieldDefinition OUT) ArgumentDefinition where + selectOr fb f key FieldDefinition {fieldContent = Just (FieldArgs args)} = selectOr fb f key args + selectOr fb _ _ _ = fb + +instance NameCollision (FieldDefinition cat) where + nameCollision name _ = + GQLError + { message = "There can Be only One field Named " <> msg name, + locations = [] + } + +instance RenderGQL (FieldDefinition cat) where + render FieldDefinition {fieldName = FieldName name, fieldType, fieldContent = Just (FieldArgs args)} = + name <> render args <> ": " <> render fieldType + render FieldDefinition {fieldName = FieldName name, fieldType} = + name <> ": " <> render fieldType + +instance RenderGQL (FieldsDefinition OUT) where + render = renderObject render . ignoreHidden . elems + +instance RenderGQL (FieldsDefinition IN) where + render = renderObject render . ignoreHidden . elems + +fieldVisibility :: FieldDefinition cat -> Bool +fieldVisibility FieldDefinition {fieldName} = fieldName `notElem` sysFields + +isFieldNullable :: FieldDefinition cat -> Bool +isFieldNullable = isNullable . fieldType + +createField :: Maybe (FieldContent TRUE cat) -> FieldName -> ([TypeWrapper], TypeName) -> FieldDefinition cat +createField fieldContent fieldName (typeWrappers, typeConName) = + FieldDefinition + { fieldName, + fieldContent, + fieldDescription = Nothing, + fieldType = TypeRef {typeConName, typeWrappers, typeArgs = Nothing}, + fieldDirectives = [] + } + +mkField :: FieldName -> ([TypeWrapper], TypeName) -> FieldDefinition cat +mkField = createField Nothing + +mkObjectField :: ArgumentsDefinition -> FieldName -> ([TypeWrapper], TypeName) -> FieldDefinition OUT +mkObjectField args = createField (Just $ FieldArgs args) + +toNullableField :: FieldDefinition cat -> FieldDefinition cat +toNullableField dataField + | isNullable (fieldType dataField) = dataField + | otherwise = dataField {fieldType = nullable (fieldType dataField)} + where + nullable alias@TypeRef {typeWrappers} = + alias {typeWrappers = TypeMaybe : typeWrappers} + +toListField :: FieldDefinition cat -> FieldDefinition cat +toListField dataField = dataField {fieldType = listW (fieldType dataField)} + where + listW alias@TypeRef {typeWrappers} = + alias {typeWrappers = TypeList : typeWrappers} + +-- 3.10 Input Objects: https://spec.graphql.org/June2018/#sec-Input-Objects +--------------------------------------------------------------------------- +-- InputObjectTypeDefinition +-- Description(opt) input Name Directives(const,opt) InputFieldsDefinition(opt) +-- +--- InputFieldsDefinition +-- { InputValueDefinition(list) } + +type InputFieldsDefinition = Fields InputValueDefinition + +type InputValueDefinition = FieldDefinition IN + +-- 3.6.1 Field Arguments : https://graphql.github.io/graphql-spec/June2018/#sec-Field-Arguments +----------------------------------------------------------------------------------------------- +-- ArgumentsDefinition: +-- (InputValueDefinition(list)) + +data ArgumentsDefinition = ArgumentsDefinition + { argumentsTypename :: Maybe TypeName, + arguments :: OrderedMap FieldName ArgumentDefinition + } + deriving (Show, Lift) + +instance RenderGQL ArgumentsDefinition where + render ArgumentsDefinition {arguments} + | null arguments = + "" + | otherwise = "(" <> intercalate ", " (map render $ elems arguments) <> ")" + +type ArgumentDefinition = FieldDefinition IN + +instance Selectable ArgumentsDefinition ArgumentDefinition where + selectOr fb f key (ArgumentsDefinition _ args) = selectOr fb f key args + +instance Collection ArgumentDefinition ArgumentsDefinition where + empty = ArgumentsDefinition Nothing empty + singleton = ArgumentsDefinition Nothing . singleton + +instance Listable ArgumentDefinition ArgumentsDefinition where + elems (ArgumentsDefinition _ args) = elems args + fromElems args = ArgumentsDefinition Nothing <$> fromElems args + +createArgument :: FieldName -> ([TypeWrapper], TypeName) -> FieldDefinition IN +createArgument = mkField + +-- https://spec.graphql.org/June2018/#InputValueDefinition +-- InputValueDefinition +-- Description(opt) Name: TypeDefaultValue(opt) Directives[Const](opt) +-- TODO: implement inputValue + +__inputname :: FieldName +__inputname = "inputname" + +createInputUnionFields :: TypeName -> [UnionMember IN] -> [FieldDefinition IN] +createInputUnionFields name members = fieldTag : map unionField members + where + fieldTag = + FieldDefinition + { fieldName = __inputname, + fieldDescription = Nothing, + fieldContent = Nothing, + fieldType = createAlias (name <> "Tags"), + fieldDirectives = [] + } + +unionField :: UnionMember IN -> FieldDefinition IN +unionField UnionMember {memberName} = + FieldDefinition + { fieldName = toFieldName memberName, + fieldDescription = Nothing, + fieldContent = Nothing, + fieldType = + TypeRef + { typeConName = memberName, + typeWrappers = [TypeMaybe], + typeArgs = Nothing + }, + fieldDirectives = [] + } + +-- +-- OTHER +-------------------------------------------------------------------------------------------------- + +createAlias :: TypeName -> TypeRef +createAlias typeConName = + TypeRef {typeConName, typeWrappers = [], typeArgs = Nothing} + +type TypeUpdater = LibUpdater Schema + +instance RenderGQL Schema where + render schema = intercalate "\n\n" $ map render visibleTypes + where + visibleTypes = filter (not . isSystemTypeName . typeName) (elems schema) + +instance RenderGQL (TypeDefinition a) where + render TypeDefinition {typeName, typeContent} = __render typeContent + where + __render DataInterface {interfaceFields} = "interface " <> render typeName <> render interfaceFields + __render DataScalar {} = "scalar " <> render typeName + __render (DataEnum tags) = "enum " <> render typeName <> renderObject render tags + __render (DataUnion members) = + "union " + <> render typeName + <> " =\n " + <> intercalate ("\n" <> renderIndent <> "| ") (map render members) + __render (DataInputObject fields) = "input " <> render typeName <> render fields + __render (DataInputUnion members) = "input " <> render typeName <> render fieldsDef + where + fieldsDef = unsafeFromFields fields + fields :: [FieldDefinition IN] + fields = createInputUnionFields typeName members + __render DataObject {objectFields} = "type " <> render typeName <> render objectFields + +ignoreHidden :: [FieldDefinition cat] -> [FieldDefinition cat] +ignoreHidden = filter fieldVisibility diff --git a/src/Data/Morpheus/Types/Internal/AST/Value.hs b/src/Data/Morpheus/Types/Internal/AST/Value.hs --- a/src/Data/Morpheus/Types/Internal/AST/Value.hs +++ b/src/Data/Morpheus/Types/Internal/AST/Value.hs @@ -35,7 +35,6 @@ FromJSON (..), ToJSON (..), Value (..), - encode, object, pairs, ) @@ -51,6 +50,7 @@ elems, mapTuple, ) +import Data.Morpheus.Rendering.RenderGQL (RenderGQL (..)) import Data.Morpheus.Types.Internal.AST.Base ( FieldName, FieldName (..), @@ -77,7 +77,6 @@ import Data.Semigroup ((<>)) import Data.Text ( Text, - unpack, ) import qualified Data.Vector as V ( toList, @@ -95,6 +94,12 @@ | Boolean Bool deriving (Show, Eq, Generic, Lift) +instance RenderGQL ScalarValue where + render (Int x) = render x + render (Float x) = render x + render (String x) = render x + render (Boolean x) = render x + instance A.ToJSON ScalarValue where toJSON (Float x) = A.toJSON x toJSON (Int x) = A.toJSON x @@ -156,16 +161,18 @@ Scalar :: ScalarValue -> Value stage Null :: Value stage +deriving instance Show (Value a) + deriving instance Eq (Value s) data ObjectEntry (s :: Stage) = ObjectEntry { entryName :: FieldName, entryValue :: Value s } - deriving (Eq) + deriving (Eq, Show) -instance Show (ObjectEntry s) where - show (ObjectEntry (FieldName name) value) = unpack name <> ":" <> show value +instance RenderGQL (ObjectEntry a) where + render (ObjectEntry (FieldName name) value) = name <> ": " <> render value instance NameCollision (ObjectEntry s) where nameCollision _ ObjectEntry {entryName} = @@ -195,26 +202,30 @@ deriving instance Lift (ObjectEntry a) -instance Show (Value a) where - show Null = "null" - show (Enum x) = "" <> unpack (readTypeName x) - show (Scalar x) = show x - show (ResolvedVariable Ref {refName} Variable {variableValue}) = - "($" <> unpack (readName refName) <> ": " <> show variableValue <> ") " - show (VariableValue Ref {refName}) = "$" <> unpack (readName refName) <> " " - show (Object keys) = "{" <> foldr toEntry "" keys <> "}" +instance RenderGQL (Value a) where + -- TODO: fix + render (ResolvedVariable Ref {refName} _) = + "$" <> readName refName + render (VariableValue Ref {refName}) = "$" <> readName refName <> " " + -- TODO: fix + render Null = "null" + render (Enum x) = readTypeName x + render (Scalar x) = render x + render (Object keys) = "{" <> foldl toEntry "" (elems keys) <> "}" where - toEntry :: ObjectEntry a -> String -> String - toEntry value "" = show value - toEntry value txt = txt <> ", " <> show value - show (List list) = "[" <> foldl toEntry "" list <> "]" + toEntry :: Text -> ObjectEntry a -> Text + toEntry "" value = render value + toEntry txt value = txt <> ", " <> render value + render (List list) = "[" <> foldl toEntry "" list <> "]" where - toEntry :: String -> Value a -> String - toEntry "" value = show value - toEntry txt value = txt <> ", " <> show value + toEntry :: Text -> Value a -> Text + toEntry "" value = render value + toEntry txt value = txt <> ", " <> render value +-- render = pack . BS.unpack . A.encode + instance Msg (Value a) where - msg = msg . A.encode + msg = msg . render instance A.ToJSON (Value a) where toJSON (ResolvedVariable _ Variable {variableValue = ValidVariableValue x}) = diff --git a/src/Data/Morpheus/Types/Internal/Resolving/Resolver.hs b/src/Data/Morpheus/Types/Internal/Resolving/Resolver.hs --- a/src/Data/Morpheus/Types/Internal/Resolving/Resolver.hs +++ b/src/Data/Morpheus/Types/Internal/Resolving/Resolver.hs @@ -78,10 +78,6 @@ VALID, msg, ) -import Data.Morpheus.Types.Internal.AST.Data - ( Arguments, - Schema, - ) import Data.Morpheus.Types.Internal.AST.MergeSet ( toOrderedMap, ) @@ -92,6 +88,10 @@ SelectionSet, UnionSelection, UnionTag (..), + ) +import Data.Morpheus.Types.Internal.AST.TypeSystem + ( Arguments, + Schema, ) import Data.Morpheus.Types.Internal.AST.Value ( GQLValue (..), diff --git a/src/Data/Morpheus/Types/Internal/Validation.hs b/src/Data/Morpheus/Types/Internal/Validation.hs --- a/src/Data/Morpheus/Types/Internal/Validation.hs +++ b/src/Data/Morpheus/Types/Internal/Validation.hs @@ -16,12 +16,8 @@ InputValidator, BaseValidator, InputSource (..), - Context (..), - SelectionContext (..), + OperationContext (..), runValidator, - askSchema, - askContext, - askFragments, askFieldType, askTypeMember, selectRequired, @@ -30,10 +26,9 @@ constraint, withScope, withScopeType, - withScopePosition, - askScopeTypeName, + withPosition, + asks, selectWithDefaultValue, - askScopePosition, askInputFieldType, askInputMember, startInput, @@ -44,13 +39,23 @@ constraintInputUnion, ScopeKind (..), withDirective, + inputValueSource, + askVariables, + Scope (..), + MissingRequired (..), + InputContext, + GetWith, + SetWith, + Unknown, + askSchema, + askFragments, + MonadContext, + CurrentSelection (..), ) where import Control.Monad.Trans.Reader - ( ReaderT (..), - ask, - withReaderT, + ( ask, ) -- MORPHEUS @@ -65,22 +70,25 @@ ) import Data.Morpheus.Types.Internal.AST ( ANY, - Directive (..), + FieldContent (..), FieldDefinition (..), FieldName, FieldsDefinition, - Fragments, + GQLErrors, IN, Message, OUT, Object, - Position, + ObjectEntry (..), + RESOLVED, Ref (..), Schema, + TRUE, TypeContent (..), TypeDefinition (..), TypeName (..), TypeRef (..), + UnionMember (..), Value (..), __inputname, entryValue, @@ -89,9 +97,6 @@ msg, toFieldName, ) -import Data.Morpheus.Types.Internal.Resolving - ( Eventless, - ) import Data.Morpheus.Types.Internal.Validation.Error ( InternalError (..), KindViolation (..), @@ -102,35 +107,50 @@ import Data.Morpheus.Types.Internal.Validation.Validator ( BaseValidator, Constraint (..), - Context (..), - InputContext (..), + CurrentSelection (..), + GetWith (..), + InputContext, InputSource (..), InputValidator, + MonadContext (..), + OperationContext (..), Prop (..), Resolution, + Scope (..), ScopeKind (..), - SelectionContext (..), SelectionValidator, + SetWith (..), Target (..), Validator (..), - renderInputPrefix, + askFragments, + askSchema, + askVariables, + asks, + inputMessagePrefix, + inputValueSource, + runValidator, + startInput, + withDirective, + withInputScope, + withPosition, + withScope, + withScopeType, ) import Data.Semigroup ( (<>), - Semigroup (..), ) getUnused :: (KeyOf b, KEY a ~ KEY b, Selectable ca a) => ca -> [b] -> [b] getUnused uses = filter (not . (`member` uses) . keyOf) -failOnUnused :: Unused b => [b] -> Validator ctx () +failOnUnused :: Unused ctx b => [b] -> Validator ctx () failOnUnused x | null x = return () | otherwise = do - (gctx, _) <- Validator ask - failure $ map (unused gctx) x + ctx <- Validator ask + failure $ map (unused ctx) x -checkUnused :: (KeyOf b, KEY a ~ KEY b, Selectable ca a, Unused b) => ca -> [b] -> Validator ctx () +checkUnused :: (KeyOf b, KEY a ~ KEY b, Selectable ca a, Unused ctx b) => ca -> [b] -> Validator ctx () checkUnused uses = failOnUnused . getUnused uses constraint :: @@ -155,39 +175,48 @@ Validator ctx value selectRequired selector container = do - (gctx, ctx) <- Validator ask + ctx <- Validator ask selectBy - [missingRequired gctx ctx selector container] + [missingRequired ctx selector container] (keyOf selector) container selectWithDefaultValue :: + forall ctx values value. ( Selectable values value, MissingRequired values ctx, - KEY value ~ FieldName + KEY value ~ FieldName, + GetWith ctx Scope, + MonadContext Validator ctx ) => - value -> + (Value RESOLVED -> value) -> FieldDefinition IN -> values -> Validator ctx value selectWithDefaultValue - fallbackValue - field@FieldDefinition {fieldName} + f + field@FieldDefinition + { fieldName, + fieldContent + } values = selectOr - handleNullable + (handeNull fieldContent) pure fieldName values where ------------------ - handleNullable - | isFieldNullable field = pure fallbackValue + handeNull :: Maybe (FieldContent TRUE IN) -> Validator ctx value + handeNull (Just (DefaultInputValue value)) = pure $ f value + handeNull Nothing + | isFieldNullable field = pure $ f Null | otherwise = failSelection ----------------- failSelection = do - (gctx, ctx) <- Validator ask - failure [missingRequired gctx ctx (Ref fieldName (scopePosition gctx)) values] + ctx <- Validator ask + position <- asks position + failure [missingRequired ctx (Ref fieldName position) values] selectKnown :: ( Selectable c a, @@ -201,9 +230,9 @@ Validator ctx a selectKnown selector lib = do - (gctx, ctx) <- Validator ask + ctx <- Validator ask selectBy - (unknown gctx ctx lib selector) + (unknown ctx lib selector) (keyOf selector) lib @@ -227,18 +256,18 @@ <> "\" must be an OUTPUT_TYPE." askTypeMember :: - TypeName -> + UnionMember OUT -> SelectionValidator (TypeName, FieldsDefinition OUT) -askTypeMember name = +askTypeMember UnionMember {memberName} = askSchema - >>= selectOr notFound pure name + >>= selectOr notFound pure memberName >>= constraintOBJECT where notFound = do - scopeType <- askScopeTypeName + scopeType <- asks typename failure $ "Type \"" - <> msg name + <> msg memberName <> "\" referenced by union \"" <> msg scopeType <> "\" can't found in Schema." @@ -248,7 +277,7 @@ where con DataObject {objectFields} = pure (typeName, objectFields) con _ = do - scopeType <- askScopeTypeName + scopeType <- asks typename failure $ "Type \"" <> msg typeName <> "\" referenced by union \"" @@ -256,8 +285,14 @@ <> "\" must be an OBJECT." askInputFieldType :: + ( Failure GQLErrors (m c), + Failure Message (m c), + Monad (m c), + GetWith c Schema, + MonadContext m c + ) => FieldDefinition IN -> - InputValidator (TypeDefinition IN) + m c (TypeDefinition IN) askInputFieldType field@FieldDefinition {fieldName, fieldType = TypeRef {typeConName}} = askSchema >>= selectBy @@ -265,7 +300,12 @@ typeConName >>= constraintINPUT where - constraintINPUT :: TypeDefinition ANY -> InputValidator (TypeDefinition IN) + constraintINPUT :: + ( Failure Message m, + Monad m + ) => + TypeDefinition ANY -> + m (TypeDefinition IN) constraintINPUT x = case (fromAny x :: Maybe (TypeDefinition IN)) of Just inputType -> pure inputType Nothing -> @@ -277,8 +317,14 @@ <> "\" must be an input type." askInputMember :: + ( GetWith c Schema, + GetWith c Scope, + Failure Message (m c), + Monad (m c), + MonadContext m c + ) => TypeName -> - InputValidator (TypeDefinition IN) + m c (TypeDefinition IN) askInputMember name = askSchema >>= selectOr notFound pure name @@ -287,105 +333,42 @@ typeInfo tName = "Type \"" <> msg tName <> "\" referenced by inputUnion " notFound = do - scopeType <- askScopeTypeName + scopeType <- asks typename failure $ typeInfo name <> msg scopeType <> "\" can't found in Schema." -------------------------------------- - constraintINPUT_OBJECT :: TypeDefinition ANY -> InputValidator (TypeDefinition IN) + constraintINPUT_OBJECT :: + ( Monad (m c), + GetWith c Scope, + Failure Message (m c), + MonadContext m c + ) => + TypeDefinition ANY -> + m c (TypeDefinition IN) constraintINPUT_OBJECT TypeDefinition {typeContent, ..} = con (fromAny typeContent) where - con :: Maybe (TypeContent a IN) -> InputValidator (TypeDefinition IN) + con :: + ( Monad (m c), + GetWith c Scope, + Failure Message (m c), + MonadContext m c + ) => + Maybe (TypeContent a IN) -> + m c (TypeDefinition IN) con (Just content@DataInputObject {}) = pure TypeDefinition {typeContent = content, ..} con _ = do - scopeType <- askScopeTypeName + scopeType <- asks typename failure $ typeInfo typeName <> "\"" <> msg scopeType <> "\" must be an INPUT_OBJECT." -startInput :: InputSource -> InputValidator a -> Validator ctx a -startInput inputSource = - setContext $ - const - InputContext - { inputSource, - inputPath = [] - } - -withDirective :: Directive s -> Validator ctx a -> Validator ctx a -withDirective - Directive - { directiveName, - directivePosition - } = setGlobalContext update - where - update ctx = - ctx - { scopePosition = directivePosition, - scopeSelectionName = directiveName, - scopeKind = DIRECTIVE - } - -withInputScope :: Prop -> InputValidator a -> InputValidator a -withInputScope prop = setContext update - where - update ctx@InputContext {inputPath = old} = - ctx {inputPath = old <> [prop]} - -runValidator :: Validator ctx a -> Context -> ctx -> Eventless a -runValidator (Validator x) globalCTX ctx = runReaderT x (globalCTX, ctx) - -askContext :: Validator ctx ctx -askContext = snd <$> Validator ask - -askSchema :: Validator ctx Schema -askSchema = schema . fst <$> Validator ask - -askFragments :: Validator ctx Fragments -askFragments = fragments . fst <$> Validator ask - -askScopeTypeName :: Validator ctx TypeName -askScopeTypeName = scopeTypeName . fst <$> Validator ask - -askScopePosition :: Validator ctx Position -askScopePosition = scopePosition . fst <$> Validator ask - -setContext :: - (c' -> c) -> - Validator c a -> - Validator c' a -setContext f = Validator . withReaderT (\(x, y) -> (x, f y)) . _runValidator - -setGlobalContext :: - (Context -> Context) -> - Validator c a -> - Validator c a -setGlobalContext f = Validator . withReaderT (\(x, y) -> (f x, y)) . _runValidator - -withScope :: TypeName -> Ref -> Validator ctx a -> Validator ctx a -withScope scopeTypeName (Ref scopeSelectionName scopePosition) = setGlobalContext update - where - update ctx = ctx {scopeTypeName, scopePosition, scopeSelectionName} - -withScopePosition :: Position -> Validator ctx a -> Validator ctx a -withScopePosition scopePosition = setGlobalContext update - where - update ctx = ctx {scopePosition} - -withScopeType :: TypeName -> Validator ctx a -> Validator ctx a -withScopeType scopeTypeName = setGlobalContext update - where - update ctx = ctx {scopeTypeName} - -inputMessagePrefix :: InputValidator Message -inputMessagePrefix = renderInputPrefix <$> askContext - constraintInputUnion :: forall stage. - [(TypeName, Bool)] -> + [UnionMember IN] -> Object stage -> Either Message (TypeName, Maybe (Value stage)) constraintInputUnion tags hm = do @@ -414,16 +397,8 @@ pure (tyName, Just value) _ -> failure ("input union can have only one variant." :: Message) -isPosibeInputUnion :: [(TypeName, Bool)] -> Value stage -> Either Message TypeName -isPosibeInputUnion tags (Enum name) = case lookup name tags of - Nothing -> - failure - ( msg name - <> " is not posible union type" - ) - _ -> pure name -isPosibeInputUnion _ _ = - failure $ - "\"" - <> msg __inputname - <> "\" must be Enum" +isPosibeInputUnion :: [UnionMember IN] -> Value stage -> Either Message TypeName +isPosibeInputUnion tags (Enum name) + | name `elem` map memberName tags = pure name + | otherwise = failure $ msg name <> " is not posible union type" +isPosibeInputUnion _ _ = failure $ "\"" <> msg __inputname <> "\" must be Enum" diff --git a/src/Data/Morpheus/Types/Internal/Validation/Error.hs b/src/Data/Morpheus/Types/Internal/Validation/Error.hs --- a/src/Data/Morpheus/Types/Internal/Validation/Error.hs +++ b/src/Data/Morpheus/Types/Internal/Validation/Error.hs @@ -46,9 +46,14 @@ getOperationName, msg, ) +import Data.Morpheus.Types.Internal.Validation.SchemaValidator + ( TypeSystemContext, + ) import Data.Morpheus.Types.Internal.Validation.Validator - ( Context (..), + ( CurrentSelection (..), InputContext (..), + OperationContext (..), + Scope (..), ScopeKind (..), Target (..), renderInputPrefix, @@ -73,13 +78,13 @@ locations = [] } -class Unused c where - unused :: Context -> c -> GQLError +class Unused ctx c where + unused :: ctx -> c -> GQLError -- query M ( $v : String ) { a } -> "Variable \"$bla\" is never used in operation \"MyMutation\".", -instance Unused (Variable s) where +instance Unused (OperationContext v) (Variable s) where unused - Context {operationName} + OperationContext {selection = CurrentSelection {operationName}} Variable {variableName, variablePosition} = GQLError { message = @@ -90,7 +95,7 @@ locations = [variablePosition] } -instance Unused Fragment where +instance Unused (OperationContext v) Fragment where unused _ Fragment {fragmentName, fragmentPosition} = @@ -102,45 +107,66 @@ } class MissingRequired c ctx where - missingRequired :: Context -> ctx -> Ref -> c -> GQLError + missingRequired :: ctx -> Ref -> c -> GQLError -instance MissingRequired (Arguments s) ctx where +instance MissingRequired (Arguments s) (OperationContext v) where missingRequired - Context {scopePosition, scopeSelectionName, scopeKind} - _ + OperationContext + { scope = Scope {position, kind}, + selection = CurrentSelection {selectionName} + } Ref {refName} _ = GQLError { message = - inScope scopeKind + inScope kind <> " argument " <> msg refName <> " is required but not provided.", - locations = [scopePosition] + locations = [position] } where - inScope SELECTION = "Field " <> msg scopeSelectionName - inScope DIRECTIVE = "Directive " <> msg ("@" <> scopeSelectionName) + inScope DIRECTIVE = "Directive " <> msg ("@" <> selectionName) + inScope _ = "Field " <> msg selectionName -instance MissingRequired (Object s) InputContext where +instance MissingRequired (Object s) (InputContext (OperationContext v)) where missingRequired - Context {scopePosition} - inputCTX + input@InputContext + { sourceContext = + OperationContext + { scope = Scope {position} + } + } Ref {refName} _ = GQLError { message = - renderInputPrefix inputCTX + renderInputPrefix input <> "Undefined Field " <> msg refName <> ".", - locations = [scopePosition] + locations = [position] } -instance MissingRequired (VariableDefinitions s) ctx where +instance MissingRequired (Object s) (InputContext (TypeSystemContext ctx)) where missingRequired - Context {operationName} - _ + input + Ref {refName} + _ = + GQLError + { message = + renderInputPrefix input + <> "Undefined Field " + <> msg refName + <> ".", + locations = [] + } + +instance MissingRequired (VariableDefinitions s) (OperationContext v) where + missingRequired + OperationContext + { selection = CurrentSelection {operationName} + } Ref {refName, refPosition} _ = GQLError @@ -155,55 +181,70 @@ class Unknown c ctx where type UnknownSelector c - unknown :: Context -> ctx -> c -> UnknownSelector c -> GQLErrors + unknown :: ctx -> c -> UnknownSelector c -> GQLErrors -- {...H} -> "Unknown fragment \"H\"." instance Unknown Fragments ctx where type UnknownSelector Fragments = Ref - unknown _ _ _ (Ref name pos) = + unknown _ _ (Ref name pos) = errorMessage pos ("Unknown Fragment " <> msg name <> ".") instance Unknown Schema ctx where type UnknownSelector Schema = TypeNameRef - unknown _ _ _ TypeNameRef {typeNameRef, typeNamePosition} = + unknown _ _ TypeNameRef {typeNameRef, typeNamePosition} = errorMessage typeNamePosition ("Unknown type " <> msg typeNameRef <> ".") instance Unknown (FieldDefinition OUT) ctx where type UnknownSelector (FieldDefinition OUT) = Argument RESOLVED - unknown _ _ FieldDefinition {fieldName} Argument {argumentName, argumentPosition} = + unknown _ FieldDefinition {fieldName} Argument {argumentName, argumentPosition} = errorMessage argumentPosition ("Unknown Argument " <> msg argumentName <> " on Field " <> msg fieldName <> ".") -instance Unknown (FieldsDefinition IN) InputContext where +instance Unknown (FieldsDefinition IN) (InputContext (OperationContext v)) where type UnknownSelector (FieldsDefinition IN) = ObjectEntry RESOLVED - unknown Context {scopePosition} ctx _ ObjectEntry {entryName} = - [ GQLError - { message = renderInputPrefix ctx <> "Unknown Field " <> msg entryName <> ".", - locations = [scopePosition] - } - ] + unknown + input@InputContext {sourceContext = OperationContext {scope = Scope {position}}} + _ + ObjectEntry {entryName} = + [ GQLError + { message = renderInputPrefix input <> "Unknown Field " <> msg entryName <> ".", + locations = [position] + } + ] +instance Unknown (FieldsDefinition IN) (InputContext (TypeSystemContext ctx)) where + type UnknownSelector (FieldsDefinition IN) = ObjectEntry RESOLVED + unknown + input + _ + ObjectEntry {entryName} = + [ GQLError + { message = renderInputPrefix input <> "Unknown Field " <> msg entryName <> ".", + locations = [] + } + ] + instance Unknown DirectiveDefinition ctx where type UnknownSelector DirectiveDefinition = Argument RESOLVED - unknown _ _ DirectiveDefinition {directiveDefinitionName} Argument {argumentName, argumentPosition} = + unknown _ DirectiveDefinition {directiveDefinitionName} Argument {argumentName, argumentPosition} = errorMessage argumentPosition ("Unknown Argument " <> msg argumentName <> " on Directive " <> msg directiveDefinitionName <> ".") instance Unknown DirectiveDefinitions ctx where type UnknownSelector DirectiveDefinitions = Directive RAW - unknown _ _ _ Directive {directiveName, directivePosition} = + unknown _ _ Directive {directiveName, directivePosition} = errorMessage directivePosition ("Unknown Directive " <> msg directiveName <> ".") -instance Unknown (FieldsDefinition OUT) ctx where +instance Unknown (FieldsDefinition OUT) (OperationContext v) where type UnknownSelector (FieldsDefinition OUT) = Ref - unknown Context {scopeTypeName} _ _ = - unknownSelectionField scopeTypeName + unknown OperationContext {scope = Scope {typename}} _ = + unknownSelectionField typename class KindViolation (t :: Target) ctx where kindViolation :: c t -> ctx -> GQLError diff --git a/src/Data/Morpheus/Types/Internal/Validation/SchemaValidator.hs b/src/Data/Morpheus/Types/Internal/Validation/SchemaValidator.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Internal/Validation/SchemaValidator.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +module Data.Morpheus.Types.Internal.Validation.SchemaValidator + ( SchemaValidator, + selectType, + TypeSystemContext (..), + constraintInterface, + inField, + inType, + inArgument, + inInterface, + Field (..), + Interface (..), + renderField, + ) +where + +import Control.Monad.Reader (asks) +--import Data.Morpheus.Error.Document.Interface (unknownInterface) +import Data.Morpheus.Error.Utils (globalErrorMessage) +-- MORPHEUS + +import Data.Morpheus.Internal.Utils + ( Failure (..), + fromElems, + selectBy, + ) +import Data.Morpheus.Types.Internal.AST + ( ANY, + FieldName, + FieldsDefinition, + OUT, + Position (..), + Schema, + TypeContent (..), + TypeDefinition (..), + TypeName, + msg, + ) +import Data.Morpheus.Types.Internal.Resolving (Result (..)) +import Data.Morpheus.Types.Internal.Validation.Validator + ( GetWith (..), + Scope (..), + ScopeKind (..), + SetWith (..), + Validator (..), + renderField, + withContext, + ) +import Data.Semigroup + ( (<>), + Semigroup (..), + ) + +data TypeSystemContext c = TypeSystemContext + { types :: [TypeDefinition ANY], + local :: c + } + deriving (Show) + +instance GetWith (TypeSystemContext ctx) Schema where + getWith ctx = case fromElems (types ctx) of + Success {result} -> result + Failure {errors} -> error (show errors) + +instance GetWith (TypeSystemContext a) Scope where + getWith _ = + Scope + { position = Position {line = 0, column = 0}, + typename = "TODO:", + kind = TYPE + } + +instance SetWith (TypeSystemContext a) Scope where + setWith _ = id --TODO: + +selectType :: TypeName -> SchemaValidator ctx (TypeDefinition ANY) +selectType name = + asks types + >>= selectBy err name + where + err = globalErrorMessage $ "Unknown Type " <> msg name <> "." + +inType :: + TypeName -> + SchemaValidator TypeName v -> + SchemaValidator () v +inType name = withLocalContext (const name) + +inInterface :: + TypeName -> + SchemaValidator Interface v -> + SchemaValidator TypeName v +inInterface interfaceName = withLocalContext (Interface interfaceName) + +inField :: + FieldName -> + SchemaValidator (t, FieldName) v -> + SchemaValidator t v +inField fname = withLocalContext (,fname) + +inArgument :: + FieldName -> + SchemaValidator (t, Field) v -> + SchemaValidator (t, FieldName) v +inArgument aname = withLocalContext (\(t1, f1) -> (t1, Field f1 aname)) + +data Interface = Interface + { interfaceName :: TypeName, + typeName :: TypeName + } + +data Field = Field + { fieldName :: FieldName, + fieldArgument :: FieldName + } + +withLocalContext :: (a -> b) -> Validator (TypeSystemContext b) v -> Validator (TypeSystemContext a) v +withLocalContext = withContext . updateLocal + +updateLocal :: (a -> b) -> TypeSystemContext a -> TypeSystemContext b +updateLocal f ctx = ctx {local = f (local ctx)} + +type SchemaValidator c = Validator (TypeSystemContext c) + +constraintInterface :: TypeDefinition ANY -> SchemaValidator ctx (TypeName, FieldsDefinition OUT) +constraintInterface + TypeDefinition + { typeName, + typeContent = DataInterface fields + } = pure (typeName, fields) +constraintInterface TypeDefinition {typeName} = + failure $ globalErrorMessage $ "type " <> msg typeName <> " must be an interface" diff --git a/src/Data/Morpheus/Types/Internal/Validation/Validator.hs b/src/Data/Morpheus/Types/Internal/Validation/Validator.hs --- a/src/Data/Morpheus/Types/Internal/Validation/Validator.hs +++ b/src/Data/Morpheus/Types/Internal/Validation/Validator.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -7,6 +8,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -16,29 +18,38 @@ InputValidator, BaseValidator, runValidator, - askSchema, - askContext, - askFragments, Constraint (..), withScope, withScopeType, - withScopePosition, - askScopeTypeName, - askScopePosition, + withPosition, withInputScope, inputMessagePrefix, - Context (..), InputSource (..), InputContext (..), - SelectionContext (..), + OperationContext (..), + CurrentSelection (..), renderInputPrefix, Target (..), Prop (..), Resolution, ScopeKind (..), + inputValueSource, + Scope (..), + withDirective, + startInput, + GetWith (..), + SetWith (..), + MonadContext (..), + withContext, + renderField, + asks, + askSchema, + askVariables, + askFragments, ) where +import Control.Monad.Reader (MonadReader) import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Monad.Trans.Reader ( ReaderT (..), @@ -46,13 +57,13 @@ withReaderT, ) -- MORPHEUS - import Data.Morpheus.Internal.Utils ( Failure (..), ) import Data.Morpheus.Types.Internal.AST ( Argument (..), - FieldName, + Directive (..), + FieldName (..), FieldsDefinition, Fragments, GQLError (..), @@ -63,9 +74,10 @@ Position, RAW, RESOLVED, + Ref (..), Schema, - TypeDefinition (..), - TypeName, + TypeDefinition, + TypeName (..), VALID, Variable (..), VariableDefinitions, @@ -77,7 +89,6 @@ ) import Data.Semigroup ( (<>), - Semigroup (..), ) data Prop = Prop @@ -92,48 +103,73 @@ renderPath [] = "" renderPath path = "in field " <> msg (intercalateName "." $ map propName path) <> ": " -renderInputPrefix :: InputContext -> Message +renderInputPrefix :: InputContext c -> Message renderInputPrefix InputContext {inputPath, inputSource} = renderSource inputSource <> renderPath inputPath renderSource :: InputSource -> Message renderSource (SourceArgument Argument {argumentName}) = "Argument " <> msg argumentName <> " got invalid value. " -renderSource (SourceVariable Variable {variableName}) = +renderSource (SourceVariable Variable {variableName} _) = "Variable " <> msg ("$" <> variableName) <> " got invalid value. " +renderSource SourceInputField {sourceTypeName, sourceFieldName, sourceArgumentName} = + "Field " <> renderField sourceTypeName sourceFieldName sourceArgumentName <> " got invalid default value. " +renderField :: TypeName -> FieldName -> Maybe FieldName -> Message +renderField (TypeName tname) (FieldName fname) arg = + msg (tname <> "." <> fname <> renderArg arg) + where + renderArg (Just (FieldName argName)) = "(" <> argName <> ":)" + renderArg Nothing = "" + data ScopeKind = DIRECTIVE | SELECTION + | TYPE deriving (Show) -data Context = Context +data OperationContext vars = OperationContext { schema :: Schema, + scope :: Scope, fragments :: Fragments, - scopePosition :: Position, - scopeTypeName :: TypeName, - operationName :: Maybe FieldName, - scopeSelectionName :: FieldName, - scopeKind :: ScopeKind + selection :: CurrentSelection, + variables :: vars } deriving (Show) -data InputContext = InputContext - { inputSource :: InputSource, - inputPath :: [Prop] +data CurrentSelection = CurrentSelection + { operationName :: Maybe FieldName, + selectionName :: FieldName } deriving (Show) -data InputSource - = SourceArgument (Argument RESOLVED) - | SourceVariable (Variable RAW) +data Scope = Scope + { position :: Position, + typename :: TypeName, + kind :: ScopeKind + } deriving (Show) -newtype SelectionContext = SelectionContext - { variables :: VariableDefinitions VALID +data InputContext ctx = InputContext + { inputSource :: InputSource, + inputPath :: [Prop], + sourceContext :: ctx } deriving (Show) +data InputSource + = SourceArgument (Argument RESOLVED) + | SourceVariable + { sourceVariable :: Variable RAW, + isDefaultValue :: Bool + } + | SourceInputField + { sourceTypeName :: TypeName, + sourceFieldName :: FieldName, + sourceArgumentName :: Maybe FieldName + } + deriving (Show) + data Target = TARGET_OBJECT | TARGET_INPUT @@ -150,85 +186,251 @@ type instance Resolution 'TARGET_INPUT = TypeDefinition IN ---type instance Resolution 'TARGET_UNION = DataUnion - -withInputScope :: Prop -> InputValidator a -> InputValidator a -withInputScope prop = setContext update +withInputScope :: Prop -> InputValidator c a -> InputValidator c a +withInputScope prop = withContext update where - update ctx@InputContext {inputPath = old} = - ctx {inputPath = old <> [prop]} + update + InputContext + { inputPath = old, + .. + } = + InputContext + { inputPath = old <> [prop], + .. + } -askContext :: Validator ctx ctx -askContext = snd <$> Validator ask +inputValueSource :: + forall m c. + ( GetWith c InputSource, + MonadContext m c + ) => + m c InputSource +inputValueSource = get -askSchema :: Validator ctx Schema -askSchema = schema . fst <$> Validator ask +asks :: + ( MonadContext m c, + GetWith c t + ) => + (t -> a) -> + m c a +asks f = f <$> get -askFragments :: Validator ctx Fragments -askFragments = fragments . fst <$> Validator ask +setSelectionName :: + ( MonadContext m c, + SetWith c CurrentSelection + ) => + FieldName -> + m c a -> + m c a +setSelectionName selectionName = set update + where + update ctx = ctx {selectionName} -askScopeTypeName :: Validator ctx TypeName -askScopeTypeName = scopeTypeName . fst <$> Validator ask +askSchema :: + ( MonadContext m c, + GetWith c Schema + ) => + m c Schema +askSchema = get -askScopePosition :: Validator ctx Position -askScopePosition = scopePosition . fst <$> Validator ask +askVariables :: + ( MonadContext m c, + GetWith c (VariableDefinitions VALID) + ) => + m c (VariableDefinitions VALID) +askVariables = get -setContext :: +askFragments :: + ( MonadContext m c, + GetWith c Fragments + ) => + m c Fragments +askFragments = get + +runValidator :: Validator ctx a -> ctx -> Eventless a +runValidator (Validator x) = runReaderT x + +withContext :: (c' -> c) -> Validator c a -> Validator c' a -setContext f = Validator . withReaderT (\(x, y) -> (x, f y)) . _runValidator +withContext f = Validator . withReaderT f . _runValidator -setGlobalContext :: - (Context -> Context) -> - Validator c a -> - Validator c a -setGlobalContext f = Validator . withReaderT (\(x, y) -> (f x, y)) . _runValidator +withDirective :: + ( SetWith c CurrentSelection, + SetWith c Scope, + MonadContext m c + ) => + Directive s -> + m c a -> + m c a +withDirective + Directive + { directiveName, + directivePosition + } = setSelectionName directiveName . set update + where + update Scope {..} = + Scope + { position = directivePosition, + kind = DIRECTIVE, + .. + } -withScope :: TypeName -> Position -> Validator ctx a -> Validator ctx a -withScope scopeTypeName scopePosition = setGlobalContext update +withScope :: + ( SetWith c CurrentSelection, + MonadContext m c, + SetWith c Scope + ) => + TypeName -> + Ref -> + m c a -> + m c a +withScope typeName (Ref selName pos) = + setSelectionName selName . set update where - update ctx = ctx {scopeTypeName, scopePosition} + update Scope {..} = Scope {typename = typeName, position = pos, ..} -withScopePosition :: Position -> Validator ctx a -> Validator ctx a -withScopePosition scopePosition = setGlobalContext update +withPosition :: + ( MonadContext m c, + SetWith c Scope + ) => + Position -> + m c a -> + m c a +withPosition pos = set update where - update ctx = ctx {scopePosition} + update Scope {..} = Scope {position = pos, ..} -withScopeType :: TypeName -> Validator ctx a -> Validator ctx a -withScopeType scopeTypeName = setGlobalContext update +withScopeType :: + ( MonadContext m c, + SetWith c Scope + ) => + TypeName -> + m c a -> + m c a +withScopeType name = set update where - update ctx = ctx {scopeTypeName} + update Scope {..} = Scope {typename = name, ..} -inputMessagePrefix :: InputValidator Message -inputMessagePrefix = renderInputPrefix <$> askContext +inputMessagePrefix :: InputValidator ctx Message +inputMessagePrefix = renderInputPrefix <$> Validator ask -runValidator :: Validator ctx a -> Context -> ctx -> Eventless a -runValidator (Validator x) globalCTX ctx = runReaderT x (globalCTX, ctx) +startInput :: + InputSource -> + InputValidator ctx a -> + Validator ctx a +startInput inputSource = withContext update + where + update sourceContext = + InputContext + { inputSource, + inputPath = [], + sourceContext + } newtype Validator ctx a = Validator { _runValidator :: ReaderT - (Context, ctx) + ctx Eventless a } - deriving + deriving newtype ( Functor, Applicative, - Monad + Monad, + MonadReader ctx ) -type BaseValidator = Validator () +type BaseValidator = Validator (OperationContext ()) -type SelectionValidator = Validator SelectionContext +type SelectionValidator = Validator (OperationContext (VariableDefinitions VALID)) -type InputValidator = Validator InputContext +type InputValidator ctx = Validator (InputContext ctx) +-- Helpers +get :: (MonadContext m ctx, GetWith ctx a) => m ctx a +get = getContext getWith + +set :: + ( MonadContext m c, + SetWith c a + ) => + (a -> a) -> + m c b -> + m c b +set f = setContext (setWith f) + +class + Monad (m c) => + MonadContext m c + where + getContext :: (c -> a) -> m c a + setContext :: (c -> c) -> m c b -> m c b + +instance MonadContext Validator c where + getContext f = f <$> Validator ask + setContext = withContext + +class GetWith (c :: *) (v :: *) where + getWith :: c -> v + +instance GetWith (OperationContext v) Scope where + getWith = scope + +instance GetWith c Scope => GetWith (InputContext c) Scope where + getWith = getWith . sourceContext + +instance GetWith (OperationContext c) Schema where + getWith = schema + +instance GetWith c Schema => GetWith (InputContext c) Schema where + getWith = getWith . sourceContext + +instance GetWith (OperationContext (VariableDefinitions VALID)) (VariableDefinitions VALID) where + getWith = variables + +instance GetWith (InputContext ctx) InputSource where + getWith = inputSource + +instance GetWith (OperationContext v) Fragments where + getWith = fragments + +-- Setters +class SetWith (c :: *) (v :: *) where + setWith :: (v -> v) -> c -> c + +instance SetWith (OperationContext v) CurrentSelection where + setWith f OperationContext {selection = selection, ..} = + OperationContext + { selection = f selection, + .. + } + +instance SetWith (OperationContext v) Scope where + setWith f OperationContext {..} = + OperationContext + { scope = f scope, + .. + } + +instance SetWith c Scope => SetWith (InputContext c) Scope where + setWith f InputContext {..} = + InputContext + { sourceContext = setWith f sourceContext, + .. + } + -- can be only used for internal errors -instance Failure Message (Validator ctx) where +instance + ( MonadContext Validator ctx, + GetWith ctx Scope + ) => + Failure Message (Validator ctx) + where failure inputMessage = do - position <- askScopePosition + position <- asks position failure [ GQLError { message = "INTERNAL: " <> inputMessage, diff --git a/src/Data/Morpheus/Validation/Document/Validation.hs b/src/Data/Morpheus/Validation/Document/Validation.hs --- a/src/Data/Morpheus/Validation/Document/Validation.hs +++ b/src/Data/Morpheus/Validation/Document/Validation.hs @@ -1,4 +1,8 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} module Data.Morpheus.Validation.Document.Validation @@ -7,73 +11,242 @@ ) where +import Control.Monad ((>=>)) +import Control.Monad.Reader (asks) +import Data.Foldable (traverse_) import Data.Functor (($>)) -- -- Morpheus + import Data.Morpheus.Error.Document.Interface ( ImplementsError (..), - partialImplements, - unknownInterface, + PartialImplements (..), ) import Data.Morpheus.Internal.Utils - ( Selectable (..), + ( KeyOf (..), + Selectable (..), elems, + empty, + failure, ) +import Data.Morpheus.Schema.Schema (systemTypes) import Data.Morpheus.Types.Internal.AST ( ANY, + ArgumentDefinition, + ArgumentsDefinition (..), + FieldContent (..), FieldDefinition (..), FieldName (..), FieldsDefinition, + IN, OUT, + ObjectEntry (..), Schema, + TRUE, TypeContent (..), TypeDefinition (..), TypeName, TypeRef (..), isWeaker, - lookupWith, ) import Data.Morpheus.Types.Internal.Resolving ( Eventless, - Failure (..), ) +import Data.Morpheus.Types.Internal.Validation + ( InputSource (..), + InputValidator, + askInputFieldType, + runValidator, + startInput, + ) +import Data.Morpheus.Types.Internal.Validation.SchemaValidator + ( Field (..), + Interface (..), + SchemaValidator, + TypeSystemContext (..), + constraintInterface, + inArgument, + inField, + inInterface, + inType, + selectType, + ) +import Data.Morpheus.Validation.Internal.Value (validateInput) +import Data.Semigroup ((<>)) validateSchema :: Schema -> Eventless Schema validateSchema schema = validatePartialDocument (elems schema) $> schema validatePartialDocument :: [TypeDefinition ANY] -> Eventless [TypeDefinition ANY] -validatePartialDocument lib = traverse validateType lib - where - validateType :: TypeDefinition ANY -> Eventless (TypeDefinition ANY) - validateType dt@TypeDefinition {typeName, typeContent = DataObject {objectImplements, objectFields}} = do - interface <- traverse getInterfaceByKey objectImplements - case concatMap (mustBeSubset objectFields) interface of - [] -> pure dt - errors -> failure $ partialImplements typeName errors - validateType x = pure x - mustBeSubset :: - FieldsDefinition OUT -> (TypeName, FieldsDefinition OUT) -> [(TypeName, FieldName, ImplementsError)] - mustBeSubset objFields (typeName, fields) = concatMap checkField (elems fields) - where - checkField :: FieldDefinition OUT -> [(TypeName, FieldName, ImplementsError)] - checkField FieldDefinition {fieldName, fieldType = interfaceT@TypeRef {typeConName = interfaceTypeName, typeWrappers = interfaceWrappers}} = - selectOr err checkTypeEq fieldName objFields - where - err = [(typeName, fieldName, UndefinedField)] - checkTypeEq FieldDefinition {fieldType = objT@TypeRef {typeConName, typeWrappers}} - | typeConName == interfaceTypeName && not (isWeaker typeWrappers interfaceWrappers) = - [] - | otherwise = - [ ( typeName, - fieldName, - UnexpectedType - { expectedType = interfaceT, - foundType = objT - } - ) - ] - ------------------------------- - getInterfaceByKey :: TypeName -> Eventless (TypeName, FieldsDefinition OUT) - getInterfaceByKey interfaceName = case lookupWith typeName interfaceName lib of - Just TypeDefinition {typeContent = DataInterface {interfaceFields}} -> pure (interfaceName, interfaceFields) - _ -> failure $ unknownInterface interfaceName +validatePartialDocument types = + runValidator + (traverse validateType types) + TypeSystemContext + { types = systemTypes <> types, + local = () + } + +validateType :: + TypeDefinition ANY -> + SchemaValidator () (TypeDefinition ANY) +validateType + dt@TypeDefinition + { typeName, + typeContent = + DataObject + { objectImplements, + objectFields + } + } = inType typeName $ + do + validateImplements objectImplements objectFields + traverse_ checkFieldArgsuments objectFields + pure dt +validateType + dt@TypeDefinition + { typeContent = DataInputObject {inputObjectFields}, + typeName + } = inType typeName $ do + traverse_ validateFieldDefaultValue inputObjectFields + pure dt +validateType x = pure x + +-- INETRFACE +---------------------------- +validateImplements :: + [TypeName] -> + FieldsDefinition OUT -> + SchemaValidator TypeName () +validateImplements objectImplements objectFields = do + interface <- traverse selectInterface objectImplements + traverse_ (mustBeSubset objectFields) interface + +mustBeSubset :: + FieldsDefinition OUT -> (TypeName, FieldsDefinition OUT) -> SchemaValidator TypeName () +mustBeSubset objFields (typeName, fields) = + inInterface typeName $ + traverse_ (checkInterfaceField objFields) (elems fields) + +checkInterfaceField :: + FieldsDefinition OUT -> + FieldDefinition OUT -> + SchemaValidator Interface () +checkInterfaceField + objFields + interfaceField@FieldDefinition + { fieldName + } = + inField fieldName $ + selectOr err (isSuptype interfaceField) fieldName objFields + where + err = failImplements Missing + +class PartialImplements ctx => TypeEq a ctx where + isSuptype :: a -> a -> SchemaValidator ctx () + +instance TypeEq (FieldDefinition OUT) (Interface, FieldName) where + FieldDefinition + { fieldType, + fieldContent = args1 + } + `isSuptype` FieldDefinition + { fieldType = fieldType', + fieldContent = args2 + } = (fieldType `isSuptype` fieldType') *> (args1 `isSuptype` args2) + +instance TypeEq (Maybe (FieldContent TRUE OUT)) (Interface, FieldName) where + f1 `isSuptype` f2 = toARgs f1 `isSuptype` toARgs f2 + where + toARgs :: Maybe (FieldContent TRUE OUT) -> ArgumentsDefinition + toARgs (Just (FieldArgs args)) = args + toARgs _ = empty + +instance (PartialImplements ctx) => TypeEq TypeRef ctx where + t1@TypeRef + { typeConName, + typeWrappers = w1 + } + `isSuptype` t2@TypeRef + { typeConName = name', + typeWrappers = w2 + } + | typeConName == name' && not (isWeaker w2 w1) = pure () + | otherwise = + failImplements UnexpectedType {expectedType = t1, foundType = t2} + +elemIn :: + ( KeyOf a, + Selectable c a, + TypeEq a ctx + ) => + a -> + c -> + SchemaValidator ctx () +elemIn el = selectOr (failImplements Missing) (isSuptype el) (keyOf el) + +instance TypeEq ArgumentsDefinition (Interface, FieldName) where + args1 `isSuptype` args2 = traverse_ validateArg (elems args1) + where + validateArg arg = inArgument (keyOf arg) $ elemIn arg args2 + +instance TypeEq ArgumentDefinition (Interface, Field) where + arg1 `isSuptype` arg2 = fieldType arg1 `isSuptype` fieldType arg2 + +------------------------------- +selectInterface :: + TypeName -> + SchemaValidator ctx (TypeName, FieldsDefinition OUT) +selectInterface = selectType >=> constraintInterface + +failImplements :: + PartialImplements ctx => + ImplementsError -> + SchemaValidator ctx a +failImplements err = do + x <- asks local + failure $ partialImplements x err + +checkFieldArgsuments :: + FieldDefinition OUT -> + SchemaValidator TypeName () +checkFieldArgsuments FieldDefinition {fieldContent = Nothing} = pure () +checkFieldArgsuments FieldDefinition {fieldContent = Just (FieldArgs args), fieldName} = do + typeName <- asks local + traverse_ (validateArgumentDefaultValue typeName fieldName) (elems args) + +validateArgumentDefaultValue :: + TypeName -> + FieldName -> + ArgumentDefinition -> + SchemaValidator TypeName () +validateArgumentDefaultValue _ _ FieldDefinition {fieldContent = Nothing} = pure () +validateArgumentDefaultValue + typeName + fName + inputField@FieldDefinition {fieldName = argName} = + startInput (SourceInputField typeName fName (Just argName)) $ + validateDefaultValue inputField + +-- DEFAULT VALUE +-- TODO: implement default value validation +validateFieldDefaultValue :: + FieldDefinition IN -> + SchemaValidator TypeName () +validateFieldDefaultValue inputField@FieldDefinition {fieldName} = do + typeName <- asks local + startInput (SourceInputField typeName fieldName Nothing) $ + validateDefaultValue inputField + +validateDefaultValue :: + FieldDefinition IN -> + InputValidator (TypeSystemContext TypeName) () +validateDefaultValue FieldDefinition {fieldContent = Nothing} = pure () +validateDefaultValue + inputField@FieldDefinition + { fieldName, + fieldType = TypeRef {typeWrappers}, + fieldContent = Just DefaultInputValue {defaultInputValue} + } = do + datatype <- askInputFieldType inputField + _ <- validateInput typeWrappers datatype (ObjectEntry fieldName defaultInputValue) + pure () diff --git a/src/Data/Morpheus/Validation/Internal/Value.hs b/src/Data/Morpheus/Validation/Internal/Value.hs --- a/src/Data/Morpheus/Validation/Internal/Value.hs +++ b/src/Data/Morpheus/Validation/Internal/Value.hs @@ -1,10 +1,15 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Data.Morpheus.Validation.Internal.Value (validateInput) where import Data.Foldable (traverse_) +import Data.Function ((&)) import Data.List (elem) import Data.Maybe (maybe) -- MORPHEUS @@ -15,18 +20,23 @@ import Data.Morpheus.Internal.Utils ( Failure (..), elems, + fromElems, ) import Data.Morpheus.Types.Internal.AST ( DataEnumValue (..), + DataInputUnion, FieldDefinition (..), + FieldsDefinition, IN, Message, + Object, ObjectEntry (..), RESOLVED, Ref (..), ResolvedValue, ScalarDefinition (..), ScalarValue (..), + Schema, TRUE, TypeContent (..), TypeDefinition (..), @@ -49,13 +59,24 @@ ( unsafeFromValues, ) import Data.Morpheus.Types.Internal.Validation - ( InputValidator, + ( GetWith, + InputContext, + InputSource (..), + InputValidator, + MissingRequired, + MonadContext, Prop (..), + Scope (..), + ScopeKind (..), + SetWith, + Unknown, + Validator, askInputFieldType, askInputMember, - askScopePosition, + asks, constraintInputUnion, inputMessagePrefix, + inputValueSource, selectKnown, selectWithDefaultValue, withInputScope, @@ -63,9 +84,16 @@ ) import Data.Semigroup ((<>)) -castFailure :: TypeRef -> Maybe Message -> ResolvedValue -> InputValidator a +castFailure :: + ( GetWith ctx Schema, + GetWith ctx Scope + ) => + TypeRef -> + Maybe Message -> + ResolvedValue -> + InputValidator ctx a castFailure expected message value = do - pos <- askScopePosition + pos <- asks position prefix <- inputMessagePrefix failure $ errorMessage pos @@ -75,7 +103,7 @@ (TypeName, [TypeWrapper]) -> Ref -> Variable VALID -> - InputValidator ValidValue + InputValidator ctx ValidValue checkTypeEquality (tyConName, tyWrappers) ref var@Variable {variableValue = ValidVariableValue value, variableType} | typeConName variableType == tyConName && not @@ -92,31 +120,45 @@ typeArgs = Nothing } --- Validate Variable Argument or all Possible input Values +type InputConstraints ctx = + ( GetWith ctx Schema, + GetWith ctx Scope, + GetWith (InputContext ctx) InputSource, + SetWith ctx Scope, + MissingRequired (Object RESOLVED) (InputContext ctx), + Unknown (FieldsDefinition IN) (InputContext ctx) + ) + +-- Validate input Values validateInput :: + forall ctx. + ( InputConstraints ctx + ) => [TypeWrapper] -> TypeDefinition IN -> ObjectEntry RESOLVED -> - InputValidator ValidValue + InputValidator ctx ValidValue validateInput tyWrappers TypeDefinition {typeContent = tyCont, typeName} = withScopeType typeName . validateWrapped tyWrappers tyCont where - mismatchError :: [TypeWrapper] -> ResolvedValue -> InputValidator ValidValue - mismatchError wrappers = castFailure (TypeRef typeName Nothing wrappers) Nothing + mismatchError :: [TypeWrapper] -> Maybe Message -> ResolvedValue -> InputValidator ctx ValidValue + mismatchError wrappers = castFailure (TypeRef typeName Nothing wrappers) -- VALIDATION validateWrapped :: [TypeWrapper] -> TypeContent TRUE IN -> ObjectEntry RESOLVED -> - InputValidator ValidValue + InputValidator ctx ValidValue -- Validate Null. value = null ? validateWrapped wrappers _ ObjectEntry {entryValue = ResolvedVariable ref variable} = checkTypeEquality (typeName, wrappers) ref variable validateWrapped wrappers _ ObjectEntry {entryValue = Null} - | isNullableWrapper wrappers = return Null - | otherwise = mismatchError wrappers Null + | isNullableWrapper wrappers = pure Null + | otherwise = mismatchError wrappers Nothing Null -- Validate LIST + validateWrapped [TypeMaybe] dt ObjectEntry {entryValue} = + validateUnwrapped (mismatchError [TypeMaybe]) dt entryValue validateWrapped (TypeMaybe : wrappers) _ value = validateWrapped wrappers tyCont value validateWrapped (TypeList : wrappers) _ (ObjectEntry key (List list)) = @@ -125,60 +167,137 @@ validateElement = validateWrapped wrappers tyCont . ObjectEntry key {-- 2. VALIDATE TYPES, all wrappers are already Processed --} {-- VALIDATE OBJECT--} - validateWrapped [] dt v = validate dt v - where - validate :: - TypeContent TRUE IN -> ObjectEntry RESOLVED -> InputValidator ValidValue - validate (DataInputObject parentFields) ObjectEntry {entryValue = Object fields} = do - traverse_ requiredFieldsDefined (elems parentFields) - Object <$> traverse validateField fields - where - requiredFieldsDefined :: FieldDefinition IN -> InputValidator (ObjectEntry RESOLVED) - requiredFieldsDefined fieldDef@FieldDefinition {fieldName} = - selectWithDefaultValue (ObjectEntry fieldName Null) fieldDef fields - validateField :: - ObjectEntry RESOLVED -> InputValidator (ObjectEntry VALID) - validateField entry@ObjectEntry {entryName} = do - inputField@FieldDefinition {fieldType = TypeRef {typeConName, typeWrappers}} <- getField - inputTypeDef <- askInputFieldType inputField - withInputScope (Prop entryName typeConName) $ - ObjectEntry entryName - <$> validateInput - typeWrappers - inputTypeDef - entry - where - getField = selectKnown entry parentFields - -- VALIDATE INPUT UNION - -- TODO: enhance input union Validation - validate (DataInputUnion inputUnion) ObjectEntry {entryValue = Object rawFields} = - case constraintInputUnion inputUnion rawFields of - Left message -> castFailure (TypeRef typeName Nothing []) (Just message) (Object rawFields) - Right (name, Nothing) -> return (Object $ unsafeFromValues [ObjectEntry "__typename" (Enum name)]) - Right (name, Just value) -> do - inputDef <- askInputMember name - validValue <- - validateInput - [TypeMaybe] - inputDef - (ObjectEntry (toFieldName name) value) - return (Object $ unsafeFromValues [ObjectEntry "__typename" (Enum name), ObjectEntry (toFieldName name) validValue]) - {-- VALIDATE ENUM --} - validate (DataEnum tags) ObjectEntry {entryValue} = - validateEnum (castFailure (TypeRef typeName Nothing []) Nothing) tags entryValue - {-- VALIDATE SCALAR --} - validate (DataScalar dataScalar) ObjectEntry {entryValue} = - validateScalar typeName dataScalar entryValue (castFailure (TypeRef typeName Nothing [])) - validate _ ObjectEntry {entryValue} = mismatchError [] entryValue + validateWrapped [] dt ObjectEntry {entryValue} = + validateUnwrapped (mismatchError []) dt entryValue {-- 3. THROW ERROR: on invalid values --} - validateWrapped wrappers _ ObjectEntry {entryValue} = mismatchError wrappers entryValue + validateWrapped wrappers _ ObjectEntry {entryValue} = mismatchError wrappers Nothing entryValue + validateUnwrapped :: + -- error + (Maybe Message -> ResolvedValue -> InputValidator ctx ValidValue) -> + TypeContent TRUE IN -> + Value RESOLVED -> + InputValidator ctx ValidValue + validateUnwrapped _ (DataInputObject parentFields) (Object fields) = + Object <$> validateInputObject parentFields fields + validateUnwrapped _ (DataInputUnion inputUnion) (Object rawFields) = + validatInputUnion typeName inputUnion rawFields + validateUnwrapped err (DataEnum tags) value = + validateEnum (err Nothing) tags value + validateUnwrapped err (DataScalar dataScalar) value = + validateScalar typeName dataScalar value err + validateUnwrapped err _ value = err Nothing value +-- INPUT UNION +validatInputUnion :: + ( InputConstraints ctx + ) => + TypeName -> + DataInputUnion -> + Object RESOLVED -> + InputValidator ctx (Value VALID) +validatInputUnion typeName inputUnion rawFields = + case constraintInputUnion inputUnion rawFields of + Left message -> castFailure (TypeRef typeName Nothing []) (Just message) (Object rawFields) + Right (name, Nothing) -> pure (mkInputObject name []) + Right (name, Just value) -> validatInputUnionMember name value + +validatInputUnionMember :: + ( InputConstraints ctx + ) => + TypeName -> + Value RESOLVED -> + InputValidator ctx (Value VALID) +validatInputUnionMember name value = do + inputDef <- askInputMember name + validValue <- + validateInput + [TypeMaybe] + inputDef + (ObjectEntry (toFieldName name) value) + pure $ mkInputObject name [ObjectEntry (toFieldName name) validValue] + +mkInputObject :: TypeName -> [ObjectEntry s] -> Value s +mkInputObject name xs = Object $ unsafeFromValues $ ObjectEntry "__typename" (Enum name) : xs + +-- INUT Object +validateInputObject :: + ( InputConstraints ctx + ) => + FieldsDefinition IN -> + Object RESOLVED -> + InputValidator ctx (Object VALID) +validateInputObject fieldsDef object = + do + kind <- asks kind + case kind of + TYPE -> + traverse_ (`requiredFieldIsDefined` object) fieldsDef + *> traverse (`validateField` fieldsDef) object + _ -> + traverse_ (`selectKnown` fieldsDef) object + *> validateObjectWithDefaultValue object fieldsDef + +validateField :: + ( InputConstraints ctx + ) => + ObjectEntry RESOLVED -> + FieldsDefinition IN -> + InputValidator ctx (ObjectEntry VALID) +validateField entry parentFields = do + field <- selectKnown entry parentFields + validateInputField field entry + +validateObjectWithDefaultValue :: + (InputConstraints c) => + Object RESOLVED -> + FieldsDefinition IN -> + Validator (InputContext c) (Object VALID) +validateObjectWithDefaultValue object fieldsDef = + traverse (validateFieldWithDefaultValue object) (elems fieldsDef) + >>= fromElems + +validateFieldWithDefaultValue :: + (InputConstraints c) => + Object RESOLVED -> + FieldDefinition IN -> + Validator (InputContext c) (ObjectEntry VALID) +validateFieldWithDefaultValue object fieldDef@FieldDefinition {fieldName} = do + entry <- selectWithDefaultValue (ObjectEntry fieldName) fieldDef object + validateInputField fieldDef entry + +validateInputField :: + (InputConstraints c) => + FieldDefinition IN -> + ObjectEntry RESOLVED -> + Validator (InputContext c) (ObjectEntry VALID) +validateInputField fieldDef@FieldDefinition {fieldName, fieldType = TypeRef {typeConName, typeWrappers}} entry = do + inputTypeDef <- askInputFieldType fieldDef + withInputScope (Prop fieldName typeConName) $ + ObjectEntry fieldName + <$> validateInput + typeWrappers + inputTypeDef + entry + +requiredFieldIsDefined :: + ( MissingRequired (Object RESOLVED) (InputContext ctx), + GetWith ctx Scope + ) => + FieldDefinition IN -> + Object RESOLVED -> + InputValidator ctx (ObjectEntry RESOLVED) +requiredFieldIsDefined fieldDef@FieldDefinition {fieldName} = + selectWithDefaultValue (ObjectEntry fieldName) fieldDef + +-- Leaf Validations validateScalar :: + forall m. + (Monad m) => TypeName -> ScalarDefinition -> ResolvedValue -> - (Maybe Message -> ResolvedValue -> InputValidator ValidValue) -> - InputValidator ValidValue + (Maybe Message -> ResolvedValue -> m ValidValue) -> + m ValidValue validateScalar typeName ScalarDefinition {validateValue} value err = do scalarValue <- toScalar value case validateValue scalarValue of @@ -186,16 +305,20 @@ Left "" -> err Nothing value Left message -> err (Just $ msg message) value where - toScalar :: ResolvedValue -> InputValidator ValidValue + toScalar :: ResolvedValue -> m ValidValue toScalar (Scalar x) | isValidDefault typeName x = pure (Scalar x) toScalar _ = err Nothing value isValidDefault :: TypeName -> ScalarValue -> Bool isValidDefault "Boolean" = isBoolean isValidDefault "String" = isString - isValidDefault "Float" = \x -> isFloat x || isInt x + isValidDefault "Float" = oneOf [isFloat, isInt] isValidDefault "Int" = isInt + isValidDefault "ID" = oneOf [isInt, isFloat, isString] isValidDefault _ = const True +oneOf :: [a -> Bool] -> a -> Bool +oneOf ls v = any (v &) ls + isBoolean :: ScalarValue -> Bool isBoolean Boolean {} = True isBoolean _ = False @@ -212,11 +335,27 @@ isInt Int {} = True isInt _ = False +isVariableValue :: (MonadContext m c, GetWith c InputSource) => m c Bool +isVariableValue = + \case + SourceVariable {isDefaultValue} -> not isDefaultValue + _ -> False + <$> inputValueSource + validateEnum :: - (ResolvedValue -> InputValidator ValidValue) -> + (MonadContext m c, GetWith c InputSource) => + (ResolvedValue -> m c ValidValue) -> [DataEnumValue] -> ResolvedValue -> - InputValidator ValidValue + m c ValidValue +validateEnum err enumValues value@(Scalar (String enumValue)) + | TypeName enumValue `elem` tags = do + isFromVariable <- isVariableValue + if isFromVariable + then pure (Enum (TypeName enumValue)) + else err value + where + tags = map enumName enumValues validateEnum err enumValues value@(Enum enumValue) | enumValue `elem` tags = pure (Enum enumValue) | otherwise = err value diff --git a/src/Data/Morpheus/Validation/Query/Arguments.hs b/src/Data/Morpheus/Validation/Query/Arguments.hs --- a/src/Data/Morpheus/Validation/Query/Arguments.hs +++ b/src/Data/Morpheus/Validation/Query/Arguments.hs @@ -30,19 +30,20 @@ TypeRef (..), VALID, Value (..), + fieldContentArgs, ) import Data.Morpheus.Types.Internal.Validation ( InputSource (..), - SelectionContext (..), + Scope (..), SelectionValidator, - askContext, askInputFieldType, - askScopePosition, + askVariables, + asks, selectKnown, selectRequired, selectWithDefaultValue, startInput, - withScopePosition, + withPosition, ) import Data.Morpheus.Validation.Internal.Value ( validateInput, @@ -62,7 +63,7 @@ resolve (List x) = List <$> traverse resolve x resolve (Object obj) = Object <$> traverse resolveEntry obj resolve (VariableValue ref) = - variables <$> askContext + askVariables >>= fmap (ResolvedVariable ref) . selectRequired ref @@ -88,10 +89,10 @@ fieldType = TypeRef {typeWrappers} } = do - argumentPosition <- askScopePosition + argumentPosition <- asks position argument <- selectWithDefaultValue - Argument {argumentName = fieldName, argumentValue = Null, argumentPosition} + (\argumentValue -> Argument {argumentName = fieldName, argumentValue, argumentPosition}) argumentDef requestArgs validateArgumentValue argument @@ -99,7 +100,7 @@ ------------------------------------------------------------------------- validateArgumentValue :: Argument RESOLVED -> SelectionValidator (Argument VALID) validateArgumentValue arg@Argument {argumentValue = value, ..} = - withScopePosition argumentPosition + withPosition argumentPosition $ startInput (SourceArgument arg) $ do datatype <- askInputFieldType argumentDef @@ -115,16 +116,14 @@ Arguments RAW -> SelectionValidator (Arguments VALID) validateFieldArguments - fieldDef@FieldDefinition {fieldArgs} + fieldDef@FieldDefinition {fieldContent} rawArgs = do args <- resolveArgumentVariables rawArgs traverse_ checkUnknown (elems args) traverse (validateArgument args) argsDef where - argsDef = case fieldArgs of - (ArgumentsDefinition _ argsD) -> argsD - NoArguments -> empty + argsDef = maybe empty fieldContentArgs fieldContent ------------------------------------------------- checkUnknown :: Argument RESOLVED -> SelectionValidator ArgumentDefinition checkUnknown = (`selectKnown` fieldDef) @@ -134,16 +133,15 @@ Arguments RAW -> SelectionValidator (Arguments VALID) validateDirectiveArguments - directiveDef@DirectiveDefinition {directiveDefinitionArgs} + directiveDef@DirectiveDefinition + { directiveDefinitionArgs = ArgumentsDefinition _ argsDef + } rawArgs = do args <- resolveArgumentVariables rawArgs traverse_ checkUnknown (elems args) traverse (validateArgument args) argsDef where - argsDef = case directiveDefinitionArgs of - (ArgumentsDefinition _ argsD) -> argsD - NoArguments -> empty ------------------------------------------------- checkUnknown :: Argument RESOLVED -> SelectionValidator ArgumentDefinition checkUnknown = (`selectKnown` directiveDef) diff --git a/src/Data/Morpheus/Validation/Query/Fragment.hs b/src/Data/Morpheus/Validation/Query/Fragment.hs --- a/src/Data/Morpheus/Validation/Query/Fragment.hs +++ b/src/Data/Morpheus/Validation/Query/Fragment.hs @@ -37,6 +37,7 @@ import Data.Morpheus.Types.Internal.Validation ( BaseValidator, Constraint (..), + OperationContext, Validator, askFragments, askSchema, @@ -65,7 +66,7 @@ | fragmentType `elem` typeMembers = pure fragment | otherwise = failure $ cannotBeSpreadOnType key fragmentType position typeMembers -resolveSpread :: [TypeName] -> Ref -> Validator ctx Fragment +resolveSpread :: [TypeName] -> Ref -> Validator (OperationContext v) Fragment resolveSpread allowedTargets ref@Ref {refName, refPosition} = askFragments >>= selectKnown ref diff --git a/src/Data/Morpheus/Validation/Query/UnionSelection.hs b/src/Data/Morpheus/Validation/Query/UnionSelection.hs --- a/src/Data/Morpheus/Validation/Query/UnionSelection.hs +++ b/src/Data/Morpheus/Validation/Query/UnionSelection.hs @@ -35,6 +35,7 @@ SelectionSet, SelectionSet, TypeName, + UnionMember (..), UnionTag (..), VALID, ) @@ -42,9 +43,10 @@ ( join, ) import Data.Morpheus.Types.Internal.Validation - ( SelectionValidator, - askScopeTypeName, + ( Scope (..), + SelectionValidator, askTypeMember, + asks, ) import Data.Morpheus.Validation.Query.Fragment ( castFragmentType, @@ -55,7 +57,7 @@ -- returns all Fragments used in Union exploreUnionFragments :: - [TypeName] -> + [UnionMember OUT] -> Selection RAW -> SelectionValidator [Fragment] exploreUnionFragments unionTags = splitFrag @@ -63,14 +65,14 @@ packFragment fragment = [fragment] splitFrag :: Selection RAW -> SelectionValidator [Fragment] - splitFrag (Spread _ ref) = packFragment <$> resolveSpread unionTags ref + splitFrag (Spread _ ref) = packFragment <$> resolveSpread (map memberName unionTags) ref splitFrag Selection {selectionName = "__typename", selectionContent = SelectionField} = pure [] splitFrag Selection {selectionName, selectionPosition} = do - typeName <- askScopeTypeName + typeName <- asks typename failure $ unknownSelectionField typeName (Ref selectionName selectionPosition) splitFrag (InlineFragment fragment) = packFragment - <$> castFragmentType Nothing (fragmentPosition fragment) unionTags fragment + <$> castFragmentType Nothing (fragmentPosition fragment) (map memberName unionTags) fragment -- sorts Fragment by contitional Types -- [ diff --git a/src/Data/Morpheus/Validation/Query/Validation.hs b/src/Data/Morpheus/Validation/Query/Validation.hs --- a/src/Data/Morpheus/Validation/Query/Validation.hs +++ b/src/Data/Morpheus/Validation/Query/Validation.hs @@ -22,9 +22,10 @@ ( Eventless, ) import Data.Morpheus.Types.Internal.Validation - ( Context (..), + ( CurrentSelection (..), + OperationContext (..), + Scope (..), ScopeKind (..), - SelectionContext (..), runValidator, ) import Data.Morpheus.Validation.Query.Fragment @@ -56,23 +57,16 @@ } } = do - variables <- runValidator validateHelpers ctx () - runValidator - (validateOperation operation) - ctx - SelectionContext - { variables - } + variables <- runValidator validateHelpers (ctx ()) + runValidator (validateOperation operation) (ctx variables) where - ctx = - Context + ctx variables = + OperationContext { schema, fragments, - scopeTypeName = "Root", - scopeSelectionName = "Root", - scopePosition = operationPosition, - operationName, - scopeKind = SELECTION + scope = Scope {typename = "Root", position = operationPosition, kind = SELECTION}, + selection = CurrentSelection {operationName, selectionName = "Root"}, + variables } validateHelpers = validateFragments operationSelection diff --git a/src/Data/Morpheus/Validation/Query/Variable.hs b/src/Data/Morpheus/Validation/Query/Variable.hs --- a/src/Data/Morpheus/Validation/Query/Variable.hs +++ b/src/Data/Morpheus/Validation/Query/Variable.hs @@ -56,7 +56,7 @@ constraint, selectKnown, startInput, - withScopePosition, + withPosition, ) import Data.Morpheus.Validation.Internal.Value ( validateInput, @@ -138,7 +138,7 @@ variablePosition, variableValue = DefaultValue defaultValue } = - withScopePosition variablePosition $ + withPosition variablePosition $ toVariable <$> ( askSchema >>= selectKnown (TypeNameRef (typeConName variableType) variablePosition) @@ -156,10 +156,10 @@ DefaultValue -> TypeDefinition IN -> BaseValidator ValidValue - checkType (Just variable) Nothing varType = validator varType variable + checkType (Just variable) Nothing varType = validator varType False variable checkType (Just variable) (Just defValue) varType = - validator varType defValue >> validator varType variable - checkType Nothing (Just defValue) varType = validator varType defValue + validator varType True defValue >> validator varType False variable + checkType Nothing (Just defValue) varType = validator varType True defValue checkType Nothing Nothing varType | validationMode /= WITHOUT_VARIABLES && not (isNullable variableType) = failure $ uninitializedVariable var @@ -167,11 +167,11 @@ returnNull where returnNull = - maybe (pure Null) (validator varType) (M.lookup variableName bodyVariables) + maybe (pure Null) (validator varType False) (M.lookup variableName bodyVariables) ----------------------------------------------------------------------------------------------- - validator :: TypeDefinition IN -> ResolvedValue -> BaseValidator ValidValue - validator varType varValue = - startInput (SourceVariable var) $ + validator :: TypeDefinition IN -> Bool -> ResolvedValue -> BaseValidator ValidValue + validator varType isDefaultValue varValue = + startInput (SourceVariable var isDefaultValue) $ validateInput (typeWrappers variableType) varType diff --git a/test/Lib.hs b/test/Lib.hs --- a/test/Lib.hs +++ b/test/Lib.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Lib ( getGQLBody, @@ -6,6 +7,10 @@ getCases, maybeVariables, readSource, + scanSchemaTests, + FileUrl (..), + CaseTree (..), + toString, ) where @@ -15,7 +20,9 @@ import Data.ByteString.Lazy.Char8 (ByteString) import Data.Maybe (fromMaybe) import Data.Morpheus.Types.Internal.AST (FieldName (..)) +import Data.Semigroup ((<>)) import Data.Text (Text, unpack) +import System.Directory (doesDirectoryExist, listDirectory) readSource :: FieldName -> IO ByteString readSource = L.readFile . path . readName @@ -28,6 +35,52 @@ resLib :: Text -> String resLib x = path x ++ "/response.json" + +data FileUrl = FileUrl + { filePath :: [FilePath], + fileName :: FilePath + } + deriving (Show) + +data CaseTree = CaseTree + { caseUrl :: FileUrl, + children :: Either [String] [CaseTree] + } + deriving (Show) + +prefix :: FileUrl -> FilePath -> FileUrl +prefix FileUrl {..} x = + FileUrl + { filePath = fileName : filePath, + fileName = x + } + +toString :: FileUrl -> FilePath +toString FileUrl {..} = foldl (\y x -> x <> "/" <> y) fileName filePath + +scanSchemaTests :: FilePath -> IO CaseTree +scanSchemaTests = deepScan + +deepScan :: FilePath -> IO CaseTree +deepScan = shouldScan . FileUrl [] + where + shouldScan :: FileUrl -> IO CaseTree + shouldScan caseUrl@FileUrl {..} = do + children <- prefixed caseUrl + pure CaseTree {..} + isDirectory :: FileUrl -> IO Bool + isDirectory = doesDirectoryExist . toString + prefixed :: FileUrl -> IO (Either [String] [CaseTree]) + prefixed p = do + dir <- isDirectory p + if dir + then do + list <- map (prefix p) <$> listDirectory (toString p) + areDirectories <- traverse isDirectory list + if and areDirectories + then Right <$> traverse shouldScan list + else pure $ Left [] + else pure $ Left [] maybeVariables :: FieldName -> IO (Maybe Value) maybeVariables (FieldName x) = decode <$> (L.readFile (path x ++ "/variables.json") <|> return "{}") diff --git a/test/Schema.hs b/test/Schema.hs --- a/test/Schema.hs +++ b/test/Schema.hs @@ -10,12 +10,13 @@ import Control.Monad ((<=<)) import Data.Aeson ((.:), (.=), FromJSON (..), ToJSON (..), Value (..), eitherDecode, encode, object) +import qualified Data.ByteString.Lazy as L (readFile) import qualified Data.ByteString.Lazy.Char8 as LB (unpack) +import Data.ByteString.Lazy.Char8 (ByteString) import Data.Either (either) import Data.Morpheus.Core (parseFullGQLDocument, validateSchema) import Data.Morpheus.Types.Internal.AST - ( FieldName, - GQLErrors, + ( GQLErrors, Schema, ) import Data.Morpheus.Types.Internal.Resolving @@ -25,16 +26,24 @@ import Data.Semigroup ((<>)) import Data.Text (pack) import GHC.Generics (Generic) -import Lib (readSource) +import Lib + ( CaseTree (..), + FileUrl (..), + scanSchemaTests, + toString, + ) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertFailure, testCase) -readSchema :: FieldName -> IO (Eventless Schema) -readSchema = fmap (validateSchema <=< parseFullGQLDocument) . readSource . ("schema/" <>) . (<> "/schema.gql") +readSource :: String -> IO ByteString +readSource = L.readFile -readResponse :: FieldName -> IO Response -readResponse = fmap (either AesonError id . eitherDecode) . readSource . ("schema/" <>) . (<> "/response.json") +readSchema :: String -> IO (Eventless Schema) +readSchema = fmap (validateSchema <=< parseFullGQLDocument) . readSource . (<> "/schema.gql") +readResponse :: String -> IO Response +readResponse = fmap (either AesonError id . eitherDecode) . readSource . (<> "/response.json") + data Response = OK | Errors {errors :: GQLErrors} @@ -52,23 +61,20 @@ toJSON (Errors err) = object ["errors" .= toJSON err] toJSON (AesonError err) = String (pack err) -testSchema :: TestTree -testSchema = +toTests :: CaseTree -> TestTree +toTests CaseTree {caseUrl, children = Left {}} = schemaCase caseUrl +toTests CaseTree {caseUrl = FileUrl {fileName}, children = Right children} = testGroup - "Test Schema" - [ testGroup - "Validation" - $ map - (uncurry schemaCase) - [ ("validation/interface/ok", "interface validation success"), - ("validation/interface/fail", "interface validation fails") - ] - ] + fileName + (map toTests children) -schemaCase :: FieldName -> String -> TestTree -schemaCase path description = testCase description $ do - schema <- readSchema path - expected <- readResponse path +testSchema :: IO TestTree +testSchema = toTests <$> scanSchemaTests "test/schema" + +schemaCase :: FileUrl -> TestTree +schemaCase url = testCase (fileName url) $ do + schema <- readSchema (toString url) + expected <- readResponse (toString url) assertion expected schema assertion :: Response -> Eventless Schema -> IO () diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -109,16 +109,17 @@ ] main :: IO () -main = +main = do + schema <- testSchema defaultMain $ testGroup "core tests" $ map (uncurry basicTest) - [ ("basic Test", "simple"), - ("test interface", "interface") + [ ("basic Test", "api/simple"), + ("test interface", "api/interface") ] - <> [testSchema] + <> [schema] basicTest :: String -> FieldName -> TestTree basicTest description path = testCase description $ do diff --git a/test/api/interface/query.gql b/test/api/interface/query.gql new file mode 100644 --- /dev/null +++ b/test/api/interface/query.gql @@ -0,0 +1,79 @@ +query Get__Type { + interface: __type(name: "Character") { + ...FullType + } + deity: __type(name: "Deity") { + ...FullType + } +} + +fragment FullType on __Type { + kind + name + fields(includeDeprecated: true) { + name + args { + ...InputValue + } + type { + ...TypeRef + } + isDeprecated + deprecationReason + } + inputFields { + ...InputValue + } + interfaces { + ...TypeRef + } + enumValues(includeDeprecated: true) { + name + isDeprecated + deprecationReason + } + possibleTypes { + ...TypeRef + } +} + +fragment InputValue on __InputValue { + name + type { + ...TypeRef + } + defaultValue +} + +fragment TypeRef on __Type { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + } + } + } + } + } + } + } +} diff --git a/test/api/interface/response.json b/test/api/interface/response.json new file mode 100644 --- /dev/null +++ b/test/api/interface/response.json @@ -0,0 +1,65 @@ +{ + "interface": { + "kind": "INTERFACE", + "name": "Character", + "fields": [ + { + "name": "name", + "args": [], + "type": { "kind": "SCALAR", "name": "String", "ofType": null }, + "isDeprecated": false, + "deprecationReason": null + } + ], + "inputFields": null, + "interfaces": null, + "enumValues": null, + "possibleTypes": [ + { "kind": "OBJECT", "name": "Deity", "ofType": null }, + { "kind": "OBJECT", "name": "Hero", "ofType": null } + ] + }, + "deity": { + "kind": "OBJECT", + "name": "Deity", + "fields": [ + { + "name": "name", + "args": [], + "type": { + "kind": "NON_NULL", + "name": null, + "ofType": { "kind": "SCALAR", "name": "String", "ofType": null } + }, + "isDeprecated": false, + "deprecationReason": null + }, + { + "name": "power", + "args": [], + "type": { + "kind": "NON_NULL", + "name": null, + "ofType": { + "kind": "LIST", + "name": null, + "ofType": { + "kind": "NON_NULL", + "name": null, + "ofType": { "kind": "SCALAR", "name": "String", "ofType": null } + } + } + }, + "isDeprecated": false, + "deprecationReason": null + } + ], + "inputFields": null, + "interfaces": [ + { "kind": "INTERFACE", "name": "Character", "ofType": null }, + { "kind": "INTERFACE", "name": "Supernatural", "ofType": null } + ], + "enumValues": null, + "possibleTypes": null + } +} diff --git a/test/api/simple/query.gql b/test/api/simple/query.gql new file mode 100644 --- /dev/null +++ b/test/api/simple/query.gql @@ -0,0 +1,6 @@ +{ + deity { + name + power + } +} diff --git a/test/api/simple/response.json b/test/api/simple/response.json new file mode 100644 --- /dev/null +++ b/test/api/simple/response.json @@ -0,0 +1,6 @@ +{ + "deity": { + "name": "Morpheus", + "power": ["Shapeshifting"] + } +} diff --git a/test/interface/query.gql b/test/interface/query.gql deleted file mode 100644 --- a/test/interface/query.gql +++ /dev/null @@ -1,79 +0,0 @@ -query Get__Type { - interface: __type(name: "Character") { - ...FullType - } - deity: __type(name: "Deity") { - ...FullType - } -} - -fragment FullType on __Type { - kind - name - fields(includeDeprecated: true) { - name - args { - ...InputValue - } - type { - ...TypeRef - } - isDeprecated - deprecationReason - } - inputFields { - ...InputValue - } - interfaces { - ...TypeRef - } - enumValues(includeDeprecated: true) { - name - isDeprecated - deprecationReason - } - possibleTypes { - ...TypeRef - } -} - -fragment InputValue on __InputValue { - name - type { - ...TypeRef - } - defaultValue -} - -fragment TypeRef on __Type { - kind - name - ofType { - kind - name - ofType { - kind - name - ofType { - kind - name - ofType { - kind - name - ofType { - kind - name - ofType { - kind - name - ofType { - kind - name - } - } - } - } - } - } - } -} diff --git a/test/interface/response.json b/test/interface/response.json deleted file mode 100644 --- a/test/interface/response.json +++ /dev/null @@ -1,65 +0,0 @@ -{ - "interface": { - "kind": "INTERFACE", - "name": "Character", - "fields": [ - { - "name": "name", - "args": [], - "type": { "kind": "SCALAR", "name": "String", "ofType": null }, - "isDeprecated": false, - "deprecationReason": null - } - ], - "inputFields": null, - "interfaces": null, - "enumValues": null, - "possibleTypes": [ - { "kind": "OBJECT", "name": "Deity", "ofType": null }, - { "kind": "OBJECT", "name": "Hero", "ofType": null } - ] - }, - "deity": { - "kind": "OBJECT", - "name": "Deity", - "fields": [ - { - "name": "name", - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { "kind": "SCALAR", "name": "String", "ofType": null } - }, - "isDeprecated": false, - "deprecationReason": null - }, - { - "name": "power", - "args": [], - "type": { - "kind": "NON_NULL", - "name": null, - "ofType": { - "kind": "LIST", - "name": null, - "ofType": { - "kind": "NON_NULL", - "name": null, - "ofType": { "kind": "SCALAR", "name": "String", "ofType": null } - } - } - }, - "isDeprecated": false, - "deprecationReason": null - } - ], - "inputFields": null, - "interfaces": [ - { "kind": "INTERFACE", "name": "Character", "ofType": null }, - { "kind": "INTERFACE", "name": "Supernatural", "ofType": null } - ], - "enumValues": null, - "possibleTypes": null - } -} diff --git a/test/schema/validation/default-value/argument/compound-ok/response.json b/test/schema/validation/default-value/argument/compound-ok/response.json new file mode 100644 --- /dev/null +++ b/test/schema/validation/default-value/argument/compound-ok/response.json @@ -0,0 +1,1 @@ +"OK" diff --git a/test/schema/validation/default-value/argument/compound-ok/schema.gql b/test/schema/validation/default-value/argument/compound-ok/schema.gql new file mode 100644 --- /dev/null +++ b/test/schema/validation/default-value/argument/compound-ok/schema.gql @@ -0,0 +1,35 @@ +enum TestEnum { + EnumA + EnumB + EnumC +} + +input InputSimple { + fieldWithDefault: ID! = "value from fieldWithDefault" + simpleField: TestEnum +} + +input InputCompound { + inputField2: String! = "value from inputField2" + inputField3: [InputSimple]! = [ + { fieldWithDefault: "value2 from inputField3", simpleField: EnumA } + { simpleField: EnumA } + ] + inputField4: [InputSimple]! = [{ simpleField: EnumB }] +} + +type User { + inputs( + inputCompound: InputCompound! = { + inputField2: "value from argument inputCompound" + } + input: InputSimple + comment: String = "test string" + input3: InputSimple! + i3: Int + ): String! +} + +type Query { + user: User +} diff --git a/test/schema/validation/default-value/argument/missing-field/response.json b/test/schema/validation/default-value/argument/missing-field/response.json new file mode 100644 --- /dev/null +++ b/test/schema/validation/default-value/argument/missing-field/response.json @@ -0,0 +1,24 @@ +{ + "errors": [ + { + "message": "Field Query.field(i1:) got invalid default value. in field \"field\": Undefined Field \"field\".", + "locations": [] + }, + { + "message": "Field Query.field(i1:) got invalid default value. in field \"field\": Undefined Field \"field2\".", + "locations": [] + }, + { + "message": "Field Query.field(i2:) got invalid default value. Undefined Field \"field\".", + "locations": [] + }, + { + "message": "Field Query.field(i3:) got invalid default value. in field \"field\": Undefined Field \"field2\".", + "locations": [] + }, + { + "message": "Field Query.field(i3:) got invalid default value. in field \"field.field\": Undefined Field \"field\".", + "locations": [] + } + ] +} diff --git a/test/schema/validation/default-value/argument/missing-field/schema.gql b/test/schema/validation/default-value/argument/missing-field/schema.gql new file mode 100644 --- /dev/null +++ b/test/schema/validation/default-value/argument/missing-field/schema.gql @@ -0,0 +1,22 @@ +input Input1 { + field: Int! +} + +input Input2 { + field: Input1! + field2: Int! + field3: Int + field4: Int! = 123 +} + +input Input3 { + field: Input2! +} + +type Query { + field( + i1: Input3 = { field: {} } + i2: Input3 = {} + i3: Input3 = { field: { field: {} } } + ): Int +} diff --git a/test/schema/validation/default-value/argument/unexpected-value/response.json b/test/schema/validation/default-value/argument/unexpected-value/response.json new file mode 100644 --- /dev/null +++ b/test/schema/validation/default-value/argument/unexpected-value/response.json @@ -0,0 +1,32 @@ +{ + "errors": [ + { + "message": "Field Query.field(i1:) got invalid default value. in field \"field1.field2\": Expected type \"String\" found 1.", + "locations": [{ "line": 0, "column": 0 }] + }, + { + "message": "Field Query.field(i1:) got invalid default value. in field \"field2\": Expected type \"String\" found true.", + "locations": [{ "line": 0, "column": 0 }] + }, + { + "message": "Field Query.field(i2:) got invalid default value. in field \"field1\": Expected type \"ID\" found {field3: 2344}.", + "locations": [{ "line": 0, "column": 0 }] + }, + { + "message": "Field Query.field(i2:) got invalid default value. in field \"field2\": Expected type \"String\" found 123.", + "locations": [{ "line": 0, "column": 0 }] + }, + { + "message": "Field Query.field(i3:) got invalid default value. Expected type \"TestEnum\" found EnumBB.", + "locations": [{ "line": 0, "column": 0 }] + }, + { + "message": "Field Query.field(i4:) got invalid default value. Expected type \"ID\" found true.", + "locations": [{ "line": 0, "column": 0 }] + }, + { + "message": "Field Query.field(i5:) got invalid default value. Expected type \"Int\" found \"some text\".", + "locations": [{ "line": 0, "column": 0 }] + } + ] +} diff --git a/test/schema/validation/default-value/argument/unexpected-value/schema.gql b/test/schema/validation/default-value/argument/unexpected-value/schema.gql new file mode 100644 --- /dev/null +++ b/test/schema/validation/default-value/argument/unexpected-value/schema.gql @@ -0,0 +1,25 @@ +enum TestEnum { + EnumA + EnumB +} + +input Input1 { + field1: ID = 1 + field2: String = "some text" + field3: TestEnum = EnumB +} + +input Input2 { + field1: Input1 + field2: String +} + +type Query { + field( + i1: Input2 = { field1: { field2: 1 }, field2: true } + i2: Input1 = { field1: { field3: 2344 }, field2: 123 } + i3: TestEnum = EnumBB + i4: ID = true + i5: Int = "some text" + ): Int +} diff --git a/test/schema/validation/default-value/argument/unknown-field/response.json b/test/schema/validation/default-value/argument/unknown-field/response.json new file mode 100644 --- /dev/null +++ b/test/schema/validation/default-value/argument/unknown-field/response.json @@ -0,0 +1,16 @@ +{ + "errors": [ + { + "message": "Field Query.field(i1:) got invalid default value. in field \"field.field\": Unknown Field \"field3\".", + "locations": [] + }, + { + "message": "Field Query.field(i1:) got invalid default value. in field \"field\": Unknown Field \"field2\".", + "locations": [] + }, + { + "message": "Field Query.field(i1:) got invalid default value. Unknown Field \"field2\".", + "locations": [] + } + ] +} diff --git a/test/schema/validation/default-value/argument/unknown-field/schema.gql b/test/schema/validation/default-value/argument/unknown-field/schema.gql new file mode 100644 --- /dev/null +++ b/test/schema/validation/default-value/argument/unknown-field/schema.gql @@ -0,0 +1,20 @@ +input Input1 { + field: Int = 123 +} + +input Input2 { + field: Input1 = {} +} + +input Input3 { + field: Input2 = {} +} + +type Query { + field( + i1: Input3 = { + field: { field2: null, field: { field3: null } } + field2: null + } + ): Int +} diff --git a/test/schema/validation/default-value/field/compound-ok/response.json b/test/schema/validation/default-value/field/compound-ok/response.json new file mode 100644 --- /dev/null +++ b/test/schema/validation/default-value/field/compound-ok/response.json @@ -0,0 +1,1 @@ +"OK" diff --git a/test/schema/validation/default-value/field/compound-ok/schema.gql b/test/schema/validation/default-value/field/compound-ok/schema.gql new file mode 100644 --- /dev/null +++ b/test/schema/validation/default-value/field/compound-ok/schema.gql @@ -0,0 +1,23 @@ +enum TestEnum { + EnumA + EnumB + EnumC +} + +input InputSimple { + fieldWithDefault: ID! = "value from fieldWithDefault" + simpleField: TestEnum +} + +input InputCompound { + inputField2: String! = "value from inputField2" + inputField3: [InputSimple]! = [ + { fieldWithDefault: "value2 from inputField3", simpleField: EnumA } + { simpleField: EnumA } + ] + inputField4: [InputSimple]! = [{ simpleField: EnumB }] +} + +type Query { + field: String! +} diff --git a/test/schema/validation/default-value/field/missing-field/response.json b/test/schema/validation/default-value/field/missing-field/response.json new file mode 100644 --- /dev/null +++ b/test/schema/validation/default-value/field/missing-field/response.json @@ -0,0 +1,12 @@ +{ + "errors": [ + { + "message": "Field Input3.field1 got invalid default value. Undefined Field \"field2\".", + "locations": [] + }, + { + "message": "Field Input3.field1 got invalid default value. in field \"field\": Undefined Field \"field\".", + "locations": [] + } + ] +} diff --git a/test/schema/validation/default-value/field/missing-field/schema.gql b/test/schema/validation/default-value/field/missing-field/schema.gql new file mode 100644 --- /dev/null +++ b/test/schema/validation/default-value/field/missing-field/schema.gql @@ -0,0 +1,18 @@ +input Input1 { + field: Int! +} + +input Input2 { + field: Input1! + field2: Int! + field3: Int + field4: Int! = 123 +} + +input Input3 { + field1: Input2! = { field: {} } +} + +type Query { + field: Int +} diff --git a/test/schema/validation/default-value/field/unexpected-value/response.json b/test/schema/validation/default-value/field/unexpected-value/response.json new file mode 100644 --- /dev/null +++ b/test/schema/validation/default-value/field/unexpected-value/response.json @@ -0,0 +1,36 @@ +{ + "errors": [ + { + "message": "Field Input2.objectField got invalid default value. in field \"field1\": Expected type \"ID!\" found true.", + "locations": [{ "line": 0, "column": 0 }] + }, + { + "message": "Field Input2.objectField got invalid default value. in field \"field2\": Expected type \"String!\" found true.", + "locations": [{ "line": 0, "column": 0 }] + }, + { + "message": "Field Input2.objectField got invalid default value. in field \"field3\": Expected type \"TestEnum\" found true.", + "locations": [{ "line": 0, "column": 0 }] + }, + { + "message": "Field Input1.field1 got invalid default value. Expected type \"ID!\" found EnumA.", + "locations": [{ "line": 0, "column": 0 }] + }, + { + "message": "Field Input1.field2 got invalid default value. Expected type \"String!\" found EnumA.", + "locations": [{ "line": 0, "column": 0 }] + }, + { + "message": "Field Input1.field3 got invalid default value. Expected type \"TestEnum\" found UnknownEnum.", + "locations": [{ "line": 0, "column": 0 }] + }, + { + "message": "Field Input1.field4 got invalid default value. Expected type \"TestEnum!\" found 1.", + "locations": [{ "line": 0, "column": 0 }] + }, + { + "message": "Field Input1.field5 got invalid default value. Expected type \"TestEnum\" found \"some text\".", + "locations": [{ "line": 0, "column": 0 }] + } + ] +} diff --git a/test/schema/validation/default-value/field/unexpected-value/schema.gql b/test/schema/validation/default-value/field/unexpected-value/schema.gql new file mode 100644 --- /dev/null +++ b/test/schema/validation/default-value/field/unexpected-value/schema.gql @@ -0,0 +1,22 @@ +enum TestEnum { + EnumA + EnumB + EnumC +} + +input Input1 { + field1: ID! = EnumA + field2: String! = EnumA + field3: TestEnum = UnknownEnum + field4: TestEnum! = 1 + field5: TestEnum = "some text" +} + +input Input2 { + objectField: Input1 = { field1: true, field2: true, field3: true } + fieldString: String +} + +type Query { + field: Int +} diff --git a/test/schema/validation/default-value/field/unknown-field/response.json b/test/schema/validation/default-value/field/unknown-field/response.json new file mode 100644 --- /dev/null +++ b/test/schema/validation/default-value/field/unknown-field/response.json @@ -0,0 +1,16 @@ +{ + "errors": [ + { + "message": "Field Input3.field got invalid default value. in field \"field\": Unknown Field \"field2\".", + "locations": [] + }, + { + "message": "Field Input3.field got invalid default value. in field \"field\": Unknown Field \"field3\".", + "locations": [] + }, + { + "message": "Field Input3.field got invalid default value. Unknown Field \"field2\".", + "locations": [] + } + ] +} diff --git a/test/schema/validation/default-value/field/unknown-field/schema.gql b/test/schema/validation/default-value/field/unknown-field/schema.gql new file mode 100644 --- /dev/null +++ b/test/schema/validation/default-value/field/unknown-field/schema.gql @@ -0,0 +1,18 @@ +input Input1 { + field: Int +} + +input Input2 { + field: Input1 +} + +input Input3 { + field: Input2 = { + field: { field: null, field2: null, field3: null } + field2: null + } +} + +type Query { + field: Int +} diff --git a/test/schema/validation/interface/fail/response.json b/test/schema/validation/interface/fail/response.json deleted file mode 100644 --- a/test/schema/validation/interface/fail/response.json +++ /dev/null @@ -1,16 +0,0 @@ -{ - "errors": [ - { - "message": "type \"Deity\" implements Interface \"Character\" Partially, on key \"name\" expected type \"String\" found \"Int\".", - "locations": [] - }, - { - "message": "type \"Deity\" implements Interface \"Supernatural\" Partially, on key \"power\" expected type \"[String!]!\" found \"[String!]\".", - "locations": [] - }, - { - "message": "type \"Hero\" implements Interface \"Character\" Partially, key \"name\" not found .", - "locations": [] - } - ] -} diff --git a/test/schema/validation/interface/fail/schema.gql b/test/schema/validation/interface/fail/schema.gql deleted file mode 100644 --- a/test/schema/validation/interface/fail/schema.gql +++ /dev/null @@ -1,33 +0,0 @@ -type Query { - deity(name: String): Deity! -} - -interface Character { - name: String -} - -interface Supernatural { - power: [String!]! -} - -type Hero implements Character { - field: String -} - -type Deity implements Character & Supernatural { - name: Int - power: [String!] -} - -# TODO: validate arguments -# interface Aged { -# age(num: Int): String! -# } - -# type Human implements Aged { -# age(num: Int!): String -# } - -# type God implements Aged { -# age(date: String!): String -# } diff --git a/test/schema/validation/interface/field-args/fail/response.json b/test/schema/validation/interface/field-args/fail/response.json new file mode 100644 --- /dev/null +++ b/test/schema/validation/interface/field-args/fail/response.json @@ -0,0 +1,16 @@ +{ + "errors": [ + { + "message": "Interface field argument Character.name(id:) expected but Deity.name does not provide it.", + "locations": [] + }, + { + "message": "Interface field argument Supernatural.power(id:) expects type\"ID!\" but Deity.power(id:) is type \"String!\".", + "locations": [] + }, + { + "message": "Interface field argument Supernatural.power(id:) expects type\"ID!\" but Hero.power(id:) is type \"ID\".", + "locations": [] + } + ] +} diff --git a/test/schema/validation/interface/field-args/fail/schema.gql b/test/schema/validation/interface/field-args/fail/schema.gql new file mode 100644 --- /dev/null +++ b/test/schema/validation/interface/field-args/fail/schema.gql @@ -0,0 +1,23 @@ +type Query { + deity(name: String): Deity! +} + +interface Character { + name(id: ID): String! +} + +interface Supernatural { + power(id: ID!): [String!]! +} + +type Deity implements Character & Supernatural { + # undefined args (id: String) + name: String! + # arg: id has different type + power(id: String!): [String!]! +} + +type Hero implements Supernatural { + # arg: id has weeker type + power(id: ID): String! +} diff --git a/test/schema/validation/interface/field-args/ok/response.json b/test/schema/validation/interface/field-args/ok/response.json new file mode 100644 --- /dev/null +++ b/test/schema/validation/interface/field-args/ok/response.json @@ -0,0 +1,1 @@ +"OK" diff --git a/test/schema/validation/interface/field-args/ok/schema.gql b/test/schema/validation/interface/field-args/ok/schema.gql new file mode 100644 --- /dev/null +++ b/test/schema/validation/interface/field-args/ok/schema.gql @@ -0,0 +1,18 @@ +type Query { + deity(name: String): Deity! +} + +interface Character { + name(id: ID): String! +} + +interface Supernatural { + power(id: ID!): [String!]! +} + +type Deity implements Character & Supernatural { + # arg id has stronger type + name(id: ID!): String! + # arg: has same type + power(id: ID!, age: Int!): [String!]! +} diff --git a/test/schema/validation/interface/field-type/fail/response.json b/test/schema/validation/interface/field-type/fail/response.json new file mode 100644 --- /dev/null +++ b/test/schema/validation/interface/field-type/fail/response.json @@ -0,0 +1,16 @@ +{ + "errors": [ + { + "message": "Interface field Character.name expects type \"String\" but Deity.name is type \"Int\".", + "locations": [] + }, + { + "message": "Interface field Supernatural.power expects type \"[String!]!\" but Deity.power is type \"[String!]\".", + "locations": [] + }, + { + "message": "Interface field Character.name expected but \"Hero\" does not provide it.", + "locations": [] + } + ] +} diff --git a/test/schema/validation/interface/field-type/fail/schema.gql b/test/schema/validation/interface/field-type/fail/schema.gql new file mode 100644 --- /dev/null +++ b/test/schema/validation/interface/field-type/fail/schema.gql @@ -0,0 +1,20 @@ +type Query { + deity(name: String): Deity! +} + +interface Character { + name: String +} + +interface Supernatural { + power: [String!]! +} + +type Hero implements Character { + field: String +} + +type Deity implements Character & Supernatural { + name: Int + power: [String!] +} diff --git a/test/schema/validation/interface/field-type/ok/response.json b/test/schema/validation/interface/field-type/ok/response.json new file mode 100644 --- /dev/null +++ b/test/schema/validation/interface/field-type/ok/response.json @@ -0,0 +1,1 @@ +"OK" diff --git a/test/schema/validation/interface/field-type/ok/schema.gql b/test/schema/validation/interface/field-type/ok/schema.gql new file mode 100644 --- /dev/null +++ b/test/schema/validation/interface/field-type/ok/schema.gql @@ -0,0 +1,20 @@ +type Query { + deity(name: String): Deity! +} + +interface Character { + name: String +} + +interface Supernatural { + power: [String!]! +} + +type Hero implements Character { + name: String +} + +type Deity implements Character & Supernatural { + name: String! + power: [String!]! +} diff --git a/test/schema/validation/interface/ok/response.json b/test/schema/validation/interface/ok/response.json deleted file mode 100644 --- a/test/schema/validation/interface/ok/response.json +++ /dev/null @@ -1,1 +0,0 @@ -"OK" diff --git a/test/schema/validation/interface/ok/schema.gql b/test/schema/validation/interface/ok/schema.gql deleted file mode 100644 --- a/test/schema/validation/interface/ok/schema.gql +++ /dev/null @@ -1,20 +0,0 @@ -type Query { - deity(name: String): Deity! -} - -interface Character { - name: String -} - -interface Supernatural { - power: [String!]! -} - -type Hero implements Character { - name: String -} - -type Deity implements Character & Supernatural { - name: String! - power: [String!]! -} diff --git a/test/simple/query.gql b/test/simple/query.gql deleted file mode 100644 --- a/test/simple/query.gql +++ /dev/null @@ -1,6 +0,0 @@ -{ - deity { - name - power - } -} diff --git a/test/simple/response.json b/test/simple/response.json deleted file mode 100644 --- a/test/simple/response.json +++ /dev/null @@ -1,6 +0,0 @@ -{ - "deity": { - "name": "Morpheus", - "power": ["Shapeshifting"] - } -}