From d1953891029a71115ee572b7b3798072cbaf2ea8 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Matth=C3=ADas=20P=C3=A1ll=20Gissurarson?= <mpg@mpg.is>
Date: Sat, 12 Mar 2016 00:59:51 +0100
Subject: Added exception handling with Alternative constraint according to
 spec.

---
 Data/GraphQL.hs         |  7 ++++--
 Data/GraphQL/Error.hs   | 62 +++++++++++++++++++++++++++++++++++++++++++++++++
 Data/GraphQL/Execute.hs | 18 ++++++++++----
 Data/GraphQL/Schema.hs  | 30 +++++++++++++++---------
 4 files changed, 100 insertions(+), 17 deletions(-)
 create mode 100644 Data/GraphQL/Error.hs

(limited to 'Data')

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
-- 
cgit v1.2.3


From 61d6af777897d918decc0ab8ef6456e05fccbe7b Mon Sep 17 00:00:00 2001
From: solrun <solalola@gmail.com>
Date: Wed, 9 Mar 2016 01:15:46 +0100
Subject: Added documentation of functions and modules and included
 tutorial.lhs.

---
 Data/GraphQL.hs         | 14 +++++++++++++-
 Data/GraphQL/AST.hs     | 39 +++++++++++++++++++++++++++++++++++++++
 Data/GraphQL/Encoder.hs |  2 ++
 Data/GraphQL/Execute.hs | 20 ++++++++++++++++----
 Data/GraphQL/Parser.hs  |  2 ++
 Data/GraphQL/Schema.hs  | 25 +++++++++++++++++++++++++
 6 files changed, 97 insertions(+), 5 deletions(-)

(limited to 'Data')

diff --git a/Data/GraphQL.hs b/Data/GraphQL.hs
index a2796ae..a5dac4d 100644
--- a/Data/GraphQL.hs
+++ b/Data/GraphQL.hs
@@ -1,3 +1,6 @@
+-- | The module Data.GraphQl provides the
+--   functions graphql and graphqlSubs to parse
+--   and execute GraphQL queries.
 module Data.GraphQL where
 
 import Control.Applicative (Alternative)
@@ -13,10 +16,19 @@ import Data.GraphQL.Schema
 
 import Data.GraphQL.Error
 
+-- | graphql takes a schema and text representing a GraphQL request document.
+--   If the text parses correctly as a GraphQl query
+--   the query is executed according to the given schema.
+--   Returns the response to the query wrapped in an Aeson.Value.
 graphql :: (Alternative m, Monad m) => Schema m -> Text -> m Aeson.Value
 graphql = flip graphqlSubs $ const Nothing
 
-
+-- | graphqlsubs takes in a schema, a substitution and text representing
+--   a GraphQL request document.
+--   If the text parses correctly as a GraphQl query
+--   the substitution is applied to the query and
+--   the query is then executed according to the given schema.
+--   Returns the response to the query wrapped in an Aeson.Value.
 graphqlSubs :: (Alternative m, Monad m) => Schema m -> Subs -> Text -> m Aeson.Value
 graphqlSubs schema f =
     either parseError (execute schema f)
diff --git a/Data/GraphQL/AST.hs b/Data/GraphQL/AST.hs
index 2703a5b..5fdd146 100644
--- a/Data/GraphQL/AST.hs
+++ b/Data/GraphQL/AST.hs
@@ -1,3 +1,8 @@
+{- | This module defines an
+     abstract syntax tree for the GraphQL language, based on
+     <https://facebook.github.io/graphql/ Facebook's GraphQL Specification>.
+-}
+
 module Data.GraphQL.AST where
 
 import Data.Int (Int32)
@@ -39,11 +44,33 @@ data Selection = SelectionField Field
                | SelectionInlineFragment InlineFragment
                  deriving (Eq,Show)
 
+{- | <https://facebook.github.io/graphql/#sec-Language.Query-Document.Fields Field Specification>
+
+     A selection set is primarily composed of fields.
+     A field describes one discrete piece of information
+     available to request within a selection set.
+
+     Some fields describe complex data or relationships to other data.
+     In order to further explore this data, a field may itself contain
+     a selection set, allowing for deeply nested requests.
+     All GraphQL operations must specify their selections down to
+     fields which return scalar values to ensure an unambiguously
+     shaped response.
+
+-}
 data Field = Field Alias Name [Argument] [Directive] SelectionSet
              deriving (Eq,Show)
 
 type Alias = Name
 
