graphql 0.6.0.0 → 0.6.1.0
raw patch · 14 files changed
+656/−364 lines, 14 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Language.GraphQL.AST.Core: Arguments :: HashMap Name Value -> Arguments
+ Language.GraphQL.AST.Core: Directive :: Name -> Arguments -> Directive
+ Language.GraphQL.AST.Core: data Directive
+ Language.GraphQL.AST.Core: instance GHC.Classes.Eq Language.GraphQL.AST.Core.Arguments
+ Language.GraphQL.AST.Core: instance GHC.Classes.Eq Language.GraphQL.AST.Core.Directive
+ Language.GraphQL.AST.Core: instance GHC.Show.Show Language.GraphQL.AST.Core.Arguments
+ Language.GraphQL.AST.Core: instance GHC.Show.Show Language.GraphQL.AST.Core.Directive
+ Language.GraphQL.AST.Core: newtype Arguments
Files
- CHANGELOG.md +15/−0
- graphql.cabal +4/−2
- src/Language/GraphQL/AST/Core.hs +10/−0
- src/Language/GraphQL/AST/Encoder.hs +136/−105
- src/Language/GraphQL/AST/Lexer.hs +2/−2
- src/Language/GraphQL/AST/Transform.hs +0/−150
- src/Language/GraphQL/Execute.hs +1/−1
- src/Language/GraphQL/Execute/Transform.hs +184/−0
- src/Language/GraphQL/Schema.hs +2/−2
- src/Language/GraphQL/Type/Directive.hs +50/−0
- tests/Language/GraphQL/AST/EncoderSpec.hs +38/−11
- tests/Language/GraphQL/AST/ParserSpec.hs +12/−0
- tests/Test/DirectiveSpec.hs +84/−0
- tests/Test/FragmentSpec.hs +118/−91
CHANGELOG.md view
@@ -1,6 +1,20 @@ # Change Log All notable changes to this project will be documented in this file. +## [0.6.1.0] - 2019-12-23+### Fixed+- Parsing multiple string arguments, such as + `login(username: "username", password: "password")` would fail on the comma+ due to strings not having a space consumer.+- Fragment spread is evaluated based on the `__typename` resolver. If the+ resolver is missing, it is assumed that the type condition is satisfied (all+ fragments are included).+- Escaping characters during encoding.++### Added+- Directive support (@skip and @include).+- Pretifying multi-line string arguments as block strings.+ ## [0.6.0.0] - 2019-11-27 ### Changed - `Language.GraphQL.Encoder` moved to `Language.GraphQL.AST.Encoder`.@@ -148,6 +162,7 @@ ### Added - Data types for the GraphQL language. +[0.6.1.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.0.0...v0.6.1.0 [0.6.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.5.1.0...v0.6.0.0 [0.5.1.0]: https://github.com/caraus-ecms/graphql/compare/v0.5.0.1...v0.5.1.0 [0.5.0.1]: https://github.com/caraus-ecms/graphql/compare/v0.5.0.0...v0.5.0.1
graphql.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.12 name: graphql-version: 0.6.0.0+version: 0.6.1.0 license: BSD3 license-file: LICENSE copyright: (c) 2019 Eugen Wissner,@@ -44,7 +44,8 @@ Language.GraphQL.Type hs-source-dirs: src other-modules:- Language.GraphQL.AST.Transform+ Language.GraphQL.Execute.Transform+ Language.GraphQL.Type.Directive default-language: Haskell2010 build-depends: aeson >=1.4.6.0 && <1.5,@@ -64,6 +65,7 @@ Language.GraphQL.AST.LexerSpec Language.GraphQL.AST.ParserSpec Language.GraphQL.ErrorSpec+ Test.DirectiveSpec Test.FragmentSpec Test.KitchenSinkSpec Test.StarWars.Data
src/Language/GraphQL/AST/Core.hs view
@@ -2,6 +2,8 @@ module Language.GraphQL.AST.Core ( Alias , Argument(..)+ , Arguments(..)+ , Directive(..) , Document , Field(..) , Fragment(..)@@ -38,6 +40,14 @@ -- | Single argument. data Argument = Argument Name Value deriving (Eq, Show)++-- | Argument list.+newtype Arguments = Arguments (HashMap Name Value)+ deriving (Eq, Show)++-- | Directive.+data Directive = Directive Name Arguments+ deriving (Eq, Show) -- | Represents fragments and inline fragments. data Fragment
src/Language/GraphQL/AST/Encoder.hs view
@@ -13,13 +13,17 @@ , value ) where +import Data.Char (ord) import Data.Foldable (fold) import Data.Monoid ((<>))-import qualified Data.List.NonEmpty as NonEmpty (toList)-import Data.Text.Lazy (Text)-import qualified Data.Text.Lazy as Text.Lazy-import Data.Text.Lazy.Builder (toLazyText)-import Data.Text.Lazy.Builder.Int (decimal)+import qualified Data.List.NonEmpty as NonEmpty+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Lazy as Lazy (Text)+import qualified Data.Text.Lazy as Lazy.Text+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 @@ -40,17 +44,17 @@ minified = Minified -- | Converts a 'Full.Document' into a string.-document :: Formatter -> Full.Document -> Text+document :: Formatter -> Full.Document -> Lazy.Text document formatter defs- | Pretty _ <- formatter = Text.Lazy.intercalate "\n" encodeDocument- | Minified <-formatter = Text.Lazy.snoc (mconcat encodeDocument) '\n'+ | Pretty _ <- formatter = Lazy.Text.intercalate "\n" encodeDocument+ | Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n' where encodeDocument = NonEmpty.toList $ definition formatter <$> defs -- | Converts a 'Full.Definition' into a string.-definition :: Formatter -> Full.Definition -> Text+definition :: Formatter -> Full.Definition -> Lazy.Text definition formatter x- | Pretty _ <- formatter = Text.Lazy.snoc (encodeDefinition x) '\n'+ | Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n' | Minified <- formatter = encodeDefinition x where encodeDefinition (Full.DefinitionOperation operation)@@ -58,7 +62,7 @@ encodeDefinition (Full.DefinitionFragment fragment) = fragmentDefinition formatter fragment -operationDefinition :: Formatter -> Full.OperationDefinition -> Text+operationDefinition :: Formatter -> Full.OperationDefinition -> Lazy.Text operationDefinition formatter (Full.OperationSelectionSet sels) = selectionSet formatter sels operationDefinition formatter (Full.OperationDefinition Full.Query name vars dirs sels)@@ -66,99 +70,106 @@ operationDefinition formatter (Full.OperationDefinition Full.Mutation name vars dirs sels) = "mutation " <> node formatter name vars dirs sels -node :: Formatter- -> Maybe Full.Name- -> [Full.VariableDefinition]- -> [Full.Directive]- -> Full.SelectionSet- -> Text+node :: Formatter ->+ Maybe Full.Name ->+ [Full.VariableDefinition] ->+ [Full.Directive] ->+ Full.SelectionSet ->+ Lazy.Text node formatter name vars dirs sels- = Text.Lazy.fromStrict (fold name)+ = Lazy.Text.fromStrict (fold name) <> optempty (variableDefinitions formatter) vars <> optempty (directives formatter) dirs <> eitherFormat formatter " " mempty <> selectionSet formatter sels -variableDefinitions :: Formatter -> [Full.VariableDefinition] -> Text+variableDefinitions :: Formatter -> [Full.VariableDefinition] -> Lazy.Text variableDefinitions formatter = parensCommas formatter $ variableDefinition formatter -variableDefinition :: Formatter -> Full.VariableDefinition -> Text+variableDefinition :: Formatter -> Full.VariableDefinition -> Lazy.Text variableDefinition formatter (Full.VariableDefinition var ty dv) = variable var <> eitherFormat formatter ": " ":" <> type' ty <> maybe mempty (defaultValue formatter) dv -defaultValue :: Formatter -> Full.Value -> Text+defaultValue :: Formatter -> Full.Value -> Lazy.Text defaultValue formatter val = eitherFormat formatter " = " "=" <> value formatter val -variable :: Full.Name -> Text-variable var = "$" <> Text.Lazy.fromStrict var+variable :: Full.Name -> Lazy.Text+variable var = "$" <> Lazy.Text.fromStrict var -selectionSet :: Formatter -> Full.SelectionSet -> Text+selectionSet :: Formatter -> Full.SelectionSet -> Lazy.Text selectionSet formatter = bracesList formatter (selection formatter) . NonEmpty.toList -selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Text+selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Lazy.Text selectionSetOpt formatter = bracesList formatter $ selection formatter -selection :: Formatter -> Full.Selection -> Text-selection formatter = Text.Lazy.append indent . f+indent :: (Integral a) => a -> Lazy.Text+indent indentation = Lazy.Text.replicate (fromIntegral indentation) " "++selection :: Formatter -> Full.Selection -> Lazy.Text+selection formatter = Lazy.Text.append indent' . encodeSelection where- f (Full.SelectionField x) = field incrementIndent x- f (Full.SelectionInlineFragment x) = inlineFragment incrementIndent x- f (Full.SelectionFragmentSpread x) = fragmentSpread incrementIndent x+ encodeSelection (Full.SelectionField field') = field incrementIndent field'+ encodeSelection (Full.SelectionInlineFragment fragment) =+ inlineFragment incrementIndent fragment+ encodeSelection (Full.SelectionFragmentSpread spread) =+ fragmentSpread incrementIndent spread incrementIndent- | Pretty n <- formatter = Pretty $ n + 1+ | Pretty indentation <- formatter = Pretty $ indentation + 1 | otherwise = Minified- indent- | Pretty n <- formatter = Text.Lazy.replicate (fromIntegral $ n + 1) " "- | otherwise = mempty+ indent'+ | Pretty indentation <- formatter = indent $ indentation + 1+ | otherwise = "" -field :: Formatter -> Full.Field -> Text-field formatter (Full.Field alias name args dirs selso)- = optempty (`Text.Lazy.append` colon) (Text.Lazy.fromStrict $ fold alias)- <> Text.Lazy.fromStrict name+colon :: Formatter -> Lazy.Text+colon formatter = eitherFormat formatter ": " ":"++field :: Formatter -> Full.Field -> Lazy.Text+field formatter (Full.Field alias name args dirs set)+ = optempty prependAlias (fold alias)+ <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args <> optempty (directives formatter) dirs- <> selectionSetOpt'+ <> optempty selectionSetOpt' set where- colon = eitherFormat formatter ": " ":"- selectionSetOpt'- | null selso = mempty- | otherwise = eitherFormat formatter " " mempty <> selectionSetOpt formatter selso+ prependAlias aliasName = Lazy.Text.fromStrict aliasName <> colon formatter+ selectionSetOpt' = (eitherFormat formatter " " "" <>)+ . selectionSetOpt formatter -arguments :: Formatter -> [Full.Argument] -> Text+arguments :: Formatter -> [Full.Argument] -> Lazy.Text arguments formatter = parensCommas formatter $ argument formatter -argument :: Formatter -> Full.Argument -> Text-argument formatter (Full.Argument name v)- = Text.Lazy.fromStrict name- <> eitherFormat formatter ": " ":"- <> value formatter v+argument :: Formatter -> Full.Argument -> Lazy.Text+argument formatter (Full.Argument name value')+ = Lazy.Text.fromStrict name+ <> colon formatter+ <> value formatter value' -- * Fragments -fragmentSpread :: Formatter -> Full.FragmentSpread -> Text+fragmentSpread :: Formatter -> Full.FragmentSpread -> Lazy.Text fragmentSpread formatter (Full.FragmentSpread name ds)- = "..." <> Text.Lazy.fromStrict name <> optempty (directives formatter) ds+ = "..." <> Lazy.Text.fromStrict name <> optempty (directives formatter) ds -inlineFragment :: Formatter -> Full.InlineFragment -> Text+inlineFragment :: Formatter -> Full.InlineFragment -> Lazy.Text inlineFragment formatter (Full.InlineFragment tc dirs sels) = "... on "- <> Text.Lazy.fromStrict (fold tc)+ <> Lazy.Text.fromStrict (fold tc) <> directives formatter dirs <> eitherFormat formatter " " mempty <> selectionSet formatter sels -fragmentDefinition :: Formatter -> Full.FragmentDefinition -> Text+fragmentDefinition :: Formatter -> Full.FragmentDefinition -> Lazy.Text fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels)- = "fragment " <> Text.Lazy.fromStrict name- <> " on " <> Text.Lazy.fromStrict tc+ = "fragment " <> Lazy.Text.fromStrict name+ <> " on " <> Lazy.Text.fromStrict tc <> optempty (directives formatter) dirs <> eitherFormat formatter " " mempty <> selectionSet formatter sels@@ -166,108 +177,128 @@ -- * Miscellaneous -- | Converts a 'Full.Directive' into a string.-directive :: Formatter -> Full.Directive -> Text+directive :: Formatter -> Full.Directive -> Lazy.Text directive formatter (Full.Directive name args)- = "@" <> Text.Lazy.fromStrict name <> optempty (arguments formatter) args+ = "@" <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args -directives :: Formatter -> [Full.Directive] -> Text-directives formatter@(Pretty _) = Text.Lazy.cons ' ' . spaces (directive formatter)+directives :: Formatter -> [Full.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 -> Text+value :: Formatter -> Full.Value -> Lazy.Text value _ (Full.Variable x) = variable x-value _ (Full.Int x) = toLazyText $ decimal x-value _ (Full.Float x) = toLazyText $ realFloat 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 = mempty-value _ (Full.String x) = stringValue $ Text.Lazy.fromStrict x-value _ (Full.Enum x) = Text.Lazy.fromStrict x+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 -booleanValue :: Bool -> Text+booleanValue :: Bool -> Lazy.Text booleanValue True = "true" booleanValue False = "false" -stringValue :: Text -> Text-stringValue- = quotes- . Text.Lazy.replace "\"" "\\\""- . Text.Lazy.replace "\\" "\\\\"+stringValue :: Formatter -> Text -> Lazy.Text+stringValue Minified string = Builder.toLazyText+ $ quote <> Text.foldr (mappend . escape') quote string+ where+ quote = Builder.singleton '\"'+ escape' '\n' = Builder.fromString "\\n"+ escape' char = escape char+stringValue (Pretty indentation) string = byStringType $ Text.lines string+ where+ byStringType [] = "\"\""+ byStringType [line] = Builder.toLazyText+ $ quote <> Text.foldr (mappend . escape) quote line+ byStringType lines' = "\"\"\"\n"+ <> Lazy.Text.unlines (transformLine <$> lines')+ <> indent indentation+ <> "\"\"\""+ transformLine = (indent (indentation + 1) <>)+ . Lazy.Text.fromStrict+ . Text.replace "\"\"\"" "\\\"\"\""+ quote = Builder.singleton '\"' -listValue :: Formatter -> [Full.Value] -> Text+escape :: Char -> Builder+escape char'+ | char' == '\\' = Builder.fromString "\\\\"+ | char' == '\"' = Builder.fromString "\\\""+ | char' == '\b' = Builder.fromString "\\b"+ | char' == '\f' = Builder.fromString "\\f"+ | char' == '\r' = Builder.fromString "\\r"+ | char' < '\x0010' = unicode "\\u000" char'+ | char' < '\x0020' = unicode "\\u00" char'+ | otherwise = Builder.singleton char'+ where+ unicode prefix = mappend (Builder.fromString prefix) . (hexadecimal . ord)++listValue :: Formatter -> [Full.Value] -> Lazy.Text listValue formatter = bracketsCommas formatter $ value formatter -objectValue :: Formatter -> [Full.ObjectField] -> Text+objectValue :: Formatter -> [Full.ObjectField] -> Lazy.Text objectValue formatter = intercalate $ objectField formatter where intercalate f = braces- . Text.Lazy.intercalate (eitherFormat formatter ", " ",")+ . Lazy.Text.intercalate (eitherFormat formatter ", " ",") . fmap f --objectField :: Formatter -> Full.ObjectField -> Text-objectField formatter (Full.ObjectField name v)- = Text.Lazy.fromStrict name <> colon <> value formatter v- where- colon- | Pretty _ <- formatter = ": "- | Minified <- formatter = ":"+objectField :: Formatter -> Full.ObjectField -> Lazy.Text+objectField formatter (Full.ObjectField name value') =+ Lazy.Text.fromStrict name <> colon formatter <> value formatter value' -- | Converts a 'Full.Type' a type into a string.-type' :: Full.Type -> Text-type' (Full.TypeNamed x) = Text.Lazy.fromStrict x+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 -listType :: Full.Type -> Text+listType :: Full.Type -> Lazy.Text listType x = brackets (type' x) -nonNullType :: Full.NonNullType -> Text-nonNullType (Full.NonNullTypeNamed x) = Text.Lazy.fromStrict x <> "!"+nonNullType :: Full.NonNullType -> Lazy.Text+nonNullType (Full.NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!" nonNullType (Full.NonNullTypeList x) = listType x <> "!" -- * Internal -between :: Char -> Char -> Text -> Text-between open close = Text.Lazy.cons open . (`Text.Lazy.snoc` close)+between :: Char -> Char -> Lazy.Text -> Lazy.Text+between open close = Lazy.Text.cons open . (`Lazy.Text.snoc` close) -parens :: Text -> Text+parens :: Lazy.Text -> Lazy.Text parens = between '(' ')' -brackets :: Text -> Text+brackets :: Lazy.Text -> Lazy.Text brackets = between '[' ']' -braces :: Text -> Text+braces :: Lazy.Text -> Lazy.Text braces = between '{' '}' -quotes :: Text -> Text-quotes = between '"' '"'--spaces :: forall a. (a -> Text) -> [a] -> Text-spaces f = Text.Lazy.intercalate "\SP" . fmap f+spaces :: forall a. (a -> Lazy.Text) -> [a] -> Lazy.Text+spaces f = Lazy.Text.intercalate "\SP" . fmap f -parensCommas :: forall a. Formatter -> (a -> Text) -> [a] -> Text+parensCommas :: forall a. Formatter -> (a -> Lazy.Text) -> [a] -> Lazy.Text parensCommas formatter f = parens- . Text.Lazy.intercalate (eitherFormat formatter ", " ",")+ . Lazy.Text.intercalate (eitherFormat formatter ", " ",") . fmap f -bracketsCommas :: Formatter -> (a -> Text) -> [a] -> Text+bracketsCommas :: Formatter -> (a -> Lazy.Text) -> [a] -> Lazy.Text bracketsCommas formatter f = brackets- . Text.Lazy.intercalate (eitherFormat formatter ", " ",")+ . Lazy.Text.intercalate (eitherFormat formatter ", " ",") . fmap f -bracesList :: forall a. Formatter -> (a -> Text) -> [a] -> Text+bracesList :: forall a. Formatter -> (a -> Lazy.Text) -> [a] -> Lazy.Text bracesList (Pretty intendation) f xs- = Text.Lazy.snoc (Text.Lazy.intercalate "\n" content) '\n'- <> (Text.Lazy.snoc $ Text.Lazy.replicate (fromIntegral intendation) " ") '}'+ = Lazy.Text.snoc (Lazy.Text.intercalate "\n" content) '\n'+ <> (Lazy.Text.snoc $ Lazy.Text.replicate (fromIntegral intendation) " ") '}' where content = "{" : fmap f xs-bracesList Minified f xs = braces $ Text.Lazy.intercalate "," $ fmap f xs+bracesList Minified f xs = braces $ Lazy.Text.intercalate "," $ fmap f xs optempty :: (Eq a, Monoid a, Monoid b) => (a -> b) -> a -> b optempty f xs = if xs == mempty then mempty else f xs
src/Language/GraphQL/AST/Lexer.hs view
@@ -134,7 +134,7 @@ -- | Parser for strings. string :: Parser T.Text-string = between "\"" "\"" stringValue+string = between "\"" "\"" stringValue <* spaceConsumer where stringValue = T.pack <$> many stringCharacter stringCharacter = satisfy isStringCharacter1@@ -143,7 +143,7 @@ -- | Parser for block strings. blockString :: Parser T.Text-blockString = between "\"\"\"" "\"\"\"" stringValue+blockString = between "\"\"\"" "\"\"\"" stringValue <* spaceConsumer where stringValue = do byLine <- sepBy (many blockStringCharacter) lineTerminator
− src/Language/GraphQL/AST/Transform.hs
@@ -1,150 +0,0 @@-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ExplicitForAll #-}---- | After the document is parsed, before getting executed the AST is--- transformed into a similar, simpler AST. This module is responsible for--- this transformation.-module Language.GraphQL.AST.Transform- ( document- ) where--import Control.Arrow (first)-import Control.Monad (foldM, unless)-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)-import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap-import qualified Data.List.NonEmpty as NonEmpty-import Data.Sequence (Seq, (<|), (><))-import qualified Language.GraphQL.AST as Full-import qualified Language.GraphQL.AST.Core as Core-import qualified Language.GraphQL.Schema as Schema---- | Associates a fragment name with a list of 'Core.Field's.-data Replacement = Replacement- { fragments :: HashMap Core.Name (Seq Core.Selection)- , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition- }--type TransformT a = StateT Replacement (ReaderT Schema.Subs Maybe) a---- | Rewrites the original syntax tree into an intermediate representation used--- for query execution.-document :: Schema.Subs -> Full.Document -> Maybe Core.Document-document subs document' =- flip runReaderT subs- $ evalStateT (collectFragments >> operations operationDefinitions)- $ Replacement HashMap.empty fragmentTable- where- (fragmentTable, operationDefinitions) = foldr defragment mempty document'- defragment (Full.DefinitionOperation definition) acc =- (definition :) <$> acc- defragment (Full.DefinitionFragment definition) acc =- let (Full.FragmentDefinition name _ _ _) = definition- in first (HashMap.insert name definition) acc---- * Operation---- TODO: Replace Maybe by MonadThrow CustomError-operations :: [Full.OperationDefinition] -> TransformT Core.Document-operations operations' = do- coreOperations <- traverse operation operations'- lift . lift $ NonEmpty.nonEmpty coreOperations--operation :: Full.OperationDefinition -> TransformT Core.Operation-operation (Full.OperationSelectionSet sels) =- operation $ Full.OperationDefinition Full.Query mempty mempty mempty sels--- TODO: Validate Variable definitions with substituter-operation (Full.OperationDefinition Full.Query name _vars _dirs sels) =- Core.Query name <$> appendSelection sels-operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels) =- Core.Mutation name <$> appendSelection sels--selection ::- Full.Selection ->- TransformT (Either (Seq Core.Selection) Core.Selection)-selection (Full.SelectionField fld) = Right . Core.SelectionField <$> field fld-selection (Full.SelectionFragmentSpread (Full.FragmentSpread name _)) = do- fragments' <- gets fragments- Left <$> maybe lookupDefinition liftJust (HashMap.lookup name fragments')- where- lookupDefinition :: TransformT (Seq Core.Selection)- lookupDefinition = do- fragmentDefinitions' <- gets fragmentDefinitions- found <- lift . lift $ HashMap.lookup name fragmentDefinitions'- fragmentDefinition found-selection (Full.SelectionInlineFragment fragment)- | (Full.InlineFragment (Just typeCondition) _ selectionSet) <- fragment- = Right- . Core.SelectionFragment- . Core.Fragment typeCondition- <$> appendSelection selectionSet- | (Full.InlineFragment Nothing _ selectionSet) <- fragment- = Left <$> appendSelection selectionSet---- * Fragment replacement---- | Extract fragment definitions into a single 'HashMap'.-collectFragments :: TransformT ()-collectFragments = do- fragDefs <- gets fragmentDefinitions- let nextValue = head $ HashMap.elems fragDefs- unless (HashMap.null fragDefs) $ do- _ <- fragmentDefinition nextValue- collectFragments--fragmentDefinition ::- Full.FragmentDefinition ->- TransformT (Seq Core.Selection)-fragmentDefinition (Full.FragmentDefinition name _tc _dirs selections) = do- modify deleteFragmentDefinition- newValue <- appendSelection selections- modify $ insertFragment newValue- liftJust newValue- where- deleteFragmentDefinition (Replacement fragments' fragmentDefinitions') =- Replacement fragments' $ HashMap.delete name fragmentDefinitions'- insertFragment newValue (Replacement fragments' fragmentDefinitions') =- let newFragments = HashMap.insert name newValue fragments'- in Replacement newFragments fragmentDefinitions'--field :: Full.Field -> TransformT Core.Field-field (Full.Field a n args _dirs sels) = do- arguments <- traverse argument args- selection' <- appendSelection sels- return $ Core.Field a n arguments selection'--argument :: Full.Argument -> TransformT Core.Argument-argument (Full.Argument n v) = Core.Argument n <$> value v--value :: Full.Value -> TransformT Core.Value-value (Full.Variable n) = do- substitute' <- lift ask- lift . lift $ substitute' n-value (Full.Int i) = pure $ Core.Int i-value (Full.Float f) = pure $ Core.Float f-value (Full.String x) = pure $ Core.String x-value (Full.Boolean b) = pure $ Core.Boolean b-value Full.Null = pure Core.Null-value (Full.Enum e) = pure $ Core.Enum e-value (Full.List l) =- Core.List <$> traverse value l-value (Full.Object o) =- Core.Object . HashMap.fromList <$> traverse objectField o--objectField :: Full.ObjectField -> TransformT (Core.Name, Core.Value)-objectField (Full.ObjectField n v) = (n,) <$> value v--appendSelection ::- Traversable t =>- t Full.Selection ->- TransformT (Seq Core.Selection)-appendSelection = foldM go mempty- where- go acc sel = append acc <$> selection sel- append acc (Left list) = list >< acc- append acc (Right one) = one <| acc--liftJust :: forall a. a -> TransformT a-liftJust = lift . lift . Just
src/Language/GraphQL/Execute.hs view
@@ -15,7 +15,7 @@ import qualified Data.Text as Text import qualified Language.GraphQL.AST as AST import qualified Language.GraphQL.AST.Core as AST.Core-import qualified Language.GraphQL.AST.Transform as Transform+import qualified Language.GraphQL.Execute.Transform as Transform import Language.GraphQL.Error import qualified Language.GraphQL.Schema as Schema
+ src/Language/GraphQL/Execute/Transform.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE TupleSections #-}++-- | After the document is parsed, before getting executed the AST is+-- transformed into a similar, simpler AST. This module is responsible for+-- this transformation.+module Language.GraphQL.Execute.Transform+ ( document+ ) where++import Control.Arrow (first)+import Control.Monad (foldM, unless)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)+import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import qualified Data.List.NonEmpty as NonEmpty+import Data.Sequence (Seq, (<|), (><))+import qualified Language.GraphQL.AST as Full+import qualified Language.GraphQL.AST.Core as Core+import qualified Language.GraphQL.Schema as Schema+import qualified Language.GraphQL.Type.Directive as Directive++-- | Associates a fragment name with a list of 'Core.Field's.+data Replacement = Replacement+ { fragments :: HashMap Core.Name Core.Fragment+ , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition+ }++type TransformT a = StateT Replacement (ReaderT Schema.Subs Maybe) a++liftJust :: forall a. a -> TransformT a+liftJust = lift . lift . Just++-- | Rewrites the original syntax tree into an intermediate representation used+-- for query execution.+document :: Schema.Subs -> Full.Document -> Maybe Core.Document+document subs document' =+ flip runReaderT subs+ $ evalStateT (collectFragments >> operations operationDefinitions)+ $ Replacement HashMap.empty fragmentTable+ where+ (fragmentTable, operationDefinitions) = foldr defragment mempty document'+ defragment (Full.DefinitionOperation definition) acc =+ (definition :) <$> acc+ defragment (Full.DefinitionFragment definition) acc =+ let (Full.FragmentDefinition name _ _ _) = definition+ in first (HashMap.insert name definition) acc++-- * Operation++operations :: [Full.OperationDefinition] -> TransformT Core.Document+operations operations' = do+ coreOperations <- traverse operation operations'+ lift . lift $ NonEmpty.nonEmpty coreOperations++operation :: Full.OperationDefinition -> TransformT Core.Operation+operation (Full.OperationSelectionSet sels) =+ operation $ Full.OperationDefinition Full.Query mempty mempty mempty sels+-- TODO: Validate Variable definitions with substituter+operation (Full.OperationDefinition Full.Query name _vars _dirs sels) =+ Core.Query name <$> appendSelection sels+operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels) =+ Core.Mutation name <$> appendSelection sels++-- * Selection++selection ::+ Full.Selection ->+ TransformT (Either (Seq Core.Selection) Core.Selection)+selection (Full.SelectionField field') =+ maybe (Left mempty) (Right . Core.SelectionField) <$> field field'+selection (Full.SelectionFragmentSpread fragment) =+ maybe (Left mempty) (Right . Core.SelectionFragment)+ <$> fragmentSpread fragment+selection (Full.SelectionInlineFragment fragment) =+ inlineFragment fragment++appendSelection ::+ Traversable t =>+ t Full.Selection ->+ TransformT (Seq Core.Selection)+appendSelection = foldM go mempty+ where+ go acc sel = append acc <$> selection sel+ append acc (Left list) = list >< acc+ append acc (Right one) = one <| acc++directives :: [Full.Directive] -> TransformT [Core.Directive]+directives = traverse directive+ where+ directive (Full.Directive directiveName directiveArguments) =+ Core.Directive directiveName <$> arguments directiveArguments++-- * Fragment replacement++-- | Extract fragment definitions into a single 'HashMap'.+collectFragments :: TransformT ()+collectFragments = do+ fragDefs <- gets fragmentDefinitions+ let nextValue = head $ HashMap.elems fragDefs+ unless (HashMap.null fragDefs) $ do+ _ <- fragmentDefinition nextValue+ collectFragments++inlineFragment ::+ Full.InlineFragment ->+ TransformT (Either (Seq Core.Selection) Core.Selection)+inlineFragment (Full.InlineFragment type' directives' selectionSet) = do+ fragmentDirectives <- Directive.selection <$> directives directives'+ case fragmentDirectives of+ Nothing -> pure $ Left mempty+ _ -> do+ fragmentSelectionSet <- appendSelection selectionSet+ pure $ maybe Left selectionFragment type' fragmentSelectionSet+ where+ selectionFragment typeName = Right+ . Core.SelectionFragment+ . Core.Fragment typeName++fragmentSpread :: Full.FragmentSpread -> TransformT (Maybe Core.Fragment)+fragmentSpread (Full.FragmentSpread name directives') = do+ spreadDirectives <- Directive.selection <$> directives directives'+ fragments' <- gets fragments+ fragment <- maybe lookupDefinition liftJust (HashMap.lookup name fragments')+ pure $ fragment <$ spreadDirectives + where+ lookupDefinition = do+ fragmentDefinitions' <- gets fragmentDefinitions+ found <- lift . lift $ HashMap.lookup name fragmentDefinitions'+ fragmentDefinition found++fragmentDefinition ::+ Full.FragmentDefinition ->+ TransformT Core.Fragment+fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do+ modify deleteFragmentDefinition+ fragmentSelection <- appendSelection selections+ let newValue = Core.Fragment type' fragmentSelection+ modify $ insertFragment newValue+ liftJust newValue+ where+ deleteFragmentDefinition (Replacement fragments' fragmentDefinitions') =+ Replacement fragments' $ HashMap.delete name fragmentDefinitions'+ insertFragment newValue (Replacement fragments' fragmentDefinitions') =+ let newFragments = HashMap.insert name newValue fragments'+ in Replacement newFragments fragmentDefinitions'++field :: Full.Field -> TransformT (Maybe Core.Field)+field (Full.Field alias name arguments' directives' selections) = do+ fieldArguments <- traverse argument arguments'+ fieldSelections <- appendSelection selections+ fieldDirectives <- Directive.selection <$> directives directives'+ let field' = Core.Field alias name fieldArguments fieldSelections+ pure $ field' <$ fieldDirectives++arguments :: [Full.Argument] -> TransformT Core.Arguments+arguments = fmap Core.Arguments . foldM go HashMap.empty+ where+ go arguments' argument' = do+ (Core.Argument name value') <- argument argument'+ return $ HashMap.insert name value' arguments'++argument :: Full.Argument -> TransformT Core.Argument+argument (Full.Argument n v) = Core.Argument n <$> value v++value :: Full.Value -> TransformT Core.Value+value (Full.Variable n) = do+ substitute' <- lift ask+ lift . lift $ substitute' n+value (Full.Int i) = pure $ Core.Int i+value (Full.Float f) = pure $ Core.Float f+value (Full.String x) = pure $ Core.String x+value (Full.Boolean b) = pure $ Core.Boolean b+value Full.Null = pure Core.Null+value (Full.Enum e) = pure $ Core.Enum e+value (Full.List l) =+ Core.List <$> traverse value l+value (Full.Object o) =+ Core.Object . HashMap.fromList <$> traverse objectField o++objectField :: Full.ObjectField -> TransformT (Core.Name, Core.Value)+objectField (Full.ObjectField name value') = (name,) <$> value value'
src/Language/GraphQL/Schema.hs view
@@ -131,8 +131,8 @@ tryResolvers (SelectionField fld@(Field _ name _ _)) = maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers name) resolvers tryResolvers (SelectionFragment (Fragment typeCondition selections')) = do- that <- maybe (return "") resolveTypeName (find (compareResolvers "__typename") resolvers)- if Aeson.String typeCondition == that+ that <- traverse resolveTypeName (find (compareResolvers "__typename") resolvers)+ if maybe True (Aeson.String typeCondition ==) that then fmap fold . traverse tryResolvers $ selections' else return mempty compareResolvers name (Resolver name' _) = name == name'
+ src/Language/GraphQL/Type/Directive.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE OverloadedStrings #-}++module Language.GraphQL.Type.Directive+ ( selection+ ) where++import qualified Data.HashMap.Strict as HashMap+import Language.GraphQL.AST.Core++-- | Directive processing status.+data Status+ = Skip -- ^ Skip the selection and stop directive processing+ | Include Directive -- ^ The directive was processed, try other handlers+ | Continue Directive -- ^ Directive handler mismatch, try other handlers++-- | Takes a list of directives, handles supported directives and excludes them+-- from the result. If the selection should be skipped, returns 'Nothing'.+selection :: [Directive] -> Maybe [Directive]+selection = foldr go (Just [])+ where+ go directive' directives' =+ case (skip . include) (Continue directive') of+ (Include _) -> directives'+ Skip -> Nothing+ (Continue x) -> (x :) <$> directives'++handle :: (Directive -> Status) -> Status -> Status+handle _ Skip = Skip+handle handler (Continue directive) = handler directive+handle handler (Include directive) = handler directive++-- * Directive implementations++skip :: Status -> Status+skip = handle skip'+ where+ skip' directive'@(Directive "skip" (Arguments arguments)) =+ case HashMap.lookup "if" arguments of+ (Just (Boolean True)) -> Skip+ _ -> Include directive'+ skip' directive' = Continue directive'++include :: Status -> Status+include = handle include'+ where+ include' directive'@(Directive "include" (Arguments arguments)) =+ case HashMap.lookup "if" arguments of+ (Just (Boolean True)) -> Include directive'+ _ -> Skip+ include' directive' = Continue directive'
tests/Language/GraphQL/AST/EncoderSpec.hs view
@@ -1,19 +1,46 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} module Language.GraphQL.AST.EncoderSpec ( spec ) where -import Language.GraphQL.AST (Value(..))+import Language.GraphQL.AST import Language.GraphQL.AST.Encoder-import Test.Hspec ( Spec- , describe- , it- , shouldBe- )+import Test.Hspec (Spec, context, describe, it, shouldBe)+import Text.RawString.QQ (r) spec :: Spec-spec = describe "value" $ do- it "escapes \\" $- value minified (String "\\") `shouldBe` "\"\\\\\""- it "escapes quotes" $- value minified (String "\"") `shouldBe` "\"\\\"\""+spec = do+ describe "value" $ do+ context "minified" $ do+ it "escapes \\" $+ value minified (String "\\") `shouldBe` "\"\\\\\""+ it "escapes quotes" $+ value minified (String "\"") `shouldBe` "\"\\\"\""+ it "escapes backspace" $+ value minified (String "a\bc") `shouldBe` "\"a\\bc\""+ it "escapes Unicode" $+ value minified (String "\0") `shouldBe` "\"\\u0000\""++ context "pretty" $ do+ it "uses strings for short string values" $+ value pretty (String "Short text") `shouldBe` "\"Short text\""+ it "uses block strings for text with new lines" $+ value pretty (String "Line 1\nLine 2")+ `shouldBe` "\"\"\"\n Line 1\n Line 2\n\"\"\""+ it "escapes \\ in short strings" $+ value pretty (String "\\") `shouldBe` "\"\\\\\""++ describe "definition" $+ it "indents block strings in arguments" $+ let arguments = [Argument "message" (String "line1\nline2")]+ field = Field Nothing "field" arguments [] []+ set = OperationSelectionSet $ pure $ SelectionField field+ operation = DefinitionOperation set+ in definition pretty operation `shouldBe` [r|{+ field(message: """+ line1+ line2+ """)+}+|]
tests/Language/GraphQL/AST/ParserSpec.hs view
@@ -30,3 +30,15 @@ mutation auth($username: String!, $password: String!){ test }|]++ it "accepts two string arguments" $+ parse document "" `shouldSucceedOn` [r|+ mutation auth{+ test(username: "username", password: "password")+ }|]++ it "accepts two block string arguments" $+ parse document "" `shouldSucceedOn` [r|+ mutation auth{+ test(username: """username""", password: """password""")+ }|]
+ tests/Test/DirectiveSpec.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+module Test.DirectiveSpec+ ( spec+ ) where++import Data.Aeson (Value, object, (.=))+import Data.List.NonEmpty (NonEmpty(..))+import Language.GraphQL+import qualified Language.GraphQL.Schema as Schema+import Test.Hspec (Spec, describe, it, shouldBe)+import Text.RawString.QQ (r)++experimentalResolver :: Schema.Resolver IO+experimentalResolver = Schema.scalar "experimentalField" $ pure (5 :: Int) ++emptyObject :: Value+emptyObject = object+ [ "data" .= object []+ ]++spec :: Spec+spec =+ describe "Directive executor" $ do+ it "should be able to @skip fields" $ do+ let query = [r|+ {+ experimentalField @skip(if: true)+ }+ |]++ actual <- graphql (experimentalResolver :| []) query+ actual `shouldBe` emptyObject++ it "should not skip fields if @skip is false" $ do+ let query = [r|+ {+ experimentalField @skip(if: false)+ }+ |]+ expected = object+ [ "data" .= object+ [ "experimentalField" .= (5 :: Int)+ ]+ ]++ actual <- graphql (experimentalResolver :| []) query+ actual `shouldBe` expected++ it "should skip fields if @include is false" $ do+ let query = [r|+ {+ experimentalField @include(if: false)+ }+ |]++ actual <- graphql (experimentalResolver :| []) query+ actual `shouldBe` emptyObject++ it "should be able to @skip a fragment spread" $ do+ let query = [r|+ {+ ...experimentalFragment @skip(if: true)+ }++ fragment experimentalFragment on ExperimentalType {+ experimentalField+ }+ |]++ actual <- graphql (experimentalResolver :| []) query+ actual `shouldBe` emptyObject++ it "should be able to @skip an inline fragment" $ do+ let query = [r|+ {+ ... on ExperimentalType @skip(if: true) {+ experimentalField+ }+ }+ |]++ actual <- graphql (experimentalResolver :| []) query+ actual `shouldBe` emptyObject
tests/Test/FragmentSpec.hs view
@@ -48,117 +48,144 @@ hasErrors _ = True spec :: Spec-spec = describe "Inline fragment executor" $ do- it "chooses the first selection if the type matches" $ do- actual <- graphql (garment "Hat" :| []) inlineQuery- let expected = object- [ "data" .= object- [ "garment" .= object- [ "circumference" .= (60 :: Int)+spec = do+ describe "Inline fragment executor" $ do+ it "chooses the first selection if the type matches" $ do+ actual <- graphql (garment "Hat" :| []) inlineQuery+ let expected = object+ [ "data" .= object+ [ "garment" .= object+ [ "circumference" .= (60 :: Int)+ ] ] ]- ]- in actual `shouldBe` expected+ in actual `shouldBe` expected - it "chooses the last selection if the type matches" $ do- actual <- graphql (garment "Shirt" :| []) inlineQuery- let expected = object- [ "data" .= object- [ "garment" .= object- [ "size" .= ("L" :: Text)+ it "chooses the last selection if the type matches" $ do+ actual <- graphql (garment "Shirt" :| []) inlineQuery+ let expected = object+ [ "data" .= object+ [ "garment" .= object+ [ "size" .= ("L" :: Text)+ ] ] ]- ]- in actual `shouldBe` expected+ in actual `shouldBe` expected - it "embeds inline fragments without type" $ do- let query = [r|{- garment {- circumference- ... {- size- }- }- }|]- resolvers = Schema.object "garment" $ return [circumference, size]+ it "embeds inline fragments without type" $ do+ let query = [r|{+ garment {+ circumference+ ... {+ size+ }+ }+ }|]+ resolvers = Schema.object "garment" $ return [circumference, size] - actual <- graphql (resolvers :| []) query- let expected = object- [ "data" .= object- [ "garment" .= object- [ "circumference" .= (60 :: Int)- , "size" .= ("L" :: Text)+ actual <- graphql (resolvers :| []) query+ let expected = object+ [ "data" .= object+ [ "garment" .= object+ [ "circumference" .= (60 :: Int)+ , "size" .= ("L" :: Text)+ ] ] ]- ]- in actual `shouldBe` expected-- it "evaluates fragments on Query" $ do- let query = [r|{- ... {- size- }- }|]+ in actual `shouldBe` expected - actual <- graphql (size :| []) query- actual `shouldNotSatisfy` hasErrors+ it "evaluates fragments on Query" $ do+ let query = [r|{+ ... {+ size+ }+ }|] - it "evaluates nested fragments" $ do- let query = [r|- {- ...circumferenceFragment- }+ actual <- graphql (size :| []) query+ actual `shouldNotSatisfy` hasErrors - fragment circumferenceFragment on Hat {- circumference- }+ describe "Fragment spread executor" $ do+ it "evaluates fragment spreads" $ do+ let query = [r|+ {+ ...circumferenceFragment+ } - fragment hatFragment on Hat {- ...circumferenceFragment- }- |]+ fragment circumferenceFragment on Hat {+ circumference+ }+ |] - actual <- graphql (circumference :| []) query- let expected = object- [ "data" .= object- [ "circumference" .= (60 :: Int)+ actual <- graphql (circumference :| []) query+ let expected = object+ [ "data" .= object+ [ "circumference" .= (60 :: Int)+ ] ]- ]- in actual `shouldBe` expected+ in actual `shouldBe` expected - it "evaluates fragments defined in any order" $ do- let query = [r|- {- ...circumferenceFragment- }+ it "evaluates nested fragments" $ do+ let query = [r|+ {+ garment {+ ...circumferenceFragment+ }+ } - fragment circumferenceFragment on Hat {- ...hatFragment- }+ fragment circumferenceFragment on Hat {+ ...hatFragment+ } - fragment hatFragment on Hat {- circumference- }- |]+ fragment hatFragment on Hat {+ circumference+ }+ |] - actual <- graphql (circumference :| []) query- let expected = object- [ "data" .= object- [ "circumference" .= (60 :: Int)+ actual <- graphql (garment "Hat" :| []) query+ let expected = object+ [ "data" .= object+ [ "garment" .= object+ [ "circumference" .= (60 :: Int)+ ]+ ] ]- ]- in actual `shouldBe` expected+ in actual `shouldBe` expected - it "rejects recursive" $ do- let query = [r|- {- ...circumferenceFragment- }+ it "rejects recursive fragments" $ do+ let query = [r|+ {+ ...circumferenceFragment+ } - fragment circumferenceFragment on Hat {- ...circumferenceFragment- }- |]+ fragment circumferenceFragment on Hat {+ ...circumferenceFragment+ }+ |] - actual <- graphql (circumference :| []) query- actual `shouldSatisfy` hasErrors+ actual <- graphql (circumference :| []) query+ actual `shouldSatisfy` hasErrors++ it "considers type condition" $ do+ let query = [r|+ {+ garment {+ ...circumferenceFragment+ ...sizeFragment+ }+ }+ fragment circumferenceFragment on Hat {+ circumference+ }+ fragment sizeFragment on Shirt {+ size+ }+ |]+ expected = object+ [ "data" .= object+ [ "garment" .= object+ [ "circumference" .= (60 :: Int)+ ]+ ]+ ]+ actual <- graphql (garment "Hat" :| []) query+ actual `shouldBe` expected