diff --git a/graphql-api.cabal b/graphql-api.cabal index 5450b8b..492d904 100644 --- a/graphql-api.cabal +++ b/graphql-api.cabal @@ -2,7 +2,7 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 6db006b020fe198ac64b8a50f8335017251389b7c34dfc553675e38eb001a428 +-- hash: 0aae3dfe62e79c389edba2fdfb743c340f8fc3401c67124aa1f623415db39ab8 name: graphql-api version: 0.3.0 @@ -67,6 +67,7 @@ library GraphQL.Internal.Value GraphQL.Internal.Value.FromValue GraphQL.Internal.Value.ToValue + GraphQL.Introspection GraphQL.Resolver GraphQL.Value other-modules: @@ -133,8 +134,11 @@ test-suite graphql-api-tests build-depends: QuickCheck , aeson + , aeson-diff + , aeson-qq , attoparsec , base >=4.9 && <5 + , bytestring , containers , directory , exceptions @@ -144,15 +148,19 @@ test-suite graphql-api-tests , raw-strings-qq , tasty , tasty-hspec + , template-haskell + , text , transformers other-modules: ASTTests EndToEndTests EnumTests ExampleSchema + MutationTests OrderedMapTests ResolverTests SchemaTests + Utils ValidationTests ValueTests Paths_graphql_api diff --git a/package.yaml b/package.yaml index 1a922e9..0df4fc7 100644 --- a/package.yaml +++ b/package.yaml @@ -71,8 +71,13 @@ tests: - hspec - QuickCheck - raw-strings-qq + - aeson-diff + - aeson-qq + - bytestring - tasty - tasty-hspec + - template-haskell + - text - directory graphql-api-doctests: diff --git a/src/GraphQL.hs b/src/GraphQL.hs index cb0cb65..e1ebcfb 100644 --- a/src/GraphQL.hs +++ b/src/GraphQL.hs @@ -2,6 +2,7 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} -- | Interface for GraphQL API. -- -- __Note__: This module is highly subject to change. We're still figuring @@ -10,14 +11,17 @@ module GraphQL ( -- * Running queries interpretQuery + , interpretRequest , interpretAnonymousQuery , Response(..) -- * Preparing queries then running them , makeSchema , compileQuery , executeQuery + , executeRequest , QueryError , Schema + , SchemaRoot(..) , VariableValues , Value ) where @@ -30,7 +34,7 @@ import qualified Data.List.NonEmpty as NonEmpty import GraphQL.API (HasObjectDefinition(..), SchemaError(..)) import GraphQL.Internal.Execution ( VariableValues - , ExecutionError + , ExecutionError(..) , substituteVariables ) import qualified GraphQL.Internal.Execution as Execution @@ -43,6 +47,9 @@ import GraphQL.Internal.Validation , validate , getSelectionSet , VariableValue + , Operation(..) + , DefinitionType(..) + , getDefinitionType ) import GraphQL.Internal.Output ( GraphQLError(..) @@ -83,6 +90,16 @@ instance GraphQLError QueryError where formatError (NonObjectResult v) = "Query returned a value that is not an object: " <> show v +toResult :: Result Value -> Response +toResult (Result errors result) = case result of + -- TODO: Prevent this at compile time. Particularly frustrating since + -- we *know* that queries and mutations have object definitions + ValueObject object -> + case NonEmpty.nonEmpty errors of + Nothing -> Success object + Just errs -> PartialSuccess object (map toError errs) + v -> ExecutionFailure (singleError (NonObjectResult v)) + -- | Execute a GraphQL query. executeQuery :: forall api m. (HasResolver m api, Applicative m, HasObjectDefinition api) @@ -94,17 +111,7 @@ executeQuery 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) - 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)) + Right (_, ss) -> toResult <$> resolve @m @api handler (Just ss) -- | Create a GraphQL schema. makeSchema :: forall api. HasObjectDefinition api => Either QueryError Schema @@ -135,6 +142,75 @@ interpretAnonymousQuery -> m Response -- ^ The result of running the query. interpretAnonymousQuery handler query = interpretQuery @api @m handler query Nothing mempty +data SchemaRoot m query mutation = SchemaRoot + { queries :: Handler m query + , mutations :: Handler m mutation + } + +-- | Execute a query or mutation +-- +-- Similar to executeQuery, execept requests are dispatched against the +-- SchemaRoot depending on whether they are a query or mutation +executeRequest + :: forall schema queries mutations m. + ( schema ~ SchemaRoot m queries mutations + , HasResolver m queries + , HasObjectDefinition queries + , HasResolver m mutations + , HasObjectDefinition mutations + , Monad m + ) + => SchemaRoot m queries mutations + -> QueryDocument VariableValue + -> Maybe Name + -> VariableValues + -> m Response +executeRequest (SchemaRoot qh mh) document name variables = + case getOperation document name variables of + Left e -> pure (ExecutionFailure (singleError e)) + Right (operation, ss) -> do + toResult <$> case operation of + Query _ _ _ -> resolve @m @queries qh (Just ss) + Mutation _ _ _ -> resolve @m @mutations mh (Just ss) + +-- | Interpret a query or mutation against a SchemaRoot +interpretRequest + :: forall schema queries mutations m. + ( schema ~ SchemaRoot m queries mutations + , HasResolver m queries + , HasObjectDefinition queries + , HasResolver m mutations + , HasObjectDefinition mutations + , Monad m + ) + => SchemaRoot m queries mutations + -> Text + -> Maybe Name + -> VariableValues + -> m Response +interpretRequest (SchemaRoot qh mh) text name variables = case parseQuery text of + Left err -> pure (PreExecutionFailure (toError (ParseError err) :| [])) + Right document -> + case getDefinitionType document name of + Just operation -> case operation of + QueryDefinition -> run @m @queries qh document + MutationDefinition -> run @m @mutations mh document + _ -> + let err = maybe NoAnonymousOperation NoSuchOperation name + in pure (ExecutionFailure (toError err :| [])) + where + run :: forall n api. + ( HasObjectDefinition api + , HasResolver n api + , Applicative n + ) + => Handler n api -> AST.QueryDocument -> n Response + run h doc = case makeSchema @api of + Left e -> pure (PreExecutionFailure (toError e :| [])) + Right schema -> case validate schema doc of + Left e -> pure (PreExecutionFailure (toError (ValidationError e) :| [])) + Right validated -> executeQuery @api h validated name variables + -- | Turn some text into a valid query document. compileQuery :: Schema -> Text -> Either QueryError (QueryDocument VariableValue) compileQuery schema query = do @@ -146,8 +222,8 @@ parseQuery :: Text -> Either Text AST.QueryDocument parseQuery query = first toS (parseOnly (Parser.queryDocument <* endOfInput) query) -- | Get an operation from a query document ready to be processed. -getOperation :: QueryDocument VariableValue -> Maybe Name -> VariableValues -> Either QueryError (SelectionSetByType Value) +getOperation :: QueryDocument VariableValue -> Maybe Name -> VariableValues -> Either QueryError (Operation VariableValue, SelectionSetByType Value) getOperation document name vars = first ExecutionError $ do op <- Execution.getOperation document name resolved <- substituteVariables op vars - pure (getSelectionSet resolved) + pure (op, getSelectionSet resolved) \ No newline at end of file diff --git a/src/GraphQL/Internal/API.hs b/src/GraphQL/Internal/API.hs index aecebb0..84c84d4 100644 --- a/src/GraphQL/Internal/API.hs +++ b/src/GraphQL/Internal/API.hs @@ -26,6 +26,8 @@ module GraphQL.Internal.API , HasAnnotatedType(..) , HasAnnotatedInputType , HasObjectDefinition(..) + , HasFieldDefinitions(..) + , HasInterfaceDefinitions(..) , getArgumentDefinition , SchemaError(..) , nameFromSymbol @@ -75,7 +77,6 @@ import GraphQL.Internal.Output (GraphQLError(..)) 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]) @@ -87,7 +88,6 @@ 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 diff --git a/src/GraphQL/Internal/Resolver.hs b/src/GraphQL/Internal/Resolver.hs index ca52f41..39f8665 100644 --- a/src/GraphQL/Internal/Resolver.hs +++ b/src/GraphQL/Internal/Resolver.hs @@ -53,8 +53,9 @@ import GraphQL.Value , FromValue(..) , ToValue(..) ) -import GraphQL.Internal.Name (Name, HasName(..)) +import GraphQL.Internal.Name (Name, HasName(..), unName) import qualified GraphQL.Internal.OrderedMap as OrderedMap +import GraphQL.Internal.Schema (ObjectTypeDefinition(..)) import GraphQL.Internal.Output (GraphQLError(..)) import GraphQL.Internal.Validation ( SelectionSetByType @@ -212,9 +213,16 @@ type family FieldName (a :: Type) = (r :: Symbol) where 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 = + ( BuildFieldResolver m dispatchType + , Monad m + , KnownSymbol (FieldName dispatchType) + ) + => FieldHandler m dispatchType + -> m ResolveFieldResult + -> ObjectTypeDefinition + -> Field Value + -> m ResolveFieldResult +resolveField handler nextHandler defn field = -- check name before case API.nameFromSymbol @(FieldName dispatchType) of Left err -> pure (Result [SchemaError err] (Just GValue.ValueNull)) @@ -225,6 +233,8 @@ resolveField handler nextHandler field = Right resolver -> do Result errs value <- resolver pure (Result errs (Just value)) + | getName field == "__typename" -> + pure $ Result [] (Just $ GValue.ValueString $ GValue.String $ unName $ getName defn) | otherwise -> nextHandler -- We're using our usual trick of rewriting a type in a closed type @@ -312,7 +322,6 @@ type family RunFieldsHandler (m :: Type -> Type) (a :: Type) = (r :: Type) where 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 @@ -321,7 +330,7 @@ class RunFields m a where -- 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 + runFields :: RunFieldsHandler m a -> ObjectTypeDefinition -> Field Value -> m ResolveFieldResult instance forall f fs m dispatchType. ( BuildFieldResolver m dispatchType @@ -330,10 +339,10 @@ instance forall f fs m dispatchType. , KnownSymbol (FieldName dispatchType) , Monad m ) => RunFields m (f :<> fs) where - runFields (handler :<> nextHandlers) field = - resolveField @dispatchType @m handler nextHandler field + runFields (handler :<> nextHandlers) defn field = + resolveField @dispatchType @m handler nextHandler defn field where - nextHandler = runFields @m @fs nextHandlers field + nextHandler = runFields @m @fs nextHandlers defn field instance forall ksM t m dispatchType. ( BuildFieldResolver m dispatchType @@ -341,8 +350,8 @@ instance forall ksM t m dispatchType. , dispatchType ~ FieldResolverDispatchType (API.Field ksM t) , Monad m ) => RunFields m (API.Field ksM t) where - runFields handler field = - resolveField @dispatchType @m handler nextHandler field + runFields handler defn field = + resolveField @dispatchType @m handler nextHandler defn field where nextHandler = pure (Result [FieldNotFoundError (getName field)] Nothing) @@ -352,8 +361,8 @@ instance forall m a b dispatchType. , KnownSymbol (FieldName dispatchType) , Monad m ) => RunFields m (a :> b) where - runFields handler field = - resolveField @dispatchType @m handler nextHandler field + runFields handler defn field = + resolveField @dispatchType @m handler nextHandler defn field where nextHandler = pure (Result [FieldNotFoundError (getName field)] Nothing) @@ -368,12 +377,12 @@ instance forall typeName interfaces fields m. resolve mHandler (Just selectionSet) = case getSelectionSet of Left err -> throwE err - Right ss -> do + Right (ss, defn) -> 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 + r <- traverse (runFields @m @(RunFieldsType m fields) handler defn) ss let (Result errs obj) = GValue.objectFromOrderedMap . OrderedMap.catMaybes <$> sequenceA r pure (Result errs (GValue.ValueObject obj)) @@ -391,7 +400,7 @@ instance forall typeName interfaces fields m. -- See for -- more details. (SelectionSet ss') <- first ValidationError $ getSelectionSetForType defn selectionSet - pure ss' + pure (ss', defn) -- TODO(tom): we're getting to a point where it might make sense to -- split resolver into submodules (GraphQL.Resolver.Union etc.) diff --git a/src/GraphQL/Internal/Schema.hs b/src/GraphQL/Internal/Schema.hs index 21cd8b7..f580282 100644 --- a/src/GraphQL/Internal/Schema.hs +++ b/src/GraphQL/Internal/Schema.hs @@ -23,6 +23,7 @@ module GraphQL.Internal.Schema , ObjectTypeDefinition(..) , UnionTypeDefinition(..) , ScalarTypeDefinition(..) + , TypeExtensionDefinition(..) -- ** Input types , InputType(..) , InputTypeDefinition(..) @@ -143,7 +144,7 @@ instance DefinesTypes TypeDefinition where TypeDefinitionUnion x -> getDefinedTypes x TypeDefinitionScalar x -> getDefinedTypes x TypeDefinitionEnum x -> getDefinedTypes x - TypeDefinitionInputObject _ -> mempty + TypeDefinitionInputObject x -> getDefinedTypes x TypeDefinitionTypeExtension _ -> panic "TODO: we should remove the 'extend' behaviour entirely" @@ -168,7 +169,7 @@ instance HasName FieldDefinition where getName (FieldDefinition name _ _) = name instance DefinesTypes FieldDefinition where - getDefinedTypes (FieldDefinition _ args retVal) = + getDefinedTypes (FieldDefinition _ args retVal) = getDefinedTypes (getAnnotatedType retVal) <> foldMap getDefinedTypes args @@ -254,12 +255,20 @@ data InputObjectTypeDefinition = InputObjectTypeDefinition Name (NonEmpty InputO instance HasName InputObjectTypeDefinition where getName (InputObjectTypeDefinition name _) = name +instance DefinesTypes InputObjectTypeDefinition where + getDefinedTypes obj@(InputObjectTypeDefinition name fields) = + Map.singleton name (TypeDefinitionInputObject obj) <> + foldMap getDefinedTypes fields + data InputObjectFieldDefinition = InputObjectFieldDefinition Name (AnnotatedType InputType) (Maybe DefaultValue) deriving (Eq, Ord, Show) -- XXX: spec is unclear about default value for input object field definitions instance HasName InputObjectFieldDefinition where getName (InputObjectFieldDefinition name _ _) = name +instance DefinesTypes InputObjectFieldDefinition where + getDefinedTypes (InputObjectFieldDefinition _ annotatedInput _) = getDefinedTypes $ getAnnotatedType annotatedInput + newtype TypeExtensionDefinition = TypeExtensionDefinition ObjectTypeDefinition deriving (Eq, Ord, Show) @@ -274,7 +283,7 @@ instance HasName InputType where instance DefinesTypes InputType where getDefinedTypes inputType = - case inputType of + case inputType of DefinedInputType typeDefinition -> getDefinedTypes typeDefinition BuiltinInputType _ -> mempty @@ -291,7 +300,7 @@ instance HasName InputTypeDefinition where instance DefinesTypes InputTypeDefinition where getDefinedTypes inputTypeDefinition = - case inputTypeDefinition of + case inputTypeDefinition of InputTypeDefinitionObject typeDefinition -> getDefinedTypes (TypeDefinitionInputObject typeDefinition) InputTypeDefinitionScalar typeDefinition -> getDefinedTypes (TypeDefinitionScalar typeDefinition) InputTypeDefinitionEnum typeDefinition -> getDefinedTypes (TypeDefinitionEnum typeDefinition) @@ -337,15 +346,15 @@ doesFragmentTypeApply objectType fragmentType = getInputTypeDefinition :: TypeDefinition -> Maybe InputTypeDefinition getInputTypeDefinition td = case td of - TypeDefinitionInputObject itd -> Just (InputTypeDefinitionObject itd) - TypeDefinitionScalar itd -> Just (InputTypeDefinitionScalar itd) + 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 +-- +-- 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 @@ -360,7 +369,7 @@ builtinFromName typeName -- 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 = +astAnnotationToSchemaAnnotation gtype schemaTypeName = case gtype of AST.TypeNamed _ -> TypeNamed schemaTypeName AST.TypeList (AST.ListType astTypeName) -> TypeList (ListType $ astAnnotationToSchemaAnnotation astTypeName schemaTypeName) diff --git a/src/GraphQL/Internal/Syntax/AST.hs b/src/GraphQL/Internal/Syntax/AST.hs index 23d6aaf..609669b 100644 --- a/src/GraphQL/Internal/Syntax/AST.hs +++ b/src/GraphQL/Internal/Syntax/AST.hs @@ -53,11 +53,11 @@ import Protolude import Test.QuickCheck (Arbitrary(..), listOf, oneof) import GraphQL.Internal.Arbitrary (arbitraryText) -import GraphQL.Internal.Name +import GraphQL.Internal.Name ( Name , HasName(..) ) - + -- * Documents -- | A 'QueryDocument' is something a user might send us. diff --git a/src/GraphQL/Internal/Validation.hs b/src/GraphQL/Internal/Validation.hs index 88e02e1..a6243d9 100644 --- a/src/GraphQL/Internal/Validation.hs +++ b/src/GraphQL/Internal/Validation.hs @@ -39,8 +39,10 @@ module GraphQL.Internal.Validation , QueryDocument(..) , validate , getErrors + , DefinitionType(..) + , getDefinitionType -- * Operating on validated documents - , Operation + , Operation(..) , getSelectionSet -- * Executing validated documents , VariableDefinition(..) @@ -926,3 +928,29 @@ instance Applicative (Validator e) where Validator (Left e) <*> _ = Validator (Left e) Validator _ <*> (Validator (Left e)) = Validator (Left e) Validator (Right f) <*> Validator (Right x) = Validator (Right (f x)) + +data DefinitionType = QueryDefinition | MutationDefinition deriving (Eq, Show) + +getDefinitionType :: AST.QueryDocument -> Maybe Name -> Maybe DefinitionType +getDefinitionType doc (Just name) = + case find (operationNamed name) $ getOperationDefinitions doc of + Just (AST.Mutation _) -> Just MutationDefinition + Just _ -> Just QueryDefinition + _ -> Nothing +getDefinitionType doc Nothing = + case getOperationDefinitions doc of + [op] -> case op of + (AST.Mutation _) -> Just MutationDefinition + _ -> Just QueryDefinition + _ -> Nothing + +getOperationDefinitions :: AST.QueryDocument -> [AST.OperationDefinition] +getOperationDefinitions = mapMaybe extract . AST.getDefinitions + where + extract (AST.DefinitionOperation op) = Just op + extract _ = Nothing + +operationNamed :: Name -> AST.OperationDefinition -> Bool +operationNamed n (AST.Query (AST.Node n' _ _ _)) = Just n == n' +operationNamed n (AST.Mutation (AST.Node n' _ _ _)) = Just n == n' +operationNamed _ _ = False diff --git a/src/GraphQL/Introspection.hs b/src/GraphQL/Introspection.hs new file mode 100644 index 0000000..38362a7 --- /dev/null +++ b/src/GraphQL/Introspection.hs @@ -0,0 +1,317 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module GraphQL.Introspection + ( SchemaField + , TypeField + , schema + , type_ + , serialize + ) where + +import Protolude hiding (TypeError, Enum) + +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map as Map +import qualified Data.Text as T + +import GraphQL (SchemaRoot(..)) +import GraphQL.API +import GraphQL.Resolver +import GraphQL.Internal.Name (getName, unName) +import GraphQL.Internal.Schema + +import qualified GraphQL.Internal.Syntax.AST as AST +import qualified GraphQL.Internal.Syntax.Encoder as E + +-- See http://facebook.github.io/graphql/June2018/#sec-Schema-Introspection +type Schema__ = Object "__Schema" '[] + '[ Field "types" (List Type__) + , Field "queryType" Type__ + , Field "mutationType" Type__ + ] + +type Type__ = Object "__Type" '[] + '[ Field "kind" TypeKind__ + , Field "name" Text + , Field "fields" (Maybe (List Field__)) + , Field "enumValues" (Maybe (List EnumValue__)) + , Field "inputFields" (Maybe (List InputValue__)) + ] + +type Field__ = Object "__Field" '[] + '[ Field "name" Text + , Field "args" (List InputValue__) + ] + +type EnumValue__ = Object "__EnumValue" '[] + '[ Field "name" Text + ] + +type InputValue__ = Object "__InputValue" '[] + '[ Field "name" Text + ] + +data TypeKind = SCALAR + | OBJECT + | INTERFACE + | UNION + | ENUM + | INPUT_OBJECT + | LIST + | NON_NULL + deriving (Show, Eq, Generic) +instance GraphQLEnum TypeKind + +type TypeKind__ = Enum "__TypeKind" TypeKind + +type SchemaField = Field "__schema" Schema__ +type TypeField = Argument "name" Text :> Field "__type" Type__ + +data SchemaDefinition = SchemaDefinition ObjectTypeDefinition ObjectTypeDefinition + +schemaDefinedTypes :: SchemaDefinition -> Map Name TypeDefinition +schemaDefinedTypes (SchemaDefinition queries mutations) = + Map.filterWithKey defined $ getDefinedTypes queries <> getDefinedTypes mutations + where + defined name _ = not $ reserved name + +reserved :: Name -> Bool +reserved name = "__" `T.isPrefixOf` unName name + +serialize :: forall s h q m. + ( s ~ SchemaRoot h q m + , HasObjectDefinition q + , HasObjectDefinition m + ) => Either SchemaError Text +serialize = do + queries <- getDefinition @q + mutations <- getDefinition @m + let definitions = ordNub $ collectDefinitions queries <> collectDefinitions mutations + + return $ + E.schemaDocument (AST.SchemaDocument $ map typeDefinitionToAST definitions) <> + ",schema{query:" <> unName (getName queries) <> ",mutation:" <> unName (getName mutations) <> "}" + +collectDefinitions :: ObjectTypeDefinition -> [TypeDefinition] +collectDefinitions = visitObject + where + visitObject (ObjectTypeDefinition name interfaces fields) = + if reserved name + then [] + else + let fields' = NonEmpty.fromList $ NonEmpty.filter (not . reserved . getName) fields + in TypeDefinitionObject (ObjectTypeDefinition name interfaces fields') : concatMap visitField fields' + + visitField (FieldDefinition _ args out) = + visitType out <> concatMap visitArg args + + visitArg (ArgumentDefinition _ input _) = case unAnnotatedType input of + DefinedInputType (InputTypeDefinitionObject inputObject) -> visitInputObjectType inputObject + _ -> [] + + visitType t = case unAnnotatedType t of + DefinedType (TypeDefinitionObject object) -> visitObject object + DefinedType definition -> [definition] + _ -> [] + + visitInputObjectType inputObject@(InputObjectTypeDefinition _ fields) = + TypeDefinitionInputObject inputObject : concatMap visitInputObjectField fields + + visitInputObjectField (InputObjectFieldDefinition _ input _) = case unAnnotatedType input of + DefinedInputType (InputTypeDefinitionObject object) -> visitInputObjectType object + _ -> [] + +unAnnotatedType :: AnnotatedType t -> t +unAnnotatedType (TypeNamed t) = t +unAnnotatedType (TypeList (ListType t)) = unAnnotatedType t +unAnnotatedType (TypeNonNull (NonNullTypeNamed t)) = t +unAnnotatedType (TypeNonNull (NonNullTypeList (ListType t))) = unAnnotatedType t + +{- + - Schema => AST conversions + - + - These are generally used to take a validated schema obtained from e.g. `getDefinition @type` + - and produce a schema document suitable for consumption by an external client + -} + +typeDefinitionToAST :: TypeDefinition -> AST.TypeDefinition +typeDefinitionToAST (TypeDefinitionObject o) = AST.TypeDefinitionObject $ objectTypeDefinitionToAST o +typeDefinitionToAST (TypeDefinitionInputObject o) = AST.TypeDefinitionInputObject $ inputObjectTypeDefinitionToAST o +typeDefinitionToAST (TypeDefinitionInterface i) = AST.TypeDefinitionInterface $ interfaceTypeDefinitionToAST i +typeDefinitionToAST (TypeDefinitionUnion u) = AST.TypeDefinitionUnion $ unionTypeDefinitionToAST u +typeDefinitionToAST (TypeDefinitionScalar s) = AST.TypeDefinitionScalar $ scalarTypeDefinitionToAST s +typeDefinitionToAST (TypeDefinitionEnum e) = AST.TypeDefinitionEnum $ enumTypeDefinitionToAST e +typeDefinitionToAST (TypeDefinitionTypeExtension e) = AST.TypeDefinitionTypeExtension $ extensionTypeDefinitionToAST e + +objectTypeDefinitionToAST :: ObjectTypeDefinition -> AST.ObjectTypeDefinition +objectTypeDefinitionToAST (ObjectTypeDefinition name interfaces fields) = + AST.ObjectTypeDefinition name (map (AST.NamedType . getName) interfaces) (NonEmpty.toList $ map fieldDefinitionToAST fields) + +inputObjectTypeDefinitionToAST :: InputObjectTypeDefinition -> AST.InputObjectTypeDefinition +inputObjectTypeDefinitionToAST (InputObjectTypeDefinition name fields) = + AST.InputObjectTypeDefinition name (NonEmpty.toList $ map inputObjectFieldDefinitionToAST fields) + +interfaceTypeDefinitionToAST :: InterfaceTypeDefinition -> AST.InterfaceTypeDefinition +interfaceTypeDefinitionToAST (InterfaceTypeDefinition name fields) = + AST.InterfaceTypeDefinition name (NonEmpty.toList $ map fieldDefinitionToAST fields) + +unionTypeDefinitionToAST :: UnionTypeDefinition -> AST.UnionTypeDefinition +unionTypeDefinitionToAST (UnionTypeDefinition name objects) = + AST.UnionTypeDefinition name (NonEmpty.toList $ map (AST.NamedType . getName) objects) + +scalarTypeDefinitionToAST :: ScalarTypeDefinition -> AST.ScalarTypeDefinition +scalarTypeDefinitionToAST (ScalarTypeDefinition name) = + AST.ScalarTypeDefinition name + +enumTypeDefinitionToAST :: EnumTypeDefinition -> AST.EnumTypeDefinition +enumTypeDefinitionToAST (EnumTypeDefinition name values) = + AST.EnumTypeDefinition name $ map (AST.EnumValueDefinition . getName) values + +extensionTypeDefinitionToAST :: TypeExtensionDefinition -> AST.TypeExtensionDefinition +extensionTypeDefinitionToAST (TypeExtensionDefinition obj) = + AST.TypeExtensionDefinition $ objectTypeDefinitionToAST obj + +fieldDefinitionToAST :: FieldDefinition -> AST.FieldDefinition +fieldDefinitionToAST (FieldDefinition name args out) = + AST.FieldDefinition name (map argToInputValue args) (typeToAST out) + +argToInputValue :: ArgumentDefinition -> AST.InputValueDefinition +argToInputValue (ArgumentDefinition name annotatedInput _) = + AST.InputValueDefinition name (inputTypeToAST annotatedInput) Nothing -- FIXME + +inputObjectFieldDefinitionToAST :: InputObjectFieldDefinition -> AST.InputValueDefinition +inputObjectFieldDefinitionToAST (InputObjectFieldDefinition name annotatedInput _) = AST.InputValueDefinition name (inputTypeToAST annotatedInput) Nothing -- FIXME + +typeToAST :: AnnotatedType GType -> AST.GType +typeToAST (TypeNamed t) = + -- AST.TypeNamed $ AST.NamedType $ getName t + AST.TypeNonNull $ AST.NonNullTypeNamed $ AST.NamedType $ getName t +typeToAST (TypeList (ListType t)) = + -- AST.TypeList $ AST.ListType $ AST.TypeNamed $ AST.NamedType $ getName t + AST.TypeNonNull $ AST.NonNullTypeList $ AST.ListType $ + -- AST.TypeNamed $ AST.NamedType $ getName t + AST.TypeNonNull $ AST.NonNullTypeNamed $ AST.NamedType $ getName t +typeToAST (TypeNonNull (NonNullTypeNamed t)) = + AST.TypeNonNull $ AST.NonNullTypeNamed $ AST.NamedType $ getName t +typeToAST (TypeNonNull (NonNullTypeList (ListType t))) = + AST.TypeNonNull $ AST.NonNullTypeList $ AST.ListType $ + -- AST.TypeNamed $ AST.NamedType $ getName t + AST.TypeNonNull $ AST.NonNullTypeNamed $ AST.NamedType $ getName t + +inputTypeToAST :: AnnotatedType InputType -> AST.GType +inputTypeToAST (TypeNamed t) = + AST.TypeNamed $ AST.NamedType $ getName t +inputTypeToAST (TypeList (ListType t)) = + AST.TypeNonNull $ AST.NonNullTypeList $ AST.ListType $ + AST.TypeNamed $ AST.NamedType $ getName t +inputTypeToAST (TypeNonNull (NonNullTypeNamed t)) = + AST.TypeNonNull $ AST.NonNullTypeNamed $ AST.NamedType $ getName t +inputTypeToAST (TypeNonNull (NonNullTypeList (ListType t))) = + AST.TypeNonNull $ AST.NonNullTypeList $ AST.ListType $ + AST.TypeNamed $ AST.NamedType $ getName t + +schema :: forall s m queries mutations. + ( s ~ SchemaRoot m queries mutations + , HasObjectDefinition queries + , HasObjectDefinition mutations + , Monad m + ) => Handler m Schema__ +schema = do + let Right queries = getDefinition @queries + Right mutations = getDefinition @mutations + types = schemaDefinedTypes $ SchemaDefinition queries mutations + pure + $ pure (map typeHandler $ Map.elems types) + :<> objectTypeHandler queries + :<> objectTypeHandler mutations + +type_ :: forall s m queries mutations. + ( s ~ SchemaRoot m queries mutations + , HasObjectDefinition queries + , HasObjectDefinition mutations + , Monad m + ) => Text -> Handler m Type__ +type_ name = do + let Right queries = getDefinition @queries + Right mutations = getDefinition @mutations + types = Map.mapKeys unName $ schemaDefinedTypes $ SchemaDefinition queries mutations + case Map.lookup name types of + Just t -> typeHandler t + Nothing -> panic "failed to find type" + +typeHandler :: Monad m => TypeDefinition -> Handler m Type__ +typeHandler (TypeDefinitionObject object) = objectTypeHandler object +typeHandler (TypeDefinitionInterface interface) = interfaceTypeHandler interface +typeHandler (TypeDefinitionUnion union) = unionTypeHandler union +typeHandler (TypeDefinitionScalar scalar) = scalarTypeHandler scalar +typeHandler (TypeDefinitionEnum enum) = enumTypeHandler enum +typeHandler (TypeDefinitionInputObject input) = inputObjectTypeHandler input +typeHandler (TypeDefinitionTypeExtension ex) = typeExtensionTypeHandler ex + +objectTypeHandler :: Monad m => ObjectTypeDefinition -> Handler m Type__ +objectTypeHandler (ObjectTypeDefinition name _ fields) = pure + $ pure OBJECT + :<> pure (unName name) + :<> pure (Just . pure $ map fieldHandler $ NonEmpty.toList fields) + :<> pure Nothing + :<> pure Nothing + +enumTypeHandler :: Monad m => EnumTypeDefinition -> Handler m Type__ +enumTypeHandler (EnumTypeDefinition name values) = pure + $ pure ENUM + :<> pure (unName name) + :<> pure Nothing + :<> pure (Just . pure $ map (pure . pure . unName . getName) values) + :<> pure Nothing + +unionTypeHandler :: Monad m => UnionTypeDefinition -> Handler m Type__ +unionTypeHandler (UnionTypeDefinition name _) = pure + $ pure UNION + :<> pure (unName name) + :<> pure Nothing + :<> pure Nothing + :<> pure Nothing + +interfaceTypeHandler :: Monad m => InterfaceTypeDefinition -> Handler m Type__ +interfaceTypeHandler (InterfaceTypeDefinition name fields) = pure + $ pure INTERFACE + :<> pure (unName name) + :<> pure (Just . pure $ map fieldHandler $ NonEmpty.toList fields) + :<> pure Nothing + :<> pure Nothing + +scalarTypeHandler :: Monad m => ScalarTypeDefinition -> Handler m Type__ +scalarTypeHandler (ScalarTypeDefinition name) = pure + $ pure SCALAR + :<> pure (unName name) + :<> pure Nothing + :<> pure Nothing + :<> pure Nothing + +inputObjectTypeHandler :: Monad m => InputObjectTypeDefinition -> Handler m Type__ +inputObjectTypeHandler (InputObjectTypeDefinition name fields) = pure + $ pure INPUT_OBJECT + :<> pure (unName name) + :<> pure Nothing + :<> pure Nothing + :<> pure (Just . pure $ map (pure . pure . unName . getName) $ NonEmpty.toList fields) + +typeExtensionTypeHandler :: Monad m => TypeExtensionDefinition -> Handler m Type__ +typeExtensionTypeHandler (TypeExtensionDefinition obj) = objectTypeHandler obj + +fieldHandler :: Monad m => FieldDefinition -> Handler m Field__ +fieldHandler (FieldDefinition name args _) = pure + $ pure (unName name) + :<> pure (map (pure . pure . unName . getName) args) \ No newline at end of file diff --git a/tests/EndToEndTests.hs b/tests/EndToEndTests.hs index 872c6fa..f9d9d45 100644 --- a/tests/EndToEndTests.hs +++ b/tests/EndToEndTests.hs @@ -8,18 +8,21 @@ -- sanity checks on our reasoning. module EndToEndTests (tests) where -import Protolude +import Protolude hiding (diff) import Data.Aeson (Value(Null), toJSON, object, (.=)) +import Data.IORef (IORef, newIORef, readIORef, modifyIORef) import qualified Data.Map as Map -import GraphQL (makeSchema, compileQuery, executeQuery, interpretAnonymousQuery, interpretQuery) +import GraphQL (makeSchema, compileQuery, executeQuery, interpretAnonymousQuery, interpretQuery, interpretRequest, SchemaRoot(..), Response) import GraphQL.API (Object, Field, List, Argument, (:>), Defaultable(..), HasAnnotatedInputType(..)) import GraphQL.Internal.Syntax.AST (Variable(..)) +import qualified GraphQL.Introspection as Introspection import GraphQL.Resolver ((:<>)(..), Handler, unionValue) import GraphQL.Value (ToValue(..), FromValue(..), makeName) import Test.Tasty (TestTree) -import Test.Tasty.Hspec (testSpec, describe, it, shouldBe) +import Test.Tasty.Hspec (testSpec, describe, it, shouldBe, runIO) import Text.RawString.QQ (r) +import Utils import ExampleSchema @@ -38,6 +41,17 @@ type QueryRoot = Object "QueryRoot" '[] , Argument "dog" DogStuff :> Field "describeDog" Text , Field "catOrDog" CatOrDog , Field "catOrDogList" (List CatOrDog) + , Introspection.SchemaField + , Introspection.TypeField + ] + +type DogWithTreats = Object "DogWithTreats" '[] + '[ Field "dog" Dog + , Field "treats" Int32 + ] + +type MutationRoot = Object "MutationRoot" '[] + '[ Argument "count" Int32 :> Field "giveTreats" DogWithTreats ] -- | An object that is passed as an argument. i.e. an input object. @@ -56,11 +70,11 @@ catOrDog = do name <- pure "MonadicFelix" -- we can do monadic actions unionValue @Cat (catHandler name Nothing 15) -catOrDogList :: Handler IO (List CatOrDog) -catOrDogList = +catOrDogList :: ServerDog -> Handler IO (List CatOrDog) +catOrDogList dog = pure [ unionValue @Cat (catHandler "Felix the Cat" (Just "felix") 42) , unionValue @Cat (catHandler "Henry" Nothing 10) - , unionValue @Dog (viewServerDog mortgage) + , unionValue @Dog (viewServerDog dog) ] catHandler :: Text -> Maybe Text -> Int32 -> Handler IO Cat @@ -80,6 +94,7 @@ data ServerDog , houseTrainedAtHome :: Bool , houseTrainedElsewhere :: Bool , owner :: ServerHuman + , treatCount :: IORef Int32 } -- | Whether 'ServerDog' knows the given command. @@ -108,19 +123,13 @@ describeDog (DogStuff toy likesTreats) | otherwise = pure $ "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 - } +rootHandler dog = pure $ + viewServerDog dog :<> + describeDog :<> + catOrDog :<> + catOrDogList dog :<> + Introspection.schema @E2ESchema :<> + Introspection.type_ @E2ESchema -- | Our server's internal representation of a 'Human'. newtype ServerHuman = ServerHuman Text deriving (Eq, Ord, Show, Generic) @@ -134,9 +143,35 @@ viewServerHuman (ServerHuman name) = pure (pure name) jml :: ServerHuman jml = ServerHuman "jml" +type E2ESchema = SchemaRoot IO QueryRoot MutationRoot + +rootMutations :: ServerDog -> IORef Int32 -> Handler IO MutationRoot +rootMutations dog treats = pure + $ \count -> do + modifyIORef treats (+ count) + pure $ viewServerDog dog :<> readIORef treats + +schemaHandler :: ServerDog -> IORef Int32 -> E2ESchema +schemaHandler dog treats = SchemaRoot (rootHandler dog) (rootMutations dog treats) tests :: IO TestTree tests = testSpec "End-to-end tests" $ do + treatCountRef <- runIO $ newIORef 0 + + let + -- | 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 + , treatCount = treatCountRef + } + describe "interpretAnonymousQuery" $ do it "Handles the simplest possible valid query" $ do let query = [r|{ @@ -483,3 +518,274 @@ tests = testSpec "End-to-end tests" $ do ] ] toJSON (toValue response) `shouldBe` expected + + describe "introspection" $ do + treatRef <- runIO $ newIORef 1 + + let + run :: Text -> IO Response + run query = interpretRequest @E2ESchema (schemaHandler mortgage treatRef) query Nothing mempty + + it "can issue direct queries" $ do + response <- run [r|query myQuery { + dog { + name + } + } + |] + response `shouldBeJSON` [json| + { + "data": { + "dog": { + "name": "Mortgage" + } + } + } + |] + + it "can issue mutations" $ do + response <- run [r|mutation goodBoy { + giveTreats(count: 2) { + dog { + name + } + treats + } + } + |] + response `shouldBeJSON` [json| + { + "data": { + "giveTreats": { + "dog": { + "name": "Mortgage" + }, + "treats": 3 + } + } + } + |] + + it "can fetch the __schema" $ do + response <- run [r|{ + __schema { + types { + kind + name + } + queryType { + name + } + mutationType { + name + } + } + }|] + response `shouldBeJSON` [json| + { + "data": { + "__schema": { + "types": [ + { + "kind": "OBJECT", + "name": "Cat" + }, + { + "kind": "ENUM", + "name": "CatCommand" + }, + { + "kind": "UNION", + "name": "CatOrDog" + }, + { + "kind": "OBJECT", + "name": "Dog" + }, + { + "kind": "ENUM", + "name": "DogCommand" + }, + { + "kind": "INPUT_OBJECT", + "name": "DogStuff" + }, + { + "kind": "OBJECT", + "name": "DogWithTreats" + }, + { + "kind": "OBJECT", + "name": "Human" + }, + { + "kind": "OBJECT", + "name": "MutationRoot" + }, + { + "kind": "INTERFACE", + "name": "Pet" + }, + { + "kind": "OBJECT", + "name": "QueryRoot" + }, + { + "kind": "INTERFACE", + "name": "Sentient" + } + ], + "queryType": { + "name": "QueryRoot" + }, + "mutationType": { + "name": "MutationRoot" + } + } + } + } + |] + + it "can introspect objects" $ do + response <- run [r|{ + __type(name: "Dog") { + kind + name + fields { + name + } + } + }|] + response `shouldBeJSON` [json| + { + "data": { + "__type": { + "kind": "OBJECT", + "name": "Dog", + "fields": [ + { "name": "name" }, + { "name": "nickname" }, + { "name": "barkVolume" }, + { "name": "doesKnowCommand" }, + { "name": "isHouseTrained" }, + { "name": "owner" } + ] + } + } + } + |] + + it "can introspect interfaces" $ do + response <- run [r|{ + __type(name: "Pet") { + kind + name + fields { + name + } + } + }|] + response `shouldBeJSON` [json|{ + "data": { + "__type": { + "kind": "INTERFACE", + "name": "Pet", + "fields": [ + { "name": "name" } + ] + } + } + }|] + + it "can introspect unions" $ do + response <- run [r|{ + __type(name: "CatOrDog") { + kind + name + } + }|] + response `shouldBeJSON` [json|{ + "data": { + "__type": { + "kind": "UNION", + "name": "CatOrDog" + } + } + }|] + + it "can introspect enums" $ do + response <- run [r|{ + __type(name: "DogCommand") { + kind + name + enumValues { + name + } + } + }|] + response `shouldBeJSON` [json|{ + "data": { + "__type": { + "kind": "ENUM", + "name": "DogCommand", + "enumValues": [ + { "name": "Sit" }, + { "name": "Down" }, + { "name": "Heel" } + ] + } + } + }|] + + it "can introspect input objects" $ do + response <- run [r|{ + __type(name: "DogStuff") { + kind + name + inputFields { + name + } + } + }|] + response `shouldBeJSON` [json|{ + "data": { + "__type": { + "kind": "INPUT_OBJECT", + "name": "DogStuff", + "inputFields": [ + { "name": "toy" }, + { "name": "likesTreats" } + ] + } + } + }|] + + it "can introspect field input args" $ do + response <- run [r|{ + __type(name: "MutationRoot") { + kind + fields { + name + args { + name + } + } + } + }|] + response `shouldBeJSON` [json|{ + "data": { + "__type": { + "kind": "OBJECT", + "fields": [{ + "name": "giveTreats", + "args": [ + { "name": "count" } + ] + }] + } + } + }|] + + it "can serialize the schema" $ do + let expected = "type QueryRoot{dog:Dog!,describeDog(dog:DogStuff!):String!,catOrDog:CatOrDog!,catOrDogList:[CatOrDog!]!}type Dog implements Pet{name:String!,nickname:String!,barkVolume:Int!,doesKnowCommand(dogCommand:DogCommand!):Boolean!,isHouseTrained(atOtherHomes:Boolean):Boolean!,owner:Human!}type Human implements Sentient{name:String!}input DogStuff{toy:String!,likesTreats:Boolean!}union CatOrDog=Cat|Dogtype MutationRoot{giveTreats(count:Int!):DogWithTreats!}type DogWithTreats{dog:Dog!,treats:Int!}\n,schema{query:QueryRoot,mutation:MutationRoot}" + Introspection.serialize @E2ESchema `shouldBe` Right expected \ No newline at end of file diff --git a/tests/MutationTests.hs b/tests/MutationTests.hs new file mode 100644 index 0000000..43fa324 --- /dev/null +++ b/tests/MutationTests.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module MutationTests (tests) where + +import Protolude hiding (Enum) + +import Data.IORef +import Text.RawString.QQ (r) +import Test.Tasty (TestTree) +import Test.Tasty.Hspec (testSpec, describe, it, runIO, before_) +import Utils + +import GraphQL +import GraphQL.API +import GraphQL.Resolver + +import GraphQL.Internal.Name (Name) +import GraphQL.Internal.Validation (QueryDocument, VariableValue) + +data Server = Server + { counter :: IORef Int32 + } + +type Counter = Object "Counter" '[] + '[ Field "value" Int32 + ] + +type QueryRoot = Object "QueryRoot" '[] + '[ Field "counter" Counter + ] + +queryRoot :: Server -> Handler IO QueryRoot +queryRoot server = pure + $ pure (readIORef $ counter server) + +type MutationRoot = Object "MutationRoot" '[] + '[ Field "increment" Counter + , Argument "to" Int32 :> Field "reset" Counter + ] + +mutationRoot :: Server -> Handler IO MutationRoot +mutationRoot server = pure + $ pure (atomicModifyIORef' (counter server) $ \n -> (n+1, n+1)) + :<> \n -> pure $ do + writeIORef (counter server) n + return n + +type CounterSchema = SchemaRoot IO QueryRoot MutationRoot + +schemaHandler :: Server -> SchemaRoot IO QueryRoot MutationRoot +schemaHandler server = SchemaRoot (queryRoot server) (mutationRoot server) + +tests :: IO TestTree +tests = + testSpec "Schema with mutations" $ do + let Right querySchema = makeSchema @QueryRoot + Right mutationSchema = makeSchema @MutationRoot + + Right getCount = compileQuery querySchema + [r|query getCount { + counter { + value + } + }|] + Right increment = compileQuery mutationSchema + [r|mutation increment { + increment { + value + } + }|] + + server <- runIO $ Server <$> newIORef 0 + + let + reset :: IO () + reset = writeIORef (counter server) 0 + + run :: QueryDocument VariableValue -> Maybe Name -> VariableValues -> IO Response + run = executeRequest @CounterSchema (schemaHandler server) + + describe "execution" $ before_ reset $ do + it "can issue queries" $ do + response <- run getCount "getCount" mempty + response `shouldBeJSON` [json| + { + "data": { + "counter": { "value": 0 } + } + } + |] + + it "can issue mutations" $ do + response <- run increment "increment" mempty + response `shouldBeJSON` [json| + { + "data": { + "increment": { "value": 1 } + } + } + |] + diff --git a/tests/ResolverTests.hs b/tests/ResolverTests.hs index 3ffdc7d..3bed108 100644 --- a/tests/ResolverTests.hs +++ b/tests/ResolverTests.hs @@ -1,14 +1,17 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} module ResolverTests (tests) where import Protolude hiding (Enum) +import Data.Aeson.QQ (aesonQQ) +import Text.RawString.QQ (r) import Test.Tasty (TestTree) import Test.Tasty.Hspec (testSpec, describe, it, shouldBe) -import Data.Aeson (encode) +import Data.Aeson (encode, toJSON) import GraphQL ( Response(..) , interpretAnonymousQuery @@ -18,12 +21,14 @@ import GraphQL.API , Field , Argument , Enum + , Union , (:>) ) import GraphQL.Resolver ( Handler , ResolverError(..) , (:<>)(..) + , unionValue ) import GraphQL.Internal.Output (singleError) @@ -74,6 +79,28 @@ enumHandler :: Handler IO EnumQuery enumHandler = pure $ pure NormalFile -- /Enum test +-- Union test +type Cat = Object "Cat" '[] '[Field "name" Text] +type Dog = Object "Dog" '[] '[Field "name" Text] +type CatOrDog = Union "CatOrDog" '[Cat, Dog] +type UnionQuery = Object "UnionQuery" '[] + '[ Argument "isCat" Bool :> Field "catOrDog" CatOrDog + ] + +dogHandler :: Handler IO Cat +dogHandler = pure $ pure "Mortgage" + +catHandler :: Handler IO Dog +catHandler = pure $ pure "Felix" + +unionHandler :: Handler IO UnionQuery +unionHandler = pure $ \isCat -> + if isCat + then unionValue @Cat catHandler + else unionValue @Dog dogHandler + +-- /Union test + tests :: IO TestTree tests = testSpec "TypeAPI" $ do describe "tTest" $ do @@ -94,3 +121,47 @@ tests = testSpec "TypeAPI" $ do it "API.Enum works" $ do Success object <- interpretAnonymousQuery @EnumQuery enumHandler "{ mode }" encode object `shouldBe` "{\"mode\":\"NormalFile\"}" + + describe "Introspection" $ do + describe "__typename" $ do + it "can describe nested objects" $ do + Success object <- interpretAnonymousQuery @Query handler [r| + { + __typename + test(id: "1") { + __typename + name + } + } + |] + + toJSON object `shouldBe` [aesonQQ| + { + "__typename": "Query", + "test": { + "__typename": "Foo", + "name": "Mort" + } + } + |] + + it "can describe unions" $ do + Success object <- interpretAnonymousQuery @UnionQuery unionHandler [r| + { + __typename + catOrDog(isCat: false) { + __typename + name + } + } + |] + + toJSON object `shouldBe` [aesonQQ| + { + "__typename": "UnionQuery", + "catOrDog": { + "__typename": "Dog", + "name": "Mortgage" + } + } + |] diff --git a/tests/Spec.hs b/tests/Spec.hs index d06857e..92925cb 100644 --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -8,6 +8,7 @@ import Test.Tasty (defaultMain, testGroup) import qualified ASTTests import qualified EndToEndTests +import qualified MutationTests import qualified OrderedMapTests import qualified ResolverTests import qualified SchemaTests @@ -24,6 +25,7 @@ main = do [ ASTTests.tests , EndToEndTests.tests , OrderedMapTests.tests + , MutationTests.tests , ResolverTests.tests , SchemaTests.tests , ValidationTests.tests diff --git a/tests/Utils.hs b/tests/Utils.hs new file mode 100644 index 0000000..a578efe --- /dev/null +++ b/tests/Utils.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Utils + ( json + , shouldBeJSON + ) where + +import Protolude hiding (diff) + +import Data.Aeson hiding (json) +import Data.Aeson.QQ (aesonQQ) +import Data.Aeson.Diff as Diff +import Data.Aeson.Pointer (formatPointer) +import qualified Data.ByteString.Lazy as LBS +import Data.String (IsString(..)) +import qualified Data.Text as T +import Language.Haskell.TH.Quote (QuasiQuoter ) +import Test.Tasty.Hspec (expectationFailure) + +import GraphQL.Internal.Name + +instance IsString (Maybe Name) where + fromString = either (const Nothing) Just . makeName . T.pack + +json :: QuasiQuoter +json = aesonQQ + +infixl 1 `shouldBeJSON` + +shouldBeJSON :: (ToJSON a, MonadIO m) => a -> Value -> m () +shouldBeJSON response js = + let response' = toJSON response + in liftIO $ unless (response' == js) $ do + let changes = map presentOperation $ patchOperations $ diff js response' + -- expectationFailure . show $ "Expected:\n" <> encode js <> "\nbut got:" <> encode response' + expectationFailure . show $ "JSON values do not match: " <> T.intercalate ", " changes + +presentOperation :: Diff.Operation -> Text +presentOperation (Add p v) = "add " <> formatPointer p <> " = " <> encodeText v +presentOperation (Rep p v) = "replace " <> formatPointer p <> " = " <> encodeText v +presentOperation (Rem p) = "remove " <> formatPointer p +presentOperation (Cpy p f) = "copy " <> formatPointer p <> "from " <> encodeText f +presentOperation (Mov p f) = "move " <> formatPointer p <> "from " <> encodeText f +presentOperation (Tst p v) = "test " <> formatPointer p <> " = " <> encodeText v + +encodeText :: ToJSON a => a -> Text +encodeText = decodeUtf8 . LBS.toStrict . encode \ No newline at end of file