Added exception handling with Alternative constraint according to spec.

6 files changed, 133 insertions, 48 deletions

diff --git a/Data/GraphQL.hs b/Data/GraphQL.hs
index 2da8a46..a2796ae 100644
--- a/Data/GraphQL.hs
+++ b/Data/GraphQL.hs
@@ -1,6 +1,6 @@
 module Data.GraphQL where
 
-import Control.Applicative (Alternative, empty)
+import Control.Applicative (Alternative)
 
 import Data.Text (Text)
 
@@ -11,10 +11,13 @@ import Data.GraphQL.Execute
 import Data.GraphQL.Parser
 import Data.GraphQL.Schema
 
+import Data.GraphQL.Error
+
 graphql :: (Alternative m, Monad m) => Schema m -> Text -> m Aeson.Value
 graphql = flip graphqlSubs $ const Nothing
 
+
 graphqlSubs :: (Alternative m, Monad m) => Schema m -> Subs -> Text -> m Aeson.Value
 graphqlSubs schema f =
-    either (const empty) (execute schema f)
+    either parseError (execute schema f)
   . Attoparsec.parseOnly document
diff --git a/Data/GraphQL/Error.hs b/Data/GraphQL/Error.hs
new file mode 100644
index 0000000..25632b4
--- /dev/null
+++ b/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)]
diff --git a/Data/GraphQL/Execute.hs b/Data/GraphQL/Execute.hs
index 47d1d03..e5998e9 100644
--- a/Data/GraphQL/Execute.hs
+++ b/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))]) =
diff --git a/Data/GraphQL/Schema.hs b/Data/GraphQL/Schema.hs
index 1c45af2..345984c 100644
--- a/Data/GraphQL/Schema.hs
+++ b/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
diff --git a/graphql.cabal b/graphql.cabal
index 18c78fa..4b3cc38 100644
--- a/graphql.cabal
+++ b/graphql.cabal
@@ -28,10 +28,11 @@ library
                        Data.GraphQL.Execute
                        Data.GraphQL.Schema
                        Data.GraphQL.Parser
-  build-depends:       base >= 4.7 && < 5,
-                       text >= 0.11.3.1,
-                       aeson >= 0.7.0.3,
+                       Data.GraphQL.Error
+  build-depends:       aeson >= 0.7.0.3,
                        attoparsec >= 0.10.4.0,
+                       base >= 4.7 && < 5,
+                       text >= 0.11.3.1,
                        unordered-containers >= 0.2.5.0
 
 test-suite tasty
@@ -44,15 +45,15 @@ test-suite tasty
                        Test.StarWars.Data
                        Test.StarWars.Schema
                        Test.StarWars.QueryTests
-  build-depends:       base >= 4.6 && <5,
-                       aeson >= 0.7.0.3,
-                       text >= 0.11.3.1,
+  build-depends:       aeson >= 0.7.0.3,
                        attoparsec >= 0.10.4.0,
+                       base >= 4.6 && <5,
+                       graphql,
                        raw-strings-qq >= 1.1,
                        tasty >= 0.10,
                        tasty-hunit >= 0.9,
-                       unordered-containers >= 0.2.5.0,
-                       graphql
+                       text >= 0.11.3.1,
+                       unordered-containers >= 0.2.5.0
 
 source-repository head
   type:     git
diff --git a/tests/Test/StarWars/QueryTests.hs b/tests/Test/StarWars/QueryTests.hs
index ccaf481..11dd2d5 100644
--- a/tests/Test/StarWars/QueryTests.hs
+++ b/tests/Test/StarWars/QueryTests.hs
@@ -2,7 +2,7 @@
 {-# LANGUAGE QuasiQuotes #-}
 module Test.StarWars.QueryTests (test) where
 
-import qualified Data.Aeson as Aeson (Value)
+import qualified Data.Aeson as Aeson (Value(Null), toJSON)
 import Data.Aeson (object, (.=))
 import Data.Text (Text)
 import Text.RawString.QQ (r)
@@ -28,7 +28,7 @@ test = testGroup "Star Wars Query Tests"
               }
             }
         |]
-      $ object ["hero" .= object ["id" .= ("2001" :: Text)]]
+      $ object [ "data" .= object ["hero" .= object ["id" .= ("2001" :: Text)]]]
     , testCase "R2-D2 ID and friends" . testQuery
         [r| query HeroNameAndFriendsQuery {
               hero {
@@ -40,7 +40,7 @@ test = testGroup "Star Wars Query Tests"
               }
             }
         |]
-      $ object [
+      $ object [ "data" .= object [
           "hero" .= object [
               "id" .= ("2001" :: Text)
             , "name" .= ("R2-D2" :: Text)
@@ -50,7 +50,7 @@ test = testGroup "Star Wars Query Tests"
                 , object ["name" .= ("Leia Organa" :: Text)]
                 ]
             ]
-        ]
+        ]]
     ]
   , testGroup "Nested Queries"
     [ testCase "R2-D2 friends" . testQuery
@@ -67,7 +67,7 @@ test = testGroup "Star Wars Query Tests"
               }
             }
         |]
