Put test helpers into Test.Hspec.GraphQL

2022-03-23 21:58:12 +01:00 · 2022-03-23 21:58:12 +01:00 · c93c64a7f4
parent 0cf459b8eb
commit c93c64a7f4
8 changed files with 198 additions and 148 deletions
--- a/cabal.project
+++ b/cabal.project
@ -1,3 +1,9 @@
-packages: . ../graphql
+packages:
+  .
+
+source-repository-package
+  type: git
+  location: git://caraus.tech/pub/graphql.git
+  tag: 8503c0f288201223776f9962438c577241f08c9d

 constraints: graphql -json
--- a/graphql-spice.cabal
+++ b/graphql-spice.cabal
@ -1,7 +1,7 @@
 cabal-version:      2.4

 name:               graphql-spice
-version:            0.1.0.0
+version:            1.0.0.0
 synopsis:           GraphQL with batteries
 description:        Various extensions and convenience functions  for the core
                    graphql package.
@ -10,7 +10,7 @@ homepage:           https://www.caraus.tech/projects/pub-graphql-spice
 bug-reports:        https://www.caraus.tech/projects/pub-graphql-spice/issues
 author:             Eugen Wissner <belka@caraus.de>
 maintainer:         belka@caraus.de
-copyright:          (c) 2021 Eugen Wissner
+copyright:          (c) 2021-2022 Eugen Wissner
 license:            MPL-2.0
 license-files:      LICENSE
 build-type:         Simple
@ -24,20 +24,22 @@ source-repository head

 library
    exposed-modules:
-      Language.GraphQL.Foundation,
-      Language.GraphQL.Serialize
+      Language.GraphQL.JSON,
+      Test.Hspec.GraphQL
    other-modules:
    hs-source-dirs:   src
    ghc-options: -Wall
    build-depends:
      aeson ^>= 2.0.3,
      base ^>=4.14.3.0,
+      conduit ^>= 1.3.4,
      containers ^>= 0.6.2,
      exceptions ^>= 0.10.4,
+      hspec-expectations >= 0.8.2 && < 0.9,
      graphql ^>= 1.0.2,
      megaparsec >= 9.0 && < 10,
      scientific ^>= 0.3.7,
-      text ^>= 1.2.5,
+      text >= 1.2 && < 3,
      vector ^>= 0.12.3,
      unordered-containers ^>= 0.2.16
    default-language: Haskell2010
--- a/src/Language/GraphQL/Foundation.hs
+++ b/src/Language/GraphQL/Foundation.hs
@ -1,58 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE RecordWildCards #-}
-
-module Language.GraphQL.Foundation
-    ( module Language.GraphQL.Serialize
-    , graphql
-    ) where
-
-import Language.GraphQL.Serialize
-import Control.Monad.Catch (MonadCatch)
-import qualified Data.Aeson as Aeson
-import qualified Data.Aeson.Types as Aeson
-import Data.HashMap.Strict (HashMap)
-import qualified Data.Aeson.KeyMap as KeyMap
-import Data.Maybe (catMaybes)
-import qualified Data.Sequence as Seq
-import Data.Text (Text)
-import Data.Vector (Vector)
-import qualified Data.Vector as Vector
-import qualified Language.GraphQL as GraphQL
-import Language.GraphQL.AST
-import Language.GraphQL.Error
-import Language.GraphQL.Type.Schema (Schema)
-import Data.Bifunctor (Bifunctor(..))
-
-- | If the text parses correctly as a @GraphQL@ query the query is
-- executed using the given 'Schema'.
-graphql :: MonadCatch m
-    => Schema m -- ^ Resolvers.
-    -> Text -- ^ Text representing a @GraphQL@ request document.
-    -> m (Either (ResponseEventStream m Aeson.Value) Aeson.Object) -- ^ Response.
-graphql schema = fmap (bimap stream formatResponse)
-    . GraphQL.graphql schema mempty (mempty :: HashMap Name JSON)
-  where
-    stream :: ResponseEventStream m JSON -> ResponseEventStream m Aeson.Value
-    stream = undefined
-    formatResponse :: Response JSON -> Aeson.Object
-    formatResponse Response{ errors, data' = JSON json } =
-        let dataResponse = KeyMap.singleton "data" json
-         in case errors of
-              Seq.Empty -> dataResponse
-              _ -> flip (KeyMap.insert "errors") dataResponse
-                  $ Aeson.Array $ foldr fromError mempty errors
-    fromError :: Error -> Vector Aeson.Value -> Vector Aeson.Value
-    fromError Error{..} = Vector.cons $ Aeson.object $ catMaybes
-        [ Just ("message", Aeson.String message)
-        , toMaybe fromLocation "locations" locations
-        , toMaybe fromPath "path" path
-        ]
-    fromPath (Segment segment) = Aeson.String segment
-    fromPath (Index index) = Aeson.toJSON index
-    fromLocation Location{..} = Aeson.object
-        [ ("line", Aeson.toJSON line)
-        , ("column", Aeson.toJSON column)
-        ]
-    toMaybe _ _ [] = Nothing
-    toMaybe f key xs = Just (key, Aeson.listValue f xs)
--- a/src/Language/GraphQL/Serialize.hs
+++ b/src/Language/GraphQL/Serialize.hs
@ -1,17 +1,30 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}

