Expand introspection system

Author: jamesdabbs

graphql-api.cabal

@@ -2,7 +2,7 @@
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 24bc26dbd1f77e90690a71683ae20372d13f4729b6073940a17679e5bc18c609
+-- hash: 796abb771a05858c20303db3e1ddd30cbdf11f24f02e09eed0fe8a9850c43269
 
 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:
@@ -145,16 +146,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

@@ -74,6 +74,7 @@ tests:
       - aeson-qq
       - tasty
       - tasty-hspec
+      - template-haskell
       - text
       - directory
 

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/Schema.hs

@@ -23,6 +23,7 @@ module GraphQL.Internal.Schema
   , ObjectTypeDefinition(..)
   , UnionTypeDefinition(..)
   , ScalarTypeDefinition(..)
+  , TypeExtensionDefinition(..)
   -- ** Input types
   , InputType(..)
   , InputTypeDefinition(..)
@@ -143,7 +144,7 @@ instance DefinesTypes TypeDefinition where
       TypeDefinitionUnion x -> getDefinedTypes x
       TypeDefinitionScalar x  -> getDefinedTypes x
       TypeDefinitionEnum x -> getDefinedTypes x
-      TypeDefinitionInputObject _ -> mempty
+      TypeDefinitionInputObject x -> getDefinedTypes x
       TypeDefinitionTypeExtension _ ->
         panic "TODO: we should remove the 'extend' behaviour entirely"
 
@@ -254,12 +255,20 @@ data InputObjectTypeDefinition = InputObjectTypeDefinition Name (NonEmpty InputO
 instance HasName InputObjectTypeDefinition where
   getName (InputObjectTypeDefinition name _) = name
 
+instance DefinesTypes InputObjectTypeDefinition where
+  getDefinedTypes obj@(InputObjectTypeDefinition name fields) =
+    Map.singleton name (TypeDefinitionInputObject obj) <>
+      foldMap getDefinedTypes fields
+
 data InputObjectFieldDefinition = InputObjectFieldDefinition Name (AnnotatedType InputType) (Maybe DefaultValue)
                                   deriving (Eq, Ord, Show) -- XXX: spec is unclear about default value for input object field definitions
 
 instance HasName InputObjectFieldDefinition where
   getName (InputObjectFieldDefinition name _ _) = name
 
+instance DefinesTypes InputObjectFieldDefinition where
+  getDefinedTypes (InputObjectFieldDefinition _ annotatedInput _) = getDefinedTypes $ getAnnotatedType annotatedInput
+
 newtype TypeExtensionDefinition = TypeExtensionDefinition ObjectTypeDefinition
                                   deriving (Eq, Ord, Show)
 

src/GraphQL/Internal/Validation.hs

@@ -39,8 +39,10 @@ module GraphQL.Internal.Validation
   , QueryDocument(..)
   , validate
   , getErrors
+  , DefinitionType(..)
+  , getDefinitionType
   -- * Operating on validated documents
-  , Operation
+  , Operation(..)
   , getSelectionSet
   -- * Executing validated documents
   , VariableDefinition(..)
@@ -926,3 +928,29 @@ instance Applicative (Validator e) where
   Validator (Left e) <*> _ = Validator (Left e)
   Validator _ <*> (Validator (Left e)) = Validator (Left e)
   Validator (Right f) <*> Validator (Right x) = Validator (Right (f x))
+
+data DefinitionType = QueryDefinition | MutationDefinition deriving (Eq, Show)
+
+getDefinitionType :: AST.QueryDocument -> Maybe Name -> Maybe DefinitionType
+getDefinitionType doc (Just name) = 
+  case find (operationNamed name) $ getOperationDefinitions doc of
+    Just (AST.Mutation _) -> Just MutationDefinition
+    Just _ -> Just QueryDefinition
+    _ -> Nothing
+getDefinitionType doc Nothing =
+  case getOperationDefinitions doc of
+    [op] -> case op of
+      (AST.Mutation _) -> Just MutationDefinition
+      _ -> Just QueryDefinition
+    _ -> Nothing
+
+getOperationDefinitions :: AST.QueryDocument -> [AST.OperationDefinition]
+getOperationDefinitions = mapMaybe extract . AST.getDefinitions
+  where
+    extract (AST.DefinitionOperation op) = Just op
+    extract _ = Nothing
+
+operationNamed :: Name -> AST.OperationDefinition -> Bool
+operationNamed n (AST.Query    (AST.Node n' _ _ _)) = Just n == n'
+operationNamed n (AST.Mutation (AST.Node n' _ _ _)) = Just n == n'
+operationNamed _ _ = False