-      $ object [
+      $ object [ "data" .= object [
           "hero" .= object [
               "name" .= ("R2-D2" :: Text)
             , "friends" .= [
@@ -102,7 +102,7 @@ test = testGroup "Star Wars Query Tests"
                     ]
                 ]
             ]
-        ]
+        ]]
     , testCase "Luke ID" . testQuery
         [r| query FetchLukeQuery {
               human(id: "1000") {
@@ -110,12 +110,12 @@ test = testGroup "Star Wars Query Tests"
               }
             }
         |]
-      $ object [
+      $ object [ "data" .= object [
           "human" .= object [
              "name" .= ("Luke Skywalker" :: Text)
           ]
         ]
-    ]
+    ]]
     , testCase "Luke ID with variable" . testQueryParams
          (\v -> if v == "someId"
                    then Just "1000"
@@ -126,9 +126,9 @@ test = testGroup "Star Wars Query Tests"
                }
              }
          |]
-      $ object [
+      $ object [ "data" .= object [
           "human" .= object ["name" .= ("Luke Skywalker" :: Text)]
-        ]
+        ]]
     , testCase "Han ID with variable" . testQueryParams
         (\v -> if v == "someId"
                   then Just "1002"
@@ -139,10 +139,10 @@ test = testGroup "Star Wars Query Tests"
               }
             }
         |]
-      $ object [
+      $ object [ "data" .= object [
           "human" .= object ["name" .= ("Han Solo" :: Text)]
-        ]
-    , testCase "Invalid ID" $ testFailParams
+        ]]
+    , testCase "Invalid ID" . testQueryParams
         (\v -> if v == "id"
                   then Just "Not a valid ID"
                   else Nothing)
@@ -151,13 +151,14 @@ test = testGroup "Star Wars Query Tests"
                 name
               }
             }
-        |]
+        |] $ object ["data" .= object ["human" .= object ["name" .= Aeson.Null]],
+                     "errors" .= (Aeson.toJSON [object ["message" .= ("field name not resolved." :: Text)]])]
         -- TODO: This test is directly ported from `graphql-js`, however do we want
         -- to mimic the same behavior? Is this part of the spec? Once proper
         -- exceptions are implemented this test might no longer be meaningful.
         -- If the same behavior needs to be replicated, should it be implemented
         -- when defining the `Schema` or when executing?
-        -- $ object ["human" .= Aeson.Null]
+        -- $ object [ "data" .= object ["human" .= Aeson.Null] ]
     , testCase "Luke aliased" . testQuery
         [r| query FetchLukeAliased {
               luke: human(id: "1000") {
@@ -165,11 +166,11 @@ test = testGroup "Star Wars Query Tests"
               }
             }
         |]
-      $ object [
+      $ object [ "data" .= object [
          "luke" .= object [
            "name" .= ("Luke Skywalker" :: Text)
            ]
-        ]
+        ]]
     , testCase "R2-D2 ID and friends aliased" . testQuery
         [r| query HeroNameAndFriendsQuery {
               hero {
@@ -181,7 +182,7 @@ test = testGroup "Star Wars Query Tests"
               }
             }
         |]
-      $ object [
+      $ object [ "data" .= object [
           "hero" .= object [
               "id" .= ("2001" :: Text)
             , "name" .= ("R2-D2" :: Text)
@@ -191,7 +192,7 @@ test = testGroup "Star Wars Query Tests"
                 , object ["friendName" .= ("Leia Organa" :: Text)]
                 ]
             ]
-        ]
+        ]]
     , testCase "Luke and Leia aliased" . testQuery
         [r| query FetchLukeAndLeiaAliased {
               luke: human(id: "1000") {
@@ -202,14 +203,14 @@ test = testGroup "Star Wars Query Tests"
               }
             }
         |]
-      $ object [
+      $ object [ "data" .= object [
           "luke" .= object [
             "name" .= ("Luke Skywalker" :: Text)
            ]
         , "leia" .= object [
             "name" .= ("Leia Organa" :: Text)
            ]
-        ]
+        ]]
   ]
 
 testQuery :: Text -> Aeson.Value -> Assertion
@@ -221,5 +222,5 @@ testQuery q expected = graphql schema q @?= Just expected
 testQueryParams :: Subs -> Text -> Aeson.Value -> Assertion
 testQueryParams f q expected = graphqlSubs schema f q @?= Just expected
 
-testFailParams :: Subs -> Text -> Assertion
-testFailParams f q = graphqlSubs schema f q @?= Nothing
+-- testFailParams :: Subs -> Text -> Assertion
+-- testFailParams f q = graphqlSubs schema f q @?= Nothing