-module Language.GraphQL.Serialize
+module Language.GraphQL.JSON
    ( JSON(..)
+    , graphql
    ) where

-import qualified Data.Aeson as Aeson
+import Control.Monad.Catch (MonadCatch)
+import qualified Data.Aeson.Types as Aeson
+import Data.Maybe (catMaybes)
+import qualified Data.Sequence as Seq
+import Data.Vector (Vector)
+import qualified Data.Vector as Vector
+import qualified Language.GraphQL as GraphQL
+import Language.GraphQL.AST (Location(..), Name)
+import Language.GraphQL.Error
+import Language.GraphQL.Type.Schema (Schema)
+import Data.Bifunctor (Bifunctor(..))
+import qualified Conduit
 import qualified Data.Aeson.Key as Aeson.Key
 import qualified Data.Aeson.KeyMap as KeyMap
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
 import Data.Scientific (toBoundedInteger, toRealFloat)
 import Data.Text (Text)
-import Language.GraphQL.AST (Name)
 import Language.GraphQL.Execute.Coerce
 import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
 import qualified Language.GraphQL.Type.In as In
@ -100,3 +113,41 @@ instance VariableValue JSON where
            coerced <- coerceVariableValue listType $ JSON variableValue
            pure $ coerced : list 
    coerceVariableValue _ _ = Nothing
