diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,13 @@ and this project adheres to [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [1.0.2.0] - 2021-12-26 +### 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 - Custom `Show` instance for `Type.Definition.Value` (for error @@ -459,6 +466,7 @@ ### Added - Data types for the GraphQL language. +[1.0.2.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=1.0.2.0&rev_to=v1.0.1.0 [1.0.1.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v1.0.1.0&rev_to=v1.0.0.0 [1.0.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v1.0.0.0&rev_to=v0.11.1.0 [0.11.1.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.11.1.0&rev_to=v0.11.0.0 diff --git a/graphql.cabal b/graphql.cabal --- a/graphql.cabal +++ b/graphql.cabal @@ -1,7 +1,7 @@ -cabal-version: 2.2 +cabal-version: 2.4 name: graphql -version: 1.0.1.0 +version: 1.0.2.0 synopsis: Haskell GraphQL implementation description: Haskell implementation. category: Language @@ -18,93 +18,100 @@ LICENSE.MPL build-type: Simple extra-source-files: - CHANGELOG.md - README.md + CHANGELOG.md + README.md tested-with: - GHC == 8.10.7 - , GHC == 9.0.1 + GHC == 8.10.7, + GHC == 9.0.1, + GHC == 9.2.1 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 - Language.GraphQL.AST - Language.GraphQL.AST.DirectiveLocation - Language.GraphQL.AST.Document - Language.GraphQL.AST.Encoder - Language.GraphQL.AST.Lexer - Language.GraphQL.AST.Parser - Language.GraphQL.Error - Language.GraphQL.Execute - Language.GraphQL.Execute.Coerce - Language.GraphQL.Execute.OrderedMap - Language.GraphQL.TH - Language.GraphQL.Type - Language.GraphQL.Type.In - Language.GraphQL.Type.Out - Language.GraphQL.Type.Schema - Language.GraphQL.Validate - Language.GraphQL.Validate.Validation - Test.Hspec.GraphQL + Language.GraphQL + Language.GraphQL.AST + Language.GraphQL.AST.DirectiveLocation + Language.GraphQL.AST.Document + Language.GraphQL.AST.Encoder + Language.GraphQL.AST.Lexer + Language.GraphQL.AST.Parser + Language.GraphQL.Error + Language.GraphQL.Execute + Language.GraphQL.Execute.Coerce + Language.GraphQL.Execute.OrderedMap + Language.GraphQL.TH + Language.GraphQL.Type + Language.GraphQL.Type.In + Language.GraphQL.Type.Out + Language.GraphQL.Type.Schema + Language.GraphQL.Validate + Language.GraphQL.Validate.Validation + Test.Hspec.GraphQL other-modules: - Language.GraphQL.Execute.Transform - Language.GraphQL.Type.Definition - Language.GraphQL.Type.Internal - Language.GraphQL.Validate.Rules + Language.GraphQL.Execute.Transform + Language.GraphQL.Type.Definition + Language.GraphQL.Type.Internal + Language.GraphQL.Validate.Rules hs-source-dirs: - src + 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 - , exceptions >= 0.10.4 && < 0.11 - , 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 + base >= 4.7 && < 5, + conduit ^>= 1.3.4, + containers ^>= 0.6.2, + exceptions ^>= 0.10.4, + megaparsec >= 9.0 && < 10, + parser-combinators >= 1.3 && < 2, + template-haskell >= 2.16 && < 3, + text ^>= 1.2.4, + transformers ^>= 0.5.6, + unordered-containers ^>= 0.2.14, + vector ^>= 0.12.3 + if flag(Json) + build-depends: + aeson >= 1.5.6 && < 1.6, + hspec-expectations >= 0.8.2 && < 0.9, + scientific >= 0.3.7 && < 0.4 + cpp-options: -DWITH_JSON + default-language: Haskell2010 test-suite graphql-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: - Language.GraphQL.AST.DocumentSpec - Language.GraphQL.AST.EncoderSpec - Language.GraphQL.AST.LexerSpec - Language.GraphQL.AST.ParserSpec - Language.GraphQL.ErrorSpec - Language.GraphQL.Execute.CoerceSpec - Language.GraphQL.Execute.OrderedMapSpec - Language.GraphQL.ExecuteSpec - Language.GraphQL.Type.OutSpec - Language.GraphQL.Validate.RulesSpec - Test.DirectiveSpec - Test.FragmentSpec - Test.RootOperationSpec + Language.GraphQL.AST.DocumentSpec + Language.GraphQL.AST.EncoderSpec + Language.GraphQL.AST.LexerSpec + Language.GraphQL.AST.ParserSpec + Language.GraphQL.ErrorSpec + Language.GraphQL.Execute.CoerceSpec + Language.GraphQL.Execute.OrderedMapSpec + Language.GraphQL.ExecuteSpec + Language.GraphQL.Type.OutSpec + Language.GraphQL.Validate.RulesSpec hs-source-dirs: - tests + tests ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: - QuickCheck >= 2.14.1 && < 2.15 - , aeson - , base >= 4.8 && < 5 - , conduit - , exceptions - , graphql - , hspec >= 2.8.2 && < 2.9 - , hspec-megaparsec >= 2.2.0 && < 2.3 - , megaparsec - , scientific - , text - , unordered-containers + QuickCheck ^>= 2.14.1, + base, + conduit, + exceptions, + graphql, + hspec ^>= 2.9.1, + hspec-megaparsec ^>= 2.2.0, + megaparsec, + text, + unordered-containers default-language: Haskell2010 diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs --- 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 @@ [ ("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 --- a/src/Language/GraphQL/Execute/Coerce.hs +++ b/src/Language/GraphQL/Execute/Coerce.hs @@ -5,6 +5,7 @@ {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} -- | Types and functions used for input and result coercion. module Language.GraphQL.Execute.Coerce @@ -15,7 +16,10 @@ , 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 @@ -24,7 +28,6 @@ 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 @@ -61,20 +64,13 @@ -> a -- ^ Variable value being coerced. -> Maybe Type.Value -- ^ Coerced value on success, 'Nothing' otherwise. -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) = +instance VariableValue Type.Value where + 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 @@ -94,14 +90,9 @@ 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 @@ -216,6 +207,28 @@ instance forall a. IsString (Output a) where fromString = String . fromString +instance Serialize Type.Value where + null = Type.Null + 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 @@ -236,3 +249,47 @@ $ 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/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs --- a/src/Language/GraphQL/Type/Schema.hs +++ b/src/Language/GraphQL/Type/Schema.hs @@ -205,5 +205,5 @@ let Out.ObjectType _ _ interfaces _ = objectType in foldr (add implementation) accumulator interfaces go _ accumulator = accumulator - add implementation (Out.InterfaceType typeName _ _ _) accumulator = - HashMap.insertWith (++) typeName [implementation] accumulator + add implementation (Out.InterfaceType typeName _ _ _) = + HashMap.insertWith (++) typeName [implementation] diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs --- a/src/Language/GraphQL/Validate/Rules.hs +++ b/src/Language/GraphQL/Validate/Rules.hs @@ -152,7 +152,7 @@ where errorMessage = "Anonymous Subscription must select only one top level field." - collectFields selectionSet = foldM forEach HashSet.empty selectionSet + collectFields = foldM forEach HashSet.empty forEach accumulator = \case Full.FieldSelection fieldSelection -> forField accumulator fieldSelection Full.FragmentSpreadSelection fragmentSelection -> @@ -472,7 +472,7 @@ collectCycles :: Traversable t => t Full.Selection -> StateT (Int, Full.Name) (ReaderT (Validation m) Seq) (HashMap Full.Name Int) - collectCycles selectionSet = foldM forEach HashMap.empty selectionSet + collectCycles = foldM forEach HashMap.empty forEach accumulator = \case Full.FieldSelection fieldSelection -> forField accumulator fieldSelection Full.InlineFragmentSelection fragmentSelection -> @@ -702,8 +702,7 @@ where go (Full.Node (Full.Object fields) _) = filterFieldDuplicates fields go _ = mempty - filterFieldDuplicates fields = - filterDuplicates getFieldName "input field" fields + filterFieldDuplicates = filterDuplicates getFieldName "input field" getFieldName (Full.ObjectField fieldName _ location') = (fieldName, location') constGo (Full.Node (Full.ConstObject fields) _) = filterFieldDuplicates fields constGo _ = mempty @@ -1331,8 +1330,8 @@ -> Type.CompositeType m -> t Full.Selection -> ValidationState m (Seq Error) - visitSelectionSet variables selectionType selections = - foldM (evaluateSelection variables selectionType) mempty selections + visitSelectionSet variables selectionType = + foldM (evaluateSelection variables selectionType) mempty evaluateFieldSelection variables selections accumulator = \case Just newParentType -> do let folder = evaluateSelection variables newParentType @@ -1617,4 +1616,3 @@ } | otherwise -> mempty _ -> checkResult - diff --git a/src/Test/Hspec/GraphQL.hs b/src/Test/Hspec/GraphQL.hs --- 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 @@ 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 --- a/tests/Language/GraphQL/ErrorSpec.hs +++ b/tests/Language/GraphQL/ErrorSpec.hs @@ -7,9 +7,9 @@ ( 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 @@ , 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 --- a/tests/Language/GraphQL/Execute/CoerceSpec.hs +++ b/tests/Language/GraphQL/Execute/CoerceSpec.hs @@ -7,12 +7,8 @@ ( 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 @@ , ("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 --- a/tests/Language/GraphQL/ExecuteSpec.hs +++ b/tests/Language/GraphQL/ExecuteSpec.hs @@ -10,9 +10,6 @@ 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 @@ ] 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 @@ ...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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ , 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 @@ 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 } }" diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs deleted file mode 100644 --- a/tests/Test/DirectiveSpec.hs +++ /dev/null @@ -1,92 +0,0 @@ -{- 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 Test.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 diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs deleted file mode 100644 --- a/tests/Test/FragmentSpec.hs +++ /dev/null @@ -1,204 +0,0 @@ -{- 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 Test.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 diff --git a/tests/Test/RootOperationSpec.hs b/tests/Test/RootOperationSpec.hs deleted file mode 100644 --- a/tests/Test/RootOperationSpec.hs +++ /dev/null @@ -1,72 +0,0 @@ -{- 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 Test.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