summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--cabal.project8
-rw-r--r--graphql-spice.cabal12
-rw-r--r--src/Language/GraphQL/Foundation.hs58
-rw-r--r--src/Language/GraphQL/JSON.hs (renamed from src/Language/GraphQL/Serialize.hs)57
-rw-r--r--src/Test/Hspec/GraphQL.hs48
-rw-r--r--tests/Language/GraphQL/DirectiveSpec.hs36
-rw-r--r--tests/Language/GraphQL/FragmentSpec.hs96
-rw-r--r--tests/Language/GraphQL/RootOperationSpec.hs31
8 files changed, 198 insertions, 148 deletions
diff --git a/cabal.project b/cabal.project
index 0742af9..995ffa8 100644
--- 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
diff --git a/graphql-spice.cabal b/graphql-spice.cabal
index c2efb06..35087c7 100644
--- 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
diff --git a/src/Language/GraphQL/Foundation.hs b/src/Language/GraphQL/Foundation.hs
deleted file mode 100644
index 4d0d4f3..0000000
--- a/src/Language/GraphQL/Foundation.hs
+++ /dev/null
@@ -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)
diff --git a/src/Language/GraphQL/Serialize.hs b/src/Language/GraphQL/JSON.hs
index cad4f47..bdbc4f4 100644
--- a/src/Language/GraphQL/Serialize.hs
+++ b/src/Language/GraphQL/JSON.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)
diff --git a/src/Test/Hspec/GraphQL.hs b/src/Test/Hspec/GraphQL.hs
new file mode 100644
index 0000000..41d9eb2
--- /dev/null
+++ 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"
diff --git a/tests/Language/GraphQL/DirectiveSpec.hs b/tests/Language/GraphQL/DirectiveSpec.hs
index 6727c50..fd429a6 100644
--- 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
diff --git a/tests/Language/GraphQL/FragmentSpec.hs b/tests/Language/GraphQL/FragmentSpec.hs
index dd13bea..a003f4c 100644
--- 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
diff --git a/tests/Language/GraphQL/RootOperationSpec.hs b/tests/Language/GraphQL/RootOperationSpec.hs
index 4c54b40..e7fbcd7 100644
--- 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
generated by cgit v1.2.3 (git 2.26.2) at 2026-06-26 19:36:07 +0000