aboutsummaryrefslogtreecommitdiff
path: root/src/Language/GraphQL
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/GraphQL')
-rw-r--r--src/Language/GraphQL/AST/Document.hs14
-rw-r--r--src/Language/GraphQL/AST/Encoder.hs6
-rw-r--r--src/Language/GraphQL/AST/Parser.hs60
-rw-r--r--src/Language/GraphQL/Error.hs7
-rw-r--r--src/Language/GraphQL/Execute.hs50
-rw-r--r--src/Language/GraphQL/Execute/Coerce.hs10
-rw-r--r--src/Language/GraphQL/Execute/Execution.hs135
-rw-r--r--src/Language/GraphQL/Execute/Internal.hs31
-rw-r--r--src/Language/GraphQL/Execute/OrderedMap.hs148
-rw-r--r--src/Language/GraphQL/Execute/Subscribe.hs78
-rw-r--r--src/Language/GraphQL/Execute/Transform.hs91
-rw-r--r--src/Language/GraphQL/Type.hs2
-rw-r--r--src/Language/GraphQL/Type/Internal.hs33
-rw-r--r--src/Language/GraphQL/Type/Schema.hs46
-rw-r--r--src/Language/GraphQL/Validate.hs21
-rw-r--r--src/Language/GraphQL/Validate/Rules.hs59
16 files changed, 537 insertions, 254 deletions
diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs
index a78b007..a698d2e 100644
--- a/src/Language/GraphQL/AST/Document.hs
+++ b/src/Language/GraphQL/AST/Document.hs
@@ -226,6 +226,12 @@ type TypeCondition = Name
-- ** Input Values
+-- | Escapes a single character according to the GraphQL escaping rules for
+-- double-quoted string values.
+--
+-- Characters, that should be escaped, are written as escaped characters with a
+-- backslash or Unicode with an \"\\u\". Other characters are returned as
+-- strings.
escape :: Char -> String
escape char'
| char' == '\\' = "\\\\"
@@ -257,7 +263,7 @@ data Value
| Boolean Bool
| Null
| Enum Name
- | List [Value]
+ | List [Node Value]
| Object [ObjectField Value]
deriving Eq
@@ -281,7 +287,7 @@ data ConstValue
| ConstBoolean Bool
| ConstNull
| ConstEnum Name
- | ConstList [ConstValue]
+ | ConstList [Node ConstValue]
| ConstObject [ObjectField ConstValue]
deriving Eq
@@ -318,13 +324,13 @@ instance Functor ObjectField where
-- Each operation can include a list of variables:
--
-- @
--- query (protagonist: String = "Zarathustra") {
+-- query (protagonist: String = \"Zarathustra\") {
-- getAuthor(protagonist: $protagonist)
-- }
-- @
--
-- This query defines an optional variable @protagonist@ of type @String@,
--- its default value is "Zarathustra". If no default value is defined and no
+-- its default value is \"Zarathustra\". If no default value is defined and no
-- value is provided, a variable can still be @null@ if its type is nullable.
--
-- Variables are usually passed along with the query, but not in the query
diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs
index f04f385..0d448df 100644
--- a/src/Language/GraphQL/AST/Encoder.hs
+++ b/src/Language/GraphQL/AST/Encoder.hs
@@ -219,7 +219,7 @@ fromConstValue (Full.ConstBoolean x) = Full.Boolean x
fromConstValue Full.ConstNull = Full.Null
fromConstValue (Full.ConstString string) = Full.String string
fromConstValue (Full.ConstEnum x) = Full.Enum x
-fromConstValue (Full.ConstList x) = Full.List $ fromConstValue <$> x
+fromConstValue (Full.ConstList x) = Full.List $ fmap fromConstValue <$> x
fromConstValue (Full.ConstObject x) = Full.Object $ fromConstObjectField <$> x
where
fromConstObjectField Full.ObjectField{value = value', ..} =
@@ -266,8 +266,8 @@ stringValue (Pretty indentation) string =
= Builder.fromLazyText (indent (indentation + 1))
<> line' <> newline <> acc
-listValue :: Formatter -> [Full.Value] -> Lazy.Text
-listValue formatter = bracketsCommas formatter $ value formatter
+listValue :: Formatter -> [Full.Node Full.Value] -> Lazy.Text
+listValue formatter = bracketsCommas formatter $ value formatter . Full.node
objectValue :: Formatter -> [Full.ObjectField Full.Value] -> Lazy.Text
objectValue formatter = intercalate $ objectField formatter
diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs
index 46c8fa3..19251ab 100644
--- a/src/Language/GraphQL/AST/Parser.hs
+++ b/src/Language/GraphQL/AST/Parser.hs
@@ -14,11 +14,7 @@ import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty
import Data.List.NonEmpty (NonEmpty(..))
import Data.Text (Text)
import qualified Language.GraphQL.AST.DirectiveLocation as Directive
-import Language.GraphQL.AST.DirectiveLocation
- ( DirectiveLocation
- , ExecutableDirectiveLocation
- , TypeSystemDirectiveLocation
- )
+import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation)
import qualified Language.GraphQL.AST.Document as Full
import Language.GraphQL.AST.Lexer
import Text.Megaparsec
@@ -96,34 +92,28 @@ directiveLocations = optional pipe
<?> "DirectiveLocations"
directiveLocation :: Parser DirectiveLocation
-directiveLocation
- = Directive.ExecutableDirectiveLocation <$> executableDirectiveLocation
- <|> Directive.TypeSystemDirectiveLocation <$> typeSystemDirectiveLocation
+directiveLocation = e (Directive.Query <$ symbol "QUERY")
+ <|> e (Directive.Mutation <$ symbol "MUTATION")
+ <|> e (Directive.Subscription <$ symbol "SUBSCRIPTION")
+ <|> t (Directive.FieldDefinition <$ symbol "FIELD_DEFINITION")
+ <|> e (Directive.Field <$ symbol "FIELD")
+ <|> e (Directive.FragmentDefinition <$ "FRAGMENT_DEFINITION")
+ <|> e (Directive.FragmentSpread <$ "FRAGMENT_SPREAD")
+ <|> e (Directive.InlineFragment <$ "INLINE_FRAGMENT")
+ <|> t (Directive.Schema <$ symbol "SCHEMA")
+ <|> t (Directive.Scalar <$ symbol "SCALAR")
+ <|> t (Directive.Object <$ symbol "OBJECT")
+ <|> t (Directive.ArgumentDefinition <$ symbol "ARGUMENT_DEFINITION")
+ <|> t (Directive.Interface <$ symbol "INTERFACE")
+ <|> t (Directive.Union <$ symbol "UNION")
+ <|> t (Directive.EnumValue <$ symbol "ENUM_VALUE")
+ <|> t (Directive.Enum <$ symbol "ENUM")
+ <|> t (Directive.InputObject <$ symbol "INPUT_OBJECT")
+ <|> t (Directive.InputFieldDefinition <$ symbol "INPUT_FIELD_DEFINITION")
<?> "DirectiveLocation"
-
-executableDirectiveLocation :: Parser ExecutableDirectiveLocation
-executableDirectiveLocation = Directive.Query <$ symbol "QUERY"
- <|> Directive.Mutation <$ symbol "MUTATION"
- <|> Directive.Subscription <$ symbol "SUBSCRIPTION"
- <|> Directive.Field <$ symbol "FIELD"
- <|> Directive.FragmentDefinition <$ "FRAGMENT_DEFINITION"
- <|> Directive.FragmentSpread <$ "FRAGMENT_SPREAD"
- <|> Directive.InlineFragment <$ "INLINE_FRAGMENT"
- <?> "ExecutableDirectiveLocation"
-
-typeSystemDirectiveLocation :: Parser TypeSystemDirectiveLocation
-typeSystemDirectiveLocation = Directive.Schema <$ symbol "SCHEMA"
- <|> Directive.Scalar <$ symbol "SCALAR"
- <|> Directive.Object <$ symbol "OBJECT"
- <|> Directive.FieldDefinition <$ symbol "FIELD_DEFINITION"
- <|> Directive.ArgumentDefinition <$ symbol "ARGUMENT_DEFINITION"
- <|> Directive.Interface <$ symbol "INTERFACE"
- <|> Directive.Union <$ symbol "UNION"
- <|> Directive.Enum <$ symbol "ENUM"
- <|> Directive.EnumValue <$ symbol "ENUM_VALUE"
- <|> Directive.InputObject <$ symbol "INPUT_OBJECT"
- <|> Directive.InputFieldDefinition <$ symbol "INPUT_FIELD_DEFINITION"
- <?> "TypeSystemDirectiveLocation"
+ where
+ e = fmap Directive.ExecutableDirectiveLocation
+ t = fmap Directive.TypeSystemDirectiveLocation
typeDefinition :: Full.Description -> Parser Full.TypeDefinition
typeDefinition description' = scalarTypeDefinition description'
@@ -460,7 +450,7 @@ value = Full.Variable <$> variable
<|> Full.Null <$ nullValue
<|> Full.String <$> stringValue
<|> Full.Enum <$> try enumValue
- <|> Full.List <$> brackets (some value)
+ <|> Full.List <$> brackets (some $ valueNode value)
<|> Full.Object <$> braces (some $ objectField $ valueNode value)
<?> "Value"
@@ -471,8 +461,8 @@ constValue = Full.ConstFloat <$> try float
<|> Full.ConstNull <$ nullValue
<|> Full.ConstString <$> stringValue
<|> Full.ConstEnum <$> try enumValue
- <|> Full.ConstList <$> brackets (some constValue)
- <|> Full.ConstObject <$> braces (some $ objectField $ valueNode constValue)
+ <|> Full.ConstList <$> brackets (many $ valueNode constValue)
+ <|> Full.ConstObject <$> braces (many $ objectField $ valueNode constValue)
<?> "Value"
booleanValue :: Parser Bool
diff --git a/src/Language/GraphQL/Error.hs b/src/Language/GraphQL/Error.hs
index b084c78..2061c20 100644
--- a/src/Language/GraphQL/Error.hs
+++ b/src/Language/GraphQL/Error.hs
@@ -1,6 +1,5 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-- | Error handling.
@@ -70,21 +69,25 @@ parseError ParseErrorBundle{..} =
type CollectErrsT m = StateT (Resolution m) m
-- | Adds an error to the list of errors.
+{-# DEPRECATED #-}
addErr :: Monad m => Error -> CollectErrsT m ()
addErr v = modify appender
where
appender :: Monad m => Resolution m -> Resolution m
appender resolution@Resolution{..} = resolution{ errors = errors |> v }
+{-# DEPRECATED #-}
makeErrorMessage :: Text -> Error
makeErrorMessage s = Error s [] []
-- | Constructs a response object containing only the error with the given
-- message.
+{-# DEPRECATED #-}
singleError :: Serialize a => Text -> Response a
-singleError message = Response null $ Seq.singleton $ makeErrorMessage message
+singleError message = Response null $ Seq.singleton $ Error message [] []
-- | Convenience function for just wrapping an error message.
+{-# DEPRECATED #-}
addErrMsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a
addErrMsg errorMessage = (addErr . makeErrorMessage) errorMessage >> pure null
diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs
index 283e56c..62754a3 100644
--- a/src/Language/GraphQL/Execute.hs
+++ b/src/Language/GraphQL/Execute.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ExplicitForAll #-}
-- | This module provides functions to execute a @GraphQL@ request.
module Language.GraphQL.Execute
@@ -10,15 +10,22 @@ import Control.Monad.Catch (MonadCatch)
import Data.HashMap.Strict (HashMap)
import Data.Sequence (Seq(..))
import Data.Text (Text)
-import Language.GraphQL.AST.Document (Document, Name)
+import qualified Language.GraphQL.AST.Document as Full
import Language.GraphQL.Execute.Coerce
import Language.GraphQL.Execute.Execution
+import Language.GraphQL.Execute.Internal
import qualified Language.GraphQL.Execute.Transform as Transform
import qualified Language.GraphQL.Execute.Subscribe as Subscribe
import Language.GraphQL.Error
+ ( Error
+ , ResponseEventStream
+ , Response(..)
+ , runCollectErrs
+ )
import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema
+import Prelude hiding (null)
-- | The substitution is applied to the document, and the resolvers are applied
-- to the resulting fields. The operation name can be used if the document
@@ -29,35 +36,36 @@ import Language.GraphQL.Type.Schema
execute :: (MonadCatch m, VariableValue a, Serialize b)
=> Schema m -- ^ Resolvers.
-> Maybe Text -- ^ Operation name.
- -> HashMap Name a -- ^ Variable substitution function.
- -> Document -- @GraphQL@ document.
+ -> HashMap Full.Name a -- ^ Variable substitution function.
+ -> Full.Document -- @GraphQL@ document.
-> m (Either (ResponseEventStream m b) (Response b))
-execute schema' operationName subs document =
- case Transform.document schema' operationName subs document of
- Left queryError -> pure
- $ Right
- $ singleError
- $ Transform.queryError queryError
- Right transformed -> executeRequest transformed
+execute schema' operationName subs document
+ = either (pure . rightErrorResponse . singleError [] . show) executeRequest
+ $ Transform.document schema' operationName subs document
executeRequest :: (MonadCatch m, Serialize a)
=> Transform.Document m
-> m (Either (ResponseEventStream m a) (Response a))
executeRequest (Transform.Document types' rootObjectType operation)
- | (Transform.Query _ fields) <- operation =
- Right <$> executeOperation types' rootObjectType fields
- | (Transform.Mutation _ fields) <- operation =
- Right <$> executeOperation types' rootObjectType fields
- | (Transform.Subscription _ fields) <- operation
- = either (Right . singleError) Left
- <$> Subscribe.subscribe types' rootObjectType fields
+ | (Transform.Query _ fields objectLocation) <- operation =
+ Right <$> executeOperation types' rootObjectType objectLocation fields
+ | (Transform.Mutation _ fields objectLocation) <- operation =
+ Right <$> executeOperation types' rootObjectType objectLocation fields
+ | (Transform.Subscription _ fields objectLocation) <- operation
+ = either rightErrorResponse Left
+ <$> Subscribe.subscribe types' rootObjectType objectLocation fields
-- This is actually executeMutation, but we don't distinguish between queries
-- and mutations yet.
executeOperation :: (MonadCatch m, Serialize a)
- => HashMap Name (Type m)
+ => HashMap Full.Name (Type m)
-> Out.ObjectType m
+ -> Full.Location
-> Seq (Transform.Selection m)
-> m (Response a)
-executeOperation types' objectType fields =
- runCollectErrs types' $ executeSelectionSet Definition.Null objectType fields
+executeOperation types' objectType objectLocation fields
+ = runCollectErrs types'
+ $ executeSelectionSet Definition.Null objectType objectLocation fields
+
+rightErrorResponse :: Serialize b => forall a. Error -> Either a (Response b)
+rightErrorResponse = Right . Response null . pure
diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs
index 08a2fc0..f5ee204 100644
--- a/src/Language/GraphQL/Execute/Coerce.hs
+++ b/src/Language/GraphQL/Execute/Coerce.hs
@@ -19,7 +19,6 @@ import qualified Data.Aeson as Aeson
import Data.Int (Int32)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
-import Data.Map.Strict (Map)
import Data.String (IsString(..))
import Data.Text (Text)
import qualified Data.Text.Lazy as Text.Lazy
@@ -27,6 +26,8 @@ import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified Data.Text.Lazy.Builder.Int as Text.Builder
import Data.Scientific (toBoundedInteger, toRealFloat)
import Language.GraphQL.AST (Name)
+import Language.GraphQL.Execute.OrderedMap (OrderedMap)
+import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
import qualified Language.GraphQL.Type as Type
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
@@ -209,7 +210,7 @@ data Output a
| Boolean Bool
| Enum Name
| List [a]
- | Object (Map Name a)
+ | Object (OrderedMap a)
deriving (Eq, Show)
instance forall a. IsString (Output a) where
@@ -229,6 +230,9 @@ instance Serialize Aeson.Value where
, Boolean boolean <- value = Just $ Aeson.Bool boolean
serialize _ (Enum enum) = Just $ Aeson.String enum
serialize _ (List list) = Just $ Aeson.toJSON list
- serialize _ (Object object) = Just $ Aeson.toJSON object
+ serialize _ (Object object) = Just
+ $ Aeson.object
+ $ OrderedMap.toList
+ $ Aeson.toJSON <$> object
serialize _ _ = Nothing
null = Aeson.Null
diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs
index 9d588ca..9ad4439 100644
--- a/src/Language/GraphQL/Execute/Execution.hs
+++ b/src/Language/GraphQL/Execute/Execution.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
@@ -13,16 +14,18 @@ import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader (runReaderT)
import Control.Monad.Trans.State (gets)
import Data.List.NonEmpty (NonEmpty(..))
-import Data.Map.Strict (Map)
+import qualified Data.List.NonEmpty as NonEmpty
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
-import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Sequence (Seq(..))
import qualified Data.Text as Text
-import Language.GraphQL.AST (Name)
+import qualified Language.GraphQL.AST as Full
import Language.GraphQL.Error
import Language.GraphQL.Execute.Coerce
+import Language.GraphQL.Execute.Internal
+import Language.GraphQL.Execute.OrderedMap (OrderedMap)
+import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
import qualified Language.GraphQL.Execute.Transform as Transform
import qualified Language.GraphQL.Type as Type
import qualified Language.GraphQL.Type.In as In
@@ -34,15 +37,17 @@ resolveFieldValue :: MonadCatch m
=> Type.Value
-> Type.Subs
-> Type.Resolve m
+ -> Full.Location
-> CollectErrsT m Type.Value
-resolveFieldValue result args resolver =
+resolveFieldValue result args resolver location' =
catch (lift $ runReaderT resolver context) handleFieldError
where
handleFieldError :: MonadCatch m
=> ResolverException
-> CollectErrsT m Type.Value
- handleFieldError e =
- addErr (Error (Text.pack $ displayException e) [] []) >> pure Type.Null
+ handleFieldError e
+ = addError Type.Null
+ $ Error (Text.pack $ displayException e) [location'] []
context = Type.Context
{ Type.arguments = Type.Arguments args
, Type.values = result
@@ -51,21 +56,21 @@ resolveFieldValue result args resolver =
collectFields :: Monad m
=> Out.ObjectType m
-> Seq (Transform.Selection m)
- -> Map Name (NonEmpty (Transform.Field m))
-collectFields objectType = foldl forEach Map.empty
+ -> OrderedMap (NonEmpty (Transform.Field m))
+collectFields objectType = foldl forEach OrderedMap.empty
where
forEach groupedFields (Transform.SelectionField field) =
let responseKey = aliasOrName field
- in Map.insertWith (<>) responseKey (field :| []) groupedFields
+ in OrderedMap.insert responseKey (field :| []) groupedFields
forEach groupedFields (Transform.SelectionFragment selectionFragment)
| Transform.Fragment fragmentType fragmentSelectionSet <- selectionFragment
, Internal.doesFragmentTypeApply fragmentType objectType =
let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet
- in Map.unionWith (<>) groupedFields fragmentGroupedFieldSet
+ in groupedFields <> fragmentGroupedFieldSet
| otherwise = groupedFields
-aliasOrName :: forall m. Transform.Field m -> Name
-aliasOrName (Transform.Field alias name _ _) = fromMaybe name alias
+aliasOrName :: forall m. Transform.Field m -> Full.Name
+aliasOrName (Transform.Field alias name _ _ _) = fromMaybe name alias
resolveAbstractType :: Monad m
=> Internal.AbstractType m
@@ -95,11 +100,15 @@ executeField fieldResolver prev fields
where
executeField' fieldDefinition resolver = do
let Out.Field _ fieldType argumentDefinitions = fieldDefinition
- let (Transform.Field _ _ arguments' _ :| []) = fields
+ let Transform.Field _ _ arguments' _ location' = NonEmpty.head fields
case coerceArgumentValues argumentDefinitions arguments' of
- Nothing -> addErrMsg "Argument coercing failed."
- Just argumentValues -> do
- answer <- resolveFieldValue prev argumentValues resolver
+ Left [] ->
+ let errorMessage = "Not all required arguments are specified."
+ in addError null $ Error errorMessage [location'] []
+ Left errorLocations -> addError null
+ $ Error "Argument coercing failed." errorLocations []
+ Right argumentValues -> do
+ answer <- resolveFieldValue prev argumentValues resolver location'
completeValue fieldType fields answer
completeValue :: (MonadCatch m, Serialize a)
@@ -110,55 +119,67 @@ completeValue :: (MonadCatch m, Serialize a)
completeValue (Out.isNonNullType -> False) _ Type.Null = pure null
completeValue outputType@(Out.ListBaseType listType) fields (Type.List list)
= traverse (completeValue listType fields) list
- >>= coerceResult outputType . List
-completeValue outputType@(Out.ScalarBaseType _) _ (Type.Int int) =
- coerceResult outputType $ Int int
-completeValue outputType@(Out.ScalarBaseType _) _ (Type.Boolean boolean) =
- coerceResult outputType $ Boolean boolean
-completeValue outputType@(Out.ScalarBaseType _) _ (Type.Float float) =
- coerceResult outputType $ Float float
-completeValue outputType@(Out.ScalarBaseType _) _ (Type.String string) =
- coerceResult outputType $ String string
-completeValue outputType@(Out.EnumBaseType enumType) _ (Type.Enum enum) =
+ >>= coerceResult outputType (firstFieldLocation fields) . List
+completeValue outputType@(Out.ScalarBaseType _) fields (Type.Int int) =
+ coerceResult outputType (firstFieldLocation fields) $ Int int
+completeValue outputType@(Out.ScalarBaseType _) fields (Type.Boolean boolean) =
+ coerceResult outputType (firstFieldLocation fields) $ Boolean boolean
+completeValue outputType@(Out.ScalarBaseType _) fields (Type.Float float) =
+ coerceResult outputType (firstFieldLocation fields) $ Float float
+completeValue outputType@(Out.ScalarBaseType _) fields (Type.String string) =
+ coerceResult outputType (firstFieldLocation fields) $ String string
+completeValue outputType@(Out.EnumBaseType enumType) fields (Type.Enum enum) =
let Type.EnumType _ _ enumMembers = enumType
+ location = firstFieldLocation fields
in if HashMap.member enum enumMembers
- then coerceResult outputType $ Enum enum
- else addErrMsg "Enum value completion failed."
-completeValue (Out.ObjectBaseType objectType) fields result =
- executeSelectionSet result objectType $ mergeSelectionSets fields
+ then coerceResult outputType location $ Enum enum
+ else addError null $ Error "Enum value completion failed." [location] []
+completeValue (Out.ObjectBaseType objectType) fields result
+ = executeSelectionSet result objectType (firstFieldLocation fields)
+ $ mergeSelectionSets fields
completeValue (Out.InterfaceBaseType interfaceType) fields result
| Type.Object objectMap <- result = do
let abstractType = Internal.AbstractInterfaceType interfaceType
+ let location = firstFieldLocation fields
concreteType <- resolveAbstractType abstractType objectMap
case concreteType of
- Just objectType -> executeSelectionSet result objectType
+ Just objectType -> executeSelectionSet result objectType location
$ mergeSelectionSets fields
- Nothing -> addErrMsg "Interface value completion failed."
+ Nothing -> addError null
+ $ Error "Interface value completion failed." [location] []
completeValue (Out.UnionBaseType unionType) fields result
| Type.Object objectMap <- result = do
let abstractType = Internal.AbstractUnionType unionType
+ let location = firstFieldLocation fields
concreteType <- resolveAbstractType abstractType objectMap
case concreteType of
Just objectType -> executeSelectionSet result objectType
- $ mergeSelectionSets fields
- Nothing -> addErrMsg "Union value completion failed."
-completeValue _ _ _ = addErrMsg "Value completion failed."
+ location $ mergeSelectionSets fields
+ Nothing -> addError null
+ $ Error "Union value completion failed." [location] []
+completeValue _ (Transform.Field _ _ _ _ location :| _) _ =
+ addError null $ Error "Value completion failed." [location] []
mergeSelectionSets :: MonadCatch m
=> NonEmpty (Transform.Field m)
-> Seq (Transform.Selection m)
mergeSelectionSets = foldr forEach mempty
where
- forEach (Transform.Field _ _ _ fieldSelectionSet) selectionSet =
+ forEach (Transform.Field _ _ _ fieldSelectionSet _) selectionSet =
selectionSet <> fieldSelectionSet
+firstFieldLocation :: MonadCatch m => NonEmpty (Transform.Field m) -> Full.Location
+firstFieldLocation (Transform.Field _ _ _ _ fieldLocation :| _) = fieldLocation
+
coerceResult :: (MonadCatch m, Serialize a)
=> Out.Type m
+ -> Full.Location
-> Output a
-> CollectErrsT m a
-coerceResult outputType result
+coerceResult outputType parentLocation result
| Just serialized <- serialize outputType result = pure serialized
- | otherwise = addErrMsg "Result coercion failed."
+ | otherwise = addError null
+ $ Error "Result coercion failed." [parentLocation] []
-- | Takes an 'Out.ObjectType' and a list of 'Transform.Selection's and applies
-- each field to each 'Transform.Selection'. Resolves into a value containing
@@ -166,29 +187,45 @@ coerceResult outputType result
executeSelectionSet :: (MonadCatch m, Serialize a)
=> Type.Value
-> Out.ObjectType m
+ -> Full.Location
-> Seq (Transform.Selection m)
-> CollectErrsT m a
-executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) selectionSet = do
+executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) objectLocation selectionSet = do
let fields = collectFields objectType selectionSet
- resolvedValues <- Map.traverseMaybeWithKey forEach fields
- coerceResult (Out.NonNullObjectType objectType) $ Object resolvedValues
+ resolvedValues <- OrderedMap.traverseMaybe forEach fields
+ coerceResult (Out.NonNullObjectType objectType) objectLocation
+ $ Object resolvedValues
where
- forEach _ fields@(field :| _) =
- let Transform.Field _ name _ _ = field
+ forEach fields@(field :| _) =
+ let Transform.Field _ name _ _ _ = field
in traverse (tryResolver fields) $ lookupResolver name
lookupResolver = flip HashMap.lookup resolvers
tryResolver fields resolver =
executeField resolver result fields >>= lift . pure
coerceArgumentValues
- :: HashMap Name In.Argument
- -> HashMap Name Transform.Input
- -> Maybe Type.Subs
-coerceArgumentValues argumentDefinitions argumentValues =
+ :: HashMap Full.Name In.Argument
+ -> HashMap Full.Name (Full.Node Transform.Input)
+ -> Either [Full.Location] Type.Subs
+coerceArgumentValues argumentDefinitions argumentNodes =
HashMap.foldrWithKey forEach (pure mempty) argumentDefinitions
where
- forEach variableName (In.Argument _ variableType defaultValue) =
- matchFieldValues coerceArgumentValue argumentValues variableName variableType defaultValue
+ forEach argumentName (In.Argument _ variableType defaultValue) = \case
+ Right resultMap
+ | Just matchedValues
+ <- matchFieldValues' argumentName variableType defaultValue $ Just resultMap
+ -> Right matchedValues
+ | otherwise -> Left $ generateError argumentName []
+ Left errorLocations
+ | Just _
+ <- matchFieldValues' argumentName variableType defaultValue $ pure mempty
+ -> Left errorLocations
+ | otherwise -> Left $ generateError argumentName errorLocations
+ generateError argumentName errorLocations =
+ case HashMap.lookup argumentName argumentNodes of
+ Just (Full.Node _ errorLocation) -> [errorLocation]
+ Nothing -> errorLocations
+ matchFieldValues' = matchFieldValues coerceArgumentValue (Full.node <$> argumentNodes)
coerceArgumentValue inputType (Transform.Int integer) =
coerceInputLiteral inputType (Type.Int integer)
coerceArgumentValue inputType (Transform.Boolean boolean) =
diff --git a/src/Language/GraphQL/Execute/Internal.hs b/src/Language/GraphQL/Execute/Internal.hs
new file mode 100644
index 0000000..046db45
--- /dev/null
+++ b/src/Language/GraphQL/Execute/Internal.hs
@@ -0,0 +1,31 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+ v. 2.0. If a copy of the MPL was not distributed with this file, You can
+ obtain one at https://mozilla.org/MPL/2.0/. -}
+
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Language.GraphQL.Execute.Internal
+ ( addError
+ , singleError
+ ) where
+
+import Control.Monad.Trans.State (modify)
+import Control.Monad.Catch (MonadCatch)
+import Data.Sequence ((|>))
+import qualified Data.Text as Text
+import qualified Language.GraphQL.AST as Full
+import Language.GraphQL.Error (CollectErrsT, Error(..), Resolution(..))
+import Prelude hiding (null)
+
+addError :: MonadCatch m => forall a. a -> Error -> CollectErrsT m a
+addError returnValue error' = modify appender >> pure returnValue
+ where
+ appender :: Resolution m -> Resolution m
+ appender resolution@Resolution{ errors } = resolution
+ { errors = errors |> error'
+ }
+
+singleError :: [Full.Location] -> String -> Error
+singleError errorLocations message = Error (Text.pack message) errorLocations []
diff --git a/src/Language/GraphQL/Execute/OrderedMap.hs b/src/Language/GraphQL/Execute/OrderedMap.hs
new file mode 100644
index 0000000..e905cce
--- /dev/null
+++ b/src/Language/GraphQL/Execute/OrderedMap.hs
@@ -0,0 +1,148 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+ v. 2.0. If a copy of the MPL was not distributed with this file, You can
+ obtain one at https://mozilla.org/MPL/2.0/. -}
+
+{-# LANGUAGE ExplicitForAll #-}
+
+-- | This module contains a map data structure, that preserves insertion order.
+-- Some definitions conflict with functions from prelude, so this module should
+-- probably be imported qualified.
+module Language.GraphQL.Execute.OrderedMap
+ ( OrderedMap
+ , elems
+ , empty
+ , insert
+ , foldlWithKey'
+ , keys
+ , lookup
+ , replace
+ , singleton
+ , size
+ , toList
+ , traverseMaybe
+ ) where
+
+import qualified Data.Foldable as Foldable
+import Data.HashMap.Strict (HashMap, (!))
+import qualified Data.HashMap.Strict as HashMap
+import Data.Text (Text)
+import Data.Vector (Vector)
+import qualified Data.Vector as Vector
+import Prelude hiding (filter, lookup)
+
+-- | This map associates values with the given text keys. Insertion order is
+-- preserved. When inserting a value with a key, that is already available in
+-- the map, the existing value isn't overridden, but combined with the new value
+-- using its 'Semigroup' instance.
+--
+-- Internally this map uses an array with keys to preserve the order and an
+-- unorded map with key-value pairs.
+data OrderedMap v = OrderedMap (Vector Text) (HashMap Text v)
+ deriving (Eq)
+
+instance Functor OrderedMap where
+ fmap f (OrderedMap vector hashMap) = OrderedMap vector $ fmap f hashMap
+
+instance Foldable OrderedMap where
+ foldr f = foldrWithKey $ const f
+ null (OrderedMap vector _) = Vector.null vector
+
+instance Semigroup v => Semigroup (OrderedMap v) where
+ (<>) = foldlWithKey'
+ $ \accumulator key value -> insert key value accumulator
+
+instance Semigroup v => Monoid (OrderedMap v) where
+ mempty = empty
+
+instance Traversable OrderedMap where
+ traverse f (OrderedMap vector hashMap) = OrderedMap vector
+ <$> traverse f hashMap
+
+instance Show v => Show (OrderedMap v) where
+ showsPrec precedence map' = showParen (precedence > 10)
+ $ showString "fromList " . shows (toList map')
+
+-- * Construction
+
+-- | Constructs a map with a single element.
+singleton :: forall v. Text -> v -> OrderedMap v
+singleton key value = OrderedMap (Vector.singleton key)
+ $ HashMap.singleton key value
+
+-- | Constructs an empty map.
+empty :: forall v. OrderedMap v
+empty = OrderedMap mempty mempty
+
+-- * Traversal
+
+-- | Reduces this map by applying a binary operator from right to left to all
+-- elements, using the given starting value.
+foldrWithKey :: forall v a. (Text -> v -> a -> a) -> a -> OrderedMap v -> a
+foldrWithKey f initial (OrderedMap vector hashMap) = foldr go initial vector
+ where
+ go key = f key (hashMap ! key)
+
+-- | Reduces this map by applying a binary operator from left to right to all
+-- elements, using the given starting value.
+foldlWithKey' :: forall v a. (a -> Text -> v -> a) -> a -> OrderedMap v -> a
+foldlWithKey' f initial (OrderedMap vector hashMap) =
+ Vector.foldl' go initial vector
+ where
+ go accumulator key = f accumulator key (hashMap ! key)
+
+-- | Traverse over the elements and collect the 'Just' results.
+traverseMaybe
+ :: Applicative f
+ => forall a
+ . (a -> f (Maybe b))
+ -> OrderedMap a
+ -> f (OrderedMap b)
+traverseMaybe f orderedMap = foldlWithKey' filter empty
+ <$> traverse f orderedMap
+ where
+ filter accumulator key (Just value) = replace key value accumulator
+ filter accumulator _ Nothing = accumulator
+
+-- * Lists
+
+-- | Converts this map to the list of key-value pairs.
+toList :: forall v. OrderedMap v -> [(Text, v)]
+toList = foldrWithKey ((.) (:) . (,)) []
+
+-- | Returns a list with all keys in this map.
+keys :: forall v. OrderedMap v -> [Text]
+keys (OrderedMap vector _) = Foldable.toList vector
+
+-- | Returns a list with all elements in this map.
+elems :: forall v. OrderedMap v -> [v]
+elems = fmap snd . toList
+
+-- * Basic interface
+
+-- | Associates the specified value with the specified key in this map. If this
+-- map previously contained a mapping for the key, the existing and new values
+-- are combined.
+insert :: Semigroup v => Text -> v -> OrderedMap v -> OrderedMap v
+insert key value (OrderedMap vector hashMap)
+ | Just available <- HashMap.lookup key hashMap = OrderedMap vector
+ $ HashMap.insert key (available <> value) hashMap
+ | otherwise = OrderedMap (Vector.snoc vector key)
+ $ HashMap.insert key value hashMap
+
+-- | Associates the specified value with the specified key in this map. If this
+-- map previously contained a mapping for the key, the existing value is
+-- replaced by the new one.
+replace :: Text -> v -> OrderedMap v -> OrderedMap v
+replace key value (OrderedMap vector hashMap)
+ | HashMap.member key hashMap = OrderedMap vector
+ $ HashMap.insert key value hashMap
+ | otherwise = OrderedMap (Vector.snoc vector key)
+ $ HashMap.insert key value hashMap
+
+-- | Gives the size of this map, i.e. number of elements in it.
+size :: forall v. OrderedMap v -> Int
+size (OrderedMap vector _) = Vector.length vector
+
+-- | Looks up a value in this map by key.
+lookup :: forall v. Text -> OrderedMap v -> Maybe v
+lookup key (OrderedMap _ hashMap) = HashMap.lookup key hashMap
diff --git a/src/Language/GraphQL/Execute/Subscribe.hs b/src/Language/GraphQL/Execute/Subscribe.hs
index 0bd274f..5d8d294 100644
--- a/src/Language/GraphQL/Execute/Subscribe.hs
+++ b/src/Language/GraphQL/Execute/Subscribe.hs
@@ -9,62 +9,78 @@ module Language.GraphQL.Execute.Subscribe
) where
import Conduit
+import Control.Arrow (left)
import Control.Monad.Catch (Exception(..), MonadCatch(..))
import Control.Monad.Trans.Reader (ReaderT(..), runReaderT)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
-import qualified Data.Map.Strict as Map
import qualified Data.List.NonEmpty as NonEmpty
import Data.Sequence (Seq(..))
-import Data.Text (Text)
-import qualified Data.Text as Text
-import Language.GraphQL.AST (Name)
+import qualified Language.GraphQL.AST as Full
import Language.GraphQL.Execute.Coerce
import Language.GraphQL.Execute.Execution
+import Language.GraphQL.Execute.Internal
+import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
import qualified Language.GraphQL.Execute.Transform as Transform
import Language.GraphQL.Error
+ ( Error(..)
+ , ResolverException
+ , Response
+ , ResponseEventStream
+ , runCollectErrs
+ )
import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type as Type
import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema
--- This is actually executeMutation, but we don't distinguish between queries
--- and mutations yet.
subscribe :: (MonadCatch m, Serialize a)
- => HashMap Name (Type m)
+ => HashMap Full.Name (Type m)
-> Out.ObjectType m
+ -> Full.Location
-> Seq (Transform.Selection m)
- -> m (Either Text (ResponseEventStream m a))
-subscribe types' objectType fields = do
- sourceStream <- createSourceEventStream types' objectType fields
- traverse (mapSourceToResponseEvent types' objectType fields) sourceStream
+ -> m (Either Error (ResponseEventStream m a))
+subscribe types' objectType objectLocation fields = do
+ sourceStream <-
+ createSourceEventStream types' objectType objectLocation fields
+ let traverser =
+ mapSourceToResponseEvent types' objectType objectLocation fields
+ traverse traverser sourceStream
mapSourceToResponseEvent :: (MonadCatch m, Serialize a)
- => HashMap Name (Type m)
+ => HashMap Full.Name (Type m)
-> Out.ObjectType m
+ -> Full.Location
-> Seq (Transform.Selection m)
-> Out.SourceEventStream m
-> m (ResponseEventStream m a)
-mapSourceToResponseEvent types' subscriptionType fields sourceStream = pure
+mapSourceToResponseEvent types' subscriptionType objectLocation fields sourceStream
+ = pure
$ sourceStream
- .| mapMC (executeSubscriptionEvent types' subscriptionType fields)
+ .| mapMC (executeSubscriptionEvent types' subscriptionType objectLocation fields)
createSourceEventStream :: MonadCatch m
- => HashMap Name (Type m)
+ => HashMap Full.Name (Type m)
-> Out.ObjectType m
+ -> Full.Location
-> Seq (Transform.Selection m)
- -> m (Either Text (Out.SourceEventStream m))
-createSourceEventStream _types subscriptionType@(Out.ObjectType _ _ _ fieldTypes) fields
- | [fieldGroup] <- Map.elems groupedFieldSet
- , Transform.Field _ fieldName arguments' _ <- NonEmpty.head fieldGroup
+ -> m (Either Error (Out.SourceEventStream m))
+createSourceEventStream _types subscriptionType objectLocation fields
+ | [fieldGroup] <- OrderedMap.elems groupedFieldSet
+ , Transform.Field _ fieldName arguments' _ errorLocation <- NonEmpty.head fieldGroup
+ , Out.ObjectType _ _ _ fieldTypes <- subscriptionType
, resolverT <- fieldTypes HashMap.! fieldName
, Out.EventStreamResolver fieldDefinition _ resolver <- resolverT
, Out.Field _ _fieldType argumentDefinitions <- fieldDefinition =
case coerceArgumentValues argumentDefinitions arguments' of
- Nothing -> pure $ Left "Argument coercion failed."
- Just argumentValues ->
- resolveFieldEventStream Type.Null argumentValues resolver
- | otherwise = pure $ Left "Subscription contains more than one field."
+ Left _ -> pure
+ $ Left
+ $ Error "Argument coercion failed." [errorLocation] []
+ Right argumentValues -> left (singleError [errorLocation])
+ <$> resolveFieldEventStream Type.Null argumentValues resolver
+ | otherwise = pure
+ $ Left
+ $ Error "Subscription contains more than one field." [objectLocation] []
where
groupedFieldSet = collectFields subscriptionType fields
@@ -72,26 +88,26 @@ resolveFieldEventStream :: MonadCatch m
=> Type.Value
-> Type.Subs
-> Out.Subscribe m
- -> m (Either Text (Out.SourceEventStream m))
+ -> m (Either String (Out.SourceEventStream m))
resolveFieldEventStream result args resolver =
catch (Right <$> runReaderT resolver context) handleEventStreamError
where
handleEventStreamError :: MonadCatch m
=> ResolverException
- -> m (Either Text (Out.SourceEventStream m))
- handleEventStreamError = pure . Left . Text.pack . displayException
+ -> m (Either String (Out.SourceEventStream m))
+ handleEventStreamError = pure . Left . displayException
context = Type.Context
{ Type.arguments = Type.Arguments args
, Type.values = result
}
--- This is actually executeMutation, but we don't distinguish between queries
--- and mutations yet.
executeSubscriptionEvent :: (MonadCatch m, Serialize a)
- => HashMap Name (Type m)
+ => HashMap Full.Name (Type m)
-> Out.ObjectType m
+ -> Full.Location
-> Seq (Transform.Selection m)
-> Definition.Value
-> m (Response a)
-executeSubscriptionEvent types' objectType fields initialValue =
- runCollectErrs types' $ executeSelectionSet initialValue objectType fields
+executeSubscriptionEvent types' objectType objectLocation fields initialValue
+ = runCollectErrs types'
+ $ executeSelectionSet initialValue objectType objectLocation fields
diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs
index 010899b..117b708 100644
--- a/src/Language/GraphQL/Execute/Transform.hs
+++ b/src/Language/GraphQL/Execute/Transform.hs
@@ -1,3 +1,7 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+ v. 2.0. If a copy of the MPL was not distributed with this file, You can
+ obtain one at https://mozilla.org/MPL/2.0/. -}
+
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -25,7 +29,6 @@ module Language.GraphQL.Execute.Transform
, QueryError(..)
, Selection(..)
, document
- , queryError
) where
import Control.Monad (foldM, unless)
@@ -71,16 +74,18 @@ data Selection m
| SelectionField (Field m)
-- | GraphQL has 3 operation types: queries, mutations and subscribtions.
---
--- Currently only queries and mutations are supported.
data Operation m
- = Query (Maybe Text) (Seq (Selection m))
- | Mutation (Maybe Text) (Seq (Selection m))
- | Subscription (Maybe Text) (Seq (Selection m))
+ = Query (Maybe Text) (Seq (Selection m)) Full.Location
+ | Mutation (Maybe Text) (Seq (Selection m)) Full.Location
+ | Subscription (Maybe Text) (Seq (Selection m)) Full.Location
-- | Single GraphQL field.
data Field m = Field
- (Maybe Full.Name) Full.Name (HashMap Full.Name Input) (Seq (Selection m))
+ (Maybe Full.Name)
+ Full.Name
+ (HashMap Full.Name (Full.Node Input))
+ (Seq (Selection m))
+ Full.Location
-- | Contains the operation to be executed along with its root type.
data Document m = Document
@@ -92,16 +97,26 @@ data OperationDefinition = OperationDefinition
[Full.VariableDefinition]
[Full.Directive]
Full.SelectionSet
+ Full.Location
-- | Query error types.
data QueryError
= OperationNotFound Text
| OperationNameRequired
| CoercionError
- | TransformationError
| EmptyDocument
| UnsupportedRootOperation
+instance Show QueryError where
+ show (OperationNotFound operationName) = unwords
+ ["Operation", Text.unpack operationName, "couldn't be found in the document."]
+ show OperationNameRequired = "Missing operation name."
+ show CoercionError = "Coercion error."
+ show EmptyDocument =
+ "The document doesn't contain any executable operations."
+ show UnsupportedRootOperation =
+ "Root operation type couldn't be found in the schema."
+
data Input
= Int Int32
| Float Double
@@ -114,17 +129,6 @@ data Input
| Variable Type.Value
deriving (Eq, Show)
-queryError :: QueryError -> Text
-queryError (OperationNotFound operationName) = Text.unwords
- ["Operation", operationName, "couldn't be found in the document."]
-queryError OperationNameRequired = "Missing operation name."
-queryError CoercionError = "Coercion error."
-queryError TransformationError = "Schema transformation error."
-queryError EmptyDocument =
- "The document doesn't contain any executable operations."
-queryError UnsupportedRootOperation =
- "Root operation type couldn't be found in the schema."
-
getOperation
:: Maybe Full.Name
-> NonEmpty OperationDefinition
@@ -135,7 +139,7 @@ getOperation (Just operationName) operations
| Just operation' <- find matchingName operations = pure operation'
| otherwise = Left $ OperationNotFound operationName
where
- matchingName (OperationDefinition _ name _ _ _) =
+ matchingName (OperationDefinition _ name _ _ _ _) =
name == Just operationName
coerceVariableValues :: Coerce.VariableValue a
@@ -145,7 +149,7 @@ coerceVariableValues :: Coerce.VariableValue a
-> HashMap.HashMap Full.Name a
-> Either QueryError Type.Subs
coerceVariableValues types operationDefinition variableValues =
- let OperationDefinition _ _ variableDefinitions _ _ = operationDefinition
+ let OperationDefinition _ _ variableDefinitions _ _ _ = operationDefinition
in maybe (Left CoercionError) Right
$ foldr forEach (Just HashMap.empty) variableDefinitions
where
@@ -173,7 +177,7 @@ constValue (Full.ConstString x) = Type.String x
constValue (Full.ConstBoolean b) = Type.Boolean b
constValue Full.ConstNull = Type.Null
constValue (Full.ConstEnum e) = Type.Enum e
-constValue (Full.ConstList l) = Type.List $ constValue <$> l
+constValue (Full.ConstList list) = Type.List $ constValue . Full.node <$> list
constValue (Full.ConstObject o) =
Type.Object $ HashMap.fromList $ constObjectField <$> o
where
@@ -203,14 +207,14 @@ document schema operationName subs ast = do
, types = referencedTypes
}
case chosenOperation of
- OperationDefinition Full.Query _ _ _ _ ->
+ OperationDefinition Full.Query _ _ _ _ _ ->
pure $ Document referencedTypes (Schema.query schema)
$ operation chosenOperation replacement
- OperationDefinition Full.Mutation _ _ _ _
+ OperationDefinition Full.Mutation _ _ _ _ _
| Just mutationType <- Schema.mutation schema ->
pure $ Document referencedTypes mutationType
$ operation chosenOperation replacement
- OperationDefinition Full.Subscription _ _ _ _
+ OperationDefinition Full.Subscription _ _ _ _ _
| Just subscriptionType <- Schema.subscription schema ->
pure $ Document referencedTypes subscriptionType
$ operation chosenOperation replacement
@@ -235,10 +239,10 @@ defragment ast =
(operations, HashMap.insert name fragment fragments')
defragment' _ acc = acc
transform = \case
- Full.OperationDefinition type' name variables directives' selections _ ->
- OperationDefinition type' name variables directives' selections
- Full.SelectionSet selectionSet _ ->
- OperationDefinition Full.Query Nothing mempty mempty selectionSet
+ Full.OperationDefinition type' name variables directives' selections location ->
+ OperationDefinition type' name variables directives' selections location
+ Full.SelectionSet selectionSet location ->
+ OperationDefinition Full.Query Nothing mempty mempty selectionSet location
-- * Operation
@@ -247,12 +251,12 @@ operation operationDefinition replacement
= runIdentity
$ evalStateT (collectFragments >> transform operationDefinition) replacement
where
- transform (OperationDefinition Full.Query name _ _ sels) =
- Query name <$> appendSelection sels
- transform (OperationDefinition Full.Mutation name _ _ sels) =
- Mutation name <$> appendSelection sels
- transform (OperationDefinition Full.Subscription name _ _ sels) =
- Subscription name <$> appendSelection sels
+ transform (OperationDefinition Full.Query name _ _ sels location) =
+ flip (Query name) location <$> appendSelection sels
+ transform (OperationDefinition Full.Mutation name _ _ sels location) =
+ flip (Mutation name) location <$> appendSelection sels
+ transform (OperationDefinition Full.Subscription name _ _ sels location) =
+ flip (Subscription name) location <$> appendSelection sels
-- * Selection
@@ -268,15 +272,20 @@ selection (Full.InlineFragmentSelection fragmentSelection) =
inlineFragment fragmentSelection
field :: Full.Field -> State (Replacement m) (Maybe (Field m))
-field (Full.Field alias name arguments' directives' selections _) = do
+field (Full.Field alias name arguments' directives' selections location) = do
fieldArguments <- foldM go HashMap.empty arguments'
fieldSelections <- appendSelection selections
fieldDirectives <- Definition.selection <$> directives directives'
- let field' = Field alias name fieldArguments fieldSelections
+ let field' = Field alias name fieldArguments fieldSelections location
pure $ field' <$ fieldDirectives
where
- go arguments (Full.Argument name' (Full.Node value' _) _) =
- inputField arguments name' value'
+ go arguments (Full.Argument name' (Full.Node value' _) location') = do
+ objectFieldValue <- input value'
+ case objectFieldValue of
+ Just fieldValue ->
+ let argumentNode = Full.Node fieldValue location'
+ in pure $ HashMap.insert name' argumentNode arguments
+ Nothing -> pure arguments
fragmentSpread
:: Full.FragmentSpread
@@ -380,7 +389,7 @@ value (Full.String string) = pure $ Type.String string
value (Full.Boolean boolean) = pure $ Type.Boolean boolean
value Full.Null = pure Type.Null
value (Full.Enum enum) = pure $ Type.Enum enum
-value (Full.List list) = Type.List <$> traverse value list
+value (Full.List list) = Type.List <$> traverse (value . Full.node) list
value (Full.Object object) =
Type.Object . HashMap.fromList <$> traverse objectField object
where
@@ -396,7 +405,7 @@ input (Full.String string) = pure $ pure $ String string
input (Full.Boolean boolean) = pure $ pure $ Boolean boolean
input Full.Null = pure $ pure Null
input (Full.Enum enum) = pure $ pure $ Enum enum
-input (Full.List list) = pure . List <$> traverse value list
+input (Full.List list) = pure . List <$> traverse (value . Full.node) list
input (Full.Object object) = do
objectFields <- foldM objectField HashMap.empty object
pure $ pure $ Object objectFields
diff --git a/src/Language/GraphQL/Type.hs b/src/Language/GraphQL/Type.hs
index 3ed8bb9..8a2a4d1 100644
--- a/src/Language/GraphQL/Type.hs
+++ b/src/Language/GraphQL/Type.hs
@@ -21,6 +21,6 @@ module Language.GraphQL.Type
) where
import Language.GraphQL.Type.Definition
-import Language.GraphQL.Type.Schema (Schema, schema)
+import Language.GraphQL.Type.Schema (Schema, schema, schemaWithTypes)
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
diff --git a/src/Language/GraphQL/Type/Internal.hs b/src/Language/GraphQL/Type/Internal.hs
index 2081b97..ce3b121 100644
--- a/src/Language/GraphQL/Type/Internal.hs
+++ b/src/Language/GraphQL/Type/Internal.hs
@@ -12,6 +12,7 @@ module Language.GraphQL.Type.Internal
, Directives
, Schema(..)
, Type(..)
+ , description
, directives
, doesFragmentTypeApply
, implementations
@@ -55,41 +56,43 @@ type Directives = HashMap Full.Name Directive
-- | A Schema is created by supplying the root types of each type of operation,
-- query and mutation (optional). A schema definition is then supplied to the
-- validator and executor.
---
--- __Note:__ When the schema is constructed, by default only the types that
--- are reachable by traversing the root types are included, other types must
--- be explicitly referenced.
data Schema m = Schema
- (Out.ObjectType m)
- (Maybe (Out.ObjectType m))
- (Maybe (Out.ObjectType m))
- Directives
- (HashMap Full.Name (Type m))
+ (Maybe Text) -- ^ Description.
+ (Out.ObjectType m) -- ^ Query.
+ (Maybe (Out.ObjectType m)) -- ^ Mutation.
+ (Maybe (Out.ObjectType m)) -- ^ Subscription.
+ Directives -- ^ Directives
+ (HashMap Full.Name (Type m)) -- ^ Types.
+ -- Interface implementations (used only for faster access).
(HashMap Full.Name [Type m])
+-- | Schema description.
+description :: forall m. Schema m -> Maybe Text
+description (Schema description' _ _ _ _ _ _) = description'
+
-- | Schema query type.
query :: forall m. Schema m -> Out.ObjectType m
-query (Schema query' _ _ _ _ _) = query'
+query (Schema _ query' _ _ _ _ _) = query'
-- | Schema mutation type.
mutation :: forall m. Schema m -> Maybe (Out.ObjectType m)
-mutation (Schema _ mutation' _ _ _ _) = mutation'
+mutation (Schema _ _ mutation' _ _ _ _) = mutation'
-- | Schema subscription type.
subscription :: forall m. Schema m -> Maybe (Out.ObjectType m)
-subscription (Schema _ _ subscription' _ _ _) = subscription'
+subscription (Schema _ _ _ subscription' _ _ _) = subscription'
-- | Schema directive definitions.
directives :: forall m. Schema m -> Directives
-directives (Schema _ _ _ directives' _ _) = directives'
+directives (Schema _ _ _ _ directives' _ _) = directives'
-- | Types referenced by the schema.
types :: forall m. Schema m -> HashMap Full.Name (Type m)
-types (Schema _ _ _ _ types' _) = types'
+types (Schema _ _ _ _ _ types' _) = types'
-- | Interface implementations.
implementations :: forall m. Schema m -> HashMap Full.Name [Type m]
-implementations (Schema _ _ _ _ _ implementations') = implementations'
+implementations (Schema _ _ _ _ _ _ implementations') = implementations'
-- | These types may describe the parent context of a selection set.
data CompositeType m
diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs
index dae8e18..ddddb4a 100644
--- a/src/Language/GraphQL/Type/Schema.hs
+++ b/src/Language/GraphQL/Type/Schema.hs
@@ -9,11 +9,13 @@
-- functions for defining and manipulating schemas.
module Language.GraphQL.Type.Schema
( schema
+ , schemaWithTypes
, module Language.GraphQL.Type.Internal
) where
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
+import Data.Text (Text)
import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..))
import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation
import qualified Language.GraphQL.AST as Full
@@ -22,6 +24,7 @@ import Language.GraphQL.Type.Internal
, Directives
, Schema
, Type(..)
+ , description
, directives
, implementations
, mutation
@@ -35,17 +38,47 @@ import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
-- | Schema constructor.
+--
+-- __Note:__ When the schema is constructed, by default only the types that
+-- are reachable by traversing the root types are included, other types must
+-- be explicitly referenced using 'schemaWithTypes' instead.
schema :: forall m
. Out.ObjectType m -- ^ Query type.
-> Maybe (Out.ObjectType m) -- ^ Mutation type.
-> Maybe (Out.ObjectType m) -- ^ Subscription type.
-> Directives -- ^ Directive definitions.
-> Schema m -- ^ Schema.
-schema queryRoot mutationRoot subscriptionRoot directiveDefinitions =
- Internal.Schema queryRoot mutationRoot subscriptionRoot
+schema queryRoot mutationRoot subscriptionRoot =
+ schemaWithTypes Nothing queryRoot mutationRoot subscriptionRoot mempty
+
+-- | Constructs a complete schema, including user-defined types not referenced
+-- in the schema directly (for example interface implementations).
+schemaWithTypes :: forall m
+ . Maybe Text -- ^ Schema description
+ -> Out.ObjectType m -- ^ Query type.
+ -> Maybe (Out.ObjectType m) -- ^ Mutation type.
+ -> Maybe (Out.ObjectType m) -- ^ Subscription type.
+ -> [Type m] -- ^ Additional types.
+ -> Directives -- ^ Directive definitions.
+ -> Schema m -- ^ Schema.
+schemaWithTypes description' queryRoot mutationRoot subscriptionRoot types' directiveDefinitions =
+ Internal.Schema description' queryRoot mutationRoot subscriptionRoot
allDirectives collectedTypes collectedImplementations
where
- collectedTypes = collectReferencedTypes queryRoot mutationRoot subscriptionRoot
+ allTypes = foldr addTypeDefinition HashMap.empty types'
+ addTypeDefinition type'@(ScalarType (Definition.ScalarType typeName _)) accumulator =
+ HashMap.insert typeName type' accumulator
+ addTypeDefinition type'@(EnumType (Definition.EnumType typeName _ _)) accumulator =
+ HashMap.insert typeName type' accumulator
+ addTypeDefinition type'@(ObjectType (Out.ObjectType typeName _ _ _)) accumulator =
+ HashMap.insert typeName type' accumulator
+ addTypeDefinition type'@(InputObjectType (In.InputObjectType typeName _ _)) accumulator =
+ HashMap.insert typeName type' accumulator
+ addTypeDefinition type'@(InterfaceType (Out.InterfaceType typeName _ _ _)) accumulator =
+ HashMap.insert typeName type' accumulator
+ addTypeDefinition type'@(UnionType (Out.UnionType typeName _ _)) accumulator =
+ HashMap.insert typeName type' accumulator
+ collectedTypes = collectReferencedTypes queryRoot mutationRoot subscriptionRoot allTypes
collectedImplementations = collectImplementations collectedTypes
allDirectives = HashMap.union directiveDefinitions defaultDirectives
defaultDirectives = HashMap.fromList
@@ -98,11 +131,12 @@ collectReferencedTypes :: forall m
-> Maybe (Out.ObjectType m)
-> Maybe (Out.ObjectType m)
-> HashMap Full.Name (Type m)
-collectReferencedTypes queryRoot mutationRoot subscriptionRoot =
- let queryTypes = traverseObjectType queryRoot HashMap.empty
+ -> HashMap Full.Name (Type m)
+collectReferencedTypes queryRoot mutationRoot subscriptionRoot extraTypes =
+ let queryTypes = traverseObjectType queryRoot extraTypes
mutationTypes = maybe queryTypes (`traverseObjectType` queryTypes)
mutationRoot
- in maybe mutationTypes (`traverseObjectType` queryTypes) subscriptionRoot
+ in maybe mutationTypes (`traverseObjectType` mutationTypes) subscriptionRoot
where
collect traverser typeName element foundTypes
| HashMap.member typeName foundTypes = foundTypes
diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs
index ea72018..f929b98 100644
--- a/src/Language/GraphQL/Validate.hs
+++ b/src/Language/GraphQL/Validate.hs
@@ -4,7 +4,6 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | GraphQL validator.
@@ -315,9 +314,6 @@ constValue (Validation.ValueRule _ rule) valueType = go valueType
go inputObjectType value'@(Full.Node (Full.ConstObject fields) _)
= foldMap (forEach inputObjectType) (Seq.fromList fields)
|> rule inputObjectType value'
- go listType value'@(Full.Node (Full.ConstList values) location')
- = embedListLocation go listType values location'
- |> rule listType value'
go anotherValue value' = pure $ rule anotherValue value'
forEach inputObjectType Full.ObjectField{value = value', ..} =
go (valueTypeByName name inputObjectType) value'
@@ -421,20 +417,6 @@ argument rule argumentType (Full.Argument _ value' _) =
where
valueType (In.Argument _ valueType' _) = valueType'
--- valueTypeFromList :: Maybe In.Type -> Maybe In.Type
-embedListLocation :: forall a m
- . (Maybe In.Type -> Full.Node a -> Seq m)
- -> Maybe In.Type
- -> [a]
- -> Full.Location
- -> Seq m
-embedListLocation go listType values location'
- = foldMap (go $ valueTypeFromList listType)
- $ flip Full.Node location' <$> Seq.fromList values
- where
- valueTypeFromList (Just (In.ListBaseType baseType)) = Just baseType
- valueTypeFromList _ = Nothing
-
value :: forall m
. Validation.Rule m
-> Maybe In.Type
@@ -445,9 +427,6 @@ value (Validation.ValueRule rule _) valueType = go valueType
go inputObjectType value'@(Full.Node (Full.Object fields) _)
= foldMap (forEach inputObjectType) (Seq.fromList fields)
|> rule inputObjectType value'
- go listType value'@(Full.Node (Full.List values) location')
- = embedListLocation go listType values location'
- |> rule listType value'
go anotherValue value' = pure $ rule anotherValue value'
forEach inputObjectType Full.ObjectField{value = value', ..} =
go (valueTypeByName name inputObjectType) value'
diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs
index 71455d3..46a14b7 100644
--- a/src/Language/GraphQL/Validate/Rules.hs
+++ b/src/Language/GraphQL/Validate/Rules.hs
@@ -1502,15 +1502,6 @@ variablesInAllowedPositionRule = OperationDefinitionRule $ \case
hasNonNullVariableDefaultValue (Just (Full.Node Full.ConstNull _)) = False
hasNonNullVariableDefaultValue Nothing = False
hasNonNullVariableDefaultValue _ = True
- unwrapInType (In.NonNullScalarType nonNullType) =
- Just $ In.NamedScalarType nonNullType
- unwrapInType (In.NonNullEnumType nonNullType) =
- Just $ In.NamedEnumType nonNullType
- unwrapInType (In.NonNullInputObjectType nonNullType) =
- Just $ In.NamedInputObjectType nonNullType
- unwrapInType (In.NonNullListType nonNullType) =
- Just $ In.ListType nonNullType
- unwrapInType _ = Nothing
makeError variableDefinition expectedType =
let Full.VariableDefinition variableName variableType _ location' =
variableDefinition
@@ -1527,6 +1518,17 @@ variablesInAllowedPositionRule = OperationDefinitionRule $ \case
, locations = [location']
}
+unwrapInType :: In.Type -> Maybe In.Type
+unwrapInType (In.NonNullScalarType nonNullType) =
+ Just $ In.NamedScalarType nonNullType
+unwrapInType (In.NonNullEnumType nonNullType) =
+ Just $ In.NamedEnumType nonNullType
+unwrapInType (In.NonNullInputObjectType nonNullType) =
+ Just $ In.NamedInputObjectType nonNullType
+unwrapInType (In.NonNullListType nonNullType) =
+ Just $ In.ListType nonNullType
+unwrapInType _ = Nothing
+
-- | Literal values must be compatible with the type expected in the position
-- they are found as per the coercion rules.
--
@@ -1540,7 +1542,7 @@ valuesOfCorrectTypeRule = ValueRule go constGo
go (Just inputType) value
| Just constValue <- toConstNode value =
lift $ check inputType constValue
- go _ _ = lift mempty
+ go _ _ = lift mempty -- This rule checks only literals.
toConstNode Full.Node{..} = flip Full.Node location <$> toConst node
toConst (Full.Variable _) = Nothing
toConst (Full.Int integer) = Just $ Full.ConstInt integer
@@ -1550,7 +1552,7 @@ valuesOfCorrectTypeRule = ValueRule go constGo
toConst Full.Null = Just Full.ConstNull
toConst (Full.Enum enum) = Just $ Full.ConstEnum enum
toConst (Full.List values) =
- Just $ Full.ConstList $ catMaybes $ toConst <$> values
+ Just $ Full.ConstList $ catMaybes $ toConstNode <$> values
toConst (Full.Object fields) = Just $ Full.ConstObject
$ catMaybes $ constObjectField <$> fields
constObjectField Full.ObjectField{..}
@@ -1582,24 +1584,37 @@ valuesOfCorrectTypeRule = ValueRule go constGo
, Full.ConstEnum memberValue <- node
, HashMap.member memberValue members = mempty
check (In.InputObjectBaseType objectType) Full.Node{ node }
- | In.InputObjectType _ _ typeFields <- objectType
- , Full.ConstObject valueFields <- node =
- foldMap (checkObjectField typeFields) valueFields
+ -- Skip, objects are checked recursively by the validation traverser.
+ | In.InputObjectType{} <- objectType
+ , Full.ConstObject{} <- node = mempty
check (In.ListBaseType listType) constValue@Full.Node{ .. }
- | Full.ConstList listValues <- node =
- foldMap (check listType) $ flip Full.Node location <$> listValues
+ | Full.ConstList values <- node =
+ foldMap (checkNull listType) values
| otherwise = check listType constValue
check inputType Full.Node{ .. } = pure $ Error
{ message = concat
[ "Value "
- , show node, " cannot be coerced to type \""
+ , show node
+ , " cannot be coerced to type \""
, show inputType
, "\"."
]
, locations = [location]
}
- checkObjectField typeFields Full.ObjectField{..}
- | Just typeField <- HashMap.lookup name typeFields
- , In.InputField _ fieldType _ <- typeField =
- check fieldType value
- checkObjectField _ _ = mempty
+ checkNull inputType constValue =
+ let checkResult = check inputType constValue
+ in case null checkResult of
+ True
+ | Just unwrappedType <- unwrapInType inputType
+ , Full.Node{ node = Full.ConstNull, .. } <- constValue ->
+ pure $ Error
+ { message = concat
+ [ "List of non-null values of type \""
+ , show unwrappedType
+ , "\" cannot contain null values."
+ ]
+ , locations = [location]
+ }
+ | otherwise -> mempty
+ _ -> checkResult
+
generated by cgit v1.2.3 (git 2.26.2) at 2026-10-02 08:51:33 +0000