Create a Request object and an interpretRequest path

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

package.yaml

@@ -32,6 +32,8 @@ library:
     - scientific
     - QuickCheck
     - text
+    - vector
+    - unordered-containers
 
 tests:
   graphql-api-tests:

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.

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 <http://graphql.org/learn/serving-over-http/#post-request>.
+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
+

src/GraphQL/Internal/Syntax/AST.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
@@ -54,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)
@@ -104,6 +106,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 err -> fail $ show err
+      Right name -> return name
+
 instance Arbitrary Name where
   arbitrary = do
     initial <- elements alpha
@@ -153,7 +161,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

src/GraphQL/Value.hs

@@ -50,9 +50,14 @@ module GraphQL.Value
 
 import Protolude
 
+import Control.Monad.Fail
 import qualified Data.Aeson as Aeson
-import Data.Aeson (ToJSON(..), (.=), pairs)
+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)
+import qualified Data.Vector as Vector
 import Test.QuickCheck (Arbitrary(..), Gen, oneof, listOf, sized)
 
 import GraphQL.Internal.Arbitrary (arbitraryText)
@@ -86,6 +91,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 +161,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 +175,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 other = typeMismatch "Scalar" other
+
 instance ToJSON ConstScalar where
   toJSON (ConstInt x) = toJSON x
   toJSON (ConstFloat x) = toJSON x
@@ -213,14 +235,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 +265,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 +325,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 -> fail "duplicate keys in object"
+      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])

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

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

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,13 +18,35 @@ 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)
 
 
 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)