+{- | <https://facebook.github.io/graphql/#sec-Language.Query-Document.Arguments Argument Specification>
+
+     Fields are conceptually functions which return values,
+     and occasionally accept arguments which alter their behavior.
+     These arguments often map directly to function arguments within a
+     GraphQL server’s implementation.
+
+-}
 data Argument = Argument Name Value deriving (Eq,Show)
 
 -- * Fragments
@@ -63,6 +90,18 @@ type TypeCondition = NamedType
 
 -- * Values
 
+{- | <https://facebook.github.io/graphql/#sec-Input-Values Input Value Specification>
+
+    Field and directive arguments accept input values
+    of various literal primitives; input values can be scalars,
+    enumeration values, lists, or input objects.
+
+    If not defined as constant (for example, in DefaultValue),
+    input values can be specified as a variable.
+    List and inputs objects may also contain
+    variables (unless defined to be constant).
+
+-}
 data Value = ValueVariable Variable
            | ValueInt Int32
            -- GraphQL Float is double precison
diff --git a/Data/GraphQL/Encoder.hs b/Data/GraphQL/Encoder.hs
index 2b7e239..6245bb0 100644
--- a/Data/GraphQL/Encoder.hs
+++ b/Data/GraphQL/Encoder.hs
@@ -1,5 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
+-- | This module defines a printer
+--   for the GraphQL language.
 module Data.GraphQL.Encoder where
 
 #if !MIN_VERSION_base(4,8,0)
diff --git a/Data/GraphQL/Execute.hs b/Data/GraphQL/Execute.hs
index e5998e9..a0436f6 100644
--- a/Data/GraphQL/Execute.hs
+++ b/Data/GraphQL/Execute.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE OverloadedStrings #-}
+-- | This module provides the function execute which executes a GraphQL
+--   request according to a given GraphQL schema.
 module Data.GraphQL.Execute (execute) where
 
 #if !MIN_VERSION_base(4,8,0)
@@ -22,17 +23,25 @@ import Data.GraphQL.Error
      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 :: Alternative f
+  => Schema.Schema f -> Schema.Subs -> Document -> f Aeson.Value
 execute (Schema resolvs) subs doc = runCollectErrs res
   where res = Schema.resolvers resolvs $ rootFields subs doc
 
-
+-- | rootFields takes in a substitution and a GraphQL document.
+--   If the document contains one query (and no other definitions)
+--   it applies the substitution to the query's set of selections
+--   and then returns their fields.
 rootFields :: Schema.Subs -> Document -> [Field]
 rootFields subs (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) =
     Schema.fields $ substitute subs <$> sels
 rootFields _ _ = []
 
+-- | substitute takes in a substitution and a selection.
+--   If the selection is a field it applies the substitution to the
+--   field's arguments using subsArg,
+--   and recursively applies the substitution to the arguments of fields
+--   nested in the primary field.
 substitute :: Schema.Subs -> Selection -> Selection
 substitute subs (SelectionField (Field alias name args directives sels)) =
     SelectionField $ Field
@@ -45,6 +54,9 @@ substitute subs (SelectionField (Field alias name args directives sels)) =
 substitute _ sel = sel
 
 -- TODO: Support different value types
+-- | subsArg takes in a substitution and an argument.
+--   If the argument's value is a variable the substitution
+--   is applied to the variable's name.
 subsArg :: Schema.Subs -> Argument -> Maybe Argument
 subsArg subs (Argument n (ValueVariable (Variable v))) =
     Argument n . ValueString <$> subs v
diff --git a/Data/GraphQL/Parser.hs b/Data/GraphQL/Parser.hs
index 6658af0..ed9df80 100644
--- a/Data/GraphQL/Parser.hs
+++ b/Data/GraphQL/Parser.hs
@@ -1,5 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
+-- | This module defines a parser
+--   for GraphQl request documents.
 module Data.GraphQL.Parser where
 
 import Prelude hiding (takeWhile)
