prescientmoon/graphql
1
0
Fork 0
forked from OSS/graphql
Code Pull Requests Activity

Reject variables as default values

Browse Source
This commit is contained in:
Eugen Wissner 2020-05-22 10:11:48 +02:00
parent c3ecfece03
commit 26cc53ce06
10 changed files with 374 additions and 210 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
CHANGELOG.md
View File

@ -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

39
src/Language/GraphQL/AST/Document.hs
View File

@ -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)
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

152
src/Language/GraphQL/AST/Encoder.hs
View File

@ -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

32
src/Language/GraphQL/AST/Parser.hs
View File

@ -410,25 +410,31 @@ value = Variable <$> variable
<|> String <$> blockString
<|> String <$> string
<|> Enum <$> try enumValue
<|> List <$> listValue
<|> Object <$> objectValue
<|> List <$> brackets (some value)
<|> Object <$> braces (some $ objectField value)
<?> "value error!"
where
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!"
booleanValue :: Parser Bool
booleanValue = True <$ symbol "true"
<|> False <$ symbol "false"
listValue :: Parser [Value]
listValue = brackets $ some value
objectValue :: Parser [ObjectField]
objectValue = braces $ some objectField
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

102
src/Language/GraphQL/Execute.hs
View File

@ -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

72
src/Language/GraphQL/Execute/Coerce.hs
View File

@ -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

113
src/Language/GraphQL/Execute/Transform.hs
View File

@ -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'

4
src/Language/GraphQL/Type/Definition.hs
View File

@ -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)

9
tests/Language/GraphQL/AST/ParserSpec.hs
View File

@ -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)
@ -142,3 +142,10 @@ spec = describe "Parser" $ do
isHiddenLocally: Boolean
}
|]
it "rejects variables in DefaultValue" $
parse document "" `shouldFailOn` [r|
query ($book: String = "Zarathustra", $author: String = $book) {
title
}
|]

32
tests/Language/GraphQL/Execute/CoerceSpec.hs
View File

@ -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