{-# LANGUAGE OverloadedStrings #-}
module Language.GraphQL.Schema
( Resolver
, Subs
, object
, objectA
, scalar
, scalarA
, resolve
, wrappedObject
, wrappedObjectA
, wrappedScalar
, wrappedScalarA
, Field
, Argument(..)
, Value(..)
) where
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (runExceptT)
import Control.Monad.Trans.Reader (runReaderT)
import Data.Foldable (find, fold)
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)
type Subs = Name -> Maybe Value
object :: MonadIO m => Name -> ActionT m [Resolver m] -> Resolver m
object name = objectA name . const
objectA :: MonadIO m
=> Name -> ([Argument] -> ActionT m [Resolver m]) -> Resolver m
objectA name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld@(Field _ _ _ flds) resolver = withField (resolve resolver flds) fld
wrappedObjectA :: MonadIO m
=> Name -> ([Argument] -> ActionT m (Type.Wrapping [Resolver m])) -> Resolver m
wrappedObjectA name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld@(Field _ _ _ sels) resolver
= withField (traverse (`resolve` sels) resolver) fld
wrappedObject :: MonadIO m
=> Name -> ActionT m (Type.Wrapping [Resolver m]) -> Resolver m
wrappedObject name = wrappedObjectA name . const
scalar :: (MonadIO m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m
scalar name = scalarA name . const
scalarA :: (MonadIO m, Aeson.ToJSON a)
=> Name -> ([Argument] -> ActionT m a) -> Resolver m
scalarA name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld result = withField (return result) fld
wrappedScalarA :: (MonadIO m, Aeson.ToJSON a)
=> Name -> ([Argument] -> ActionT m (Type.Wrapping a)) -> Resolver m
wrappedScalarA 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
wrappedScalar :: (MonadIO m, Aeson.ToJSON a)
=> Name -> ActionT m (Type.Wrapping a) -> Resolver m
wrappedScalar name = wrappedScalarA name . const
resolveFieldValue :: MonadIO m
=> ([Argument] -> ActionT m a)
-> (Field -> a -> CollectErrsT m (HashMap Text Aeson.Value))
-> Field
-> CollectErrsT m (HashMap Text Aeson.Value)
resolveFieldValue f resolveRight fld@(Field _ _ args _) = do
result <- lift $ reader . runExceptT . runActionT $ f args
either resolveLeft (resolveRight fld) result
where
reader = flip runReaderT $ Context mempty
resolveLeft err = do
_ <- addErrMsg err
return $ HashMap.singleton (aliasOrName fld) Aeson.Null
withField :: (MonadIO 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 :: MonadIO m
=> [Resolver m] -> Seq Selection -> CollectErrsT m Aeson.Value
resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
where
resolveTypeName (Resolver "__typename" f) = do
value <- f $ Field Nothing "__typename" mempty mempty
return $ HashMap.lookupDefault "" "__typename" value
resolveTypeName _ = return ""
tryResolvers (SelectionField fld@(Field _ name _ _))
= maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers name) resolvers
tryResolvers (SelectionFragment (Fragment typeCondition selections')) = do
that <- maybe (return "") resolveTypeName (find (compareResolvers "__typename") resolvers)
if Aeson.String typeCondition == that
then fmap fold . traverse tryResolvers $ selections'
else return mempty
compareResolvers name (Resolver name' _) = name == name'
tryResolver fld (Resolver _ resolver) = resolver fld
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