diff --git a/HLint.hs b/HLint.hs index 80ef602..a92a5cd 100644 --- a/HLint.hs +++ b/HLint.hs @@ -3,3 +3,4 @@ import "hint" HLint.Generalise ignore "Use fmap" ignore "Redundant do" +ignore "Use =<<" diff --git a/graphql-wai/src/GraphQL/Wai.hs b/graphql-wai/src/GraphQL/Wai.hs index b7598bb..ade4d8f 100644 --- a/graphql-wai/src/GraphQL/Wai.hs +++ b/graphql-wai/src/GraphQL/Wai.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} +-- | Basic WAI handlers for graphql-api module GraphQL.Wai ( toApplication ) where @@ -9,6 +10,7 @@ module GraphQL.Wai import Protolude import GraphQL (interpretAnonymousQuery) +import GraphQL.API (HasObjectDefinition) import GraphQL.Resolver (HasResolver, Handler) import Network.Wai (Application, queryString, responseLBS) import GraphQL.Value.ToValue (toValue) @@ -23,7 +25,9 @@ import qualified Data.Aeson as Aeson -- -- If you have a 'Cat' type and a corresponding 'catHandler' then you -- can use "toApplication @Cat catHandler". -toApplication :: forall r. (HasResolver IO r) => Handler IO r -> Application +toApplication + :: forall r. (HasResolver IO r, HasObjectDefinition r) + => Handler IO r -> Application toApplication handler = app where app req respond = diff --git a/src/GraphQL.hs b/src/GraphQL.hs index 9c86e6f..cd6f27b 100644 --- a/src/GraphQL.hs +++ b/src/GraphQL.hs @@ -7,14 +7,19 @@ -- __Note__: This module is highly subject to change. We're still figuring -- where to draw the lines and what to expose. module GraphQL - ( QueryError + ( + -- * Running queries + interpretQuery + , interpretAnonymousQuery , Response(..) - , VariableValues - , Value + -- * Preparing queries then running them + , makeSchema , compileQuery , executeQuery - , interpretQuery - , interpretAnonymousQuery + , QueryError + , Schema + , VariableValues + , Value ) where import Protolude @@ -22,6 +27,7 @@ import Protolude import Data.Attoparsec.Text (parseOnly, endOfInput) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty +import GraphQL.API (HasObjectDefinition(..)) import GraphQL.Internal.Execution ( VariableValues , ExecutionError @@ -32,7 +38,7 @@ import qualified GraphQL.Internal.Syntax.AST as AST import qualified GraphQL.Internal.Syntax.Parser as Parser import GraphQL.Internal.Validation ( QueryDocument - , SelectionSet + , SelectionSetByType , ValidationErrors , validate , getSelectionSet @@ -40,12 +46,13 @@ import GraphQL.Internal.Validation ) import GraphQL.Internal.Output ( GraphQLError(..) - , Error(..) , Response(..) , singleError ) +import GraphQL.Internal.Schema (Schema) +import qualified GraphQL.Internal.Schema as Schema import GraphQL.Resolver (HasResolver(..), Result(..)) -import GraphQL.Value (Name, Value, pattern ValueObject) +import GraphQL.Value (Name, NameError, Value, pattern ValueObject) -- | Errors that can happen while processing a query document. data QueryError @@ -58,6 +65,8 @@ data QueryError | ValidationError ValidationErrors -- | Validated, but failed during execution. | ExecutionError ExecutionError + -- | Error in the schema. + | SchemaError NameError -- | Got a value that wasn't an object. | NonObjectResult Value deriving (Eq, Show) @@ -69,12 +78,14 @@ instance GraphQLError QueryError where "Validation errors:\n" <> mconcat [" " <> formatError e <> "\n" | e <- NonEmpty.toList es] formatError (ExecutionError e) = "Execution error: " <> show e + formatError (SchemaError e) = + "Schema error: " <> formatError e formatError (NonObjectResult v) = "Query returned a value that is not an object: " <> show v -- | Execute a GraphQL query. executeQuery - :: forall api m. (HasResolver m api, Applicative m) + :: forall api m. (HasResolver m api, Applicative m, HasObjectDefinition api) => 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". @@ -83,59 +94,59 @@ 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 operation + Right operation -> toResult <$> resolve @m @api handler (Just operation) where toResult (Result errors result) = case result of - -- TODO: Prevent this at compile time. + -- 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)) +-- | Create a GraphQL schema. +makeSchema :: forall api. HasObjectDefinition api => Either QueryError Schema +makeSchema = first SchemaError (Schema.makeSchema <$> getDefinition @api) + -- | Interpet a GraphQL query. -- -- Compiles then executes a GraphQL query. interpretQuery - :: forall api m. (Applicative m, HasResolver m api) + :: forall api m. (Applicative m, HasResolver m api, HasObjectDefinition api) => 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"@. -> VariableValues -- ^ Values for variables defined in the query document. A map of 'Variable' to 'Value'. -> m Response -- ^ The outcome of running the query. interpretQuery handler query name variables = - case parseQuery query of - Left err -> pure (PreExecutionFailure (Error err [] :| [])) - Right parsed -> - case validate parsed of - Left errs -> pure (PreExecutionFailure (map toError errs)) - Right document -> - executeQuery @api @m handler document name variables - + case makeSchema @api >>= flip compileQuery query of + Left err -> pure (PreExecutionFailure (toError err :| [])) + Right document -> executeQuery @api @m handler document name variables -- | Interpret an anonymous GraphQL query. -- -- Anonymous queries have no name and take no variables. interpretAnonymousQuery - :: forall api m. (Applicative m, HasResolver m api) + :: forall api m. (Applicative m, HasResolver m api, HasObjectDefinition api) => 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. interpretAnonymousQuery handler query = interpretQuery @api @m handler query Nothing mempty -- | Turn some text into a valid query document. -compileQuery :: Text -> Either QueryError (QueryDocument VariableValue) -compileQuery query = do +compileQuery :: Schema -> Text -> Either QueryError (QueryDocument VariableValue) +compileQuery schema query = do parsed <- first ParseError (parseQuery query) - first ValidationError (validate parsed) + first ValidationError (validate schema parsed) -- | Parse a query document. 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 (SelectionSet Value) +getOperation :: QueryDocument VariableValue -> Maybe Name -> VariableValues -> Either QueryError (SelectionSetByType Value) getOperation document name vars = first ExecutionError $ do op <- Execution.getOperation document name resolved <- substituteVariables op vars diff --git a/src/GraphQL/Internal/OrderedMap.hs b/src/GraphQL/Internal/OrderedMap.hs index 994f2a7..a4a036b 100644 --- a/src/GraphQL/Internal/OrderedMap.hs +++ b/src/GraphQL/Internal/OrderedMap.hs @@ -36,9 +36,15 @@ module GraphQL.Internal.OrderedMap , orderedMap -- * Querying , lookup + -- * Filtering + , GraphQL.Internal.OrderedMap.catMaybes -- * Combine -- ** Union , unions + , unionWith + , unionsWith + , unionWithM + , unionsWithM -- * Conversion , toList , toMap @@ -69,7 +75,7 @@ data OrderedMap key value -- -- /O(n log n)/ toList :: forall key value. Ord key => OrderedMap key value -> [(key, value)] -toList (OrderedMap keys entries) = catMaybes (foreach keys $ \k -> (,) k <$> Map.lookup k entries) +toList (OrderedMap keys entries) = Protolude.catMaybes (foreach keys $ \k -> (,) k <$> Map.lookup k entries) instance Foldable (OrderedMap key) where foldr f z (OrderedMap _ entries) = foldr f z entries @@ -120,6 +126,61 @@ values = map snd . toList unions :: forall key value. Ord key => [OrderedMap key value] -> Maybe (OrderedMap key value) unions orderedMaps = orderedMap (orderedMaps >>= toList) +-- | Append the second ordered map to the first, combining any shared elements +-- with the given function. +unionWith :: Ord key + => (value -> value -> value) + -> OrderedMap key value + -> OrderedMap key value + -> OrderedMap key value +unionWith f x y = + OrderedMap + { toMap = Map.unionWith f (toMap x) (toMap y) + , keys = keys x <> [k | k <- keys y, k `Map.notMember` toMap x] + } + +-- | Append together a list of ordered maps, preserving ordering of keys. +-- Combine any shared elements with the given function. +unionsWith :: Ord key + => (value -> value -> value) + -> [OrderedMap key value] + -> OrderedMap key value +unionsWith f = foldl' (unionWith f) empty + +-- | Take two ordered maps, append the second one to the first. If the second +-- contains any keys that also appear in the first, combine the two values +-- with the given function. +unionWithM :: (Monad m, Ord key) + => (value -> value -> m value) + -> OrderedMap key value + -> OrderedMap key value + -> m (OrderedMap key value) +unionWithM f x y = sequenceA (unionWith (liftMM f) (map pure x) (map pure y)) + +-- | Take a list of ordered maps and append them together. Any shared elements +-- are combined using the given function. +unionsWithM :: (Monad m, Ord key) + => (value -> value -> m value) + -> [OrderedMap key value] + -> m (OrderedMap key value) +unionsWithM f xs = sequenceA (unionsWith (liftMM f) (map (map pure) xs)) + +liftMM :: Monad m => (a -> b -> m c) -> m a -> m b -> m c +liftMM f a' b' = do + (a, b) <- (,) <$> a' <*> b' + f a b + +-- | Take an ordered map with 'Maybe' values and return the same map with all +-- the 'Nothing' values removed. +catMaybes :: Ord key => OrderedMap key (Maybe value) -> OrderedMap key value +catMaybes xs = + OrderedMap + { keys = [ k | k <- keys xs, k `Map.member` newMap ] + , toMap = newMap + } + where + newMap = Map.mapMaybe identity (toMap xs) + -- | Construct an ordered map from a list. -- -- /O(n log n)/. diff --git a/src/GraphQL/Internal/Schema.hs b/src/GraphQL/Internal/Schema.hs index 9408383..6f4190e 100644 --- a/src/GraphQL/Internal/Schema.hs +++ b/src/GraphQL/Internal/Schema.hs @@ -32,28 +32,79 @@ module GraphQL.Internal.Schema , AnnotatedType(..) , ListType(..) , NonNullType(..) + , DefinesTypes(..) + , doesFragmentTypeApply + -- * The schema + , Schema + , makeSchema + , lookupType ) where import Protolude hiding (Type) +import qualified Data.Map as Map import GraphQL.Value (Value) import GraphQL.Internal.Name (HasName(..), Name, unsafeMakeName) +-- | An entire GraphQL schema. +-- +-- This is very much a work in progress. Currently, the only thing we provide +-- is a dictionary mapping type names to their definitions. +newtype Schema = Schema (Map Name TypeDefinition) deriving (Eq, Ord, Show) + +-- | Create a schema from the root object. +-- +-- This is technically an insufficient API, since not all types in a schema +-- need to be reachable from a single root object. However, it's a start. +makeSchema :: ObjectTypeDefinition -> Schema +makeSchema = Schema . getDefinedTypes + +-- | 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, Show) +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@ + -- + -- TODO: This ignores whether a value can define multiple types with the + -- same name, and further admits the possibility that the name embedded in + -- the type definition does not match the name in the returned dictionary. + -- jml would like to have a schema validation phase that eliminates one or + -- both of these possibilities. + -- + -- Also pretty much works because we've inlined all our type definitions. + getDefinedTypes :: t -> Map Name TypeDefinition data AnnotatedType t = TypeNamed t | TypeList (ListType t) | TypeNonNull (NonNullType t) - deriving (Eq,Show) + deriving (Eq, Ord, Show) -newtype ListType t = ListType (AnnotatedType t) deriving (Eq, Show) +-- | Get the type that is being annotated. +getAnnotatedType :: AnnotatedType t -> t +getAnnotatedType (TypeNamed t) = t +getAnnotatedType (TypeList (ListType t)) = getAnnotatedType t +getAnnotatedType (TypeNonNull (NonNullTypeNamed t)) = t +getAnnotatedType (TypeNonNull (NonNullTypeList (ListType t))) = getAnnotatedType t + +instance HasName t => HasName (AnnotatedType t) where + getName = getName . getAnnotatedType + +newtype ListType t = ListType (AnnotatedType t) deriving (Eq, Ord, Show) data NonNullType t = NonNullTypeNamed t | NonNullTypeList (ListType t) - deriving (Eq,Show) + deriving (Eq, Ord, Show) + +data Type = DefinedType TypeDefinition | BuiltinType Builtin deriving (Eq, Ord, Show) -data Type = DefinedType TypeDefinition | BuiltinType Builtin deriving (Eq, Show) +instance DefinesTypes Type where + getDefinedTypes (BuiltinType _) = mempty + getDefinedTypes (DefinedType t) = getDefinedTypes t instance HasName Type where getName (DefinedType x) = getName x @@ -66,7 +117,7 @@ data TypeDefinition = TypeDefinitionObject ObjectTypeDefinition | TypeDefinitionEnum EnumTypeDefinition | TypeDefinitionInputObject InputObjectTypeDefinition | TypeDefinitionTypeExtension TypeExtensionDefinition - deriving (Eq, Show) + deriving (Eq, Ord, Show) instance HasName TypeDefinition where getName (TypeDefinitionObject x) = getName x @@ -77,44 +128,76 @@ instance HasName TypeDefinition where getName (TypeDefinitionInputObject x) = getName x getName (TypeDefinitionTypeExtension x) = getName x +instance DefinesTypes TypeDefinition where + getDefinedTypes defn = + case defn of + TypeDefinitionObject x -> getDefinedTypes x + TypeDefinitionInterface x -> getDefinedTypes x + TypeDefinitionUnion x -> getDefinedTypes x + TypeDefinitionScalar x -> getDefinedTypes x + TypeDefinitionEnum x -> getDefinedTypes x + TypeDefinitionInputObject _ -> mempty + TypeDefinitionTypeExtension _ -> + panic "TODO: we should remove the 'extend' behaviour entirely" + data ObjectTypeDefinition = ObjectTypeDefinition Name Interfaces (NonEmptyList FieldDefinition) - deriving (Eq, Show) + deriving (Eq, Ord, Show) instance HasName ObjectTypeDefinition where getName (ObjectTypeDefinition name _ _) = name +instance DefinesTypes ObjectTypeDefinition where + getDefinedTypes obj@(ObjectTypeDefinition name interfaces fields) = + Map.singleton name (TypeDefinitionObject obj) <> + foldMap getDefinedTypes interfaces <> + foldMap getDefinedTypes fields + type Interfaces = [InterfaceTypeDefinition] data FieldDefinition = FieldDefinition Name [ArgumentDefinition] (AnnotatedType Type) - deriving (Eq, Show) + deriving (Eq, Ord, Show) instance HasName FieldDefinition where getName (FieldDefinition name _ _) = name +instance DefinesTypes FieldDefinition where + getDefinedTypes (FieldDefinition _ _ retVal) = getDefinedTypes (getAnnotatedType retVal) + data ArgumentDefinition = ArgumentDefinition Name (AnnotatedType InputType) (Maybe DefaultValue) - deriving (Eq, Show) + deriving (Eq, Ord, Show) instance HasName ArgumentDefinition where getName (ArgumentDefinition name _ _) = name data InterfaceTypeDefinition = InterfaceTypeDefinition Name (NonEmptyList FieldDefinition) - deriving (Eq, Show) + deriving (Eq, Ord, Show) instance HasName InterfaceTypeDefinition where getName (InterfaceTypeDefinition name _) = name +instance DefinesTypes InterfaceTypeDefinition where + getDefinedTypes i@(InterfaceTypeDefinition name fields) = Map.singleton name (TypeDefinitionInterface i) <> foldMap getDefinedTypes fields + data UnionTypeDefinition = UnionTypeDefinition Name (NonEmptyList ObjectTypeDefinition) - deriving (Eq, Show) + deriving (Eq, Ord, Show) instance HasName UnionTypeDefinition where getName (UnionTypeDefinition name _) = name +instance DefinesTypes UnionTypeDefinition where + getDefinedTypes defn@(UnionTypeDefinition name objs) = + Map.singleton name (TypeDefinitionUnion defn) <> + foldMap getDefinedTypes objs + newtype ScalarTypeDefinition = ScalarTypeDefinition Name - deriving (Eq, Show) + deriving (Eq, Ord, Show) instance HasName ScalarTypeDefinition where getName (ScalarTypeDefinition name) = name +instance DefinesTypes ScalarTypeDefinition where + getDefinedTypes defn = Map.singleton (getName defn) (TypeDefinitionScalar defn) + -- | Types that are built into GraphQL. -- -- The GraphQL spec refers to these as @@ -129,7 +212,7 @@ data Builtin -- | Signed double‐precision fractional values as specified by [IEEE 754](https://en.wikipedia.org/wiki/IEEE_floating_point) | GFloat -- | A unique identifier, often used to refetch an object or as the key for a cache - | GID deriving (Eq, Show) + | GID deriving (Eq, Ord, Show) instance HasName Builtin where getName = unsafeMakeName . getBuiltinName @@ -141,36 +224,39 @@ instance HasName Builtin where getBuiltinName GID = "ID" data EnumTypeDefinition = EnumTypeDefinition Name [EnumValueDefinition] - deriving (Eq, Show) + deriving (Eq, Ord, Show) instance HasName EnumTypeDefinition where getName (EnumTypeDefinition name _) = name +instance DefinesTypes EnumTypeDefinition where + getDefinedTypes enum = Map.singleton (getName enum) (TypeDefinitionEnum enum) + newtype EnumValueDefinition = EnumValueDefinition Name - deriving (Eq, Show) + deriving (Eq, Ord, Show) instance HasName EnumValueDefinition where getName (EnumValueDefinition name) = name data InputObjectTypeDefinition = InputObjectTypeDefinition Name (NonEmptyList InputObjectFieldDefinition) - deriving (Eq, Show) + deriving (Eq, Ord, Show) instance HasName InputObjectTypeDefinition where getName (InputObjectTypeDefinition name _) = name data InputObjectFieldDefinition = InputObjectFieldDefinition Name (AnnotatedType InputType) (Maybe DefaultValue) - deriving (Eq, Show) -- XXX: spec is unclear about default value for input object field definitions + deriving (Eq, Ord, Show) -- XXX: spec is unclear about default value for input object field definitions instance HasName InputObjectFieldDefinition where getName (InputObjectFieldDefinition name _ _) = name newtype TypeExtensionDefinition = TypeExtensionDefinition ObjectTypeDefinition - deriving (Eq, Show) + deriving (Eq, Ord, Show) instance HasName TypeExtensionDefinition where getName (TypeExtensionDefinition obj) = getName obj -data InputType = DefinedInputType InputTypeDefinition | BuiltinInputType Builtin deriving (Eq, Show) +data InputType = DefinedInputType InputTypeDefinition | BuiltinInputType Builtin deriving (Eq, Ord, Show) instance HasName InputType where getName (DefinedInputType x) = getName x @@ -180,7 +266,7 @@ data InputTypeDefinition = InputTypeDefinitionObject InputObjectTypeDefinition | InputTypeDefinitionScalar ScalarTypeDefinition | InputTypeDefinitionEnum EnumTypeDefinition - deriving (Eq, Show) + deriving (Eq, Ord, Show) instance HasName InputTypeDefinition where getName (InputTypeDefinitionObject x) = getName x @@ -196,3 +282,28 @@ instance HasName InputTypeDefinition where -- 'InputObjectFieldDefinition') can have default values. These are allowed to -- be any kind of literal. type DefaultValue = Value + + +-- | Does the given object type match the given type condition. +-- +-- See +-- +-- @ +-- DoesFragmentTypeApply(objectType, fragmentType) +-- If fragmentType is an Object Type: +-- if objectType and fragmentType are the same type, return true, otherwise return false. +-- If fragmentType is an Interface Type: +-- if objectType is an implementation of fragmentType, return true otherwise return false. +-- If fragmentType is a Union: +-- if objectType is a possible type of fragmentType, return true otherwise return false. +-- @ +doesFragmentTypeApply :: ObjectTypeDefinition -> TypeDefinition -> Bool +doesFragmentTypeApply objectType fragmentType = + case fragmentType of + TypeDefinitionObject obj -> obj == objectType + TypeDefinitionInterface interface -> objectType `implements` interface + TypeDefinitionUnion union -> objectType `branchOf` union + _ -> False + where + implements (ObjectTypeDefinition _ interfaces _) int = int `elem` interfaces + branchOf obj (UnionTypeDefinition _ (NonEmptyList branches)) = obj `elem` branches diff --git a/src/GraphQL/Internal/Syntax/AST.hs b/src/GraphQL/Internal/Syntax/AST.hs index 6b1ac05..b7925ca 100644 --- a/src/GraphQL/Internal/Syntax/AST.hs +++ b/src/GraphQL/Internal/Syntax/AST.hs @@ -1,6 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/src/GraphQL/Internal/Validation.hs b/src/GraphQL/Internal/Validation.hs index 14d7834..a07d12c 100644 --- a/src/GraphQL/Internal/Validation.hs +++ b/src/GraphQL/Internal/Validation.hs @@ -15,10 +15,6 @@ -- type-level validation, as we attempt to defer all of that to the Haskell -- type checker. -- --- Still missing: --- --- * field selection merging --- -- Deliberately not going to do: -- -- * field selections on compound types @@ -39,27 +35,25 @@ module GraphQL.Internal.Validation ( ValidationError(..) , ValidationErrors , QueryDocument(..) - , Selection'(..) -- TODO, can we hide this again? - , Selection - , InlineFragment(..) , validate , getErrors -- * Operating on validated documents , Operation - , getVariableDefinitions , getSelectionSet - , VariableDefinitions + -- * Executing validated documents , VariableDefinition(..) - , AST.Type(..) + , VariableValue , Variable - , SelectionSet - , getFields + , AST.Type(..) + -- * Resolving queries + , SelectionSetByType + , SelectionSet(..) + , getSelectionSetForType , Field - , getFieldSelectionSet - , getResponseKey - , FragmentSpread , lookupArgument - , VariableValue + , getSubSelectionSet + , ResponseKey + , getResponseKey -- * Exported for testing , findDuplicates ) where @@ -74,8 +68,17 @@ import GraphQL.Internal.Name (HasName(..), Name) import qualified GraphQL.Internal.Syntax.AST as AST -- Directly import things from the AST that do not need validation, so that -- @AST.Foo@ in a type signature implies that something hasn't been validated. -import GraphQL.Internal.Syntax.AST (Alias, TypeCondition, Variable) +import GraphQL.Internal.Syntax.AST (Alias, Variable, NamedType(..)) +import GraphQL.Internal.OrderedMap (OrderedMap) +import qualified GraphQL.Internal.OrderedMap as OrderedMap import GraphQL.Internal.Output (GraphQLError(..)) +import GraphQL.Internal.Schema + ( TypeDefinition + , ObjectTypeDefinition + , Schema + , doesFragmentTypeApply + , lookupType + ) import GraphQL.Value ( Value , Value' @@ -95,65 +98,52 @@ data QueryDocument value deriving (Eq, Show) data Operation value - = Query VariableDefinitions (Directives value) (SelectionSet value) - | Mutation VariableDefinitions (Directives value) (SelectionSet value) + = Query VariableDefinitions (Directives value) (SelectionSetByType value) + | Mutation VariableDefinitions (Directives value) (SelectionSetByType value) deriving (Eq, Show) instance Functor Operation where - fmap f (Query vars directives selectionSet) = Query vars (fmap f directives) (map (fmap f) selectionSet) - fmap f (Mutation vars directives selectionSet) = Mutation vars (fmap f directives) (map (fmap f) selectionSet) + 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) instance Foldable Operation where - foldMap f (Query _ directives selectionSet) = foldMap f directives `mappend` mconcat (map (foldMap f) selectionSet) - foldMap f (Mutation _ directives selectionSet) = foldMap f directives `mappend` mconcat (map (foldMap f) selectionSet) + foldMap f (Query _ directives selectionSet) = foldMap f directives `mappend` foldMap f selectionSet + foldMap f (Mutation _ 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 (traverse f) selectionSet - traverse f (Mutation vars directives selectionSet) = Mutation vars <$> traverse f directives <*> traverse (traverse f) selectionSet - - --- | Get the variable definitions for an operation. -getVariableDefinitions :: Operation value -> VariableDefinitions -getVariableDefinitions (Query vars _ _) = vars -getVariableDefinitions (Mutation vars _ _) = vars + 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 -- | Get the selection set for an operation. --- --- TODO: This doesn't return the *actual* selection set we need, because it --- hasn't substituted variables or applied directives. -getSelectionSet :: Operation value -> SelectionSet value +getSelectionSet :: Operation value -> SelectionSetByType value getSelectionSet (Query _ _ ss) = ss getSelectionSet (Mutation _ _ ss) = ss -- | Type alias for 'Query' and 'Mutation' constructors of 'Operation'. -type OperationType value = VariableDefinitions -> Directives value -> SelectionSet value -> Operation value +type OperationType value = VariableDefinitions -> Directives value -> SelectionSetByType value -> Operation value type Operations value = Map Name (Operation value) -type SelectionSet value = [Selection value] - -type Selection value = Selection' FragmentSpread value - -- | Turn a parsed document into a known valid one. -- -- The document is known to be syntactically valid, as we've got its AST. -- Here, we confirm that it's semantically valid (modulo types). -validate :: AST.QueryDocument -> Either (NonEmpty ValidationError) (QueryDocument VariableValue) -validate (AST.QueryDocument defns) = runValidator $ do +validate :: Schema -> AST.QueryDocument -> Either (NonEmpty ValidationError) (QueryDocument VariableValue) +validate schema (AST.QueryDocument defns) = runValidator $ do let (operations, fragments) = splitBy splitDefns defns let (anonymous, named) = splitBy splitOps operations - (frags, visitedFrags) <- resolveFragmentDefinitions =<< validateFragmentDefinitions fragments + (frags, visitedFrags) <- resolveFragmentDefinitions =<< validateFragmentDefinitions schema fragments case (anonymous, named) of ([], ops) -> do - (validOps, usedFrags) <- runStateT (validateOperations frags ops) mempty + (validOps, usedFrags) <- runStateT (validateOperations schema frags ops) mempty assertAllFragmentsUsed frags (visitedFrags <> usedFrags) resolvedOps <- traverse validateOperation validOps pure (MultipleOperations resolvedOps) ([x], []) -> do - (ss, usedFrags) <- runStateT (validateSelectionSet frags x) mempty + (ss, usedFrags) <- runStateT (validateSelectionSet schema frags x) mempty assertAllFragmentsUsed frags (visitedFrags <> usedFrags) - validValuesSS <- traverse validateValues ss - resolvedValuesSS <- traverse (resolveVariables emptyVariableDefinitions) validValuesSS + validValuesSS <- validateValues ss + resolvedValuesSS <- resolveVariables emptyVariableDefinitions validValuesSS pure (LoneAnonymousOperation (Query emptyVariableDefinitions emptyDirectives resolvedValuesSS)) _ -> throwE (MixedAnonymousOperations (length anonymous) (map fst named)) @@ -175,22 +165,22 @@ validate (AST.QueryDocument defns) = runValidator $ do -- * Operations -validateOperations :: Fragments AST.Value -> [(Name, (OperationType AST.Value, AST.Node))] -> StateT (Set Name) Validation (Operations AST.Value) -validateOperations fragments ops = do +validateOperations :: Schema -> Fragments AST.Value -> [(Name, (OperationType AST.Value, AST.Node))] -> StateT (Set 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) <*> lift (validateDirectives directives) - <*> validateSelectionSet fragments ss + <*> 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 <*> traverse validateValues selectionSet + 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 @@ -199,7 +189,7 @@ validateOperation (Query vars directives selectionSet) = do unless (Set.null unusedVariables) $ throwE (UnusedVariables unusedVariables) resolveVariables vars validValues validateOperation (Mutation vars directives selectionSet) = do - validValues <- Mutation vars <$> validateValues directives <*> traverse validateValues selectionSet + validValues <- Mutation 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 @@ -208,18 +198,158 @@ validateOperation (Mutation vars directives selectionSet) = do unless (Set.null unusedVariables) $ throwE (UnusedVariables unusedVariables) resolveVariables vars validValues --- * Arguments --- | The set of arguments for a given field, directive, etc. +-- * Selection sets + +-- https://facebook.github.io/graphql/#sec-Field-Selection-Merging +-- https://facebook.github.io/graphql/#sec-Executing-Selection-Sets +-- 1. the selection set is turned into a grouped field set; +-- 2. each represented field in the grouped field set produces an entry into +-- a response map. +-- https://facebook.github.io/graphql/#sec-Field-Collection + + +-- | Resolve all the fragments in a selection set and make sure the names, +-- arguments, and directives are all valid. -- --- Note that the 'value' can be a variable. -newtype Arguments value = Arguments (Map Name value) deriving (Eq, Show, Functor, Foldable, Traversable) +-- Runs in 'StateT', collecting a set of names of 'FragmentDefinition' that +-- have been used by this selection set. +-- +-- We do this /before/ validating the values (since that's much easier once +-- everything is in a nice structure and away from the AST), which means we +-- can't yet evaluate directives. +validateSelectionSet :: Schema -> Fragments AST.Value -> [AST.Selection] -> StateT (Set Name) Validation (SelectionSetByType AST.Value) +validateSelectionSet schema fragments selections = do + unresolved <- lift $ traverse (validateSelection schema) selections + resolved <- traverse (resolveSelection fragments) unresolved + lift $ groupByResponseKey resolved --- | Turn a set of arguments from the AST into a guaranteed unique set of arguments. +-- | A selection set, almost fully validated. -- --- -validateArguments :: [AST.Argument] -> Validation (Arguments AST.Value) -validateArguments args = Arguments <$> mapErrors DuplicateArgument (makeMap [(name, value) | AST.Argument name value <- args]) +-- Sub-selection sets might not be validated. +newtype SelectionSet value = SelectionSet (OrderedMap ResponseKey (Field value)) deriving (Eq, Ord, Show) + +newtype SelectionSetByType value + = SelectionSetByType (OrderedMap ResponseKey (OrderedMap (Set TypeDefinition) (Field value))) + deriving (Eq, Ord, Show, Functor, Foldable, Traversable) + +-- | A 'ResponseKey' is the key under which a field appears in a response. If +-- there's an alias, it's the alias, if not, it's the field name. +type ResponseKey = Name + +-- | A field ready to be resolved. +data Field value + = Field + { name :: Name + , arguments :: Arguments value + , subSelectionSet :: Maybe (SelectionSetByType value) + } deriving (Eq, Ord, Show, Functor, Foldable, Traversable) + +instance HasName (Field value) where + getName = name + +-- | Get the value of an argument in a field. +lookupArgument :: Field value -> Name -> Maybe value +lookupArgument (Field _ (Arguments args) _) name = Map.lookup name args + +-- | Get the selection set within a field. +getSubSelectionSet :: Field value -> Maybe (SelectionSetByType value) +getSubSelectionSet = subSelectionSet + +-- | Merge two execution fields. Assumes that they are fields for the same +-- response key on the same type (i.e. that they are fields we would actually +-- rationally want to merge). +mergeFields :: Eq value => Field value -> Field value -> Validation (Field value) +mergeFields field1 field2 = do + unless (name field1 == name field2) $ throwE (MismatchedNames (name field1) (name field2)) + unless (arguments field1 == arguments field2) $ throwE (MismatchedArguments (name field1)) + case (subSelectionSet field1, subSelectionSet field2) of + (Nothing, Nothing) -> + pure Field { name = name field1 + , arguments = arguments field1 + , subSelectionSet = Nothing + } + (Just ss1, Just ss2) -> do + mergedSet <- mergeSelectionSets ss1 ss2 + pure Field { name = name field1 + , arguments = arguments field1 + , subSelectionSet = Just mergedSet + } + _ -> throwE (IncompatibleFields (name field1)) + + where + mergeSelectionSets :: Eq value + => SelectionSetByType value + -> SelectionSetByType value + -> Validation (SelectionSetByType value) + mergeSelectionSets (SelectionSetByType ss1) (SelectionSetByType ss2) = + SelectionSetByType <$> OrderedMap.unionWithM (OrderedMap.unionWithM mergeFields) ss1 ss2 + +-- | Once we know the GraphQL type of the object that a selection set (i.e. a +-- 'SelectionSetByType') is for, we can eliminate all the irrelevant types and +-- present a single, flattened map of 'ResponseKey' to 'Field'. +getSelectionSetForType + :: Eq value + => ObjectTypeDefinition -- ^ The type of the object that the selection set is for + -> SelectionSetByType value -- ^ A selection set with type conditions, obtained from the validation process + -> Either ValidationErrors (SelectionSet value) -- ^ A flattened + -- selection set without type conditions. It's possible that some of the + -- fields in various types are not mergeable, in which case, we'll return a + -- validation error. +getSelectionSetForType objectType (SelectionSetByType ss) = runValidator $ + SelectionSet . OrderedMap.catMaybes <$> traverse mergeFieldsForType ss + where + mergeFieldsForType fieldMap = do + let matching = filter (satisfiesType . fst) (OrderedMap.toList fieldMap) + case map snd matching of + [] -> pure Nothing + x:xs -> Just <$> foldlM mergeFields x xs + + satisfiesType = all (doesFragmentTypeApply objectType) . Set.toList + + +-- | Flatten the selection and group it by response key and then type +-- conditions. +-- +-- Doesn't do any validation at all. Just provides a list of "execution +-- values" which are the possible things that might be executed, depending on +-- the type. +-- +-- XXX: This is so incredibly complex. No doubt there's a way to simplify, but +-- jml can't see it right now. +groupByResponseKey :: Eq value => [Selection' FragmentSpread value] -> Validation (SelectionSetByType value) +groupByResponseKey selectionSet = SelectionSetByType <$> + flattenSelectionSet mempty selectionSet + where + -- | Given a currently "active" type condition, and a single selection, + -- return a map of response keys to validated fields, grouped by types: + -- essentially a SelectionSetByType without the wrapping + -- constructor. + -- + -- The "active" type condition is the type condition of the selection set + -- that contains the selection. + byKey :: Eq value + => Set TypeDefinition + -> Selection' FragmentSpread value + -> Validation (OrderedMap ResponseKey (OrderedMap (Set TypeDefinition) (Field value))) + byKey typeConds (SelectionField field@(Field' _ name arguments _ ss)) + = case ss of + [] -> pure $ OrderedMap.singleton (getResponseKey field) . OrderedMap.singleton typeConds . Field name arguments $ Nothing + _ -> OrderedMap.singleton (getResponseKey field) . OrderedMap.singleton typeConds . Field name arguments . Just <$> groupByResponseKey ss + byKey typeConds (SelectionFragmentSpread (FragmentSpread _ _ (FragmentDefinition _ typeCond _ ss))) + = flattenSelectionSet (typeConds <> Set.singleton typeCond) ss + byKey typeConds (SelectionInlineFragment (InlineFragment (Just typeCond) _ ss)) + = flattenSelectionSet (typeConds <> Set.singleton typeCond) ss + byKey typeConds (SelectionInlineFragment (InlineFragment Nothing _ ss)) + = flattenSelectionSet typeConds ss + + flattenSelectionSet :: Eq value + => Set TypeDefinition + -> [Selection' FragmentSpread value] + -> Validation (OrderedMap ResponseKey (OrderedMap (Set TypeDefinition) (Field value))) + flattenSelectionSet typeConds ss = do + groupedByKey <- traverse (byKey typeConds) ss + OrderedMap.unionsWithM (OrderedMap.unionWithM mergeFields) groupedByKey -- * Selections @@ -251,17 +381,6 @@ data Selection' (spread :: * -> *) value | SelectionInlineFragment (InlineFragment spread value) deriving (Eq, Show, Functor, Foldable, Traversable) --- | Get all of the fields directly inside the given selection set. --- --- TODO: This ignores fragments, whereas it should actually do something with --- them. --- --- TODO: At this point, we ought to know that field names are unique. As such, --- we should return an ordered map of Name to Fields, rather than a bland --- list. -getFields :: SelectionSet value -> [Field value] -getFields ss = [field | SelectionField field <- ss] - -- | A field in a selection set, which itself might have children which might -- have fragment spreads. data Field' spread value @@ -274,7 +393,7 @@ data Field' spread value -- otherwise the field’s name.\" -- -- -getResponseKey :: Field' spread value -> Name +getResponseKey :: Field' spread value -> ResponseKey getResponseKey (Field' alias name _ _ _) = fromMaybe name alias instance HasName (Field' spread value) where @@ -297,16 +416,6 @@ instance Traversable spread => Traversable (Field' spread) where <*> traverse f directives <*> traverse (traverse f) selectionSet -type Field value = Field' FragmentSpread value - --- | Get the value of an argument in a field. -lookupArgument :: Field value -> Name -> Maybe value -lookupArgument (Field' _ _ (Arguments args) _ _) name = Map.lookup name args - --- | Get the selection set within a field. -getFieldSelectionSet :: Field' spread value -> [Selection' spread value] -getFieldSelectionSet (Field' _ _ _ _ ss) = ss - -- | A fragment spread that has a valid set of directives, but may or may not -- refer to a fragment that actually exists. data UnresolvedFragmentSpread value @@ -336,20 +445,20 @@ instance Traversable FragmentSpread where -- | An inline fragment, which itself can contain fragment spreads. data InlineFragment spread value - = InlineFragment (Maybe TypeCondition) (Directives value) [Selection' spread value] + = InlineFragment (Maybe TypeDefinition) (Directives value) [Selection' spread value] deriving (Eq, Show) instance Functor spread => Functor (InlineFragment spread) where - fmap f (InlineFragment typeCond directives selectionSet) = - InlineFragment typeCond (fmap f directives) (map (fmap f) selectionSet) + fmap f (InlineFragment typeDefn directives selectionSet) = + InlineFragment typeDefn (fmap f directives) (map (fmap f) selectionSet) instance Foldable spread => Foldable (InlineFragment spread) where foldMap f (InlineFragment _ directives selectionSet) = foldMap f directives `mappend` mconcat (map (foldMap f) selectionSet) instance Traversable spread => Traversable (InlineFragment spread) where - traverse f (InlineFragment typeCond directives selectionSet) = - InlineFragment typeCond <$> traverse f directives + traverse f (InlineFragment typeDefn directives selectionSet) = + InlineFragment typeDefn <$> traverse f directives <*> traverse (traverse f) selectionSet -- | Traverse through every fragment spread in a selection. @@ -374,17 +483,25 @@ traverseFragmentSpreads f selection = childSegments = traverse (traverseFragmentSpreads f) -- | Ensure a selection has valid arguments and directives. -validateSelection :: AST.Selection -> Validation (Selection' UnresolvedFragmentSpread AST.Value) -validateSelection selection = +validateSelection :: Schema -> AST.Selection -> Validation (Selection' UnresolvedFragmentSpread AST.Value) +validateSelection schema selection = case selection of AST.SelectionField (AST.Field alias name args directives ss) -> - SelectionField <$> (Field' alias name <$> validateArguments args <*> validateDirectives directives <*> childSegments ss) + SelectionField <$> (Field' alias name + <$> validateArguments args + <*> validateDirectives directives + <*> childSegments ss) AST.SelectionFragmentSpread (AST.FragmentSpread name directives) -> SelectionFragmentSpread <$> (UnresolvedFragmentSpread name <$> validateDirectives directives) AST.SelectionInlineFragment (AST.InlineFragment typeCond directives ss) -> - SelectionInlineFragment <$> (InlineFragment typeCond <$> validateDirectives directives <*> childSegments ss) + SelectionInlineFragment <$> (InlineFragment -- TODO: fix the case statement + <$> (case typeCond of + Nothing -> pure Nothing + Just tC -> Just <$> validateTypeCondition schema tC) + <*> validateDirectives directives + <*> childSegments ss) where - childSegments = traverse validateSelection + childSegments = traverse (validateSelection schema) -- | Resolve the fragment references in a selection, accumulating a set of -- the fragment names that we have resolved. @@ -402,13 +519,6 @@ resolveSelection fragments = traverseFragmentSpreads resolveFragmentSpread modify (Set.insert name) pure (FragmentSpread name directive fragment) -validateSelectionSet :: Fragments AST.Value -> [AST.Selection] -> StateT (Set Name) Validation (SelectionSet AST.Value) -validateSelectionSet fragments selections = do - unresolved <- lift (traverse validateSelection selections) - resolved <- traverse (resolveSelection fragments) unresolved - -- TODO: Check that the fields are mergable. - pure resolved - -- * Fragment definitions -- | A validated fragment definition. @@ -416,35 +526,45 @@ validateSelectionSet fragments selections = do -- @spread@ indicates whether references to other fragment definitions have -- been resolved. data FragmentDefinition spread value - = FragmentDefinition Name TypeCondition (Directives value) [Selection' spread value] + = FragmentDefinition Name TypeDefinition (Directives value) [Selection' spread value] deriving (Eq, Show) type Fragments value = Map Name (FragmentDefinition FragmentSpread value) instance Functor spread => Functor (FragmentDefinition spread) where - fmap f (FragmentDefinition name typeCond directives selectionSet) = - FragmentDefinition name typeCond (fmap f directives) (map (fmap f) selectionSet) + fmap f (FragmentDefinition name typeDefn directives selectionSet) = + FragmentDefinition name typeDefn (fmap f directives) (map (fmap f) selectionSet) instance Foldable spread => Foldable (FragmentDefinition spread) where foldMap f (FragmentDefinition _ _ directives selectionSet) = foldMap f directives `mappend` mconcat (map (foldMap f) selectionSet) instance Traversable spread => Traversable (FragmentDefinition spread) where - traverse f (FragmentDefinition name typeCond directives selectionSet) = - FragmentDefinition name typeCond <$> traverse f directives + traverse f (FragmentDefinition name typeDefn directives selectionSet) = + FragmentDefinition name typeDefn <$> traverse f directives <*> traverse (traverse f) selectionSet -- | Ensure fragment definitions are uniquely named, and that their arguments -- and directives are sane. -- -- -validateFragmentDefinitions :: [AST.FragmentDefinition] -> Validation (Map Name (FragmentDefinition UnresolvedFragmentSpread AST.Value)) -validateFragmentDefinitions frags = do +validateFragmentDefinitions :: Schema -> [AST.FragmentDefinition] -> Validation (Map Name (FragmentDefinition UnresolvedFragmentSpread AST.Value)) +validateFragmentDefinitions schema frags = do defns <- traverse validateFragmentDefinition frags mapErrors DuplicateFragmentDefinition (makeMap [(name, value) | value@(FragmentDefinition name _ _ _) <- defns]) where - validateFragmentDefinition (AST.FragmentDefinition name cond directives ss) = - FragmentDefinition name cond <$> validateDirectives directives <*> traverse validateSelection ss + validateFragmentDefinition (AST.FragmentDefinition name typeCond directives ss) = do + FragmentDefinition name + <$> validateTypeCondition schema typeCond + <*> validateDirectives directives + <*> traverse (validateSelection schema) ss + +-- | Validate a type condition that appears in a query. +validateTypeCondition :: Schema -> AST.TypeCondition -> Validation TypeDefinition +validateTypeCondition schema (NamedType typeCond) = + case lookupType schema typeCond of + Nothing -> throwE (TypeConditionNotFound typeCond) + Just typeDefn -> pure typeDefn -- | Resolve all references to fragments inside fragment definitions. -- @@ -484,6 +604,19 @@ resolveFragmentDefinitions allFragments = modify (Set.insert name) FragmentSpread name directives <$> resolveFragment' definition +-- * Arguments + +-- | The set of arguments for a given field, directive, etc. +-- +-- Note that the 'value' can be a variable. +newtype Arguments value = Arguments (Map Name value) deriving (Eq, Ord, Show, Functor, Foldable, Traversable) + +-- | Turn a set of arguments from the AST into a guaranteed unique set of arguments. +-- +-- +validateArguments :: [AST.Argument] -> Validation (Arguments AST.Value) +validateArguments args = Arguments <$> mapErrors DuplicateArgument (makeMap [(name, value) | AST.Argument name value <- args]) + -- * Variables -- | Defines a variable within the context of an operation. @@ -561,7 +694,7 @@ resolveVariables definitions = traverse resolveVariableValue -- * Directives -- | A directive is a way of changing the run-time behaviour -newtype Directives value = Directives (Map Name (Arguments value)) deriving (Eq, Show, Foldable, Functor, Traversable) +newtype Directives value = Directives (Map Name (Arguments value)) deriving (Eq, Ord, Show, Foldable, Functor, Traversable) emptyDirectives :: Directives value emptyDirectives = Directives Map.empty @@ -634,6 +767,14 @@ data ValidationError | InvalidValue AST.Value -- | Default value in AST contained variables. | InvalidDefaultValue AST.Value + -- | Two different names given for the same response key. + | MismatchedNames Name Name + -- | Two different sets of arguments given for the same response key. + | MismatchedArguments Name + -- | Two fields had the same response key, one was a leaf, the other was not. + | IncompatibleFields Name + -- | There's a type condition that's not present in the schema. + | TypeConditionNotFound Name deriving (Eq, Show) instance GraphQLError ValidationError where @@ -652,6 +793,10 @@ instance GraphQLError ValidationError where formatError (UndefinedVariable variable) = "No definition for variable: " <> show variable formatError (InvalidValue value) = "Invalid value (maybe an object has duplicate field names?): " <> show value formatError (InvalidDefaultValue value) = "Invalid default value, contains variables: " <> show value + formatError (MismatchedNames name1 name2) = "Two different names given for same response key: " <> show name1 <> ", " <> show name2 + 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." type ValidationErrors = NonEmpty ValidationError @@ -663,9 +808,9 @@ type Validation = Validator ValidationError -- An empty list means no errors. -- -- -getErrors :: AST.QueryDocument -> [ValidationError] -getErrors doc = - case validate doc of +getErrors :: Schema -> AST.QueryDocument -> [ValidationError] +getErrors schema doc = + case validate schema doc of Left errors -> NonEmpty.toList errors Right _ -> [] diff --git a/src/GraphQL/Resolver.hs b/src/GraphQL/Resolver.hs index ed95f3e..f86de01 100644 --- a/src/GraphQL/Resolver.hs +++ b/src/GraphQL/Resolver.hs @@ -31,6 +31,9 @@ module GraphQL.Resolver -- - Enforce non-empty lists (might only be doable via value-level validation) import Protolude hiding (Enum, TypeError) + +import qualified Data.Text as Text +import qualified Data.List.NonEmpty as NonEmpty import GHC.TypeLits (KnownSymbol, TypeError, ErrorMessage(..), Symbol, symbolVal) import qualified GHC.Exts (Any) import Unsafe.Coerce (unsafeCoerce) @@ -48,18 +51,16 @@ import GraphQL.Value ) import GraphQL.Value.FromValue (FromValue(..)) import GraphQL.Value.ToValue (ToValue(..)) -import GraphQL.Internal.Name (Name, NameError(..), HasName(..), makeName, nameFromSymbol) -import qualified GraphQL.Internal.Syntax.AST as AST +import GraphQL.Internal.Name (Name, NameError(..), HasName(..), nameFromSymbol) +import qualified GraphQL.Internal.OrderedMap as OrderedMap import GraphQL.Internal.Output (GraphQLError(..)) import GraphQL.Internal.Validation - ( SelectionSet - , Selection'(..) - , InlineFragment(..) - , FragmentSpread + ( SelectionSetByType + , SelectionSet(..) , Field - , getFields - , getFieldSelectionSet - , getResponseKey + , ValidationErrors + , getSubSelectionSet + , getSelectionSetForType , lookupArgument ) @@ -72,13 +73,12 @@ data ResolverError | ValueMissing Name -- | Could not translate value into Haskell. Probably a client-side problem. | InvalidValue Name Text - -- | Found duplicate fields in set. - | DuplicateFields [ResolveFieldResult] -- TODO: Catch this in validation - -- | We tried to use an inline fragment with a name that the union - -- type does not support. - | UnionTypeNotFound Name (SelectionSet Value) - -- | We found more than one inline fragment matching the given type condition. - | MultipleInlineFragmentsForType Name [InlineFragment FragmentSpread Value] + -- | 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 @@ -90,15 +90,12 @@ instance GraphQLError ResolverError where "No value provided for " <> show name <> ", and no default specified." formatError (InvalidValue name text) = "Could not coerce " <> show name <> " to valid value: " <> text - -- TODO: format 'result' nicely - formatError (DuplicateFields result) = - "Duplicate fields requested: " <> show result - formatError (UnionTypeNotFound unionTypeName selectionSet) = - "No inline fragment for " <> show unionTypeName - <> " (e.g. '... on " <> show unionTypeName <> "') found in selection set: " - <> show selectionSet - formatError (MultipleInlineFragmentsForType name fragments) = - "Multiple inline fragments found for " <> show name <> ": " <> show fragments + 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 = + "Triet to treat object as if it were leaf field." -- | Object field separation operator. -- @@ -134,6 +131,9 @@ data Result a = Result [ResolverError] a deriving (Show, Functor, Eq) 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) @@ -141,10 +141,9 @@ instance Applicative Result where ok :: Value -> Result Value ok = pure - class HasResolver m a where type Handler m a - resolve :: Handler m a -> SelectionSet Value -> m (Result Value) + resolve :: Handler m a -> Maybe (SelectionSetByType Value) -> m (Result Value) -- | Specify a default value for a type in a GraphQL schema. -- @@ -179,28 +178,27 @@ instance Defaultable (Maybe a) where -- | The default for @Maybe a@ is @Nothing@. defaultFor _ = pure Nothing -instance forall m. (Functor m) => HasResolver m Int32 where +instance forall m. (Applicative m) => HasResolver m Int32 where type Handler m Int32 = m Int32 - -- TODO check that selectionset is empty (we expect a terminal node) - resolve handler _ = do - map (ok . toValue) handler + resolve handler Nothing = map (ok . toValue) handler + resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) - -instance forall m. (Functor m) => HasResolver m Double where +instance forall m. (Applicative m) => HasResolver m Double where type Handler m Double = m Double - -- TODO check that selectionset is empty (we expect a terminal node) - resolve handler _ = map (ok . toValue) handler + resolve handler Nothing = map (ok . toValue) handler + resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) -instance forall m. (Functor m) => HasResolver m Text where +instance forall m. (Applicative m) => HasResolver m Text where type Handler m Text = m Text - -- TODO check that selectionset is empty (we expect a terminal node) - resolve handler _ = map (ok . toValue) handler + resolve handler Nothing = map (ok . toValue) handler + resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) -instance forall m. (Functor m) => HasResolver m Bool where +instance forall m. (Applicative m) => HasResolver m Bool where type Handler m Bool = m Bool - -- TODO check that selectionset is empty (we expect a terminal node) - resolve handler _ = map (ok . toValue) handler + resolve handler Nothing = map (ok . toValue) handler + resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) +-- XXX: jml really doesn't understand this. What happens to the selection set? What if it's a nullable object? instance forall m hg. (HasResolver m hg, Functor m, ToValue (Maybe hg)) => HasResolver m (Maybe hg) where type Handler m (Maybe hg) = m (Maybe hg) resolve handler _ = map (ok . toValue) handler @@ -215,14 +213,15 @@ instance forall m hg. (Monad m, Applicative m, HasResolver m hg) => HasResolver instance forall m ksN enum. (Applicative m, API.GraphQLEnum enum) => HasResolver m (API.Enum ksN enum) where type Handler m (API.Enum ksN enum) = enum - resolve handler _ = (pure . ok . GValue.ValueEnum . API.enumToValue) handler + resolve handler Nothing = (pure . ok . GValue.ValueEnum . API.enumToValue) handler + resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) -- 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.ObjectField) +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 @@ -241,17 +240,15 @@ resolveField :: forall dispatchType (m :: Type -> Type). resolveField handler nextHandler field = -- check name before case nameFromSymbol @(FieldName dispatchType) of - Left err -> pure (Result [SchemaError err] (Just (GValue.ObjectField responseKey GValue.ValueNull))) + 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.ObjectField responseKey GValue.ValueNull))) + Left err -> pure (Result [err] (Just GValue.ValueNull)) Right resolver -> do Result errs value <- resolver - pure (Result errs (Just (GValue.ObjectField responseKey value))) + pure (Result errs (Just value)) | otherwise -> nextHandler - where - responseKey = getResponseKey field -- We're using our usual trick of rewriting a type in a closed type -- family to emulate a closed typeclass. The following are the @@ -280,8 +277,7 @@ 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 - let resolver = resolve @m @t handler (getFieldSelectionSet field) - pure resolver + pure (resolve @m @t handler (getSubSelectionSet field)) instance forall ksH t f m. ( KnownSymbol ksH @@ -357,10 +353,10 @@ instance forall f fs m dispatchType. , KnownSymbol (FieldName dispatchType) , Monad m ) => RunFields m (f :<> fs) where - runFields (handler :<> nextHandlers) selection = - resolveField @dispatchType @m handler nextHandler selection + runFields (handler :<> nextHandlers) field = + resolveField @dispatchType @m handler nextHandler field where - nextHandler = runFields @m @fs nextHandlers selection + nextHandler = runFields @m @fs nextHandlers field instance forall ksM t m dispatchType. ( BuildFieldResolver m dispatchType @@ -386,23 +382,39 @@ instance forall m a b dispatchType. 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 mHandler selectionSet = do - -- First we run the actual handler function itself in IO. - handler <- mHandler - let fields = getFields selectionSet - -- We're evaluating an Object so we're collecting ObjectFields from - -- runFields and build a GValue.Map with them. - r <- forM fields (runFields @m @(RunFieldsType m fields) handler) - -- let (errs, fields) = foldr' (\(Result ea fa) (eb, fbs) -> (eb <> ea, fa:fbs)) ([], []) r - let (Result errs obj) = GValue.makeObject . catMaybes <$> sequenceA r - case obj of - Nothing -> pure (Result [DuplicateFields r] GValue.ValueNull) - Just object -> pure (Result errs (GValue.ValueObject object)) + 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.) @@ -440,19 +452,20 @@ 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 -> InlineFragment FragmentSpread Value -> m (Result Value) + 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 fragment@(InlineFragment _ _ selection) = + runUnion duv selectionSet = case extractUnionValue @(API.Object name interfaces fields) @union @m duv of - Just handler -> resolve @m @(API.Object name interfaces fields) handler selection - Nothing -> runUnion @m @union @objects duv fragment + 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 @@ -471,41 +484,10 @@ instance forall m unionName objects. , 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) - -- 'label' is the name of the GraphQL type of the branch of the union that - -- we are currently implementing. - resolve mHandler selectionSet = do - duv@(DynamicUnionValue label _) <- mHandler - case makeName label of - Left e -> pure (Result [SchemaError e] GValue.ValueNull) - Right name -> - -- we only need to look at the fragment that matches by name: - case findInlineFragmentForType name selectionSet of - Left e -> pure (Result [e] GValue.ValueNull) - Right inlineFragment -> do - -- loop through union handlers and call right one when type matches. - runUnion @m @(API.Union unionName objects) @objects duv inlineFragment - --- | Inline fragments have optional[*] type conditions. Find the inline --- fragment in the selection set that matches the named type. --- --- --- --- [*] Except we currently treat type conditions as mandatory. This is a bug. --- See --- --- Note: probably want to move this to Validation, esp. as part of work to --- validate selection sets (see https://github.com/jml/graphql-api/issues/59). -findInlineFragmentForType :: Name -> SelectionSet Value -> Either ResolverError (InlineFragment FragmentSpread Value) -findInlineFragmentForType name selectionSet = - case mapMaybe getInlineFragment selectionSet of - [] -> Left (UnionTypeNotFound name selectionSet) - [x] -> Right x - xs -> Left (MultipleInlineFragmentsForType name xs) - where - getInlineFragment (SelectionInlineFragment frag@(InlineFragment (Just (AST.NamedType name')) _ _)) - | name == name' = Just frag - | otherwise = Nothing - getInlineFragment _ = Nothing + 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) diff --git a/src/GraphQL/Value.hs b/src/GraphQL/Value.hs index aed109d..5f3652d 100644 --- a/src/GraphQL/Value.hs +++ b/src/GraphQL/Value.hs @@ -41,6 +41,7 @@ module GraphQL.Value -- ** Constructing , makeObject , objectFromList + , objectFromOrderedMap -- ** Combining , unionObjects -- ** Querying @@ -289,6 +290,10 @@ instance Arbitrary scalar => Arbitrary (ObjectField' scalar) where 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 diff --git a/tests/EndToEndTests.hs b/tests/EndToEndTests.hs index 43c0baa..c784fd3 100644 --- a/tests/EndToEndTests.hs +++ b/tests/EndToEndTests.hs @@ -10,7 +10,7 @@ import Protolude import Data.Aeson (Value(Null), toJSON, object, (.=)) import qualified Data.Map as Map -import GraphQL (compileQuery, executeQuery, interpretAnonymousQuery, interpretQuery) +import GraphQL (makeSchema, compileQuery, executeQuery, interpretAnonymousQuery, interpretQuery) import GraphQL.API (Object, Field) import GraphQL.Internal.Syntax.AST (Variable(..)) import GraphQL.Resolver ((:<>)(..), Handler) @@ -49,7 +49,7 @@ data ServerDog -- | Whether 'ServerDog' knows the given command. doesKnowCommand :: ServerDog -> DogCommand -> Bool -doesKnowCommand dog command = command `elem` (knownCommands dog) +doesKnowCommand dog command = command `elem` knownCommands dog -- | Whether 'ServerDog' is house-trained. isHouseTrained :: ServerDog -> Maybe Bool -> Bool @@ -199,6 +199,41 @@ tests = testSpec "End-to-end tests" $ do ] ] 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) @@ -239,14 +274,16 @@ tests = testSpec "End-to-end tests" $ do toJSON (toValue response) `shouldBe` expected describe "Handles variables" $ do let root = pure (viewServerDog mortgage) + let Right schema = makeSchema @Dog let Right query = - compileQuery [r|query myQuery($whichCommand: DogCommand) { - dog { - name - doesKnowCommand(dogCommand: $whichCommand) - } - } - |] + 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 = diff --git a/tests/Examples/UnionExample.hs b/tests/Examples/UnionExample.hs index 87bb0a2..2d8efe3 100644 --- a/tests/Examples/UnionExample.hs +++ b/tests/Examples/UnionExample.hs @@ -10,7 +10,7 @@ import GraphQL.Resolver (Handler, (:<>)(..), unionValue) type MiniCat = Object "MiniCat" '[] '[Field "name" Text, Field "meowVolume" Int32] type MiniDog = Object "MiniDog" '[] '[Field "barkVolume" Int32] -type CatOrDog = Union "CatOrDog" '[MiniCat, MiniDog] +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 @@ -20,7 +20,7 @@ miniDog :: Handler IO MiniDog miniDog = pure (pure 100) catOrDog :: Handler IO CatOrDog -catOrDog = do +catOrDog = pure $ do name <- pure "MonadicFelix" -- we can do monadic actions unionValue @MiniCat (miniCat name) @@ -39,9 +39,9 @@ catOrDogList = pure $ -- -- >>> response <- exampleQuery -- >>> putStrLn $ encode $ toValue response --- {"data":{"meowVolume":32,"name":"MonadicFelix"}} +-- {"data":{"myPet":{"meowVolume":32,"name":"MonadicFelix"}}} exampleQuery :: IO Response -exampleQuery = interpretAnonymousQuery @CatOrDog catOrDog "{ ... on MiniCat { name meowVolume } ... on MiniDog { barkVolume } }" +exampleQuery = interpretAnonymousQuery @CatOrDog catOrDog "{ myPet { ... on MiniCat { name meowVolume } ... on MiniDog { barkVolume } } }" -- | 'unionValue' can be used in a list context -- diff --git a/tests/ValidationTests.hs b/tests/ValidationTests.hs index fb055bd..0820bae 100644 --- a/tests/ValidationTests.hs +++ b/tests/ValidationTests.hs @@ -12,6 +12,7 @@ import Test.Tasty.Hspec (testSpec, describe, it, shouldBe) import GraphQL.Internal.Name (Name, unsafeMakeName) import qualified GraphQL.Internal.Syntax.AST as AST +import GraphQL.Internal.Schema (Schema) import GraphQL.Internal.Validation ( ValidationError(..) , findDuplicates @@ -24,6 +25,11 @@ me = unsafeMakeName "me" someName :: Name someName = unsafeMakeName "name" +-- | Schema used for these tests. Since none of them do type-level stuff, we +-- don't need to define it. +schema :: Schema +schema = undefined + tests :: IO TestTree tests = testSpec "Validation" $ do describe "getErrors" $ do @@ -37,7 +43,7 @@ tests = testSpec "Validation" $ do ) ) ] - getErrors doc `shouldBe` [] + getErrors schema doc `shouldBe` [] it "Detects duplicate operation names" $ do let doc = AST.QueryDocument @@ -56,7 +62,7 @@ tests = testSpec "Validation" $ do ) ) ] - getErrors doc `shouldBe` [DuplicateOperation me] + getErrors schema doc `shouldBe` [DuplicateOperation me] it "Detects duplicate anonymous operations" $ do let doc = AST.QueryDocument @@ -71,7 +77,7 @@ tests = testSpec "Validation" $ do ] ) ] - getErrors doc `shouldBe` [MixedAnonymousOperations 2 []] + getErrors schema doc `shouldBe` [MixedAnonymousOperations 2 []] describe "findDuplicates" $ do prop "returns empty on unique lists" $ do