diff --git a/CHANGELOG.md b/CHANGELOG.md index 1b41dfc..38d5217 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/src/Language/GraphQL/AST/Transform.hs b/src/Language/GraphQL/AST/Transform.hs index 95cdfbb..4822248 100644 --- a/src/Language/GraphQL/AST/Transform.hs +++ b/src/Language/GraphQL/AST/Transform.hs @@ -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 diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs index afe068f..fa8bf78 100644 --- a/src/Language/GraphQL/Schema.hs +++ b/src/Language/GraphQL/Schema.hs @@ -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' diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs index 69f1344..de10d63 100644 --- a/tests/Test/FragmentSpec.hs +++ b/tests/Test/FragmentSpec.hs @@ -48,117 +48,144 @@ hasErrors (Object object') = HashMap.member "errors" object' 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 +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 + + 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 + + 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) + ] + ] + ] + in actual `shouldBe` expected + + it "evaluates fragments on Query" $ do + let query = [r|{ + ... { + size + } + }|] + + actual <- graphql (size :| []) query + actual `shouldNotSatisfy` hasErrors + + describe "Fragment spread executor" $ do + it "evaluates fragment spreads" $ do + let query = [r| + { + ...circumferenceFragment + } + + fragment circumferenceFragment on Hat { + circumference + } + |] + + actual <- graphql (circumference :| []) query + let expected = object + [ "data" .= 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 "evaluates nested fragments" $ do + let query = [r| + { + garment { + ...circumferenceFragment + } + } + + fragment circumferenceFragment on Hat { + ...hatFragment + } + + fragment hatFragment on Hat { + circumference + } + |] + + actual <- graphql (garment "Hat" :| []) query + let expected = object + [ "data" .= object + [ "garment" .= object + [ "circumference" .= (60 :: Int) + ] ] ] - ] - 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 "rejects recursive fragments" $ do + let query = [r| + { + ...circumferenceFragment + } - actual <- graphql (resolvers :| []) query - let expected = object - [ "data" .= object - [ "garment" .= object - [ "circumference" .= (60 :: Int) - , "size" .= ("L" :: Text) + fragment circumferenceFragment on Hat { + ...circumferenceFragment + } + |] + + 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) + ] ] ] - ] - in actual `shouldBe` expected - - it "evaluates fragments on Query" $ do - let query = [r|{ - ... { - size - } - }|] - - actual <- graphql (size :| []) query - actual `shouldNotSatisfy` hasErrors - - it "evaluates nested fragments" $ do - let query = [r| - { - ...circumferenceFragment - } - - fragment circumferenceFragment on Hat { - circumference - } - - fragment hatFragment on Hat { - ...circumferenceFragment - } - |] - - actual <- graphql (circumference :| []) query - let expected = object - [ "data" .= object - [ "circumference" .= (60 :: Int) - ] - ] - in actual `shouldBe` expected - - it "evaluates fragments defined in any order" $ do - let query = [r| - { - ...circumferenceFragment - } - - fragment circumferenceFragment on Hat { - ...hatFragment - } - - fragment hatFragment on Hat { - circumference - } - |] - - actual <- graphql (circumference :| []) query - let expected = object - [ "data" .= object - [ "circumference" .= (60 :: Int) - ] - ] - in actual `shouldBe` expected - - it "rejects recursive" $ do - let query = [r| - { - ...circumferenceFragment - } - - fragment circumferenceFragment on Hat { - ...circumferenceFragment - } - |] - - actual <- graphql (circumference :| []) query - actual `shouldSatisfy` hasErrors + actual <- graphql (garment "Hat" :| []) query + actual `shouldBe` expected