{-# LANGUAGE OverloadedStrings #-}
module Language.GraphQL.Schema
( Resolver
, Schema
, Subs
, object
, objectA
, scalar
, scalarA
, enum
, enumA
, resolve
, wrappedEnum
, wrappedEnumA
, 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 Data.Foldable ( find
, fold
)
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe (fromMaybe)
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
import Language.GraphQL.Error
import Language.GraphQL.Trans
import Language.GraphQL.Type
import Language.GraphQL.AST.Core
type Schema m = NonEmpty (Resolver m)
data Resolver m = Resolver
Text
(Field -> CollectErrsT m Aeson.Object)
type Fields = [Field]
type Arguments = [Argument]
type Subs = Name -> Maybe Value
object :: MonadIO m => Name -> ActionT m [Resolver m] -> Resolver m
object name = objectA name . const
objectA :: MonadIO m
=> Name -> (Arguments -> 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 -> (Arguments -> ActionT m (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 (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 -> (Arguments -> 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 -> (Arguments -> ActionT m (Wrapping a)) -> Resolver m
wrappedScalarA name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld (Named result) = withField (return result) fld
resolveRight fld Null
= return $ HashMap.singleton (aliasOrName fld) Aeson.Null
resolveRight fld (List result) = withField (return result) fld
wrappedScalar :: (MonadIO m, Aeson.ToJSON a)
=> Name -> ActionT m (Wrapping a) -> Resolver m
wrappedScalar name = wrappedScalarA name . const
enum :: MonadIO m => Name -> ActionT m [Text] -> Resolver m
enum name = enumA name . const
enumA :: MonadIO m => Name -> (Arguments -> ActionT m [Text]) -> Resolver m
enumA name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld resolver = withField (return resolver) fld
wrappedEnumA :: MonadIO m
=> Name -> (Arguments -> ActionT m (Wrapping [Text])) -> Resolver m
wrappedEnumA name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld (Named resolver) = withField (return resolver) fld
resolveRight fld Null
= return $ HashMap.singleton (aliasOrName fld) Aeson.Null
resolveRight fld (List resolver) = withField (return resolver) fld
wrappedEnum :: MonadIO m => Name -> ActionT m (Wrapping [Text]) -> Resolver m
wrappedEnum name = wrappedEnumA 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 $ runExceptT . runActionT $ f args
either resolveLeft (resolveRight fld) result
where
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] -> Fields -> CollectErrsT m Aeson.Value
resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
where
tryResolvers fld = maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers fld) resolvers
compareResolvers (Field _ 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