diff --git a/CHANGELOG.rst b/CHANGELOG.rst --- a/CHANGELOG.rst +++ b/CHANGELOG.rst @@ -2,6 +2,13 @@ graphql-api changelog ===================== +0.4.0 (2019-10-15) +================== + +* Schemas that have empty field lists or empty unions will fail much earlier +* [breaking change] allow user-supplied handlers to emit errors (#224) +* Better compile-time error reporting + 0.3.0 (2018-02-08) ================== @@ -12,6 +19,8 @@ * 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`_) +* ``GraphQL.Value.ToValue`` and ``GraphQL.Value.FromValue`` modules have been removed. + Import ``ToValue(..)`` and ``FromValue(..)`` from ``GraphQL.Value`` directly. Improvements ------------ diff --git a/examples/InputObject.hs b/examples/InputObject.hs new file mode 100644 --- /dev/null +++ b/examples/InputObject.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} + +-- | Demonstrate input object usage. +module Main (main) where + +import Protolude hiding (Enum) + +import qualified Data.Aeson as Aeson + +import GraphQL +import GraphQL.API +import GraphQL.Resolver (Handler, returns) +import GraphQL.Value (FromValue, toValue) + +data DogStuff = DogStuff { _toy :: Text, _likesTreats :: Bool } deriving (Show, Generic) +instance FromValue DogStuff +instance HasAnnotatedInputType DogStuff +instance Defaultable DogStuff where + -- TODO defaultFor takes a Name which makes sense, but what's the + -- name for an input object? + defaultFor _ = Just (DogStuff "shoe" False) + +type Query = Object "Query" '[] + '[ Argument "dogStuff" DogStuff :> Field "description" Text ] + +root :: Handler IO Query +root = pure description + +description :: DogStuff -> Handler IO Text +description (DogStuff toy likesTreats) + | likesTreats = returns $ "likes treats and their favorite toy is a " <> toy + | otherwise = returns $ "their favorite toy is a " <> toy + +-- | Show input object usage +-- +-- >>> response <- example "{ description(dogStuff: {toy: \"bone\", likesTreats: true}) }" +-- >>> putStrLn $ encode $ toValue response +-- {"data":{"description":"likes treats and their favorite toy is a bone"}} +-- +-- >>> response <- example "{ description }" +-- >>> putStrLn $ encode $ toValue response +-- {"data":{"description":"their favorite toy is a shoe"}} +example :: Text -> IO Response +example = interpretAnonymousQuery @Query root + + +main :: IO () +main = do + response <- example "{ description(dogStuff: {_toy: \"bone\", _likesTreats: true}) }" + putStrLn $ Aeson.encode $ toValue response + response' <- example "{ description }" + putStrLn $ Aeson.encode $ toValue response' diff --git a/examples/UnionExample.hs b/examples/UnionExample.hs new file mode 100644 --- /dev/null +++ b/examples/UnionExample.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DataKinds #-} +module Main (main) where + +import Protolude + +import qualified Data.Aeson as Aeson +import GraphQL.API (Field, List, Object, Union) +import GraphQL (interpretAnonymousQuery) +import GraphQL.Resolver (Handler, (:<>)(..), unionValue, returns) +import GraphQL.Value (ToValue(..)) + +-- Slightly reduced example from the spec +type MiniCat = Object "MiniCat" '[] '[Field "name" Text, Field "meowVolume" Int32] +type MiniDog = Object "MiniDog" '[] '[Field "barkVolume" Int32] + +type CatOrDog = Object "Me" '[] '[Field "myPet" (Union "CatOrDog" '[MiniCat, MiniDog])] +type CatOrDogList = Object "CatOrDogList" '[] '[Field "pets" (List (Union "CatOrDog" '[MiniCat, MiniDog]))] + +miniCat :: Text -> Handler IO MiniCat +miniCat name = pure (returns name :<> returns 32) + +miniDog :: Handler IO MiniDog +miniDog = pure (returns 100) + +catOrDog :: Handler IO CatOrDog +catOrDog = pure $ do + name <- pure "MonadicFelix" -- we can do monadic actions + unionValue @MiniCat (miniCat name) + +catOrDogList :: Handler IO CatOrDogList +catOrDogList = pure $ + returns [ unionValue @MiniCat (miniCat "Felix") + , unionValue @MiniCat (miniCat "Mini") + , unionValue @MiniDog miniDog + ] + +main :: IO () +main = do + response <- interpretAnonymousQuery @CatOrDog catOrDog "{ myPet { ... on MiniCat { name meowVolume } ... on MiniDog { barkVolume } } }" + putStrLn $ Aeson.encode $ toValue response + response' <- interpretAnonymousQuery @CatOrDogList catOrDogList "{ pets { ... on MiniCat { name meowVolume } ... on MiniDog { barkVolume } } }" + putStrLn $ Aeson.encode $ toValue response' diff --git a/graphql-api.cabal b/graphql-api.cabal --- a/graphql-api.cabal +++ b/graphql-api.cabal @@ -1,11 +1,13 @@ --- This file has been generated from package.yaml by hpack version 0.20.0. +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.2. -- -- see: https://github.com/sol/hpack -- --- hash: 2160ff0226a0b10f7166ddbcf09ec6f79dfddfd66c81244898fb1afabe36bcf8 +-- hash: 39720cafd3fe95e5c20d8064aaddbffaa16071fb08720ffc587d4d48228deec8 name: graphql-api -version: 0.3.0 +version: 0.4.0 synopsis: GraphQL API description: Implement [GraphQL](http://graphql.org/) servers in Haskell. . @@ -22,8 +24,6 @@ license: Apache license-file: LICENSE.Apache-2.0 build-type: Simple -cabal-version: >= 1.10 - extra-source-files: CHANGELOG.rst @@ -51,26 +51,61 @@ exposed-modules: GraphQL GraphQL.API - GraphQL.API.Enum + GraphQL.Internal.API + GraphQL.Internal.API.Enum GraphQL.Internal.Arbitrary GraphQL.Internal.Execution GraphQL.Internal.Name GraphQL.Internal.OrderedMap GraphQL.Internal.Output + GraphQL.Internal.Resolver GraphQL.Internal.Schema GraphQL.Internal.Syntax.AST GraphQL.Internal.Syntax.Encoder GraphQL.Internal.Syntax.Parser GraphQL.Internal.Syntax.Tokens GraphQL.Internal.Validation + GraphQL.Internal.Value + GraphQL.Internal.Value.FromValue + GraphQL.Internal.Value.ToValue GraphQL.Resolver GraphQL.Value - GraphQL.Value.FromValue - GraphQL.Value.ToValue other-modules: Paths_graphql_api default-language: Haskell2010 +executable input-object-example + main-is: InputObject.hs + hs-source-dirs: + examples + default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications + ghc-options: -Wall -fno-warn-redundant-constraints + build-depends: + aeson + , attoparsec + , base >=4.9 && <5 + , exceptions + , graphql-api + , protolude >=0.2.1 + , transformers + default-language: Haskell2010 + +executable union-example + main-is: UnionExample.hs + hs-source-dirs: + examples + default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications + ghc-options: -Wall -fno-warn-redundant-constraints + build-depends: + aeson + , attoparsec + , base >=4.9 && <5 + , exceptions + , graphql-api + , protolude >=0.2.1 + , transformers + default-language: Haskell2010 + test-suite graphql-api-doctests type: exitcode-stdio-1.0 main-is: Main.hs @@ -91,7 +126,7 @@ test-suite graphql-api-tests type: exitcode-stdio-1.0 - main-is: Spec.hs + main-is: Main.hs hs-source-dirs: tests default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications @@ -108,21 +143,18 @@ , hspec , protolude >=0.2.1 , raw-strings-qq - , tasty - , tasty-hspec , transformers other-modules: - ASTTests - EndToEndTests + ASTSpec + EndToEndSpec EnumTests - Examples.InputObject - Examples.UnionExample ExampleSchema - OrderedMapTests - ResolverTests - SchemaTests - ValidationTests - ValueTests + OrderedMapSpec + ResolverSpec + SchemaSpec + Spec + ValidationSpec + ValueSpec Paths_graphql_api default-language: Haskell2010 diff --git a/src/GraphQL.hs b/src/GraphQL.hs --- a/src/GraphQL.hs +++ b/src/GraphQL.hs @@ -1,7 +1,9 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} -- | Interface for GraphQL API. -- -- __Note__: This module is highly subject to change. We're still figuring @@ -27,7 +29,7 @@ import Data.Attoparsec.Text (parseOnly, endOfInput) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty -import GraphQL.API (HasObjectDefinition(..)) +import GraphQL.API (HasObjectDefinition(..), Object, SchemaError(..)) import GraphQL.Internal.Execution ( VariableValues , ExecutionError @@ -51,8 +53,13 @@ ) import GraphQL.Internal.Schema (Schema) import qualified GraphQL.Internal.Schema as Schema -import GraphQL.Resolver (HasResolver(..), Result(..)) -import GraphQL.Value (Name, NameError, Value, pattern ValueObject) +import GraphQL.Resolver + ( HasResolver(..) + , OperationResolverConstraint + , Result(..) + , resolveOperation + ) +import GraphQL.Value (Name, Value) -- | Errors that can happen while processing a query document. data QueryError @@ -66,7 +73,7 @@ -- | Validated, but failed during execution. | ExecutionError ExecutionError -- | Error in the schema. - | SchemaError NameError + | SchemaError SchemaError -- | Got a value that wasn't an object. | NonObjectResult Value deriving (Eq, Show) @@ -85,7 +92,10 @@ -- | Execute a GraphQL query. executeQuery - :: forall api m. (HasResolver m api, Applicative m, HasObjectDefinition api) + :: forall api m fields typeName interfaces. + ( Object typeName interfaces fields ~ api + , OperationResolverConstraint m fields typeName interfaces + ) => Handler m api -- ^ Handler for the query. This links the query to the code you've written to handle it. -> QueryDocument VariableValue -- ^ A validated query document. Build one with 'compileQuery'. -> Maybe Name -- ^ An optional name. If 'Nothing', then executes the only operation in the query. If @Just "something"@, executes the query named @"something". @@ -94,17 +104,14 @@ executeQuery handler document name variables = case getOperation document name variables of Left e -> pure (ExecutionFailure (singleError e)) - Right operation -> toResult <$> resolve @m @api handler (Just operation) + Right operation -> + toResult + <$> resolveOperation @m @fields @typeName @interfaces handler operation where - toResult (Result errors result) = - case result of - -- TODO: Prevent this at compile time. Particularly frustrating since - -- we *know* that api has an object definition. - ValueObject object -> - case NonEmpty.nonEmpty errors of - Nothing -> Success object - Just errs -> PartialSuccess object (map toError errs) - v -> ExecutionFailure (singleError (NonObjectResult v)) + toResult (Result errors object) = + case NonEmpty.nonEmpty errors of + Nothing -> Success object + Just errs -> PartialSuccess object (map toError errs) -- | Create a GraphQL schema. makeSchema :: forall api. HasObjectDefinition api => Either QueryError Schema @@ -114,7 +121,10 @@ -- -- Compiles then executes a GraphQL query. interpretQuery - :: forall api m. (Applicative m, HasResolver m api, HasObjectDefinition api) + :: forall api m fields typeName interfaces. + ( Object typeName interfaces fields ~ api + , OperationResolverConstraint m fields typeName interfaces + ) => Handler m api -- ^ Handler for the query. This links the query to the code you've written to handle it. -> Text -- ^ The text of a query document. Will be parsed and then executed. -> Maybe Name -- ^ An optional name for the operation within document to run. If 'Nothing', execute the only operation in the document. If @Just "something"@, execute the query or mutation named @"something"@. @@ -129,7 +139,10 @@ -- -- Anonymous queries have no name and take no variables. interpretAnonymousQuery - :: forall api m. (Applicative m, HasResolver m api, HasObjectDefinition api) + :: forall api m fields typeName interfaces. + ( Object typeName interfaces fields ~ api + , OperationResolverConstraint m fields typeName interfaces + ) => Handler m api -- ^ Handler for the anonymous query. -> Text -- ^ The text of the anonymous query. Should defined only a single, unnamed query operation. -> m Response -- ^ The result of running the query. diff --git a/src/GraphQL/API.hs b/src/GraphQL/API.hs --- a/src/GraphQL/API.hs +++ b/src/GraphQL/API.hs @@ -1,16 +1,6 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - --- | Type-level definitions for a GraphQL schema. +-- | Description: Define a GraphQL schema with Haskell types +-- +-- Use this to define your GraphQL schema with Haskell types. module GraphQL.API ( Object , Field @@ -22,345 +12,23 @@ , Interface , (:>)(..) , Defaultable(..) - , HasAnnotatedType(..) - , HasAnnotatedInputType , HasObjectDefinition(..) - , getArgumentDefinition - -- | Exported for testing. Perhaps should be a different module. - , getFieldDefinition - , getInterfaceDefinition - , getAnnotatedInputType + , HasAnnotatedInputType(..) + , SchemaError(..) ) where -import Protolude hiding (Enum, TypeError) - -import GHC.TypeLits (Symbol, KnownSymbol, TypeError, ErrorMessage(..)) -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) - - --- $setup --- >>> :set -XDataKinds -XTypeOperators - --- | Argument operator. Can only be used with 'Field'. --- --- Say we have a @Company@ object that has a field that shows whether --- someone is an employee, e.g. --- --- @ --- type Company { --- hasEmployee(employeeName: String!): String! --- } --- @ --- --- Then we might represent that as: --- --- >>> type Company = Object "Company" '[] '[Argument "employeeName" Text :> Field "hasEmployee" Bool] --- --- For multiple arguments, simply chain them together with ':>', ending --- finally with 'Field'. e.g. --- --- @ --- Argument "foo" String :> Argument "bar" Int :> Field "qux" Int --- @ -data a :> b = a :> b -infixr 8 :> - - -data Object (name :: Symbol) (interfaces :: [Type]) (fields :: [Type]) -data Enum (name :: Symbol) (values :: Type) -data Union (name :: Symbol) (types :: [Type]) -data List (elemType :: Type) - --- TODO(tom): AFACIT We can't constrain "fields" to e.g. have at least --- one field in it - is this a problem? -data Interface (name :: Symbol) (fields :: [Type]) -data Field (name :: Symbol) (fieldType :: Type) -data Argument (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 Schema.ObjectTypeDefinition - -class HasFieldDefinition a where - getFieldDefinition :: Either NameError Schema.FieldDefinition - - --- Fields -class HasFieldDefinitions a where - getFieldDefinitions :: Either NameError [Schema.FieldDefinition] - -instance forall a as. (HasFieldDefinition a, HasFieldDefinitions as) => HasFieldDefinitions (a:as) where - getFieldDefinitions = cons <$> getFieldDefinition @a <*> getFieldDefinitions @as - -instance HasFieldDefinitions '[] where - getFieldDefinitions = pure [] - - --- object types from union type lists, e.g. for --- Union "Horse" '[Leg, Head, Tail] --- ^^^^^^^^^^^^^^^^^^ this part -class HasUnionTypeObjectTypeDefinitions a where - getUnionTypeObjectTypeDefinitions :: Either NameError [Schema.ObjectTypeDefinition] - -instance forall a as. (HasObjectDefinition a, HasUnionTypeObjectTypeDefinitions as) => HasUnionTypeObjectTypeDefinitions (a:as) where - getUnionTypeObjectTypeDefinitions = cons <$> getDefinition @a <*> getUnionTypeObjectTypeDefinitions @as - -instance HasUnionTypeObjectTypeDefinitions '[] where - getUnionTypeObjectTypeDefinitions = pure [] - --- Interfaces -class HasInterfaceDefinitions a where - getInterfaceDefinitions :: Either NameError Schema.Interfaces - -instance forall a as. (HasInterfaceDefinition a, HasInterfaceDefinitions as) => HasInterfaceDefinitions (a:as) where - getInterfaceDefinitions = cons <$> getInterfaceDefinition @a <*> getInterfaceDefinitions @as - -instance HasInterfaceDefinitions '[] where - getInterfaceDefinitions = pure [] - -class HasInterfaceDefinition a where - getInterfaceDefinition :: Either NameError Schema.InterfaceTypeDefinition - -instance forall ks fields. (KnownSymbol ks, HasFieldDefinitions fields) => HasInterfaceDefinition (Interface ks fields) where - getInterfaceDefinition = - let name = nameFromSymbol @ks - 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 = 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 (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 Schema.FieldDefinition <$> name <*> pure [] <*> getAnnotatedType @t - -class HasArgumentDefinition a where - getArgumentDefinition :: Either NameError Schema.ArgumentDefinition - -instance forall ks t. (KnownSymbol ks, HasAnnotatedInputType t) => HasArgumentDefinition (Argument ks t) where - getArgumentDefinition = Schema.ArgumentDefinition <$> argName <*> argType <*> defaultValue - where - argName = nameFromSymbol @ks - argType = getAnnotatedInputType @t - defaultValue = pure Nothing - -instance forall a b. (HasArgumentDefinition a, HasFieldDefinition b) => HasFieldDefinition (a :> b) where - getFieldDefinition = - prependArg <$> argument <*> getFieldDefinition @b - where - prependArg arg (Schema.FieldDefinition name argDefs at) = Schema.FieldDefinition name (arg:argDefs) at - argument = getArgumentDefinition @a - -instance forall ks is fields. - (KnownSymbol ks, HasInterfaceDefinitions is, HasFieldDefinitions fields) => - HasObjectDefinition (Object ks is fields) where - getDefinition = - let name = nameFromSymbol @ks - interfaces = getInterfaceDefinitions @is - fields = Schema.NonEmptyList <$> getFieldDefinitions @fields - in Schema.ObjectTypeDefinition <$> name <*> interfaces <*> fields - --- Builtin output types (annotated types) -class HasAnnotatedType a where - -- TODO - the fact that we have to return TypeNonNull for normal - -- types will amost certainly lead to bugs because people will - -- 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 (Schema.AnnotatedType Schema.GType) - --- | Turn a non-null type into the optional version of its own type. -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 :: 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 --- class. - --- TODO(jml): Be smarter and figure out how to say "all integral types" rather --- than listing each individually. - -instance HasAnnotatedType Int where - getAnnotatedType = builtinType Schema.GInt - -instance HasAnnotatedType Int32 where - getAnnotatedType = builtinType Schema.GInt - -instance HasAnnotatedType Bool where - getAnnotatedType = builtinType Schema.GBool - -instance HasAnnotatedType Text where - getAnnotatedType = builtinType Schema.GString - -instance HasAnnotatedType Double where - getAnnotatedType = builtinType Schema.GFloat - -instance HasAnnotatedType Float where - getAnnotatedType = builtinType Schema.GFloat - -instance forall t. (HasAnnotatedType t) => HasAnnotatedType (List t) where - 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 [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, HasUnionTypeObjectTypeDefinitions as) => HasAnnotatedType (Union ks as) where - getAnnotatedType = - let name = nameFromSymbol @ks - 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 = 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 (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 :: Schema.Builtin -> Either NameError (Schema.AnnotatedType Schema.InputType) -builtinInputType = pure . Schema.TypeNonNull . Schema.NonNullTypeNamed . Schema.BuiltinInputType - -instance HasAnnotatedInputType Int where - getAnnotatedInputType = builtinInputType Schema.GInt - -instance HasAnnotatedInputType Int32 where - getAnnotatedInputType = builtinInputType Schema.GInt - -instance HasAnnotatedInputType Bool where - getAnnotatedInputType = builtinInputType Schema.GBool - -instance HasAnnotatedInputType Text where - getAnnotatedInputType = builtinInputType Schema.GString - -instance HasAnnotatedInputType Double where - getAnnotatedInputType = builtinInputType Schema.GFloat - -instance HasAnnotatedInputType Float where - getAnnotatedInputType = builtinInputType Schema.GFloat - -instance forall t. (HasAnnotatedInputType t) => HasAnnotatedInputType (List t) where - 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 [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 (Schema.AnnotatedType Schema.InputType) - -class GenericInputObjectFieldDefinitions (f :: Type -> Type) where - genericGetInputObjectFieldDefinitions :: Either NameError [Schema.InputObjectFieldDefinition] - -instance forall dataName consName records s l p. - ( KnownSymbol dataName - , KnownSymbol consName - , GenericInputObjectFieldDefinitions records - ) => GenericAnnotatedInputType (D1 ('MetaData dataName s l 'False) - (C1 ('MetaCons consName p 'True) records - )) where - genericGetAnnotatedInputType = do - name <- nameFromSymbol @dataName - map ( Schema.TypeNonNull - . Schema.NonNullTypeNamed - . Schema.DefinedInputType - . Schema.InputTypeDefinitionObject - . Schema.InputObjectTypeDefinition name - . Schema.NonEmptyList - ) (genericGetInputObjectFieldDefinitions @records) - -instance forall wrappedType fieldName rest u s l. - ( KnownSymbol fieldName - , HasAnnotatedInputType wrappedType - , GenericInputObjectFieldDefinitions rest - ) => GenericInputObjectFieldDefinitions (S1 ('MetaSel ('Just fieldName) u s l) (Rec0 wrappedType) :*: rest) where - genericGetInputObjectFieldDefinitions = do - name <- nameFromSymbol @fieldName - annotatedInputType <- getAnnotatedInputType @wrappedType - let l = Schema.InputObjectFieldDefinition name annotatedInputType Nothing - r <- genericGetInputObjectFieldDefinitions @rest - pure (l:r) - -instance forall wrappedType fieldName u s l. - ( KnownSymbol fieldName - , HasAnnotatedInputType wrappedType - ) => GenericInputObjectFieldDefinitions (S1 ('MetaSel ('Just fieldName) u s l) (Rec0 wrappedType)) where - genericGetInputObjectFieldDefinitions = do - name <- nameFromSymbol @fieldName - annotatedInputType <- getAnnotatedInputType @wrappedType - let l = Schema.InputObjectFieldDefinition name annotatedInputType Nothing - pure [l] +import GraphQL.Internal.API + ( Object + , Field + , Argument + , Union + , List + , Enum + , GraphQLEnum(..) + , Interface + , (:>)(..) + , Defaultable(..) + , HasObjectDefinition(..) + , HasAnnotatedInputType(..) + , SchemaError(..) + ) diff --git a/src/GraphQL/API/Enum.hs b/src/GraphQL/API/Enum.hs deleted file mode 100644 --- a/src/GraphQL/API/Enum.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module GraphQL.API.Enum - ( GraphQLEnum(..) - ) where - -import Protolude hiding (Enum, TypeError) -import GraphQL.Internal.Name (Name, nameFromSymbol, NameError) -import GraphQL.Internal.Output (GraphQLError(..)) -import GHC.Generics (D, (:+:)(..)) -import GHC.TypeLits (KnownSymbol, TypeError, ErrorMessage(..)) -import GHC.Types (Type) - -invalidEnumName :: forall t. NameError -> Either Text t -invalidEnumName x = Left ("In Enum: " <> formatError x) - --- TODO: Enums have a slightly more restricted set of names than 'Name' --- implies. Especially, they cannot be 'true', 'false', or 'nil'. The parser --- /probably/ guarantees this, so it should export this guarantee by providing --- an 'Enum' type. - -class GenericEnumValues (f :: Type -> Type) where - genericEnumValues :: [Either NameError Name] - -- XXX: Why is this 'Text' and not 'NameError'? - genericEnumFromValue :: Name -> Either Text (f p) - genericEnumToValue :: f p -> Name - -instance forall conName m p f nt. - ( KnownSymbol conName - , KnownSymbol m - , KnownSymbol p - , GenericEnumValues f - ) => GenericEnumValues (M1 D ('MetaData conName m p nt) f) where - genericEnumValues = genericEnumValues @f - genericEnumFromValue name = M1 <$> genericEnumFromValue name - genericEnumToValue (M1 gv) = genericEnumToValue gv - -instance forall left right. - ( GenericEnumValues left - , GenericEnumValues right - ) => GenericEnumValues (left :+: right) where - genericEnumValues = genericEnumValues @left <> genericEnumValues @right - genericEnumFromValue vname = - let left = genericEnumFromValue @left vname - right = genericEnumFromValue @right vname - in case (left, right) of - (x@(Right _), Left _) -> L1 <$> x - (Left _, x@(Right _)) -> R1 <$> x - (err@(Left _), Left _) -> L1 <$> err - _ -> panic "Can't have two successful branches in Haskell" - - genericEnumToValue (L1 gv) = genericEnumToValue gv - genericEnumToValue (R1 gv) = genericEnumToValue gv - -instance forall conName p b. (KnownSymbol conName) => GenericEnumValues (C1 ('MetaCons conName p b) U1) where - genericEnumValues = let name = nameFromSymbol @conName in [name] - genericEnumFromValue vname = - case nameFromSymbol @conName of - Right name -> if name == vname - then Right (M1 U1) - else Left ("Not a valid choice for enum: " <> show vname) - -- XXX: This is impossible to catch during validation, because we cannot - -- validate type-level symbols, we can only validate values. We could - -- show that the schema is invalid at the type-level and still decide to - -- call this anyway. The error should rather say that the schema is - -- invalid. - -- - -- Further, we don't actually have any schema-level validation, so - -- "should have been caught during validation" is misleading. - Left x -> invalidEnumName x - genericEnumToValue (M1 _) = - let Right name = nameFromSymbol @conName - in name - --- TODO(tom): better type errors using `n`. Also type errors for other --- invalid constructors. -instance forall conName p b sa sb. - ( TypeError ('Text "Constructor not unary: " ':<>: 'Text conName) - , KnownSymbol conName - ) => GenericEnumValues (C1 ('MetaCons conName p b) (S1 sa sb)) where - 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 = 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. --- --- TODO: Update this comment to explain what a GraphQLEnum is, why you might --- want an instance, and any laws that apply to method relations. -class GraphQLEnum a where - -- TODO: Document each of these methods. - enumValues :: [Either NameError Name] - default enumValues :: (Generic a, GenericEnumValues (Rep a)) => [Either NameError Name] - enumValues = genericEnumValues @(Rep a) - - enumFromValue :: Name -> Either Text a - default enumFromValue :: (Generic a, GenericEnumValues (Rep a)) => Name -> Either Text a - enumFromValue v = to <$> genericEnumFromValue v - - enumToValue :: a -> Name - default enumToValue :: (Generic a, GenericEnumValues (Rep a)) => a -> Name - enumToValue = genericEnumToValue . from diff --git a/src/GraphQL/Internal/API.hs b/src/GraphQL/Internal/API.hs new file mode 100644 --- /dev/null +++ b/src/GraphQL/Internal/API.hs @@ -0,0 +1,395 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | Description: Define a GraphQL schema with Haskell types +module GraphQL.Internal.API + ( Object + , Field + , Argument + , Union + , List + , Enum + , GraphQLEnum(..) + , Interface + , (:>)(..) + , Defaultable(..) + , HasAnnotatedType(..) + , HasAnnotatedInputType + , HasObjectDefinition(..) + , getArgumentDefinition + , SchemaError(..) + , nameFromSymbol + -- | Exported for testing. + , getFieldDefinition + , getInterfaceDefinition + , getAnnotatedInputType + ) where + +import Protolude hiding (Enum, TypeError) + +import qualified Data.List.NonEmpty as NonEmpty +import Data.Semigroup as S ((<>)) +import GHC.Generics ((:*:)(..)) +import GHC.TypeLits (Symbol, KnownSymbol, TypeError, ErrorMessage(..)) +import GHC.Types (Type) + +import qualified GraphQL.Internal.Schema as Schema +import qualified GraphQL.Internal.Name as Name +import GraphQL.Internal.Name (Name, NameError) +import GraphQL.Internal.API.Enum (GraphQLEnum(..)) +import GraphQL.Internal.Output (GraphQLError(..)) + +-- $setup +-- >>> :set -XDataKinds -XTypeOperators + +-- | Argument operator. Can only be used with 'Field'. +-- +-- Say we have a @Company@ object that has a field that shows whether +-- someone is an employee, e.g. +-- +-- @ +-- type Company { +-- hasEmployee(employeeName: String!): String! +-- } +-- @ +-- +-- Then we might represent that as: +-- +-- >>> type Company = Object "Company" '[] '[Argument "employeeName" Text :> Field "hasEmployee" Bool] +-- +-- For multiple arguments, simply chain them together with ':>', ending +-- finally with 'Field'. e.g. +-- +-- @ +-- Argument "foo" String :> Argument "bar" Int :> Field "qux" Int +-- @ +data a :> b = a :> b +infixr 8 :> + + +data Object (name :: Symbol) (interfaces :: [Type]) (fields :: [Type]) +data Enum (name :: Symbol) (values :: Type) +data Union (name :: Symbol) (types :: [Type]) +data List (elemType :: Type) + +-- TODO(tom): AFACIT We can't constrain "fields" to e.g. have at least +-- one field in it - is this a problem? +data Interface (name :: Symbol) (fields :: [Type]) +data Field (name :: Symbol) (fieldType :: Type) +data Argument (name :: Symbol) (argType :: Type) + + +-- | The type-level schema was somehow invalid. +data SchemaError + = NameError NameError + | EmptyFieldList + | EmptyUnion + deriving (Eq, Show) + +instance GraphQLError SchemaError where + formatError (NameError err) = formatError err + formatError EmptyFieldList = "Empty field list in type definition" + formatError EmptyUnion = "Empty object list in union" + +nameFromSymbol :: forall (n :: Symbol). KnownSymbol n => Either SchemaError Name +nameFromSymbol = first NameError (Name.nameFromSymbol @n) + +-- | 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 = (:) + +singleton :: a -> NonEmpty a +singleton x = x :| [] + +-- Transform into a Schema definition +class HasObjectDefinition a where + -- Todo rename to getObjectTypeDefinition + getDefinition :: Either SchemaError Schema.ObjectTypeDefinition + +class HasFieldDefinition a where + getFieldDefinition :: Either SchemaError Schema.FieldDefinition + + +-- Fields +class HasFieldDefinitions a where + getFieldDefinitions :: Either SchemaError (NonEmpty Schema.FieldDefinition) + +instance forall a as. (HasFieldDefinition a, HasFieldDefinitions as) => HasFieldDefinitions (a:as) where + getFieldDefinitions = + case getFieldDefinitions @as of + Left EmptyFieldList -> singleton <$> getFieldDefinition @a + Left err -> Left err + Right fields -> NonEmpty.cons <$> getFieldDefinition @a <*> pure fields + +instance HasFieldDefinitions '[] where + getFieldDefinitions = Left EmptyFieldList + + +-- object types from union type lists, e.g. for +-- Union "Horse" '[Leg, Head, Tail] +-- ^^^^^^^^^^^^^^^^^^ this part +class HasUnionTypeObjectTypeDefinitions a where + getUnionTypeObjectTypeDefinitions :: Either SchemaError (NonEmpty Schema.ObjectTypeDefinition) + +instance forall a as. (HasObjectDefinition a, HasUnionTypeObjectTypeDefinitions as) => HasUnionTypeObjectTypeDefinitions (a:as) where + getUnionTypeObjectTypeDefinitions = + case getUnionTypeObjectTypeDefinitions @as of + Left EmptyUnion -> singleton <$> getDefinition @a + Left err -> Left err + Right objects -> NonEmpty.cons <$> getDefinition @a <*> pure objects + +instance HasUnionTypeObjectTypeDefinitions '[] where + getUnionTypeObjectTypeDefinitions = Left EmptyUnion + +-- Interfaces +class HasInterfaceDefinitions a where + getInterfaceDefinitions :: Either SchemaError Schema.Interfaces + +instance forall a as. (HasInterfaceDefinition a, HasInterfaceDefinitions as) => HasInterfaceDefinitions (a:as) where + getInterfaceDefinitions = cons <$> getInterfaceDefinition @a <*> getInterfaceDefinitions @as + +instance HasInterfaceDefinitions '[] where + getInterfaceDefinitions = pure [] + +class HasInterfaceDefinition a where + getInterfaceDefinition :: Either SchemaError Schema.InterfaceTypeDefinition + +instance forall ks fields. (KnownSymbol ks, HasFieldDefinitions fields) => HasInterfaceDefinition (Interface ks fields) where + getInterfaceDefinition = + let name = nameFromSymbol @ks + fields = 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 = 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 (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 Schema.FieldDefinition <$> name <*> pure [] <*> getAnnotatedType @t + +class HasArgumentDefinition a where + getArgumentDefinition :: Either SchemaError Schema.ArgumentDefinition + +instance forall ks t. (KnownSymbol ks, HasAnnotatedInputType t) => HasArgumentDefinition (Argument ks t) where + getArgumentDefinition = Schema.ArgumentDefinition <$> argName <*> argType <*> defaultValue + where + argName = nameFromSymbol @ks + argType = getAnnotatedInputType @t + defaultValue = pure Nothing + +instance forall a b. (HasArgumentDefinition a, HasFieldDefinition b) => HasFieldDefinition (a :> b) where + getFieldDefinition = + prependArg <$> argument <*> getFieldDefinition @b + where + prependArg arg (Schema.FieldDefinition name argDefs at) = Schema.FieldDefinition name (arg:argDefs) at + argument = getArgumentDefinition @a + +instance forall ks is fields. + (KnownSymbol ks, HasInterfaceDefinitions is, HasFieldDefinitions fields) => + HasObjectDefinition (Object ks is fields) where + getDefinition = + let name = nameFromSymbol @ks + interfaces = getInterfaceDefinitions @is + fields = getFieldDefinitions @fields + in Schema.ObjectTypeDefinition <$> name <*> interfaces <*> fields + +-- Builtin output types (annotated types) +class HasAnnotatedType a where + -- TODO - the fact that we have to return TypeNonNull for normal + -- types will amost certainly lead to bugs because people will + -- forget this. Maybe we can flip the internal encoding to be + -- non-null by default and needing explicit null-encoding (via + -- Maybe). + getAnnotatedType :: Either SchemaError (Schema.AnnotatedType Schema.GType) + +-- | Turn a non-null type into the optional version of its own type. +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 :: Schema.Builtin -> Either SchemaError (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 +-- class. + +-- TODO(jml): Be smarter and figure out how to say "all integral types" rather +-- than listing each individually. + +instance HasAnnotatedType Int where + getAnnotatedType = builtinType Schema.GInt + +instance HasAnnotatedType Int32 where + getAnnotatedType = builtinType Schema.GInt + +instance HasAnnotatedType Bool where + getAnnotatedType = builtinType Schema.GBool + +instance HasAnnotatedType Text where + getAnnotatedType = builtinType Schema.GString + +instance HasAnnotatedType Double where + getAnnotatedType = builtinType Schema.GFloat + +instance HasAnnotatedType Float where + getAnnotatedType = builtinType Schema.GFloat + +instance forall t. (HasAnnotatedType t) => HasAnnotatedType (List t) where + 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 [Schema.Name] + let et = Schema.EnumTypeDefinition <$> name <*> map (map Schema.EnumValueDefinition) (first NameError enums) + Schema.TypeNonNull . Schema.NonNullTypeNamed . Schema.DefinedType . Schema.TypeDefinitionEnum <$> et + +instance forall ks as. (KnownSymbol ks, HasUnionTypeObjectTypeDefinitions as) => HasAnnotatedType (Union ks as) where + getAnnotatedType = + let name = nameFromSymbol @ks + types = 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 = 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 SchemaError (Schema.AnnotatedType Schema.InputType) + default getAnnotatedInputType :: (Generic a, GenericAnnotatedInputType (Rep a)) => Either SchemaError (Schema.AnnotatedType Schema.InputType) + getAnnotatedInputType = genericGetAnnotatedInputType @(Rep a) + +instance forall a. HasAnnotatedInputType a => HasAnnotatedInputType (Maybe a) where + getAnnotatedInputType = dropNonNull <$> getAnnotatedInputType @a + +builtinInputType :: Schema.Builtin -> Either SchemaError (Schema.AnnotatedType Schema.InputType) +builtinInputType = pure . Schema.TypeNonNull . Schema.NonNullTypeNamed . Schema.BuiltinInputType + +instance HasAnnotatedInputType Int where + getAnnotatedInputType = builtinInputType Schema.GInt + +instance HasAnnotatedInputType Int32 where + getAnnotatedInputType = builtinInputType Schema.GInt + +instance HasAnnotatedInputType Bool where + getAnnotatedInputType = builtinInputType Schema.GBool + +instance HasAnnotatedInputType Text where + getAnnotatedInputType = builtinInputType Schema.GString + +instance HasAnnotatedInputType Double where + getAnnotatedInputType = builtinInputType Schema.GFloat + +instance HasAnnotatedInputType Float where + getAnnotatedInputType = builtinInputType Schema.GFloat + +instance forall t. (HasAnnotatedInputType t) => HasAnnotatedInputType (List t) where + 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 [Schema.Name] + let et = Schema.EnumTypeDefinition <$> name <*> map (map Schema.EnumValueDefinition) (first NameError enums) + Schema.TypeNonNull . Schema.NonNullTypeNamed . Schema.DefinedInputType . Schema.InputTypeDefinitionEnum <$> et + + +-- Generic getAnnotatedInputType function +class GenericAnnotatedInputType (f :: Type -> Type) where + genericGetAnnotatedInputType :: Either SchemaError (Schema.AnnotatedType Schema.InputType) + +class GenericInputObjectFieldDefinitions (f :: Type -> Type) where + genericGetInputObjectFieldDefinitions :: Either SchemaError (NonEmpty Schema.InputObjectFieldDefinition) + +instance forall dataName consName records s l p. + ( KnownSymbol dataName + , KnownSymbol consName + , GenericInputObjectFieldDefinitions records + ) => GenericAnnotatedInputType (D1 ('MetaData dataName s l 'False) + (C1 ('MetaCons consName p 'True) records + )) where + genericGetAnnotatedInputType = do + name <- nameFromSymbol @dataName + map ( Schema.TypeNonNull + . Schema.NonNullTypeNamed + . Schema.DefinedInputType + . Schema.InputTypeDefinitionObject + . Schema.InputObjectTypeDefinition name + ) (genericGetInputObjectFieldDefinitions @records) + +instance forall a b. + ( GenericInputObjectFieldDefinitions a + , GenericInputObjectFieldDefinitions b + ) => GenericInputObjectFieldDefinitions (a :*: b) where + genericGetInputObjectFieldDefinitions = do + l <- genericGetInputObjectFieldDefinitions @a + r <- genericGetInputObjectFieldDefinitions @b + pure (l S.<> r) + +instance forall wrappedType fieldName u s l. + ( KnownSymbol fieldName + , HasAnnotatedInputType wrappedType + ) => GenericInputObjectFieldDefinitions (S1 ('MetaSel ('Just fieldName) u s l) (Rec0 wrappedType)) where + genericGetInputObjectFieldDefinitions = do + name <- nameFromSymbol @fieldName + annotatedInputType <- getAnnotatedInputType @wrappedType + let l = Schema.InputObjectFieldDefinition name annotatedInputType Nothing + pure (l :| []) diff --git a/src/GraphQL/Internal/API/Enum.hs b/src/GraphQL/Internal/API/Enum.hs new file mode 100644 --- /dev/null +++ b/src/GraphQL/Internal/API/Enum.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | Description: Define GraphQL Enums with Haskell types +module GraphQL.Internal.API.Enum + ( GraphQLEnum(..) + ) where + +import Protolude hiding (Enum, TypeError) + +import GHC.Generics (D, (:+:)(..)) +import GHC.TypeLits (KnownSymbol, TypeError, ErrorMessage(..)) +import GHC.Types (Type) + +import GraphQL.Internal.Name (Name, nameFromSymbol, NameError) +import GraphQL.Internal.Output (GraphQLError(..)) + +invalidEnumName :: forall t. NameError -> Either Text t +invalidEnumName x = Left ("In Enum: " <> formatError x) + +-- TODO: Enums have a slightly more restricted set of names than 'Name' +-- implies. Especially, they cannot be 'true', 'false', or 'nil'. The parser +-- /probably/ guarantees this, so it should export this guarantee by providing +-- an 'Enum' type. + +class GenericEnumValues (f :: Type -> Type) where + genericEnumValues :: [Either NameError Name] + -- XXX: Why is this 'Text' and not 'NameError'? + genericEnumFromValue :: Name -> Either Text (f p) + genericEnumToValue :: f p -> Name + +instance forall conName m p f nt. + ( KnownSymbol conName + , KnownSymbol m + , KnownSymbol p + , GenericEnumValues f + ) => GenericEnumValues (M1 D ('MetaData conName m p nt) f) where + genericEnumValues = genericEnumValues @f + genericEnumFromValue name = M1 <$> genericEnumFromValue name + genericEnumToValue (M1 gv) = genericEnumToValue gv + +instance forall left right. + ( GenericEnumValues left + , GenericEnumValues right + ) => GenericEnumValues (left :+: right) where + genericEnumValues = genericEnumValues @left <> genericEnumValues @right + genericEnumFromValue vname = + let left = genericEnumFromValue @left vname + right = genericEnumFromValue @right vname + in case (left, right) of + (x@(Right _), Left _) -> L1 <$> x + (Left _, x@(Right _)) -> R1 <$> x + (err@(Left _), Left _) -> L1 <$> err + _ -> panic "Can't have two successful branches in Haskell" + + genericEnumToValue (L1 gv) = genericEnumToValue gv + genericEnumToValue (R1 gv) = genericEnumToValue gv + +instance forall conName p b. (KnownSymbol conName) => GenericEnumValues (C1 ('MetaCons conName p b) U1) where + genericEnumValues = let name = nameFromSymbol @conName in [name] + genericEnumFromValue vname = + case nameFromSymbol @conName of + Right name -> if name == vname + then Right (M1 U1) + else Left ("Not a valid choice for enum: " <> show vname) + -- XXX: This is impossible to catch during validation, because we cannot + -- validate type-level symbols, we can only validate values. We could + -- show that the schema is invalid at the type-level and still decide to + -- call this anyway. The error should rather say that the schema is + -- invalid. + -- + -- Further, we don't actually have any schema-level validation, so + -- "should have been caught during validation" is misleading. + Left x -> invalidEnumName x + genericEnumToValue (M1 _) = + let Right name = nameFromSymbol @conName + in name + +-- TODO(tom): better type errors using `n`. Also type errors for other +-- invalid constructors. +instance forall conName p b sa sb. + ( TypeError ('Text "Constructor not unary: " ':<>: 'Text conName) + , KnownSymbol conName + ) => GenericEnumValues (C1 ('MetaCons conName p b) (S1 sa sb)) where + 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 = 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. +-- +-- TODO: Update this comment to explain what a GraphQLEnum is, why you might +-- want an instance, and any laws that apply to method relations. +class GraphQLEnum a where + -- TODO: Document each of these methods. + enumValues :: [Either NameError Name] + default enumValues :: (Generic a, GenericEnumValues (Rep a)) => [Either NameError Name] + enumValues = genericEnumValues @(Rep a) + + enumFromValue :: Name -> Either Text a + default enumFromValue :: (Generic a, GenericEnumValues (Rep a)) => Name -> Either Text a + enumFromValue v = to <$> genericEnumFromValue v + + enumToValue :: a -> Name + default enumToValue :: (Generic a, GenericEnumValues (Rep a)) => a -> Name + enumToValue = genericEnumToValue . from diff --git a/src/GraphQL/Internal/Arbitrary.hs b/src/GraphQL/Internal/Arbitrary.hs --- a/src/GraphQL/Internal/Arbitrary.hs +++ b/src/GraphQL/Internal/Arbitrary.hs @@ -1,5 +1,7 @@ {-# LANGUAGE RankNTypes #-} +{-# OPTIONS_HADDOCK not-home #-} +-- | Description: QuickCheck instances to help with testing module GraphQL.Internal.Arbitrary ( arbitraryText , arbitraryNonEmpty 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 @@ -1,6 +1,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PatternSynonyms #-} --- | Implement the \"Execution\" part of the GraphQL spec. +{-# OPTIONS_HADDOCK not-home #-} + +-- | Description: Implement the \"Execution\" part of the GraphQL spec. -- -- Actually, most of the execution work takes place in 'GraphQL.Resolver', but -- there's still a fair bit required to glue together the results of @@ -26,13 +28,15 @@ , Object'(..) ) import GraphQL.Internal.Output (GraphQLError(..)) +import GraphQL.Internal.Schema + ( AnnotatedType (TypeNonNull) + ) import GraphQL.Internal.Validation ( Operation , QueryDocument(..) , VariableDefinition(..) , VariableValue , Variable - , GType(..) ) -- | Get an operation from a GraphQL document 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 @@ -1,9 +1,11 @@ --- | Representation of GraphQL names. {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | Description: Representation of GraphQL names. module GraphQL.Internal.Name ( Name(unName, Name) , NameError(..) diff --git a/src/GraphQL/Internal/OrderedMap.hs b/src/GraphQL/Internal/OrderedMap.hs --- a/src/GraphQL/Internal/OrderedMap.hs +++ b/src/GraphQL/Internal/OrderedMap.hs @@ -1,5 +1,7 @@ {-# LANGUAGE RankNTypes #-} --- | Data structure for mapping keys to values while preserving order of appearance. +{-# OPTIONS_HADDOCK not-home #-} + +-- | Description: Data structure for mapping keys to values while preserving order of appearance -- -- There are many cases in GraphQL where we want to have a map from names to -- values, where values can easily be lookup up by name and name is unique. diff --git a/src/GraphQL/Internal/Output.hs b/src/GraphQL/Internal/Output.hs --- a/src/GraphQL/Internal/Output.hs +++ b/src/GraphQL/Internal/Output.hs @@ -1,7 +1,7 @@ {-# LANGUAGE PatternSynonyms #-} --- | GraphQL output. --- --- How we encode GraphQL responses. +{-# OPTIONS_HADDOCK not-home #-} + +-- | Description: How we encode GraphQL responses module GraphQL.Internal.Output ( Response(..) , Errors @@ -11,8 +11,10 @@ ) where import Protolude hiding (Location, Map) + import Data.Aeson (ToJSON(..)) import Data.List.NonEmpty (NonEmpty(..)) + import GraphQL.Value ( Object , objectFromList @@ -20,9 +22,9 @@ , pattern ValueObject , pattern ValueNull , NameError(..) + , ToValue(..) ) import GraphQL.Internal.Name (Name) -import GraphQL.Value.ToValue (ToValue(..)) -- | GraphQL response. -- diff --git a/src/GraphQL/Internal/Resolver.hs b/src/GraphQL/Internal/Resolver.hs new file mode 100644 --- /dev/null +++ b/src/GraphQL/Internal/Resolver.hs @@ -0,0 +1,572 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} -- nicer type errors in some cases +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- for TypeError +{-# OPTIONS_HADDOCK not-home #-} + +-- | Description: Implement handlers for GraphQL schemas +module GraphQL.Internal.Resolver + ( ResolverError(..) + , HasResolver(..) + , OperationResolverConstraint + , (:<>)(..) + , Result(..) + , unionValue + , resolveOperation + , returns + , handlerError + ) where + +-- TODO (probably incomplete, the spec is large) +-- - input objects - I'm not super clear from the spec on how +-- they differ from normal objects. +-- - "extend type X" is used in examples in the spec but it's not +-- explained anywhere? +-- - 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, throwE) + +import qualified Data.Text as Text +import qualified Data.List.NonEmpty as NonEmpty +import GHC.TypeLits (KnownSymbol, TypeError, ErrorMessage(..), Symbol, symbolVal) +import GHC.Types (Type) +import qualified GHC.Exts (Any) +import Unsafe.Coerce (unsafeCoerce) + +import GraphQL.Internal.API + ( HasAnnotatedType(..) + , HasAnnotatedInputType(..) + , (:>) + ) +import qualified GraphQL.Internal.API as API +import qualified GraphQL.Value as GValue +import GraphQL.Value + ( Value + , pattern ValueEnum + , FromValue(..) + , ToValue(..) + ) +import GraphQL.Internal.Name (Name, HasName(..)) +import qualified GraphQL.Internal.OrderedMap as OrderedMap +import GraphQL.Internal.Output (GraphQLError(..)) +import GraphQL.Internal.Validation + ( SelectionSetByType + , SelectionSet(..) + , Field + , ValidationErrors + , getSubSelectionSet + , getSelectionSetForType + , lookupArgument + ) + +data ResolverError + -- | There was a problem in the schema. Server-side problem. + = SchemaError API.SchemaError + -- | Couldn't find the requested field in the object. A client-side problem. + | FieldNotFoundError Name + -- | No value provided for name, and no default specified. Client-side problem. + | ValueMissing Name + -- | Could not translate value into Haskell. Probably a client-side problem. + | InvalidValue Name Text + -- | Found validation errors when we tried to merge fields. + | ValidationError ValidationErrors + -- | Tried to get subselection of leaf field. + | SubSelectionOnLeaf (SelectionSetByType Value) + -- | Tried to treat an object as a leaf. + | MissingSelectionSet + -- | Error from handler + | HandlerError Text + deriving (Show, Eq) + +instance GraphQLError ResolverError where + formatError (SchemaError e) = + "Schema error: " <> formatError e + formatError (FieldNotFoundError field) = + "Field not supported by the API: " <> show field + formatError (ValueMissing name) = + "No value provided for " <> show name <> ", and no default specified." + formatError (InvalidValue name text) = + "Could not coerce " <> show name <> " to valid value: " <> text + formatError (ValidationError errs) = + "Validation errors: " <> Text.intercalate ", " (map formatError (NonEmpty.toList errs)) + formatError (SubSelectionOnLeaf ss) = + "Tried to get values within leaf field: " <> show ss + formatError MissingSelectionSet = + "Tried to treat object as if it were leaf field." + formatError (HandlerError err) = + "Handler error: " <> err + +-- | Object field separation operator. +-- +-- Use this to provide handlers for fields of an object. +-- +-- Say you had the following GraphQL type with \"foo\" and \"bar\" fields, +-- e.g. +-- +-- @ +-- type MyObject { +-- foo: Int! +-- bar: String! +-- } +-- @ +-- +-- You could provide handlers for it like this: +-- +-- >>> :m +System.Environment +-- >>> let fooHandler = pure 42 +-- >>> let barHandler = System.Environment.getProgName +-- >>> let myObjectHandler = pure $ fooHandler :<> barHandler :<> () +data a :<> b = a :<> b +infixr 8 :<> + + +-- Result collects errors and values at the same time unless a handler +-- tells us to bail out in which case we stop the processing +-- immediately. +data Result a = Result [ResolverError] a deriving (Show, Functor, Eq) + +-- Aggregating results keeps all errors and creates a ValueList +-- containing the individual values. +aggregateResults :: [Result Value] -> Result Value +aggregateResults r = toValue <$> sequenceA r + +throwE :: Applicative f => ResolverError -> f (Result Value) +throwE err = pure (Result [err] GValue.ValueNull) + +instance Applicative Result where + pure v = Result [] v + (Result e1 f) <*> (Result e2 x) = Result (e1 <> e2) (f x) + +ok :: Value -> Result Value +ok = pure + + +-- | The result of a handler is either text errors generated by the +-- handler or a value. +type HandlerResult a = Either Text a + +-- | `returns` is a convenience function for a Handler that is +-- returning the expected value. +returns :: Applicative f => a -> f (HandlerResult a) +returns = pure . Right + +-- | `handlerError` is a convenience function for a Handler that has +-- encountered an error and is unable to return the expected value. +handlerError :: Applicative f => Text -> f (HandlerResult a) +handlerError = pure . Left + + +class HasResolver m a where + type Handler m a + resolve :: Handler m a -> Maybe (SelectionSetByType Value) -> m (Result Value) + +type OperationResolverConstraint m fields typeName interfaces = + ( RunFields m (RunFieldsType m fields) + , API.HasObjectDefinition (API.Object typeName interfaces fields) + , Monad m + ) + +resolveOperation + :: forall m fields typeName interfaces. + ( OperationResolverConstraint m fields typeName interfaces ) + => Handler m (API.Object typeName interfaces fields) + -> SelectionSetByType Value + -> m (Result GValue.Object) +resolveOperation handler ss = + resolveObject @m @fields @typeName @interfaces handler ss + +-- | Called when the schema expects an input argument @name@ of type @a@ but +-- @name@ has not been provided. +valueMissing :: API.Defaultable a => Name -> Either ResolverError a +valueMissing name = maybe (Left (ValueMissing name)) Right (API.defaultFor name) + +gotHandlerErr :: Text -> Result Value +gotHandlerErr err = Result [HandlerError err] GValue.ValueNull + +handlerResult :: (Applicative f, ToValue a) => f (HandlerResult a) -> f (Result Value) +handlerResult = fmap (either gotHandlerErr (ok . toValue)) + +instance forall m. (Applicative m) => HasResolver m Int32 where + type Handler m Int32 = m (HandlerResult Int32) + resolve handler Nothing = handlerResult @m handler + resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) + +instance forall m. (Applicative m) => HasResolver m Double where + type Handler m Double = m (HandlerResult Double) + resolve handler Nothing = handlerResult handler + resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) + +instance forall m. (Applicative m) => HasResolver m Text where + type Handler m Text = m (HandlerResult Text) + resolve handler Nothing = handlerResult handler + resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) + +instance forall m. (Applicative m) => HasResolver m Bool where + type Handler m Bool = m (HandlerResult Bool) + resolve handler Nothing = handlerResult handler + resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) + +instance forall m hg. (Monad m, Applicative m, HasResolver m hg) => HasResolver m (API.List hg) where + type Handler m (API.List hg) = m (HandlerResult [Handler m hg]) + resolve handler selectionSet = do + handler >>= \case + Right h -> + let a = traverse (flip (resolve @m @hg) selectionSet) h + in map aggregateResults a + Left err -> pure $ gotHandlerErr err + +instance forall m ksN enum. (Applicative m, API.GraphQLEnum enum) => HasResolver m (API.Enum ksN enum) where + type Handler m (API.Enum ksN enum) = m (HandlerResult enum) + resolve handler Nothing = either gotHandlerErr (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 + type Handler m (Maybe hg) = m (HandlerResult (Maybe (Handler m hg))) + resolve handler selectionSet = do + result <- handler + case result of + Right res -> + case res of + Just x -> resolve @m @hg (x :: Handler m hg) selectionSet + Nothing -> (pure . ok) GValue.ValueNull + Left err -> pure $ gotHandlerErr err + +-- TODO: A parametrized `Result` is really not a good way to handle the +-- "result" for resolveField, but not sure what to use either. Tom liked the +-- tuple we had before more because it didn't imply any other structure or +-- meaning. Maybe we can just create a new datatype. jml thinks we should +-- extract some helpful generic monad, ala `Validator`. +-- +type ResolveFieldResult = Result (Maybe GValue.Value) + +-- Extract field name from an argument type. TODO: ideally we'd run +-- this directly on the "a :> b" argument structure, but that requires +-- passing in the plain argument structure type into resolveField or +-- resolving "name" in the buildFieldResolver. Both options duplicate +-- code somwehere else. +type family FieldName (a :: Type) = (r :: Symbol) where + FieldName (JustHandler (API.Field name t)) = name + FieldName (PlainArgument a f) = FieldName f + FieldName (EnumArgument a f) = FieldName f + FieldName x = TypeError ('Text "Unexpected branch in FieldName type family. Please file a bug!" ':<>: 'ShowType x) + +resolveField :: forall dispatchType (m :: Type -> Type). + (BuildFieldResolver m dispatchType, Monad m, KnownSymbol (FieldName dispatchType)) + => FieldHandler m dispatchType -> m ResolveFieldResult -> Field Value -> m ResolveFieldResult +resolveField handler nextHandler field = + -- check name before + case API.nameFromSymbol @(FieldName dispatchType) of + Left err -> pure (Result [SchemaError err] (Just GValue.ValueNull)) + Right name' + | getName field == name' -> + case buildFieldResolver @m @dispatchType handler field of + Left err -> pure (Result [err] (Just GValue.ValueNull)) + Right resolver -> do + Result errs value <- resolver + pure (Result errs (Just value)) + | otherwise -> nextHandler + +-- We're using our usual trick of rewriting a type in a closed type +-- family to emulate a closed typeclass. The following are the +-- universe of "allowed" class instances for field types: +data JustHandler a +data EnumArgument a b +data PlainArgument a b + +-- injective helps with errors sometimes +type family FieldResolverDispatchType (a :: Type) = (r :: Type) | r -> a where + FieldResolverDispatchType (API.Field ksA t) = JustHandler (API.Field ksA t) + FieldResolverDispatchType (API.Argument ksB (API.Enum name t) :> f) = EnumArgument (API.Argument ksB (API.Enum name t)) (FieldResolverDispatchType f) + FieldResolverDispatchType (API.Argument ksC t :> f) = PlainArgument (API.Argument ksC t) (FieldResolverDispatchType f) + +-- | Derive the handler type from the Field/Argument type in a closed +-- type family: We don't want anyone else to extend this ever. +type family FieldHandler (m :: Type -> Type) (a :: Type) = (r :: Type) where + FieldHandler m (JustHandler (API.Field ksD t)) = Handler m t + FieldHandler m (PlainArgument (API.Argument ksE t) f) = t -> FieldHandler m f + FieldHandler m (EnumArgument (API.Argument ksF (API.Enum name t)) f) = t -> FieldHandler m f + +class BuildFieldResolver m fieldResolverType where + buildFieldResolver :: FieldHandler m fieldResolverType -> Field Value -> Either ResolverError (m (Result Value)) + +instance forall ksG t m. + ( KnownSymbol ksG, HasResolver m t, HasAnnotatedType t, Monad m + ) => BuildFieldResolver m (JustHandler (API.Field ksG t)) where + buildFieldResolver handler field = do + pure (resolve @m @t handler (getSubSelectionSet field)) + +instance forall ksH t f m. + ( KnownSymbol ksH + , BuildFieldResolver m f + , FromValue t + , API.Defaultable t + , HasAnnotatedInputType t + , Monad m + ) => BuildFieldResolver m (PlainArgument (API.Argument ksH t) f) where + buildFieldResolver handler field = do + argument <- first SchemaError (API.getArgumentDefinition @(API.Argument ksH t)) + let argName = getName argument + value <- case lookupArgument field argName of + Nothing -> valueMissing @t argName + Just v -> first (InvalidValue argName) (fromValue @t v) + buildFieldResolver @m @f (handler value) field + +instance forall ksK t f m name. + ( KnownSymbol ksK + , BuildFieldResolver m f + , KnownSymbol name + , API.Defaultable t + , API.GraphQLEnum t + , Monad m + ) => BuildFieldResolver m (EnumArgument (API.Argument ksK (API.Enum name t)) f) where + buildFieldResolver handler field = do + argName <- first SchemaError (API.nameFromSymbol @ksK) + value <- case lookupArgument field argName of + Nothing -> valueMissing @t argName + Just (ValueEnum enum) -> first (InvalidValue argName) (API.enumFromValue @t enum) + Just value -> Left (InvalidValue argName (show value <> " not an enum: " <> show (API.enumValues @t))) + buildFieldResolver @m @f (handler value) field + +-- Note that we enumerate all ks variables with capital letters so we +-- can figure out error messages like the following that don't come +-- with line numbers: +-- +-- • No instance for (GHC.TypeLits.KnownSymbol ks0) +-- arising from a use of ‘interpretAnonymousQuery’ + +-- We only allow Field and Argument :> Field combinations: +type family RunFieldsType (m :: Type -> Type) (a :: [Type]) = (r :: Type) where + RunFieldsType m '[API.Field ksI t] = API.Field ksI t + RunFieldsType m '[a :> b] = a :> b + RunFieldsType m ((API.Field ksJ t) ': rest) = API.Field ksJ t :<> RunFieldsType m rest + RunFieldsType m ((a :> b) ': rest) = (a :> b) :<> RunFieldsType m rest + RunFieldsType m a = TypeError ( + 'Text "All field entries in an Object must be Field or Argument :> Field. Got: " ':<>: 'ShowType a) + +-- Match the three possible cases for Fields (see also RunFieldsType) +type family RunFieldsHandler (m :: Type -> Type) (a :: Type) = (r :: Type) where + RunFieldsHandler m (f :<> fs) = FieldHandler m (FieldResolverDispatchType f) :<> RunFieldsHandler m fs + RunFieldsHandler m (API.Field ksL t) = FieldHandler m (FieldResolverDispatchType (API.Field ksL t)) + RunFieldsHandler m (a :> b) = FieldHandler m (FieldResolverDispatchType (a :> b)) + RunFieldsHandler m a = TypeError ( + 'Text "Unexpected RunFieldsHandler types: " ':<>: 'ShowType a) + + +class RunFields m a where + -- | Run a single 'Selection' over all possible fields (as specified by the + -- type @a@), returning exactly one 'GValue.ObjectField' when a field + -- matches, or an error otherwise. + -- + -- Individual implementations are responsible for calling 'runFields' if + -- they haven't matched the field and there are still candidate fields + -- within the handler. + runFields :: RunFieldsHandler m a -> Field Value -> m ResolveFieldResult + +instance forall f fs m dispatchType. + ( BuildFieldResolver m dispatchType + , dispatchType ~ FieldResolverDispatchType f + , RunFields m fs + , KnownSymbol (FieldName dispatchType) + , Monad m + ) => RunFields m (f :<> fs) where + runFields (handler :<> nextHandlers) field = + resolveField @dispatchType @m handler nextHandler field + where + nextHandler = runFields @m @fs nextHandlers field + +instance forall ksM t m dispatchType. + ( BuildFieldResolver m dispatchType + , KnownSymbol ksM + , dispatchType ~ FieldResolverDispatchType (API.Field ksM t) + , Monad m + ) => RunFields m (API.Field ksM t) where + runFields handler field = + resolveField @dispatchType @m handler nextHandler field + where + nextHandler = pure (Result [FieldNotFoundError (getName field)] Nothing) + +instance forall m a b dispatchType. + ( BuildFieldResolver m dispatchType + , dispatchType ~ FieldResolverDispatchType (a :> b) + , KnownSymbol (FieldName dispatchType) + , Monad m + ) => RunFields m (a :> b) where + runFields handler field = + resolveField @dispatchType @m handler nextHandler field + where + nextHandler = pure (Result [FieldNotFoundError (getName field)] Nothing) + +resolveObject + :: forall m fields typeName interfaces. + ( OperationResolverConstraint m fields typeName interfaces ) + => Handler m (API.Object typeName interfaces fields) + -> SelectionSetByType Value + -> m (Result GValue.Object) +resolveObject mHandler selectionSet = + case getSelectionSet of + Left err -> return (Result [err] (GValue.Object' OrderedMap.empty)) + Right ss -> do + -- Run the handler so the field resolvers have access to the object. + -- This (and other places, including field resolvers) is where user + -- code can do things like look up something in a database. + handler <- mHandler + r <- traverse (runFields @m @(RunFieldsType m fields) handler) ss + let (Result errs obj) = GValue.objectFromOrderedMap . OrderedMap.catMaybes <$> sequenceA r + pure (Result errs obj) + + where + getSelectionSet = do + defn <- first SchemaError $ API.getDefinition @(API.Object typeName interfaces fields) + -- Fields of a selection set may be behind "type conditions", due to + -- inline fragments or the use of fragment spreads. These type + -- conditions are represented in the schema by the name of a type + -- (e.g. "Dog"). To determine which type conditions (and thus which + -- fields) are relevant for this 1selection set, we need to look up the + -- actual types they refer to, as interfaces (say) match objects + -- differently than unions. + -- + -- See for + -- more details. + (SelectionSet ss') <- first ValidationError $ getSelectionSetForType defn selectionSet + pure ss' + +instance forall typeName interfaces fields m. + ( RunFields m (RunFieldsType m fields) + , API.HasObjectDefinition (API.Object typeName interfaces fields) + , Monad m + ) => HasResolver m (API.Object typeName interfaces fields) where + type Handler m (API.Object typeName interfaces fields) = m (RunFieldsHandler m (RunFieldsType m fields)) + + resolve _ Nothing = throwE MissingSelectionSet + resolve handler (Just ss) = do + result <- resolveObject @m @fields @typeName @interfaces handler ss + return $ GValue.ValueObject <$> result + +-- TODO(tom): we're getting to a point where it might make sense to +-- split resolver into submodules (GraphQL.Resolver.Union etc.) + + +-- | For unions we need a way to have type-safe, open sum types based +-- on the possible 'API.Object's of a union. The following closed type +-- family selects one Object from the union and returns the matching +-- 'HasResolver' 'Handler' type. If the object @o@ is not a member of +-- 'API.Union' then the user code won't compile. +-- +-- This type family is an implementation detail but its TypeError +-- messages are visible at compile time. +type family TypeIndex (m :: Type -> Type) (object :: Type) (union :: Type) = (result :: Type) where + TypeIndex m (API.Object name interfaces fields) (API.Union uName (API.Object name interfaces fields:_)) = + Handler m (API.Object name interfaces fields) + TypeIndex m (API.Object name interfaces fields) (API.Union uName (API.Object name' i' f':objects)) = + TypeIndex m (API.Object name interfaces fields) (API.Union uName objects) + -- Slightly nicer type errors: + TypeIndex _ (API.Object name interfaces fields) (API.Union uName '[]) = + TypeError ('Text "Type not found in union definition: " ':<>: 'ShowType (API.Object name interfaces fields)) + TypeIndex _ (API.Object name interfaces fields) x = + TypeError ('Text "3rd type must be a union but it is: " ':<>: 'ShowType x) + TypeIndex _ o _ = + TypeError ('Text "Invalid TypeIndex. Must be Object but got: " ':<>: 'ShowType o) + + +-- | The 'Handler' type of a 'API.Union' must be the same for all +-- possible Objects, but each Object has a different type. We +-- unsafeCoerce the return type into an Any, tagging it with the union +-- and the underlying monad for type safety, but we elide the Object +-- type itself. This way we can represent all 'Handler' types of the +-- Union with a single type and still stay type-safe. +type role DynamicUnionValue representational representational +data DynamicUnionValue (union :: Type) (m :: Type -> Type) = DynamicUnionValue { _label :: Text, _value :: GHC.Exts.Any } + +class RunUnion m union objects where + runUnion :: DynamicUnionValue union m -> SelectionSetByType Value -> m (Result Value) + +instance forall m union objects name interfaces fields. + ( Monad m + , KnownSymbol name + , TypeIndex m (API.Object name interfaces fields) union ~ Handler m (API.Object name interfaces fields) + , RunFields m (RunFieldsType m fields) + , API.HasObjectDefinition (API.Object name interfaces fields) + , RunUnion m union objects + ) => RunUnion m union (API.Object name interfaces fields:objects) where + runUnion duv selectionSet = + case extractUnionValue @(API.Object name interfaces fields) @union @m duv of + Just handler -> resolve @m @(API.Object name interfaces fields) handler (Just selectionSet) + Nothing -> runUnion @m @union @objects duv selectionSet + +-- AFAICT it should not be possible to ever hit the empty case because +-- the compiler doesn't allow constructing a unionValue that's not in +-- the Union. If the following code ever gets executed it's almost +-- certainly a bug in the union code. +-- +-- We still need to implement this instance for the compiler because +-- it exhaustively checks all cases when deconstructs the Union. +instance forall m union. RunUnion m union '[] where + runUnion (DynamicUnionValue label _) selection = + panic ("Unexpected branch in runUnion, got " <> show selection <> " for label " <> label <> ". Please file a bug.") + +instance forall m unionName objects. + ( Monad m + , KnownSymbol unionName + , RunUnion m (API.Union unionName objects) objects + ) => HasResolver m (API.Union unionName objects) where + type Handler m (API.Union unionName objects) = m (DynamicUnionValue (API.Union unionName objects) m) + resolve _ Nothing = throwE MissingSelectionSet + resolve mHandler (Just selectionSet) = do + duv <- mHandler + runUnion @m @(API.Union unionName objects) @objects duv selectionSet + +symbolText :: forall ks. KnownSymbol ks => Text +symbolText = toS (symbolVal @ks Proxy) + +-- | Translate a 'Handler' into a DynamicUnionValue type required by +-- 'Union' handlers. This is dynamic, but nevertheless type-safe +-- because we can only tag with types that are part of the union. +-- +-- Use e.g. like "unionValue @Cat" if you have an object like this: +-- +-- >>> type Cat = API.Object "Cat" '[] '[API.Field "name" Text] +-- +-- and then use `unionValue @Cat (pure (pure "Felix"))`. See +-- `examples/UnionExample.hs` for more code. +unionValue :: + forall (object :: Type) (union :: Type) m (name :: Symbol) interfaces fields. + (Monad m, API.Object name interfaces fields ~ object, KnownSymbol name) + => TypeIndex m object union -> m (DynamicUnionValue union m) +unionValue x = + -- TODO(tom) - we might want to move to Typeable `cast` for uValue + -- instead of doing our own unsafeCoerce because it comes with + -- additional safety guarantees: Typerep is unforgeable, while we + -- can still into a bad place by matching on name only. We can't + -- actually segfault this because right now we walk the list of + -- objects in a union left-to-right so in case of duplicate names we + -- only every see one type. That doesn't seen like a great thing to + -- rely on though! + + -- Note that unsafeCoerce is safe because we index the type from the + -- union with an 'API.Object' whose name we're storing in label. On + -- the way out we check that the name is the same, and we know the + -- type universe is the same because we annotated DynamicUnionValue + -- with the type universe. + pure (DynamicUnionValue (symbolText @name) (unsafeCoerce x)) + +extractUnionValue :: + forall (object :: Type) (union :: Type) m (name :: Symbol) interfaces fields. + (API.Object name interfaces fields ~ object, KnownSymbol name) + => DynamicUnionValue union m -> Maybe (TypeIndex m object union) +extractUnionValue (DynamicUnionValue uName uValue) = + if uName == symbolText @name + then Just (unsafeCoerce uValue) + else Nothing 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 @@ -1,6 +1,6 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_HADDOCK not-home #-} --- | Fully realized GraphQL schema type system at the value level. +-- | Description: Fully realized GraphQL schema type system at the Haskell value level -- -- Differs from "Data.GraphQL.AST" in the -- [graphql](http://hackage.haskell.org/package/graphql) package in that there @@ -20,9 +20,9 @@ , FieldDefinition(..) , Interfaces , InterfaceTypeDefinition(..) - , NonEmptyList(..) , ObjectTypeDefinition(..) , UnionTypeDefinition(..) + , ScalarTypeDefinition(..) -- ** Input types , InputType(..) , InputTypeDefinition(..) @@ -34,15 +34,20 @@ , NonNullType(..) , DefinesTypes(..) , doesFragmentTypeApply + , getInputTypeDefinition + , builtinFromName + , astAnnotationToSchemaAnnotation -- * The schema , Schema , makeSchema + , emptySchema , lookupType ) where import Protolude import qualified Data.Map as Map +import qualified GraphQL.Internal.Syntax.AST as AST import GraphQL.Value (Value) import GraphQL.Internal.Name (HasName(..), Name) @@ -59,13 +64,15 @@ makeSchema :: ObjectTypeDefinition -> Schema makeSchema = Schema . getDefinedTypes +-- | Create an empty schema for testing purpose. +-- +emptySchema :: Schema +emptySchema = Schema (Map.empty :: (Map Name TypeDefinition)) + -- | Find the type with the given name in the schema. lookupType :: Schema -> Name -> Maybe TypeDefinition lookupType (Schema schema) name = Map.lookup name schema --- XXX: Use the built-in NonEmptyList in Haskell -newtype NonEmptyList a = NonEmptyList [a] deriving (Eq, Ord, Show, Functor, Foldable) - -- | A thing that defines types. Excludes definitions of input types. class DefinesTypes t where -- | Get the types defined by @t@ @@ -140,7 +147,7 @@ TypeDefinitionTypeExtension _ -> panic "TODO: we should remove the 'extend' behaviour entirely" -data ObjectTypeDefinition = ObjectTypeDefinition Name Interfaces (NonEmptyList FieldDefinition) +data ObjectTypeDefinition = ObjectTypeDefinition Name Interfaces (NonEmpty FieldDefinition) deriving (Eq, Ord, Show) instance HasName ObjectTypeDefinition where @@ -161,7 +168,9 @@ getName (FieldDefinition name _ _) = name instance DefinesTypes FieldDefinition where - getDefinedTypes (FieldDefinition _ _ retVal) = getDefinedTypes (getAnnotatedType retVal) + getDefinedTypes (FieldDefinition _ args retVal) = + getDefinedTypes (getAnnotatedType retVal) <> + foldMap getDefinedTypes args data ArgumentDefinition = ArgumentDefinition Name (AnnotatedType InputType) (Maybe DefaultValue) deriving (Eq, Ord, Show) @@ -169,7 +178,10 @@ instance HasName ArgumentDefinition where getName (ArgumentDefinition name _ _) = name -data InterfaceTypeDefinition = InterfaceTypeDefinition Name (NonEmptyList FieldDefinition) +instance DefinesTypes ArgumentDefinition where + getDefinedTypes (ArgumentDefinition _ annotatedType _) = getDefinedTypes $ getAnnotatedType annotatedType + +data InterfaceTypeDefinition = InterfaceTypeDefinition Name (NonEmpty FieldDefinition) deriving (Eq, Ord, Show) instance HasName InterfaceTypeDefinition where @@ -178,7 +190,7 @@ instance DefinesTypes InterfaceTypeDefinition where getDefinedTypes i@(InterfaceTypeDefinition name fields) = Map.singleton name (TypeDefinitionInterface i) <> foldMap getDefinedTypes fields -data UnionTypeDefinition = UnionTypeDefinition Name (NonEmptyList ObjectTypeDefinition) +data UnionTypeDefinition = UnionTypeDefinition Name (NonEmpty ObjectTypeDefinition) deriving (Eq, Ord, Show) instance HasName UnionTypeDefinition where @@ -236,7 +248,7 @@ instance HasName EnumValueDefinition where getName (EnumValueDefinition name) = name -data InputObjectTypeDefinition = InputObjectTypeDefinition Name (NonEmptyList InputObjectFieldDefinition) +data InputObjectTypeDefinition = InputObjectTypeDefinition Name (NonEmpty InputObjectFieldDefinition) deriving (Eq, Ord, Show) instance HasName InputObjectTypeDefinition where @@ -260,6 +272,12 @@ getName (DefinedInputType x) = getName x getName (BuiltinInputType x) = getName x +instance DefinesTypes InputType where + getDefinedTypes inputType = + case inputType of + DefinedInputType typeDefinition -> getDefinedTypes typeDefinition + BuiltinInputType _ -> mempty + data InputTypeDefinition = InputTypeDefinitionObject InputObjectTypeDefinition | InputTypeDefinitionScalar ScalarTypeDefinition @@ -271,6 +289,13 @@ getName (InputTypeDefinitionScalar x) = getName x getName (InputTypeDefinitionEnum x) = getName x +instance DefinesTypes InputTypeDefinition where + getDefinedTypes inputTypeDefinition = + case inputTypeDefinition of + InputTypeDefinitionObject typeDefinition -> getDefinedTypes (TypeDefinitionInputObject typeDefinition) + InputTypeDefinitionScalar typeDefinition -> getDefinedTypes (TypeDefinitionScalar typeDefinition) + InputTypeDefinitionEnum typeDefinition -> getDefinedTypes (TypeDefinitionEnum typeDefinition) + -- | A literal value specified as a default as part of a type definition. -- -- Use this type alias when you want to be clear that a definition may include @@ -304,4 +329,40 @@ _ -> False where implements (ObjectTypeDefinition _ interfaces _) int = int `elem` interfaces - branchOf obj (UnionTypeDefinition _ (NonEmptyList branches)) = obj `elem` branches + branchOf obj (UnionTypeDefinition _ branches) = obj `elem` branches + +-- | Convert the given 'TypeDefinition' to an 'InputTypeDefinition' if it's a valid 'InputTypeDefinition' +-- (because 'InputTypeDefinition' is a subset of 'TypeDefinition') +-- see +getInputTypeDefinition :: TypeDefinition -> Maybe InputTypeDefinition +getInputTypeDefinition td = + case td of + TypeDefinitionInputObject itd -> Just (InputTypeDefinitionObject itd) + TypeDefinitionScalar itd -> Just (InputTypeDefinitionScalar itd) + TypeDefinitionEnum itd -> Just (InputTypeDefinitionEnum itd) + _ -> Nothing + +-- | Create a 'Builtin' type from a 'Name' +-- +-- Mostly used for the AST validation +-- theobat: There's probably a better way to do it but can't find it right now +builtinFromName :: Name -> Maybe Builtin +builtinFromName typeName + | typeName == getName GInt = Just GInt + | typeName == getName GBool = Just GBool + | typeName == getName GString = Just GString + | typeName == getName GFloat = Just GFloat + | typeName == getName GID = Just GID + | otherwise = Nothing + +-- | Simple translation between 'AST' annotation types and 'Schema' annotation types +-- +-- AST type annotations do not need any validation. +-- GraphQL annotations are semantic decorations around type names to indicate type composition (list/non null). +astAnnotationToSchemaAnnotation :: AST.GType -> a -> AnnotatedType a +astAnnotationToSchemaAnnotation gtype schemaTypeName = + case gtype of + AST.TypeNamed _ -> TypeNamed schemaTypeName + AST.TypeList (AST.ListType astTypeName) -> TypeList (ListType $ astAnnotationToSchemaAnnotation astTypeName schemaTypeName) + AST.TypeNonNull (AST.NonNullTypeNamed _) -> TypeNonNull (NonNullTypeNamed schemaTypeName) + AST.TypeNonNull (AST.NonNullTypeList (AST.ListType astTypeName)) -> TypeNonNull (NonNullTypeList (ListType (astAnnotationToSchemaAnnotation astTypeName schemaTypeName))) 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 @@ -2,7 +2,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_HADDOCK not-home #-} +-- | Description: The GraphQL AST module GraphQL.Internal.Syntax.AST ( QueryDocument(..) , SchemaDocument(..) @@ -51,8 +53,11 @@ import Test.QuickCheck (Arbitrary(..), listOf, oneof) import GraphQL.Internal.Arbitrary (arbitraryText) -import GraphQL.Internal.Name (Name) - +import GraphQL.Internal.Name + ( Name + , HasName(..) + ) + -- * Documents -- | A 'QueryDocument' is something a user might send us. @@ -173,6 +178,13 @@ | TypeList ListType | TypeNonNull NonNullType deriving (Eq, Ord, Show) + +-- | Get the name of the given 'GType'. +instance HasName GType where + getName (TypeNamed (NamedType n)) = n + getName (TypeList (ListType t)) = getName t + getName (TypeNonNull (NonNullTypeNamed (NamedType n))) = n + getName (TypeNonNull (NonNullTypeList (ListType l))) = getName l newtype NamedType = NamedType Name deriving (Eq, Ord, Show) 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 @@ -1,3 +1,6 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- | Description: Turn GraphQL ASTs into text module GraphQL.Internal.Syntax.Encoder ( queryDocument , schemaDocument 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 @@ -1,11 +1,14 @@ {-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | Description: Parse text into GraphQL ASTs module GraphQL.Internal.Syntax.Parser ( queryDocument , schemaDocument , value ) where -import Protolude hiding (option, takeWhile) +import Protolude hiding (option) import Control.Applicative ((<|>), empty, many, optional) import Control.Monad (fail) diff --git a/src/GraphQL/Internal/Syntax/Tokens.hs b/src/GraphQL/Internal/Syntax/Tokens.hs --- a/src/GraphQL/Internal/Syntax/Tokens.hs +++ b/src/GraphQL/Internal/Syntax/Tokens.hs @@ -1,4 +1,6 @@ --- | Basic tokenising used by parser. +{-# OPTIONS_HADDOCK not-home #-} + +-- | Description: Basic tokenising used by parser module GraphQL.Internal.Syntax.Tokens ( tok , whiteSpace 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 @@ -5,7 +5,9 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE KindSignatures #-} --- | Transform GraphQL query documents from AST into valid structures +{-# OPTIONS_HADDOCK not-home #-} + +-- | Description: Transform GraphQL query documents from AST into valid structures -- -- This corresponds roughly to the -- [Validation](https://facebook.github.io/graphql/#sec-Validation) section of @@ -56,6 +58,7 @@ , getResponseKey -- * Exported for testing , findDuplicates + , formatErrors ) where import Protolude hiding ((<>), throwE) @@ -79,6 +82,12 @@ , Schema , doesFragmentTypeApply , lookupType + , AnnotatedType(..) + , InputType (BuiltinInputType, DefinedInputType) + , AnnotatedType + , getInputTypeDefinition + , builtinFromName + , astAnnotationToSchemaAnnotation ) import GraphQL.Value ( Value @@ -98,30 +107,34 @@ | MultipleOperations (Operations value) deriving (Eq, Show) + +data OperationType + = Mutation + | Query + deriving (Eq, Show) + data Operation value - = Query VariableDefinitions (Directives value) (SelectionSetByType value) - | Mutation VariableDefinitions (Directives value) (SelectionSetByType value) + = Operation OperationType VariableDefinitions (Directives value) (SelectionSetByType value) deriving (Eq, Show) instance Functor Operation where - fmap f (Query vars directives selectionSet) = Query vars (fmap f directives) (fmap f selectionSet) - fmap f (Mutation vars directives selectionSet) = Mutation vars (fmap f directives) (fmap f selectionSet) + fmap f (Operation operationType vars directives selectionSet) + = Operation operationType vars (fmap f directives) (fmap f selectionSet) instance Foldable Operation where - foldMap f (Query _ directives selectionSet) = foldMap f directives `mappend` foldMap f selectionSet - foldMap f (Mutation _ directives selectionSet) = foldMap f directives `mappend` foldMap f selectionSet + foldMap f (Operation _ _ directives selectionSet) + = foldMap f directives `mappend` foldMap f selectionSet instance Traversable Operation where - traverse f (Query vars directives selectionSet) = Query vars <$> traverse f directives <*> traverse f selectionSet - traverse f (Mutation vars directives selectionSet) = Mutation vars <$> traverse f directives <*> traverse f selectionSet + traverse f (Operation operationType vars directives selectionSet) + = Operation operationType vars <$> traverse f directives <*> traverse f selectionSet -- | Get the selection set for an operation. getSelectionSet :: Operation value -> SelectionSetByType value -getSelectionSet (Query _ _ ss) = ss -getSelectionSet (Mutation _ _ ss) = ss +getSelectionSet (Operation _ _ _ ss) = ss -- | Type alias for 'Query' and 'Mutation' constructors of 'Operation'. -type OperationType value = VariableDefinitions -> Directives value -> SelectionSetByType value -> Operation value +type OperationBuilder value = VariableDefinitions -> Directives value -> SelectionSetByType value -> Operation value type Operations value = Map (Maybe Name) (Operation value) @@ -145,7 +158,7 @@ assertAllFragmentsUsed frags (visitedFrags <> usedFrags) validValuesSS <- validateValues ss resolvedValuesSS <- resolveVariables emptyVariableDefinitions validValuesSS - pure (LoneAnonymousOperation (Query emptyVariableDefinitions emptyDirectives resolvedValuesSS)) + pure (LoneAnonymousOperation (Operation Query emptyVariableDefinitions emptyDirectives resolvedValuesSS)) _ -> throwE (MixedAnonymousOperations (length anonymous) (map fst maybeNamed)) where @@ -156,41 +169,29 @@ splitDefns (AST.DefinitionFragment frag) = Right frag splitOps (AST.AnonymousQuery ss) = Left ss - splitOps (AST.Query node@(AST.Node maybeName _ _ _)) = Right (maybeName, (Query, node)) - splitOps (AST.Mutation node@(AST.Node maybeName _ _ _)) = Right (maybeName, (Mutation, node)) + splitOps (AST.Query node@(AST.Node maybeName _ _ _)) = Right (maybeName, (Operation Query, node)) + splitOps (AST.Mutation node@(AST.Node maybeName _ _ _)) = Right (maybeName, (Operation Mutation, node)) assertAllFragmentsUsed :: Fragments value -> Set (Maybe Name) -> Validation () assertAllFragmentsUsed fragments used = - let unused = ( Set.map pure (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 -> [(Maybe Name, (OperationType AST.Value, AST.Node))] -> StateT (Set (Maybe Name)) Validation (Operations AST.Value) +validateOperations :: Schema -> Fragments AST.Value -> [(Maybe Name, (OperationBuilder 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 where - validateNode (operationType, AST.Node _ vars directives ss) = - operationType <$> lift (validateVariableDefinitions vars) + validateNode (operationBuilder, AST.Node _ vars directives ss) = + operationBuilder <$> lift (validateVariableDefinitions schema vars) <*> lift (validateDirectives directives) <*> validateSelectionSet schema fragments ss --- TODO: Either make operation type (Query, Mutation) a parameter of an --- Operation constructor or give all the fields accessors. This duplication is --- driving me batty. validateOperation :: Operation AST.Value -> Validation (Operation VariableValue) -validateOperation (Query vars directives selectionSet) = do - validValues <- Query vars <$> validateValues directives <*> validateValues selectionSet - -- Instead of doing this, we could build up a list of used variables as we - -- resolve them. - let usedVariables = getVariables validValues - let definedVariables = getDefinedVariables vars - let unusedVariables = definedVariables `Set.difference` usedVariables - unless (Set.null unusedVariables) $ throwE (UnusedVariables unusedVariables) - resolveVariables vars validValues -validateOperation (Mutation vars directives selectionSet) = do - validValues <- Mutation vars <$> validateValues directives <*> validateValues selectionSet +validateOperation (Operation operationType vars directives selectionSet) = do + validValues <- Operation operationType vars <$> validateValues directives <*> validateValues selectionSet -- Instead of doing this, we could build up a list of used variables as we -- resolve them. let usedVariables = getVariables validValues @@ -624,7 +625,7 @@ data VariableDefinition = VariableDefinition { variable :: Variable -- ^ The name of the variable - , variableType :: AST.GType -- ^ The type of the variable + , variableType :: AnnotatedType InputType -- ^ The type of the variable , defaultValue :: Maybe Value -- ^ An optional default value for the variable } deriving (Eq, Ord, Show) @@ -640,17 +641,44 @@ emptyVariableDefinitions = mempty -- | Ensure that a set of variable definitions is valid. -validateVariableDefinitions :: [AST.VariableDefinition] -> Validation VariableDefinitions -validateVariableDefinitions vars = do - validatedDefns <- traverse validateVariableDefinition vars +validateVariableDefinitions :: Schema -> [AST.VariableDefinition] -> Validation VariableDefinitions +validateVariableDefinitions schema vars = do + validatedDefns <- traverse (validateVariableDefinition schema) vars let items = [ (variable defn, defn) | defn <- validatedDefns] mapErrors DuplicateVariableDefinition (makeMap items) -- | Ensure that a variable definition is a valid one. -validateVariableDefinition :: AST.VariableDefinition -> Validation VariableDefinition -validateVariableDefinition (AST.VariableDefinition name varType value) = - VariableDefinition name varType <$> traverse validateDefaultValue value +validateVariableDefinition :: Schema -> AST.VariableDefinition -> Validation VariableDefinition +validateVariableDefinition schema (AST.VariableDefinition var varType value) = + VariableDefinition var + <$> validateTypeAssertion schema var varType + <*> traverse validateDefaultValue value +-- | Ensure that a variable has a correct type declaration given a schema. +validateTypeAssertion :: Schema -> Variable -> AST.GType -> Validation (AnnotatedType InputType) +validateTypeAssertion schema var varTypeAST = + astAnnotationToSchemaAnnotation varTypeAST <$> + case lookupType schema varTypeNameAST of + Nothing -> validateVariableTypeBuiltin var varTypeNameAST + Just cleanTypeDef -> validateVariableTypeDefinition var cleanTypeDef + where + varTypeNameAST = getName varTypeAST + +-- | Validate a variable type which has a type definition in the schema. +validateVariableTypeDefinition :: Variable -> TypeDefinition -> Validation InputType +validateVariableTypeDefinition var typeDef = + case getInputTypeDefinition typeDef of + Nothing -> throwE (VariableTypeIsNotInputType var $ getName typeDef) + Just value -> pure (DefinedInputType value) + + +-- | Validate a variable type which has no type definition (either builtin or not in the schema). +validateVariableTypeBuiltin :: Variable -> Name -> Validation InputType +validateVariableTypeBuiltin var typeName = + case builtinFromName typeName of + Nothing -> throwE (VariableTypeNotFound var typeName) + Just builtin -> pure (BuiltinInputType builtin) + -- | Ensure that a default value contains no variables. validateDefaultValue :: AST.DefaultValue -> Validation Value validateDefaultValue defaultValue = @@ -774,6 +802,11 @@ | IncompatibleFields Name -- | There's a type condition that's not present in the schema. | TypeConditionNotFound Name + -- | There's a variable type that's not present in the schema. + | VariableTypeNotFound Variable Name + -- | A variable was defined with a non input type. + -- + | VariableTypeIsNotInputType Variable Name deriving (Eq, Show) instance GraphQLError ValidationError where @@ -796,6 +829,8 @@ formatError (MismatchedArguments name) = "Two different sets of arguments given for same response key: " <> show name formatError (IncompatibleFields name) = "Field " <> show name <> " has a leaf in one place and a non-leaf in another." formatError (TypeConditionNotFound name) = "Type condition " <> show name <> " not found in schema." + formatError (VariableTypeNotFound var name) = "Type named " <> show name <> " for variable " <> show var <> " is not in the schema." + formatError (VariableTypeIsNotInputType var name) = "Type named " <> show name <> " for variable " <> show var <> " is not an input type." type ValidationErrors = NonEmpty ValidationError @@ -838,6 +873,11 @@ Just dups -> throwErrors dups -- * Error handling + +-- | Utility function for tests, format ErrorTypes to their text representation +-- returns a list of error messages +formatErrors :: [ValidationError] -> [Text] +formatErrors errors = formatError <$> errors -- | A 'Validator' is a value that can either be valid or have a non-empty -- list of errors. diff --git a/src/GraphQL/Internal/Value.hs b/src/GraphQL/Internal/Value.hs new file mode 100644 --- /dev/null +++ b/src/GraphQL/Internal/Value.hs @@ -0,0 +1,367 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | Description: Literal GraphQL values +module GraphQL.Internal.Value + ( Value + , Value'(..) + , ConstScalar + , UnresolvedVariableValue + , pattern ValueInt + , pattern ValueFloat + , pattern ValueBoolean + , pattern ValueString + , pattern ValueEnum + , pattern ValueList + , pattern ValueObject + , pattern ValueNull + , toObject + , valueToAST + , astToVariableValue + , variableValueToAST + , List + , List'(..) + , String(..) + -- * Names + , Name(..) + , NameError(..) + , makeName + -- * Objects + , Object + , Object'(..) + , ObjectField + , ObjectField'(ObjectField) + -- ** Constructing + , makeObject + , objectFromList + , objectFromOrderedMap + -- ** Combining + , unionObjects + -- ** Querying + , objectFields + ) where + +import Protolude + +import qualified Data.Aeson as Aeson +import Data.Aeson (ToJSON(..), (.=), pairs) +import qualified Data.Map as Map +import Test.QuickCheck (Arbitrary(..), Gen, oneof, listOf, sized) + +import GraphQL.Internal.Arbitrary (arbitraryText) +import GraphQL.Internal.Name (Name(..), NameError(..), makeName) +import GraphQL.Internal.Syntax.AST (Variable) +import qualified GraphQL.Internal.Syntax.AST as AST +import GraphQL.Internal.OrderedMap (OrderedMap) +import qualified GraphQL.Internal.OrderedMap as OrderedMap + +-- * Values + +-- | A GraphQL value. @scalar@ represents the type of scalar that's contained +-- within this value. +-- +-- Normally, it is one of either 'ConstScalar' (to indicate that there are no +-- variables whatsoever) or 'VariableScalar' (to indicate that there might be +-- some variables). +data Value' scalar + = ValueScalar' scalar + | ValueList' (List' scalar) + | ValueObject' (Object' scalar) + deriving (Eq, Ord, Show, Functor) + +instance Foldable Value' where + foldMap f (ValueScalar' scalar) = f scalar + foldMap f (ValueList' values) = foldMap f values + foldMap f (ValueObject' obj) = foldMap f obj + +instance Traversable Value' where + traverse f (ValueScalar' x) = ValueScalar' <$> f x + traverse f (ValueList' xs) = ValueList' <$> traverse f xs + traverse f (ValueObject' xs) = ValueObject' <$> traverse f xs + +instance ToJSON scalar => ToJSON (Value' scalar) where + toJSON (ValueScalar' x) = toJSON x + toJSON (ValueList' x) = toJSON x + toJSON (ValueObject' x) = toJSON x + +instance Arbitrary scalar => Arbitrary (Value' scalar) where + -- | Generate an arbitrary value. Uses the generator's \"size\" property to + -- determine maximum object depth. + arbitrary = sized genValue + +-- | Generate an arbitrary value, with objects at most @n@ levels deep. +genValue :: Arbitrary scalar => Int -> Gen (Value' scalar) +genValue n + | n <= 0 = arbitrary + | otherwise = oneof [ ValueScalar' <$> arbitrary + , ValueObject' <$> genObject (n - 1) + , ValueList' . List' <$> listOf (genValue (n - 1)) + ] + +-- | A GraphQL value which contains no variables. +type Value = Value' ConstScalar + +-- TODO: These next two definitions are quite internal. We should move this +-- module to Internal and then re-export the bits that end-users will use. +-- + +-- | A GraphQL value which might contain some variables. These variables are +-- not yet associated with +-- (see also 'GraphQL.Internal.Validation.VariableDefinition'), +-- which are provided in a different context. +type UnresolvedVariableValue = Value' UnresolvedVariableScalar + +pattern ValueInt :: Int32 -> Value +pattern ValueInt x = ValueScalar' (ConstInt x) + +pattern ValueFloat :: Double -> Value +pattern ValueFloat x = ValueScalar' (ConstFloat x) + +pattern ValueBoolean :: Bool -> Value +pattern ValueBoolean x = ValueScalar' (ConstBoolean x) + +pattern ValueString :: String -> Value +pattern ValueString x = ValueScalar' (ConstString x) + +pattern ValueEnum :: Name -> Value +pattern ValueEnum x = ValueScalar' (ConstEnum x) + +pattern ValueList :: forall t. List' t -> Value' t +pattern ValueList x = ValueList' x + +pattern ValueObject :: forall t. Object' t -> Value' t +pattern ValueObject x = ValueObject' x + +pattern ValueNull :: Value +pattern ValueNull = ValueScalar' ConstNull + +-- | If a value is an object, return just that. Otherwise @Nothing@. +toObject :: Value' scalar -> Maybe (Object' scalar) +toObject (ValueObject' o) = pure o +toObject _ = empty + +-- * Scalars + +-- | A non-variable value which contains no other values. +data ConstScalar + = ConstInt Int32 + | ConstFloat Double + | ConstBoolean Bool + | ConstString String + | ConstEnum Name + | ConstNull + deriving (Eq, Ord, Show) + +instance ToJSON ConstScalar where + toJSON (ConstInt x) = toJSON x + toJSON (ConstFloat x) = toJSON x + toJSON (ConstBoolean x) = toJSON x + toJSON (ConstString x) = toJSON x + toJSON (ConstEnum x) = toJSON x + toJSON ConstNull = Aeson.Null + +-- | A value which contains no other values, and might be a variable that +-- might lack a definition. +type UnresolvedVariableScalar = Either Variable ConstScalar + +-- | Generate an arbitrary scalar value. +instance Arbitrary ConstScalar where + arbitrary = oneof [ ConstInt <$> arbitrary + , ConstFloat <$> arbitrary + , ConstBoolean <$> arbitrary + , ConstString <$> arbitrary + , ConstEnum <$> arbitrary + , pure ConstNull + ] + +-- | Convert a constant scalar to an AST.Value +constScalarToAST :: ConstScalar -> AST.Value +constScalarToAST scalar = + case scalar of + ConstInt x -> AST.ValueInt x + ConstFloat x -> AST.ValueFloat x + ConstBoolean x -> AST.ValueBoolean x + ConstString (String x) -> AST.ValueString (AST.StringValue x) + ConstEnum x -> AST.ValueEnum x + ConstNull -> AST.ValueNull + +-- | Convert a variable scalar to an AST.Value +variableToAST :: UnresolvedVariableScalar -> AST.Value +variableToAST (Left variable) = AST.ValueVariable variable +variableToAST (Right constant) = constScalarToAST constant + +-- | Convert a value from the AST into a variable scalar, presuming it /is/ a +-- scalar. +astToScalar :: AST.Value -> Maybe UnresolvedVariableScalar +astToScalar (AST.ValueInt x) = pure $ Right $ ConstInt x +astToScalar (AST.ValueFloat x) = pure $ Right $ ConstFloat x +astToScalar (AST.ValueBoolean x) = pure $ Right $ ConstBoolean x +astToScalar (AST.ValueString (AST.StringValue x)) = pure $ Right $ ConstString (String x) +astToScalar (AST.ValueEnum x) = pure $ Right $ ConstEnum x +astToScalar AST.ValueNull = pure $ Right ConstNull +astToScalar (AST.ValueVariable x) = pure $ Left x +astToScalar _ = empty + + +-- * Strings + +newtype String = String Text deriving (Eq, Ord, Show) + +instance Arbitrary String where + arbitrary = String <$> arbitraryText + +instance ToJSON String where + toJSON (String x) = toJSON x + +-- * Lists + +newtype List' scalar = List' [Value' scalar] deriving (Eq, Ord, Show, Functor) + +instance Foldable List' where + foldMap f (List' values) = mconcat (map (foldMap f) values) + +instance Traversable List' where + traverse f (List' xs) = List' <$> traverse (traverse f) xs + + +-- | A list of values that are known to be constants. +-- +-- Note that this list might not be valid GraphQL, because GraphQL only allows +-- homogeneous lists (i.e. all elements of the same type), and we do no type +-- checking at this point. +type List = List' ConstScalar + +instance Arbitrary scalar => Arbitrary (List' scalar) where + -- TODO: GraphQL does not allow heterogeneous lists: + -- https://facebook.github.io/graphql/#sec-Lists, so this will generate + -- invalid lists. + arbitrary = List' <$> listOf arbitrary + + +instance ToJSON scalar => ToJSON (List' scalar) where + toJSON (List' x) = toJSON x + +-- * Objects + +-- | A GraphQL object. +-- +-- Note that https://facebook.github.io/graphql/#sec-Response calls these +-- \"Maps\", but everywhere else in the spec refers to them as objects. +newtype Object' scalar = Object' (OrderedMap Name (Value' scalar)) deriving (Eq, Ord, Show, Functor) + +instance Foldable Object' where + foldMap f (Object' fieldMap) = foldMap (foldMap f) fieldMap + +instance Traversable Object' where + traverse f (Object' xs) = Object' <$> traverse (traverse f) xs + +-- | A GraphQL object that contains only non-variable values. +type Object = Object' ConstScalar + +objectFields :: Object' scalar -> [ObjectField' scalar] +objectFields (Object' object) = map (uncurry ObjectField') (OrderedMap.toList object) + +instance Arbitrary scalar => Arbitrary (Object' scalar) where + arbitrary = sized genObject + +-- | Generate an arbitrary object to the given maximum depth. +genObject :: Arbitrary scalar => Int -> Gen (Object' scalar) +genObject n = Object' <$> OrderedMap.genOrderedMap arbitrary (genValue n) + +data ObjectField' scalar = ObjectField' Name (Value' scalar) deriving (Eq, Ord, Show, Functor) + +-- | A field of an object that has a non-variable value. +type ObjectField = ObjectField' ConstScalar + +pattern ObjectField :: forall t. Name -> Value' t -> ObjectField' t +pattern ObjectField name value = ObjectField' name value + +instance Arbitrary scalar => Arbitrary (ObjectField' scalar) where + arbitrary = ObjectField' <$> arbitrary <*> arbitrary + +-- | Make an object from a list of object fields. +makeObject :: [ObjectField' scalar] -> Maybe (Object' scalar) +makeObject fields = objectFromList [(name, value) | ObjectField' name value <- fields] + +-- | Make an object from an ordered map. +objectFromOrderedMap :: OrderedMap Name (Value' scalar) -> Object' scalar +objectFromOrderedMap = Object' + +-- | Create an object from a list of (name, value) pairs. +objectFromList :: [(Name, Value' scalar)] -> Maybe (Object' scalar) +objectFromList xs = Object' <$> OrderedMap.orderedMap xs + +unionObjects :: [Object' scalar] -> Maybe (Object' scalar) +unionObjects objects = Object' <$> OrderedMap.unions [obj | Object' obj <- objects] + +instance ToJSON scalar => ToJSON (Object' scalar) where + -- Direct encoding to preserve order of keys / values + toJSON (Object' xs) = toJSON (Map.fromList [(unName k, v) | (k, v) <- OrderedMap.toList xs]) + toEncoding (Object' xs) = pairs (foldMap (\(k, v) -> toS (unName k) .= v) (OrderedMap.toList xs)) + + + + +-- * Conversion to and from AST. + +-- | Convert an AST value into a literal value. +-- +-- This is a stop-gap until we have proper conversion of user queries into +-- canonical forms. +astToValue' :: (AST.Value -> scalar) -> AST.Value -> Maybe (Value' scalar) +astToValue' f x@(AST.ValueInt _) = pure (ValueScalar' (f x)) +astToValue' f x@(AST.ValueFloat _) = pure (ValueScalar' (f x)) +astToValue' f x@(AST.ValueBoolean _) = pure (ValueScalar' (f x)) +astToValue' f x@(AST.ValueString (AST.StringValue _)) = pure (ValueScalar' (f x)) +astToValue' f x@(AST.ValueEnum _) = pure (ValueScalar' (f x)) +astToValue' f AST.ValueNull = pure (ValueScalar' (f AST.ValueNull)) +astToValue' f x@(AST.ValueVariable _) = pure (ValueScalar' (f x)) +astToValue' f (AST.ValueList (AST.ListValue xs)) = ValueList' . List' <$> traverse (astToValue' f) xs +astToValue' f (AST.ValueObject (AST.ObjectValue fields)) = do + fields' <- traverse toObjectField fields + object <- makeObject fields' + pure (ValueObject' object) + where + toObjectField (AST.ObjectField name value) = ObjectField' name <$> astToValue' f value + +-- | Convert an AST value to a variable value. +-- +-- Will fail if the AST value contains duplicate object fields, or is +-- otherwise invalid. +astToVariableValue :: HasCallStack => AST.Value -> Maybe UnresolvedVariableValue +astToVariableValue ast = astToValue' convertScalar ast + where + convertScalar x = + case astToScalar x of + Just scalar -> scalar + Nothing -> panic ("Non-scalar passed to convertScalar, bug in astToValue': " <> show x) + +-- | Convert a value to an AST value. +valueToAST :: Value -> AST.Value +valueToAST = valueToAST' constScalarToAST + +-- | Convert a variable value to an AST value. +variableValueToAST :: UnresolvedVariableValue -> AST.Value +variableValueToAST = valueToAST' variableToAST + +-- | Convert a literal value into an AST value. +-- +-- Nulls are converted into Nothing. +-- +-- This function probably isn't particularly useful, but it functions as a +-- stop-gap until we have QuickCheck generators for the AST. +valueToAST' :: (scalar -> AST.Value) -> Value' scalar -> AST.Value +valueToAST' f (ValueScalar' x) = f x +valueToAST' f (ValueList' (List' xs)) = AST.ValueList (AST.ListValue (map (valueToAST' f) xs)) +valueToAST' f (ValueObject' (Object' fields)) = AST.ValueObject (AST.ObjectValue (map toObjectField (OrderedMap.toList fields))) + where + toObjectField (name, value) = AST.ObjectField name (valueToAST' f value) diff --git a/src/GraphQL/Internal/Value/FromValue.hs b/src/GraphQL/Internal/Value/FromValue.hs new file mode 100644 --- /dev/null +++ b/src/GraphQL/Internal/Value/FromValue.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | Description: Convert GraphQL values to domain-specific Haskell values +module GraphQL.Internal.Value.FromValue + ( FromValue(..) + , prop_roundtripValue + , wrongType + ) where + +import Protolude hiding (TypeError) + +import qualified Data.List.NonEmpty as NonEmpty +import GHC.Generics ((:*:)(..)) +import GHC.TypeLits (KnownSymbol, TypeError, ErrorMessage(..)) +import GHC.Types (Type) + +import GraphQL.Internal.Name (nameFromSymbol) +import qualified GraphQL.Internal.OrderedMap as OM +import GraphQL.Internal.Value +import GraphQL.Internal.Value.ToValue (ToValue(..)) + +-- * FromValue + +-- | @a@ can be converted from a GraphQL 'Value' to a Haskell value. +-- +-- The @FromValue@ instance converts 'AST.Value' to the type expected by the +-- handler function. It is the boundary between incoming data and your custom +-- application Haskell types. +-- +-- @FromValue@ has a generic instance for converting input objects to +-- records. +class FromValue a where + -- | Convert an already-parsed value into a Haskell value, generally to be + -- passed to a handler. + fromValue :: Value' ConstScalar -> Either Text a + default fromValue :: (Generic a, GenericFromValue (Rep a)) => Value' ConstScalar -> Either Text a + fromValue (ValueObject v) = to <$> genericFromValue v + fromValue v = wrongType "genericFromValue only works with objects." v + +instance FromValue Int32 where + fromValue (ValueInt v) = pure v + fromValue v = wrongType "Int" v + +instance FromValue Double where + fromValue (ValueFloat v) = pure v + fromValue v = wrongType "Double" v + +instance FromValue Bool where + fromValue (ValueBoolean v) = pure v + fromValue v = wrongType "Bool" v + +instance FromValue Text where + fromValue (ValueString (String v)) = pure v + fromValue v = wrongType "String" v + +instance forall v. FromValue v => FromValue [v] where + fromValue (ValueList' (List' values)) = traverse (fromValue @v) values + fromValue v = wrongType "List" v + +instance forall v. FromValue v => FromValue (NonEmpty v) where + fromValue (ValueList' (List' values)) = + case NonEmpty.nonEmpty values of + Nothing -> Left "Cannot construct NonEmpty from empty list" + Just values' -> traverse (fromValue @v) values' + fromValue v = wrongType "List" v + +instance forall v. FromValue v => FromValue (Maybe v) where + fromValue ValueNull = pure Nothing + fromValue x = Just <$> fromValue @v x + +-- | Anything that can be converted to a value and from a value should roundtrip. +prop_roundtripValue :: forall a. (Eq a, ToValue a, FromValue a) => a -> Bool +prop_roundtripValue x = fromValue (toValue x) == Right x + +-- | Throw an error saying that @value@ does not have the @expected@ type. +wrongType :: (MonadError Text m, Show a) => Text -> a -> m b +wrongType expected value = throwError ("Wrong type, should be: `" <> expected <> "` but is: `" <> show value <> "`") + +-- We only allow generic record reading for now because I am not sure +-- how we should interpret any other generic things (e.g. tuples). +class GenericFromValue (f :: Type -> Type) where + genericFromValue :: Object' ConstScalar -> Either Text (f p) + +instance forall dataName consName records s l p. + ( KnownSymbol dataName + , KnownSymbol consName + , GenericFromValue records + ) => GenericFromValue (D1 ('MetaData dataName s l 'False) + (C1 ('MetaCons consName p 'True) records + )) where + genericFromValue o = M1 . M1 <$> genericFromValue @records o + + +instance forall l r. + ( GenericFromValue l + , GenericFromValue r + ) => GenericFromValue (l :*: r) where + genericFromValue object = liftA2 (:*:) (genericFromValue @l object) (genericFromValue @r object) + +-- | Look up a single record field element in the Object. +getValue :: forall wrappedType fieldName u s l p. (FromValue wrappedType, KnownSymbol fieldName) + => Object' ConstScalar -> Either Text ((S1 ('MetaSel ('Just fieldName) u s l) (Rec0 wrappedType)) p) +getValue (Object' fieldMap) = do + fieldName <- case nameFromSymbol @fieldName of + Left err -> throwError ("invalid field name" <> show err) + Right name' -> pure name' + -- TODO(tom): How do we deal with optional fields? Maybe sounds + -- like the correct type, but how would Maybe be different from + -- `null`? Delegating to FromValue not good enough here because of + -- the dictionary lookup. + case OM.lookup fieldName fieldMap of + Nothing -> throwError ("Key not found: " <> show fieldName) + Just v -> M1 . K1 <$> fromValue @wrappedType v + +instance forall wrappedType fieldName u s l. + ( KnownSymbol fieldName + , FromValue wrappedType + ) => GenericFromValue (S1 ('MetaSel ('Just fieldName) u s l) (Rec0 wrappedType)) where + genericFromValue = getValue @wrappedType @fieldName + +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 = panic "genericFromValue cannot be called for records with more than one data constructor. Code that tries will not be compiled." diff --git a/src/GraphQL/Internal/Value/ToValue.hs b/src/GraphQL/Internal/Value/ToValue.hs new file mode 100644 --- /dev/null +++ b/src/GraphQL/Internal/Value/ToValue.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | Description: Turn domain-specific Haskell values into GraphQL values. +module GraphQL.Internal.Value.ToValue + ( ToValue(..) + ) where + +import Protolude + +import GraphQL.Internal.Value + +-- * ToValue + +-- | Turn a Haskell value into a GraphQL value. +class ToValue a where + toValue :: a -> Value' ConstScalar + +instance ToValue (Value' ConstScalar) where + toValue = identity + +-- XXX: Should this just be for Foldable? +instance ToValue a => ToValue [a] where + toValue = toValue . List' . map toValue + +-- TODO - tom still thinks that using Maybe for nullable is maybe not +-- the best idea. +instance ToValue a => ToValue (Maybe a) where + toValue Nothing = ValueNull + toValue (Just v) = toValue v + +instance ToValue a => ToValue (NonEmpty a) where + toValue = toValue . makeList + +instance ToValue Bool where + toValue = ValueBoolean + +instance ToValue Int32 where + toValue = ValueInt + +instance ToValue Double where + toValue = ValueFloat + +instance ToValue String where + toValue = ValueString + +-- XXX: Make more generic: any string-like thing rather than just Text. +instance ToValue Text where + toValue = toValue . String + +instance ToValue List where + toValue = ValueList' + +instance ToValue (Object' ConstScalar) where + toValue = ValueObject' + + +makeList :: (Functor f, Foldable f, ToValue a) => f a -> List +makeList = List' . Protolude.toList . map toValue diff --git a/src/GraphQL/Resolver.hs b/src/GraphQL/Resolver.hs --- a/src/GraphQL/Resolver.hs +++ b/src/GraphQL/Resolver.hs @@ -1,508 +1,18 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeFamilyDependencies #-} -- nicer type errors in some cases -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -- for TypeError - +-- | Description: Implement handlers for GraphQL schemas +-- +-- Contains everything you need to write handlers for your GraphQL schema. module GraphQL.Resolver + ( module Export + ) where + +import GraphQL.Internal.Resolver as Export ( ResolverError(..) , HasResolver(..) + , OperationResolverConstraint , (:<>)(..) , Result(..) , unionValue - ) where - --- TODO (probably incomplete, the spec is large) --- - input objects - I'm not super clear from the spec on how --- they differ from normal objects. --- - "extend type X" is used in examples in the spec but it's not --- explained anywhere? --- - 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, throwE) - -import qualified Data.Text as Text -import qualified Data.List.NonEmpty as NonEmpty -import GHC.TypeLits (KnownSymbol, TypeError, ErrorMessage(..), Symbol, symbolVal) -import GHC.Types (Type) -import qualified GHC.Exts (Any) -import Unsafe.Coerce (unsafeCoerce) - -import GraphQL.API - ( (:>) - , HasAnnotatedType(..) - , HasAnnotatedInputType(..) - ) -import qualified GraphQL.API as API -import qualified GraphQL.Value as GValue -import GraphQL.Value - ( Value - , pattern ValueEnum - ) -import GraphQL.Value.FromValue (FromValue(..)) -import GraphQL.Value.ToValue (ToValue(..)) -import GraphQL.Internal.Name (Name, NameError(..), HasName(..), nameFromSymbol) -import qualified GraphQL.Internal.OrderedMap as OrderedMap -import GraphQL.Internal.Output (GraphQLError(..)) -import GraphQL.Internal.Validation - ( SelectionSetByType - , SelectionSet(..) - , Field - , ValidationErrors - , getSubSelectionSet - , getSelectionSetForType - , lookupArgument + , resolveOperation + , returns + , handlerError ) - -data ResolverError - -- | There was a problem in the schema. Server-side problem. - = SchemaError NameError - -- | Couldn't find the requested field in the object. A client-side problem. - | FieldNotFoundError Name - -- | No value provided for name, and no default specified. Client-side problem. - | ValueMissing Name - -- | Could not translate value into Haskell. Probably a client-side problem. - | InvalidValue Name Text - -- | Found validation errors when we tried to merge fields. - | ValidationError ValidationErrors - -- | Tried to get subselection of leaf field. - | SubSelectionOnLeaf (SelectionSetByType Value) - -- | Tried to treat an object as a leaf. - | MissingSelectionSet - deriving (Show, Eq) - -instance GraphQLError ResolverError where - formatError (SchemaError e) = - "Schema error: " <> formatError e - formatError (FieldNotFoundError field) = - "Field not supported by the API: " <> show field - formatError (ValueMissing name) = - "No value provided for " <> show name <> ", and no default specified." - formatError (InvalidValue name text) = - "Could not coerce " <> show name <> " to valid value: " <> text - formatError (ValidationError errs) = - "Validation errors: " <> Text.intercalate ", " (map formatError (NonEmpty.toList errs)) - formatError (SubSelectionOnLeaf ss) = - "Tried to get values within leaf field: " <> show ss - formatError MissingSelectionSet = - "Tried to treat object as if it were leaf field." - --- | Object field separation operator. --- --- Use this to provide handlers for fields of an object. --- --- Say you had the following GraphQL type with \"foo\" and \"bar\" fields, --- e.g. --- --- @ --- type MyObject { --- foo: Int! --- bar: String! --- } --- @ --- --- You could provide handlers for it like this: --- --- >>> :m +System.Environment --- >>> let fooHandler = pure 42 --- >>> let barHandler = System.Environment.getProgName --- >>> let myObjectHandler = pure $ fooHandler :<> barHandler :<> () -data a :<> b = a :<> b -infixr 8 :<> - - --- Result collects errors and values at the same time unless a handler --- tells us to bail out in which case we stop the processing --- immediately. -data Result a = Result [ResolverError] a deriving (Show, Functor, Eq) - --- Aggregating results keeps all errors and creates a ValueList --- containing the individual values. -aggregateResults :: [Result Value] -> Result Value -aggregateResults r = toValue <$> sequenceA r - -throwE :: Applicative f => ResolverError -> f (Result Value) -throwE err = pure (Result [err] GValue.ValueNull) - -instance Applicative Result where - pure v = Result [] v - (Result e1 f) <*> (Result e2 x) = Result (e1 <> e2) (f x) - -ok :: Value -> Result Value -ok = pure - -class HasResolver m a where - type Handler m a - resolve :: Handler m a -> Maybe (SelectionSetByType Value) -> m (Result Value) - --- | Called when the schema expects an input argument @name@ of type @a@ but --- @name@ has not been provided. -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 - resolve handler Nothing = map (ok . toValue) handler - resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) - -instance forall m. (Applicative m) => HasResolver m Double where - type Handler m Double = m Double - resolve handler Nothing = map (ok . toValue) handler - resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) - -instance forall m. (Applicative m) => HasResolver m Text where - type Handler m Text = m Text - resolve handler Nothing = map (ok . toValue) handler - resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) - -instance forall m. (Applicative m) => HasResolver m Bool where - type Handler m Bool = m Bool - resolve handler Nothing = map (ok . toValue) handler - resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) - -instance forall m hg. (Monad m, Applicative m, HasResolver m hg) => HasResolver m (API.List hg) where - type Handler m (API.List hg) = m [Handler m hg] - resolve handler selectionSet = do - h <- handler - let a = traverse (flip (resolve @m @hg) selectionSet) h - 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) = 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 - type Handler m (Maybe hg) = m (Maybe (Handler m hg)) - resolve handler selectionSet = do - result <- handler - case result of - Just x -> resolve @m @hg (x :: Handler m hg) selectionSet - Nothing -> (pure . ok) GValue.ValueNull - --- TODO: A parametrized `Result` is really not a good way to handle the --- "result" for resolveField, but not sure what to use either. Tom liked the --- tuple we had before more because it didn't imply any other structure or --- meaning. Maybe we can just create a new datatype. jml thinks we should --- extract some helpful generic monad, ala `Validator`. --- -type ResolveFieldResult = Result (Maybe GValue.Value) - --- Extract field name from an argument type. TODO: ideally we'd run --- this directly on the "a :> b" argument structure, but that requires --- passing in the plain argument structure type into resolveField or --- resolving "name" in the buildFieldResolver. Both options duplicate --- code somwehere else. -type family FieldName (a :: Type) = (r :: Symbol) where - FieldName (JustHandler (API.Field name t)) = name - FieldName (PlainArgument a f) = FieldName f - FieldName (EnumArgument a f) = FieldName f - FieldName x = TypeError ('Text "Unexpected branch in FieldName type family. Please file a bug!" ':<>: 'ShowType x) - -resolveField :: forall dispatchType (m :: Type -> Type). - (BuildFieldResolver m dispatchType, Monad m, KnownSymbol (FieldName dispatchType)) - => FieldHandler m dispatchType -> m ResolveFieldResult -> Field Value -> m ResolveFieldResult -resolveField handler nextHandler field = - -- check name before - case nameFromSymbol @(FieldName dispatchType) of - Left err -> pure (Result [SchemaError err] (Just GValue.ValueNull)) - Right name' - | getName field == name' -> - case buildFieldResolver @m @dispatchType handler field of - Left err -> pure (Result [err] (Just GValue.ValueNull)) - Right resolver -> do - Result errs value <- resolver - pure (Result errs (Just value)) - | otherwise -> nextHandler - --- We're using our usual trick of rewriting a type in a closed type --- family to emulate a closed typeclass. The following are the --- universe of "allowed" class instances for field types: -data JustHandler a -data EnumArgument a b -data PlainArgument a b - --- injective helps with errors sometimes -type family FieldResolverDispatchType (a :: Type) = (r :: Type) | r -> a where - FieldResolverDispatchType (API.Field ksA t) = JustHandler (API.Field ksA t) - FieldResolverDispatchType (API.Argument ksB (API.Enum name t) :> f) = EnumArgument (API.Argument ksB (API.Enum name t)) (FieldResolverDispatchType f) - FieldResolverDispatchType (API.Argument ksC t :> f) = PlainArgument (API.Argument ksC t) (FieldResolverDispatchType f) - --- | Derive the handler type from the Field/Argument type in a closed --- type family: We don't want anyone else to extend this ever. -type family FieldHandler (m :: Type -> Type) (a :: Type) = (r :: Type) where - FieldHandler m (JustHandler (API.Field ksD t)) = Handler m t - FieldHandler m (PlainArgument (API.Argument ksE t) f) = t -> FieldHandler m f - FieldHandler m (EnumArgument (API.Argument ksF (API.Enum name t)) f) = t -> FieldHandler m f - -class BuildFieldResolver m fieldResolverType where - buildFieldResolver :: FieldHandler m fieldResolverType -> Field Value -> Either ResolverError (m (Result Value)) - -instance forall ksG t m. - ( KnownSymbol ksG, HasResolver m t, HasAnnotatedType t, Monad m - ) => BuildFieldResolver m (JustHandler (API.Field ksG t)) where - buildFieldResolver handler field = do - pure (resolve @m @t handler (getSubSelectionSet field)) - -instance forall ksH t f m. - ( KnownSymbol ksH - , BuildFieldResolver m f - , FromValue t - , API.Defaultable t - , HasAnnotatedInputType t - , Monad m - ) => BuildFieldResolver m (PlainArgument (API.Argument ksH t) f) where - buildFieldResolver handler field = do - argument <- first SchemaError (API.getArgumentDefinition @(API.Argument ksH t)) - let argName = getName argument - value <- case lookupArgument field argName of - Nothing -> valueMissing @t argName - Just v -> first (InvalidValue argName) (fromValue @t v) - buildFieldResolver @m @f (handler value) field - -instance forall ksK t f m name. - ( KnownSymbol ksK - , BuildFieldResolver m f - , KnownSymbol name - , API.Defaultable t - , API.GraphQLEnum t - , Monad m - ) => BuildFieldResolver m (EnumArgument (API.Argument ksK (API.Enum name t)) f) where - buildFieldResolver handler field = do - argName <- first SchemaError (nameFromSymbol @ksK) - value <- case lookupArgument field argName of - Nothing -> valueMissing @t argName - Just (ValueEnum enum) -> first (InvalidValue argName) (API.enumFromValue @t enum) - Just value -> Left (InvalidValue argName (show value <> " not an enum: " <> show (API.enumValues @t))) - buildFieldResolver @m @f (handler value) field - --- Note that we enumerate all ks variables with capital letters so we --- can figure out error messages like the following that don't come --- with line numbers: --- --- • No instance for (GHC.TypeLits.KnownSymbol ks0) --- arising from a use of ‘interpretAnonymousQuery’ - --- We only allow Field and Argument :> Field combinations: -type family RunFieldsType (m :: Type -> Type) (a :: [Type]) = (r :: Type) where - RunFieldsType m '[API.Field ksI t] = API.Field ksI t - RunFieldsType m '[a :> b] = a :> b - RunFieldsType m ((API.Field ksJ t) ': rest) = API.Field ksJ t :<> RunFieldsType m rest - RunFieldsType m ((a :> b) ': rest) = (a :> b) :<> RunFieldsType m rest - RunFieldsType m a = TypeError ( - 'Text "All field entries in an Object must be Field or Argument :> Field. Got: " ':<>: 'ShowType a) - --- Match the three possible cases for Fields (see also RunFieldsType) -type family RunFieldsHandler (m :: Type -> Type) (a :: Type) = (r :: Type) where - RunFieldsHandler m (f :<> fs) = FieldHandler m (FieldResolverDispatchType f) :<> RunFieldsHandler m fs - RunFieldsHandler m (API.Field ksL t) = FieldHandler m (FieldResolverDispatchType (API.Field ksL t)) - RunFieldsHandler m (a :> b) = FieldHandler m (FieldResolverDispatchType (a :> b)) - RunFieldsHandler m a = TypeError ( - 'Text "Unexpected RunFieldsHandler types: " ':<>: 'ShowType a) - - -class RunFields m a where - -- | Run a single 'Selection' over all possible fields (as specified by the - -- type @a@), returning exactly one 'GValue.ObjectField' when a field - -- matches, or an error otherwise. - -- - -- Individual implementations are responsible for calling 'runFields' if - -- they haven't matched the field and there are still candidate fields - -- within the handler. - runFields :: RunFieldsHandler m a -> Field Value -> m ResolveFieldResult - -instance forall f fs m dispatchType. - ( BuildFieldResolver m dispatchType - , dispatchType ~ FieldResolverDispatchType f - , RunFields m fs - , KnownSymbol (FieldName dispatchType) - , Monad m - ) => RunFields m (f :<> fs) where - runFields (handler :<> nextHandlers) field = - resolveField @dispatchType @m handler nextHandler field - where - nextHandler = runFields @m @fs nextHandlers field - -instance forall ksM t m dispatchType. - ( BuildFieldResolver m dispatchType - , KnownSymbol ksM - , dispatchType ~ FieldResolverDispatchType (API.Field ksM t) - , Monad m - ) => RunFields m (API.Field ksM t) where - runFields handler field = - resolveField @dispatchType @m handler nextHandler field - where - nextHandler = pure (Result [FieldNotFoundError (getName field)] Nothing) - -instance forall m a b dispatchType. - ( BuildFieldResolver m dispatchType - , dispatchType ~ FieldResolverDispatchType (a :> b) - , KnownSymbol (FieldName dispatchType) - , Monad m - ) => RunFields m (a :> b) where - runFields handler field = - resolveField @dispatchType @m handler nextHandler field - where - nextHandler = pure (Result [FieldNotFoundError (getName field)] Nothing) - -instance forall typeName interfaces fields m. - ( RunFields m (RunFieldsType m fields) - , API.HasObjectDefinition (API.Object typeName interfaces fields) - , Monad m - ) => HasResolver m (API.Object typeName interfaces fields) where - type Handler m (API.Object typeName interfaces fields) = m (RunFieldsHandler m (RunFieldsType m fields)) - - resolve _ Nothing = throwE MissingSelectionSet - resolve mHandler (Just selectionSet) = - case getSelectionSet of - Left err -> throwE err - Right ss -> do - -- Run the handler so the field resolvers have access to the object. - -- This (and other places, including field resolvers) is where user - -- code can do things like look up something in a database. - handler <- mHandler - r <- traverse (runFields @m @(RunFieldsType m fields) handler) ss - let (Result errs obj) = GValue.objectFromOrderedMap . OrderedMap.catMaybes <$> sequenceA r - pure (Result errs (GValue.ValueObject obj)) - - where - getSelectionSet = do - defn <- first SchemaError $ API.getDefinition @(API.Object typeName interfaces fields) - -- Fields of a selection set may be behind "type conditions", due to - -- inline fragments or the use of fragment spreads. These type - -- conditions are represented in the schema by the name of a type - -- (e.g. "Dog"). To determine which type conditions (and thus which - -- fields) are relevant for this 1selection set, we need to look up the - -- actual types they refer to, as interfaces (say) match objects - -- differently than unions. - -- - -- See for - -- more details. - (SelectionSet ss') <- first ValidationError $ getSelectionSetForType defn selectionSet - pure ss' - --- TODO(tom): we're getting to a point where it might make sense to --- split resolver into submodules (GraphQL.Resolver.Union etc.) - - --- | For unions we need a way to have type-safe, open sum types based --- on the possible 'API.Object's of a union. The following closed type --- family selects one Object from the union and returns the matching --- 'HasResolver' 'Handler' type. If the object @o@ is not a member of --- 'API.Union' then the user code won't compile. --- --- This type family is an implementation detail but its TypeError --- messages are visible at compile time. -type family TypeIndex (m :: Type -> Type) (object :: Type) (union :: Type) = (result :: Type) where - TypeIndex m (API.Object name interfaces fields) (API.Union uName (API.Object name interfaces fields:_)) = - Handler m (API.Object name interfaces fields) - TypeIndex m (API.Object name interfaces fields) (API.Union uName (API.Object name' i' f':objects)) = - TypeIndex m (API.Object name interfaces fields) (API.Union uName objects) - -- Slightly nicer type errors: - TypeIndex _ (API.Object name interfaces fields) (API.Union uName '[]) = - TypeError ('Text "Type not found in union definition: " ':<>: 'ShowType (API.Object name interfaces fields)) - TypeIndex _ (API.Object name interfaces fields) x = - TypeError ('Text "3rd type must be a union but it is: " ':<>: 'ShowType x) - TypeIndex _ o _ = - TypeError ('Text "Invalid TypeIndex. Must be Object but got: " ':<>: 'ShowType o) - - --- | The 'Handler' type of a 'API.Union' must be the same for all --- possible Objects, but each Object has a different type. We --- unsafeCoerce the return type into an Any, tagging it with the union --- and the underlying monad for type safety, but we elide the Object --- type itself. This way we can represent all 'Handler' types of the --- Union with a single type and still stay type-safe. -type role DynamicUnionValue representational representational -data DynamicUnionValue (union :: Type) (m :: Type -> Type) = DynamicUnionValue { _label :: Text, _value :: GHC.Exts.Any } - -class RunUnion m union objects where - runUnion :: DynamicUnionValue union m -> SelectionSetByType Value -> m (Result Value) - -instance forall m union objects name interfaces fields. - ( Monad m - , KnownSymbol name - , TypeIndex m (API.Object name interfaces fields) union ~ Handler m (API.Object name interfaces fields) - , RunFields m (RunFieldsType m fields) - , API.HasObjectDefinition (API.Object name interfaces fields) - , RunUnion m union objects - ) => RunUnion m union (API.Object name interfaces fields:objects) where - runUnion duv selectionSet = - case extractUnionValue @(API.Object name interfaces fields) @union @m duv of - Just handler -> resolve @m @(API.Object name interfaces fields) handler (Just selectionSet) - Nothing -> runUnion @m @union @objects duv selectionSet - --- AFAICT it should not be possible to ever hit the empty case because --- the compiler doesn't allow constructing a unionValue that's not in --- the Union. If the following code ever gets executed it's almost --- certainly a bug in the union code. --- --- We still need to implement this instance for the compiler because --- it exhaustively checks all cases when deconstructs the Union. -instance forall m union. RunUnion m union '[] where - runUnion (DynamicUnionValue label _) selection = - panic ("Unexpected branch in runUnion, got " <> show selection <> " for label " <> label <> ". Please file a bug.") - -instance forall m unionName objects. - ( Monad m - , KnownSymbol unionName - , RunUnion m (API.Union unionName objects) objects - ) => HasResolver m (API.Union unionName objects) where - type Handler m (API.Union unionName objects) = m (DynamicUnionValue (API.Union unionName objects) m) - resolve _ Nothing = throwE MissingSelectionSet - resolve mHandler (Just selectionSet) = do - duv <- mHandler - runUnion @m @(API.Union unionName objects) @objects duv selectionSet - -symbolText :: forall ks. KnownSymbol ks => Text -symbolText = toS (symbolVal @ks Proxy) - --- | Translate a 'Handler' into a DynamicUnionValue type required by --- 'Union' handlers. This is dynamic, but nevertheless type-safe --- because we can only tag with types that are part of the union. --- --- Use e.g. like "unionValue @Cat" if you have an object like this: --- --- >>> type Cat = API.Object "Cat" '[] '[API.Field "name" Text] --- --- and then use `unionValue @Cat (pure (pure "Felix"))`. See --- `examples/UnionExample.hs` for more code. -unionValue :: - forall (object :: Type) (union :: Type) m (name :: Symbol) interfaces fields. - (Monad m, API.Object name interfaces fields ~ object, KnownSymbol name) - => TypeIndex m object union -> m (DynamicUnionValue union m) -unionValue x = - -- TODO(tom) - we might want to move to Typeable `cast` for uValue - -- instead of doing our own unsafeCoerce because it comes with - -- additional safety guarantees: Typerep is unforgeable, while we - -- can still into a bad place by matching on name only. We can't - -- actually segfault this because right now we walk the list of - -- objects in a union left-to-right so in case of duplicate names we - -- only every see one type. That doesn't seen like a great thing to - -- rely on though! - - -- Note that unsafeCoerce is safe because we index the type from the - -- union with an 'API.Object' whose name we're storing in label. On - -- the way out we check that the name is the same, and we know the - -- type universe is the same because we annotated DynamicUnionValue - -- with the type universe. - pure (DynamicUnionValue (symbolText @name) (unsafeCoerce x)) - -extractUnionValue :: - forall (object :: Type) (union :: Type) m (name :: Symbol) interfaces fields. - (API.Object name interfaces fields ~ object, KnownSymbol name) - => DynamicUnionValue union m -> Maybe (TypeIndex m object union) -extractUnionValue (DynamicUnionValue uName uValue) = - if uName == symbolText @name - then Just (unsafeCoerce uValue) - else Nothing diff --git a/src/GraphQL/Value.hs b/src/GraphQL/Value.hs --- a/src/GraphQL/Value.hs +++ b/src/GraphQL/Value.hs @@ -1,14 +1,5 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} +-- | Description: Literal GraphQL values {-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - --- | Literal GraphQL values. module GraphQL.Value ( Value , Value'(..) @@ -46,321 +37,47 @@ , unionObjects -- ** Querying , objectFields + -- * Converting to and from Value + , ToValue(..) + , FromValue(..) ) where -import Protolude - -import qualified Data.Aeson as Aeson -import Data.Aeson (ToJSON(..), (.=), pairs) -import qualified Data.Map as Map -import Test.QuickCheck (Arbitrary(..), Gen, oneof, listOf, sized) - -import GraphQL.Internal.Arbitrary (arbitraryText) -import GraphQL.Internal.Name (Name(..), NameError(..), makeName) -import GraphQL.Internal.Syntax.AST (Variable) -import qualified GraphQL.Internal.Syntax.AST as AST -import GraphQL.Internal.OrderedMap (OrderedMap) -import qualified GraphQL.Internal.OrderedMap as OrderedMap - --- * Values - --- | A GraphQL value. @scalar@ represents the type of scalar that's contained --- within this value. --- --- Normally, it is one of either 'ConstScalar' (to indicate that there are no --- variables whatsoever) or 'VariableScalar' (to indicate that there might be --- some variables). -data Value' scalar - = ValueScalar' scalar - | ValueList' (List' scalar) - | ValueObject' (Object' scalar) - deriving (Eq, Ord, Show, Functor) - -instance Foldable Value' where - foldMap f (ValueScalar' scalar) = f scalar - foldMap f (ValueList' values) = foldMap f values - foldMap f (ValueObject' obj) = foldMap f obj - -instance Traversable Value' where - traverse f (ValueScalar' x) = ValueScalar' <$> f x - traverse f (ValueList' xs) = ValueList' <$> traverse f xs - traverse f (ValueObject' xs) = ValueObject' <$> traverse f xs - -instance ToJSON scalar => ToJSON (Value' scalar) where - toJSON (ValueScalar' x) = toJSON x - toJSON (ValueList' x) = toJSON x - toJSON (ValueObject' x) = toJSON x - -instance Arbitrary scalar => Arbitrary (Value' scalar) where - -- | Generate an arbitrary value. Uses the generator's \"size\" property to - -- determine maximum object depth. - arbitrary = sized genValue - --- | Generate an arbitrary value, with objects at most @n@ levels deep. -genValue :: Arbitrary scalar => Int -> Gen (Value' scalar) -genValue n - | n <= 0 = arbitrary - | otherwise = oneof [ ValueScalar' <$> arbitrary - , ValueObject' <$> genObject (n - 1) - , ValueList' . List' <$> listOf (genValue (n - 1)) - ] - --- | A GraphQL value which contains no variables. -type Value = Value' ConstScalar - --- TODO: These next two definitions are quite internal. We should move this --- module to Internal and then re-export the bits that end-users will use. --- - --- | A GraphQL value which might contain some variables. These variables are --- not yet associated with --- (see also 'GraphQL.Internal.Validation.VariableDefinition'), --- which are provided in a different context. -type UnresolvedVariableValue = Value' UnresolvedVariableScalar - -pattern ValueInt :: Int32 -> Value -pattern ValueInt x = ValueScalar' (ConstInt x) - -pattern ValueFloat :: Double -> Value -pattern ValueFloat x = ValueScalar' (ConstFloat x) - -pattern ValueBoolean :: Bool -> Value -pattern ValueBoolean x = ValueScalar' (ConstBoolean x) - -pattern ValueString :: String -> Value -pattern ValueString x = ValueScalar' (ConstString x) - -pattern ValueEnum :: Name -> Value -pattern ValueEnum x = ValueScalar' (ConstEnum x) - -pattern ValueList :: forall t. List' t -> Value' t -pattern ValueList x = ValueList' x - -pattern ValueObject :: forall t. Object' t -> Value' t -pattern ValueObject x = ValueObject' x - -pattern ValueNull :: Value -pattern ValueNull = ValueScalar' ConstNull - --- | If a value is an object, return just that. Otherwise @Nothing@. -toObject :: Value' scalar -> Maybe (Object' scalar) -toObject (ValueObject' o) = pure o -toObject _ = empty - --- * Scalars - --- | A non-variable value which contains no other values. -data ConstScalar - = ConstInt Int32 - | ConstFloat Double - | ConstBoolean Bool - | ConstString String - | ConstEnum Name - | ConstNull - deriving (Eq, Ord, Show) - -instance ToJSON ConstScalar where - toJSON (ConstInt x) = toJSON x - toJSON (ConstFloat x) = toJSON x - toJSON (ConstBoolean x) = toJSON x - toJSON (ConstString x) = toJSON x - toJSON (ConstEnum x) = toJSON x - toJSON ConstNull = Aeson.Null - --- | A value which contains no other values, and might be a variable that --- might lack a definition. -type UnresolvedVariableScalar = Either Variable ConstScalar - --- | Generate an arbitrary scalar value. -instance Arbitrary ConstScalar where - arbitrary = oneof [ ConstInt <$> arbitrary - , ConstFloat <$> arbitrary - , ConstBoolean <$> arbitrary - , ConstString <$> arbitrary - , ConstEnum <$> arbitrary - , pure ConstNull - ] - --- | Convert a constant scalar to an AST.Value -constScalarToAST :: ConstScalar -> AST.Value -constScalarToAST scalar = - case scalar of - ConstInt x -> AST.ValueInt x - ConstFloat x -> AST.ValueFloat x - ConstBoolean x -> AST.ValueBoolean x - ConstString (String x) -> AST.ValueString (AST.StringValue x) - ConstEnum x -> AST.ValueEnum x - ConstNull -> AST.ValueNull - --- | Convert a variable scalar to an AST.Value -variableToAST :: UnresolvedVariableScalar -> AST.Value -variableToAST (Left variable) = AST.ValueVariable variable -variableToAST (Right constant) = constScalarToAST constant - --- | Convert a value from the AST into a variable scalar, presuming it /is/ a --- scalar. -astToScalar :: AST.Value -> Maybe UnresolvedVariableScalar -astToScalar (AST.ValueInt x) = pure $ Right $ ConstInt x -astToScalar (AST.ValueFloat x) = pure $ Right $ ConstFloat x -astToScalar (AST.ValueBoolean x) = pure $ Right $ ConstBoolean x -astToScalar (AST.ValueString (AST.StringValue x)) = pure $ Right $ ConstString (String x) -astToScalar (AST.ValueEnum x) = pure $ Right $ ConstEnum x -astToScalar AST.ValueNull = pure $ Right ConstNull -astToScalar (AST.ValueVariable x) = pure $ Left x -astToScalar _ = empty - - --- * Strings - -newtype String = String Text deriving (Eq, Ord, Show) - -instance Arbitrary String where - arbitrary = String <$> arbitraryText - -instance ToJSON String where - toJSON (String x) = toJSON x - --- * Lists - -newtype List' scalar = List' [Value' scalar] deriving (Eq, Ord, Show, Functor) - -instance Foldable List' where - foldMap f (List' values) = mconcat (map (foldMap f) values) - -instance Traversable List' where - traverse f (List' xs) = List' <$> traverse (traverse f) xs - - --- | A list of values that are known to be constants. --- --- Note that this list might not be valid GraphQL, because GraphQL only allows --- homogeneous lists (i.e. all elements of the same type), and we do no type --- checking at this point. -type List = List' ConstScalar - -instance Arbitrary scalar => Arbitrary (List' scalar) where - -- TODO: GraphQL does not allow heterogeneous lists: - -- https://facebook.github.io/graphql/#sec-Lists, so this will generate - -- invalid lists. - arbitrary = List' <$> listOf arbitrary - - -instance ToJSON scalar => ToJSON (List' scalar) where - toJSON (List' x) = toJSON x - --- * Objects - --- | A GraphQL object. --- --- Note that https://facebook.github.io/graphql/#sec-Response calls these --- \"Maps\", but everywhere else in the spec refers to them as objects. -newtype Object' scalar = Object' (OrderedMap Name (Value' scalar)) deriving (Eq, Ord, Show, Functor) - -instance Foldable Object' where - foldMap f (Object' fieldMap) = foldMap (foldMap f) fieldMap - -instance Traversable Object' where - traverse f (Object' xs) = Object' <$> traverse (traverse f) xs - --- | A GraphQL object that contains only non-variable values. -type Object = Object' ConstScalar - -objectFields :: Object' scalar -> [ObjectField' scalar] -objectFields (Object' object) = map (uncurry ObjectField') (OrderedMap.toList object) - -instance Arbitrary scalar => Arbitrary (Object' scalar) where - arbitrary = sized genObject - --- | Generate an arbitrary object to the given maximum depth. -genObject :: Arbitrary scalar => Int -> Gen (Object' scalar) -genObject n = Object' <$> OrderedMap.genOrderedMap arbitrary (genValue n) - -data ObjectField' scalar = ObjectField' Name (Value' scalar) deriving (Eq, Ord, Show, Functor) - --- | A field of an object that has a non-variable value. -type ObjectField = ObjectField' ConstScalar - -pattern ObjectField :: forall t. Name -> Value' t -> ObjectField' t -pattern ObjectField name value = ObjectField' name value - -instance Arbitrary scalar => Arbitrary (ObjectField' scalar) where - arbitrary = ObjectField' <$> arbitrary <*> arbitrary - --- | Make an object from a list of object fields. -makeObject :: [ObjectField' scalar] -> Maybe (Object' scalar) -makeObject fields = objectFromList [(name, value) | ObjectField' name value <- fields] - --- | Make an object from an ordered map. -objectFromOrderedMap :: OrderedMap Name (Value' scalar) -> Object' scalar -objectFromOrderedMap = Object' - --- | Create an object from a list of (name, value) pairs. -objectFromList :: [(Name, Value' scalar)] -> Maybe (Object' scalar) -objectFromList xs = Object' <$> OrderedMap.orderedMap xs - -unionObjects :: [Object' scalar] -> Maybe (Object' scalar) -unionObjects objects = Object' <$> OrderedMap.unions [obj | Object' obj <- objects] - -instance ToJSON scalar => ToJSON (Object' scalar) where - -- Direct encoding to preserve order of keys / values - toJSON (Object' xs) = toJSON (Map.fromList [(unName k, v) | (k, v) <- OrderedMap.toList xs]) - toEncoding (Object' xs) = pairs (foldMap (\(k, v) -> toS (unName k) .= v) (OrderedMap.toList xs)) - - - - --- * Conversion to and from AST. - --- | Convert an AST value into a literal value. --- --- This is a stop-gap until we have proper conversion of user queries into --- canonical forms. -astToValue' :: (AST.Value -> scalar) -> AST.Value -> Maybe (Value' scalar) -astToValue' f x@(AST.ValueInt _) = pure (ValueScalar' (f x)) -astToValue' f x@(AST.ValueFloat _) = pure (ValueScalar' (f x)) -astToValue' f x@(AST.ValueBoolean _) = pure (ValueScalar' (f x)) -astToValue' f x@(AST.ValueString (AST.StringValue _)) = pure (ValueScalar' (f x)) -astToValue' f x@(AST.ValueEnum _) = pure (ValueScalar' (f x)) -astToValue' f AST.ValueNull = pure (ValueScalar' (f AST.ValueNull)) -astToValue' f x@(AST.ValueVariable _) = pure (ValueScalar' (f x)) -astToValue' f (AST.ValueList (AST.ListValue xs)) = ValueList' . List' <$> traverse (astToValue' f) xs -astToValue' f (AST.ValueObject (AST.ObjectValue fields)) = do - fields' <- traverse toObjectField fields - object <- makeObject fields' - pure (ValueObject' object) - where - toObjectField (AST.ObjectField name value) = ObjectField' name <$> astToValue' f value - --- | Convert an AST value to a variable value. --- --- Will fail if the AST value contains duplicate object fields, or is --- otherwise invalid. -astToVariableValue :: HasCallStack => AST.Value -> Maybe UnresolvedVariableValue -astToVariableValue ast = astToValue' convertScalar ast - where - convertScalar x = - case astToScalar x of - Just scalar -> scalar - Nothing -> panic ("Non-scalar passed to convertScalar, bug in astToValue': " <> show x) - --- | Convert a value to an AST value. -valueToAST :: Value -> AST.Value -valueToAST = valueToAST' constScalarToAST - --- | Convert a variable value to an AST value. -variableValueToAST :: UnresolvedVariableValue -> AST.Value -variableValueToAST = valueToAST' variableToAST - --- | Convert a literal value into an AST value. --- --- Nulls are converted into Nothing. --- --- This function probably isn't particularly useful, but it functions as a --- stop-gap until we have QuickCheck generators for the AST. -valueToAST' :: (scalar -> AST.Value) -> Value' scalar -> AST.Value -valueToAST' f (ValueScalar' x) = f x -valueToAST' f (ValueList' (List' xs)) = AST.ValueList (AST.ListValue (map (valueToAST' f) xs)) -valueToAST' f (ValueObject' (Object' fields)) = AST.ValueObject (AST.ObjectValue (map toObjectField (OrderedMap.toList fields))) - where - toObjectField (name, value) = AST.ObjectField name (valueToAST' f value) +import GraphQL.Internal.Value + ( Value + , Value'(..) + , ConstScalar + , UnresolvedVariableValue + , pattern ValueInt + , pattern ValueFloat + , pattern ValueBoolean + , pattern ValueString + , pattern ValueEnum + , pattern ValueList + , pattern ValueObject + , pattern ValueNull + , toObject + , valueToAST + , astToVariableValue + , variableValueToAST + , List + , List'(..) + , String(..) + , Name(..) + , NameError(..) + , makeName + , Object + , Object'(..) + , ObjectField + , ObjectField'(ObjectField) + , makeObject + , objectFromList + , objectFromOrderedMap + , unionObjects + , objectFields + ) +import GraphQL.Internal.Value.FromValue + ( FromValue(..) + ) +import GraphQL.Internal.Value.ToValue + ( ToValue(..) + ) diff --git a/src/GraphQL/Value/FromValue.hs b/src/GraphQL/Value/FromValue.hs deleted file mode 100644 --- a/src/GraphQL/Value/FromValue.hs +++ /dev/null @@ -1,135 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE AllowAmbiguousTypes #-} - --- | Literal GraphQL values. -module GraphQL.Value.FromValue - ( FromValue(..) - , prop_roundtripValue - , wrongType - ) where - -import Protolude hiding (TypeError) -import GraphQL.Internal.Name (nameFromSymbol) -import qualified GraphQL.Internal.OrderedMap as OM -import GraphQL.Value -import GraphQL.Value.ToValue (ToValue(..)) -import qualified Data.List.NonEmpty as NonEmpty -import Data.List.NonEmpty (NonEmpty) -import GHC.Generics ((:*:)(..)) -import GHC.TypeLits (KnownSymbol, TypeError, ErrorMessage(..)) -import GHC.Types (Type) - --- * FromValue - --- | @a@ can be converted from a GraphQL 'Value' to a Haskell value. --- --- The @FromValue@ instance converts 'AST.Value' to the type expected by the --- handler function. It is the boundary between incoming data and your custom --- application Haskell types. --- --- @FromValue@ has a generic instance for converting input objects to --- records. -class FromValue a where - -- | Convert an already-parsed value into a Haskell value, generally to be - -- passed to a handler. - fromValue :: Value' ConstScalar -> Either Text a - default fromValue :: (Generic a, GenericFromValue (Rep a)) => Value' ConstScalar -> Either Text a - fromValue (ValueObject v) = to <$> genericFromValue v - fromValue v = wrongType "genericFromValue only works with objects." v - -instance FromValue Int32 where - fromValue (ValueInt v) = pure v - fromValue v = wrongType "Int" v - -instance FromValue Double where - fromValue (ValueFloat v) = pure v - fromValue v = wrongType "Double" v - -instance FromValue Bool where - fromValue (ValueBoolean v) = pure v - fromValue v = wrongType "Bool" v - -instance FromValue Text where - fromValue (ValueString (String v)) = pure v - fromValue v = wrongType "String" v - -instance forall v. FromValue v => FromValue [v] where - fromValue (ValueList' (List' values)) = traverse (fromValue @v) values - fromValue v = wrongType "List" v - -instance forall v. FromValue v => FromValue (NonEmpty v) where - fromValue (ValueList' (List' values)) = - case NonEmpty.nonEmpty values of - Nothing -> Left "Cannot construct NonEmpty from empty list" - Just values' -> traverse (fromValue @v) values' - fromValue v = wrongType "List" v - -instance forall v. FromValue v => FromValue (Maybe v) where - fromValue ValueNull = pure Nothing - fromValue x = Just <$> fromValue @v x - --- | Anything that can be converted to a value and from a value should roundtrip. -prop_roundtripValue :: forall a. (Eq a, ToValue a, FromValue a) => a -> Bool -prop_roundtripValue x = fromValue (toValue x) == Right x - --- | Throw an error saying that @value@ does not have the @expected@ type. -wrongType :: (MonadError Text m, Show a) => Text -> a -> m b -wrongType expected value = throwError ("Wrong type, should be: `" <> expected <> "` but is: `" <> show value <> "`") - --- We only allow generic record reading for now because I am not sure --- how we should interpret any other generic things (e.g. tuples). -class GenericFromValue (f :: Type -> Type) where - genericFromValue :: Object' ConstScalar -> Either Text (f p) - -instance forall dataName consName records s l p. - ( KnownSymbol dataName - , KnownSymbol consName - , GenericFromValue records - ) => GenericFromValue (D1 ('MetaData dataName s l 'False) - (C1 ('MetaCons consName p 'True) records - )) where - genericFromValue o = M1 . M1 <$> genericFromValue @records o - -instance forall wrappedType fieldName rest u s l. - ( KnownSymbol fieldName - , FromValue wrappedType - , GenericFromValue rest - ) => GenericFromValue (S1 ('MetaSel ('Just fieldName) u s l) (Rec0 wrappedType) :*: rest) where - genericFromValue object = do - l <- getValue @wrappedType @fieldName object - r <- genericFromValue @rest object - pure (l :*: r) - --- | Look up a single record field element in the Object. -getValue :: forall wrappedType fieldName u s l p. (FromValue wrappedType, KnownSymbol fieldName) - => Object' ConstScalar -> Either Text ((S1 ('MetaSel ('Just fieldName) u s l) (Rec0 wrappedType)) p) -getValue (Object' fieldMap) = do - fieldName <- case nameFromSymbol @fieldName of - Left err -> throwError ("invalid field name" <> show err) - Right name' -> pure name' - -- TODO(tom): How do we deal with optional fields? Maybe sounds - -- like the correct type, but how would Maybe be different from - -- `null`? Delegating to FromValue not good enough here because of - -- the dictionary lookup. - case OM.lookup fieldName fieldMap of - Nothing -> throwError ("Key not found: " <> show fieldName) - Just v -> M1 . K1 <$> fromValue @wrappedType v - -instance forall wrappedType fieldName u s l. - ( KnownSymbol fieldName - , FromValue wrappedType - ) => GenericFromValue (S1 ('MetaSel ('Just fieldName) u s l) (Rec0 wrappedType)) where - genericFromValue = getValue @wrappedType @fieldName - -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 = panic "genericFromValue cannot be called for records with more than one data constructor. Code that tries will not be compiled." diff --git a/src/GraphQL/Value/ToValue.hs b/src/GraphQL/Value/ToValue.hs deleted file mode 100644 --- a/src/GraphQL/Value/ToValue.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} - -module GraphQL.Value.ToValue - ( ToValue(..) - ) where - -import Protolude -import GraphQL.Value -import Data.List.NonEmpty (NonEmpty) - --- * ToValue - --- | Turn a Haskell value into a GraphQL value. -class ToValue a where - toValue :: a -> Value' ConstScalar - -instance ToValue (Value' ConstScalar) where - toValue = identity - --- XXX: Should this just be for Foldable? -instance ToValue a => ToValue [a] where - toValue = toValue . List' . map toValue - --- TODO - tom still thinks that using Maybe for nullable is maybe not --- the best idea. -instance ToValue a => ToValue (Maybe a) where - toValue Nothing = ValueNull - toValue (Just v) = toValue v - -instance ToValue a => ToValue (NonEmpty a) where - toValue = toValue . makeList - -instance ToValue Bool where - toValue = ValueBoolean - -instance ToValue Int32 where - toValue = ValueInt - -instance ToValue Double where - toValue = ValueFloat - -instance ToValue String where - toValue = ValueString - --- XXX: Make more generic: any string-like thing rather than just Text. -instance ToValue Text where - toValue = toValue . String - -instance ToValue List where - toValue = ValueList' - -instance ToValue (Object' ConstScalar) where - toValue = ValueObject' - - -makeList :: (Functor f, Foldable f, ToValue a) => f a -> List -makeList = List' . Protolude.toList . map toValue diff --git a/tests/ASTSpec.hs b/tests/ASTSpec.hs new file mode 100644 --- /dev/null +++ b/tests/ASTSpec.hs @@ -0,0 +1,317 @@ +{-# LANGUAGE QuasiQuotes #-} + +-- | Tests for AST, including parser and encoder. +module ASTSpec (spec) where + +import Protolude + +import Data.Attoparsec.Text (parseOnly) +import Text.RawString.QQ (r) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (arbitrary, forAll, resize) +import Test.Hspec + +import GraphQL.Value (String(..)) +import GraphQL.Internal.Name (Name) +import qualified GraphQL.Internal.Syntax.AST as AST +import qualified GraphQL.Internal.Syntax.Parser as Parser +import qualified GraphQL.Internal.Syntax.Encoder as Encoder + +kitchenSink :: Text +kitchenSink = "query queryName($foo:ComplexType,$site:Site=MOBILE){whoever123is:node(id:[123,456]){id,... on User@defer{field2{id,alias:field1(first:10,after:$foo)@include(if:$foo){id,...frag}}}}}mutation likeStory{like(story:123)@defer{story{id}}}fragment frag on Friend{foo(size:$size,bar:$b,obj:{key:\"value\"})}\n" + +dog :: Name +dog = "dog" + +someName :: Name +someName = "name" + +spec :: Spec +spec = describe "AST" $ do + describe "Parser and encoder" $ do + it "roundtrips on minified documents" $ do + let actual = Encoder.queryDocument <$> parseOnly Parser.queryDocument kitchenSink + actual `shouldBe` Right kitchenSink + describe "parsing numbers" $ do + it "works for some integers" $ do + parseOnly Parser.value "1" `shouldBe` Right (AST.ValueInt 1) + prop "works for all integers" $ do + \x -> parseOnly Parser.value (show x) == Right (AST.ValueInt x) + it "works for some floats" $ do + parseOnly Parser.value "1.5" `shouldBe` Right (AST.ValueFloat 1.5) + it "treats floats as floats even if they end with .0" $ do + parseOnly Parser.value "0.0" `shouldBe` Right (AST.ValueFloat 0.0) + prop "works for floats" $ do + \x -> parseOnly Parser.value (show x) == Right (AST.ValueFloat x) + describe "strings" $ do + prop "works for all strings" $ do + \(String x) -> + let input = AST.ValueString (AST.StringValue x) + output = Encoder.value input in + parseOnly Parser.value output == Right input + it "handles unusual strings" $ do + let input = AST.ValueString (AST.StringValue "\fh\244") + let output = Encoder.value input + -- \f is \u000c + output `shouldBe` "\"\\u000ch\244\"" + parseOnly Parser.value output `shouldBe` Right input + describe "parsing values" $ do + prop "works for all literal values" $ do + forAll (resize 3 arbitrary) $ \x -> parseOnly Parser.value (Encoder.value x) `shouldBe` Right x + it "parses ununusual objects" $ do + let input = AST.ValueObject + (AST.ObjectValue + [ AST.ObjectField "s" + (AST.ValueString (AST.StringValue "\224\225v^6{FPDk\DC3\a")), + AST.ObjectField "Hsr" (AST.ValueInt 0) + ]) + let output = Encoder.value input + parseOnly Parser.value output `shouldBe` Right input + it "parses lists of floats" $ do + let input = AST.ValueList + (AST.ListValue + [ AST.ValueFloat 1.5 + , AST.ValueFloat 1.5 + ]) + let output = Encoder.value input + output `shouldBe` "[1.5,1.5]" + parseOnly Parser.value output `shouldBe` Right input + describe "Parser" $ do + it "parses shorthand syntax documents" $ do + let query = [r|{ + dog { + name + } + }|] + let Right parsed = parseOnly Parser.queryDocument query + let expected = AST.QueryDocument + [ AST.DefinitionOperation + (AST.AnonymousQuery + [ AST.SelectionField + (AST.Field Nothing dog [] [] + [ AST.SelectionField (AST.Field Nothing someName [] [] []) + ]) + ]) + ] + 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 "errors on missing selection set" $ do + let query = [r|query { + dog { + + } + }|] + let Left parsed = parseOnly Parser.queryDocument query + -- this is not very explicit + parsed `shouldBe` "query document error! > definition error!: string" + + it "parses invalid documents" $ do + let query = [r|{ + dog { + name + } + } + + query getName { + dog { + owner { + name + } + } + }|] + let Right parsed = parseOnly Parser.queryDocument query + let expected = AST.QueryDocument + [ AST.DefinitionOperation + (AST.AnonymousQuery + [ AST.SelectionField + (AST.Field Nothing dog [] [] + [ AST.SelectionField (AST.Field Nothing someName [] [] []) + ]) + ]) + , AST.DefinitionOperation + (AST.Query + (AST.Node (pure "getName") [] [] + [ AST.SelectionField + (AST.Field Nothing dog [] [] + [ AST.SelectionField + (AST.Field Nothing "owner" [] [] + [ AST.SelectionField (AST.Field Nothing someName [] [] []) + ]) + ]) + ])) + ] + parsed `shouldBe` expected + + it "includes variable definitions" $ do + let query = [r| + query houseTrainedQuery($atOtherHomes: Boolean = true) { + dog { + isHousetrained(atOtherHomes: $atOtherHomes) + } + } + |] + let Right parsed = parseOnly Parser.queryDocument query + let expected = AST.QueryDocument + [ AST.DefinitionOperation + (AST.Query + (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")) + (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 variable annotation" $ do + let query = [r| + query ($atOtherHomes: [Home!]) { + 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.TypeList + (AST.ListType + (AST.TypeNonNull + (AST.NonNullTypeNamed (AST.NamedType "Home")) + ) + ) + ) + Nothing + ] [] + [ 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 inline argument (List, Object, Enum, String, Number)" $ do + -- keys are not quoted for inline objects + let query = [r| + query { + dog { + isHousetrained(atOtherHomes: [{testKey: 123, anotherKey: "string"}]) + } + } + |] + 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 "isHousetrained" + [ AST.Argument "atOtherHomes" + (AST.ValueList (AST.ListValue [ + (AST.ValueObject (AST.ObjectValue [ + (AST.ObjectField "testKey" (AST.ValueInt 123)), + (AST.ObjectField "anotherKey" (AST.ValueString (AST.StringValue "string"))) + ])) + ])) + ] [] []) + ]) + ])) + ] + parsed `shouldBe` expected + it "parses anonymous query with fragment" $ do + -- keys are not quoted for inline objects + let query = [r| + fragment dogTest on Dog { + name + } + query { + dog { + ...dogTest + } + } + |] + let Right parsed = parseOnly Parser.queryDocument query + let expected = AST.QueryDocument + [(AST.DefinitionFragment (AST.FragmentDefinition "dogTest" + (AST.NamedType "Dog") [] [ + AST.SelectionField (AST.Field Nothing "name" [] [] []) + ])), + (AST.DefinitionOperation + (AST.Query + (AST.Node Nothing + [] [] + [AST.SelectionField + (AST.Field Nothing dog [] [] + [AST.SelectionFragmentSpread (AST.FragmentSpread "dogTest" []) + ]) + ]))) + ] + parsed `shouldBe` expected diff --git a/tests/ASTTests.hs b/tests/ASTTests.hs deleted file mode 100644 --- a/tests/ASTTests.hs +++ /dev/null @@ -1,213 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} - --- | Tests for AST, including parser and encoder. -module ASTTests (tests) where - -import Protolude - -import Data.Attoparsec.Text (parseOnly) -import Text.RawString.QQ (r) -import Test.Hspec.QuickCheck (prop) -import Test.QuickCheck (arbitrary, forAll, resize) -import Test.Tasty (TestTree) -import Test.Tasty.Hspec (testSpec, describe, it, shouldBe) - -import GraphQL.Value (String(..)) -import GraphQL.Internal.Name (Name) -import qualified GraphQL.Internal.Syntax.AST as AST -import qualified GraphQL.Internal.Syntax.Parser as Parser -import qualified GraphQL.Internal.Syntax.Encoder as Encoder - -kitchenSink :: Text -kitchenSink = "query queryName($foo:ComplexType,$site:Site=MOBILE){whoever123is:node(id:[123,456]){id,... on User@defer{field2{id,alias:field1(first:10,after:$foo)@include(if:$foo){id,...frag}}}}}mutation likeStory{like(story:123)@defer{story{id}}}fragment frag on Friend{foo(size:$size,bar:$b,obj:{key:\"value\"})}\n" - -dog :: Name -dog = "dog" - -someName :: Name -someName = "name" - -tests :: IO TestTree -tests = testSpec "AST" $ do - describe "Parser and encoder" $ do - it "roundtrips on minified documents" $ do - let actual = Encoder.queryDocument <$> parseOnly Parser.queryDocument kitchenSink - actual `shouldBe` Right kitchenSink - describe "parsing numbers" $ do - it "works for some integers" $ do - parseOnly Parser.value "1" `shouldBe` Right (AST.ValueInt 1) - prop "works for all integers" $ do - \x -> parseOnly Parser.value (show x) == Right (AST.ValueInt x) - it "works for some floats" $ do - parseOnly Parser.value "1.5" `shouldBe` Right (AST.ValueFloat 1.5) - it "treats floats as floats even if they end with .0" $ do - parseOnly Parser.value "0.0" `shouldBe` Right (AST.ValueFloat 0.0) - prop "works for floats" $ do - \x -> parseOnly Parser.value (show x) == Right (AST.ValueFloat x) - describe "strings" $ do - prop "works for all strings" $ do - \(String x) -> - let input = AST.ValueString (AST.StringValue x) - output = Encoder.value input in - parseOnly Parser.value output == Right input - it "handles unusual strings" $ do - let input = AST.ValueString (AST.StringValue "\fh\244") - let output = Encoder.value input - -- \f is \u000c - output `shouldBe` "\"\\u000ch\244\"" - parseOnly Parser.value output `shouldBe` Right input - describe "parsing values" $ do - prop "works for all literal values" $ do - forAll (resize 3 arbitrary) $ \x -> parseOnly Parser.value (Encoder.value x) `shouldBe` Right x - it "parses ununusual objects" $ do - let input = AST.ValueObject - (AST.ObjectValue - [ AST.ObjectField "s" - (AST.ValueString (AST.StringValue "\224\225v^6{FPDk\DC3\a")), - AST.ObjectField "Hsr" (AST.ValueInt 0) - ]) - let output = Encoder.value input - parseOnly Parser.value output `shouldBe` Right input - it "parses lists of floats" $ do - let input = AST.ValueList - (AST.ListValue - [ AST.ValueFloat 1.5 - , AST.ValueFloat 1.5 - ]) - let output = Encoder.value input - output `shouldBe` "[1.5,1.5]" - parseOnly Parser.value output `shouldBe` Right input - describe "Parser" $ do - it "parses shorthand syntax documents" $ do - let query = [r|{ - dog { - name - } - }|] - let Right parsed = parseOnly Parser.queryDocument query - let expected = AST.QueryDocument - [ AST.DefinitionOperation - (AST.AnonymousQuery - [ AST.SelectionField - (AST.Field Nothing dog [] [] - [ AST.SelectionField (AST.Field Nothing someName [] [] []) - ]) - ]) - ] - 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 { - name - } - } - - query getName { - dog { - owner { - name - } - } - }|] - let Right parsed = parseOnly Parser.queryDocument query - let expected = AST.QueryDocument - [ AST.DefinitionOperation - (AST.AnonymousQuery - [ AST.SelectionField - (AST.Field Nothing dog [] [] - [ AST.SelectionField (AST.Field Nothing someName [] [] []) - ]) - ]) - , AST.DefinitionOperation - (AST.Query - (AST.Node (pure "getName") [] [] - [ AST.SelectionField - (AST.Field Nothing dog [] [] - [ AST.SelectionField - (AST.Field Nothing "owner" [] [] - [ AST.SelectionField (AST.Field Nothing someName [] [] []) - ]) - ]) - ])) - ] - parsed `shouldBe` expected - - it "includes variable definitions" $ do - let query = [r| - query houseTrainedQuery($atOtherHomes: Boolean = true) { - dog { - isHousetrained(atOtherHomes: $atOtherHomes) - } - } - |] - let Right parsed = parseOnly Parser.queryDocument query - let expected = AST.QueryDocument - [ AST.DefinitionOperation - (AST.Query - (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")) - (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 diff --git a/tests/EndToEndSpec.hs b/tests/EndToEndSpec.hs new file mode 100644 --- /dev/null +++ b/tests/EndToEndSpec.hs @@ -0,0 +1,484 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeOperators #-} +-- | Tests that span the entire system. +-- +-- These tests function both as examples of how to use the API, as well as +-- sanity checks on our reasoning. +module EndToEndSpec (spec) where + +import Protolude + +import Data.Aeson (Value(Null), toJSON, object, (.=)) +import qualified Data.Map as Map +import GraphQL (makeSchema, compileQuery, executeQuery, interpretAnonymousQuery, interpretQuery) +import GraphQL.API (Object, Field, List, Argument, (:>), Defaultable(..), HasAnnotatedInputType(..)) +import GraphQL.Internal.Syntax.AST (Variable(..)) +import GraphQL.Resolver ((:<>)(..), Handler, unionValue, returns) +import GraphQL.Value (ToValue(..), FromValue(..), makeName) +import Test.Hspec +import Text.RawString.QQ (r) + +import ExampleSchema + +-- | Example query root. +-- +-- @ +-- type QueryRoot { +-- dog: Dog +-- describeDog(dog: DEFAULT): String +-- } +-- @ +-- +-- Drawn from . +type QueryRoot = Object "QueryRoot" '[] + '[ Field "dog" Dog + , Argument "dog" DogStuff :> Field "describeDog" Text + , Field "catOrDog" CatOrDog + , Field "catOrDogList" (List CatOrDog) + ] + +-- | An object that is passed as an argument. i.e. an input object. +-- +-- TODO: Ideally this would be Dog itself, or ServerDog at worst. +-- Unfortunately, jml cannot figure out how to do that. +data DogStuff = DogStuff { toy :: Text, likesTreats :: Bool } deriving (Show, Generic) +instance FromValue DogStuff +instance HasAnnotatedInputType DogStuff +instance Defaultable DogStuff where + defaultFor "dog" = pure DogStuff { toy = "shoe", likesTreats = False } + defaultFor _ = empty + +catOrDog :: Handler IO CatOrDog +catOrDog = do + name <- pure "MonadicFelix" -- we can do monadic actions + unionValue @Cat (catHandler name Nothing 15) + +catOrDogList :: Handler IO (List CatOrDog) +catOrDogList = + returns [ unionValue @Cat (catHandler "Felix the Cat" (Just "felix") 42) + , unionValue @Cat (catHandler "Henry" Nothing 10) + , unionValue @Dog (viewServerDog mortgage) + ] + +catHandler :: Text -> Maybe Text -> Int32 -> Handler IO Cat +catHandler name nickName meowVolume = pure $ + returns name :<> + returns (returns <$> nickName) :<> + returns . const False :<> -- doesn't know any commands + returns meowVolume + +-- | Our server's internal representation of a 'Dog'. +data ServerDog + = ServerDog + { name :: Text + , nickname :: Maybe Text + , barkVolume :: Int32 + , knownCommands :: Set DogCommand + , houseTrainedAtHome :: Bool + , houseTrainedElsewhere :: Bool + , owner :: ServerHuman + } + +-- | Whether 'ServerDog' knows the given command. +doesKnowCommand :: ServerDog -> DogCommand -> Bool +doesKnowCommand dog command = command `elem` knownCommands dog + +-- | Whether 'ServerDog' is house-trained. +isHouseTrained :: ServerDog -> Maybe Bool -> Bool +isHouseTrained dog Nothing = houseTrainedAtHome dog || houseTrainedElsewhere dog +isHouseTrained dog (Just False) = houseTrainedAtHome dog +isHouseTrained dog (Just True) = houseTrainedElsewhere dog + +-- | Present 'ServerDog' for GraphQL. +viewServerDog :: ServerDog -> Handler IO Dog +viewServerDog dog@ServerDog{..} = pure $ + returns name :<> + returns (fmap returns nickname) :<> + returns barkVolume :<> + returns . doesKnowCommand dog :<> + returns . isHouseTrained dog :<> + viewServerHuman owner + +describeDog :: DogStuff -> Handler IO Text +describeDog (DogStuff toy likesTreats) + | likesTreats = returns $ "likes treats and their favorite toy is a " <> toy + | otherwise = returns $ "their favorite toy is a " <> toy + +rootHandler :: ServerDog -> Handler IO QueryRoot +rootHandler dog = pure $ viewServerDog dog :<> describeDog :<> catOrDog :<> catOrDogList + +-- | jml has a stuffed black dog called "Mortgage". +mortgage :: ServerDog +mortgage = ServerDog + { name = "Mortgage" + , nickname = Just "Mort" + , barkVolume = 0 -- He's stuffed + , knownCommands = mempty -- He's stuffed + , houseTrainedAtHome = True -- Never been a problem + , houseTrainedElsewhere = True -- Untested in the field + , owner = jml + } + +-- | Our server's internal representation of a 'Human'. +newtype ServerHuman = ServerHuman Text deriving (Eq, Ord, Show, Generic) + + +-- | Present a 'ServerHuman' as a GraphQL 'Human'. +viewServerHuman :: ServerHuman -> Handler IO Human +viewServerHuman (ServerHuman name) = pure (returns name) + +-- | It me. +jml :: ServerHuman +jml = ServerHuman "jml" + + +spec :: Spec +spec = describe "End-to-end tests" $ do + describe "interpretAnonymousQuery" $ do + it "Handles the simplest possible valid query" $ do + let query = [r|{ + dog { + name + } + } + |] + response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query + let expected = + object + [ "data" .= object + [ "dog" .= object + [ "name" .= ("Mortgage" :: Text) + ] + ] + ] + toJSON (toValue response) `shouldBe` expected + it "Handles more than one field" $ do + let query = [r|{ + dog { + name + barkVolume + } + } + |] + response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query + let expected = + object + [ "data" .= object + [ "dog" .= object + [ "name" .= ("Mortgage" :: Text) + , "barkVolume" .= (0 :: Int32) + ] + ] + ] + toJSON (toValue response) `shouldBe` expected + it "Handles nested queries" $ do + let query = [r|{ + dog { + name + owner { + name + } + } + } + |] + response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query + let expected = + object + [ "data" .= object + [ "dog" .= object + [ "name" .= ("Mortgage" :: Text) + , "owner" .= object + [ "name" .= ("jml" :: Text) + ] + ] + ] + ] + toJSON (toValue response) `shouldBe` expected + it "It aliases fields" $ do + let query = [r|{ + dog { + name + boss: owner { + name + } + } + } + |] + response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query + let expected = + object + [ "data" .= object + [ "dog" .= object + [ "name" .= ("Mortgage" :: Text) + , "boss" .= object + [ "name" .= ("jml" :: Text) + ] + ] + ] + ] + toJSON (toValue response) `shouldBe` expected + it "Passes arguments to functions" $ do + let query = [r|{ + dog { + name + doesKnowCommand(dogCommand: Sit) + } + } + |] + response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query + let expected = + object + [ "data" .= object + [ "dog" .= object + [ "name" .= ("Mortgage" :: Text) + , "doesKnowCommand" .= False + ] + ] + ] + toJSON (toValue response) `shouldBe` expected + it "Passes arguments that are objects to functions" $ do + let query = [r|{ + describeDog(dog: {toy: "bone", likesTreats: true}) + } + |] + response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query + let expected = + object + [ "data" .= object + [ "describeDog" .= ("likes treats and their favorite toy is a bone" :: Text) ] + ] + toJSON (toValue response) `shouldBe` expected + it "Passes default arguments that are objects to functions" $ do + let query = [r|{ + describeDog + } + |] + response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query + let expected = + object + [ "data" .= object + [ "describeDog" .= ("their favorite toy is a shoe" :: Text) ] + ] + toJSON (toValue response) `shouldBe` expected + it "Handles fairly complex queries" $ do + let query = [r|{ + dog { + callsign: name + ... on Dog { + callsign: name + me: owner { + ... on Sentient { + name + } + ... on Human { + name + } + name + } + } + } + } + |] + response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query + let expected = + object + [ "data" .= object + [ "dog" .= object + [ "callsign" .= ("Mortgage" :: Text) + , "me" .= object + [ "name" .= ("jml" :: Text) + ] + ] + ] + ] + toJSON (toValue response) `shouldBe` expected + it "Lets you query union types" $ do + let query = "{ catOrDog { ... on Cat { name meowVolume } ... on Dog { barkVolume } } }" + response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query + let expected = + object + [ "data" .= object + [ "catOrDog" .= object + [ "name" .= ("MonadicFelix" :: Text) + , "meowVolume" .= (15 :: Float) + ] + ] + ] + toJSON (toValue response) `shouldBe` expected + it "Lets you query lists of union types" $ do + let query = "{ catOrDogList { ... on Cat { name meowVolume } ... on Dog { barkVolume } } }" + response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query + let expected = + object + [ "data" .= object + [ "catOrDogList" .= + [ object + [ "name" .= ("Felix the Cat" :: Text) + , "meowVolume" .= (42 :: Float) + ] + , object + [ "name" .= ("Henry" :: Text) + , "meowVolume" .= (10 :: Float) + ] + , object + [ "barkVolume" .= (0 :: Float) + ] + ] + ] + ] + toJSON (toValue response) `shouldBe` expected + describe "interpretQuery" $ do + it "Handles the simplest named query" $ do + let query = [r|query myQuery { + dog { + name + } + } + |] + response <- interpretQuery @QueryRoot (rootHandler mortgage) query Nothing mempty + let expected = + object + [ "data" .= object + [ "dog" .= object + [ "name" .= ("Mortgage" :: Text) + ] + ] + ] + toJSON (toValue response) `shouldBe` expected + it "Allows calling query by name" $ do + let query = [r|query myQuery { + dog { + name + } + } + |] + let Right name = makeName "myQuery" + response <- interpretQuery @QueryRoot (rootHandler mortgage) query (Just name) mempty + let expected = + object + [ "data" .= object + [ "dog" .= object + [ "name" .= ("Mortgage" :: Text) + ] + ] + ] + toJSON (toValue response) `shouldBe` expected + describe "Handles variables" $ do + let Right schema = makeSchema @Dog + let Right query = + compileQuery schema + [r|query myQuery($whichCommand: DogCommand) { + dog { + name + doesKnowCommand(dogCommand: $whichCommand) + } + } + |] + let Right annotatedQuery = + compileQuery schema + [r|query myQuery($whichCommand: DogCommand!) { + dog { + name + doesKnowCommand(dogCommand: $whichCommand) + } + } + |] + let Right badQuery = + compileQuery schema + [r|query myQuery($whichCommand: String!) { + dog { + name + doesKnowCommand(dogCommand: $whichCommand) + } + } + |] + it "Errors when variable and argument types are in conflict" $ do + let vars = Map.singleton (Variable "whichCommand") $ toValue @Text "cow" + response <- executeQuery @QueryRoot (rootHandler mortgage) badQuery Nothing vars + let expected = + object + [ "data" .= object + [ "dog" .= object + [ "name" .= ("Mortgage" :: Text) + , "doesKnowCommand" .= Null + ] + ] + , "errors" .= + [ + object + -- TODO: This error message is pretty bad. We should define + -- a typeclass for client-friendly "Show" (separate from + -- actual Show which remains extremely useful for debugging) + -- and use that when including values in error messages. + [ "message" .= ("Could not coerce Name {unName = \"dogCommand\"} to valid value: ValueScalar' (ConstString (String \"cow\")) not an enum: [Right (Name {unName = \"Sit\"}),Right (Name {unName = \"Down\"}),Right (Name {unName = \"Heel\"})]" :: Text) + ] + ] + ] + toJSON (toValue response) `shouldBe` expected + it "Errors when no variables provided" $ do + response <- executeQuery @QueryRoot (rootHandler mortgage) query Nothing mempty + let expected = + object + [ "data" .= object + [ "dog" .= object + [ "name" .= ("Mortgage" :: Text) + , "doesKnowCommand" .= Null + ] + ] + , "errors" .= + [ + object + [ "message" .= ("Could not coerce Name {unName = \"dogCommand\"} to valid value: ValueScalar' ConstNull not an enum: [Right (Name {unName = \"Sit\"}),Right (Name {unName = \"Down\"}),Right (Name {unName = \"Heel\"})]" :: Text) + ] + ] + ] + toJSON (toValue response) `shouldBe` expected + it "Substitutes variables when they are provided" $ do + -- TODO: This is a crummy way to make a variable map. jml doesn't want + -- to come up with a new API in this PR, but probably we should have a + -- very simple function to turn a JSON value / object into the + -- variable map that we desire. Alternatively, we should have APIs + -- like Aeson does. + -- + let Right varName = makeName "whichCommand" + let vars = Map.singleton (Variable varName) (toValue Sit) + response <- executeQuery @QueryRoot (rootHandler mortgage) query Nothing vars + let expected = + object + [ "data" .= object + [ "dog" .= object + [ "name" .= ("Mortgage" :: Text) + , "doesKnowCommand" .= False + ] + ] + ] + toJSON (toValue response) `shouldBe` expected + it "Substitutes annotated variables when they are provided" $ do + let Right varName = makeName "whichCommand" + let vars = Map.singleton (Variable varName) (toValue Sit) + response <- executeQuery @QueryRoot (rootHandler mortgage) annotatedQuery Nothing vars + let expected = + object + [ "data" .= object + [ "dog" .= object + [ "name" .= ("Mortgage" :: Text) + , "doesKnowCommand" .= False + ] + ] + ] + toJSON (toValue response) `shouldBe` expected + it "Errors when non-null variable is not provided" $ do + response <- executeQuery @QueryRoot (rootHandler mortgage) annotatedQuery Nothing mempty + let expected = + object + [ "data" .= Null + , "errors" .= + [ + object + [ "message" .= ("Execution error: MissingValue (Variable (Name {unName = \"whichCommand\"}))" :: Text) + ] + ] + ] + toJSON (toValue response) `shouldBe` expected diff --git a/tests/EndToEndTests.hs b/tests/EndToEndTests.hs deleted file mode 100644 --- a/tests/EndToEndTests.hs +++ /dev/null @@ -1,328 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE QuasiQuotes #-} --- | Tests that span the entire system. --- --- These tests function both as examples of how to use the API, as well as --- sanity checks on our reasoning. -module EndToEndTests (tests) where - -import Protolude - -import Data.Aeson (Value(Null), toJSON, object, (.=)) -import qualified Data.Map as Map -import GraphQL (makeSchema, compileQuery, executeQuery, interpretAnonymousQuery, interpretQuery) -import GraphQL.API (Object, Field) -import GraphQL.Internal.Syntax.AST (Variable(..)) -import GraphQL.Resolver ((:<>)(..), Handler) -import GraphQL.Value (makeName) -import GraphQL.Value.ToValue (ToValue(..)) -import Test.Tasty (TestTree) -import Test.Tasty.Hspec (testSpec, describe, it, shouldBe) -import Text.RawString.QQ (r) - -import ExampleSchema - --- | Example query root. --- --- @ --- type QueryRoot { --- dog: Dog --- } --- @ --- --- Drawn from . -type QueryRoot = Object "QueryRoot" '[] - '[ Field "dog" Dog - ] - --- | Our server's internal representation of a 'Dog'. -data ServerDog - = ServerDog - { name :: Text - , nickname :: Maybe Text - , barkVolume :: Int32 - , knownCommands :: Set DogCommand - , houseTrainedAtHome :: Bool - , houseTrainedElsewhere :: Bool - , owner :: ServerHuman - } - --- | Whether 'ServerDog' knows the given command. -doesKnowCommand :: ServerDog -> DogCommand -> Bool -doesKnowCommand dog command = command `elem` knownCommands dog - --- | Whether 'ServerDog' is house-trained. -isHouseTrained :: ServerDog -> Maybe Bool -> Bool -isHouseTrained dog Nothing = houseTrainedAtHome dog || houseTrainedElsewhere dog -isHouseTrained dog (Just False) = houseTrainedAtHome dog -isHouseTrained dog (Just True) = houseTrainedElsewhere dog - --- | Present 'ServerDog' for GraphQL. -viewServerDog :: ServerDog -> Handler IO Dog -viewServerDog dog@(ServerDog{..}) = pure $ - pure name :<> - pure (fmap pure nickname) :<> - pure barkVolume :<> - pure . doesKnowCommand dog :<> - pure . isHouseTrained dog :<> - viewServerHuman owner - --- | jml has a stuffed black dog called "Mortgage". -mortgage :: ServerDog -mortgage = ServerDog - { name = "Mortgage" - , nickname = Just "Mort" - , barkVolume = 0 -- He's stuffed - , knownCommands = mempty -- He's stuffed - , houseTrainedAtHome = True -- Never been a problem - , houseTrainedElsewhere = True -- Untested in the field - , owner = jml - } - --- | Our server's internal representation of a 'Human'. -data ServerHuman = ServerHuman Text deriving (Eq, Ord, Show) - --- | Present a 'ServerHuman' as a GraphQL 'Human'. -viewServerHuman :: ServerHuman -> Handler IO Human -viewServerHuman (ServerHuman name) = pure (pure name) - --- | It me. -jml :: ServerHuman -jml = ServerHuman "jml" - -tests :: IO TestTree -tests = testSpec "End-to-end tests" $ do - describe "interpretAnonymousQuery" $ do - it "Handles the simplest possible valid query" $ do - let root = pure (viewServerDog mortgage) - let query = [r|{ - dog { - name - } - } - |] - response <- interpretAnonymousQuery @QueryRoot root query - let expected = - object - [ "data" .= object - [ "dog" .= object - [ "name" .= ("Mortgage" :: Text) - ] - ] - ] - toJSON (toValue response) `shouldBe` expected - it "Handles more than one field" $ do - let root = pure (viewServerDog mortgage) - let query = [r|{ - dog { - name - barkVolume - } - } - |] - response <- interpretAnonymousQuery @QueryRoot root query - let expected = - object - [ "data" .= object - [ "dog" .= object - [ "name" .= ("Mortgage" :: Text) - , "barkVolume" .= (0 :: Int32) - ] - ] - ] - toJSON (toValue response) `shouldBe` expected - it "Handles nested queries" $ do - let root = pure (viewServerDog mortgage) - let query = [r|{ - dog { - name - owner { - name - } - } - } - |] - response <- interpretAnonymousQuery @QueryRoot root query - let expected = - object - [ "data" .= object - [ "dog" .= object - [ "name" .= ("Mortgage" :: Text) - , "owner" .= object - [ "name" .= ("jml" :: Text) - ] - ] - ] - ] - toJSON (toValue response) `shouldBe` expected - it "It aliases fields" $ do - let root = pure (viewServerDog mortgage) - let query = [r|{ - dog { - name - boss: owner { - name - } - } - } - |] - response <- interpretAnonymousQuery @QueryRoot root query - let expected = - object - [ "data" .= object - [ "dog" .= object - [ "name" .= ("Mortgage" :: Text) - , "boss" .= object - [ "name" .= ("jml" :: Text) - ] - ] - ] - ] - toJSON (toValue response) `shouldBe` expected - it "Passes arguments to functions" $ do - let root = pure (viewServerDog mortgage) - let query = [r|{ - dog { - name - doesKnowCommand(dogCommand: Sit) - } - } - |] - response <- interpretAnonymousQuery @QueryRoot root query - let expected = - object - [ "data" .= object - [ "dog" .= object - [ "name" .= ("Mortgage" :: Text) - , "doesKnowCommand" .= False - ] - ] - ] - toJSON (toValue response) `shouldBe` expected - it "Handles fairly complex queries" $ do - let root = pure (viewServerDog mortgage) - -- TODO: jml would like to put some union checks in here, but we don't - -- have any unions reachable from Dog! - let query = [r|{ - dog { - callsign: name - ... on Dog { - callsign: name - me: owner { - ... on Sentient { - name - } - ... on Human { - name - } - name - } - } - } - } - |] - response <- interpretAnonymousQuery @QueryRoot root query - let expected = - object - [ "data" .= object - [ "dog" .= object - [ "callsign" .= ("Mortgage" :: Text) - , "me" .= object - [ "name" .= ("jml" :: Text) - ] - ] - ] - ] - toJSON (toValue response) `shouldBe` expected - describe "interpretQuery" $ do - it "Handles the simplest named query" $ do - let root = pure (viewServerDog mortgage) - let query = [r|query myQuery { - dog { - name - } - } - |] - response <- interpretQuery @QueryRoot root query Nothing mempty - let expected = - object - [ "data" .= object - [ "dog" .= object - [ "name" .= ("Mortgage" :: Text) - ] - ] - ] - toJSON (toValue response) `shouldBe` expected - it "Allows calling query by name" $ do - let root = pure (viewServerDog mortgage) - let query = [r|query myQuery { - dog { - name - } - } - |] - let Right name = makeName "myQuery" - response <- interpretQuery @QueryRoot root query (Just name) mempty - let expected = - object - [ "data" .= object - [ "dog" .= object - [ "name" .= ("Mortgage" :: Text) - ] - ] - ] - toJSON (toValue response) `shouldBe` expected - describe "Handles variables" $ do - let root = pure (viewServerDog mortgage) - let Right schema = makeSchema @Dog - let Right query = - compileQuery schema - [r|query myQuery($whichCommand: DogCommand) { - dog { - name - doesKnowCommand(dogCommand: $whichCommand) - } - } - |] - it "Errors when no variables provided" $ do - response <- executeQuery @QueryRoot root query Nothing mempty - let expected = - object - [ "data" .= object - [ "dog" .= object - [ "name" .= ("Mortgage" :: Text) - , "doesKnowCommand" .= Null - ] - ] - , "errors" .= - [ - object - -- TODO: This error message is pretty bad. We should define - -- a typeclass for client-friendly "Show" (separate from - -- actual Show which remains extremely useful for debugging) - -- and use that when including values in error messages. - [ "message" .= ("Could not coerce Name {unName = \"dogCommand\"} to valid value: ValueScalar' ConstNull not an enum: [Right (Name {unName = \"Sit\"}),Right (Name {unName = \"Down\"}),Right (Name {unName = \"Heel\"})]" :: Text) - ] - ] - ] - toJSON (toValue response) `shouldBe` expected - it "Substitutes variables when they are provided" $ do - -- TODO: This is a crummy way to make a variable map. jml doesn't want - -- to come up with a new API in this PR, but probably we should have a - -- very simple function to turn a JSON value / object into the - -- variable map that we desire. Alternatively, we should have APIs - -- like Aeson does. - -- - let Right varName = makeName "whichCommand" - let vars = Map.singleton (Variable varName) (toValue Sit) - response <- executeQuery @QueryRoot root query Nothing vars - let expected = - object - [ "data" .= object - [ "dog" .= object - [ "name" .= ("Mortgage" :: Text) - , "doesKnowCommand" .= False - ] - ] - ] - toJSON (toValue response) `shouldBe` expected diff --git a/tests/EnumTests.hs b/tests/EnumTests.hs --- a/tests/EnumTests.hs +++ b/tests/EnumTests.hs @@ -3,7 +3,7 @@ import Protolude hiding (Enum) -import GraphQL.API.Enum (GraphQLEnum) +import GraphQL.API (GraphQLEnum) -- https://github.com/jml/graphql-api/issues/116 -- Generic enum code is broken diff --git a/tests/ExampleSchema.hs b/tests/ExampleSchema.hs --- a/tests/ExampleSchema.hs +++ b/tests/ExampleSchema.hs @@ -87,8 +87,11 @@ , (:>) , Defaultable(..) ) -import GraphQL.Value (pattern ValueEnum, unName) -import GraphQL.Value.ToValue (ToValue(..)) +import GraphQL.Value + ( pattern ValueEnum + , unName + , ToValue(..) + ) -- | A command that can be given to a 'Dog'. -- @@ -105,6 +108,12 @@ -- so it can be placed in a schema. data DogCommand = Sit | Down | Heel deriving (Show, Eq, Ord, Generic) +instance Defaultable DogCommand where + -- Explicitly want no default for dogCommand + defaultFor (unName -> "dogCommand") = Nothing + -- DogCommand shouldn't be used elsewhere in schema, but who can say? + defaultFor _ = Nothing + instance GraphQLEnum DogCommand -- TODO: Probably shouldn't have to do this for enums. @@ -175,12 +184,6 @@ , Field "owner" Human ] -instance Defaultable DogCommand where - -- Explicitly want no default for dogCommand - defaultFor (unName -> "dogCommand") = Nothing - -- DogCommand shouldn't be used elsewhere in schema, but who can say? - defaultFor _ = Nothing - -- | Sentient beings have names. -- -- This defines an interface, 'Sentient', that objects can implement. @@ -245,6 +248,9 @@ -- enum CatCommand { JUMP } -- @ data CatCommand = Jump deriving Generic + +instance Defaultable CatCommand where + defaultFor _ = empty instance GraphQLEnum CatCommand diff --git a/tests/Examples/InputObject.hs b/tests/Examples/InputObject.hs deleted file mode 100644 --- a/tests/Examples/InputObject.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DeriveGeneric #-} - -module Examples.InputObject where -import Protolude hiding (Enum) - -import GraphQL -import GraphQL.API -import GraphQL.Resolver (Handler) -import GraphQL.Value.FromValue (FromValue) - -data DogStuff = DogStuff { toy :: Text, likesTreats :: Bool } deriving (Show, Generic) -instance FromValue DogStuff -instance HasAnnotatedInputType DogStuff -instance Defaultable DogStuff where - -- TODO defaultFor takes a Name which makes sense, but what's the - -- name for an input object? - defaultFor _ = Just (DogStuff "shoe" False) - -type Query = Object "Query" '[] - '[ Argument "dogStuff" DogStuff :> Field "description" Text ] - -root :: Handler IO Query -root = pure description - -description :: DogStuff -> Handler IO Text -description (DogStuff toy likesTreats) - | likesTreats = pure $ "likes treats and their favorite toy is a " <> toy - | otherwise = pure $ "their favorite toy is a " <> toy - --- $setup --- >>> import Data.Aeson (encode) --- >>> import GraphQL.Value.ToValue (ToValue(..)) - --- | Show input object usage --- --- >>> response <- example "{ description(dogStuff: {toy: \"bone\", likesTreats: true}) }" --- >>> putStrLn $ encode $ toValue response --- {"data":{"description":"likes treats and their favorite toy is a bone"}} --- --- >>> response <- example "{ description }" --- >>> putStrLn $ encode $ toValue response --- {"data":{"description":"their favorite toy is a shoe"}} -example :: Text -> IO Response -example = interpretAnonymousQuery @Query root diff --git a/tests/Examples/UnionExample.hs b/tests/Examples/UnionExample.hs deleted file mode 100644 --- a/tests/Examples/UnionExample.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE DataKinds #-} -module Examples.UnionExample where - -import Protolude -import GraphQL.API (Field, List, Object, Union) -import GraphQL (Response, interpretAnonymousQuery) -import GraphQL.Resolver (Handler, (:<>)(..), unionValue) - --- Slightly reduced example from the spec -type MiniCat = Object "MiniCat" '[] '[Field "name" Text, Field "meowVolume" Int32] -type MiniDog = Object "MiniDog" '[] '[Field "barkVolume" Int32] - -type CatOrDog = Object "Me" '[] '[Field "myPet" (Union "CatOrDog" '[MiniCat, MiniDog])] -type CatOrDogList = Object "CatOrDogList" '[] '[Field "pets" (List (Union "CatOrDog" '[MiniCat, MiniDog]))] - -miniCat :: Text -> Handler IO MiniCat -miniCat name = pure (pure name :<> pure 32) - -miniDog :: Handler IO MiniDog -miniDog = pure (pure 100) - -catOrDog :: Handler IO CatOrDog -catOrDog = pure $ do - name <- pure "MonadicFelix" -- we can do monadic actions - unionValue @MiniCat (miniCat name) - -catOrDogList :: Handler IO CatOrDogList -catOrDogList = pure $ - pure [ unionValue @MiniCat (miniCat "Felix") - , unionValue @MiniCat (miniCat "Mini") - , unionValue @MiniDog miniDog - ] - --- $setup --- >>> import Data.Aeson (encode) --- >>> import GraphQL.Value.ToValue (ToValue(..)) - --- | Show usage of a single unionValue --- --- >>> response <- exampleQuery --- >>> putStrLn $ encode $ toValue response --- {"data":{"myPet":{"meowVolume":32,"name":"MonadicFelix"}}} -exampleQuery :: IO Response -exampleQuery = interpretAnonymousQuery @CatOrDog catOrDog "{ myPet { ... on MiniCat { name meowVolume } ... on MiniDog { barkVolume } } }" - --- | 'unionValue' can be used in a list context --- --- >>> response <- exampleListQuery --- >>> putStrLn $ encode $ toValue response --- {"data":{"pets":[{"meowVolume":32,"name":"Felix"},{"meowVolume":32,"name":"Mini"},{"barkVolume":100}]}} -exampleListQuery :: IO Response -exampleListQuery = interpretAnonymousQuery @CatOrDogList catOrDogList "{ pets { ... on MiniCat { name meowVolume } ... on MiniDog { barkVolume } } }" diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,10 @@ +module Main where + +import Protolude + +import Test.Hspec +import qualified Spec (spec) + +main :: IO () +main = do + hspec Spec.spec diff --git a/tests/OrderedMapSpec.hs b/tests/OrderedMapSpec.hs new file mode 100644 --- /dev/null +++ b/tests/OrderedMapSpec.hs @@ -0,0 +1,42 @@ +module OrderedMapSpec (spec) where + +import Protolude + +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (Gen, arbitrary, forAll) +import Test.Hspec + +import qualified Data.Map as Map +import GraphQL.Internal.OrderedMap (OrderedMap) +import qualified GraphQL.Internal.OrderedMap as OrderedMap + + +orderedMaps :: Gen (OrderedMap Int Int) +orderedMaps = arbitrary + +spec :: Spec +spec = describe "OrderedMap" $ do + describe "Integrity" $ do + prop "fromList . toList == id" $ do + forAll orderedMaps (\x -> OrderedMap.orderedMap (OrderedMap.toList x) == Just x) + prop "keys == Map.keys . toMap" $ do + forAll orderedMaps (\x -> sort (OrderedMap.keys x) == sort (Map.keys (OrderedMap.toMap x))) + prop "keys == map fst . Map.toList" $ do + forAll orderedMaps (\x -> OrderedMap.keys x == map fst (OrderedMap.toList x)) + prop "has unique keys" $ do + forAll orderedMaps (\x -> let ks = OrderedMap.keys x in ks == ordNub ks) + prop "all keys can be looked up" $ do + forAll orderedMaps (\x -> let keys = OrderedMap.keys x + values = OrderedMap.values x + in mapMaybe (flip OrderedMap.lookup x) keys == values) + it "empty is orderedMap []" $ do + Just (OrderedMap.empty @Int @Int) `shouldBe` OrderedMap.orderedMap [] + prop "singleton x is orderedMap [x]" $ do + \x y -> Just (OrderedMap.singleton @Int @Int x y) == OrderedMap.orderedMap [(x, y)] + it "preserves insertion order" $ do + let items1 = [("foo", 2), ("bar", 1)] + let Just x = OrderedMap.orderedMap items1 + OrderedMap.toList @Text @Int x `shouldBe` items1 + let items2 = [("bar", 1), ("foo", 2)] + let Just y = OrderedMap.orderedMap items2 + OrderedMap.toList @Text @Int y `shouldBe` items2 diff --git a/tests/OrderedMapTests.hs b/tests/OrderedMapTests.hs deleted file mode 100644 --- a/tests/OrderedMapTests.hs +++ /dev/null @@ -1,43 +0,0 @@ -module OrderedMapTests (tests) where - -import Protolude - -import Test.Hspec.QuickCheck (prop) -import Test.QuickCheck (Gen, arbitrary, forAll) -import Test.Tasty (TestTree) -import Test.Tasty.Hspec (testSpec, describe, it, shouldBe) - -import qualified Data.Map as Map -import GraphQL.Internal.OrderedMap (OrderedMap) -import qualified GraphQL.Internal.OrderedMap as OrderedMap - - -orderedMaps :: Gen (OrderedMap Int Int) -orderedMaps = arbitrary - -tests :: IO TestTree -tests = testSpec "OrderedMap" $ do - describe "Integrity" $ do - prop "fromList . toList == id" $ do - forAll orderedMaps (\x -> OrderedMap.orderedMap (OrderedMap.toList x) == Just x) - prop "keys == Map.keys . toMap" $ do - forAll orderedMaps (\x -> sort (OrderedMap.keys x) == sort (Map.keys (OrderedMap.toMap x))) - prop "keys == map fst . Map.toList" $ do - forAll orderedMaps (\x -> OrderedMap.keys x == map fst (OrderedMap.toList x)) - prop "has unique keys" $ do - forAll orderedMaps (\x -> let ks = OrderedMap.keys x in ks == ordNub ks) - prop "all keys can be looked up" $ do - forAll orderedMaps (\x -> let keys = OrderedMap.keys x - values = OrderedMap.values x - in mapMaybe (flip OrderedMap.lookup x) keys == values) - it "empty is orderedMap []" $ do - Just (OrderedMap.empty @Int @Int) `shouldBe` OrderedMap.orderedMap [] - prop "singleton x is orderedMap [x]" $ do - \x y -> Just (OrderedMap.singleton @Int @Int x y) == OrderedMap.orderedMap [(x, y)] - it "preserves insertion order" $ do - let items1 = [("foo", 2), ("bar", 1)] - let Just x = OrderedMap.orderedMap items1 - OrderedMap.toList @Text @Int x `shouldBe` items1 - let items2 = [("bar", 1), ("foo", 2)] - let Just y = OrderedMap.orderedMap items2 - OrderedMap.toList @Text @Int y `shouldBe` items2 diff --git a/tests/ResolverSpec.hs b/tests/ResolverSpec.hs new file mode 100644 --- /dev/null +++ b/tests/ResolverSpec.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +module ResolverSpec (spec) where + +import Protolude hiding (Enum) + +import Test.Hspec + +import Data.Aeson (encode, toJSON, object, (.=), Value(Null)) +import GraphQL + ( Response(..) + , interpretAnonymousQuery + ) +import GraphQL.API + ( Object + , Field + , Argument + , Enum + , List + , (:>) + ) +import GraphQL.Resolver + ( Handler + , ResolverError(..) + , (:<>)(..) + , returns + , handlerError + ) +import GraphQL.Internal.Output (singleError) +import qualified GraphQL.Value as GValue +import EnumTests ( Mode(NormalFile) ) + +-- Test a custom error monad +type TMonad = ExceptT Text IO +type T = Object "T" '[] '[ Field "z" Int32 + , Argument "x" Int32 :> Field "t" Int32 + , Argument "y" Int32 :> Field "q" (Maybe Int32) + , Argument "d" Double :> Field "r" Double + , Field "l" (List Int32) + , Argument "n" Text :> Field "foo" (Maybe Foo) + , Field "bar" (Maybe Foo) + ] + +tHandler :: Handler TMonad T +tHandler = pure $ + returns 10 + :<> (\x -> if x == 99 then handlerError "missed 99th value" else returns x) + :<> returns . Just . (returns . (*2)) + :<> (\dArg -> if dArg == 9.9 then handlerError "bad 9.9 value" else returns dArg) + :<> returns ([ returns 0, returns 7, handlerError "no number 9" ]) + :<> (\_nArg -> returns $ Just $ return $ returns "fred") + :<> returns Nothing + +-- https://github.com/jml/graphql-api/issues/119 +-- Maybe X didn't descend into its argument. Now it does. +type Query = Object "Query" '[] + '[ Argument "id" Text :> Field "test" (Maybe Foo) ] + +type Foo = Object "Foo" '[] + '[ Field "name" Text ] + +data ServerFoo = ServerFoo + { name :: Text + } deriving (Eq, Show) + +lookupFoo :: Text -> IO (Maybe ServerFoo) +lookupFoo _ = pure $ Just (ServerFoo "Mort") + +viewFoo :: ServerFoo -> Handler IO Foo +viewFoo ServerFoo { name=name } = pure $ returns $ name + +handler :: Handler IO Query +handler = pure $ \fooId -> do + foo <- lookupFoo fooId + returns $ viewFoo <$> foo + +-- Enum test +type EnumQuery = Object "File" '[] + '[ Field "mode" (Enum "modeEnumName" Mode) ] + +enumHandler :: Handler IO EnumQuery +enumHandler = pure $ returns NormalFile + +enumHandler2 :: Handler IO EnumQuery +enumHandler2 = pure $ handlerError "I forgot!" + +-- /Enum test + +spec :: Spec +spec = describe "TypeAPI" $ do + describe "tTest" $ do + it "works in a simple Int32 case" $ do + Right (Success obj) <- runExceptT (interpretAnonymousQuery @T tHandler "{ t(x: 12) }") + encode obj `shouldBe` "{\"t\":12}" + it "works in a simple Double case" $ do + r <- runExceptT (interpretAnonymousQuery @T tHandler "{ r(d: 1.2) }") + case r of + Right (Success obj) -> encode obj `shouldBe` "{\"r\":1.2}" + _ -> r `shouldNotBe` r + it "works for value and error list elements" $ do + r <- runExceptT (interpretAnonymousQuery @T tHandler "{ l }") + case r of + Right (PartialSuccess obj err) -> do + encode obj `shouldBe` "{\"l\":[0,7,null]}" + err `shouldBe` (singleError (HandlerError "no number 9")) + _ -> r `shouldNotBe` r + it "works for Nullable present elements" $ do + r <- runExceptT (interpretAnonymousQuery @T tHandler "{ foo(n: \"flintstone\") { name } }") + case r of + Right (Success obj) -> do + encode obj `shouldBe` "{\"foo\":{\"name\":\"fred\"}}" + _ -> r `shouldNotBe` r + it "works for Nullable null elements" $ do + r <- runExceptT (interpretAnonymousQuery @T tHandler "{ bar { name } }") + case r of + Right (Success obj) -> do + encode obj `shouldBe` "{\"bar\":null}" + _ -> r `shouldNotBe` r + it "complains about a missing field" $ do + Right (PartialSuccess _ errs) <- runExceptT (interpretAnonymousQuery @T tHandler "{ not_a_field }") + errs `shouldBe` singleError (FieldNotFoundError "not_a_field") + it "complains about a handler throwing an exception" $ do + r <- runExceptT (interpretAnonymousQuery @T tHandler "{ t(x: 99) }") + case r of + Right (PartialSuccess v errs) -> do + -- n.b. this hasn't gone through the final JSON embedding, + -- so it's the individual components instead of the final + -- response of '{ "data": ..., "errors": ... }' + errs `shouldBe` (singleError (HandlerError "missed 99th value")) + toJSON (GValue.toValue v) `shouldBe` object [ "t" .= Null ] + _ -> r `shouldNotBe` r + it "complains about missing argument" $ do + Right (PartialSuccess _ errs) <- runExceptT (interpretAnonymousQuery @T tHandler "{ t }") + errs `shouldBe` singleError (ValueMissing "x") + describe "issue 119" $ do + it "Just works" $ do + Success obj <- interpretAnonymousQuery @Query handler "{ test(id: \"10\") { name } }" + encode obj `shouldBe` "{\"test\":{\"name\":\"Mort\"}}" + describe "Parse, validate and execute queries against API" $ do + it "API.Enum works" $ do + Success obj <- interpretAnonymousQuery @EnumQuery enumHandler "{ mode }" + encode obj `shouldBe` "{\"mode\":\"NormalFile\"}" + it "API.Enum handles errors" $ do + r <- interpretAnonymousQuery @EnumQuery enumHandler2 "{ mode }" + case r of + (PartialSuccess obj errs) -> do + encode obj `shouldBe` "{\"mode\":null}" + errs `shouldBe` (singleError $ HandlerError "I forgot!") + _ -> r `shouldNotBe` r diff --git a/tests/ResolverTests.hs b/tests/ResolverTests.hs deleted file mode 100644 --- a/tests/ResolverTests.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -module ResolverTests (tests) where - -import Protolude hiding (Enum) - -import Test.Tasty (TestTree) -import Test.Tasty.Hspec (testSpec, describe, it, shouldBe) - -import Data.Aeson (encode) -import GraphQL - ( Response(..) - , interpretAnonymousQuery - ) -import GraphQL.API - ( Object - , Field - , Argument - , Enum - , (:>) - ) -import GraphQL.Resolver - ( Handler - , ResolverError(..) - , (:<>)(..) - ) -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 - , Argument "x" Int32 :> Field "t" Int32 - , Argument "y" Int32 :> Field "q" Int32 - ] - -tHandler :: Handler TMonad T -tHandler = - pure $ (pure 10) :<> (\tArg -> pure tArg) :<> (pure . (*2)) - - --- https://github.com/jml/graphql-api/issues/119 --- Maybe X didn't descend into its argument. Now it does. -type Query = Object "Query" '[] - '[ Argument "id" Text :> Field "test" (Maybe Foo) ] - -type Foo = Object "Foo" '[] - '[ Field "name" Text ] - -data ServerFoo = ServerFoo - { name :: Text - } deriving (Eq, Show) - -lookupFoo :: Text -> IO (Maybe ServerFoo) -lookupFoo _ = pure $ Just (ServerFoo "Mort") - -viewFoo :: ServerFoo -> Handler IO Foo -viewFoo ServerFoo { name=name } = pure $ pure $ name - -handler :: Handler IO Query -handler = pure $ \fooId -> do - foo <- lookupFoo fooId - -- note that fmap maps over the Maybe, so we still need - -- 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 - it "works in a simple case" $ do - Right (Success object) <- runExceptT (interpretAnonymousQuery @T tHandler "{ t(x: 12) }") - encode object `shouldBe` "{\"t\":12}" - it "complains about missing field" $ do - Right (PartialSuccess _ errs) <- runExceptT (interpretAnonymousQuery @T tHandler "{ not_a_field }") - errs `shouldBe` singleError (FieldNotFoundError "not_a_field") - it "complains about missing argument" $ do - Right (PartialSuccess _ errs) <- runExceptT (interpretAnonymousQuery @T tHandler "{ t }") - errs `shouldBe` singleError (ValueMissing "x") - describe "issue 119" $ do - 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/SchemaSpec.hs b/tests/SchemaSpec.hs new file mode 100644 --- /dev/null +++ b/tests/SchemaSpec.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +module SchemaSpec (spec) where + +import Protolude hiding (Down, Enum) + +import Test.Hspec + +import GraphQL.API + ( Field + , Enum + , List + , getAnnotatedInputType + , getDefinition + ) +import qualified GraphQL.Internal.Syntax.AST as AST +import GraphQL.Internal.API + ( getAnnotatedType + , getFieldDefinition + , getInterfaceDefinition + ) +import GraphQL.Internal.Schema + ( EnumTypeDefinition(..) + , EnumValueDefinition(..) + , FieldDefinition(..) + , ObjectTypeDefinition(..) + , InterfaceTypeDefinition(..) + , AnnotatedType(..) + , ListType(..) + , UnionTypeDefinition(..) + , GType(..) + , TypeDefinition(..) + , InputTypeDefinition(..) + , InputObjectTypeDefinition(..) + , InputObjectFieldDefinition(..) + , ScalarTypeDefinition(..) + , AnnotatedType(..) + , NonNullType(..) + , Builtin(..) + , InputType(..) + , getInputTypeDefinition + , builtinFromName + , astAnnotationToSchemaAnnotation + ) +import ExampleSchema + +spec :: Spec +spec = describe "Type" $ do + describe "Field" $ + it "encodes correctly" $ do + getFieldDefinition @(Field "hello" Int) `shouldBe` Right (FieldDefinition "hello" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GInt)))) + describe "Interface" $ + it "encodes correctly" $ do + getInterfaceDefinition @Sentient `shouldBe` + Right (InterfaceTypeDefinition + "Sentient" + (FieldDefinition "name" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString))) :| [])) + describe "full example" $ + it "encodes correctly" $ do + getDefinition @Human `shouldBe` + Right (ObjectTypeDefinition "Human" + [ InterfaceTypeDefinition "Sentient" ( + FieldDefinition "name" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString))) :| []) + ] + (FieldDefinition "name" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString))) :| [])) + describe "output Enum" $ + it "encodes correctly" $ do + getAnnotatedType @(Enum "DogCommand" DogCommand) `shouldBe` + Right (TypeNonNull (NonNullTypeNamed (DefinedType (TypeDefinitionEnum (EnumTypeDefinition "DogCommand" + [ EnumValueDefinition "Sit" + , EnumValueDefinition "Down" + , EnumValueDefinition "Heel" + ]))))) + describe "Union type" $ + it "encodes correctly" $ do + getAnnotatedType @CatOrDog `shouldBe` + TypeNamed . DefinedType . TypeDefinitionUnion . UnionTypeDefinition "CatOrDog" + <$> sequence (getDefinition @Cat :| [getDefinition @Dog]) + describe "List" $ + it "encodes correctly" $ do + getAnnotatedType @(List Int) `shouldBe` Right (TypeList (ListType (TypeNonNull (NonNullTypeNamed (BuiltinType GInt))))) + getAnnotatedInputType @(List Int) `shouldBe` Right (TypeList (ListType (TypeNonNull (NonNullTypeNamed (BuiltinInputType GInt))))) + describe "TypeDefinition accepted as InputTypes" $ + it "Enum/InputObject/Scalar" $ do + getInputTypeDefinition (TypeDefinitionEnum (EnumTypeDefinition "DogCommand" + [ EnumValueDefinition "Sit" + , EnumValueDefinition "Down" + , EnumValueDefinition "Heel" + ])) `shouldBe` Just (InputTypeDefinitionEnum (EnumTypeDefinition "DogCommand" + [ EnumValueDefinition "Sit" + , EnumValueDefinition "Down" + , EnumValueDefinition "Heel" + ])) + getInputTypeDefinition (TypeDefinitionInputObject (InputObjectTypeDefinition "Human" + (InputObjectFieldDefinition "name" (TypeNonNull (NonNullTypeNamed (BuiltinInputType GString))) Nothing :| []) + )) `shouldBe` Just (InputTypeDefinitionObject (InputObjectTypeDefinition "Human" + (InputObjectFieldDefinition "name" (TypeNonNull (NonNullTypeNamed (BuiltinInputType GString))) Nothing :| []) + )) + getInputTypeDefinition (TypeDefinitionScalar (ScalarTypeDefinition "Human")) `shouldBe` Just (InputTypeDefinitionScalar (ScalarTypeDefinition "Human")) + describe "TypeDefinition refused as InputTypes" $ + -- todo: add all the others (union type, ..?) + it "Object" $ do + getInputTypeDefinition (TypeDefinitionObject (ObjectTypeDefinition "Human" [] + (FieldDefinition "name" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString))) :| []))) `shouldBe` Nothing + describe "Builtin types from name" $ + it "Int/Bool/String/Float/ID" $ do + builtinFromName "Int" `shouldBe` Just GInt + builtinFromName "Boolean" `shouldBe` Just GBool + builtinFromName "String" `shouldBe` Just GString + builtinFromName "Float" `shouldBe` Just GFloat + builtinFromName "ID" `shouldBe` Just GID + builtinFromName "RANDOMSTRING" `shouldBe` Nothing + describe "Annotations from AST" $ + it "annotation like [[ScalarType!]]!" $ do + let typeDefinitionScalar = (TypeDefinitionScalar (ScalarTypeDefinition "ScalarType")) + astAnnotationToSchemaAnnotation ( + AST.TypeNonNull ( + AST.NonNullTypeList ( + AST.ListType ( + AST.TypeList ( + AST.ListType ( + AST.TypeNonNull ( + AST.NonNullTypeNamed (AST.NamedType "ScalarType") + ))))))) typeDefinitionScalar `shouldBe` ( + TypeNonNull ( + NonNullTypeList ( + ListType ( + TypeList ( + ListType ( + TypeNonNull ( + NonNullTypeNamed typeDefinitionScalar + ))))))) diff --git a/tests/SchemaTests.hs b/tests/SchemaTests.hs deleted file mode 100644 --- a/tests/SchemaTests.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -module SchemaTests (tests) where - -import Protolude hiding (Down, Enum) - -import Test.Tasty (TestTree) -import Test.Tasty.Hspec (testSpec, describe, it, shouldBe) - -import GraphQL.API - ( Field - , Enum - , List - , getAnnotatedType - , getAnnotatedInputType - , getDefinition - , getFieldDefinition - , getInterfaceDefinition - ) -import GraphQL.Internal.Schema - ( EnumTypeDefinition(..) - , EnumValueDefinition(..) - , FieldDefinition(..) - , ObjectTypeDefinition(..) - , NonEmptyList(..) - , InterfaceTypeDefinition(..) - , AnnotatedType(..) - , ListType(..) - , UnionTypeDefinition(..) - , GType(..) - , TypeDefinition(..) - , NonNullType(..) - , Builtin(..) - , InputType(..) - ) -import ExampleSchema - -tests :: IO TestTree -tests = testSpec "Type" $ do - describe "Field" $ - it "encodes correctly" $ do - getFieldDefinition @(Field "hello" Int) `shouldBe` Right (FieldDefinition "hello" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GInt)))) - describe "Interface" $ - it "encodes correctly" $ do - getInterfaceDefinition @Sentient `shouldBe` - Right (InterfaceTypeDefinition - "Sentient" - (NonEmptyList [FieldDefinition "name" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString)))])) - describe "full example" $ - it "encodes correctly" $ do - getDefinition @Human `shouldBe` - Right (ObjectTypeDefinition "Human" - [ InterfaceTypeDefinition "Sentient" ( - NonEmptyList [FieldDefinition "name" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString)))]) - ] - (NonEmptyList [FieldDefinition "name" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString)))])) - describe "output Enum" $ - it "encodes correctly" $ do - getAnnotatedType @(Enum "DogCommand" DogCommand) `shouldBe` - Right (TypeNonNull (NonNullTypeNamed (DefinedType (TypeDefinitionEnum (EnumTypeDefinition "DogCommand" - [ EnumValueDefinition "Sit" - , EnumValueDefinition "Down" - , EnumValueDefinition "Heel" - ]))))) - describe "Union type" $ - it "encodes correctly" $ do - getAnnotatedType @CatOrDog `shouldBe` - TypeNamed . DefinedType . TypeDefinitionUnion . UnionTypeDefinition "CatOrDog" - . NonEmptyList <$> sequence [ getDefinition @Cat - , getDefinition @Dog - ] - describe "List" $ - it "encodes correctly" $ do - getAnnotatedType @(List Int) `shouldBe` Right (TypeList (ListType (TypeNonNull (NonNullTypeNamed (BuiltinType GInt))))) - getAnnotatedInputType @(List Int) `shouldBe` Right (TypeList (ListType (TypeNonNull (NonNullTypeNamed (BuiltinInputType GInt))))) diff --git a/tests/Spec.hs b/tests/Spec.hs --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -1,35 +1,1 @@ -module Main - ( main - ) where - -import Protolude - -import Test.Tasty (defaultMain, testGroup) - -import qualified ASTTests -import qualified EndToEndTests -import qualified OrderedMapTests -import qualified ResolverTests -import qualified SchemaTests -import qualified ValidationTests -import qualified ValueTests -import qualified EnumTests () - --- import examples to ensure they compile -import Examples.InputObject () -import Examples.UnionExample () - -main :: IO () -main = do - t <- sequence tests - defaultMain . testGroup "GraphQL API" $ t - where - tests = - [ ASTTests.tests - , EndToEndTests.tests - , OrderedMapTests.tests - , ResolverTests.tests - , SchemaTests.tests - , ValidationTests.tests - , ValueTests.tests - ] +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/tests/ValidationSpec.hs b/tests/ValidationSpec.hs new file mode 100644 --- /dev/null +++ b/tests/ValidationSpec.hs @@ -0,0 +1,257 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} + +-- | Tests for query validation. +module ValidationSpec (spec) where + +import Protolude + +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck ((===)) +import Test.Hspec +import qualified Data.Set as Set + +import GraphQL.Internal.Name (Name) +import qualified GraphQL.Internal.Syntax.AST as AST +import GraphQL.Internal.Schema (emptySchema, Schema) +import GraphQL.Internal.Validation + ( ValidationError(..) + , findDuplicates + , getErrors + , formatErrors + ) + +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 = emptySchema + +spec :: Spec +spec = describe "Validation" $ do + describe "getErrors" $ do + it "Treats simple queries as valid" $ do + let doc = AST.QueryDocument + [ AST.DefinitionOperation + ( AST.Query + ( AST.Node me [] [] + [ AST.SelectionField (AST.Field Nothing someName [] [] []) + ] + ) + ) + ] + 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` [] + it "Treats anonymous queries with annotated variables as valid ([[Boolean]]!)" $ do + let doc = AST.QueryDocument + [ AST.DefinitionOperation + (AST.Query + (AST.Node Nothing + [ AST.VariableDefinition + (AST.Variable "atOtherHomes") + (AST.TypeNonNull (AST.NonNullTypeList (AST.ListType + (AST.TypeList (AST.ListType (AST.TypeNamed (AST.NamedType "Boolean")))) + ))) + Nothing + ] [] + [ AST.SelectionField + (AST.Field Nothing dog [] [] + [ AST.SelectionField + (AST.Field Nothing "isHousetrained" + [ AST.Argument "atOtherHomes" + (AST.ValueVariable (AST.Variable "atOtherHomes")) + ] [] []) + ]) + ])) + ] + getErrors schema doc `shouldBe` [] + + it "Detects duplicate operation names" $ do + let doc = AST.QueryDocument + [ AST.DefinitionOperation + ( AST.Query + ( AST.Node me [] [] + [ AST.SelectionField (AST.Field Nothing someName [] [] []) + ] + ) + ) + , AST.DefinitionOperation + ( AST.Query + ( AST.Node me [] [] + [ AST.SelectionField (AST.Field Nothing someName [] [] []) + ] + ) + ) + ] + getErrors schema doc `shouldBe` [DuplicateOperation me] + + it "Detects duplicate anonymous operations" $ do + let doc = AST.QueryDocument + [ AST.DefinitionOperation + ( AST.AnonymousQuery + [ AST.SelectionField (AST.Field Nothing someName [] [] []) + ] + ) + , AST.DefinitionOperation + ( AST.AnonymousQuery + [ AST.SelectionField (AST.Field Nothing someName [] [] []) + ] + ) + ] + let errors = getErrors schema doc + errors `shouldBe` [MixedAnonymousOperations 2 []] + formatErrors errors `shouldBe` ["Multiple anonymous operations defined. Found 2"] + + it "Detects mixed operations" $ do + let doc = AST.QueryDocument + [ AST.DefinitionOperation + ( AST.AnonymousQuery + [ AST.SelectionField (AST.Field Nothing someName [] [] []) + ] + ) + , AST.DefinitionOperation + ( AST.Query (AST.Node (pure "houseTrainedQuery") [] [] + [ AST.SelectionField (AST.Field Nothing someName [] [] []) + ] + )) + ] + let errors = getErrors schema doc + errors `shouldBe` [MixedAnonymousOperations 1 [Just "houseTrainedQuery"]] + formatErrors errors `shouldBe` ["Document contains both anonymous operations (1) and named operations ([Just (Name {unName = \"houseTrainedQuery\"})])"] + + it "Detects non-existing type in variable definition" $ do + let doc = AST.QueryDocument + [ AST.DefinitionOperation + (AST.Query + (AST.Node Nothing + [ AST.VariableDefinition + (AST.Variable "atOtherHomes") + (AST.TypeNamed (AST.NamedType "MyNonExistingType")) + (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` [VariableTypeNotFound (AST.Variable "atOtherHomes") "MyNonExistingType"] + + it "Detects unused variable definition" $ do + let doc = AST.QueryDocument + [ AST.DefinitionOperation + (AST.Query + (AST.Node Nothing + [ AST.VariableDefinition + (AST.Variable "atOtherHomes") + (AST.TypeNamed (AST.NamedType "String")) + (Just (AST.ValueBoolean True)) + ] [] + [ AST.SelectionField + (AST.Field Nothing dog [] [] + [ AST.SelectionField + (AST.Field Nothing "isHousetrained" + [] [] []) + ]) + ])) + ] + getErrors schema doc `shouldBe` [UnusedVariables (Set.fromList [AST.Variable "atOtherHomes"])] + + it "Treats anonymous queries with inline arguments 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 "isHousetrained" + [ AST.Argument "atOtherHomes" + (AST.ValueList (AST.ListValue [ + (AST.ValueObject (AST.ObjectValue [ + (AST.ObjectField "testKey" (AST.ValueInt 123)), + (AST.ObjectField "anotherKey" (AST.ValueString (AST.StringValue "string"))) + ])) + ])) + ] [] []) + ]) + ])) + ] + getErrors schema doc `shouldBe` [] + it "Detects non-existent fragment type" $ do + let doc = AST.QueryDocument + [(AST.DefinitionFragment (AST.FragmentDefinition "dogTest" + (AST.NamedType "Dog") [] [ + AST.SelectionField (AST.Field Nothing "name" [] [] []) + ])), + (AST.DefinitionOperation + (AST.Query + (AST.Node Nothing + [] [] + [AST.SelectionField + (AST.Field Nothing dog [] [] + [AST.SelectionFragmentSpread (AST.FragmentSpread "dogTest" []) + ]) + ]))) + ] + getErrors schema doc `shouldBe` [TypeConditionNotFound "Dog"] + + describe "findDuplicates" $ do + prop "returns empty on unique lists" $ do + \xs -> findDuplicates @Int (ordNub xs) === [] + prop "finds only duplicates" $ \xs -> do + all (>1) (count xs <$> findDuplicates @Int xs) + prop "finds all duplicates" $ \xs -> do + (sort . findDuplicates @Int) xs === (ordNub . sort . filter ((> 1) . count xs)) xs + + +-- | Count the number of times 'x' occurs in 'xs'. +count :: Eq a => [a] -> a -> Int +count xs x = (length . filter (== x)) xs diff --git a/tests/ValidationTests.hs b/tests/ValidationTests.hs deleted file mode 100644 --- a/tests/ValidationTests.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# LANGUAGE TypeApplications #-} - --- | Tests for query validation. -module ValidationTests (tests) where - -import Protolude - -import Test.Hspec.QuickCheck (prop) -import Test.QuickCheck ((===)) -import Test.Tasty (TestTree) -import Test.Tasty.Hspec (testSpec, describe, it, shouldBe) - -import GraphQL.Internal.Name (Name) -import qualified GraphQL.Internal.Syntax.AST as AST -import GraphQL.Internal.Schema (Schema) -import GraphQL.Internal.Validation - ( ValidationError(..) - , findDuplicates - , getErrors - ) - -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 = panic "schema evaluated. We weren't expecting that." - -tests :: IO TestTree -tests = testSpec "Validation" $ do - describe "getErrors" $ do - it "Treats simple queries as valid" $ do - let doc = AST.QueryDocument - [ AST.DefinitionOperation - ( AST.Query - ( AST.Node me [] [] - [ AST.SelectionField (AST.Field Nothing someName [] [] []) - ] - ) - ) - ] - 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` [] - - it "Detects duplicate operation names" $ do - let doc = AST.QueryDocument - [ AST.DefinitionOperation - ( AST.Query - ( AST.Node me [] [] - [ AST.SelectionField (AST.Field Nothing someName [] [] []) - ] - ) - ) - , AST.DefinitionOperation - ( AST.Query - ( AST.Node me [] [] - [ AST.SelectionField (AST.Field Nothing someName [] [] []) - ] - ) - ) - ] - getErrors schema doc `shouldBe` [DuplicateOperation me] - - it "Detects duplicate anonymous operations" $ do - let doc = AST.QueryDocument - [ AST.DefinitionOperation - ( AST.AnonymousQuery - [ AST.SelectionField (AST.Field Nothing someName [] [] []) - ] - ) - , AST.DefinitionOperation - ( AST.AnonymousQuery - [ AST.SelectionField (AST.Field Nothing someName [] [] []) - ] - ) - ] - getErrors schema doc `shouldBe` [MixedAnonymousOperations 2 []] - - describe "findDuplicates" $ do - prop "returns empty on unique lists" $ do - \xs -> findDuplicates @Int (ordNub xs) === [] - prop "finds only duplicates" $ \xs -> do - all (>1) (count xs <$> findDuplicates @Int xs) - prop "finds all duplicates" $ \xs -> do - (sort . findDuplicates @Int) xs === (ordNub . sort . filter ((> 1) . count xs)) xs - - --- | Count the number of times 'x' occurs in 'xs'. -count :: Eq a => [a] -> a -> Int -count xs x = (length . filter (== x)) xs diff --git a/tests/ValueSpec.hs b/tests/ValueSpec.hs new file mode 100644 --- /dev/null +++ b/tests/ValueSpec.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE DeriveGeneric #-} +module ValueSpec (spec) where + +import Protolude + +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (forAll) +import Test.Hspec + +import qualified GraphQL.Internal.Syntax.AST as AST +import GraphQL.Internal.Arbitrary (arbitraryText, arbitraryNonEmpty) +import GraphQL.Value + ( Object + , Value'(ValueObject') + , ObjectField'(..) + , astToVariableValue + , unionObjects + , objectFields + , objectFromList + , toValue + ) +import GraphQL.Internal.Value.FromValue (FromValue(..), prop_roundtripValue) + +data Resource = Resource + { resText :: Text + , resInt :: Int32 + , resDouble :: Double + , resBool :: Bool + } deriving (Generic, Eq, Show) + +instance FromValue Resource + +spec :: Spec +spec = describe "Value" $ do + describe "unionObject" $ do + it "returns empty on empty list" $ do + unionObjects [] `shouldBe` (objectFromList [] :: Maybe Object) + it "merges objects" $ do + let (Just foo) = objectFromList [ ("foo", toValue @Int32 1) + , ("bar",toValue @Int32 2)] + let (Just bar) = objectFromList [ ("bar", toValue @Text "cow") + , ("baz",toValue @Int32 3)] + let observed = unionObjects [foo, bar] + observed `shouldBe` Nothing + it "merges objects with unique keys" $ do + let (Just foo) = objectFromList [("foo", toValue @Int32 1)] + let (Just bar) = objectFromList [ ("bar", toValue @Text "cow") + , ("baz",toValue @Int32 3)] + let (Just expected) = objectFromList [ ("foo", toValue @Int32 1) + , ("bar", toValue @Text "cow") + , ("baz", toValue @Int32 3) + ] + let (Just observed) = unionObjects [foo, bar] + observed `shouldBe` expected + expected `shouldSatisfy` prop_fieldsUnique + describe "Objects" $ do + prop "have unique fields" $ do + prop_fieldsUnique + -- See https://github.com/haskell-graphql/graphql-api/pull/178 for background + it "derives fromValue instances for objects with more than three fields" $ do + let Just value = objectFromList + [ ("resText", toValue @Text "text") + , ("resBool", toValue @Bool False) + , ("resDouble", toValue @Double 1.2) + , ("resInt", toValue @Int32 32) + ] + let Right observed = fromValue $ ValueObject' value + let expected = Resource + { resText = "text" + , resInt = 32 + , resDouble = 1.2 + , resBool = False + } + observed `shouldBe` expected + + describe "ToValue / FromValue instances" $ do + prop "Bool" $ prop_roundtripValue @Bool + prop "Int32" $ prop_roundtripValue @Int32 + prop "Double" $ prop_roundtripValue @Double + prop "Text" $ forAll arbitraryText prop_roundtripValue + prop "Lists" $ prop_roundtripValue @[Int32] + prop "Non-empty lists" $ forAll (arbitraryNonEmpty @Int32) prop_roundtripValue + describe "AST" $ do + it "Objects converted from AST have unique fields" $ do + let input = AST.ObjectValue [ AST.ObjectField "foo" (AST.ValueString (AST.StringValue "bar")) + , AST.ObjectField "foo" (AST.ValueString (AST.StringValue "qux")) + ] + astToVariableValue (AST.ValueObject input) `shouldBe` Nothing + + +-- | All of the fields in an object should have unique names. +prop_fieldsUnique :: Object -> Bool +prop_fieldsUnique object = + fieldNames == ordNub fieldNames + where + fieldNames = [name | ObjectField name _ <- objectFields object] diff --git a/tests/ValueTests.hs b/tests/ValueTests.hs deleted file mode 100644 --- a/tests/ValueTests.hs +++ /dev/null @@ -1,70 +0,0 @@ -module ValueTests (tests) where - -import Protolude - -import Test.Hspec.QuickCheck (prop) -import Test.QuickCheck (forAll) -import Test.Tasty (TestTree) -import Test.Tasty.Hspec (testSpec, describe, it, shouldBe, shouldSatisfy) - -import qualified GraphQL.Internal.Syntax.AST as AST -import GraphQL.Internal.Arbitrary (arbitraryText, arbitraryNonEmpty) -import GraphQL.Value - ( Object - , ObjectField'(..) - , astToVariableValue - , unionObjects - , objectFields - , objectFromList - ) -import GraphQL.Value.FromValue (prop_roundtripValue) -import GraphQL.Value.ToValue (toValue) - - -tests :: IO TestTree -tests = testSpec "Value" $ do - describe "unionObject" $ do - it "returns empty on empty list" $ do - unionObjects [] `shouldBe` (objectFromList [] :: Maybe Object) - it "merges objects" $ do - let (Just foo) = objectFromList [ ("foo", toValue @Int32 1) - , ("bar",toValue @Int32 2)] - let (Just bar) = objectFromList [ ("bar", toValue @Text "cow") - , ("baz",toValue @Int32 3)] - let observed = unionObjects [foo, bar] - observed `shouldBe` Nothing - it "merges objects with unique keys" $ do - let (Just foo) = objectFromList [("foo", toValue @Int32 1)] - let (Just bar) = objectFromList [ ("bar", toValue @Text "cow") - , ("baz",toValue @Int32 3)] - let (Just expected) = objectFromList [ ("foo", toValue @Int32 1) - , ("bar", toValue @Text "cow") - , ("baz", toValue @Int32 3) - ] - let (Just observed) = unionObjects [foo, bar] - observed `shouldBe` expected - expected `shouldSatisfy` prop_fieldsUnique - describe "Objects" $ do - prop "have unique fields" $ do - prop_fieldsUnique - describe "ToValue / FromValue instances" $ do - prop "Bool" $ prop_roundtripValue @Bool - prop "Int32" $ prop_roundtripValue @Int32 - prop "Double" $ prop_roundtripValue @Double - prop "Text" $ forAll arbitraryText prop_roundtripValue - prop "Lists" $ prop_roundtripValue @[Int32] - prop "Non-empty lists" $ forAll (arbitraryNonEmpty @Int32) prop_roundtripValue - describe "AST" $ do - it "Objects converted from AST have unique fields" $ do - let input = AST.ObjectValue [ AST.ObjectField "foo" (AST.ValueString (AST.StringValue "bar")) - , AST.ObjectField "foo" (AST.ValueString (AST.StringValue "qux")) - ] - astToVariableValue (AST.ValueObject input) `shouldBe` Nothing - - --- | All of the fields in an object should have unique names. -prop_fieldsUnique :: Object -> Bool -prop_fieldsUnique object = - fieldNames == ordNub fieldNames - where - fieldNames = [name | ObjectField name _ <- objectFields object] diff --git a/tests/doctests/Main.hs b/tests/doctests/Main.hs --- a/tests/doctests/Main.hs +++ b/tests/doctests/Main.hs @@ -15,7 +15,5 @@ , "TypeApplications" , "DataKinds" ] - -- library code and examples - files = [ "src/" - , "tests/Examples/" - ] + -- library code + files = [ "src/" ]