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 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 similarity index 66% rename from src/Language/GraphQL/Serialize.hs rename to 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