Consider __typename when evaluating fragments

Fixes #30.
This commit is contained in:
Eugen Wissner 2019-12-01 20:43:19 +01:00
parent def52ddc20
commit fc9ad9c4a1
4 changed files with 153 additions and 119 deletions

View File

@ -6,6 +6,9 @@ All notable changes to this project will be documented in this file.
- Parsing multiple string arguments, such as - Parsing multiple string arguments, such as
`login(username: "username", password: "password")` would fail on the comma `login(username: "username", password: "password")` would fail on the comma
due to strings not having a space consumer. 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).
## [0.6.0.0] - 2019-11-27 ## [0.6.0.0] - 2019-11-27
### Changed ### Changed

View File

@ -23,7 +23,7 @@ import qualified Language.GraphQL.Schema as Schema
-- | Associates a fragment name with a list of 'Core.Field's. -- | Associates a fragment name with a list of 'Core.Field's.
data Replacement = Replacement data Replacement = Replacement
{ fragments :: HashMap Core.Name (Seq Core.Selection) { fragments :: HashMap Core.Name Core.Fragment
, fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition
} }
@ -65,15 +65,8 @@ selection ::
Full.Selection -> Full.Selection ->
TransformT (Either (Seq Core.Selection) Core.Selection) TransformT (Either (Seq Core.Selection) Core.Selection)
selection (Full.SelectionField fld) = Right . Core.SelectionField <$> field fld selection (Full.SelectionField fld) = Right . Core.SelectionField <$> field fld
selection (Full.SelectionFragmentSpread (Full.FragmentSpread name _)) = do selection (Full.SelectionFragmentSpread fragment) =
fragments' <- gets fragments Right . Core.SelectionFragment <$> fragmentSpread fragment
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) selection (Full.SelectionInlineFragment fragment)
| (Full.InlineFragment (Just typeCondition) _ selectionSet) <- fragment | (Full.InlineFragment (Just typeCondition) _ selectionSet) <- fragment
= Right = Right
@ -94,12 +87,23 @@ collectFragments = do
_ <- fragmentDefinition nextValue _ <- fragmentDefinition nextValue
collectFragments collectFragments
fragmentSpread :: Full.FragmentSpread -> TransformT Core.Fragment
fragmentSpread (Full.FragmentSpread name _) = do
fragments' <- gets fragments
maybe lookupDefinition liftJust (HashMap.lookup name fragments')
where
lookupDefinition = do
fragmentDefinitions' <- gets fragmentDefinitions
found <- lift . lift $ HashMap.lookup name fragmentDefinitions'
fragmentDefinition found
fragmentDefinition :: fragmentDefinition ::
Full.FragmentDefinition -> Full.FragmentDefinition ->
TransformT (Seq Core.Selection) TransformT Core.Fragment
fragmentDefinition (Full.FragmentDefinition name _tc _dirs selections) = do fragmentDefinition (Full.FragmentDefinition name typeCondition _dirs selections) = do
modify deleteFragmentDefinition modify deleteFragmentDefinition
newValue <- appendSelection selections fragmentSelection <- appendSelection selections
let newValue = Core.Fragment typeCondition fragmentSelection
modify $ insertFragment newValue modify $ insertFragment newValue
liftJust newValue liftJust newValue
where where

View File

@ -131,8 +131,8 @@ resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
tryResolvers (SelectionField fld@(Field _ name _ _)) tryResolvers (SelectionField fld@(Field _ name _ _))
= maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers name) resolvers = maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers name) resolvers
tryResolvers (SelectionFragment (Fragment typeCondition selections')) = do tryResolvers (SelectionFragment (Fragment typeCondition selections')) = do
that <- maybe (return "") resolveTypeName (find (compareResolvers "__typename") resolvers) that <- traverse resolveTypeName (find (compareResolvers "__typename") resolvers)
if Aeson.String typeCondition == that if maybe True (Aeson.String typeCondition ==) that
then fmap fold . traverse tryResolvers $ selections' then fmap fold . traverse tryResolvers $ selections'
else return mempty else return mempty
compareResolvers name (Resolver name' _) = name == name' compareResolvers name (Resolver name' _) = name == name'

View File

@ -48,7 +48,8 @@ hasErrors (Object object') = HashMap.member "errors" object'
hasErrors _ = True hasErrors _ = True
spec :: Spec spec :: Spec
spec = describe "Inline fragment executor" $ do spec = do
describe "Inline fragment executor" $ do
it "chooses the first selection if the type matches" $ do it "chooses the first selection if the type matches" $ do
actual <- graphql (garment "Hat" :| []) inlineQuery actual <- graphql (garment "Hat" :| []) inlineQuery
let expected = object let expected = object
@ -103,7 +104,8 @@ spec = describe "Inline fragment executor" $ do
actual <- graphql (size :| []) query actual <- graphql (size :| []) query
actual `shouldNotSatisfy` hasErrors actual `shouldNotSatisfy` hasErrors
it "evaluates nested fragments" $ do describe "Fragment spread executor" $ do
it "evaluates fragment spreads" $ do
let query = [r| let query = [r|
{ {
...circumferenceFragment ...circumferenceFragment
@ -112,10 +114,6 @@ spec = describe "Inline fragment executor" $ do
fragment circumferenceFragment on Hat { fragment circumferenceFragment on Hat {
circumference circumference
} }
fragment hatFragment on Hat {
...circumferenceFragment
}
|] |]
actual <- graphql (circumference :| []) query actual <- graphql (circumference :| []) query
@ -126,11 +124,13 @@ spec = describe "Inline fragment executor" $ do
] ]
in actual `shouldBe` expected in actual `shouldBe` expected
it "evaluates fragments defined in any order" $ do it "evaluates nested fragments" $ do
let query = [r| let query = [r|
{ {
garment {
...circumferenceFragment ...circumferenceFragment
} }
}
fragment circumferenceFragment on Hat { fragment circumferenceFragment on Hat {
...hatFragment ...hatFragment
@ -141,15 +141,17 @@ spec = describe "Inline fragment executor" $ do
} }
|] |]
actual <- graphql (circumference :| []) query actual <- graphql (garment "Hat" :| []) query
let expected = object let expected = object
[ "data" .= object [ "data" .= object
[ "garment" .= object
[ "circumference" .= (60 :: Int) [ "circumference" .= (60 :: Int)
] ]
] ]
]
in actual `shouldBe` expected in actual `shouldBe` expected
it "rejects recursive" $ do it "rejects recursive fragments" $ do
let query = [r| let query = [r|
{ {
...circumferenceFragment ...circumferenceFragment
@ -162,3 +164,28 @@ spec = describe "Inline fragment executor" $ do
actual <- graphql (circumference :| []) query actual <- graphql (circumference :| []) query
actual `shouldSatisfy` hasErrors 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