Move functional tests

graphql-spice.cabal

@@ -5,10 +5,8 @@ version:            0.1.0.0
 synopsis:           GraphQL with batteries
 description:        Various extensions and convenience functions  for the core
                     graphql package.
-
+homepage:           https://www.caraus.tech/projects/pub-graphql-spice
--- A URL where users can report bugs.
+bug-reports:        https://www.caraus.tech/projects/pub-graphql-spice/issues
--- bug-reports:
-
 license:            MPL-2.0
 license-files:      LICENSE
 author:             Eugen Wissner <belka@caraus.de>
@@ -17,6 +15,8 @@ maintainer:         belka@caraus.de
 copyright:          (c) 2021 Eugen Wissner
 category:           Language
 extra-source-files: CHANGELOG.md
+tested-with:
+    GHC == 8.10.7
 
 source-repository head
   type: git
@@ -29,6 +29,27 @@ library
     hs-source-dirs:   src
     ghc-options: -Wall
     build-depends:
+--      aeson >= 2.0.2.0 && < 2.1
         base ^>=4.14.3.0
       , graphql >= 1.0.1.0 && < 1.1
     default-language: Haskell2010
+
+
+test-suite graphql-test
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
+  other-modules:
+      Language.GraphQL.DirectiveSpec
+      Language.GraphQL.FragmentSpec
+      Language.GraphQL.RootOperationSpec
+  hs-source-dirs:
+      tests
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall
+  build-depends:
+      aeson
+    , base >= 4.8 && < 5
+    , graphql
+    , hspec >= 2.9.1 && < 3
+    , text
+    , unordered-containers
+  default-language: Haskell2010

tests/Language/GraphQL/DirectiveSpec.hs

@@ -0,0 +1,92 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Language.GraphQL.DirectiveSpec
+    ( spec
+    ) where
+
+import Data.Aeson (object, (.=))
+import qualified Data.Aeson as Aeson
+import qualified Data.HashMap.Strict as HashMap
+import Language.GraphQL
+import Language.GraphQL.TH
+import Language.GraphQL.Type
+import qualified Language.GraphQL.Type.Out as Out
+import Test.Hspec (Spec, describe, it)
+import Test.Hspec.GraphQL
+
+experimentalResolver :: Schema IO
+experimentalResolver = schema queryType Nothing Nothing mempty
+  where
+    queryType = Out.ObjectType "Query" Nothing []
+        $ HashMap.singleton "experimentalField"
+        $ Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
+        $ pure $ Int 5
+
+emptyObject :: Aeson.Object
+emptyObject = HashMap.singleton "data" $ object []
+
+spec :: Spec
+spec =
+    describe "Directive executor" $ do
+        it "should be able to @skip fields" $ do
+            let sourceQuery = [gql|
+              {
+                experimentalField @skip(if: true)
+              }
+            |]
+
+            actual <- graphql experimentalResolver sourceQuery
+            actual `shouldResolveTo` emptyObject
+
+        it "should not skip fields if @skip is false" $ do
+            let sourceQuery = [gql|
+              {
+                experimentalField @skip(if: false)
+              }
+            |]
+                expected = HashMap.singleton "data"
+                    $ object
+                        [ "experimentalField" .= (5 :: Int)
+                        ]
+            actual <- graphql experimentalResolver sourceQuery
+            actual `shouldResolveTo` expected
+
+        it "should skip fields if @include is false" $ do
+            let sourceQuery = [gql|
+              {
+                experimentalField @include(if: false)
+              }
+            |]
+
+            actual <- graphql experimentalResolver sourceQuery
+            actual `shouldResolveTo` emptyObject
+
+        it "should be able to @skip a fragment spread" $ do
+            let sourceQuery = [gql|
+              {
+                ...experimentalFragment @skip(if: true)
+              }
+
+              fragment experimentalFragment on Query {
+                experimentalField
+              }
+            |]
+
+            actual <- graphql experimentalResolver sourceQuery
+            actual `shouldResolveTo` emptyObject
+
+        it "should be able to @skip an inline fragment" $ do
+            let sourceQuery = [gql|
+              {
+                ... on Query @skip(if: true) {
+                  experimentalField
+                }
+              }
+            |]
+
+            actual <- graphql experimentalResolver sourceQuery
+            actual `shouldResolveTo` emptyObject

