Expand mutation and introspection support

graphql-api.cabal

@@ -2,7 +2,7 @@
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 6db006b020fe198ac64b8a50f8335017251389b7c34dfc553675e38eb001a428
+-- hash: 0aae3dfe62e79c389edba2fdfb743c340f8fc3401c67124aa1f623415db39ab8
 
 name:           graphql-api
 version:        0.3.0
@@ -67,6 +67,7 @@ library
       GraphQL.Internal.Value
       GraphQL.Internal.Value.FromValue
       GraphQL.Internal.Value.ToValue
+      GraphQL.Introspection
       GraphQL.Resolver
       GraphQL.Value
   other-modules:
@@ -133,8 +134,11 @@ test-suite graphql-api-tests
   build-depends:
       QuickCheck
     , aeson
+    , aeson-diff
+    , aeson-qq
     , attoparsec
     , base >=4.9 && <5
+    , bytestring
     , containers
     , directory
     , exceptions
@@ -144,15 +148,19 @@ test-suite graphql-api-tests
     , raw-strings-qq
     , tasty
     , tasty-hspec
+    , template-haskell
+    , text
     , transformers
   other-modules:
       ASTTests
       EndToEndTests
       EnumTests
       ExampleSchema
+      MutationTests
       OrderedMapTests
       ResolverTests
       SchemaTests
+      Utils
       ValidationTests
       ValueTests
       Paths_graphql_api

package.yaml

@@ -71,8 +71,13 @@ tests:
       - hspec
       - QuickCheck
       - raw-strings-qq
+      - aeson-diff
+      - aeson-qq
+      - bytestring
       - tasty
       - tasty-hspec
+      - template-haskell
+      - text
       - directory
 
   graphql-api-doctests:

src/GraphQL.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
 -- | Interface for GraphQL API.
 --
 -- __Note__: This module is highly subject to change. We're still figuring
@@ -10,14 +11,17 @@ module GraphQL
   (
     -- * Running queries
     interpretQuery
+  , interpretRequest
   , interpretAnonymousQuery
   , Response(..)
     -- * Preparing queries then running them
   , makeSchema
   , compileQuery
   , executeQuery
+  , executeRequest
   , QueryError
   , Schema
+  , SchemaRoot(..)
   , VariableValues
   , Value
   ) where
@@ -30,7 +34,7 @@ import qualified Data.List.NonEmpty as NonEmpty
 import GraphQL.API (HasObjectDefinition(..), SchemaError(..))
 import GraphQL.Internal.Execution
   ( VariableValues
-  , ExecutionError
+  , ExecutionError(..)
   , substituteVariables
   )
 import qualified GraphQL.Internal.Execution as Execution
@@ -43,6 +47,9 @@ import GraphQL.Internal.Validation
   , validate
   , getSelectionSet
   , VariableValue
