diff --git a/CHANGELOG.rst b/CHANGELOG.rst new file mode 100644 --- /dev/null +++ b/CHANGELOG.rst @@ -0,0 +1,49 @@ +===================== +graphql-api changelog +===================== + +0.3.0 (2018-02-08) +================== + +Breaking changes +---------------- + +* ``Enum`` handlers are now monadic (see `#118`_) +* You must use protolude 0.2.1 or later +* ``Defaultable`` must now be imported from ``GraphQL.API``, rather than ``GraphQL.Resolver``, + this moves ``GraphQL.API`` closer to being sufficient for API definition. (see `#149`_) + +Improvements +------------ + +* Now support GHC 8.2 as well as 8.0.2 and later +* Added support for anonymous queries (thanks `@sunwukonga`_) + +.. _`#118`: https://github.com/jml/graphql-api/issues/118 +.. _`#149`: https://github.com/haskell-graphql/graphql-api/issues/149 +.. _`@sunwukonga`: https://github.com/sunwukonga + +v0.2.0 (2017-10-12) +=================== + +* Make ``Name`` an overloaded string that panics if an invalid name is + provided. +* Correctly descend into the type parameter of a ``Maybe``. See https://github.com/jml/graphql-api/issues/119. + This is a backwards-incompatible change. + + A common update would be having to ``fmap pure callback`` instead of just ``callback`` + for ``Maybe`` handlers. + + +v0.1.0 (2017-01-30) +=================== + +No code changes. + +* Remove ``-Werror`` in order to upload to hackage + + +v0.1.0 (2017-01-29) +=================== + +Initial release, support basic handling of GraphQL queries. diff --git a/graphql-api.cabal b/graphql-api.cabal --- a/graphql-api.cabal +++ b/graphql-api.cabal @@ -1,23 +1,35 @@ --- This file has been generated from package.yaml by hpack version 0.17.0. +-- This file has been generated from package.yaml by hpack version 0.20.0. -- -- see: https://github.com/sol/hpack +-- +-- hash: 2160ff0226a0b10f7166ddbcf09ec6f79dfddfd66c81244898fb1afabe36bcf8 name: graphql-api -version: 0.2.0 -synopsis: Sketch of GraphQL stuff -description: Please see README.md +version: 0.3.0 +synopsis: GraphQL API +description: Implement [GraphQL](http://graphql.org/) servers in Haskell. + . + Provides a Servant-like type-based API for defining GraphQL schemas and + implementing handlers for those schemas. + . + See [README.md](https://github.com/haskell-graphql/graphql-api#graphql-api) for more details. category: Web -homepage: https://github.com/jml/graphql-api#readme -bug-reports: https://github.com/jml/graphql-api/issues -maintainer: Jonathan M. Lange +stability: unstable +homepage: https://github.com/haskell-graphql/graphql-api#readme +bug-reports: https://github.com/haskell-graphql/graphql-api/issues +author: Jonathan M. Lange, Tom Hunger +maintainer: Jonathan M. Lange , Tom Hunger license: Apache license-file: LICENSE.Apache-2.0 build-type: Simple cabal-version: >= 1.10 +extra-source-files: + CHANGELOG.rst + source-repository head type: git - location: https://github.com/jml/graphql-api + location: https://github.com/haskell-graphql/graphql-api library hs-source-dirs: @@ -25,17 +37,17 @@ default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications ghc-options: -Wall -fno-warn-redundant-constraints build-depends: - base >= 4.9 && < 5 - , protolude >= 0.2 - , exceptions - , transformers - , attoparsec + QuickCheck , aeson + , attoparsec + , base >=4.9 && <5 , containers + , exceptions , ghc-prim + , protolude >=0.2.1 , scientific - , QuickCheck , text + , transformers exposed-modules: GraphQL GraphQL.API @@ -55,35 +67,26 @@ GraphQL.Value GraphQL.Value.FromValue GraphQL.Value.ToValue + other-modules: + Paths_graphql_api default-language: Haskell2010 test-suite graphql-api-doctests type: exitcode-stdio-1.0 - main-is: Doctests.hs + main-is: Main.hs hs-source-dirs: - tests + tests/doctests default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications ghc-options: -Wall -fno-warn-redundant-constraints -threaded build-depends: - base >= 4.9 && < 5 - , protolude >= 0.2 + attoparsec + , base >=4.9 && <5 + , doctest , exceptions + , protolude >=0.2.1 , transformers - , attoparsec - , doctest other-modules: - ASTTests - EndToEndTests - EnumTests - Examples.InputObject - Examples.UnionExample - ExampleSchema - OrderedMapTests - ResolverTests - SchemaTests - Spec - ValidationTests - ValueTests + Paths_graphql_api default-language: Haskell2010 test-suite graphql-api-tests @@ -94,23 +97,22 @@ default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications ghc-options: -Wall -fno-warn-redundant-constraints build-depends: - base >= 4.9 && < 5 - , protolude >= 0.2 - , exceptions - , transformers - , attoparsec + QuickCheck , aeson + , attoparsec + , base >=4.9 && <5 , containers + , directory + , exceptions , graphql-api , hspec - , QuickCheck + , protolude >=0.2.1 , raw-strings-qq , tasty , tasty-hspec - , directory + , transformers other-modules: ASTTests - Doctests EndToEndTests EnumTests Examples.InputObject @@ -121,6 +123,7 @@ SchemaTests ValidationTests ValueTests + Paths_graphql_api default-language: Haskell2010 benchmark criterion @@ -131,13 +134,14 @@ default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications ghc-options: -Wall -fno-warn-redundant-constraints build-depends: - base >= 4.9 && < 5 - , protolude >= 0.2 - , exceptions - , transformers - , attoparsec + attoparsec + , base >=4.9 && <5 , criterion + , exceptions , graphql-api + , protolude >=0.2.1 + , transformers other-modules: Validation + Paths_graphql_api default-language: Haskell2010 diff --git a/src/GraphQL/API.hs b/src/GraphQL/API.hs --- a/src/GraphQL/API.hs +++ b/src/GraphQL/API.hs @@ -15,13 +15,13 @@ ( Object , Field , Argument - , DefaultArgument , Union , List , Enum , GraphQLEnum(..) , Interface , (:>)(..) + , Defaultable(..) , HasAnnotatedType(..) , HasAnnotatedInputType , HasObjectDefinition(..) @@ -34,10 +34,9 @@ import Protolude hiding (Enum, TypeError) -import GraphQL.Internal.Schema hiding (Type) -import qualified GraphQL.Internal.Schema (Type) import GHC.TypeLits (Symbol, KnownSymbol, TypeError, ErrorMessage(..)) -import GraphQL.Internal.Name (NameError, nameFromSymbol) +import qualified GraphQL.Internal.Schema as Schema +import GraphQL.Internal.Name (Name, NameError, nameFromSymbol) import GraphQL.API.Enum (GraphQLEnum(..)) import GHC.Generics ((:*:)(..)) import GHC.Types (Type) @@ -83,27 +82,50 @@ data Argument (name :: Symbol) (argType :: Type) --- Can't set the value for default arguments via types, but can --- distinguish to force users to provide a default argument somewhere --- in their function (using Maybe? ore some new type like --- https://hackage.haskell.org/package/optional-args-1.0.1) -data DefaultArgument (name :: Symbol) (argType :: Type) +-- | Specify a default value for a type in a GraphQL schema. +-- +-- GraphQL schema can have default values in certain places. For example, +-- arguments to fields can have default values. Because we cannot lift +-- arbitrary values to the type level, we need some way of getting at those +-- values. This typeclass provides the means. +-- +-- To specify a default, implement this typeclass. +-- +-- The default implementation is to say that there *is* no default for this +-- type. +class Defaultable a where + -- | defaultFor returns the value to be used when no value has been given. + defaultFor :: Name -> Maybe a + defaultFor _ = empty +instance Defaultable Int32 + +instance Defaultable Double + +instance Defaultable Bool + +instance Defaultable Text + +instance Defaultable (Maybe a) where + -- | The default for @Maybe a@ is @Nothing@. + defaultFor _ = pure Nothing + + cons :: a -> [a] -> [a] cons = (:) -- Transform into a Schema definition class HasObjectDefinition a where -- Todo rename to getObjectTypeDefinition - getDefinition :: Either NameError ObjectTypeDefinition + getDefinition :: Either NameError Schema.ObjectTypeDefinition class HasFieldDefinition a where - getFieldDefinition :: Either NameError FieldDefinition + getFieldDefinition :: Either NameError Schema.FieldDefinition -- Fields class HasFieldDefinitions a where - getFieldDefinitions :: Either NameError [FieldDefinition] + getFieldDefinitions :: Either NameError [Schema.FieldDefinition] instance forall a as. (HasFieldDefinition a, HasFieldDefinitions as) => HasFieldDefinitions (a:as) where getFieldDefinitions = cons <$> getFieldDefinition @a <*> getFieldDefinitions @as @@ -115,18 +137,18 @@ -- object types from union type lists, e.g. for -- Union "Horse" '[Leg, Head, Tail] -- ^^^^^^^^^^^^^^^^^^ this part -class UnionTypeObjectTypeDefinitionList a where - getUnionTypeObjectTypeDefinitions :: Either NameError [ObjectTypeDefinition] +class HasUnionTypeObjectTypeDefinitions a where + getUnionTypeObjectTypeDefinitions :: Either NameError [Schema.ObjectTypeDefinition] -instance forall a as. (HasObjectDefinition a, UnionTypeObjectTypeDefinitionList as) => UnionTypeObjectTypeDefinitionList (a:as) where +instance forall a as. (HasObjectDefinition a, HasUnionTypeObjectTypeDefinitions as) => HasUnionTypeObjectTypeDefinitions (a:as) where getUnionTypeObjectTypeDefinitions = cons <$> getDefinition @a <*> getUnionTypeObjectTypeDefinitions @as -instance UnionTypeObjectTypeDefinitionList '[] where +instance HasUnionTypeObjectTypeDefinitions '[] where getUnionTypeObjectTypeDefinitions = pure [] -- Interfaces class HasInterfaceDefinitions a where - getInterfaceDefinitions :: Either NameError Interfaces + getInterfaceDefinitions :: Either NameError Schema.Interfaces instance forall a as. (HasInterfaceDefinition a, HasInterfaceDefinitions as) => HasInterfaceDefinitions (a:as) where getInterfaceDefinitions = cons <$> getInterfaceDefinition @a <*> getInterfaceDefinitions @as @@ -135,35 +157,35 @@ getInterfaceDefinitions = pure [] class HasInterfaceDefinition a where - getInterfaceDefinition :: Either NameError InterfaceTypeDefinition + getInterfaceDefinition :: Either NameError Schema.InterfaceTypeDefinition instance forall ks fields. (KnownSymbol ks, HasFieldDefinitions fields) => HasInterfaceDefinition (Interface ks fields) where getInterfaceDefinition = let name = nameFromSymbol @ks - fields = NonEmptyList <$> getFieldDefinitions @fields - in InterfaceTypeDefinition <$> name <*> fields + fields = Schema.NonEmptyList <$> getFieldDefinitions @fields + in Schema.InterfaceTypeDefinition <$> name <*> fields -- Give users some help if they don't terminate Arguments with a Field: -- NB the "redundant constraints" warning is a GHC bug: https://ghc.haskell.org/trac/ghc/ticket/11099 instance forall ks t. TypeError ('Text ":> Arguments must end with a Field") => HasFieldDefinition (Argument ks t) where - getFieldDefinition = notImplemented + getFieldDefinition = panic ":> Arugments must end with a Field. This should not happen, but rather we'll get a compile-time error instead." instance forall ks is ts. (KnownSymbol ks, HasInterfaceDefinitions is, HasFieldDefinitions ts) => HasAnnotatedType (Object ks is ts) where getAnnotatedType = let obj = getDefinition @(Object ks is ts) - in (TypeNamed . DefinedType . TypeDefinitionObject) <$> obj + in (Schema.TypeNamed . Schema.DefinedType . Schema.TypeDefinitionObject) <$> obj instance forall t ks. (KnownSymbol ks, HasAnnotatedType t) => HasFieldDefinition (Field ks t) where getFieldDefinition = let name = nameFromSymbol @ks - in FieldDefinition <$> name <*> pure [] <*> getAnnotatedType @t + in Schema.FieldDefinition <$> name <*> pure [] <*> getAnnotatedType @t class HasArgumentDefinition a where - getArgumentDefinition :: Either NameError ArgumentDefinition + getArgumentDefinition :: Either NameError Schema.ArgumentDefinition instance forall ks t. (KnownSymbol ks, HasAnnotatedInputType t) => HasArgumentDefinition (Argument ks t) where - getArgumentDefinition = ArgumentDefinition <$> argName <*> argType <*> defaultValue + getArgumentDefinition = Schema.ArgumentDefinition <$> argName <*> argType <*> defaultValue where argName = nameFromSymbol @ks argType = getAnnotatedInputType @t @@ -173,7 +195,7 @@ getFieldDefinition = prependArg <$> argument <*> getFieldDefinition @b where - prependArg arg (FieldDefinition name argDefs at) = FieldDefinition name (arg:argDefs) at + prependArg arg (Schema.FieldDefinition name argDefs at) = Schema.FieldDefinition name (arg:argDefs) at argument = getArgumentDefinition @a instance forall ks is fields. @@ -182,8 +204,8 @@ getDefinition = let name = nameFromSymbol @ks interfaces = getInterfaceDefinitions @is - fields = NonEmptyList <$> getFieldDefinitions @fields - in ObjectTypeDefinition <$> name <*> interfaces <*> fields + fields = Schema.NonEmptyList <$> getFieldDefinitions @fields + in Schema.ObjectTypeDefinition <$> name <*> interfaces <*> fields -- Builtin output types (annotated types) class HasAnnotatedType a where @@ -192,21 +214,21 @@ -- forget this. Maybe we can flip the internal encoding to be -- non-null by default and needing explicit null-encoding (via -- Maybe). - getAnnotatedType :: Either NameError (AnnotatedType GraphQL.Internal.Schema.Type) + getAnnotatedType :: Either NameError (Schema.AnnotatedType Schema.GType) -- | Turn a non-null type into the optional version of its own type. -dropNonNull :: AnnotatedType t -> AnnotatedType t -dropNonNull (TypeNonNull (NonNullTypeNamed t)) = TypeNamed t -dropNonNull (TypeNonNull (NonNullTypeList t)) = TypeList t -dropNonNull x@(TypeNamed _) = x -dropNonNull x@(TypeList _) = x +dropNonNull :: Schema.AnnotatedType t -> Schema.AnnotatedType t +dropNonNull (Schema.TypeNonNull (Schema.NonNullTypeNamed t)) = Schema.TypeNamed t +dropNonNull (Schema.TypeNonNull (Schema.NonNullTypeList t)) = Schema.TypeList t +dropNonNull x@(Schema.TypeNamed _) = x +dropNonNull x@(Schema.TypeList _) = x instance forall a. HasAnnotatedType a => HasAnnotatedType (Maybe a) where -- see TODO in HasAnnotatedType class getAnnotatedType = dropNonNull <$> getAnnotatedType @a -builtinType :: Builtin -> Either NameError (AnnotatedType GraphQL.Internal.Schema.Type) -builtinType = pure . TypeNonNull . NonNullTypeNamed . BuiltinType +builtinType :: Schema.Builtin -> Either NameError (Schema.AnnotatedType Schema.GType) +builtinType = pure . Schema.TypeNonNull . Schema.NonNullTypeNamed . Schema.BuiltinType -- TODO(jml): Given that AnnotatedType is parametrised, we can probably reduce -- a great deal of duplication by making HasAnnotatedType a parametrised type @@ -216,93 +238,93 @@ -- than listing each individually. instance HasAnnotatedType Int where - getAnnotatedType = builtinType GInt + getAnnotatedType = builtinType Schema.GInt instance HasAnnotatedType Int32 where - getAnnotatedType = builtinType GInt + getAnnotatedType = builtinType Schema.GInt instance HasAnnotatedType Bool where - getAnnotatedType = builtinType GBool + getAnnotatedType = builtinType Schema.GBool instance HasAnnotatedType Text where - getAnnotatedType = builtinType GString + getAnnotatedType = builtinType Schema.GString instance HasAnnotatedType Double where - getAnnotatedType = builtinType GFloat + getAnnotatedType = builtinType Schema.GFloat instance HasAnnotatedType Float where - getAnnotatedType = builtinType GFloat + getAnnotatedType = builtinType Schema.GFloat instance forall t. (HasAnnotatedType t) => HasAnnotatedType (List t) where - getAnnotatedType = TypeList . ListType <$> getAnnotatedType @t + getAnnotatedType = Schema.TypeList . Schema.ListType <$> getAnnotatedType @t instance forall ks enum. (KnownSymbol ks, GraphQLEnum enum) => HasAnnotatedType (Enum ks enum) where getAnnotatedType = do let name = nameFromSymbol @ks - let enums = sequenceA (enumValues @enum) :: Either NameError [Name] - let et = EnumTypeDefinition <$> name <*> map (map EnumValueDefinition) enums - TypeNonNull . NonNullTypeNamed . DefinedType . TypeDefinitionEnum <$> et + let enums = sequenceA (enumValues @enum) :: Either NameError [Schema.Name] + let et = Schema.EnumTypeDefinition <$> name <*> map (map Schema.EnumValueDefinition) enums + Schema.TypeNonNull . Schema.NonNullTypeNamed . Schema.DefinedType . Schema.TypeDefinitionEnum <$> et -instance forall ks as. (KnownSymbol ks, UnionTypeObjectTypeDefinitionList as) => HasAnnotatedType (Union ks as) where +instance forall ks as. (KnownSymbol ks, HasUnionTypeObjectTypeDefinitions as) => HasAnnotatedType (Union ks as) where getAnnotatedType = let name = nameFromSymbol @ks - types = NonEmptyList <$> getUnionTypeObjectTypeDefinitions @as - in (TypeNamed . DefinedType . TypeDefinitionUnion) <$> (UnionTypeDefinition <$> name <*> types) + types = Schema.NonEmptyList <$> getUnionTypeObjectTypeDefinitions @as + in (Schema.TypeNamed . Schema.DefinedType . Schema.TypeDefinitionUnion) <$> (Schema.UnionTypeDefinition <$> name <*> types) -- Help users with better type errors instance TypeError ('Text "Cannot encode Integer because it has arbitrary size but the JSON encoding is a number") => HasAnnotatedType Integer where - getAnnotatedType = undefined + getAnnotatedType = panic "Cannot encode Integer into JSON due to its arbitrary size. Should get a compile-time error instead of this." -- Builtin input types class HasAnnotatedInputType a where -- See TODO comment in "HasAnnotatedType" class for nullability. - getAnnotatedInputType :: Either NameError (AnnotatedType InputType) - default getAnnotatedInputType :: (Generic a, GenericAnnotatedInputType (Rep a)) => Either NameError (AnnotatedType InputType) + getAnnotatedInputType :: Either NameError (Schema.AnnotatedType Schema.InputType) + default getAnnotatedInputType :: (Generic a, GenericAnnotatedInputType (Rep a)) => Either NameError (Schema.AnnotatedType Schema.InputType) getAnnotatedInputType = genericGetAnnotatedInputType @(Rep a) instance forall a. HasAnnotatedInputType a => HasAnnotatedInputType (Maybe a) where getAnnotatedInputType = dropNonNull <$> getAnnotatedInputType @a -builtinInputType :: Builtin -> Either NameError (AnnotatedType InputType) -builtinInputType = pure . TypeNonNull . NonNullTypeNamed . BuiltinInputType +builtinInputType :: Schema.Builtin -> Either NameError (Schema.AnnotatedType Schema.InputType) +builtinInputType = pure . Schema.TypeNonNull . Schema.NonNullTypeNamed . Schema.BuiltinInputType instance HasAnnotatedInputType Int where - getAnnotatedInputType = builtinInputType GInt + getAnnotatedInputType = builtinInputType Schema.GInt instance HasAnnotatedInputType Int32 where - getAnnotatedInputType = builtinInputType GInt + getAnnotatedInputType = builtinInputType Schema.GInt instance HasAnnotatedInputType Bool where - getAnnotatedInputType = builtinInputType GBool + getAnnotatedInputType = builtinInputType Schema.GBool instance HasAnnotatedInputType Text where - getAnnotatedInputType = builtinInputType GString + getAnnotatedInputType = builtinInputType Schema.GString instance HasAnnotatedInputType Double where - getAnnotatedInputType = builtinInputType GFloat + getAnnotatedInputType = builtinInputType Schema.GFloat instance HasAnnotatedInputType Float where - getAnnotatedInputType = builtinInputType GFloat + getAnnotatedInputType = builtinInputType Schema.GFloat instance forall t. (HasAnnotatedInputType t) => HasAnnotatedInputType (List t) where - getAnnotatedInputType = TypeList . ListType <$> getAnnotatedInputType @t + getAnnotatedInputType = Schema.TypeList . Schema.ListType <$> getAnnotatedInputType @t instance forall ks enum. (KnownSymbol ks, GraphQLEnum enum) => HasAnnotatedInputType (Enum ks enum) where getAnnotatedInputType = do let name = nameFromSymbol @ks - enums = sequenceA (enumValues @enum) :: Either NameError [Name] - let et = EnumTypeDefinition <$> name <*> map (map EnumValueDefinition) enums - TypeNonNull . NonNullTypeNamed . DefinedInputType . InputTypeDefinitionEnum <$> et + enums = sequenceA (enumValues @enum) :: Either NameError [Schema.Name] + let et = Schema.EnumTypeDefinition <$> name <*> map (map Schema.EnumValueDefinition) enums + Schema.TypeNonNull . Schema.NonNullTypeNamed . Schema.DefinedInputType . Schema.InputTypeDefinitionEnum <$> et -- Generic getAnnotatedInputType function class GenericAnnotatedInputType (f :: Type -> Type) where - genericGetAnnotatedInputType :: Either NameError (AnnotatedType InputType) + genericGetAnnotatedInputType :: Either NameError (Schema.AnnotatedType Schema.InputType) class GenericInputObjectFieldDefinitions (f :: Type -> Type) where - genericGetInputObjectFieldDefinitions :: Either NameError [InputObjectFieldDefinition] + genericGetInputObjectFieldDefinitions :: Either NameError [Schema.InputObjectFieldDefinition] instance forall dataName consName records s l p. ( KnownSymbol dataName @@ -313,12 +335,12 @@ )) where genericGetAnnotatedInputType = do name <- nameFromSymbol @dataName - map ( TypeNonNull - . NonNullTypeNamed - . DefinedInputType - . InputTypeDefinitionObject - . (InputObjectTypeDefinition name) - . NonEmptyList + map ( Schema.TypeNonNull + . Schema.NonNullTypeNamed + . Schema.DefinedInputType + . Schema.InputTypeDefinitionObject + . Schema.InputObjectTypeDefinition name + . Schema.NonEmptyList ) (genericGetInputObjectFieldDefinitions @records) instance forall wrappedType fieldName rest u s l. @@ -329,7 +351,7 @@ genericGetInputObjectFieldDefinitions = do name <- nameFromSymbol @fieldName annotatedInputType <- getAnnotatedInputType @wrappedType - let l = InputObjectFieldDefinition name annotatedInputType Nothing + let l = Schema.InputObjectFieldDefinition name annotatedInputType Nothing r <- genericGetInputObjectFieldDefinitions @rest pure (l:r) @@ -340,5 +362,5 @@ genericGetInputObjectFieldDefinitions = do name <- nameFromSymbol @fieldName annotatedInputType <- getAnnotatedInputType @wrappedType - let l = InputObjectFieldDefinition name annotatedInputType Nothing + let l = Schema.InputObjectFieldDefinition name annotatedInputType Nothing pure [l] diff --git a/src/GraphQL/API/Enum.hs b/src/GraphQL/API/Enum.hs --- a/src/GraphQL/API/Enum.hs +++ b/src/GraphQL/API/Enum.hs @@ -86,18 +86,20 @@ ( TypeError ('Text "Constructor not unary: " ':<>: 'Text conName) , KnownSymbol conName ) => GenericEnumValues (C1 ('MetaCons conName p b) (S1 sa sb)) where - genericEnumValues = undefined - genericEnumFromValue = undefined - genericEnumToValue = undefined + genericEnumValues = nonUnaryConstructorError + genericEnumFromValue = nonUnaryConstructorError + genericEnumToValue = nonUnaryConstructorError instance forall conName p b sa sb f. ( TypeError ('Text "Constructor not unary: " ':<>: 'Text conName) , KnownSymbol conName ) => GenericEnumValues (C1 ('MetaCons conName p b) (S1 sa sb) :+: f) where - genericEnumValues = undefined - genericEnumFromValue = undefined - genericEnumToValue = undefined + genericEnumValues = nonUnaryConstructorError + genericEnumFromValue = nonUnaryConstructorError + genericEnumToValue = nonUnaryConstructorError +nonUnaryConstructorError :: a +nonUnaryConstructorError = panic "Tried to construct enum with non-unary constructor. Should get a compile-time error instead of this." -- | For each enum type we need 1) a list of all possible values 2) a -- way to serialise and 3) deserialise. diff --git a/src/GraphQL/Internal/Execution.hs b/src/GraphQL/Internal/Execution.hs --- a/src/GraphQL/Internal/Execution.hs +++ b/src/GraphQL/Internal/Execution.hs @@ -32,7 +32,7 @@ , VariableDefinition(..) , VariableValue , Variable - , Type(..) + , GType(..) ) -- | Get an operation from a GraphQL document @@ -51,7 +51,7 @@ -- * Return {operation}. getOperation :: QueryDocument value -> Maybe Name -> Either ExecutionError (Operation value) getOperation (LoneAnonymousOperation op) Nothing = pure op -getOperation (MultipleOperations ops) (Just name) = note (NoSuchOperation name) (Map.lookup name ops) +getOperation (MultipleOperations ops) (Just name) = note (NoSuchOperation name) (Map.lookup (pure name) ops) getOperation (MultipleOperations ops) Nothing = case toList ops of [op] -> pure op diff --git a/src/GraphQL/Internal/Name.hs b/src/GraphQL/Internal/Name.hs --- a/src/GraphQL/Internal/Name.hs +++ b/src/GraphQL/Internal/Name.hs @@ -5,10 +5,11 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module GraphQL.Internal.Name - ( Name(unName) + ( Name(unName, Name) , NameError(..) , makeName , nameFromSymbol + , nameParser -- * Named things , HasName(..) -- * Unsafe functions @@ -17,14 +18,59 @@ import Protolude +import qualified Data.Aeson as Aeson import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) -import GraphQL.Internal.Syntax.AST - ( Name(..) - , NameError(..) - , unsafeMakeName - , makeName - ) +import Data.Char (isDigit) +import Data.Text as T (Text) +import qualified Data.Attoparsec.Text as A +import Test.QuickCheck (Arbitrary(..), elements, listOf) +import Data.String (IsString(..)) +import GraphQL.Internal.Syntax.Tokens (tok) + +-- * Name + +-- | A name in GraphQL. +-- +-- https://facebook.github.io/graphql/#sec-Names +newtype Name = Name { unName :: T.Text } deriving (Eq, Ord, Show) + + +-- | Create a 'Name', panicking if the given text is invalid. +-- +-- Prefer 'makeName' to this in all cases. +-- +-- >>> unsafeMakeName "foo" +-- Name {unName = "foo"} +unsafeMakeName :: HasCallStack => Text -> Name +unsafeMakeName name = + case makeName name of + Left e -> panic (show e) + Right n -> n + +-- | Create a 'Name'. +-- +-- Names must match the regex @[_A-Za-z][_0-9A-Za-z]*@. If the given text does +-- not match, return NameError. +-- +-- >>> makeName "foo" +-- Right (Name {unName = "foo"}) +-- >>> makeName "9-bar" +-- Left (NameError "9-bar") +makeName :: Text -> Either NameError Name +makeName name = first (const (NameError name)) (A.parseOnly nameParser name) + +-- | Parser for 'Name'. +nameParser :: A.Parser Name +nameParser = Name <$> tok ((<>) <$> A.takeWhile1 isA_z + <*> A.takeWhile ((||) <$> isDigit <*> isA_z)) + where + -- `isAlpha` handles many more Unicode Chars + isA_z = A.inClass $ '_' : ['A'..'Z'] <> ['a'..'z'] + +-- | An invalid name. +newtype NameError = NameError Text deriving (Eq, Show) + -- | Convert a type-level 'Symbol' into a GraphQL 'Name'. nameFromSymbol :: forall (n :: Symbol). KnownSymbol n => Either NameError Name nameFromSymbol = makeName (toS (symbolVal @n Proxy)) @@ -41,3 +87,18 @@ class HasName a where -- | Get the name of the object. getName :: a -> Name + +instance IsString Name where + fromString = unsafeMakeName . toS + +instance Aeson.ToJSON Name where + toJSON = Aeson.toJSON . unName + +instance Arbitrary Name where + arbitrary = do + initial <- elements alpha + rest <- listOf (elements (alpha <> numeric)) + pure (Name (toS (initial:rest))) + where + alpha = ['A'..'Z'] <> ['a'..'z'] <> ['_'] + numeric = ['0'..'9'] diff --git a/src/GraphQL/Internal/Schema.hs b/src/GraphQL/Internal/Schema.hs --- a/src/GraphQL/Internal/Schema.hs +++ b/src/GraphQL/Internal/Schema.hs @@ -8,7 +8,7 @@ -- -- Equivalent representation of GraphQL /values/ is in "GraphQL.Value". module GraphQL.Internal.Schema - ( Type(..) + ( GType(..) -- * Builtin types , Builtin(..) -- * Defining new types @@ -100,13 +100,13 @@ | NonNullTypeList (ListType t) deriving (Eq, Ord, Show) -data Type = DefinedType TypeDefinition | BuiltinType Builtin deriving (Eq, Ord, Show) +data GType = DefinedType TypeDefinition | BuiltinType Builtin deriving (Eq, Ord, Show) -instance DefinesTypes Type where +instance DefinesTypes GType where getDefinedTypes (BuiltinType _) = mempty getDefinedTypes (DefinedType t) = getDefinedTypes t -instance HasName Type where +instance HasName GType where getName (DefinedType x) = getName x getName (BuiltinType x) = getName x @@ -154,7 +154,7 @@ type Interfaces = [InterfaceTypeDefinition] -data FieldDefinition = FieldDefinition Name [ArgumentDefinition] (AnnotatedType Type) +data FieldDefinition = FieldDefinition Name [ArgumentDefinition] (AnnotatedType GType) deriving (Eq, Ord, Show) instance HasName FieldDefinition where diff --git a/src/GraphQL/Internal/Syntax/AST.hs b/src/GraphQL/Internal/Syntax/AST.hs --- a/src/GraphQL/Internal/Syntax/AST.hs +++ b/src/GraphQL/Internal/Syntax/AST.hs @@ -4,17 +4,11 @@ {-# LANGUAGE ScopedTypeVariables #-} module GraphQL.Internal.Syntax.AST - ( Name(unName) - , nameParser - , NameError(..) - , unsafeMakeName - , makeName - , QueryDocument(..) + ( QueryDocument(..) , SchemaDocument(..) , Definition(..) , OperationDefinition(..) , Node(..) - , getNodeName , VariableDefinition(..) , Variable(..) , SelectionSet @@ -33,7 +27,7 @@ , ObjectField(..) , DefaultValue , Directive(..) - , Type(..) + , GType(..) , NamedType(..) , ListType(..) , NonNullType(..) @@ -54,72 +48,10 @@ import Protolude -import qualified Data.Aeson as Aeson -import qualified Data.Attoparsec.Text as A -import Data.Char (isDigit) -import Data.String (IsString(..)) -import Test.QuickCheck (Arbitrary(..), elements, listOf, oneof) +import Test.QuickCheck (Arbitrary(..), listOf, oneof) import GraphQL.Internal.Arbitrary (arbitraryText) -import GraphQL.Internal.Syntax.Tokens (tok) - --- * Name - --- | A name in GraphQL. --- --- https://facebook.github.io/graphql/#sec-Names -newtype Name = Name { unName :: Text } deriving (Eq, Ord, Show) - --- | Create a 'Name', panicking if the given text is invalid. --- --- Prefer 'makeName' to this in all cases. --- --- >>> unsafeMakeName "foo" --- Name {unName = "foo"} -unsafeMakeName :: HasCallStack => Text -> Name -unsafeMakeName name = - case makeName name of - Left e -> panic (show e) - Right n -> n - --- | Create a 'Name'. --- --- Names must match the regex @[_A-Za-z][_0-9A-Za-z]*@. If the given text does --- not match, return Nothing. --- --- >>> makeName "foo" --- Right (Name {unName = "foo"}) --- >>> makeName "9-bar" --- Left (NameError "9-bar") -makeName :: Text -> Either NameError Name -makeName name = first (const (NameError name)) (A.parseOnly nameParser name) - --- | An invalid name. -newtype NameError = NameError Text deriving (Eq, Show) - - -instance IsString Name where - fromString = unsafeMakeName . toS - -instance Aeson.ToJSON Name where - toJSON = Aeson.toJSON . unName - -instance Arbitrary Name where - arbitrary = do - initial <- elements alpha - rest <- listOf (elements (alpha <> numeric)) - pure (Name (toS (initial:rest))) - where - alpha = ['A'..'Z'] <> ['a'..'z'] <> ['_'] - numeric = ['0'..'9'] - --- | Parser for 'Name'. -nameParser :: A.Parser Name -nameParser = Name <$> tok ((<>) <$> A.takeWhile1 isA_z - <*> A.takeWhile ((||) <$> isDigit <*> isA_z)) - where - -- `isAlpha` handles many more Unicode Chars - isA_z = A.inClass $ '_' : ['A'..'Z'] <> ['a'..'z'] +import GraphQL.Internal.Name (Name) -- * Documents @@ -143,14 +75,10 @@ | AnonymousQuery SelectionSet deriving (Eq,Show) -data Node = Node Name [VariableDefinition] [Directive] SelectionSet +data Node = Node (Maybe Name) [VariableDefinition] [Directive] SelectionSet deriving (Eq,Show) --- TODO: Just make Node implement HasName. -getNodeName :: Node -> Name -getNodeName (Node name _ _ _) = name - -data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue) +data VariableDefinition = VariableDefinition Variable GType (Maybe DefaultValue) deriving (Eq,Show) newtype Variable = Variable Name deriving (Eq, Ord, Show) @@ -241,14 +169,14 @@ -- * Type Reference -data Type = TypeNamed NamedType - | TypeList ListType - | TypeNonNull NonNullType - deriving (Eq, Ord, Show) +data GType = TypeNamed NamedType + | TypeList ListType + | TypeNonNull NonNullType + deriving (Eq, Ord, Show) newtype NamedType = NamedType Name deriving (Eq, Ord, Show) -newtype ListType = ListType Type deriving (Eq, Ord, Show) +newtype ListType = ListType GType deriving (Eq, Ord, Show) data NonNullType = NonNullTypeNamed NamedType | NonNullTypeList ListType @@ -270,12 +198,12 @@ type Interfaces = [NamedType] -data FieldDefinition = FieldDefinition Name ArgumentsDefinition Type +data FieldDefinition = FieldDefinition Name ArgumentsDefinition GType deriving (Eq,Show) type ArgumentsDefinition = [InputValueDefinition] -data InputValueDefinition = InputValueDefinition Name Type (Maybe DefaultValue) +data InputValueDefinition = InputValueDefinition Name GType (Maybe DefaultValue) deriving (Eq,Show) data InterfaceTypeDefinition = InterfaceTypeDefinition Name [FieldDefinition] diff --git a/src/GraphQL/Internal/Syntax/Encoder.hs b/src/GraphQL/Internal/Syntax/Encoder.hs --- a/src/GraphQL/Internal/Syntax/Encoder.hs +++ b/src/GraphQL/Internal/Syntax/Encoder.hs @@ -10,6 +10,7 @@ import Data.Text (Text, cons, intercalate, pack, snoc) import qualified GraphQL.Internal.Syntax.AST as AST +import GraphQL.Internal.Name (unName) -- * Document @@ -29,11 +30,15 @@ operationDefinition (AST.AnonymousQuery ss) = selectionSet ss node :: AST.Node -> Text -node (AST.Node name vds ds ss) = - AST.unName name +node (AST.Node (Just name) vds ds ss) = + unName name <> optempty variableDefinitions vds <> optempty directives ds <> selectionSet ss +node (AST.Node Nothing vds ds ss) = + optempty variableDefinitions vds + <> optempty directives ds + <> selectionSet ss variableDefinitions :: [AST.VariableDefinition] -> Text variableDefinitions = parensCommas variableDefinition @@ -46,7 +51,7 @@ defaultValue val = "=" <> value val variable :: AST.Variable -> Text -variable (AST.Variable name) = "$" <> AST.unName name +variable (AST.Variable name) = "$" <> unName name selectionSet :: AST.SelectionSet -> Text selectionSet = bracesCommas selection @@ -58,8 +63,8 @@ field :: AST.Field -> Text field (AST.Field alias name args ds ss) = - optempty (`snoc` ':') (maybe mempty AST.unName alias) - <> AST.unName name + optempty (`snoc` ':') (maybe mempty unName alias) + <> unName name <> optempty arguments args <> optempty directives ds <> optempty selectionSet ss @@ -68,17 +73,17 @@ arguments = parensCommas argument argument :: AST.Argument -> Text -argument (AST.Argument name v) = AST.unName name <> ":" <> value v +argument (AST.Argument name v) = unName name <> ":" <> value v -- * Fragments fragmentSpread :: AST.FragmentSpread -> Text fragmentSpread (AST.FragmentSpread name ds) = - "..." <> AST.unName name <> optempty directives ds + "..." <> unName name <> optempty directives ds inlineFragment :: AST.InlineFragment -> Text inlineFragment (AST.InlineFragment (Just (AST.NamedType tc)) ds ss) = - "... on " <> AST.unName tc + "... on " <> unName tc <> optempty directives ds <> optempty selectionSet ss inlineFragment (AST.InlineFragment Nothing ds ss) = @@ -87,7 +92,7 @@ fragmentDefinition :: AST.FragmentDefinition -> Text fragmentDefinition (AST.FragmentDefinition name (AST.NamedType tc) ds ss) = - "fragment " <> AST.unName name <> " on " <> AST.unName tc + "fragment " <> unName name <> " on " <> unName tc <> optempty directives ds <> selectionSet ss @@ -101,7 +106,7 @@ value (AST.ValueFloat x) = pack $ show x value (AST.ValueBoolean x) = booleanValue x value (AST.ValueString x) = stringValue x -value (AST.ValueEnum x) = AST.unName x +value (AST.ValueEnum x) = unName x value (AST.ValueList x) = listValue x value (AST.ValueObject x) = objectValue x value AST.ValueNull = "null" @@ -121,7 +126,7 @@ objectValue (AST.ObjectValue ofs) = bracesCommas objectField ofs objectField :: AST.ObjectField -> Text -objectField (AST.ObjectField name v) = AST.unName name <> ":" <> value v +objectField (AST.ObjectField name v) = unName name <> ":" <> value v -- * Directives @@ -129,23 +134,23 @@ directives = spaces directive directive :: AST.Directive -> Text -directive (AST.Directive name args) = "@" <> AST.unName name <> optempty arguments args +directive (AST.Directive name args) = "@" <> unName name <> optempty arguments args -- * Type Reference -type_ :: AST.Type -> Text -type_ (AST.TypeNamed (AST.NamedType x)) = AST.unName x +type_ :: AST.GType -> Text +type_ (AST.TypeNamed (AST.NamedType x)) = unName x type_ (AST.TypeList x) = listType x type_ (AST.TypeNonNull x) = nonNullType x namedType :: AST.NamedType -> Text -namedType (AST.NamedType name) = AST.unName name +namedType (AST.NamedType name) = unName name listType :: AST.ListType -> Text listType (AST.ListType ty) = brackets (type_ ty) nonNullType :: AST.NonNullType -> Text -nonNullType (AST.NonNullTypeNamed (AST.NamedType x)) = AST.unName x <> "!" +nonNullType (AST.NonNullTypeNamed (AST.NamedType x)) = unName x <> "!" nonNullType (AST.NonNullTypeList x) = listType x <> "!" typeDefinition :: AST.TypeDefinition -> Text @@ -159,7 +164,7 @@ objectTypeDefinition :: AST.ObjectTypeDefinition -> Text objectTypeDefinition (AST.ObjectTypeDefinition name ifaces fds) = - "type " <> AST.unName name + "type " <> unName name <> optempty (spaced . interfaces) ifaces <> optempty fieldDefinitions fds @@ -171,7 +176,7 @@ fieldDefinition :: AST.FieldDefinition -> Text fieldDefinition (AST.FieldDefinition name args ty) = - AST.unName name <> optempty argumentsDefinition args + unName name <> optempty argumentsDefinition args <> ":" <> type_ ty @@ -180,36 +185,36 @@ interfaceTypeDefinition :: AST.InterfaceTypeDefinition -> Text interfaceTypeDefinition (AST.InterfaceTypeDefinition name fds) = - "interface " <> AST.unName name <> fieldDefinitions fds + "interface " <> unName name <> fieldDefinitions fds unionTypeDefinition :: AST.UnionTypeDefinition -> Text unionTypeDefinition (AST.UnionTypeDefinition name ums) = - "union " <> AST.unName name <> "=" <> unionMembers ums + "union " <> unName name <> "=" <> unionMembers ums unionMembers :: [AST.NamedType] -> Text unionMembers = intercalate "|" . fmap namedType scalarTypeDefinition :: AST.ScalarTypeDefinition -> Text -scalarTypeDefinition (AST.ScalarTypeDefinition name) = "scalar " <> AST.unName name +scalarTypeDefinition (AST.ScalarTypeDefinition name) = "scalar " <> unName name enumTypeDefinition :: AST.EnumTypeDefinition -> Text enumTypeDefinition (AST.EnumTypeDefinition name evds) = - "enum " <> AST.unName name + "enum " <> unName name <> bracesCommas enumValueDefinition evds enumValueDefinition :: AST.EnumValueDefinition -> Text -enumValueDefinition (AST.EnumValueDefinition name) = AST.unName name +enumValueDefinition (AST.EnumValueDefinition name) = unName name inputObjectTypeDefinition :: AST.InputObjectTypeDefinition -> Text inputObjectTypeDefinition (AST.InputObjectTypeDefinition name ivds) = - "input " <> AST.unName name <> inputValueDefinitions ivds + "input " <> unName name <> inputValueDefinitions ivds inputValueDefinitions :: [AST.InputValueDefinition] -> Text inputValueDefinitions = bracesCommas inputValueDefinition inputValueDefinition :: AST.InputValueDefinition -> Text inputValueDefinition (AST.InputValueDefinition name ty dv) = - AST.unName name <> ":" <> type_ ty <> maybe mempty defaultValue dv + unName name <> ":" <> type_ ty <> maybe mempty defaultValue dv typeExtensionDefinition :: AST.TypeExtensionDefinition -> Text typeExtensionDefinition (AST.TypeExtensionDefinition otd) = diff --git a/src/GraphQL/Internal/Syntax/Parser.hs b/src/GraphQL/Internal/Syntax/Parser.hs --- a/src/GraphQL/Internal/Syntax/Parser.hs +++ b/src/GraphQL/Internal/Syntax/Parser.hs @@ -28,6 +28,7 @@ import qualified GraphQL.Internal.Syntax.AST as AST import GraphQL.Internal.Syntax.Tokens (tok, whiteSpace) +import GraphQL.Internal.Name (nameParser) -- * Document @@ -51,7 +52,7 @@ "operationDefinition error!" node :: Parser AST.Node -node = AST.Node <$> AST.nameParser +node = AST.Node <$> optional nameParser <*> optempty variableDefinitions <*> optempty directives <*> selectionSet @@ -70,7 +71,7 @@ defaultValue = tok "=" *> value variable :: Parser AST.Variable -variable = AST.Variable <$ tok "$" <*> AST.nameParser +variable = AST.Variable <$ tok "$" <*> nameParser selectionSet :: Parser AST.SelectionSet selectionSet = braces $ many1 selection @@ -84,19 +85,19 @@ field :: Parser AST.Field field = AST.Field <$> option empty (pure <$> alias) - <*> AST.nameParser + <*> nameParser <*> optempty arguments <*> optempty directives <*> optempty selectionSet alias :: Parser AST.Alias -alias = AST.nameParser <* tok ":" +alias = nameParser <* tok ":" arguments :: Parser [AST.Argument] arguments = parens $ many1 argument argument :: Parser AST.Argument -argument = AST.Argument <$> AST.nameParser <* tok ":" <*> value +argument = AST.Argument <$> nameParser <* tok ":" <*> value -- * Fragments @@ -105,7 +106,7 @@ -- See https://facebook.github.io/graphql/#FragmentSpread fragmentSpread = AST.FragmentSpread <$ tok "..." - <*> AST.nameParser + <*> nameParser <*> optempty directives -- InlineFragment tried first in order to guard against 'on' keyword @@ -119,7 +120,7 @@ fragmentDefinition :: Parser AST.FragmentDefinition fragmentDefinition = AST.FragmentDefinition <$ tok "fragment" - <*> AST.nameParser + <*> nameParser <* tok "on" <*> typeCondition <*> optempty directives @@ -139,7 +140,7 @@ <|> AST.ValueBoolean <$> (booleanValue "booleanValue") <|> AST.ValueString <$> (stringValue "stringValue") -- `true` and `false` have been tried before - <|> AST.ValueEnum <$> (AST.nameParser "name") + <|> AST.ValueEnum <$> (nameParser "name") <|> AST.ValueList <$> (listValue "listValue") <|> AST.ValueObject <$> (objectValue "objectValue") "value error!") @@ -192,7 +193,7 @@ objectValue = AST.ObjectValue <$> braces (many (objectField "objectField")) objectField :: Parser AST.ObjectField -objectField = AST.ObjectField <$> AST.nameParser <* tok ":" <*> value +objectField = AST.ObjectField <$> nameParser <* tok ":" <*> value -- * Directives @@ -202,19 +203,19 @@ directive :: Parser AST.Directive directive = AST.Directive <$ tok "@" - <*> AST.nameParser + <*> nameParser <*> optempty arguments -- * Type Reference -type_ :: Parser AST.Type +type_ :: Parser AST.GType type_ = AST.TypeList <$> listType <|> AST.TypeNonNull <$> nonNullType <|> AST.TypeNamed <$> namedType "type_ error!" namedType :: Parser AST.NamedType -namedType = AST.NamedType <$> AST.nameParser +namedType = AST.NamedType <$> nameParser listType :: Parser AST.ListType listType = AST.ListType <$> brackets type_ @@ -240,7 +241,7 @@ objectTypeDefinition :: Parser AST.ObjectTypeDefinition objectTypeDefinition = AST.ObjectTypeDefinition <$ tok "type" - <*> AST.nameParser + <*> nameParser <*> optempty interfaces <*> fieldDefinitions @@ -252,7 +253,7 @@ fieldDefinition :: Parser AST.FieldDefinition fieldDefinition = AST.FieldDefinition - <$> AST.nameParser + <$> nameParser <*> optempty argumentsDefinition <* tok ":" <*> type_ @@ -263,13 +264,13 @@ interfaceTypeDefinition :: Parser AST.InterfaceTypeDefinition interfaceTypeDefinition = AST.InterfaceTypeDefinition <$ tok "interface" - <*> AST.nameParser + <*> nameParser <*> fieldDefinitions unionTypeDefinition :: Parser AST.UnionTypeDefinition unionTypeDefinition = AST.UnionTypeDefinition <$ tok "union" - <*> AST.nameParser + <*> nameParser <* tok "=" <*> unionMembers @@ -279,24 +280,24 @@ scalarTypeDefinition :: Parser AST.ScalarTypeDefinition scalarTypeDefinition = AST.ScalarTypeDefinition <$ tok "scalar" - <*> AST.nameParser + <*> nameParser enumTypeDefinition :: Parser AST.EnumTypeDefinition enumTypeDefinition = AST.EnumTypeDefinition <$ tok "enum" - <*> AST.nameParser + <*> nameParser <*> enumValueDefinitions enumValueDefinitions :: Parser [AST.EnumValueDefinition] enumValueDefinitions = braces $ many1 enumValueDefinition enumValueDefinition :: Parser AST.EnumValueDefinition -enumValueDefinition = AST.EnumValueDefinition <$> AST.nameParser +enumValueDefinition = AST.EnumValueDefinition <$> nameParser inputObjectTypeDefinition :: Parser AST.InputObjectTypeDefinition inputObjectTypeDefinition = AST.InputObjectTypeDefinition <$ tok "input" - <*> AST.nameParser + <*> nameParser <*> inputValueDefinitions inputValueDefinitions :: Parser [AST.InputValueDefinition] @@ -304,7 +305,7 @@ inputValueDefinition :: Parser AST.InputValueDefinition inputValueDefinition = AST.InputValueDefinition - <$> AST.nameParser + <$> nameParser <* tok ":" <*> type_ <*> optional defaultValue diff --git a/src/GraphQL/Internal/Validation.hs b/src/GraphQL/Internal/Validation.hs --- a/src/GraphQL/Internal/Validation.hs +++ b/src/GraphQL/Internal/Validation.hs @@ -44,7 +44,7 @@ , VariableDefinition(..) , VariableValue , Variable - , AST.Type(..) + , AST.GType(..) -- * Resolving queries , SelectionSetByType , SelectionSet(..) @@ -58,7 +58,7 @@ , findDuplicates ) where -import Protolude hiding ((<>)) +import Protolude hiding ((<>), throwE) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty @@ -123,7 +123,7 @@ -- | Type alias for 'Query' and 'Mutation' constructors of 'Operation'. type OperationType value = VariableDefinitions -> Directives value -> SelectionSetByType value -> Operation value -type Operations value = Map Name (Operation value) +type Operations value = Map (Maybe Name) (Operation value) -- | Turn a parsed document into a known valid one. -- @@ -132,9 +132,9 @@ validate :: Schema -> AST.QueryDocument -> Either (NonEmpty ValidationError) (QueryDocument VariableValue) validate schema (AST.QueryDocument defns) = runValidator $ do let (operations, fragments) = splitBy splitDefns defns - let (anonymous, named) = splitBy splitOps operations + let (anonymous, maybeNamed) = splitBy splitOps operations (frags, visitedFrags) <- resolveFragmentDefinitions =<< validateFragmentDefinitions schema fragments - case (anonymous, named) of + case (anonymous, maybeNamed) of ([], ops) -> do (validOps, usedFrags) <- runStateT (validateOperations schema frags ops) mempty assertAllFragmentsUsed frags (visitedFrags <> usedFrags) @@ -146,7 +146,7 @@ validValuesSS <- validateValues ss resolvedValuesSS <- resolveVariables emptyVariableDefinitions validValuesSS pure (LoneAnonymousOperation (Query emptyVariableDefinitions emptyDirectives resolvedValuesSS)) - _ -> throwE (MixedAnonymousOperations (length anonymous) (map fst named)) + _ -> throwE (MixedAnonymousOperations (length anonymous) (map fst maybeNamed)) where splitBy :: (a -> Either b c) -> [a] -> ([b], [c]) @@ -156,17 +156,17 @@ splitDefns (AST.DefinitionFragment frag) = Right frag splitOps (AST.AnonymousQuery ss) = Left ss - splitOps (AST.Query node@(AST.Node name _ _ _)) = Right (name, (Query, node)) - splitOps (AST.Mutation node@(AST.Node name _ _ _)) = Right (name, (Mutation, node)) + splitOps (AST.Query node@(AST.Node maybeName _ _ _)) = Right (maybeName, (Query, node)) + splitOps (AST.Mutation node@(AST.Node maybeName _ _ _)) = Right (maybeName, (Mutation, node)) - assertAllFragmentsUsed :: Fragments value -> Set Name -> Validation () + assertAllFragmentsUsed :: Fragments value -> Set (Maybe Name) -> Validation () assertAllFragmentsUsed fragments used = - let unused = Map.keysSet fragments `Set.difference` used + let unused = ( Set.map pure (Map.keysSet fragments)) `Set.difference` used in unless (Set.null unused) (throwE (UnusedFragments unused)) -- * Operations -validateOperations :: Schema -> Fragments AST.Value -> [(Name, (OperationType AST.Value, AST.Node))] -> StateT (Set Name) Validation (Operations AST.Value) +validateOperations :: Schema -> Fragments AST.Value -> [(Maybe Name, (OperationType AST.Value, AST.Node))] -> StateT (Set (Maybe Name)) Validation (Operations AST.Value) validateOperations schema fragments ops = do deduped <- lift (mapErrors DuplicateOperation (makeMap ops)) traverse validateNode deduped @@ -219,7 +219,7 @@ -- We do this /before/ validating the values (since that's much easier once -- everything is in a nice structure and away from the AST), which means we -- can't yet evaluate directives. -validateSelectionSet :: Schema -> Fragments AST.Value -> [AST.Selection] -> StateT (Set Name) Validation (SelectionSetByType AST.Value) +validateSelectionSet :: Schema -> Fragments AST.Value -> [AST.Selection] -> StateT (Set (Maybe Name)) Validation (SelectionSetByType AST.Value) validateSelectionSet schema fragments selections = do unresolved <- lift $ traverse (validateSelection schema) selections resolved <- traverse (resolveSelection fragments) unresolved @@ -508,14 +508,14 @@ -- We're doing a standard depth-first traversal of fragment references, where -- references are by name, so the set of names can be thought of as a record -- of visited references. -resolveSelection :: Fragments a -> Selection' UnresolvedFragmentSpread a -> StateT (Set Name) Validation (Selection' FragmentSpread a) +resolveSelection :: Fragments a -> Selection' UnresolvedFragmentSpread a -> StateT (Set (Maybe Name)) Validation (Selection' FragmentSpread a) resolveSelection fragments = traverseFragmentSpreads resolveFragmentSpread where resolveFragmentSpread (UnresolvedFragmentSpread name directive) = do case Map.lookup name fragments of Nothing -> lift (throwE (NoSuchFragment name)) Just fragment -> do - modify (Set.insert name) + modify (Set.insert (pure name)) pure (FragmentSpread name directive fragment) -- * Fragment definitions @@ -577,7 +577,7 @@ -- -- -- -resolveFragmentDefinitions :: Map Name (FragmentDefinition UnresolvedFragmentSpread value) -> Validation (Fragments value, Set Name) +resolveFragmentDefinitions :: Map Name (FragmentDefinition UnresolvedFragmentSpread value) -> Validation (Fragments value, Set (Maybe Name)) resolveFragmentDefinitions allFragments = splitResult <$> traverse resolveFragment allFragments where @@ -595,12 +595,12 @@ FragmentDefinition name cond directives <$> traverse (traverseFragmentSpreads resolveSpread) ss resolveSpread (UnresolvedFragmentSpread name directives) = do - visited <- Set.member name <$> get + visited <- Set.member (pure name) <$> get when visited (lift (throwE (CircularFragmentSpread name))) case Map.lookup name allFragments of Nothing -> lift (throwE (NoSuchFragment name)) Just definition -> do - modify (Set.insert name) + modify (Set.insert (pure name)) FragmentSpread name directives <$> resolveFragment' definition -- * Arguments @@ -624,7 +624,7 @@ data VariableDefinition = VariableDefinition { variable :: Variable -- ^ The name of the variable - , variableType :: AST.Type -- ^ The type of the variable + , variableType :: AST.GType -- ^ The type of the variable , defaultValue :: Maybe Value -- ^ An optional default value for the variable } deriving (Eq, Ord, Show) @@ -727,12 +727,12 @@ -- with the given name. -- -- - = DuplicateOperation Name + = DuplicateOperation (Maybe Name) -- | 'MixedAnonymousOperations' means there was more than one operation -- defined in a document with an anonymous operation. -- -- - | MixedAnonymousOperations Int [Name] + | MixedAnonymousOperations Int [Maybe Name] -- | 'DuplicateArgument' means that multiple copies of the same argument was -- given to the same field, directive, etc. | DuplicateArgument Name @@ -755,7 +755,7 @@ | CircularFragmentSpread Name -- | 'UnusedFragments' means that fragments were defined that weren't used. -- - | UnusedFragments (Set Name) + | UnusedFragments (Set (Maybe Name)) -- | Variables were defined without being used. -- | UnusedVariables (Set Variable) @@ -777,10 +777,10 @@ deriving (Eq, Show) instance GraphQLError ValidationError where - formatError (DuplicateOperation name) = "More than one operation named '" <> show name <> "'" - formatError (MixedAnonymousOperations n names) - | n > 1 && null names = "Multiple anonymous operations defined. Found " <> show n - | otherwise = "Document contains both anonymous operations (" <> show n <> ") and named operations (" <> show names <> ")" + formatError (DuplicateOperation maybeName) = "More than one operation named '" <> show maybeName <> "'" + formatError (MixedAnonymousOperations n maybeNames) + | n > 1 && null maybeNames = "Multiple anonymous operations defined. Found " <> show n + | otherwise = "Document contains both anonymous operations (" <> show n <> ") and named operations (" <> show maybeNames <> ")" formatError (DuplicateArgument name) = "More than one argument named '" <> show name <> "'" formatError (DuplicateFragmentDefinition name) = "More than one fragment named '" <> show name <> "'" formatError (NoSuchFragment name) = "No fragment named '" <> show name <> "'" diff --git a/src/GraphQL/Resolver.hs b/src/GraphQL/Resolver.hs --- a/src/GraphQL/Resolver.hs +++ b/src/GraphQL/Resolver.hs @@ -17,7 +17,6 @@ ( ResolverError(..) , HasResolver(..) , (:<>)(..) - , Defaultable(..) , Result(..) , unionValue ) where @@ -30,7 +29,7 @@ -- - Directives (https://facebook.github.io/graphql/#sec-Type-System.Directives) -- - Enforce non-empty lists (might only be doable via value-level validation) -import Protolude hiding (Enum, TypeError) +import Protolude hiding (Enum, TypeError, throwE) import qualified Data.Text as Text import qualified Data.List.NonEmpty as NonEmpty @@ -146,38 +145,10 @@ type Handler m a resolve :: Handler m a -> Maybe (SelectionSetByType Value) -> m (Result Value) --- | Specify a default value for a type in a GraphQL schema. --- --- GraphQL schema can have default values in certain places. For example, --- arguments to fields can have default values. Because we cannot lift --- arbitrary values to the type level, we need some way of getting at those --- values. This typeclass provides the means. --- --- To specify a default, implement this typeclass. --- --- The default implementation is to say that there *is* no default for this --- type. -class Defaultable a where - -- | defaultFor returns the value to be used when no value has been given. - defaultFor :: Name -> Maybe a - defaultFor _ = empty - -- | Called when the schema expects an input argument @name@ of type @a@ but -- @name@ has not been provided. -valueMissing :: Defaultable a => Name -> Either ResolverError a -valueMissing name = maybe (Left (ValueMissing name)) Right (defaultFor name) - -instance Defaultable Int32 - -instance Defaultable Double - -instance Defaultable Bool - -instance Defaultable Text - -instance Defaultable (Maybe a) where - -- | The default for @Maybe a@ is @Nothing@. - defaultFor _ = pure Nothing +valueMissing :: API.Defaultable a => Name -> Either ResolverError a +valueMissing name = maybe (Left (ValueMissing name)) Right (API.defaultFor name) instance forall m. (Applicative m) => HasResolver m Int32 where type Handler m Int32 = m Int32 @@ -207,8 +178,8 @@ map aggregateResults a instance forall m ksN enum. (Applicative m, API.GraphQLEnum enum) => HasResolver m (API.Enum ksN enum) where - type Handler m (API.Enum ksN enum) = enum - resolve handler Nothing = (pure . ok . GValue.ValueEnum . API.enumToValue) handler + type Handler m (API.Enum ksN enum) = m enum + resolve handler Nothing = map (ok . GValue.ValueEnum . API.enumToValue) handler resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) instance forall m hg. (HasResolver m hg, Monad m) => HasResolver m (Maybe hg) where @@ -287,7 +258,7 @@ ( KnownSymbol ksH , BuildFieldResolver m f , FromValue t - , Defaultable t + , API.Defaultable t , HasAnnotatedInputType t , Monad m ) => BuildFieldResolver m (PlainArgument (API.Argument ksH t) f) where @@ -303,7 +274,7 @@ ( KnownSymbol ksK , BuildFieldResolver m f , KnownSymbol name - , Defaultable t + , API.Defaultable t , API.GraphQLEnum t , Monad m ) => BuildFieldResolver m (EnumArgument (API.Argument ksK (API.Enum name t)) f) where diff --git a/src/GraphQL/Value/FromValue.hs b/src/GraphQL/Value/FromValue.hs --- a/src/GraphQL/Value/FromValue.hs +++ b/src/GraphQL/Value/FromValue.hs @@ -132,4 +132,4 @@ instance forall l r m. ( TypeError ('Text "Generic fromValue only works for records with exactly one data constructor.") ) => GenericFromValue (D1 m (l :+: r)) where - genericFromValue = undefined + genericFromValue = panic "genericFromValue cannot be called for records with more than one data constructor. Code that tries will not be compiled." diff --git a/tests/ASTTests.hs b/tests/ASTTests.hs --- a/tests/ASTTests.hs +++ b/tests/ASTTests.hs @@ -78,7 +78,7 @@ output `shouldBe` "[1.5,1.5]" parseOnly Parser.value output `shouldBe` Right input describe "Parser" $ do - it "parses anonymous query documents" $ do + it "parses shorthand syntax documents" $ do let query = [r|{ dog { name @@ -96,6 +96,25 @@ ] parsed `shouldBe` expected + it "parses anonymous query documents" $ do + let query = [r|query { + dog { + name + } + }|] + let Right parsed = parseOnly Parser.queryDocument query + let expected = AST.QueryDocument + [ AST.DefinitionOperation + (AST.Query + (AST.Node Nothing [] [] + [ AST.SelectionField + (AST.Field Nothing dog [] [] + [ AST.SelectionField (AST.Field Nothing someName [] [] []) + ]) + ])) + ] + parsed `shouldBe` expected + it "parses invalid documents" $ do let query = [r|{ dog { @@ -121,7 +140,7 @@ ]) , AST.DefinitionOperation (AST.Query - (AST.Node "getName" [] [] + (AST.Node (pure "getName") [] [] [ AST.SelectionField (AST.Field Nothing dog [] [] [ AST.SelectionField @@ -145,7 +164,37 @@ let expected = AST.QueryDocument [ AST.DefinitionOperation (AST.Query - (AST.Node "houseTrainedQuery" + (AST.Node (pure "houseTrainedQuery") + [ AST.VariableDefinition + (AST.Variable "atOtherHomes") + (AST.TypeNamed (AST.NamedType "Boolean")) + (Just (AST.ValueBoolean True)) + ] [] + [ AST.SelectionField + (AST.Field Nothing dog [] [] + [ AST.SelectionField + (AST.Field Nothing "isHousetrained" + [ AST.Argument "atOtherHomes" + (AST.ValueVariable (AST.Variable "atOtherHomes")) + ] [] []) + ]) + ])) + ] + parsed `shouldBe` expected + + it "parses anonymous query with variables" $ do + let query = [r| + query ($atOtherHomes: Boolean = true) { + dog { + isHousetrained(atOtherHomes: $atOtherHomes) + } + } + |] + let Right parsed = parseOnly Parser.queryDocument query + let expected = AST.QueryDocument + [ AST.DefinitionOperation + (AST.Query + (AST.Node Nothing [ AST.VariableDefinition (AST.Variable "atOtherHomes") (AST.TypeNamed (AST.NamedType "Boolean")) diff --git a/tests/Doctests.hs b/tests/Doctests.hs deleted file mode 100644 --- a/tests/Doctests.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Main (main) where - -import Protolude - -import Test.DocTest - -main :: IO () -main = doctest $ ["-isrc"] <> options <> files - where - options = map ("-X" <>) extensions - -- These must match the extensions in package.yaml. - extensions = [ "NoImplicitPrelude" - , "OverloadedStrings" - , "RecordWildCards" - , "TypeApplications" - , "DataKinds" - ] - -- library code and examples - files = [ "src/" - , "tests/Examples/" - ] diff --git a/tests/EnumTests.hs b/tests/EnumTests.hs --- a/tests/EnumTests.hs +++ b/tests/EnumTests.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} -module EnumTests () where +module EnumTests ( Mode(Directory, NormalFile, ExecutableFile, Symlink) ) where import Protolude hiding (Enum) diff --git a/tests/ExampleSchema.hs b/tests/ExampleSchema.hs --- a/tests/ExampleSchema.hs +++ b/tests/ExampleSchema.hs @@ -85,10 +85,8 @@ , Interface , Union , (:>) + , Defaultable(..) ) --- XXX: This really shouldn't be part of Resolver, since whether or not a --- thing has a default is part of the API / Schema definition. -import GraphQL.Resolver (Defaultable(..)) import GraphQL.Value (pattern ValueEnum, unName) import GraphQL.Value.ToValue (ToValue(..)) diff --git a/tests/Examples/InputObject.hs b/tests/Examples/InputObject.hs --- a/tests/Examples/InputObject.hs +++ b/tests/Examples/InputObject.hs @@ -7,7 +7,7 @@ import GraphQL import GraphQL.API -import GraphQL.Resolver (Handler, Defaultable(..)) +import GraphQL.Resolver (Handler) import GraphQL.Value.FromValue (FromValue) data DogStuff = DogStuff { toy :: Text, likesTreats :: Bool } deriving (Show, Generic) diff --git a/tests/ResolverTests.hs b/tests/ResolverTests.hs --- a/tests/ResolverTests.hs +++ b/tests/ResolverTests.hs @@ -17,6 +17,7 @@ ( Object , Field , Argument + , Enum , (:>) ) import GraphQL.Resolver @@ -26,6 +27,8 @@ ) import GraphQL.Internal.Output (singleError) +import EnumTests ( Mode(NormalFile) ) + -- Test a custom error monad type TMonad = ExceptT Text IO type T = Object "T" '[] '[ Field "z" Int32 @@ -63,7 +66,14 @@ -- have to wrap the result in a pure. sequence $ fmap (pure . viewFoo) foo +-- Enum test +type EnumQuery = Object "File" '[] + '[ Field "mode" (Enum "modeEnumName" Mode) ] +enumHandler :: Handler IO EnumQuery +enumHandler = pure $ pure NormalFile +-- /Enum test + tests :: IO TestTree tests = testSpec "TypeAPI" $ do describe "tTest" $ do @@ -80,3 +90,7 @@ it "Just works" $ do Success object <- interpretAnonymousQuery @Query handler "{ test(id: \"10\") { name } }" encode object `shouldBe` "{\"test\":{\"name\":\"Mort\"}}" + describe "Parse, validate and execute queries against API" $ do + it "API.Enum works" $ do + Success object <- interpretAnonymousQuery @EnumQuery enumHandler "{ mode }" + encode object `shouldBe` "{\"mode\":\"NormalFile\"}" diff --git a/tests/SchemaTests.hs b/tests/SchemaTests.hs --- a/tests/SchemaTests.hs +++ b/tests/SchemaTests.hs @@ -27,7 +27,7 @@ , AnnotatedType(..) , ListType(..) , UnionTypeDefinition(..) - , Type(..) + , GType(..) , TypeDefinition(..) , NonNullType(..) , Builtin(..) diff --git a/tests/ValidationTests.hs b/tests/ValidationTests.hs --- a/tests/ValidationTests.hs +++ b/tests/ValidationTests.hs @@ -19,16 +19,19 @@ , getErrors ) -me :: Name -me = "me" +me :: Maybe Name +me = pure "me" someName :: Name someName = "name" +dog :: Name +dog = "dog" + -- | Schema used for these tests. Since none of them do type-level stuff, we -- don't need to define it. schema :: Schema -schema = undefined +schema = panic "schema evaluated. We weren't expecting that." tests :: IO TestTree tests = testSpec "Validation" $ do @@ -42,6 +45,41 @@ ] ) ) + ] + getErrors schema doc `shouldBe` [] + + it "Treats anonymous queries as valid" $ do + let doc = AST.QueryDocument + [ AST.DefinitionOperation + (AST.Query + (AST.Node (Nothing) [] [] + [ AST.SelectionField + (AST.Field Nothing dog [] [] + [ AST.SelectionField (AST.Field Nothing someName [] [] []) + ]) + ])) + ] + getErrors schema doc `shouldBe` [] + + it "Treats anonymous queries with variables as valid" $ do + let doc = AST.QueryDocument + [ AST.DefinitionOperation + (AST.Query + (AST.Node Nothing + [ AST.VariableDefinition + (AST.Variable "atOtherHomes") + (AST.TypeNamed (AST.NamedType "Boolean")) + (Just (AST.ValueBoolean True)) + ] [] + [ AST.SelectionField + (AST.Field Nothing dog [] [] + [ AST.SelectionField + (AST.Field Nothing "isHousetrained" + [ AST.Argument "atOtherHomes" + (AST.ValueVariable (AST.Variable "atOtherHomes")) + ] [] []) + ]) + ])) ] getErrors schema doc `shouldBe` [] diff --git a/tests/doctests/Main.hs b/tests/doctests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/doctests/Main.hs @@ -0,0 +1,21 @@ +module Main (main) where + +import Protolude + +import Test.DocTest + +main :: IO () +main = doctest $ ["-isrc"] <> options <> files + where + options = map ("-X" <>) extensions + -- These must match the extensions in package.yaml. + extensions = [ "NoImplicitPrelude" + , "OverloadedStrings" + , "RecordWildCards" + , "TypeApplications" + , "DataKinds" + ] + -- library code and examples + files = [ "src/" + , "tests/Examples/" + ]