{- 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
    ( ServerException(..)
    , argument
    , defaultResolver
    ) where

import Control.Monad.Catch (Exception(..), MonadCatch(..), MonadThrow(..))
import Control.Monad.Trans.Reader (ReaderT, asks)
import qualified Data.HashMap.Strict as HashMap
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 :: ServerException -> String
show (FieldNotResolvedException Text
fieldName) =
        Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unwords [Text
"Field", Text
fieldName, Text
"not resolved."]
    show (ErroneousArgumentTypeException Text
argumentName) =
        Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unwords
            [ Text
"Unable to convert the argument"
            , Text
argumentName
            , Text
"to a user-defined type."
            ]

instance Exception ServerException where
    toException :: ServerException -> SomeException
toException = ResolverException -> SomeException
forall e. Exception e => e -> SomeException
toException (ResolverException -> SomeException)
-> (ServerException -> ResolverException)
-> ServerException
-> SomeException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerException -> ResolverException
forall e. Exception e => e -> ResolverException
ResolverException
    fromException :: SomeException -> Maybe ServerException
fromException SomeException
x = do
        ResolverException e
a <- SomeException -> Maybe ResolverException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
x
        e -> Maybe ServerException
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
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 :: forall (m :: * -> *). MonadCatch m => Text -> Resolve m
defaultResolver Text
fieldName = do
    Value
values' <- (Context -> Value) -> Resolve m
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Context -> Value
Type.values
    case Value
values' of
        Type.Object HashMap Text Value
objectValue
            | Just Value
result <- Text -> HashMap Text Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
fieldName HashMap Text Value
objectValue -> Value -> Resolve m
forall a. a -> ReaderT Context m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
result
        Value
_nonObject -> ServerException -> Resolve m
forall e a. (HasCallStack, Exception e) => e -> ReaderT Context m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (ServerException -> Resolve m) -> ServerException -> Resolve m
forall a b. (a -> b) -> a -> b
$ Text -> ServerException
FieldNotResolvedException Text
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 :: forall (m :: * -> *) a.
(MonadCatch m, FromGraphQL a) =>
Text -> ReaderT Context m a
argument Text
argumentName =
    Text -> Resolve m
forall (m :: * -> *). Monad m => Text -> Resolve m
Type.argument Text
argumentName Resolve m -> (Value -> ReaderT Context m a) -> ReaderT Context m a
forall a b.
ReaderT Context m a
-> (a -> ReaderT Context m b) -> ReaderT Context m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReaderT Context m a
-> (a -> ReaderT Context m a) -> Maybe a -> ReaderT Context m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ReaderT Context m a
forall {a}. ReaderT Context m a
throwError a -> ReaderT Context m a
forall a. a -> ReaderT Context m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> ReaderT Context m a)
-> (Value -> Maybe a) -> Value -> ReaderT Context m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Maybe a
forall a. FromGraphQL a => Value -> Maybe a
fromGraphQL
  where
    throwError :: ReaderT Context m a
throwError = ServerException -> ReaderT Context m a
forall e a. (HasCallStack, Exception e) => e -> ReaderT Context m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (ServerException -> ReaderT Context m a)
-> ServerException -> ReaderT Context m a
forall a b. (a -> b) -> a -> b
$ Text -> ServerException
ErroneousArgumentTypeException Text
argumentName