OSS/graphql
1
1
Fork 1
Code Issues 5 Pull Requests Actions Releases 22 Wiki Activity

Consider __typename when evaluating fragments

Browse Source 
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
CHANGELOG.md
View File

@ -6,6 +6,9 @@ All notable changes to this project will be documented in this file.
- 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).
## [0.6.0.0] - 2019-11-27
### Changed

30
src/Language/GraphQL/AST/Transform.hs
View File

@ -23,7 +23,7 @@ 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)
{ fragments :: HashMap Core.Name Core.Fragment
, fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition
}
@ -65,15 +65,8 @@ 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.SelectionFragmentSpread fragment) =
Right . Core.SelectionFragment <$> fragmentSpread fragment
selection (Full.SelectionInlineFragment fragment)
| (Full.InlineFragment (Just typeCondition) _ selectionSet) <- fragment
= Right
@ -94,12 +87,23 @@ collectFragments = do
_ <- fragmentDefinition nextValue
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 ::
Full.FragmentDefinition ->
TransformT (Seq Core.Selection)
fragmentDefinition (Full.FragmentDefinition name _tc _dirs selections) = do
TransformT Core.Fragment
fragmentDefinition (Full.FragmentDefinition name typeCondition _dirs selections) = do
modify deleteFragmentDefinition
newValue <- appendSelection selections
fragmentSelection <- appendSelection selections
let newValue = Core.Fragment typeCondition fragmentSelection
modify $ insertFragment newValue
liftJust newValue
where

4
src/Language/GraphQL/Schema.hs
View File

@ -131,8 +131,8 @@ resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
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'

45
tests/Test/FragmentSpec.hs
View File

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