+  , Operation(..)
+  , DefinitionType(..)
+  , getDefinitionType
   )
 import GraphQL.Internal.Output
   ( GraphQLError(..)
@@ -83,6 +90,16 @@ instance GraphQLError QueryError where
   formatError (NonObjectResult v) =
     "Query returned a value that is not an object: " <> show v
 
+toResult :: Result Value -> Response
+toResult (Result errors result) = case result of
+  -- TODO: Prevent this at compile time. Particularly frustrating since
+  -- we *know* that queries and mutations have object definitions
+  ValueObject object ->
+    case NonEmpty.nonEmpty errors of
+      Nothing -> Success object
+      Just errs -> PartialSuccess object (map toError errs)
+  v -> ExecutionFailure (singleError (NonObjectResult v))
+
 -- | Execute a GraphQL query.
 executeQuery
   :: forall api m. (HasResolver m api, Applicative m, HasObjectDefinition api)
@@ -94,17 +111,7 @@ executeQuery
 executeQuery handler document name variables =
   case getOperation document name variables of
     Left e -> pure (ExecutionFailure (singleError e))
-    Right operation -> toResult <$> resolve @m @api handler (Just operation)
-  where
-    toResult (Result errors result) =
-      case result of
-        -- TODO: Prevent this at compile time. Particularly frustrating since
-        -- we *know* that api has an object definition.
-        ValueObject object ->
-          case NonEmpty.nonEmpty errors of
-            Nothing -> Success object
-            Just errs -> PartialSuccess object (map toError errs)
-        v -> ExecutionFailure (singleError (NonObjectResult v))
+    Right (_, ss) -> toResult <$> resolve @m @api handler (Just ss)
 
 -- | Create a GraphQL schema.
 makeSchema :: forall api. HasObjectDefinition api => Either QueryError Schema
@@ -135,6 +142,75 @@ interpretAnonymousQuery
   -> m Response -- ^ The result of running the query.
 interpretAnonymousQuery handler query = interpretQuery @api @m handler query Nothing mempty
 
+data SchemaRoot m query mutation = SchemaRoot
+  { queries   :: Handler m query
+  , mutations :: Handler m mutation
+  }
+
+-- | Execute a query or mutation
+--
+-- Similar to executeQuery, execept requests are dispatched against the
+-- SchemaRoot depending on whether they are a query or mutation
+executeRequest
+  :: forall schema queries mutations m.
+  ( schema ~ SchemaRoot m queries mutations
+  , HasResolver m queries
+  , HasObjectDefinition queries
+  , HasResolver m mutations
+  , HasObjectDefinition mutations
+  , Monad m
+  )
+  => SchemaRoot m queries mutations
+  -> QueryDocument VariableValue
+  -> Maybe Name
+  -> VariableValues
+  -> m Response
+executeRequest (SchemaRoot qh mh) document name variables =
+  case getOperation document name variables of
+    Left e -> pure (ExecutionFailure (singleError e))
+    Right (operation, ss) -> do
+      toResult <$> case operation of
+        Query    _ _ _ -> resolve @m @queries qh (Just ss)
+        Mutation _ _ _ -> resolve @m @mutations mh (Just ss)
+
+-- | Interpret a query or mutation against a SchemaRoot
+interpretRequest
+  :: forall schema queries mutations m.
+  ( schema ~ SchemaRoot m queries mutations
+  , HasResolver m queries
+  , HasObjectDefinition queries
+  , HasResolver m mutations
+  , HasObjectDefinition mutations
+  , Monad m
+  )
+  => SchemaRoot m queries mutations
+  -> Text
+  -> Maybe Name
+  -> VariableValues
+  -> m Response
+interpretRequest (SchemaRoot qh mh) text name variables = case parseQuery text of
+  Left err -> pure (PreExecutionFailure (toError (ParseError err) :| []))
+  Right document ->
+    case getDefinitionType document name of
+      Just operation -> case operation of
+        QueryDefinition    -> run @m @queries qh document
+        MutationDefinition -> run @m @mutations mh document
+      _ -> 
+        let err = maybe NoAnonymousOperation NoSuchOperation name
+        in pure (ExecutionFailure (toError err :| []))
+    where
+      run :: forall n api.
+          ( HasObjectDefinition api
+          , HasResolver n api
+          , Applicative n
+          )
+          => Handler n api -> AST.QueryDocument -> n Response
+      run h doc = case makeSchema @api of
+        Left e -> pure (PreExecutionFailure (toError e :| []))
+        Right schema -> case validate schema doc of
+          Left e -> pure (PreExecutionFailure (toError (ValidationError e) :| []))
+          Right validated -> executeQuery @api h validated name variables
+
 -- | Turn some text into a valid query document.
 compileQuery :: Schema -> Text -> Either QueryError (QueryDocument VariableValue)
 compileQuery schema query = do
@@ -146,8 +222,8 @@ parseQuery :: Text -> Either Text AST.QueryDocument
 parseQuery query = first toS (parseOnly (Parser.queryDocument <* endOfInput) query)
 
 -- | Get an operation from a query document ready to be processed.
-getOperation :: QueryDocument VariableValue -> Maybe Name -> VariableValues -> Either QueryError (SelectionSetByType Value)
+getOperation :: QueryDocument VariableValue -> Maybe Name -> VariableValues -> Either QueryError (Operation VariableValue, SelectionSetByType Value)
 getOperation document name vars = first ExecutionError $ do
   op <- Execution.getOperation document name
   resolved <- substituteVariables op vars
-  pure (getSelectionSet resolved)
+  pure (op, getSelectionSet resolved)

src/GraphQL/Internal/API.hs

@@ -26,6 +26,8 @@ module GraphQL.Internal.API
   , HasAnnotatedType(..)
   , HasAnnotatedInputType
   , HasObjectDefinition(..)
+  , HasFieldDefinitions(..)
+  , HasInterfaceDefinitions(..)
   , getArgumentDefinition
   , SchemaError(..)
   , nameFromSymbol
@@ -75,7 +77,6 @@ import GraphQL.Internal.Output (GraphQLError(..))
 data a :> b = a :> b
 infixr 8 :>
 
-
 data Object (name :: Symbol) (interfaces :: [Type]) (fields :: [Type])
 data Enum (name :: Symbol) (values :: Type)
 data Union (name :: Symbol) (types :: [Type])
@@ -87,7 +88,6 @@ data Interface (name :: Symbol) (fields :: [Type])
 data Field (name :: Symbol) (fieldType :: Type)
 data Argument (name :: Symbol) (argType :: Type)
 
-
 -- | The type-level schema was somehow invalid.
 data SchemaError
   = NameError NameError

src/GraphQL/Internal/Resolver.hs

@@ -53,8 +53,9 @@ import GraphQL.Value
   , FromValue(..)
   , ToValue(..)
   )
-import GraphQL.Internal.Name (Name, HasName(..))
+import GraphQL.Internal.Name (Name, HasName(..), unName)
 import qualified GraphQL.Internal.OrderedMap as OrderedMap
