{-# LANGUAGE OverloadedStrings #-}
module Language.GraphQL.Schema
( Resolver(..)
, Subs
, object
, resolve
, resolversToMap
, scalar
, wrappedObject
, wrappedScalar
, Field
, Value(..)
) where
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (runExceptT)
import Control.Monad.Trans.Reader (runReaderT)
import Data.Foldable (fold, toList)
import Data.Maybe (fromMaybe)
import qualified Data.Aeson as Aeson
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Sequence (Seq)
import Data.Text (Text)
import qualified Data.Text as T
import Language.GraphQL.AST.Core
import Language.GraphQL.Error
import Language.GraphQL.Trans
import qualified Language.GraphQL.Type as Type
data Resolver m = Resolver
Text
(Field -> CollectErrsT m Aeson.Object)
resolversToMap
:: (Foldable f, Functor f)
=> f (Resolver m)
-> HashMap Text (Field -> CollectErrsT m Aeson.Object)
resolversToMap = HashMap.fromList . toList . fmap toKV
where
toKV (Resolver name f) = (name, f)
type Subs = HashMap Name Value
object :: Monad m => Name -> ActionT m [Resolver m] -> Resolver m
object name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld@(Field _ _ _ flds) resolver
= withField (resolve (resolversToMap resolver) flds) fld
wrappedObject ::
Monad m =>
Name ->
ActionT m (Type.Wrapping [Resolver m]) ->
Resolver m
wrappedObject name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld@(Field _ _ _ sels) resolver
= withField (traverse (resolveMap sels) resolver) fld
resolveMap = flip (resolve . resolversToMap)
scalar :: (Monad m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m
scalar name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld result = withField (return result) fld
wrappedScalar ::
(Monad m, Aeson.ToJSON a) =>
Name ->
ActionT m (Type.Wrapping a) ->
Resolver m
wrappedScalar name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld (Type.Named result) = withField (return result) fld
resolveRight fld Type.Null
= return $ HashMap.singleton (aliasOrName fld) Aeson.Null
resolveRight fld (Type.List result) = withField (return result) fld
resolveFieldValue ::
Monad m =>
ActionT m a ->
(Field -> a -> CollectErrsT m Aeson.Object) ->
Field ->
CollectErrsT m (HashMap Text Aeson.Value)
resolveFieldValue f resolveRight fld@(Field _ _ args _) = do
result <- lift $ reader . runExceptT . runActionT $ f
either resolveLeft (resolveRight fld) result
where
reader = flip runReaderT $ Context {arguments=args}
resolveLeft err = do
_ <- addErrMsg err
return $ HashMap.singleton (aliasOrName fld) Aeson.Null
withField :: (Monad m, Aeson.ToJSON a)
=> CollectErrsT m a -> Field -> CollectErrsT m (HashMap Text Aeson.Value)
withField v fld
= HashMap.singleton (aliasOrName fld) . Aeson.toJSON <$> runAppendErrs v
resolve :: Monad m
=> HashMap Text (Field -> CollectErrsT m Aeson.Object)
-> Seq Selection
-> CollectErrsT m Aeson.Value
resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
where
resolveTypeName f = do
value <- f $ Field Nothing "__typename" mempty mempty
return $ HashMap.lookupDefault "" "__typename" value
tryResolvers (SelectionField fld@(Field _ name _ _))
= fromMaybe (errmsg fld) $ HashMap.lookup name resolvers <*> Just fld
tryResolvers (SelectionFragment (Fragment typeCondition selections')) = do
that <- traverse resolveTypeName $ HashMap.lookup "__typename" resolvers
if maybe True (Aeson.String typeCondition ==) that
then fmap fold . traverse tryResolvers $ selections'
else return mempty
errmsg fld@(Field _ name _ _) = do
addErrMsg $ T.unwords ["field", name, "not resolved."]
return $ HashMap.singleton (aliasOrName fld) Aeson.Null
aliasOrName :: Field -> Text
aliasOrName (Field alias name _ _) = fromMaybe name alias