From c6241d33904763adea081b5396dff563b4d50108 Mon Sep 17 00:00:00 2001 From: David Maze Date: Sun, 19 Nov 2017 06:47:33 -0500 Subject: [PATCH 1/4] Add FromJSON instances for Name, Variable. --- src/GraphQL/Internal/Syntax/AST.hs | 13 ++++++++++++- tests/ASTTests.hs | 4 ++++ 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/src/GraphQL/Internal/Syntax/AST.hs b/src/GraphQL/Internal/Syntax/AST.hs index 9063507..64dbf98 100644 --- a/src/GraphQL/Internal/Syntax/AST.hs +++ b/src/GraphQL/Internal/Syntax/AST.hs @@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -104,6 +105,12 @@ instance IsString Name where instance Aeson.ToJSON Name where toJSON = Aeson.toJSON . unName +instance Aeson.FromJSON Name where + parseJSON = Aeson.withText "Name" $ \v -> + case makeName v of + Left _ -> mempty + Right name -> return name + instance Arbitrary Name where arbitrary = do initial <- elements alpha @@ -153,7 +160,11 @@ getNodeName (Node name _ _ _) = name data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue) deriving (Eq,Show) -newtype Variable = Variable Name deriving (Eq, Ord, Show) +newtype Variable = Variable Name deriving (Eq, Ord, Show, Aeson.FromJSON, + Aeson.ToJSON) + +instance Aeson.FromJSONKey Variable +instance Aeson.ToJSONKey Variable instance Arbitrary Variable where arbitrary = Variable <$> arbitrary diff --git a/tests/ASTTests.hs b/tests/ASTTests.hs index 0a47e6a..596964f 100644 --- a/tests/ASTTests.hs +++ b/tests/ASTTests.hs @@ -5,6 +5,7 @@ module ASTTests (tests) where import Protolude +import Data.Aeson (decode, encode) import Data.Attoparsec.Text (parseOnly) import Text.RawString.QQ (r) import Test.Hspec.QuickCheck (prop) @@ -29,6 +30,9 @@ someName = "name" tests :: IO TestTree tests = testSpec "AST" $ do + describe "Name" $ do + prop "round trips valid names through JSON" $ do + \x -> decode (encode (x :: Name)) == Just x describe "Parser and encoder" $ do it "roundtrips on minified documents" $ do let actual = Encoder.queryDocument <$> parseOnly Parser.queryDocument kitchenSink From af093b4c3f3113f39d3f35828e10537005525fe0 Mon Sep 17 00:00:00 2001 From: David Maze Date: Sun, 19 Nov 2017 06:47:38 -0500 Subject: [PATCH 2/4] Add a generic FromYAML instance for Value. --- graphql-api.cabal | 4 +++- package.yaml | 2 ++ src/GraphQL/Value.hs | 41 ++++++++++++++++++++++++++++++++++++----- tests/ValueTests.hs | 24 ++++++++++++++++++++++++ 4 files changed, 65 insertions(+), 6 deletions(-) diff --git a/graphql-api.cabal b/graphql-api.cabal index 1f9f77c..3919de7 100644 --- a/graphql-api.cabal +++ b/graphql-api.cabal @@ -1,4 +1,4 @@ --- This file has been generated from package.yaml by hpack version 0.17.0. +-- This file has been generated from package.yaml by hpack version 0.17.1. -- -- see: https://github.com/sol/hpack @@ -36,6 +36,8 @@ library , scientific , QuickCheck , text + , vector + , unordered-containers exposed-modules: GraphQL GraphQL.API diff --git a/package.yaml b/package.yaml index b3d0d29..75b146c 100644 --- a/package.yaml +++ b/package.yaml @@ -32,6 +32,8 @@ library: - scientific - QuickCheck - text + - vector + - unordered-containers tests: graphql-api-tests: diff --git a/src/GraphQL/Value.hs b/src/GraphQL/Value.hs index ab45a2a..d4cbca6 100644 --- a/src/GraphQL/Value.hs +++ b/src/GraphQL/Value.hs @@ -51,8 +51,11 @@ module GraphQL.Value import Protolude import qualified Data.Aeson as Aeson -import Data.Aeson (ToJSON(..), (.=), pairs) +import Data.Aeson (FromJSON(..), ToJSON(..), (.=), pairs) +import qualified Data.HashMap.Lazy as HashMap import qualified Data.Map as Map +import Data.Scientific (toRealFloat) +import qualified Data.Vector as Vector import Test.QuickCheck (Arbitrary(..), Gen, oneof, listOf, sized) import GraphQL.Internal.Arbitrary (arbitraryText) @@ -86,6 +89,11 @@ instance Traversable Value' where traverse f (ValueList' xs) = ValueList' <$> traverse f xs traverse f (ValueObject' xs) = ValueObject' <$> traverse f xs +instance FromJSON scalar => FromJSON (Value' scalar) where + parseJSON (Aeson.Object x) = ValueObject' <$> parseJSON (Aeson.Object x) + parseJSON (Aeson.Array x) = ValueList' <$> parseJSON (Aeson.Array x) + parseJSON x = ValueScalar' <$> parseJSON x + instance ToJSON scalar => ToJSON (Value' scalar) where toJSON (ValueScalar' x) = toJSON x toJSON (ValueList' x) = toJSON x @@ -151,6 +159,11 @@ toObject _ = empty -- * Scalars -- | A non-variable value which contains no other values. +-- +-- Note that the 'FromJSON' instance always decodes JSON strings to +-- GraphQL strings (never enums) and JSON numbers to GraphQL floats +-- (never ints); doing a better job of resolving this requires query +-- context. data ConstScalar = ConstInt Int32 | ConstFloat Double @@ -160,6 +173,13 @@ data ConstScalar | ConstNull deriving (Eq, Ord, Show) +instance FromJSON ConstScalar where + parseJSON (Aeson.String x) = parseJSON (Aeson.String x) >>= return . ConstString + parseJSON (Aeson.Number x) = return $ ConstFloat $ toRealFloat x + parseJSON (Aeson.Bool x) = return $ ConstBoolean x + parseJSON Aeson.Null = return ConstNull + parseJSON _ = mempty + instance ToJSON ConstScalar where toJSON (ConstInt x) = toJSON x toJSON (ConstFloat x) = toJSON x @@ -213,14 +233,12 @@ astToScalar _ = empty -- * Strings -newtype String = String Text deriving (Eq, Ord, Show) +newtype String = String Text deriving (Eq, Ord, Show, Aeson.FromJSON, + Aeson.ToJSON) instance Arbitrary String where arbitrary = String <$> arbitraryText -instance ToJSON String where - toJSON (String x) = toJSON x - -- * Lists newtype List' scalar = List' [Value' scalar] deriving (Eq, Ord, Show, Functor) @@ -245,6 +263,9 @@ instance Arbitrary scalar => Arbitrary (List' scalar) where -- invalid lists. arbitrary = List' <$> listOf arbitrary +instance FromJSON scalar => FromJSON (List' scalar) where + parseJSON = Aeson.withArray "List" $ \v -> + mapM parseJSON v >>= return . List' . Vector.toList instance ToJSON scalar => ToJSON (List' scalar) where toJSON (List' x) = toJSON x @@ -302,6 +323,16 @@ objectFromList xs = Object' <$> OrderedMap.orderedMap xs unionObjects :: [Object' scalar] -> Maybe (Object' scalar) unionObjects objects = Object' <$> OrderedMap.unions [obj | Object' obj <- objects] +instance FromJSON scalar => FromJSON (Object' scalar) where + parseJSON = Aeson.withObject "Object" $ \v -> do + -- Order of keys is lost before we get here + let kvps = HashMap.toList v + names <- mapM parseJSON (Aeson.String <$> fst <$> kvps) + values <- mapM parseJSON (snd <$> kvps) + case objectFromList $ zip names values of + Nothing -> mempty + Just obj -> return obj + instance ToJSON scalar => ToJSON (Object' scalar) where -- Direct encoding to preserve order of keys / values toJSON (Object' xs) = toJSON (Map.fromList [(unName k, v) | (k, v) <- OrderedMap.toList xs]) diff --git a/tests/ValueTests.hs b/tests/ValueTests.hs index 6bc9902..ec0e49c 100644 --- a/tests/ValueTests.hs +++ b/tests/ValueTests.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE PatternSynonyms #-} module ValueTests (tests) where import Protolude +import Data.Aeson (decode) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (forAll) import Test.Tasty (TestTree) @@ -16,6 +18,13 @@ import GraphQL.Value , unionObjects , objectFields , objectFromList + , String(..) + , pattern ValueFloat + , pattern ValueBoolean + , pattern ValueString + , pattern ValueList + , pattern ValueNull + , List'(..) ) import GraphQL.Value.FromValue (prop_roundtripValue) import GraphQL.Value.ToValue (toValue) @@ -23,6 +32,21 @@ import GraphQL.Value.ToValue (toValue) tests :: IO TestTree tests = testSpec "Value" $ do + describe "FromJSON instance" $ do + it "reads a string" $ do + decode "\"hi\"" `shouldBe` Just (ValueString (String "hi")) + it "reads a numeric string as a string" $ do + decode "\"2\"" `shouldBe` Just (ValueString (String "2")) + it "reads a number as a float" $ do + decode "2" `shouldBe` Just (ValueFloat 2) + it "reads a boolean" $ do + decode "true" `shouldBe` Just (ValueBoolean True) + it "reads null" $ do + decode "null" `shouldBe` Just (ValueNull) + it "reads a list" $ do + decode "[1]" `shouldBe` Just (ValueList $ List' [ValueFloat 1]) + it "reads an object" $ do + decode "{\"a\": \"b\"}" `shouldBe` objectFromList [("a", ValueString (String "b"))] describe "unionObject" $ do it "returns empty on empty list" $ do unionObjects [] `shouldBe` (objectFromList [] :: Maybe Object) From 73f83e5126c78602a086723104ecf58a959cebf6 Mon Sep 17 00:00:00 2001 From: David Maze Date: Sun, 19 Nov 2017 06:47:41 -0500 Subject: [PATCH 3/4] Add a Request object that matches the typical JSON request format. --- src/GraphQL.hs | 11 +++++++++++ src/GraphQL/Internal/Execution.hs | 14 ++++++++++++++ tests/EndToEndTests.hs | 11 +++++++++-- 3 files changed, 34 insertions(+), 2 deletions(-) diff --git a/src/GraphQL.hs b/src/GraphQL.hs index cd6f27b..f687bda 100644 --- a/src/GraphQL.hs +++ b/src/GraphQL.hs @@ -10,6 +10,7 @@ module GraphQL ( -- * Running queries interpretQuery + , interpretRequest , interpretAnonymousQuery , Response(..) -- * Preparing queries then running them @@ -32,6 +33,7 @@ import GraphQL.Internal.Execution ( VariableValues , ExecutionError , substituteVariables + , Request(..) ) import qualified GraphQL.Internal.Execution as Execution import qualified GraphQL.Internal.Syntax.AST as AST @@ -125,6 +127,15 @@ interpretQuery handler query name variables = Left err -> pure (PreExecutionFailure (toError err :| [])) Right document -> executeQuery @api @m handler document name variables +-- | Interpret a GraphQL query, given a packaged request. +interpretRequest + :: forall api m. (Applicative m, HasResolver m api, HasObjectDefinition api) + => Handler m api -- ^ Handler for the query. This links the query to the code you've written to handle it. + -> Request -- ^ The query and its input values. + -> m Response -- ^ The outcome of running the query. +interpretRequest handler (Request query name variables) = + interpretQuery @api @m handler query name variables + -- | Interpret an anonymous GraphQL query. -- -- Anonymous queries have no name and take no variables. diff --git a/src/GraphQL/Internal/Execution.hs b/src/GraphQL/Internal/Execution.hs index f793fae..1f3b0d6 100644 --- a/src/GraphQL/Internal/Execution.hs +++ b/src/GraphQL/Internal/Execution.hs @@ -12,6 +12,7 @@ module GraphQL.Internal.Execution , formatError , getOperation , substituteVariables + , Request(..) ) where import Protolude @@ -34,6 +35,7 @@ import GraphQL.Internal.Validation , Variable , Type(..) ) +import Data.Aeson (FromJSON(..), withObject, (.:), (.:?), (.!=)) -- | Get an operation from a GraphQL document -- @@ -105,3 +107,15 @@ instance GraphQLError ExecutionError where -- GraphQL allows the values of variables to be specified, but doesn't provide -- a way for doing so in the language. type VariableValues = Map Variable Value + +-- | A JSON request to execute a GraphQL query with some context. +-- See . +data Request = Request Text (Maybe Name) VariableValues deriving (Eq, Show) + +instance FromJSON Request where + parseJSON = withObject "Request" $ \v -> do + query <- v .: "query" + operationName <- v .:? "operationName" + variables <- v .:? "variables" .!= mempty + return $ Request query operationName variables + diff --git a/tests/EndToEndTests.hs b/tests/EndToEndTests.hs index 21a72df..1daa503 100644 --- a/tests/EndToEndTests.hs +++ b/tests/EndToEndTests.hs @@ -8,9 +8,9 @@ module EndToEndTests (tests) where import Protolude -import Data.Aeson (Value(Null), toJSON, object, (.=)) +import Data.Aeson (Value(Null), toJSON, object, (.=), decode, encode) import qualified Data.Map as Map -import GraphQL (makeSchema, compileQuery, executeQuery, interpretAnonymousQuery, interpretQuery) +import GraphQL (makeSchema, compileQuery, executeQuery, interpretAnonymousQuery, interpretQuery, interpretRequest) import GraphQL.API (Object, Field) import GraphQL.Internal.Syntax.AST (Variable(..)) import GraphQL.Resolver ((:<>)(..), Handler) @@ -326,3 +326,10 @@ tests = testSpec "End-to-end tests" $ do ] ] toJSON (toValue response) `shouldBe` expected + describe "interpretRequest" $ do + it "performs a query" $ do + let root = pure (viewServerDog mortgage) + let Just request = decode [r|{"query": "{ dog { name } }"}|] + response <- interpretRequest @QueryRoot root request + let expected = "{\"data\":{\"dog\":{\"name\":\"Mortgage\"}}}" + encode response `shouldBe` expected From 6572204b9aebaf30fc2b6703003522ce93de367d Mon Sep 17 00:00:00 2001 From: David Maze Date: Sun, 19 Nov 2017 20:27:09 -0500 Subject: [PATCH 4/4] Improve error handling in FromJSON instances --- src/GraphQL/Internal/Syntax/AST.hs | 3 ++- src/GraphQL/Value.hs | 6 ++++-- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/src/GraphQL/Internal/Syntax/AST.hs b/src/GraphQL/Internal/Syntax/AST.hs index 64dbf98..1c00b02 100644 --- a/src/GraphQL/Internal/Syntax/AST.hs +++ b/src/GraphQL/Internal/Syntax/AST.hs @@ -55,6 +55,7 @@ module GraphQL.Internal.Syntax.AST import Protolude +import Control.Monad.Fail import qualified Data.Aeson as Aeson import qualified Data.Attoparsec.Text as A import Data.Char (isDigit) @@ -108,7 +109,7 @@ instance Aeson.ToJSON Name where instance Aeson.FromJSON Name where parseJSON = Aeson.withText "Name" $ \v -> case makeName v of - Left _ -> mempty + Left err -> fail $ show err Right name -> return name instance Arbitrary Name where diff --git a/src/GraphQL/Value.hs b/src/GraphQL/Value.hs index d4cbca6..e3c1c1f 100644 --- a/src/GraphQL/Value.hs +++ b/src/GraphQL/Value.hs @@ -50,8 +50,10 @@ module GraphQL.Value import Protolude +import Control.Monad.Fail import qualified Data.Aeson as Aeson import Data.Aeson (FromJSON(..), ToJSON(..), (.=), pairs) +import Data.Aeson.Types (typeMismatch) import qualified Data.HashMap.Lazy as HashMap import qualified Data.Map as Map import Data.Scientific (toRealFloat) @@ -178,7 +180,7 @@ instance FromJSON ConstScalar where parseJSON (Aeson.Number x) = return $ ConstFloat $ toRealFloat x parseJSON (Aeson.Bool x) = return $ ConstBoolean x parseJSON Aeson.Null = return ConstNull - parseJSON _ = mempty + parseJSON other = typeMismatch "Scalar" other instance ToJSON ConstScalar where toJSON (ConstInt x) = toJSON x @@ -330,7 +332,7 @@ instance FromJSON scalar => FromJSON (Object' scalar) where names <- mapM parseJSON (Aeson.String <$> fst <$> kvps) values <- mapM parseJSON (snd <$> kvps) case objectFromList $ zip names values of - Nothing -> mempty + Nothing -> fail "duplicate keys in object" Just obj -> return obj instance ToJSON scalar => ToJSON (Object' scalar) where