+import GraphQL.Internal.Schema (ObjectTypeDefinition(..))
 import GraphQL.Internal.Output (GraphQLError(..))
 import GraphQL.Internal.Validation
   ( SelectionSetByType
@@ -212,9 +213,16 @@ type family FieldName (a :: Type) = (r :: Symbol) where
   FieldName x = TypeError ('Text "Unexpected branch in FieldName type family. Please file a bug!" ':<>: 'ShowType x)
 
 resolveField :: forall dispatchType (m :: Type -> Type).
-  (BuildFieldResolver m dispatchType, Monad m, KnownSymbol (FieldName dispatchType))
-  => FieldHandler m dispatchType -> m ResolveFieldResult -> Field Value -> m ResolveFieldResult
-resolveField handler nextHandler field =
+  ( BuildFieldResolver m dispatchType
+  , Monad m
+  , KnownSymbol (FieldName dispatchType)
+  ) 
+  => FieldHandler m dispatchType 
+  -> m ResolveFieldResult 
+  -> ObjectTypeDefinition
+  -> Field Value 
+  -> m ResolveFieldResult
+resolveField handler nextHandler defn field =
   -- check name before
   case API.nameFromSymbol @(FieldName dispatchType) of
     Left err -> pure (Result [SchemaError err] (Just GValue.ValueNull))
@@ -225,6 +233,8 @@ resolveField handler nextHandler field =
             Right resolver -> do
               Result errs value <- resolver
               pure (Result errs (Just value))
+      | getName field == "__typename" -> 
+          pure $ Result [] (Just $ GValue.ValueString $ GValue.String $ unName $ getName defn)
       | otherwise -> nextHandler
 
 -- We're using our usual trick of rewriting a type in a closed type
@@ -312,7 +322,6 @@ type family RunFieldsHandler (m :: Type -> Type) (a :: Type) = (r :: Type) where
   RunFieldsHandler m a = TypeError (
     'Text "Unexpected RunFieldsHandler types: " ':<>: 'ShowType a)
 
-
 class RunFields m a where
   -- | Run a single 'Selection' over all possible fields (as specified by the
   -- type @a@), returning exactly one 'GValue.ObjectField' when a field
@@ -321,7 +330,7 @@ class RunFields m a where
   -- Individual implementations are responsible for calling 'runFields' if
   -- they haven't matched the field and there are still candidate fields
   -- within the handler.
-  runFields :: RunFieldsHandler m a -> Field Value -> m ResolveFieldResult
+  runFields :: RunFieldsHandler m a -> ObjectTypeDefinition -> Field Value -> m ResolveFieldResult
 
 instance forall f fs m dispatchType.
          ( BuildFieldResolver m dispatchType
@@ -330,19 +339,19 @@ instance forall f fs m dispatchType.
          , KnownSymbol (FieldName dispatchType)
          , Monad m
          ) => RunFields m (f :<> fs) where
-  runFields (handler :<> nextHandlers) field =
-    resolveField @dispatchType @m handler nextHandler field
+  runFields (handler :<> nextHandlers) defn field =
+    resolveField @dispatchType @m handler nextHandler defn field
     where
-      nextHandler = runFields @m @fs nextHandlers field
+      nextHandler = runFields @m @fs nextHandlers defn field
 
 instance forall ksM t m dispatchType.
          ( BuildFieldResolver m dispatchType
          , KnownSymbol ksM
          , dispatchType ~ FieldResolverDispatchType (API.Field ksM t)
          , Monad m
          ) => RunFields m (API.Field ksM t) where
-  runFields handler field =
-    resolveField @dispatchType @m handler nextHandler field
+  runFields handler defn field =
+    resolveField @dispatchType @m handler nextHandler defn field
     where
       nextHandler = pure (Result [FieldNotFoundError (getName field)] Nothing)
 
@@ -352,8 +361,8 @@ instance forall m a b dispatchType.
          , KnownSymbol (FieldName dispatchType)
          , Monad m
          ) => RunFields m (a :> b) where
-  runFields handler field =
-    resolveField @dispatchType @m handler nextHandler field
+  runFields handler defn field =
+    resolveField @dispatchType @m handler nextHandler defn field
     where
       nextHandler = pure (Result [FieldNotFoundError (getName field)] Nothing)
 
@@ -368,12 +377,12 @@ instance forall typeName interfaces fields m.
   resolve mHandler (Just selectionSet) =
     case getSelectionSet of
       Left err -> throwE err
-      Right ss -> do
+      Right (ss, defn) -> do
         -- Run the handler so the field resolvers have access to the object.
         -- This (and other places, including field resolvers) is where user
         -- code can do things like look up something in a database.
         handler <- mHandler
-        r <- traverse (runFields @m @(RunFieldsType m fields) handler) ss
+        r <- traverse (runFields @m @(RunFieldsType m fields) handler defn) ss
         let (Result errs obj)  = GValue.objectFromOrderedMap . OrderedMap.catMaybes <$> sequenceA r
         pure (Result errs (GValue.ValueObject obj))
 
@@ -391,7 +400,7 @@ instance forall typeName interfaces fields m.
         -- See <https://facebook.github.io/graphql/#sec-Field-Collection> for
         -- more details.
         (SelectionSet ss') <- first ValidationError $ getSelectionSetForType defn selectionSet
-        pure ss'
+        pure (ss', defn)
 
 -- TODO(tom): we're getting to a point where it might make sense to
 -- split resolver into submodules (GraphQL.Resolver.Union  etc.)