From 26cc53ce0678d48bf7d5550df65171e6bf5288d2 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Fri, 22 May 2020 10:11:48 +0200 Subject: [PATCH] Reject variables as default values --- CHANGELOG.md | 9 +- src/Language/GraphQL/AST/Document.hs | 41 ++++- src/Language/GraphQL/AST/Encoder.hs | 152 ++++++++++--------- src/Language/GraphQL/AST/Parser.hs | 48 +++--- src/Language/GraphQL/Execute.hs | 102 +------------ src/Language/GraphQL/Execute/Coerce.hs | 72 +++++++++ src/Language/GraphQL/Execute/Transform.hs | 113 +++++++++++++- src/Language/GraphQL/Type/Definition.hs | 4 + tests/Language/GraphQL/AST/ParserSpec.hs | 11 +- tests/Language/GraphQL/Execute/CoerceSpec.hs | 32 +++- 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