From 92463f7c4a9be2581aa5f6913762a8de393c4924 Mon Sep 17 00:00:00 2001
From: Eugen Wissner <belka@caraus.de>
Date: Wed, 24 Aug 2022 22:33:20 +0300
Subject: [PATCH] Add Resolver module with helpers and exceptions

---
 CHANGELOG.md                     |  1 +
 graphql-spice.cabal              |  2 ++
 src/Language/GraphQL/Class.hs    |  2 +-
 src/Language/GraphQL/Resolver.hs | 61 ++++++++++++++++++++++++++++++++
 4 files changed, 65 insertions(+), 1 deletion(-)
 create mode 100644 src/Language/GraphQL/Resolver.hs

diff --git a/CHANGELOG.md b/CHANGELOG.md
index e274b42..bcaa367 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -9,6 +9,7 @@ and this project adheres to
 ## [Unreleased]
 ### Added
 - `ToGraphQL` and `FromGraphQL` typeclasses with instances for basic types.
+- `Resolver` module with `argument` and `defaultResolver` helper functions.
 
 ## [1.0.0.0] - 2022-03-29
 ### Added
diff --git a/graphql-spice.cabal b/graphql-spice.cabal
index f774dcc..6c1f6dc 100644
--- a/graphql-spice.cabal
+++ b/graphql-spice.cabal
@@ -26,6 +26,7 @@ library
     exposed-modules:
       Language.GraphQL.Class
       Language.GraphQL.JSON
+      Language.GraphQL.Resolver
       Test.Hspec.GraphQL
     other-modules:
     hs-source-dirs:   src
@@ -41,6 +42,7 @@ library
       megaparsec >= 9.0 && < 10,
       scientific ^>= 0.3.7,
       text >= 1.2 && < 3,
+      transformers ^>= 0.5.6,
       vector ^>= 0.12.3,
       unordered-containers ^>= 0.2.16
     default-language: Haskell2010
diff --git a/src/Language/GraphQL/Class.hs b/src/Language/GraphQL/Class.hs
index 66a0b2b..3f52a13 100644
--- a/src/Language/GraphQL/Class.hs
+++ b/src/Language/GraphQL/Class.hs
@@ -24,7 +24,7 @@ fromGraphQLToIntegral (Type.Int value) = Just $ fromIntegral value
 fromGraphQLToIntegral (Type.String value) =
     case Text.Read.decimal value of
         Right (converted, "") -> Just converted
-        _ -> Nothing
+        _conversionError -> Nothing
 fromGraphQLToIntegral _ = Nothing
 
 -- | Instances of this typeclass can be converted to GraphQL internal
diff --git a/src/Language/GraphQL/Resolver.hs b/src/Language/GraphQL/Resolver.hs
new file mode 100644
index 0000000..dbf9a6a
--- /dev/null
+++ b/src/Language/GraphQL/Resolver.hs
@@ -0,0 +1,61 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Helper functions and exceptions to write resolvers.
+module Language.GraphQL.Resolver
+    ( argument
+    , defaultResolver
+    ) where
+
+import Control.Monad.Catch (Exception(..), MonadCatch(..), MonadThrow(..))
+import Control.Monad.Trans.Reader (ReaderT, asks)
+import Data.HashMap.Strict ((!))
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Data.Typeable (cast)
+import Language.GraphQL.AST.Document (Name)
+import Language.GraphQL.Error
+import qualified Language.GraphQL.Type as Type
+import Language.GraphQL.Class (FromGraphQL(..))
+
+-- | Exceptions thrown by the functions in this module.
+data ServerException
+    = FieldNotResolvedException !Text
+    | ErroneousArgumentTypeException !Text
+
+instance Show ServerException where
+    show (FieldNotResolvedException fieldName) =
+        Text.unpack $ Text.unwords ["Field", fieldName, "not resolved."]
+    show (ErroneousArgumentTypeException argumentName) =
+        Text.unpack $ Text.unwords
+            [ "Unable to convert the argument"
+            , argumentName
+            , "to a user-defined type."
+            ]
+
+instance Exception ServerException where
+    toException = toException . ResolverException
+    fromException x = do
+        ResolverException a <- fromException x
+        cast a
+
+-- | Default resolver expects that the field value is returned by the parent
+-- object. If the parent is not an object or it doesn't contain the requested
+-- field name, an error is thrown.
+defaultResolver :: MonadCatch m => Name -> Type.Resolve m
+defaultResolver fieldName = do
+    values' <- asks Type.values
+    case values' of
+        Type.Object objectValue -> pure $ objectValue ! fieldName
+        _nonObject -> throwM $ FieldNotResolvedException fieldName
+
+-- | Takes an argument name, validates that the argument exists, and optionally
+-- converts it to a user-defined type.
+argument :: (MonadCatch m, FromGraphQL a) => Name -> ReaderT Type.Context m a
+argument argumentName =
+    Type.argument argumentName >>= maybe throwError pure . fromGraphQL
+  where
+    throwError = throwM $ ErroneousArgumentTypeException argumentName