{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Morpheus.Types.Internal.Resolving.Resolver
( Event (..),
UnSubResolver,
Resolver,
MapStrategy (..),
LiftOperation,
unsafeBind,
toResolver,
lift,
subscribe,
SubEvent,
GQLChannel (..),
ResponseEvent (..),
ResponseStream,
ObjectResModel (..),
ResModel (..),
FieldResModel,
WithOperation,
Context (..),
unsafeInternalContext,
runRootResModel,
setTypeName,
RootResModel (..),
liftStateless,
withArguments,
)
where
import Control.Monad.Fail (MonadFail (..))
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Class (MonadTrans (..))
import Control.Monad.Trans.Reader (ReaderT (..), ask, mapReaderT, withReaderT)
import Data.Maybe (maybe)
import Data.Morpheus.Error.Internal (internalResolvingError)
import Data.Morpheus.Error.Selection (subfieldsNotSelected)
import Data.Morpheus.Internal.Utils
( Merge (..),
empty,
keyOf,
selectOr,
)
import Data.Morpheus.Types.IO
( GQLResponse,
renderResponse,
)
import Data.Morpheus.Types.Internal.AST.Base
( FieldName,
GQLError (..),
GQLErrors,
MUTATION,
Message,
OperationType,
OperationType (..),
QUERY,
SUBSCRIPTION,
TypeName (..),
VALID,
msg,
)
import Data.Morpheus.Types.Internal.AST.Data
( Arguments,
Schema,
)
import Data.Morpheus.Types.Internal.AST.MergeSet
( toOrderedMap,
)
import Data.Morpheus.Types.Internal.AST.Selection
( Operation (..),
Selection (..),
SelectionContent (..),
SelectionSet,
UnionSelection,
UnionTag (..),
)
import Data.Morpheus.Types.Internal.AST.Value
( GQLValue (..),
ObjectEntry (..),
ScalarValue (..),
ValidValue,
Value (..),
)
import Data.Morpheus.Types.Internal.Resolving.Core
( Channel (..),
Event (..),
Eventless,
Failure (..),
GQLChannel (..),
PushEvents (..),
Result (..),
ResultT (..),
StreamChannel,
cleanEvents,
mapEvent,
statelessToResultT,
)
import Data.Semigroup
( (<>),
Semigroup (..),
)
type WithOperation (o :: OperationType) = LiftOperation o
type ResponseStream event (m :: * -> *) = ResultT (ResponseEvent event m) m
data ResponseEvent event (m :: * -> *)
= Publish event
| Subscribe (SubEvent event m)
type SubEvent event m = Event (Channel event) (event -> m GQLResponse)
data Context = Context
{ currentSelection :: Selection VALID,
schema :: Schema,
operation :: Operation VALID,
currentTypeName :: TypeName
}
deriving (Show)
newtype ResolverState event m a = ResolverState
{ runResolverState :: ReaderT Context (ResultT event m) a
}
deriving
( Functor,
Applicative,
Monad
)
instance MonadTrans (ResolverState e) where
lift = ResolverState . lift . lift
instance (Monad m) => Failure Message (ResolverState e m) where
failure message = ResolverState $ do
selection <- currentSelection <$> ask
lift $ failure [resolverFailureMessage selection message]
instance (Monad m) => Failure GQLErrors (ResolverState e m) where
failure = ResolverState . lift . failure
instance (Monad m) => PushEvents e (ResolverState e m) where
pushEvents = ResolverState . lift . pushEvents
mapResolverState ::
( ReaderT Context (ResultT e m) a ->
ReaderT Context (ResultT e' m') a'
) ->
ResolverState e m a ->
ResolverState e' m' a'
mapResolverState f (ResolverState x) = ResolverState (f x)
getState :: (Monad m) => ResolverState e m (Selection VALID)
getState = ResolverState $ currentSelection <$> ask
mapState :: (Context -> Context) -> ResolverState e m a -> ResolverState e m a
mapState f = mapResolverState (withReaderT f)
clearStateResolverEvents :: (Functor m) => ResolverState e m a -> ResolverState e' m a
clearStateResolverEvents = mapResolverState (mapReaderT cleanEvents)
resolverFailureMessage :: Selection VALID -> Message -> GQLError
resolverFailureMessage Selection {selectionName, selectionPosition} message =
GQLError
{ message = "Failure on Resolving Field " <> msg selectionName <> ": " <> message,
locations = [selectionPosition]
}
data Resolver (o :: OperationType) event (m :: * -> *) value where
ResolverQ :: {runResolverQ :: ResolverState () m value} -> Resolver QUERY event m value
ResolverM :: {runResolverM :: ResolverState event m value} -> Resolver MUTATION event m value
ResolverS :: {runResolverS :: ResolverState (Channel event) m (ReaderT event (Resolver QUERY event m) value)} -> Resolver SUBSCRIPTION event m value
instance Show (Resolver o e m value) where
show ResolverQ {} = "Resolver QUERY e m a"
show ResolverM {} = "Resolver MUTATION e m a"
show ResolverS {} = "Resolver SUBSCRIPTION e m a"
deriving instance (Functor m) => Functor (Resolver o e m)
instance (LiftOperation o, Monad m) => Applicative (Resolver o e m) where
pure = packResolver . pure
ResolverQ r1 <*> ResolverQ r2 = ResolverQ $ r1 <*> r2
ResolverM r1 <*> ResolverM r2 = ResolverM $ r1 <*> r2
ResolverS r1 <*> ResolverS r2 = ResolverS $ (<*>) <$> r1 <*> r2
instance (Monad m, LiftOperation o) => Monad (Resolver o e m) where
return = pure
(>>=) = unsafeBind
#if __GLASGOW_HASKELL__ < 808
fail = failure . msg
# endif
instance (MonadIO m, LiftOperation o) => MonadIO (Resolver o e m) where
liftIO = lift . liftIO
instance (LiftOperation o) => MonadTrans (Resolver o e) where
lift = packResolver . lift
instance (LiftOperation o, Monad m) => Failure Message (Resolver o e m) where
failure = packResolver . failure
instance (LiftOperation o, Monad m) => Failure GQLErrors (Resolver o e m) where
failure = packResolver . failure
instance (Monad m, LiftOperation o) => MonadFail (Resolver o e m) where
fail = failure . msg
instance (Monad m) => PushEvents e (Resolver MUTATION e m) where
pushEvents = packResolver . pushEvents
instance (Monad m, Semigroup a, LiftOperation o) => Semigroup (Resolver o e m a) where
x <> y = fmap (<>) x <*> y
liftStateless ::
( LiftOperation o,
Monad m
) =>
Eventless a ->
Resolver o e m a
liftStateless =
packResolver
. ResolverState
. ReaderT
. const
. statelessToResultT
class LiftOperation (o :: OperationType) where
packResolver :: Monad m => ResolverState e m a -> Resolver o e m a
withResolver :: Monad m => ResolverState e m a -> (a -> Resolver o e m b) -> Resolver o e m b
instance LiftOperation QUERY where
packResolver = ResolverQ . clearStateResolverEvents
withResolver ctxRes toRes = ResolverQ $ do
v <- clearStateResolverEvents ctxRes
runResolverQ $ toRes v
instance LiftOperation MUTATION where
packResolver = ResolverM
withResolver ctxRes toRes = ResolverM $ ctxRes >>= runResolverM . toRes
instance LiftOperation SUBSCRIPTION where
packResolver = ResolverS . pure . lift . packResolver
withResolver ctxRes toRes = ResolverS $ do
value <- clearStateResolverEvents ctxRes
runResolverS $ toRes value
mapResolverContext :: Monad m => (Context -> Context) -> Resolver o e m a -> Resolver o e m a
mapResolverContext f (ResolverQ res) = ResolverQ (mapState f res)
mapResolverContext f (ResolverM res) = ResolverM (mapState f res)
mapResolverContext f (ResolverS resM) = ResolverS $ do
res <- resM
pure $ ReaderT $ \e -> ResolverQ $ mapState f (runResolverQ (runReaderT res e))
setSelection :: Monad m => Selection VALID -> Resolver o e m a -> Resolver o e m a
setSelection currentSelection =
mapResolverContext (\ctx -> ctx {currentSelection})
setTypeName :: Monad m => TypeName -> Resolver o e m a -> Resolver o e m a
setTypeName currentTypeName =
mapResolverContext (\ctx -> ctx {currentTypeName})
unsafeBind ::
forall o e m a b.
Monad m =>
Resolver o e m a ->
(a -> Resolver o e m b) ->
Resolver o e m b
unsafeBind (ResolverQ x) m2 = ResolverQ (x >>= runResolverQ . m2)
unsafeBind (ResolverM x) m2 = ResolverM (x >>= runResolverM . m2)
unsafeBind (ResolverS res) m2 = ResolverS $ do
(readResA :: ReaderT e (Resolver QUERY e m) a) <- res
pure $ ReaderT $ \e -> ResolverQ $ do
let (resA :: Resolver QUERY e m a) = runReaderT readResA e
(valA :: a) <- runResolverQ resA
(readResB :: ReaderT e (Resolver QUERY e m) b) <- clearStateResolverEvents $ runResolverS (m2 valA)
runResolverQ $ runReaderT readResB e
subscribe ::
forall e m a.
( PushEvents (Channel e) (ResolverState (Channel e) m),
Monad m
) =>
[StreamChannel e] ->
Resolver QUERY e m (e -> Resolver QUERY e m a) ->
Resolver SUBSCRIPTION e m a
subscribe ch res = ResolverS $ do
pushEvents (map Channel ch :: [Channel e])
(eventRes :: e -> Resolver QUERY e m a) <- clearStateResolverEvents (runResolverQ res)
pure $ ReaderT eventRes
unsafeInternalContext :: (Monad m, LiftOperation o) => Resolver o e m Context
unsafeInternalContext = packResolver $ ResolverState ask
type family UnSubResolver (a :: * -> *) :: (* -> *)
type instance UnSubResolver (Resolver SUBSCRIPTION e m) = Resolver QUERY e m
withArguments ::
forall o e m a.
(LiftOperation o, Monad m) =>
(Arguments VALID -> Resolver o e m a) ->
Resolver o e m a
withArguments = withResolver args
where
args :: ResolverState e m (Arguments VALID)
args = selectionArguments <$> getState
toResolver ::
forall o e m a b.
(LiftOperation o, Monad m) =>
(Arguments VALID -> Eventless a) ->
(a -> Resolver o e m b) ->
Resolver o e m b
toResolver toArgs = withResolver args
where
args :: ResolverState e m a
args =
ResultT . pure . toArgs . selectionArguments <$> getState
>>= ResolverState . lift . cleanEvents
pickSelection :: TypeName -> UnionSelection VALID -> SelectionSet VALID
pickSelection = selectOr empty unionTagSelection
withObject ::
(LiftOperation o, Monad m) =>
(SelectionSet VALID -> Resolver o e m value) ->
Selection VALID ->
Resolver o e m value
withObject f Selection {selectionName, selectionContent, selectionPosition} = checkContent selectionContent
where
checkContent (SelectionSet selection) = f selection
checkContent _ = failure (subfieldsNotSelected selectionName "" selectionPosition)
lookupRes ::
(LiftOperation o, Monad m) =>
Selection VALID ->
ObjectResModel o e m ->
Resolver o e m ValidValue
lookupRes Selection {selectionName}
| selectionName == "__typename" =
pure . Scalar . String . readTypeName . __typename
| otherwise =
maybe
(pure gqlNull)
(`unsafeBind` runDataResolver)
. lookup selectionName
. objectFields
resolveObject ::
forall o e m.
(LiftOperation o, Monad m) =>
SelectionSet VALID ->
ResModel o e m ->
Resolver o e m ValidValue
resolveObject selectionSet (ResObject drv@ObjectResModel {__typename}) =
Object . toOrderedMap <$> traverse resolver selectionSet
where
resolver :: Selection VALID -> Resolver o e m (ObjectEntry VALID)
resolver sel =
setSelection sel
$ setTypeName __typename
$ ObjectEntry (keyOf sel) <$> lookupRes sel drv
resolveObject _ _ =
failure $ internalResolvingError "expected object as resolver"
toEventResolver :: Monad m => ReaderT event (Resolver QUERY event m) ValidValue -> Context -> event -> m GQLResponse
toEventResolver (ReaderT subRes) sel event = do
value <- runResultT $ runReaderT (runResolverState $ runResolverQ (subRes event)) sel
pure $ renderResponse value
runDataResolver :: (Monad m, LiftOperation o) => ResModel o e m -> Resolver o e m ValidValue
runDataResolver = withResolver getState . __encode
where
__encode obj sel@Selection {selectionContent} = encodeNode obj selectionContent
where
encodeNode (ResList x) _ = List <$> traverse runDataResolver x
encodeNode objDrv@ResObject {} _ = withObject (`resolveObject` objDrv) sel
encodeNode (ResEnum _ enum) SelectionField = pure $ gqlString $ readTypeName enum
encodeNode (ResEnum typename enum) unionSel@UnionSelection {} =
encodeNode (unionDrv (typename <> "EnumObject")) unionSel
where
unionDrv name =
ResUnion name
$ pure
$ ResObject
$ ObjectResModel name [("enum", pure $ ResScalar $ String $ readTypeName enum)]
encodeNode ResEnum {} _ =
failure ("wrong selection on enum value" :: Message)
encodeNode (ResUnion typename unionRef) (UnionSelection selections) =
unionRef >>= resolveObject currentSelection
where
currentSelection = pickSelection typename selections
encodeNode (ResUnion name _) _ =
failure ("union Resolver " <> msg name <> " should only recieve UnionSelection")
encodeNode ResNull _ = pure Null
encodeNode (ResScalar x) SelectionField = pure $ Scalar x
encodeNode ResScalar {} _ =
failure ("scalar Resolver should only recieve SelectionField" :: Message)
runResolver ::
Monad m =>
Resolver o event m ValidValue ->
Context ->
ResponseStream event m ValidValue
runResolver (ResolverQ resT) sel = cleanEvents $ runReaderT (runResolverState resT) sel
runResolver (ResolverM resT) sel = mapEvent Publish $ runReaderT (runResolverState resT) sel
runResolver (ResolverS resT) sel = ResultT $ do
readResValue <- runResultT $ runReaderT (runResolverState resT) sel
pure $ case readResValue of
Failure x -> Failure x
Success {warnings, result, events = channels} -> do
let eventRes = toEventResolver result sel
Success
{ events = [Subscribe $ Event channels eventRes],
warnings,
result = gqlNull
}
type FieldResModel o e m =
(FieldName, Resolver o e m (ResModel o e m))
data ObjectResModel o e m = ObjectResModel
{ __typename :: TypeName,
objectFields ::
[FieldResModel o e m]
}
deriving (Show)
instance Merge (ObjectResModel o e m) where
merge _ (ObjectResModel tyname x) (ObjectResModel _ y) =
pure $ ObjectResModel tyname (x <> y)
data ResModel (o :: OperationType) e (m :: * -> *)
= ResNull
| ResScalar ScalarValue
| ResEnum TypeName TypeName
| ResList [ResModel o e m]
| ResObject (ObjectResModel o e m)
| ResUnion TypeName (Resolver o e m (ResModel o e m))
deriving (Show)
instance Merge (ResModel o e m) where
merge p (ResObject x) (ResObject y) =
ResObject <$> merge p x y
merge _ _ _ =
failure $ internalResolvingError "can't merge: incompatible resolvers"
data RootResModel e m = RootResModel
{ query :: Eventless (ResModel QUERY e m),
mutation :: Eventless (ResModel MUTATION e m),
subscription :: Eventless (ResModel SUBSCRIPTION e m)
}
runRootDataResolver ::
(Monad m, LiftOperation o) =>
Eventless (ResModel o e m) ->
Context ->
ResponseStream e m (Value VALID)
runRootDataResolver
res
ctx@Context {operation = Operation {operationSelection}} =
do
root <- statelessToResultT res
runResolver (resolveObject operationSelection root) ctx
runRootResModel :: Monad m => RootResModel e m -> Context -> ResponseStream e m (Value VALID)
runRootResModel
RootResModel
{ query,
mutation,
subscription
}
ctx@Context {operation = Operation {operationType}} =
selectByOperation operationType
where
selectByOperation Query =
runRootDataResolver query ctx
selectByOperation Mutation =
runRootDataResolver mutation ctx
selectByOperation Subscription =
runRootDataResolver subscription ctx
class
MapStrategy
(from :: OperationType)
(to :: OperationType)
where
mapStrategy ::
Monad m =>
Resolver from e m (ResModel from e m) ->
Resolver to e m (ResModel to e m)
instance MapStrategy o o where
mapStrategy = id
instance MapStrategy QUERY SUBSCRIPTION where
mapStrategy = ResolverS . pure . lift . fmap mapDeriving
mapDeriving ::
( MapStrategy o o',
Monad m
) =>
ResModel o e m ->
ResModel o' e m
mapDeriving ResNull = ResNull
mapDeriving (ResScalar x) = ResScalar x
mapDeriving (ResEnum typeName enum) = ResEnum typeName enum
mapDeriving (ResList x) = ResList $ map mapDeriving x
mapDeriving (ResObject x) = ResObject (mapObjectDeriving x)
mapDeriving (ResUnion name x) = ResUnion name (mapStrategy x)
mapObjectDeriving ::
( MapStrategy o o',
Monad m
) =>
ObjectResModel o e m ->
ObjectResModel o' e m
mapObjectDeriving (ObjectResModel tyname x) =
ObjectResModel tyname $
map (mapEntry mapStrategy) x
mapEntry :: (a -> b) -> (k, a) -> (k, b)
mapEntry f (name, value) = (name, f value)