From 3c1a5c800f382db0ae0c7a74ba3a5a1fdc4c23cb Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Fri, 6 Dec 2019 22:52:24 +0100 Subject: [PATCH] Support directives (skip and include) Fixes #24. --- CHANGELOG.md | 3 + package.yaml | 1 + src/Language/GraphQL/AST/Core.hs | 10 +++ src/Language/GraphQL/AST/Transform.hs | 96 +++++++++++++++-------- src/Language/GraphQL/Execute/Directive.hs | 50 ++++++++++++ tests/Test/DirectiveSpec.hs | 84 ++++++++++++++++++++ 6 files changed, 211 insertions(+), 33 deletions(-) create mode 100644 src/Language/GraphQL/Execute/Directive.hs create mode 100644 tests/Test/DirectiveSpec.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index 38d5217..5cc152c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -10,6 +10,9 @@ All notable changes to this project will be documented in this file. resolver is missing, it is assumed that the type condition is satisfied (all fragments are included). +### Added +- Directive support (@skip and @include). + ## [0.6.0.0] - 2019-11-27 ### Changed - `Language.GraphQL.Encoder` moved to `Language.GraphQL.AST.Encoder`. diff --git a/package.yaml b/package.yaml index c2c5028..222b64e 100644 --- a/package.yaml +++ b/package.yaml @@ -38,6 +38,7 @@ library: source-dirs: src other-modules: - Language.GraphQL.AST.Transform + - Language.GraphQL.Execute.Directive tests: tasty: diff --git a/src/Language/GraphQL/AST/Core.hs b/src/Language/GraphQL/AST/Core.hs index f7a008f..7ba4830 100644 --- 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(..) @@ -39,6 +41,14 @@ data Field -- | 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 = Fragment TypeCondition (Seq Selection) diff --git a/src/Language/GraphQL/AST/Transform.hs b/src/Language/GraphQL/AST/Transform.hs index 4822248..fadf929 100644 --- a/src/Language/GraphQL/AST/Transform.hs +++ b/src/Language/GraphQL/AST/Transform.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE TupleSections #-} {-# 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 @@ -19,6 +19,7 @@ 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.Execute.Directive as Directive import qualified Language.GraphQL.Schema as Schema -- | Associates a fragment name with a list of 'Core.Field's. @@ -46,7 +47,6 @@ document subs document' = -- * Operation --- TODO: Replace Maybe by MonadThrow CustomError operations :: [Full.OperationDefinition] -> TransformT Core.Document operations operations' = do coreOperations <- traverse operation operations' @@ -61,20 +61,34 @@ operation (Full.OperationDefinition Full.Query name _vars _dirs 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 fld) = Right . Core.SelectionField <$> field fld +selection (Full.SelectionField field') = + maybe (Left mempty) (Right . Core.SelectionField) <$> field field' selection (Full.SelectionFragmentSpread fragment) = - Right . Core.SelectionFragment <$> fragmentSpread fragment -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 + 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 @@ -87,10 +101,27 @@ collectFragments = do _ <- fragmentDefinition nextValue collectFragments -fragmentSpread :: Full.FragmentSpread -> TransformT Core.Fragment -fragmentSpread (Full.FragmentSpread name _) = do +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 - maybe lookupDefinition liftJust (HashMap.lookup name fragments') + fragment <- maybe lookupDefinition liftJust (HashMap.lookup name fragments') + pure $ fragment <$ spreadDirectives where lookupDefinition = do fragmentDefinitions' <- gets fragmentDefinitions @@ -100,10 +131,10 @@ fragmentSpread (Full.FragmentSpread name _) = do fragmentDefinition :: Full.FragmentDefinition -> TransformT Core.Fragment -fragmentDefinition (Full.FragmentDefinition name typeCondition _dirs selections) = do +fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do modify deleteFragmentDefinition fragmentSelection <- appendSelection selections - let newValue = Core.Fragment typeCondition fragmentSelection + let newValue = Core.Fragment type' fragmentSelection modify $ insertFragment newValue liftJust newValue where @@ -113,11 +144,20 @@ fragmentDefinition (Full.FragmentDefinition name typeCondition _dirs selections) 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' +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 @@ -138,17 +178,7 @@ 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 +objectField (Full.ObjectField name value') = (name,) <$> value value' liftJust :: forall a. a -> TransformT a liftJust = lift . lift . Just diff --git a/src/Language/GraphQL/Execute/Directive.hs b/src/Language/GraphQL/Execute/Directive.hs new file mode 100644 index 0000000..733b6cf --- /dev/null +++ b/src/Language/GraphQL/Execute/Directive.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Language.GraphQL.Execute.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/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs new file mode 100644 index 0000000..2224bc5 --- /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