+
+-- | If the text parses correctly as a @GraphQL@ query the query is
+-- executed using the given 'Schema'.
+graphql :: MonadCatch m
+    => Schema m -- ^ Resolvers.
+    -> Maybe Text -- ^ Operation name.
+    -> Aeson.Object -- ^ Variables.
+    -> Text -- ^ Text representing a @GraphQL@ request document.
+    -> m (Either (ResponseEventStream m Aeson.Value) Aeson.Object) -- ^ Response.
+graphql schema operationName variableValues = fmap (bimap stream formatResponse)
+    . GraphQL.graphql schema operationName jsonVariables
+  where
+    jsonVariables = JSON <$> KeyMap.toHashMapText variableValues
+    -- stream :: ResponseEventStream m JSON -> ResponseEventStream m Aeson.Value
+    stream = Conduit.mapOutput mapResponse
+    mapResponse response@Response{ data' = JSON json } =
+        response{ data' = json }
+    formatResponse :: Response JSON -> Aeson.Object
+    formatResponse Response{ errors, data' = JSON json } =
+        let dataResponse = KeyMap.singleton "data" json
+         in case errors of
+              Seq.Empty -> dataResponse
+              _ -> flip (KeyMap.insert "errors") dataResponse
+                  $ Aeson.Array $ foldr fromError mempty errors
+    fromError :: Error -> Vector Aeson.Value -> Vector Aeson.Value
+    fromError Error{..} = Vector.cons $ Aeson.object $ catMaybes
+        [ Just ("message", Aeson.String message)
+        , toMaybe fromLocation "locations" locations
+        , toMaybe fromPath "path" path
+        ]
+    fromPath (Segment segment) = Aeson.String segment
+    fromPath (Index index) = Aeson.toJSON index
+    fromLocation Location{..} = Aeson.object
+        [ ("line", Aeson.toJSON line)
+        , ("column", Aeson.toJSON column)
+        ]
+    toMaybe _ _ [] = Nothing
+    toMaybe f key xs = Just (key, Aeson.listValue f xs)
--- a/src/Test/Hspec/GraphQL.hs
+++ b/src/Test/Hspec/GraphQL.hs
@ -0,0 +1,48 @@
+{- 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 ExplicitForAll #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+-- | Test helpers.
+module Test.Hspec.GraphQL
+    ( shouldResolve
+    , shouldResolveTo
+    ) where
+
+import Control.Monad.Catch (MonadCatch)
+import qualified Data.Sequence as Seq
+import Data.Text (Text)
+import Language.GraphQL.Error
+import Language.GraphQL.Execute
+import Test.Hspec.Expectations
+    ( Expectation
+    , expectationFailure
+    , shouldBe
+    , shouldSatisfy
+    )
+
+-- | Asserts that a query resolves to some value.
+shouldResolveTo :: (MonadCatch m, Serialize b, Eq b, Show b)
+    => Either (ResponseEventStream m b) (Response b)
+    -> b
+    -> Expectation
+shouldResolveTo (Right Response{ errors = Seq.Empty, data' }) expected =
+    data' `shouldBe` expected
+shouldResolveTo _ _ = expectationFailure
+    "the query is expected to resolve to a value, but it resolved to an event stream"
+
+-- | Asserts that the response doesn't contain any errors.
+shouldResolve :: (MonadCatch m, Serialize b)
+    => (Text -> IO (Either (ResponseEventStream m b) (Response b)))
+    -> Text
+    -> Expectation
+shouldResolve executor query = do
+    actual <- executor query
+    case actual of
+        Right Response{ errors } -> errors `shouldSatisfy` Seq.null
+        _ -> expectationFailure
+            "the query is expected to resolve to a value, but it resolved to an event stream"
--- a/tests/Language/GraphQL/DirectiveSpec.hs
+++ b/tests/Language/GraphQL/DirectiveSpec.hs
@ -4,19 +4,21 @@

 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE PackageImports #-}
+
 module Language.GraphQL.DirectiveSpec
    ( spec
    ) where

-import Data.Aeson (object, (.=))
-import qualified Data.Aeson as Aeson
+import Language.GraphQL.AST.Document (Name)
+import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
-import Language.GraphQL.Foundation
+import qualified Language.GraphQL as 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
+import "graphql-spice" Test.Hspec.GraphQL

 experimentalResolver :: Schema IO
 experimentalResolver = schema queryType Nothing Nothing mempty
@ -26,9 +28,6 @@ experimentalResolver = schema queryType Nothing Nothing mempty
        $ 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
@ -39,8 +38,8 @@ spec =
              }
            |]

-            actual <- graphql experimentalResolver sourceQuery
-            actual `shouldResolveTo` emptyObject
+            actual <- GraphQL.graphql experimentalResolver Nothing (mempty :: HashMap Name Value) sourceQuery
+            actual `shouldResolveTo` Object mempty

        it "should not skip fields if @skip is false" $ do
            let sourceQuery = [gql|
@ -48,11 +47,8 @@ spec =
                experimentalField @skip(if: false)
              }
            |]
-                expected = HashMap.singleton "data"
-                    $ object
-                        [ "experimentalField" .= (5 :: Int)
-                        ]
-            actual <- graphql experimentalResolver sourceQuery
+                expected = Object $ HashMap.singleton "experimentalField" (Int 5)
+            actual <- GraphQL.graphql experimentalResolver Nothing (mempty :: HashMap Name Value) sourceQuery
            actual `shouldResolveTo` expected

        it "should skip fields if @include is false" $ do
@ -62,8 +58,8 @@ spec =
              }
            |]

-            actual <- graphql experimentalResolver sourceQuery
-            actual `shouldResolveTo` emptyObject
+            actual <- GraphQL.graphql experimentalResolver Nothing (mempty :: HashMap Name Value) sourceQuery
+            actual `shouldResolveTo` Object mempty

        it "should be able to @skip a fragment spread" $ do
            let sourceQuery = [gql|
@ -76,8 +72,8 @@ spec =
              }
            |]

