Added exception handling with Alternative constraint according to spec.

Data/GraphQL/Error.hs

@@ -0,0 +1,62 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Data.GraphQL.Error (
+  parseError,
+  CollectErrsT,
+  addErr,
+  addErrMsg,
+  runCollectErrs,
+  joinErrs,
+  errWrap
+  ) where
+
+import qualified Data.Aeson as Aeson
+import Data.Text (Text, pack)
+
+import Control.Arrow ((&&&))
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative (Applicative, pure)
+import Data.Foldable (Foldable, concatMap)
+import Prelude hiding (concatMap)
+#endif
+
+-- | Wraps a parse error into a list of errors.
+parseError :: Applicative f => String -> f Aeson.Value
+parseError s =
+  pure $ Aeson.object [("errors", Aeson.toJSON [makeErrorMsg $ pack s])]
+
+-- | A wrapper for an applicative functor, for passing around error messages.
+type CollectErrsT f a = f (a,[Aeson.Value])
+
+-- | Takes a (wrapped) list (foldable functor) of values and errors and
+--   joins the values into a list and concatenates the errors.
+joinErrs
+  :: (Functor m, Functor f, Foldable f)
+  => m (f (a,[Aeson.Value])) -> CollectErrsT m (f a)
+joinErrs = fmap $ fmap fst &&& concatMap snd
+
+-- | Wraps the given applicative to handle errors
+errWrap :: Functor f => f a -> f (a, [Aeson.Value])
+errWrap = fmap (flip (,) [])
+
+-- | Adds an error to the list of errors.
+addErr :: Functor f => Aeson.Value -> CollectErrsT f a -> CollectErrsT f a
+addErr v = (fmap . fmap) (v :)
+
+makeErrorMsg :: Text -> Aeson.Value
+makeErrorMsg s = Aeson.object [("message",Aeson.toJSON s)]
+
+-- | Convenience function for just wrapping an error message.
+addErrMsg :: Functor f => Text -> CollectErrsT f a -> CollectErrsT f a
+addErrMsg = addErr . makeErrorMsg
+
+-- | Runs the given query computation, but collects the errors into an error
+--  list, which is then sent back with the data.
+runCollectErrs :: Functor f => CollectErrsT f Aeson.Value -> f Aeson.Value
+runCollectErrs = fmap finalD
+  where finalD (dat,errs) =
+          Aeson.object $
+          if null errs
+            then [("data",dat)]
+            else [("data",dat),("errors",Aeson.toJSON $ reverse errs)]

Data/GraphQL/Execute.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
 module Data.GraphQL.Execute (execute) where
 
 #if !MIN_VERSION_base(4,8,0)
@@ -13,10 +14,19 @@ import Data.GraphQL.AST
 import Data.GraphQL.Schema (Schema(..))
 import qualified Data.GraphQL.Schema as Schema
 
-execute
-  :: Alternative f
-  => Schema.Schema f -> Schema.Subs -> Document -> f Aeson.Value
-execute (Schema resolvs) subs = Schema.resolvers resolvs . rootFields subs
+import Data.GraphQL.Error
+
+{- | Takes a schema, a substitution and a GraphQL document.
+     The substition is applied to the document using rootFields, and
+     the schema's resolvers are applied to the resulting fields.
+     Returns the result of the query against the schema wrapped in a
+     "data" field, or errors wrapped in a "errors field".
+-}
+execute :: Alternative m
+  => Schema.Schema m -> Schema.Subs -> Document -> m Aeson.Value
+execute (Schema resolvs) subs doc = runCollectErrs res
+  where res = Schema.resolvers resolvs $ rootFields subs doc
+
 
 rootFields :: Schema.Subs -> Document -> [Field]
 rootFields subs (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) =

Data/GraphQL/Schema.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE LambdaCase #-}
 module Data.GraphQL.Schema
   ( Schema(..)
@@ -28,7 +29,7 @@ import Data.Monoid (Monoid(mempty,mappend))
 #else
 import Data.Monoid (Alt(Alt,getAlt))
 #endif
-import Control.Applicative (Alternative, empty)
+import Control.Applicative (Alternative(..))
 import Data.Maybe (catMaybes)
 import Data.Foldable (fold)
 
@@ -36,13 +37,16 @@ import qualified Data.Aeson as Aeson
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
 import Data.Text (Text)
-import qualified Data.Text as T (null)
+import qualified Data.Text as T (null, unwords)
+
+import Control.Arrow
 
 import Data.GraphQL.AST
+import Data.GraphQL.Error
 
 data Schema f = Schema [Resolver f]
 
-type Resolver  f = Field -> f Aeson.Object
+type Resolver f = Field -> CollectErrsT f Aeson.Object
 
 type Subs = Text -> Maybe Text
 
@@ -65,7 +69,7 @@ scalar name s = scalarA name $ \case
 scalarA
   :: (Alternative f, Aeson.ToJSON a)
   => Text -> ([Argument] -> f a) -> Resolver f
-scalarA name f fld@(Field _ _ args _ []) = withField name (f args) fld
+scalarA name f fld@(Field _ _ args _ []) = withField name (errWrap $ f args) fld
 scalarA _ _ _ = empty
 
 array :: Alternative f => Text -> [[Resolver f]] -> Resolver f
@@ -77,7 +81,7 @@ arrayA
   :: Alternative f
   => Text -> ([Argument] -> [[Resolver f]]) -> Resolver f
 arrayA name f fld@(Field _ _ args _ sels) =
-     withField name (traverse (flip resolvers $ fields sels) $ f args) fld
+     withField name (joinErrs $ traverse (flip resolvers $ fields sels) $ f args) fld
 
 enum :: Alternative f => Text -> f [Text] -> Resolver f
 enum name enums = enumA name $ \case
@@ -85,23 +89,27 @@ enum name enums = enumA name $ \case
      _  -> empty
 
 enumA :: Alternative f => Text -> ([Argument] -> f [Text]) -> Resolver f
-enumA name f fld@(Field _ _ args _ []) = withField name (f args) fld
+enumA name f fld@(Field _ _ args _ []) = withField name (errWrap $ f args) fld
 enumA _ _ _ = empty
 
 withField
   :: (Alternative f, Aeson.ToJSON a)
-  => Text -> f a -> Field -> f (HashMap Text Aeson.Value)
+  => Text -> CollectErrsT f a -> Field -> CollectErrsT f (HashMap Text Aeson.Value)
 withField name f (Field alias name' _ _ _) =
      if name == name'
-        then fmap (HashMap.singleton aliasOrName . Aeson.toJSON) f
+        then fmap (first $ HashMap.singleton aliasOrName . Aeson.toJSON) f
         else empty
      where
        aliasOrName = if T.null alias then name' else alias
 
-resolvers :: Alternative f => [Resolver f] -> [Field] -> f Aeson.Value
+resolvers :: Alternative f => [Resolver f] -> [Field] -> CollectErrsT f Aeson.Value
 resolvers resolvs =
-    fmap (Aeson.toJSON . fold)
-  . traverse (\fld -> getAlt $ foldMap (Alt . ($ fld)) resolvs)
+    fmap (first Aeson.toJSON . fold)
+  . traverse (\fld -> (getAlt $ foldMap (Alt . ($ fld)) resolvs) <|> errmsg fld)
+    where errmsg (Field alias name _ _ _) = addErrMsg msg $ (errWrap . pure) val
+            where val = HashMap.singleton aliasOrName Aeson.Null
+                  msg = T.unwords ["field", name, "not resolved."]
+                  aliasOrName = if T.null alias then name else alias
 
 field :: Selection -> Maybe Field
 field (SelectionField x) = Just x