diff options
| -rw-r--r-- | CHANGELOG.md | 2 | ||||
| -rw-r--r-- | graphql.cabal | 17 | ||||
| -rw-r--r-- | src/Language/GraphQL.hs | 9 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute/Coerce.hs | 107 | ||||
| -rw-r--r-- | src/Test/Hspec/GraphQL.hs | 8 | ||||
| -rw-r--r-- | tests/Language/GraphQL/ErrorSpec.hs | 4 | ||||
| -rw-r--r-- | tests/Language/GraphQL/Execute/CoerceSpec.hs | 76 | ||||
| -rw-r--r-- | tests/Language/GraphQL/ExecuteSpec.hs | 72 |
8 files changed, 136 insertions, 159 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md index dbcf594..409d585 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -10,6 +10,8 @@ and this project adheres to ### Added - `Serialize` instance for `Type.Definition.Value`. - `VariableValue` instance for `Type.Definition.Value`. +- `Json` build flag, enabled by default. JSON and Aeson support can be disabled + by disabling this flag. ## [1.0.1.0] - 2021-09-27 ### Added diff --git a/graphql.cabal b/graphql.cabal index 232b537..a78bced 100644 --- a/graphql.cabal +++ b/graphql.cabal @@ -28,6 +28,11 @@ source-repository head type: git location: git://caraus.tech/pub/graphql.git +flag Json + description: Whether to build against @aeson 1.x@ + default: True + manual: True + library exposed-modules: Language.GraphQL @@ -57,8 +62,8 @@ library hs-source-dirs: src ghc-options: -Wall + build-depends: - aeson >= 1.5.6 && < 1.6, base >= 4.7 && < 5, conduit >= 1.3.4 && < 1.4, containers >= 0.6.2 && < 0.7, @@ -66,12 +71,17 @@ library hspec-expectations >= 0.8.2 && < 0.9, megaparsec >= 9.0.1 && < 9.1, parser-combinators >= 1.3.0 && < 1.4, - scientific >= 0.3.7 && < 0.4, template-haskell >= 2.16 && < 2.18, text >= 1.2.4 && < 1.3, transformers >= 0.5.6 && < 0.6, unordered-containers >= 0.2.14 && < 0.3, vector >= 0.12.3 && < 0.13 + if flag(Json) + build-depends: + aeson >= 1.5.6 && < 1.6, + scientific >= 0.3.7 && < 0.4 + cpp-options: -DWITH_JSON + default-language: Haskell2010 test-suite graphql-test @@ -91,9 +101,9 @@ test-suite graphql-test hs-source-dirs: tests ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: QuickCheck >= 2.14.1 && < 2.15, - aeson, base >= 4.8 && < 5, conduit, exceptions, @@ -101,7 +111,6 @@ test-suite graphql-test hspec >= 2.9.1 && < 3, hspec-megaparsec >= 2.2.0 && < 2.3, megaparsec, - scientific, text, unordered-containers default-language: Haskell2010 diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs index 03ef54b..20bb123 100644 --- a/src/Language/GraphQL.hs +++ b/src/Language/GraphQL.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE CPP #-} + +#ifdef WITH_JSON {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -73,3 +76,9 @@ graphqlSubs schema operationName variableValues document' = [ ("line", Aeson.toJSON line) , ("column", Aeson.toJSON column) ] +#else +-- | This module provides the functions to parse and execute @GraphQL@ queries. +module Language.GraphQL + ( + ) where +#endif diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs index 9d5af96..9bc6b10 100644 --- a/src/Language/GraphQL/Execute/Coerce.hs +++ b/src/Language/GraphQL/Execute/Coerce.hs @@ -3,9 +3,9 @@ obtain one at https://mozilla.org/MPL/2.0/. -} {-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} -- | Types and functions used for input and result coercion. module Language.GraphQL.Execute.Coerce @@ -16,7 +16,10 @@ module Language.GraphQL.Execute.Coerce , matchFieldValues ) where +#ifdef WITH_JSON import qualified Data.Aeson as Aeson +import Data.Scientific (toBoundedInteger, toRealFloat) +#endif import Data.Int (Int32) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap @@ -25,7 +28,6 @@ import Data.Text (Text) import qualified Data.Text.Lazy as Text.Lazy import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Data.Text.Lazy.Builder.Int as Text.Builder -import Data.Scientific (toBoundedInteger, toRealFloat) import Language.GraphQL.AST (Name) import Language.GraphQL.Execute.OrderedMap (OrderedMap) import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap @@ -63,22 +65,12 @@ class VariableValue a where -> Maybe Type.Value -- ^ Coerced value on success, 'Nothing' otherwise. instance VariableValue Type.Value where - coerceVariableValue = const Just - -instance VariableValue Aeson.Value where - coerceVariableValue _ Aeson.Null = Just Type.Null - coerceVariableValue (In.ScalarBaseType scalarType) value - | (Aeson.String stringValue) <- value = Just $ Type.String stringValue - | (Aeson.Bool booleanValue) <- value = Just $ Type.Boolean booleanValue - | (Aeson.Number numberValue) <- value - , (Type.ScalarType "Float" _) <- scalarType = - Just $ Type.Float $ toRealFloat numberValue - | (Aeson.Number numberValue) <- value = -- ID or Int - Type.Int <$> toBoundedInteger numberValue - coerceVariableValue (In.EnumBaseType _) (Aeson.String stringValue) = + coerceVariableValue _ Type.Null = Just Type.Null + coerceVariableValue (In.ScalarBaseType _) value = Just value + coerceVariableValue (In.EnumBaseType _) (Type.Enum stringValue) = Just $ Type.Enum stringValue coerceVariableValue (In.InputObjectBaseType objectType) value - | (Aeson.Object objectValue) <- value = do + | (Type.Object objectValue) <- value = do let (In.InputObjectType _ _ inputFields) = objectType (newObjectValue, resultMap) <- foldWithKey objectValue inputFields if HashMap.null newObjectValue @@ -98,14 +90,9 @@ instance VariableValue Aeson.Value where pure (newObjectValue, insert coerced) Nothing -> Just (objectValue, resultMap) coerceVariableValue (In.ListBaseType listType) value - | (Aeson.Array arrayValue) <- value = - Type.List <$> foldr foldVector (Just []) arrayValue + | (Type.List arrayValue) <- value = + Type.List <$> traverse (coerceVariableValue listType) arrayValue | otherwise = coerceVariableValue listType value - where - foldVector _ Nothing = Nothing - foldVector variableValue (Just list) = do - coerced <- coerceVariableValue listType variableValue - pure $ coerced : list coerceVariableValue _ _ = Nothing -- | Looks up a value by name in the given map, coerces it and inserts into the @@ -222,18 +209,26 @@ instance forall a. IsString (Output a) where instance Serialize Type.Value where null = Type.Null - serialize _ = \case - Int int -> Just $ Type.Int int - Float float -> Just $ Type.Float float - String string -> Just $ Type.String string - Boolean boolean -> Just $ Type.Boolean boolean - Enum enum -> Just $ Type.Enum enum - List list -> Just $ Type.List list - Object object -> Just - $ Type.Object - $ HashMap.fromList - $ OrderedMap.toList object + serialize (Out.ScalarBaseType scalarType) value + | Type.ScalarType "Int" _ <- scalarType + , Int int <- value = Just $ Type.Int int + | Type.ScalarType "Float" _ <- scalarType + , Float float <- value = Just $ Type.Float float + | Type.ScalarType "String" _ <- scalarType + , String string <- value = Just $ Type.String string + | Type.ScalarType "ID" _ <- scalarType + , String string <- value = Just $ Type.String string + | Type.ScalarType "Boolean" _ <- scalarType + , Boolean boolean <- value = Just $ Type.Boolean boolean + serialize _ (Enum enum) = Just $ Type.Enum enum + serialize _ (List list) = Just $ Type.List list + serialize _ (Object object) = Just + $ Type.Object + $ HashMap.fromList + $ OrderedMap.toList object + serialize _ _ = Nothing +#ifdef WITH_JSON instance Serialize Aeson.Value where serialize (Out.ScalarBaseType scalarType) value | Type.ScalarType "Int" _ <- scalarType @@ -254,3 +249,47 @@ instance Serialize Aeson.Value where $ Aeson.toJSON <$> object serialize _ _ = Nothing null = Aeson.Null + +instance VariableValue Aeson.Value where + coerceVariableValue _ Aeson.Null = Just Type.Null + coerceVariableValue (In.ScalarBaseType scalarType) value + | (Aeson.String stringValue) <- value = Just $ Type.String stringValue + | (Aeson.Bool booleanValue) <- value = Just $ Type.Boolean booleanValue + | (Aeson.Number numberValue) <- value + , (Type.ScalarType "Float" _) <- scalarType = + Just $ Type.Float $ toRealFloat numberValue + | (Aeson.Number numberValue) <- value = -- ID or Int + Type.Int <$> toBoundedInteger numberValue + coerceVariableValue (In.EnumBaseType _) (Aeson.String stringValue) = + Just $ Type.Enum stringValue + coerceVariableValue (In.InputObjectBaseType objectType) value + | (Aeson.Object objectValue) <- value = do + let (In.InputObjectType _ _ inputFields) = objectType + (newObjectValue, resultMap) <- foldWithKey objectValue inputFields + if HashMap.null newObjectValue + then Just $ Type.Object resultMap + else Nothing + where + foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues' + $ Just (objectValue, HashMap.empty) + matchFieldValues' _ _ Nothing = Nothing + matchFieldValues' fieldName inputField (Just (objectValue, resultMap)) = + let (In.InputField _ fieldType _) = inputField + insert = flip (HashMap.insert fieldName) resultMap + newObjectValue = HashMap.delete fieldName objectValue + in case HashMap.lookup fieldName objectValue of + Just variableValue -> do + coerced <- coerceVariableValue fieldType variableValue + pure (newObjectValue, insert coerced) + Nothing -> Just (objectValue, resultMap) + coerceVariableValue (In.ListBaseType listType) value + | (Aeson.Array arrayValue) <- value = + Type.List <$> foldr foldVector (Just []) arrayValue + | otherwise = coerceVariableValue listType value + where + foldVector _ Nothing = Nothing + foldVector variableValue (Just list) = do + coerced <- coerceVariableValue listType variableValue + pure $ coerced : list + coerceVariableValue _ _ = Nothing +#endif diff --git a/src/Test/Hspec/GraphQL.hs b/src/Test/Hspec/GraphQL.hs index 253b366..5d812bf 100644 --- a/src/Test/Hspec/GraphQL.hs +++ b/src/Test/Hspec/GraphQL.hs @@ -2,6 +2,9 @@ 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 CPP #-} + +#ifdef WITH_JSON {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE OverloadedStrings #-} @@ -39,3 +42,8 @@ shouldResolve executor query = do response `shouldNotSatisfy` HashMap.member "errors" _ -> expectationFailure "the query is expected to resolve to a value, but it resolved to an event stream" +#else +module Test.Hspec.GraphQL + ( + ) where +#endif diff --git a/tests/Language/GraphQL/ErrorSpec.hs b/tests/Language/GraphQL/ErrorSpec.hs index f64e70a..75d9f33 100644 --- a/tests/Language/GraphQL/ErrorSpec.hs +++ b/tests/Language/GraphQL/ErrorSpec.hs @@ -7,9 +7,9 @@ module Language.GraphQL.ErrorSpec ( spec ) where -import qualified Data.Aeson as Aeson import Data.List.NonEmpty (NonEmpty (..)) import Language.GraphQL.Error +import qualified Language.GraphQL.Type as Type import Test.Hspec ( Spec , describe @@ -31,6 +31,6 @@ spec = describe "parseError" $ , pstateTabWidth = mkPos 1 , pstateLinePrefix = "" } - Response Aeson.Null actual <- + Response Type.Null actual <- parseError (ParseErrorBundle parseErrors posState) length actual `shouldBe` 1 diff --git a/tests/Language/GraphQL/Execute/CoerceSpec.hs b/tests/Language/GraphQL/Execute/CoerceSpec.hs index 2b00895..e0df4bb 100644 --- a/tests/Language/GraphQL/Execute/CoerceSpec.hs +++ b/tests/Language/GraphQL/Execute/CoerceSpec.hs @@ -7,12 +7,8 @@ module Language.GraphQL.Execute.CoerceSpec ( spec ) where -import Data.Aeson as Aeson ((.=)) -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Types as Aeson import qualified Data.HashMap.Strict as HashMap import Data.Maybe (isNothing) -import Data.Scientific (scientific) import qualified Language.GraphQL.Execute.Coerce as Coerce import Language.GraphQL.Type import qualified Language.GraphQL.Type.In as In @@ -27,81 +23,11 @@ direction = EnumType "Direction" Nothing $ HashMap.fromList , ("WEST", EnumValue Nothing) ] -singletonInputObject :: In.Type -singletonInputObject = In.NamedInputObjectType type' - where - type' = In.InputObjectType "ObjectName" Nothing inputFields - inputFields = HashMap.singleton "field" field - field = In.InputField Nothing (In.NamedScalarType string) Nothing - namedIdType :: In.Type namedIdType = In.NamedScalarType id spec :: Spec -spec = do - describe "VariableValue Aeson" $ do - it "coerces strings" $ - let expected = Just (String "asdf") - actual = Coerce.coerceVariableValue - (In.NamedScalarType string) (Aeson.String "asdf") - in actual `shouldBe` expected - it "coerces non-null strings" $ - let expected = Just (String "asdf") - actual = Coerce.coerceVariableValue - (In.NonNullScalarType string) (Aeson.String "asdf") - in actual `shouldBe` expected - it "coerces booleans" $ - let expected = Just (Boolean True) - actual = Coerce.coerceVariableValue - (In.NamedScalarType boolean) (Aeson.Bool True) - in actual `shouldBe` expected - it "coerces zero to an integer" $ - let expected = Just (Int 0) - actual = Coerce.coerceVariableValue - (In.NamedScalarType int) (Aeson.Number 0) - in actual `shouldBe` expected - it "rejects fractional if an integer is expected" $ - let actual = Coerce.coerceVariableValue - (In.NamedScalarType int) (Aeson.Number $ scientific 14 (-1)) - in actual `shouldSatisfy` isNothing - it "coerces float numbers" $ - let expected = Just (Float 1.4) - actual = Coerce.coerceVariableValue - (In.NamedScalarType float) (Aeson.Number $ scientific 14 (-1)) - in actual `shouldBe` expected - it "coerces IDs" $ - let expected = Just (String "1234") - json = Aeson.String "1234" - actual = Coerce.coerceVariableValue namedIdType json - in actual `shouldBe` expected - it "coerces input objects" $ - let actual = Coerce.coerceVariableValue singletonInputObject - $ Aeson.object ["field" .= ("asdf" :: Aeson.Value)] - expected = Just $ Object $ HashMap.singleton "field" "asdf" - in actual `shouldBe` expected - it "skips the field if it is missing in the variables" $ - let actual = Coerce.coerceVariableValue - singletonInputObject Aeson.emptyObject - expected = Just $ Object HashMap.empty - in actual `shouldBe` expected - it "fails if input object value contains extra fields" $ - let actual = Coerce.coerceVariableValue singletonInputObject - $ Aeson.object variableFields - variableFields = - [ "field" .= ("asdf" :: Aeson.Value) - , "extra" .= ("qwer" :: Aeson.Value) - ] - in actual `shouldSatisfy` isNothing - it "preserves null" $ - let actual = Coerce.coerceVariableValue namedIdType Aeson.Null - in actual `shouldBe` Just Null - it "preserves list order" $ - let list = Aeson.toJSONList ["asdf" :: Aeson.Value, "qwer"] - listType = (In.ListType $ In.NamedScalarType string) - actual = Coerce.coerceVariableValue listType list - expected = Just $ List [String "asdf", String "qwer"] - in actual `shouldBe` expected - +spec = describe "coerceInputLiteral" $ do it "coerces enums" $ let expected = Just (Enum "NORTH") diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs index 6723524..5eafb2e 100644 --- a/tests/Language/GraphQL/ExecuteSpec.hs +++ b/tests/Language/GraphQL/ExecuteSpec.hs @@ -10,9 +10,6 @@ module Language.GraphQL.ExecuteSpec import Control.Exception (Exception(..), SomeException) import Control.Monad.Catch (throwM) -import Data.Aeson ((.=)) -import qualified Data.Aeson as Aeson -import Data.Aeson.Types (emptyObject) import Data.Conduit import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap @@ -189,12 +186,12 @@ schoolType = EnumType "School" Nothing $ HashMap.fromList ] type EitherStreamOrValue = Either - (ResponseEventStream (Either SomeException) Aeson.Value) - (Response Aeson.Value) + (ResponseEventStream (Either SomeException) Value) + (Response Value) execute' :: Document -> Either SomeException EitherStreamOrValue execute' = - execute philosopherSchema Nothing (mempty :: HashMap Name Aeson.Value) + execute philosopherSchema Nothing (mempty :: HashMap Name Value) spec :: Spec spec = @@ -209,38 +206,37 @@ spec = ...cyclicFragment } |] - expected = Response emptyObject mempty + expected = Response (Object mempty) mempty Right (Right actual) = either (pure . parseError) execute' $ parse document "" sourceQuery in actual `shouldBe` expected context "Query" $ do it "skips unknown fields" $ - let data'' = Aeson.object - [ "philosopher" .= Aeson.object - [ "firstName" .= ("Friedrich" :: String) - ] - ] + let data'' = Object + $ HashMap.singleton "philosopher" + $ Object + $ HashMap.singleton "firstName" + $ String "Friedrich" expected = Response data'' mempty Right (Right actual) = either (pure . parseError) execute' $ parse document "" "{ philosopher { firstName surname } }" in actual `shouldBe` expected it "merges selections" $ - let data'' = Aeson.object - [ "philosopher" .= Aeson.object - [ "firstName" .= ("Friedrich" :: String) - , "lastName" .= ("Nietzsche" :: String) + let data'' = Object + $ HashMap.singleton "philosopher" + $ Object + $ HashMap.fromList + [ ("firstName", String "Friedrich") + , ("lastName", String "Nietzsche") ] - ] expected = Response data'' mempty Right (Right actual) = either (pure . parseError) execute' $ parse document "" "{ philosopher { firstName } philosopher { lastName } }" in actual `shouldBe` expected it "errors on invalid output enum values" $ - let data'' = Aeson.object - [ "philosopher" .= Aeson.Null - ] + let data'' = Object $ HashMap.singleton "philosopher" Null executionErrors = pure $ Error { message = "Value completion error. Expected type !School, found: EXISTENTIALISM." @@ -253,9 +249,7 @@ spec = in actual `shouldBe` expected it "gives location information for non-null unions" $ - let data'' = Aeson.object - [ "philosopher" .= Aeson.Null - ] + let data'' = Object $ HashMap.singleton "philosopher" Null executionErrors = pure $ Error { message = "Value completion error. Expected type !Interest, found: { instrument: \"piano\" }." @@ -268,9 +262,7 @@ spec = in actual `shouldBe` expected it "gives location information for invalid interfaces" $ - let data'' = Aeson.object - [ "philosopher" .= Aeson.Null - ] + let data'' = Object $ HashMap.singleton "philosopher" Null executionErrors = pure $ Error { message = "Value completion error. Expected type !Work, found:\ @@ -284,9 +276,7 @@ spec = in actual `shouldBe` expected it "gives location information for invalid scalar arguments" $ - let data'' = Aeson.object - [ "philosopher" .= Aeson.Null - ] + let data'' = Object $ HashMap.singleton "philosopher" Null executionErrors = pure $ Error { message = "Argument \"id\" has invalid type. Expected type ID, found: True." @@ -299,9 +289,7 @@ spec = in actual `shouldBe` expected it "gives location information for failed result coercion" $ - let data'' = Aeson.object - [ "philosopher" .= Aeson.Null - ] + let data'' = Object $ HashMap.singleton "philosopher" Null executionErrors = pure $ Error { message = "Unable to coerce result to !Int." , locations = [Location 1 26] @@ -313,9 +301,7 @@ spec = in actual `shouldBe` expected it "gives location information for failed result coercion" $ - let data'' = Aeson.object - [ "genres" .= Aeson.Null - ] + let data'' = Object $ HashMap.singleton "genres" Null executionErrors = pure $ Error { message = "PhilosopherException" , locations = [Location 1 3] @@ -332,15 +318,13 @@ spec = , locations = [Location 1 3] , path = [Segment "count"] } - expected = Response Aeson.Null executionErrors + expected = Response Null executionErrors Right (Right actual) = either (pure . parseError) execute' $ parse document "" "{ count }" in actual `shouldBe` expected it "detects nullability errors" $ - let data'' = Aeson.object - [ "philosopher" .= Aeson.Null - ] + let data'' = Object $ HashMap.singleton "philosopher" Null executionErrors = pure $ Error { message = "Value completion error. Expected type !String, found: null." , locations = [Location 1 26] @@ -353,11 +337,11 @@ spec = context "Subscription" $ it "subscribes" $ - let data'' = Aeson.object - [ "newQuote" .= Aeson.object - [ "quote" .= ("Naturam expelles furca, tamen usque recurret." :: String) - ] - ] + let data'' = Object + $ HashMap.singleton "newQuote" + $ Object + $ HashMap.singleton "quote" + $ String "Naturam expelles furca, tamen usque recurret." expected = Response data'' mempty Right (Left stream) = either (pure . parseError) execute' $ parse document "" "subscription { newQuote { quote } }" |