diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/graphql.cabal b/graphql.cabal --- a/graphql.cabal +++ b/graphql.cabal @@ -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 diff --git a/src/Language/GraphQL/AST/Core.hs b/src/Language/GraphQL/AST/Core.hs --- a/src/Language/GraphQL/AST/Core.hs +++ b/src/Language/GraphQL/AST/Core.hs @@ -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 diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs --- a/src/Language/GraphQL/AST/Encoder.hs +++ b/src/Language/GraphQL/AST/Encoder.hs @@ -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 diff --git a/src/Language/GraphQL/AST/Lexer.hs b/src/Language/GraphQL/AST/Lexer.hs --- a/src/Language/GraphQL/AST/Lexer.hs +++ b/src/Language/GraphQL/AST/Lexer.hs @@ -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 diff --git a/src/Language/GraphQL/AST/Transform.hs b/src/Language/GraphQL/AST/Transform.hs deleted file mode 100644 --- a/src/Language/GraphQL/AST/Transform.hs +++ /dev/null @@ -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 diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -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 diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs new file mode 100644 --- /dev/null +++ b/src/Language/GraphQL/Execute/Transform.hs @@ -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' diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs --- a/src/Language/GraphQL/Schema.hs +++ b/src/Language/GraphQL/Schema.hs @@ -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' diff --git a/src/Language/GraphQL/Type/Directive.hs b/src/Language/GraphQL/Type/Directive.hs new file mode 100644 --- /dev/null +++ b/src/Language/GraphQL/Type/Directive.hs @@ -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' diff --git a/tests/Language/GraphQL/AST/EncoderSpec.hs b/tests/Language/GraphQL/AST/EncoderSpec.hs --- a/tests/Language/GraphQL/AST/EncoderSpec.hs +++ b/tests/Language/GraphQL/AST/EncoderSpec.hs @@ -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 + """) +} +|] diff --git a/tests/Language/GraphQL/AST/ParserSpec.hs b/tests/Language/GraphQL/AST/ParserSpec.hs --- a/tests/Language/GraphQL/AST/ParserSpec.hs +++ b/tests/Language/GraphQL/AST/ParserSpec.hs @@ -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""") + }|] diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/DirectiveSpec.hs @@ -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 diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs --- a/tests/Test/FragmentSpec.hs +++ b/tests/Test/FragmentSpec.hs @@ -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