tests/Language/GraphQL/FragmentSpec.hs

@@ -0,0 +1,204 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Language.GraphQL.FragmentSpec
+    ( spec
+    ) where
+
+import Data.Aeson ((.=))
+import qualified Data.Aeson as Aeson
+import qualified Data.HashMap.Strict as HashMap
+import Data.Text (Text)
+import Language.GraphQL
+import Language.GraphQL.Type
+import qualified Language.GraphQL.Type.Out as Out
+import Language.GraphQL.TH
+import Test.Hspec (Spec, describe, it)
+import Test.Hspec.GraphQL
+
+size :: (Text, Value)
+size = ("size", String "L")
+
+circumference :: (Text, Value)
+circumference = ("circumference", Int 60)
+
+garment :: Text -> (Text, Value)
+garment typeName =
+    ("garment",  Object $ HashMap.fromList
+        [ if typeName == "Hat" then circumference else size
+        , ("__typename", String typeName)
+        ]
+    )
+
+inlineQuery :: Text
+inlineQuery = [gql|
+  {
+    garment {
+      ... on Hat {
+        circumference
+      }
+      ... on Shirt {
+        size
+      }
+    }
+  }
+|]
+
+shirtType :: Out.ObjectType IO
+shirtType = Out.ObjectType "Shirt" Nothing [] $ HashMap.fromList
+    [ ("size", sizeFieldType)
+    ]
+
+hatType :: Out.ObjectType IO
+hatType = Out.ObjectType "Hat" Nothing [] $ HashMap.fromList
+    [ ("size", sizeFieldType)
+    , ("circumference", circumferenceFieldType)
+    ]
+
+circumferenceFieldType :: Out.Resolver IO
+circumferenceFieldType
+    = Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
+    $ pure $ snd circumference
+
+sizeFieldType :: Out.Resolver IO
+sizeFieldType
+    = Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
+    $ pure $ snd size
+
+toSchema :: Text -> (Text, Value) -> Schema IO
+toSchema t (_, resolve) = schema queryType Nothing Nothing mempty
+  where
+    garmentType = Out.UnionType "Garment" Nothing [hatType, shirtType]
+    typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty
+    garmentField = Out.Field Nothing (Out.NamedUnionType garmentType) mempty
+    queryType =
+        case t of
+            "circumference" -> hatType
+            "size" -> shirtType
+            _ -> Out.ObjectType "Query" Nothing []
+                $ HashMap.fromList
+                    [ ("garment", ValueResolver garmentField (pure resolve))
+                    , ("__typename", ValueResolver typeNameField (pure $ String "Shirt"))
+                    ]
+
+spec :: Spec
+spec = do
+    describe "Inline fragment executor" $ do
+        it "chooses the first selection if the type matches" $ do
+            actual <- graphql (toSchema "Hat" $ garment "Hat") inlineQuery
+            let expected = HashMap.singleton "data"
+                    $ Aeson.object
+                        [ "garment" .= Aeson.object
+                            [ "circumference" .= (60 :: Int)
+                            ]
+                        ]
+             in actual `shouldResolveTo` expected
+
+        it "chooses the last selection if the type matches" $ do
+            actual <- graphql (toSchema "Shirt" $ garment "Shirt") inlineQuery
+            let expected = HashMap.singleton "data"
+                    $ Aeson.object
+                        [ "garment" .= Aeson.object
+                            [ "size" .= ("L" :: Text)
+                            ]
+                        ]
+             in actual `shouldResolveTo` expected
+
+        it "embeds inline fragments without type" $ do
+            let sourceQuery = [gql|
+              {
+                circumference
+                ... {
+                  size
+                }
+              }
+            |]
+            actual <- graphql (toSchema "circumference" circumference) sourceQuery
+            let expected = HashMap.singleton "data"
+                    $ Aeson.object
+                        [ "circumference" .= (60 :: Int)
+                        , "size" .= ("L" :: Text)
+                        ]
+             in actual `shouldResolveTo` expected
+
+        it "evaluates fragments on Query" $ do
+            let sourceQuery = [gql|
+              {
+                ... {
+                  size
+                }
+              }
+            |]
+             in graphql (toSchema "size" size) `shouldResolve` sourceQuery
+
+    describe "Fragment spread executor" $ do
+        it "evaluates fragment spreads" $ do
+            let sourceQuery = [gql|
+              {
+                ...circumferenceFragment
+              }
+
+              fragment circumferenceFragment on Hat {
+                circumference
+              }
+            |]
+
+            actual <- graphql (toSchema "circumference" circumference) sourceQuery
+            let expected = HashMap.singleton "data"
+                    $ Aeson.object
+                        [ "circumference" .= (60 :: Int)
+                        ]
+             in actual `shouldResolveTo` expected
+
+        it "evaluates nested fragments" $ do
+            let sourceQuery = [gql|
+              {
+                garment {
+                  ...circumferenceFragment
+                }
+              }
+
+              fragment circumferenceFragment on Hat {
+                ...hatFragment
+              }
+
+              fragment hatFragment on Hat {
+                circumference
+              }
+            |]
+
+            actual <- graphql (toSchema "Hat" $ garment "Hat") sourceQuery
+            let expected = HashMap.singleton "data"
+                    $ Aeson.object
+                        [ "garment" .= Aeson.object
+                            [ "circumference" .= (60 :: Int)
+                            ]
+                        ]
+             in actual `shouldResolveTo` expected
+
+        it "considers type condition" $ do
+            let sourceQuery = [gql|
+              {
+                garment {
+                  ...circumferenceFragment
+                  ...sizeFragment
+                }
+              }
+              fragment circumferenceFragment on Hat {
+                circumference
+              }
+              fragment sizeFragment on Shirt {
+                size
+              }
+            |]
+                expected = HashMap.singleton "data"
+                    $ Aeson.object
+                        [ "garment" .= Aeson.object
+                            [ "circumference" .= (60 :: Int)
+                            ]
+                        ]
+            actual <- graphql (toSchema "Hat" $ garment "Hat") sourceQuery
+            actual `shouldResolveTo` expected