-            actual <- graphql experimentalResolver sourceQuery
-            actual `shouldResolveTo` emptyObject
+            actual <- GraphQL.graphql experimentalResolver Nothing (mempty :: HashMap Name Value) sourceQuery
+            actual `shouldResolveTo` Object mempty

        it "should be able to @skip an inline fragment" $ do
            let sourceQuery = [gql|
@ -88,5 +84,5 @@ spec =
              }
            |]

-            actual <- graphql experimentalResolver sourceQuery
-            actual `shouldResolveTo` emptyObject
+            actual <- GraphQL.graphql experimentalResolver Nothing (mempty :: HashMap Name Value) sourceQuery
+            actual `shouldResolveTo` Object mempty
--- a/tests/Language/GraphQL/FragmentSpec.hs
+++ b/tests/Language/GraphQL/FragmentSpec.hs
@ -4,20 +4,23 @@

 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE PackageImports #-}
+
 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.Foundation
+import Language.GraphQL.AST (Name)
+import Data.HashMap.Strict (HashMap)
 import Language.GraphQL.Type
+import Language.GraphQL.Error
 import qualified Language.GraphQL.Type.Out as Out
 import Language.GraphQL.TH
+import qualified Language.GraphQL as GraphQL
 import Test.Hspec (Spec, describe, it)
-import Test.Hspec.GraphQL
+import "graphql-spice" Test.Hspec.GraphQL

 size :: (Text, Value)
 size = ("size", String "L")
@ -88,23 +91,23 @@ 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)
-                            ]
-                        ]
+            let localSchema = toSchema "Hat" $ garment "Hat"
+            actual <- GraphQL.graphql localSchema Nothing (mempty :: HashMap Name Value) inlineQuery
+            let expected = Object
+                    $ HashMap.singleton "garment"
+                    $ Object
+                    $ HashMap.singleton  "circumference"
+                    $ Int 60
             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)
-                            ]
-                        ]
+            let localSchema = toSchema "Shirt" $ garment "Shirt"
+            actual <- GraphQL.graphql localSchema Nothing (mempty :: HashMap Name Value) inlineQuery
+            let expected = Object
+                    $ HashMap.singleton "garment"
+                    $ Object
+                    $ HashMap.singleton "size"
+                    $ String "L"
             in actual `shouldResolveTo` expected

        it "embeds inline fragments without type" $ do
@ -116,12 +119,12 @@ spec = do
                }
              }
            |]
-            actual <- graphql (toSchema "circumference" circumference) sourceQuery
-            let expected = HashMap.singleton "data"
-                    $ Aeson.object
-                        [ "circumference" .= (60 :: Int)
-                        , "size" .= ("L" :: Text)
-                        ]
+            let localSchema = toSchema "circumference" circumference
+            actual <- GraphQL.graphql localSchema Nothing (mempty :: HashMap Name Value) sourceQuery
+            let expected = Object $ HashMap.fromList
+                    [ ("circumference", Int 60)
+                    , ("size", String  "L")
+                    ]
             in actual `shouldResolveTo` expected

        it "evaluates fragments on Query" $ do
@ -132,7 +135,10 @@ spec = do
                }
              }
            |]
-             in graphql (toSchema "size" size) `shouldResolve` sourceQuery
+                localSchema = toSchema "size" size
+                actual :: Text -> IO (Either (ResponseEventStream IO Value) (Response Value))
+                actual = GraphQL.graphql localSchema Nothing (mempty :: HashMap Name Value)
+             in actual `shouldResolve` sourceQuery

    describe "Fragment spread executor" $ do
        it "evaluates fragment spreads" $ do
