1
0
forked from OSS/graphql

Support directives (skip and include)

Fixes .
This commit is contained in:
Eugen Wissner 2019-12-06 22:52:24 +01:00
parent fc9ad9c4a1
commit 3c1a5c800f
6 changed files with 211 additions and 33 deletions

View File

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

View File

@ -38,6 +38,7 @@ library:
source-dirs: src
other-modules:
- Language.GraphQL.AST.Transform
- Language.GraphQL.Execute.Directive
tests:
tasty:

View File

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

View File

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

View File

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

View File

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