summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEugen Wissner <belka@caraus.de>2020-05-22 10:11:48 +0200
committerEugen Wissner <belka@caraus.de>2020-05-22 10:11:48 +0200
commit26cc53ce0678d48bf7d5550df65171e6bf5288d2 (patch)
tree4b823c8d481463f2d2eb43beeea06310b2c51e5e
parentc3ecfece0358d79dd1da6efbe6ab83e63bf50f88 (diff)
downloadgraphql-26cc53ce0678d48bf7d5550df65171e6bf5288d2.tar.gz
Reject variables as default values
-rw-r--r--CHANGELOG.md9
-rw-r--r--src/Language/GraphQL/AST/Document.hs41
-rw-r--r--src/Language/GraphQL/AST/Encoder.hs152
-rw-r--r--src/Language/GraphQL/AST/Parser.hs48
-rw-r--r--src/Language/GraphQL/Execute.hs102
-rw-r--r--src/Language/GraphQL/Execute/Coerce.hs72
-rw-r--r--src/Language/GraphQL/Execute/Transform.hs113
-rw-r--r--src/Language/GraphQL/Type/Definition.hs4
-rw-r--r--tests/Language/GraphQL/AST/ParserSpec.hs11
-rw-r--r--tests/Language/GraphQL/Execute/CoerceSpec.hs32
10 files changed, 374 insertions, 210 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 7633c5a..c54d090 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -7,14 +7,17 @@ and this project adheres to
[Haskell Package Versioning Policy](https://pvp.haskell.org/).
## [Unreleased]
+### Fixed
+- The parser rejects variables when parsing defaultValue (DefaultValue). The
+ specification defines default values as `Value` with `const` parameter and
+ constant cannot be variables. `AST.Document.ConstValue` was added,
+ `AST.Document.ObjectField` was modified.
+
### Changed
- `Resolver` is now `Resolver Name FieldResolver` where `FieldResolver` can
contain a JSON value or another resolver, which is invoked during the
execution. `FieldResolver` is executed in `ActionT` and the current `Field` is
passed in the reader and not as an explicit argument.
-- `Execute.Transform.OperationDefinition` is almost the same as
- `AST.Document.OperationDefinition`. It is used to unify operations in the
- shorthand form and other operations.
- `Execute.Transform.operation` has the prior responsibility of
`Execute.Transform.document`, but transforms only the chosen operation and not
the whole document. `Execute.Transform.document` translates
diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs
index 3b13691..430e92a 100644
--- a/src/Language/GraphQL/AST/Document.hs
+++ b/src/Language/GraphQL/AST/Document.hs
@@ -8,6 +8,7 @@ module Language.GraphQL.AST.Document
( Alias
, Argument(..)
, ArgumentsDefinition(..)
+ , ConstValue(..)
, Definition(..)
, Description(..)
, Directive(..)
@@ -197,7 +198,7 @@ type TypeCondition = Name
-- ** Input Values
--- | Input value.
+-- | Input value (literal or variable).
data Value
= Variable Name
| Int Int32
@@ -207,18 +208,46 @@ data Value
| Null
| Enum Name
| List [Value]
- | Object [ObjectField]
+ | Object [ObjectField Value]
+ deriving (Eq, Show)
+
+-- | Constant input value.
+data ConstValue
+ = ConstInt Int32
+ | ConstFloat Double
+ | ConstString Text
+ | ConstBoolean Bool
+ | ConstNull
+ | ConstEnum Name
+ | ConstList [ConstValue]
+ | ConstObject [ObjectField ConstValue]
deriving (Eq, Show)
-- | Key-value pair.
--
--- A list of 'ObjectField's represents a GraphQL object type.
-data ObjectField = ObjectField Name Value deriving (Eq, Show)
+-- A list of 'ObjectField's represents a GraphQL object type.
+data ObjectField a = ObjectField Name a
+ deriving (Eq, Show)
-- ** Variables
-- | Variable definition.
-data VariableDefinition = VariableDefinition Name Type (Maybe Value)
+--
+-- Each operation can include a list of variables:
+--
+-- @
+-- 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
+-- 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
+-- itself. They make queries reusable.
+data VariableDefinition = VariableDefinition Name Type (Maybe ConstValue)
deriving (Eq, Show)
-- ** Type References
@@ -445,7 +474,7 @@ instance Monoid ArgumentsDefinition where
--
-- The input type "Point2D" contains two value definitions: "x" and "y".
data InputValueDefinition
- = InputValueDefinition Description Name Type (Maybe Value) [Directive]
+ = InputValueDefinition Description Name Type (Maybe ConstValue) [Directive]
deriving (Eq, Show)
-- ** Unions
diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs
index 69f5599..7fb0677 100644
--- a/src/Language/GraphQL/AST/Encoder.hs
+++ b/src/Language/GraphQL/AST/Encoder.hs
@@ -24,7 +24,6 @@ import Data.Text.Lazy.Builder (Builder)
import qualified Data.Text.Lazy.Builder as Builder
import Data.Text.Lazy.Builder.Int (decimal, hexadecimal)
import Data.Text.Lazy.Builder.RealFloat (realFloat)
-import qualified Language.GraphQL.AST as Full
import Language.GraphQL.AST.Document
-- | Instructs the encoder whether the GraphQL document should be minified or
@@ -53,32 +52,32 @@ document formatter defs
executableDefinition (ExecutableDefinition x) acc = definition formatter x : acc
executableDefinition _ acc = acc
--- | Converts a t'Full.ExecutableDefinition' into a string.
+-- | Converts a t'ExecutableDefinition' into a string.
definition :: Formatter -> ExecutableDefinition -> Lazy.Text
definition formatter x
| Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n'
| Minified <- formatter = encodeDefinition x
where
- encodeDefinition (Full.DefinitionOperation operation)
+ encodeDefinition (DefinitionOperation operation)
= operationDefinition formatter operation
- encodeDefinition (Full.DefinitionFragment fragment)
+ encodeDefinition (DefinitionFragment fragment)
= fragmentDefinition formatter fragment
--- | Converts a 'Full.OperationDefinition into a string.
-operationDefinition :: Formatter -> Full.OperationDefinition -> Lazy.Text
-operationDefinition formatter (Full.SelectionSet sels)
+-- | Converts a 'OperationDefinition into a string.
+operationDefinition :: Formatter -> OperationDefinition -> Lazy.Text
+operationDefinition formatter (SelectionSet sels)
= selectionSet formatter sels
-operationDefinition formatter (Full.OperationDefinition Full.Query name vars dirs sels)
+operationDefinition formatter (OperationDefinition Query name vars dirs sels)
= "query " <> node formatter name vars dirs sels
-operationDefinition formatter (Full.OperationDefinition Full.Mutation name vars dirs sels)
+operationDefinition formatter (OperationDefinition Mutation name vars dirs sels)
= "mutation " <> node formatter name vars dirs sels
--- | Converts a Full.Query or Full.Mutation into a string.
+-- | Converts a Query or Mutation into a string.
node :: Formatter ->
- Maybe Full.Name ->
- [Full.VariableDefinition] ->
- [Full.Directive] ->
- Full.SelectionSet ->
+ Maybe Name ->
+ [VariableDefinition] ->
+ [Directive] ->
+ SelectionSet ->
Lazy.Text
node formatter name vars dirs sels
= Lazy.Text.fromStrict (fold name)
@@ -87,31 +86,31 @@ node formatter name vars dirs sels
<> eitherFormat formatter " " mempty
<> selectionSet formatter sels
-variableDefinitions :: Formatter -> [Full.VariableDefinition] -> Lazy.Text
+variableDefinitions :: Formatter -> [VariableDefinition] -> Lazy.Text
variableDefinitions formatter
= parensCommas formatter $ variableDefinition formatter
-variableDefinition :: Formatter -> Full.VariableDefinition -> Lazy.Text
-variableDefinition formatter (Full.VariableDefinition var ty dv)
+variableDefinition :: Formatter -> VariableDefinition -> Lazy.Text
+variableDefinition formatter (VariableDefinition var ty defaultValue')
= variable var
<> eitherFormat formatter ": " ":"
<> type' ty
- <> maybe mempty (defaultValue formatter) dv
+ <> maybe mempty (defaultValue formatter) defaultValue'
-defaultValue :: Formatter -> Full.Value -> Lazy.Text
+defaultValue :: Formatter -> ConstValue -> Lazy.Text
defaultValue formatter val
= eitherFormat formatter " = " "="
- <> value formatter val
+ <> value formatter (fromConstValue val)
-variable :: Full.Name -> Lazy.Text
+variable :: Name -> Lazy.Text
variable var = "$" <> Lazy.Text.fromStrict var
-selectionSet :: Formatter -> Full.SelectionSet -> Lazy.Text
+selectionSet :: Formatter -> SelectionSet -> Lazy.Text
selectionSet formatter
= bracesList formatter (selection formatter)
. NonEmpty.toList
-selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Lazy.Text
+selectionSetOpt :: Formatter -> SelectionSetOpt -> Lazy.Text
selectionSetOpt formatter = bracesList formatter $ selection formatter
indentSymbol :: Lazy.Text
@@ -120,14 +119,14 @@ indentSymbol = " "
indent :: (Integral a) => a -> Lazy.Text
indent indentation = Lazy.Text.replicate (fromIntegral indentation) indentSymbol
-selection :: Formatter -> Full.Selection -> Lazy.Text
+selection :: Formatter -> Selection -> Lazy.Text
selection formatter = Lazy.Text.append indent' . encodeSelection
where
- encodeSelection (Full.Field alias name args directives' selections) =
+ encodeSelection (Field alias name args directives' selections) =
field incrementIndent alias name args directives' selections
- encodeSelection (Full.InlineFragment typeCondition directives' selections) =
+ encodeSelection (InlineFragment typeCondition directives' selections) =
inlineFragment incrementIndent typeCondition directives' selections
- encodeSelection (Full.FragmentSpread name directives') =
+ encodeSelection (FragmentSpread name directives') =
fragmentSpread incrementIndent name directives'
incrementIndent
| Pretty indentation <- formatter = Pretty $ indentation + 1
@@ -139,13 +138,13 @@ selection formatter = Lazy.Text.append indent' . encodeSelection
colon :: Formatter -> Lazy.Text
colon formatter = eitherFormat formatter ": " ":"
--- | Converts Full.Field into a string
+-- | Converts Field into a string
field :: Formatter ->
- Maybe Full.Name ->
- Full.Name ->
- [Full.Argument] ->
- [Full.Directive] ->
- [Full.Selection] ->
+ Maybe Name ->
+ Name ->
+ [Argument] ->
+ [Directive] ->
+ [Selection] ->
Lazy.Text
field formatter alias name args dirs set
= optempty prependAlias (fold alias)
@@ -158,27 +157,27 @@ field formatter alias name args dirs set
selectionSetOpt' = (eitherFormat formatter " " "" <>)
. selectionSetOpt formatter
-arguments :: Formatter -> [Full.Argument] -> Lazy.Text
+arguments :: Formatter -> [Argument] -> Lazy.Text
arguments formatter = parensCommas formatter $ argument formatter
-argument :: Formatter -> Full.Argument -> Lazy.Text
-argument formatter (Full.Argument name value')
+argument :: Formatter -> Argument -> Lazy.Text
+argument formatter (Argument name value')
= Lazy.Text.fromStrict name
<> colon formatter
<> value formatter value'
-- * Fragments
-fragmentSpread :: Formatter -> Full.Name -> [Full.Directive] -> Lazy.Text
+fragmentSpread :: Formatter -> Name -> [Directive] -> Lazy.Text
fragmentSpread formatter name directives'
= "..." <> Lazy.Text.fromStrict name
<> optempty (directives formatter) directives'
inlineFragment ::
Formatter ->
- Maybe Full.TypeCondition ->
- [Full.Directive] ->
- Full.SelectionSet ->
+ Maybe TypeCondition ->
+ [Directive] ->
+ SelectionSet ->
Lazy.Text
inlineFragment formatter tc dirs sels = "... on "
<> Lazy.Text.fromStrict (fold tc)
@@ -186,8 +185,8 @@ inlineFragment formatter tc dirs sels = "... on "
<> eitherFormat formatter " " mempty
<> selectionSet formatter sels
-fragmentDefinition :: Formatter -> Full.FragmentDefinition -> Lazy.Text
-fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels)
+fragmentDefinition :: Formatter -> FragmentDefinition -> Lazy.Text
+fragmentDefinition formatter (FragmentDefinition name tc dirs sels)
= "fragment " <> Lazy.Text.fromStrict name
<> " on " <> Lazy.Text.fromStrict tc
<> optempty (directives formatter) dirs
@@ -196,26 +195,39 @@ fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels)
-- * Miscellaneous
--- | Converts a 'Full.Directive' into a string.
-directive :: Formatter -> Full.Directive -> Lazy.Text
-directive formatter (Full.Directive name args)
+-- | Converts a 'Directive' into a string.
+directive :: Formatter -> Directive -> Lazy.Text
+directive formatter (Directive name args)
= "@" <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args
-directives :: Formatter -> [Full.Directive] -> Lazy.Text
+directives :: Formatter -> [Directive] -> Lazy.Text
directives Minified = spaces (directive Minified)
directives formatter = Lazy.Text.cons ' ' . spaces (directive formatter)
--- | Converts a 'Full.Value' into a string.
-value :: Formatter -> Full.Value -> Lazy.Text
-value _ (Full.Variable x) = variable x
-value _ (Full.Int x) = Builder.toLazyText $ decimal x
-value _ (Full.Float x) = Builder.toLazyText $ realFloat x
-value _ (Full.Boolean x) = booleanValue x
-value _ Full.Null = "null"
-value formatter (Full.String string) = stringValue formatter string
-value _ (Full.Enum x) = Lazy.Text.fromStrict x
-value formatter (Full.List x) = listValue formatter x
-value formatter (Full.Object x) = objectValue formatter x
+-- | Converts a 'Value' into a string.
+value :: Formatter -> Value -> Lazy.Text
+value _ (Variable x) = variable x
+value _ (Int x) = Builder.toLazyText $ decimal x
+value _ (Float x) = Builder.toLazyText $ realFloat x
+value _ (Boolean x) = booleanValue x
+value _ Null = "null"
+value formatter (String string) = stringValue formatter string
+value _ (Enum x) = Lazy.Text.fromStrict x
+value formatter (List x) = listValue formatter x
+value formatter (Object x) = objectValue formatter x
+
+fromConstValue :: ConstValue -> Value
+fromConstValue (ConstInt x) = Int x
+fromConstValue (ConstFloat x) = Float x
+fromConstValue (ConstBoolean x) = Boolean x
+fromConstValue ConstNull = Null
+fromConstValue (ConstString string) = String string
+fromConstValue (ConstEnum x) = Enum x
+fromConstValue (ConstList x) = List $ fromConstValue <$> x
+fromConstValue (ConstObject x) = Object $ fromConstObjectField <$> x
+ where
+ fromConstObjectField (ObjectField key value') =
+ ObjectField key $ fromConstValue value'
booleanValue :: Bool -> Lazy.Text
booleanValue True = "true"
@@ -271,10 +283,10 @@ escape char'
where
unicode prefix = mappend (Builder.fromString prefix) . (hexadecimal . ord)
-listValue :: Formatter -> [Full.Value] -> Lazy.Text
+listValue :: Formatter -> [Value] -> Lazy.Text
listValue formatter = bracketsCommas formatter $ value formatter
-objectValue :: Formatter -> [Full.ObjectField] -> Lazy.Text
+objectValue :: Formatter -> [ObjectField Value] -> Lazy.Text
objectValue formatter = intercalate $ objectField formatter
where
intercalate f
@@ -282,22 +294,22 @@ objectValue formatter = intercalate $ objectField formatter
. Lazy.Text.intercalate (eitherFormat formatter ", " ",")
. fmap f
-objectField :: Formatter -> Full.ObjectField -> Lazy.Text
-objectField formatter (Full.ObjectField name value') =
+objectField :: Formatter -> ObjectField Value -> Lazy.Text
+objectField formatter (ObjectField name value') =
Lazy.Text.fromStrict name <> colon formatter <> value formatter value'
--- | Converts a 'Full.Type' a type into a string.
-type' :: Full.Type -> Lazy.Text
-type' (Full.TypeNamed x) = Lazy.Text.fromStrict x
-type' (Full.TypeList x) = listType x
-type' (Full.TypeNonNull x) = nonNullType x
+-- | Converts a 'Type' a type into a string.
+type' :: Type -> Lazy.Text
+type' (TypeNamed x) = Lazy.Text.fromStrict x
+type' (TypeList x) = listType x
+type' (TypeNonNull x) = nonNullType x
-listType :: Full.Type -> Lazy.Text
+listType :: Type -> Lazy.Text
listType x = brackets (type' x)
-nonNullType :: Full.NonNullType -> Lazy.Text
-nonNullType (Full.NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!"
-nonNullType (Full.NonNullTypeList x) = listType x <> "!"
+nonNullType :: NonNullType -> Lazy.Text
+nonNullType (NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!"
+nonNullType (NonNullTypeList x) = listType x <> "!"
-- * Internal
diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs
index 3449903..c18c36a 100644
--- a/src/Language/GraphQL/AST/Parser.hs
+++ b/src/Language/GraphQL/AST/Parser.hs
@@ -403,32 +403,38 @@ typeCondition = symbol "on" *> name
value :: Parser Value
value = Variable <$> variable
- <|> Float <$> try float
- <|> Int <$> integer
- <|> Boolean <$> booleanValue
- <|> Null <$ symbol "null"
- <|> String <$> blockString
- <|> String <$> string
- <|> Enum <$> try enumValue
- <|> List <$> listValue
- <|> Object <$> objectValue
+ <|> Float <$> try float
+ <|> Int <$> integer
+ <|> Boolean <$> booleanValue
+ <|> Null <$ symbol "null"
+ <|> String <$> blockString
+ <|> String <$> string
+ <|> Enum <$> try enumValue
+ <|> List <$> brackets (some value)
+ <|> Object <$> braces (some $ objectField value)
<?> "value error!"
- where
- booleanValue :: Parser Bool
- booleanValue = True <$ symbol "true"
- <|> False <$ symbol "false"
- listValue :: Parser [Value]
- listValue = brackets $ some value
+constValue :: Parser ConstValue
+constValue = ConstFloat <$> try float
+ <|> ConstInt <$> integer
+ <|> ConstBoolean <$> booleanValue
+ <|> ConstNull <$ symbol "null"
+ <|> ConstString <$> blockString
+ <|> ConstString <$> string
+ <|> ConstEnum <$> try enumValue
+ <|> ConstList <$> brackets (some constValue)
+ <|> ConstObject <$> braces (some $ objectField constValue)
+ <?> "value error!"
- objectValue :: Parser [ObjectField]
- objectValue = braces $ some objectField
+booleanValue :: Parser Bool
+booleanValue = True <$ symbol "true"
+ <|> False <$ symbol "false"
enumValue :: Parser Name
enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name
-objectField :: Parser ObjectField
-objectField = ObjectField <$> name <* colon <*> value
+objectField :: Parser a -> Parser (ObjectField a)
+objectField valueParser = ObjectField <$> name <* colon <*> valueParser
-- * Variables
@@ -446,8 +452,8 @@ variableDefinition = VariableDefinition
variable :: Parser Name
variable = dollar *> name
-defaultValue :: Parser (Maybe Value)
-defaultValue = optional (equals *> value) <?> "DefaultValue"
+defaultValue :: Parser (Maybe ConstValue)
+defaultValue = optional (equals *> constValue) <?> "DefaultValue"
-- * Input Types
diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs
index e21d5de..7513b6e 100644
--- a/src/Language/GraphQL/Execute.hs
+++ b/src/Language/GraphQL/Execute.hs
@@ -8,11 +8,8 @@ module Language.GraphQL.Execute
) where
import qualified Data.Aeson as Aeson
-import Data.Foldable (find)
import qualified Data.HashMap.Strict as HashMap
-import Data.List.NonEmpty (NonEmpty(..))
import Data.Text (Text)
-import qualified Data.Text as Text
import Language.GraphQL.AST.Document
import qualified Language.GraphQL.AST.Core as AST.Core
import Language.GraphQL.Execute.Coerce
@@ -22,18 +19,6 @@ import qualified Language.GraphQL.Schema as Schema
import qualified Language.GraphQL.Type.Definition as Definition
import Language.GraphQL.Type.Schema
--- | Query error types.
-data QueryError
- = OperationNotFound Text
- | OperationNameRequired
- | CoercionError
-
-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."
-
-- | The substitution is applied to the document, and the resolvers are applied
-- to the resulting fields.
--
@@ -60,77 +45,6 @@ executeWithName :: (Monad m, VariableValue a)
-> m Aeson.Value
executeWithName schema operationName = document schema (Just operationName)
-getOperation
- :: Maybe Text
- -> Transform.Document
- -> Either QueryError Transform.OperationDefinition
-getOperation Nothing (Transform.Document (operation' :| []) _) = pure operation'
-getOperation Nothing _ = Left OperationNameRequired
-getOperation (Just operationName) (Transform.Document operations _)
- | Just operation' <- find matchingName operations = pure operation'
- | otherwise = Left $ OperationNotFound operationName
- where
- matchingName (Transform.OperationDefinition _ name _ _ _) =
- name == Just operationName
-
-lookupInputType
- :: Type
- -> HashMap.HashMap Name (Definition.TypeDefinition m)
- -> Maybe Definition.InputType
-lookupInputType (TypeNamed name) types =
- case HashMap.lookup name types of
- Just (Definition.ScalarTypeDefinition scalarType) ->
- Just $ Definition.ScalarInputType scalarType
- Just (Definition.EnumTypeDefinition enumType) ->
- Just $ Definition.EnumInputType enumType
- Just (Definition.InputObjectTypeDefinition objectType) ->
- Just $ Definition.ObjectInputType objectType
- _ -> Nothing
-lookupInputType (TypeList list) types
- = Definition.ListInputType
- <$> lookupInputType list types
-lookupInputType (TypeNonNull (NonNullTypeNamed nonNull)) types =
- case HashMap.lookup nonNull types of
- Just (Definition.ScalarTypeDefinition scalarType) ->
- Just $ Definition.NonNullScalarInputType scalarType
- Just (Definition.EnumTypeDefinition enumType) ->
- Just $ Definition.NonNullEnumInputType enumType
- Just (Definition.InputObjectTypeDefinition objectType) ->
- Just $ Definition.NonNullObjectInputType objectType
- _ -> Nothing
-lookupInputType (TypeNonNull (NonNullTypeList nonNull)) types
- = Definition.NonNullListInputType
- <$> lookupInputType nonNull types
-
-coerceVariableValues :: (Monad m, VariableValue a)
- => Schema m
- -> Transform.OperationDefinition
- -> HashMap.HashMap Name a
- -> Either QueryError Schema.Subs
-coerceVariableValues schema (Transform.OperationDefinition _ _ variables _ _) values =
- let referencedTypes = collectReferencedTypes schema
- in maybe (Left CoercionError) Right
- $ foldr (coerceValue referencedTypes) (Just HashMap.empty) variables
- where
- coerceValue referencedTypes variableDefinition coercedValues = do
- let VariableDefinition variableName variableTypeName _defaultValue =
- variableDefinition
- variableType <- lookupInputType variableTypeName referencedTypes
- value <- HashMap.lookup variableName values
- coercedValue <- coerceVariableValue variableType value
- HashMap.insert variableName coercedValue <$> coercedValues
-
-executeRequest :: (Monad m, VariableValue a)
- => Schema m
- -> Maybe Text
- -> HashMap.HashMap Name a
- -> Transform.Document
- -> Either QueryError (Transform.OperationDefinition, Schema.Subs)
-executeRequest schema operationName subs document' = do
- operation' <- getOperation operationName document'
- coercedValues <- coerceVariableValues schema operation' subs
- pure (operation', coercedValues)
-
document :: (Monad m, VariableValue a)
=> Schema m
-> Maybe Text
@@ -138,19 +52,9 @@ document :: (Monad m, VariableValue a)
-> Document
-> m Aeson.Value
document schema operationName subs document' =
- case Transform.document document' of
- Just transformed -> executeRequest' transformed
- Nothing -> pure $ singleError
- "The document doesn't contain any executable operations."
- where
- transformOperation fragmentTable operation' subs' =
- case Transform.operation fragmentTable subs' operation' of
- Just operationResult -> operation schema operationResult
- Nothing -> pure $ singleError "Schema transformation error."
- executeRequest' transformed@(Transform.Document _ fragmentTable) =
- case executeRequest schema operationName subs transformed of
- Right (operation', subs') -> transformOperation fragmentTable operation' subs'
- Left error' -> pure $ singleError $ queryError error'
+ case Transform.document schema operationName subs document' of
+ Left queryError -> pure $ singleError $ Transform.queryError queryError
+ Right (Transform.Document op _) -> operation schema op
operation :: Monad m
=> Schema m
diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs
index 5b26faa..ead19dc 100644
--- a/src/Language/GraphQL/Execute/Coerce.hs
+++ b/src/Language/GraphQL/Execute/Coerce.hs
@@ -3,12 +3,19 @@
-- | Types and functions used for input and result coercion.
module Language.GraphQL.Execute.Coerce
( VariableValue(..)
+ , coerceInputLiterals
) where
import qualified Data.Aeson as Aeson
+import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
+import qualified Data.Set as Set
+import qualified Data.Text.Lazy as Text.Lazy
+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.Core
+import Language.GraphQL.Schema
import Language.GraphQL.Type.Definition
-- | Since variables are passed separately from the query, in an independent
@@ -82,3 +89,68 @@ instance VariableValue Aeson.Value where
coerced <- coerceVariableValue listType variableValue
pure $ coerced : list
coerceVariableValue _ _ = Nothing
+
+-- | Coerces operation arguments according to the input coercion rules for the
+-- corresponding types.
+coerceInputLiterals
+ :: HashMap Name InputType
+ -> HashMap Name Value
+ -> Maybe Subs
+coerceInputLiterals variableTypes variableValues =
+ foldWithKey operator variableTypes
+ where
+ operator variableName variableType resultMap =
+ HashMap.insert variableName
+ <$> (lookupVariable variableName >>= coerceInputLiteral variableType)
+ <*> resultMap
+ coerceInputLiteral (ScalarInputType type') value
+ | (String stringValue) <- value
+ , (ScalarType "String" _) <- type' = Just $ String stringValue
+ | (Boolean booleanValue) <- value
+ , (ScalarType "Boolean" _) <- type' = Just $ Boolean booleanValue
+ | (Int intValue) <- value
+ , (ScalarType "Int" _) <- type' = Just $ Int intValue
+ | (Float floatValue) <- value
+ , (ScalarType "Float" _) <- type' = Just $ Float floatValue
+ | (Int intValue) <- value
+ , (ScalarType "Float" _) <- type' =
+ Just $ Float $ fromIntegral intValue
+ | (String stringValue) <- value
+ , (ScalarType "ID" _) <- type' = Just $ String stringValue
+ | (Int intValue) <- value
+ , (ScalarType "ID" _) <- type' = Just $ decimal intValue
+ coerceInputLiteral (EnumInputType type') (Enum enumValue)
+ | member enumValue type' = Just $ Enum enumValue
+ coerceInputLiteral (ObjectInputType type') (Object _) =
+ let (InputObjectType _ _ inputFields) = type'
+ in Object <$> foldWithKey matchFieldValues inputFields
+ coerceInputLiteral _ _ = Nothing
+ member value (EnumType _ _ members) = Set.member value members
+ matchFieldValues fieldName (InputField _ type' defaultValue) resultMap =
+ case lookupVariable fieldName of
+ Just Null
+ | isNonNullInputType type' -> Nothing
+ | otherwise ->
+ HashMap.insert fieldName Null <$> resultMap
+ Just variableValue -> HashMap.insert fieldName
+ <$> coerceInputLiteral type' variableValue
+ <*> resultMap
+ Nothing
+ | Just value <- defaultValue ->
+ HashMap.insert fieldName value <$> resultMap
+ | Nothing <- defaultValue
+ , isNonNullInputType type' -> Nothing
+ | otherwise -> resultMap
+ lookupVariable = flip HashMap.lookup variableValues
+ foldWithKey f = HashMap.foldrWithKey f (Just HashMap.empty)
+ decimal = String
+ . Text.Lazy.toStrict
+ . Text.Builder.toLazyText
+ . Text.Builder.decimal
+
+isNonNullInputType :: InputType -> Bool
+isNonNullInputType (NonNullScalarInputType _) = True
+isNonNullInputType (NonNullEnumInputType _) = True
+isNonNullInputType (NonNullObjectInputType _) = True
+isNonNullInputType (NonNullListInputType _) = True
+isNonNullInputType _ = False
diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs
index 56b2a22..485bd51 100644
--- a/src/Language/GraphQL/Execute/Transform.hs
+++ b/src/Language/GraphQL/Execute/Transform.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
-- | After the document is parsed, before getting executed the AST is
@@ -7,24 +8,30 @@
-- this transformation.
module Language.GraphQL.Execute.Transform
( Document(..)
- , OperationDefinition(..)
+ , QueryError(..)
, document
- , operation
+ , queryError
) where
import Control.Monad (foldM, unless)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT)
import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
+import Data.Foldable (find)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
-import Data.List.NonEmpty (NonEmpty)
+import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Sequence (Seq, (<|), (><))
+import Data.Text (Text)
+import qualified Data.Text as Text
import qualified Language.GraphQL.AST as Full
import qualified Language.GraphQL.AST.Core as Core
+import Language.GraphQL.Execute.Coerce
import qualified Language.GraphQL.Schema as Schema
+import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type.Directive as Directive
+import Language.GraphQL.Type.Schema
-- | Associates a fragment name with a list of 'Core.Field's.
data Replacement = Replacement
@@ -39,7 +46,7 @@ liftJust = lift . lift . Just
-- | GraphQL document is a non-empty list of operations.
data Document = Document
- (NonEmpty OperationDefinition)
+ Core.Operation
(HashMap Full.Name Full.FragmentDefinition)
data OperationDefinition = OperationDefinition
@@ -49,12 +56,102 @@ data OperationDefinition = OperationDefinition
[Full.Directive]
Full.SelectionSet
+-- | Query error types.
+data QueryError
+ = OperationNotFound Text
+ | OperationNameRequired
+ | CoercionError
+ | TransformationError
+ | EmptyDocument
+
+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."
+
+getOperation
+ :: Maybe Full.Name
+ -> NonEmpty OperationDefinition
+ -> Either QueryError OperationDefinition
+getOperation Nothing (operation' :| []) = pure operation'
+getOperation Nothing _ = Left OperationNameRequired
+getOperation (Just operationName) operations
+ | Just operation' <- find matchingName operations = pure operation'
+ | otherwise = Left $ OperationNotFound operationName
+ where
+ matchingName (OperationDefinition _ name _ _ _) =
+ name == Just operationName
+
+lookupInputType
+ :: Full.Type
+ -> HashMap.HashMap Full.Name (Definition.TypeDefinition m)
+ -> Maybe Definition.InputType
+lookupInputType (Full.TypeNamed name) types =
+ case HashMap.lookup name types of
+ Just (Definition.ScalarTypeDefinition scalarType) ->
+ Just $ Definition.ScalarInputType scalarType
+ Just (Definition.EnumTypeDefinition enumType) ->
+ Just $ Definition.EnumInputType enumType
+ Just (Definition.InputObjectTypeDefinition objectType) ->
+ Just $ Definition.ObjectInputType objectType
+ _ -> Nothing
+lookupInputType (Full.TypeList list) types
+ = Definition.ListInputType
+ <$> lookupInputType list types
+lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types =
+ case HashMap.lookup nonNull types of
+ Just (Definition.ScalarTypeDefinition scalarType) ->
+ Just $ Definition.NonNullScalarInputType scalarType
+ Just (Definition.EnumTypeDefinition enumType) ->
+ Just $ Definition.NonNullEnumInputType enumType
+ Just (Definition.InputObjectTypeDefinition objectType) ->
+ Just $ Definition.NonNullObjectInputType objectType
+ _ -> Nothing
+lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types
+ = Definition.NonNullListInputType
+ <$> lookupInputType nonNull types
+
+coerceVariableValues :: (Monad m, VariableValue a)
+ => Schema m
+ -> OperationDefinition
+ -> HashMap.HashMap Full.Name a
+ -> Either QueryError Schema.Subs
+coerceVariableValues schema (OperationDefinition _ _ variables _ _) values =
+ let referencedTypes = collectReferencedTypes schema
+ in maybe (Left CoercionError) Right
+ $ foldr (coerceValue referencedTypes) (Just HashMap.empty) variables
+ where
+ coerceValue referencedTypes variableDefinition coercedValues = do
+ let Full.VariableDefinition variableName variableTypeName _defaultValue =
+ variableDefinition
+ variableType <- lookupInputType variableTypeName referencedTypes
+ value' <- HashMap.lookup variableName values
+ coercedValue <- coerceVariableValue variableType value'
+ HashMap.insert variableName coercedValue <$> coercedValues
+
-- | Rewrites the original syntax tree into an intermediate representation used
-- for query execution.
-document :: Full.Document -> Maybe Document
-document ast =
+document :: (Monad m, VariableValue a)
+ => Schema m
+ -> Maybe Full.Name
+ -> HashMap Full.Name a
+ -> Full.Document
+ -> Either QueryError Document
+document schema operationName subs ast = do
let (operations, fragmentTable) = foldr defragment ([], HashMap.empty) ast
- in Document <$> NonEmpty.nonEmpty operations <*> pure fragmentTable
+ nonEmptyOperations <- maybe (Left EmptyDocument) Right
+ $ NonEmpty.nonEmpty operations
+ chosenOperation <- getOperation operationName nonEmptyOperations
+ coercedValues <- coerceVariableValues schema chosenOperation subs
+
+ maybe (Left TransformationError) Right
+ $ Document
+ <$> operation fragmentTable coercedValues chosenOperation
+ <*> pure fragmentTable
where
defragment definition (operations, fragments')
| (Full.ExecutableDefinition executable) <- definition
@@ -186,5 +283,5 @@ value (Full.List l) =
value (Full.Object o) =
Core.Object . HashMap.fromList <$> traverse objectField o
-objectField :: Full.ObjectField -> TransformT (Core.Name, Core.Value)
+objectField :: Full.ObjectField Full.Value -> TransformT (Core.Name, Core.Value)
objectField (Full.ObjectField name value') = (name,) <$> value value'
diff --git a/src/Language/GraphQL/Type/Definition.hs b/src/Language/GraphQL/Type/Definition.hs
index 5891f71..a916d51 100644
--- a/src/Language/GraphQL/Type/Definition.hs
+++ b/src/Language/GraphQL/Type/Definition.hs
@@ -193,18 +193,22 @@ pattern ListInputTypeDefinition listType <-
, ScalarInputTypeDefinition
#-}
+-- | Matches either 'ScalarOutputType' or 'NonNullScalarOutputType'.
pattern ScalarOutputTypeDefinition :: forall m. ScalarType -> OutputType m
pattern ScalarOutputTypeDefinition scalarType <-
(isScalarOutputType -> Just scalarType)
+-- | Matches either 'EnumOutputType' or 'NonNullEnumOutputType'.
pattern EnumOutputTypeDefinition :: forall m. EnumType -> OutputType m
pattern EnumOutputTypeDefinition enumType <-
(isEnumOutputType -> Just enumType)
+-- | Matches either 'ObjectOutputType' or 'NonNullObjectOutputType'.
pattern ObjectOutputTypeDefinition :: forall m. ObjectType m -> OutputType m
pattern ObjectOutputTypeDefinition objectType <-
(isObjectOutputType -> Just objectType)
+-- | Matches either 'ListOutputType' or 'NonNullListOutputType'.
pattern ListOutputTypeDefinition :: forall m. OutputType m -> OutputType m
pattern ListOutputTypeDefinition listType <-
(isListOutputType -> Just listType)
diff --git a/tests/Language/GraphQL/AST/ParserSpec.hs b/tests/Language/GraphQL/AST/ParserSpec.hs
index 4fae5b1..2801b57 100644
--- a/tests/Language/GraphQL/AST/ParserSpec.hs
+++ b/tests/Language/GraphQL/AST/ParserSpec.hs
@@ -8,7 +8,7 @@ import Data.List.NonEmpty (NonEmpty(..))
import Language.GraphQL.AST.Document
import Language.GraphQL.AST.Parser
import Test.Hspec (Spec, describe, it)
-import Test.Hspec.Megaparsec (shouldParse, shouldSucceedOn)
+import Test.Hspec.Megaparsec (shouldParse, shouldFailOn, shouldSucceedOn)
import Text.Megaparsec (parse)
import Text.RawString.QQ (r)
@@ -141,4 +141,11 @@ spec = describe "Parser" $ do
extend type Story {
isHiddenLocally: Boolean
}
- |] \ No newline at end of file
+ |]
+
+ it "rejects variables in DefaultValue" $
+ parse document "" `shouldFailOn` [r|
+ query ($book: String = "Zarathustra", $author: String = $book) {
+ title
+ }
+ |]
diff --git a/tests/Language/GraphQL/Execute/CoerceSpec.hs b/tests/Language/GraphQL/Execute/CoerceSpec.hs
index 45a647d..2ddab0c 100644
--- a/tests/Language/GraphQL/Execute/CoerceSpec.hs
+++ b/tests/Language/GraphQL/Execute/CoerceSpec.hs
@@ -6,15 +6,30 @@ module Language.GraphQL.Execute.CoerceSpec
import Data.Aeson as Aeson ((.=))
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
+import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (isNothing)
import Data.Scientific (scientific)
+import qualified Data.Set as Set
import Language.GraphQL.AST.Core
import Language.GraphQL.Execute.Coerce
+import Language.GraphQL.Schema
import Language.GraphQL.Type.Definition
import Prelude hiding (id)
import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy)
+direction :: EnumType
+direction = EnumType "Direction" Nothing
+ $ Set.fromList ["NORTH", "EAST", "SOUTH", "WEST"]
+
+coerceInputLiteral :: InputType -> Value -> Maybe Subs
+coerceInputLiteral input value = coerceInputLiterals
+ (HashMap.singleton "variableName" input)
+ (HashMap.singleton "variableName" value)
+
+lookupActual :: Maybe (HashMap Name Value) -> Maybe Value
+lookupActual = (HashMap.lookup "variableName" =<<)
+
singletonInputObject :: InputType
singletonInputObject = ObjectInputType type'
where
@@ -23,7 +38,7 @@ singletonInputObject = ObjectInputType type'
field = InputField Nothing (ScalarInputType string) Nothing
spec :: Spec
-spec =
+spec = do
describe "ToGraphQL Aeson" $ do
it "coerces strings" $
let expected = Just (String "asdf")
@@ -86,3 +101,18 @@ spec =
actual = coerceVariableValue listType list
expected = Just $ List [String "asdf", String "qwer"]
in actual `shouldBe` expected
+
+ describe "coerceInputLiterals" $ do
+ it "coerces enums" $
+ let expected = Just (Enum "NORTH")
+ actual = coerceInputLiteral
+ (EnumInputType direction) (Enum "NORTH")
+ in lookupActual actual `shouldBe` expected
+ it "fails with non-existing enum value" $
+ let actual = coerceInputLiteral
+ (EnumInputType direction) (Enum "NORTH_EAST")
+ in actual `shouldSatisfy` isNothing
+ it "coerces integers to IDs" $
+ let expected = Just (String "1234")
+ actual = coerceInputLiteral (ScalarInputType id) (Int 1234)
+ in lookupActual actual `shouldBe` expected