@ -145,12 +151,11 @@ spec = do
                circumference
              }
            |]
-
-            actual <- graphql (toSchema "circumference" circumference) sourceQuery
-            let expected = HashMap.singleton "data"
-                    $ Aeson.object
-                        [ "circumference" .= (60 :: Int)
-                        ]
+            let localSchema = toSchema "circumference" circumference
+            actual <- GraphQL.graphql localSchema Nothing (mempty :: HashMap Name Value) sourceQuery
+            let expected = Object
+                    $ HashMap.singleton "circumference"
+                    $ Int 60
             in actual `shouldResolveTo` expected

        it "evaluates nested fragments" $ do
@ -169,14 +174,13 @@ spec = do
                circumference
              }
            |]
-
-            actual <- graphql (toSchema "Hat" $ garment "Hat") sourceQuery
-            let expected = HashMap.singleton "data"
-                    $ Aeson.object
-                        [ "garment" .= Aeson.object
-                            [ "circumference" .= (60 :: Int)
-                            ]
-                        ]
+            let localSchema = toSchema "Hat" $ garment "Hat"
+            actual <- GraphQL.graphql localSchema Nothing (mempty :: HashMap Name Value) sourceQuery
+            let expected = Object
+                    $ HashMap.singleton "garment"
+                    $ Object
+                    $ HashMap.singleton "circumference"
+                    $ Int 60
             in actual `shouldResolveTo` expected

        it "considers type condition" $ do
@ -194,11 +198,11 @@ spec = do
                size
              }
            |]
-                expected = HashMap.singleton "data"
-                    $ Aeson.object
-                        [ "garment" .= Aeson.object
-                            [ "circumference" .= (60 :: Int)
-                            ]
-                        ]
-            actual <- graphql (toSchema "Hat" $ garment "Hat") sourceQuery
+                expected = Object
+                    $ HashMap.singleton "garment"
+                    $ Object
+                    $ HashMap.singleton "circumference"
+                    $ Int 60
+            let localSchema = toSchema "Hat" $ garment "Hat"
+            actual <- GraphQL.graphql localSchema Nothing (mempty :: HashMap Name Value) sourceQuery
            actual `shouldResolveTo` expected
--- a/tests/Language/GraphQL/RootOperationSpec.hs
+++ b/tests/Language/GraphQL/RootOperationSpec.hs
@ -4,18 +4,21 @@

 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE PackageImports #-}
+
 module Language.GraphQL.RootOperationSpec
    ( spec
    ) where

-import Data.Aeson ((.=), object)
+import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
-import Language.GraphQL.Foundation
+import Language.GraphQL
+import Language.GraphQL.AST (Name)
 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
+import "graphql-spice" Test.Hspec.GraphQL

 hatType :: Out.ObjectType IO
 hatType = Out.ObjectType "Hat" Nothing []
@ -49,13 +52,12 @@ spec =
                }
              }
            |]
-                expected = HashMap.singleton "data"
-                    $ object
-                        [ "garment" .= object
-                            [ "circumference" .= (60 :: Int)
-                            ]
-                        ]
-            actual <- graphql garmentSchema querySource
+                expected = Object
+                    $ HashMap.singleton "garment"
+                    $ Object
+                    $ HashMap.singleton "circumference"
+                    $ Int 60
+            actual <- graphql garmentSchema Nothing (mempty :: HashMap Name Value) querySource
            actual `shouldResolveTo` expected

        it "chooses Mutation" $ do
@ -64,9 +66,8 @@ spec =
                incrementCircumference
              }
            |]
-                expected = HashMap.singleton "data"
-                    $ object
-                        [ "incrementCircumference" .= (61 :: Int)
-                        ]
-            actual <- graphql garmentSchema querySource
+                expected = Object
+                    $ HashMap.singleton "incrementCircumference"
+                    $ Int 61
+            actual <- graphql garmentSchema Nothing (mempty :: HashMap Name Value) querySource
            actual `shouldResolveTo` expected