tests/Language/GraphQL/RootOperationSpec.hs

@@ -0,0 +1,72 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Language.GraphQL.RootOperationSpec
+    ( spec
+    ) where
+
+import Data.Aeson ((.=), object)
+import qualified Data.HashMap.Strict as HashMap
+import Language.GraphQL
+import Test.Hspec (Spec, describe, it)
+import Language.GraphQL.TH
+import Language.GraphQL.Type
+import qualified Language.GraphQL.Type.Out as Out
+import Test.Hspec.GraphQL
+
+hatType :: Out.ObjectType IO
+hatType = Out.ObjectType "Hat" Nothing []
+    $ HashMap.singleton "circumference"
+    $ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
+    $ pure $ Int 60
+
+garmentSchema :: Schema IO
+garmentSchema = schema queryType (Just mutationType) Nothing mempty
+  where
+    queryType = Out.ObjectType "Query" Nothing [] hatFieldResolver
+    mutationType = Out.ObjectType "Mutation" Nothing [] incrementFieldResolver
+    garment = pure $ Object $ HashMap.fromList
+        [ ("circumference", Int 60)
+        ]
+    incrementFieldResolver = HashMap.singleton "incrementCircumference"
+        $ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
+        $ pure $ Int 61
+    hatField = Out.Field Nothing (Out.NamedObjectType hatType) mempty
+    hatFieldResolver =
+        HashMap.singleton "garment" $ ValueResolver hatField garment
+
+spec :: Spec
+spec =
+    describe "Root operation type" $ do
+        it "returns objects from the root resolvers" $ do
+            let querySource = [gql|
+              {
+                garment {
+                  circumference
+                }
+              }
+            |]
+                expected = HashMap.singleton "data"
+                    $ object
+                        [ "garment" .= object
+                            [ "circumference" .= (60 :: Int)
+                            ]
+                        ]
+            actual <- graphql garmentSchema querySource
+            actual `shouldResolveTo` expected
+
+        it "chooses Mutation" $ do
+            let querySource = [gql|
+              mutation {
+                incrementCircumference
+              }
+            |]
+                expected = HashMap.singleton "data"
+                    $ object
+                        [ "incrementCircumference" .= (61 :: Int)
+                        ]
+            actual <- graphql garmentSchema querySource
+            actual `shouldResolveTo` expected

tests/Spec.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}