{-# 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
{-# DEPRECATED Schema "Use NonEmpty (Resolver m) instead" #-}
type Schema m = NonEmpty (Resolver m)
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 (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 -> ([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 (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
{-# DEPRECATED enum "Use scalar instead" #-}
enum :: MonadIO m => Name -> ActionT m [Text] -> Resolver m
enum name = enumA name . const
{-# DEPRECATED enumA "Use scalarA instead" #-}
enumA :: MonadIO m => Name -> ([Argument] -> ActionT m [Text]) -> Resolver m
enumA name f = Resolver name $ resolveFieldValue f resolveRight
where
resolveRight fld resolver = withField (return resolver) fld
{-# DEPRECATED wrappedEnumA "Use wrappedScalarA instead" #-}
wrappedEnumA :: MonadIO m
=> Name -> ([Argument] -> 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
{-# DEPRECATED wrappedEnum "Use wrappedScalar instead" #-}
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] -> [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