diff --git a/Data/GraphQL/Schema.hs b/Data/GraphQL/Schema.hs
index 345984c..0a30eb9 100644
--- a/Data/GraphQL/Schema.hs
+++ b/Data/GraphQL/Schema.hs
@@ -1,6 +1,9 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE LambdaCase #-}
+-- | This module provides the type Schema,
+--   representing a GraphQL schema, and functions for defining
+--   a schema.
 module Data.GraphQL.Schema
   ( Schema(..)
   , Resolver
@@ -44,54 +47,70 @@ import Control.Arrow
 import Data.GraphQL.AST
 import Data.GraphQL.Error
 
+-- | Schema represents a GraphQL schema.
+--   f usually has to be an instance of Alternative.
 data Schema f = Schema [Resolver f]
 
+-- | Resolver resolves a field in to a wrapped Aeson.Object with error information
+--   (or empty). The wrapped f usually has to be an instance of Alternative.
 type Resolver f = Field -> CollectErrsT f Aeson.Object
 
+-- | Subs represents a substitution.
 type Subs = Text -> Maybe Text
 
+-- | Objects represent a list of named fields, each of which
+--   yield a value of a specific type.
 object :: Alternative f => Text -> [Resolver f] -> Resolver f
 object name resolvs = objectA name $ \case
      [] -> resolvs
      _  -> empty
 
+-- | Fields can accept arguments to further specify the return value.
 objectA
   :: Alternative f
   => Text -> ([Argument] -> [Resolver f]) -> Resolver f
 objectA name f fld@(Field _ _ args _ sels) =
     withField name (resolvers (f args) $ fields sels) fld
 
+-- | A scalar represents a primitive value, like a string or an integer.
 scalar :: (Alternative f, Aeson.ToJSON a) => Text -> a -> Resolver f
 scalar name s = scalarA name $ \case
     [] -> pure s
     _  -> empty
 
+-- | Arguments can be used to further specify a scalar's return value.
 scalarA
   :: (Alternative f, Aeson.ToJSON a)
   => Text -> ([Argument] -> f a) -> Resolver f
 scalarA name f fld@(Field _ _ args _ []) = withField name (errWrap $ f args) fld
 scalarA _ _ _ = empty
 
+-- | Arrays are like objects but have an array of resolvers instead of a list.
 array :: Alternative f => Text -> [[Resolver f]] -> Resolver f
 array name resolvs = arrayA name $ \case
     [] -> resolvs
     _  -> empty
 
+-- | Arguments can be used to further specify an array's return values.
 arrayA
   :: Alternative f
   => Text -> ([Argument] -> [[Resolver f]]) -> Resolver f
 arrayA name f fld@(Field _ _ args _ sels) =
      withField name (joinErrs $ traverse (flip resolvers $ fields sels) $ f args) fld
 
+-- | An enum represents one of a finite set of possible values.
+--   Used in place of a scalar when the possible responses are easily enumerable.
 enum :: Alternative f => Text -> f [Text] -> Resolver f
 enum name enums = enumA name $ \case
      [] -> enums
      _  -> empty
 
+-- | Arguments can be used to further specify an enum's return values.
 enumA :: Alternative f => Text -> ([Argument] -> f [Text]) -> Resolver f
 enumA name f fld@(Field _ _ args _ []) = withField name (errWrap $ f args) fld
 enumA _ _ _ = empty
 
+-- | Used to implement a resolver with arguments.
 withField
   :: (Alternative f, Aeson.ToJSON a)
   => Text -> CollectErrsT f a -> Field -> CollectErrsT f (HashMap Text Aeson.Value)
@@ -102,6 +121,9 @@ withField name f (Field alias name' _ _ _) =
      where
        aliasOrName = if T.null alias then name' else alias
 
+-- | resolvers takes a list of resolvers and a list of fields,
+--   and applies each resolver to each field. Resolves into a value
+--   containing the resolved field, or a null value and error information.
 resolvers :: Alternative f => [Resolver f] -> [Field] -> CollectErrsT f Aeson.Value
 resolvers resolvs =
     fmap (first Aeson.toJSON . fold)
@@ -111,10 +133,13 @@ resolvers resolvs =
                   msg = T.unwords ["field", name, "not resolved."]
                   aliasOrName = if T.null alias then name else alias
 
+-- | Checks whether the given selection contains a field and
+--   returns the field if so, else returns Nothing.
 field :: Selection -> Maybe Field
 field (SelectionField x) = Just x
 field _ = Nothing
 
+-- | Returns a list of the fields contained in the given selection set.
 fields :: SelectionSet -> [Field]
 fields = catMaybes . fmap field
 
-- 
cgit v1.2.3