morpheus-graphql 0.9.1 → 0.10.0
raw patch · 22 files changed
+798/−729 lines, 22 filesdep +mtl
Dependencies added: mtl
Files
- README.md +23/−11
- changelog.md +74/−0
- morpheus-graphql.cabal +6/−4
- src/Data/Morpheus/Error/Selection.hs +0/−8
- src/Data/Morpheus/Execution/Document/Encode.hs +2/−5
- src/Data/Morpheus/Execution/Server/Encode.hs +40/−81
- src/Data/Morpheus/Execution/Server/Interpreter.hs +1/−1
- src/Data/Morpheus/Execution/Server/Resolve.hs +30/−20
- src/Data/Morpheus/Execution/Server/Subscription.hs +105/−0
- src/Data/Morpheus/Execution/Subscription/Apollo.hs +0/−92
- src/Data/Morpheus/Execution/Subscription/ClientRegister.hs +0/−126
- src/Data/Morpheus/Schema/SchemaAPI.hs +1/−1
- src/Data/Morpheus/Server.hs +8/−8
- src/Data/Morpheus/Types.hs +20/−3
- src/Data/Morpheus/Types/GQLType.hs +1/−1
- src/Data/Morpheus/Types/Internal/Apollo.hs +92/−0
- src/Data/Morpheus/Types/Internal/Resolving.hs +8/−6
- src/Data/Morpheus/Types/Internal/Resolving/Core.hs +58/−33
- src/Data/Morpheus/Types/Internal/Resolving/Resolver.hs +305/−302
- src/Data/Morpheus/Types/Internal/WebSocket.hs +15/−12
- test/Feature/Holistic/API.hs +2/−8
- test/Feature/WrappedTypeName/API.hs +7/−7
README.md view
@@ -29,7 +29,7 @@ resolver: lts-14.8 extra-deps:- - morpheus-graphql-0.9.1+ - morpheus-graphql-0.10.0 ``` As Morpheus is quite new, make sure stack can find morpheus-graphql by running `stack upgrade` and `stack update`@@ -425,17 +425,17 @@ where -- Mutation Without Event Triggering createDeity :: ResolveM EVENT IO Address- createDeity = MutResolver \$ do- value <- lift dbCreateDeity- pure (- [Event { channels = [ChannelA], content = ContentA 1 }],- value- )- newDeity = SubResolver [ChannelA] subResolver+ createDeity = do+ requireAuthorized+ publish [Event { channels = [ChannelA], content = ContentA 1 }]+ lift dbCreateDeity+ newDeity = subscribe [ChannelA] $ do+ requireAuthorized+ lift deityByEvent where- subResolver (Event [ChannelA] (ContentA _value)) = fetchDeity -- resolve New State- subResolver (Event [ChannelA] (ContentB _value)) = fetchDeity -- resolve New State- subResolver _ = fetchDeity -- Resolve Old State+ deityByEvent (Event [ChannelA] (ContentA _value)) = fetchDeity -- resolve New State+ deityByEvent (Event [ChannelA] (ContentB _value)) = fetchDeity -- resolve New State+ deityByEvent _ = fetchDeity -- Resolve Old State ``` ## Morpheus `GraphQL Client` with Template haskell QuasiQuotes@@ -541,6 +541,18 @@ ## Morpheus CLI for Code Generating you should use [morpheus-graphql-cli](https://github.com/morpheusgraphql/morpheus-graphql-cli)++## Showcase++Below are the list of projects using Morpheus GraphQL. If you want to start using Morpheus GraphQL, they are+good templates to begin with.++- https://github.com/morpheusgraphql/mythology-api+ - Serverless Mythology API+- https://github.com/dandoh/web-haskell+ - Modern webserver boilerplate in Haskell: Morpheus Graphql + Postgresql + Authentication + DB migration + Dotenv and more++*Edit this section and send PR if you want to share your project*. # About
changelog.md view
@@ -1,5 +1,79 @@ # Changelog +## 0.10.0 - 07.01.2020++### Breaking Changes++- all constructors of `Resolver`: `QueryResolver`,`MutResolver`,`SubResolver` are unexposed. use `lift` , `publish` or `subscribe`.+ e.g++ ```hs+ -- Query Resolver+ resolveUser :: ResolveQ EVENT IO User+ resolveUser = lift getDBUser++ -- Mutation Resolver+ resolveCreateUser :: ResolveM EVENT IO User+ resolveCreateUser = do+ publish [userUpdate] -- publishes event inside mutation+ lift setDBUser++ -- Subscription Resolver+ resolveNewUser :: ResolveS EVENT IO User+ resolveNewUser = subscribe [USER] $ do+ pure $ \(Event _ content) -> lift (getDBUserByContent content)+ ```+ +### New features++- exposed `publish` for mutation resolvers, now you can write++ ```hs+ resolveCreateUser :: ResolveM EVENT IO User+ resolveCreateUser = do+ requireAuthorized+ publish [userUpdate]+ liftEither setDBUser+ ```++- exposed `subscribe` for subscription resolvers, now you can write++ ```hs+ resolveNewUser :: ResolveS EVENT IO User+ resolveNewUser = subscribe [USER] $ do+ requireAuthorized+ pure userByEvent+ where userByEvent (Event _ content) = liftEither (getDBUser content)+ ```++- `type SubField` will convert your subscription monad to query monad.+ `SubField (Resolver Subscription Event IO) User` will generate same as+ `Resolver Subscription Event IO (User ((Resolver QUERY Event IO)))`+ + now if you want define subscription as follows+ + ```hs+ data Subscription m = Subscription {+ newUser :: SubField m User+ }+ ```++- `unsafeInternalContext` to get resolver context, use only if it really necessary.+ the code depending on it may break even on minor version changes.+ + ```hs+ resolveUser :: ResolveQ EVENT IO User+ resolveUser = do+ Context { currentSelection, schema, operation } <- unsafeInternalContext+ lift (getDBUser currentSelection)+ ```++### Minor++- MonadIO instance for resolvers. Thanks @dandoh+- Example using STM, authentication, monad transformers. Thanks @dandoh+- added dependency `mtl`+ ## [0.9.1] - 02.01.2020 - removed dependency `mtl`
morpheus-graphql.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 0d4240eb95d5effb0f31f87c698a24d51c363a7197319f37b50f29999209a999+-- hash: acb4d101970b68e1e9b3790252120726595167c2154a4861772462f29501c7bb name: morpheus-graphql-version: 0.9.1+version: 0.10.0 synopsis: Morpheus GraphQL description: Build GraphQL APIs with your favourite functional language! category: web, graphql@@ -341,8 +341,7 @@ Data.Morpheus.Execution.Server.Interpreter Data.Morpheus.Execution.Server.Introspect Data.Morpheus.Execution.Server.Resolve- Data.Morpheus.Execution.Subscription.Apollo- Data.Morpheus.Execution.Subscription.ClientRegister+ Data.Morpheus.Execution.Server.Subscription Data.Morpheus.Parsing.Document.Parser Data.Morpheus.Parsing.Document.TypeSystem Data.Morpheus.Parsing.Internal.Internal@@ -363,6 +362,7 @@ Data.Morpheus.Types.GQLScalar Data.Morpheus.Types.GQLType Data.Morpheus.Types.ID+ Data.Morpheus.Types.Internal.Apollo Data.Morpheus.Types.Internal.AST.Base Data.Morpheus.Types.Internal.AST.Data Data.Morpheus.Types.Internal.AST.Selection@@ -391,6 +391,7 @@ , bytestring >=0.10.4 && <0.11 , containers >=0.4.2.1 && <0.7 , megaparsec >=7.0.0 && <9.0.0+ , mtl >=2.0 && <=2.3 , scientific >=0.3.6.2 && <0.4 , template-haskell >=2.0 && <=2.16 , text >=1.2.3.0 && <1.3@@ -431,6 +432,7 @@ , containers >=0.4.2.1 && <0.7 , megaparsec >=7.0.0 && <9.0.0 , morpheus-graphql+ , mtl >=2.0 && <=2.3 , scientific >=0.3.6.2 && <0.4 , tasty , tasty-hunit
src/Data/Morpheus/Error/Selection.hs view
@@ -5,7 +5,6 @@ , subfieldsNotSelected , duplicateQuerySelections , hasNoSubfields- , resolvingFailedError ) where @@ -22,13 +21,6 @@ import Data.Text ( Text ) import qualified Data.Text as T ( concat )---resolvingFailedError :: Position -> Text -> Text -> GQLError-resolvingFailedError position name reason = GQLError- { message = "Failure on Resolving Field \"" <> name <> "\": " <> reason- , locations = [position]- } -- GQL: "Field \"default\" must not have a selection since type \"String!\" has no subfields."
src/Data/Morpheus/Execution/Document/Encode.hs view
@@ -34,7 +34,6 @@ ( Resolver , MapStrategy(..) , LiftOperation- , ResolvingStrategy , DataResolver(..) ) import Data.Morpheus.Types.Internal.TH@@ -80,15 +79,13 @@ | isSubscription typeKindD = [applyT ''MapStrategy $ map conT [''QUERY, ''SUBSCRIPTION]] | otherwise- = [ iLiftOp fo_ ''ResolvingStrategy- , iLiftOp fo_ ''Resolver+ = [ iLiftOp fo_ , typeT ''MapStrategy [fo_, po_] , iTypeable fo_ , iTypeable po_ ] -------------------------- iLiftOp op name =- applyT ''LiftOperation [varT $ mkName $ unpack op, conT name]+ iLiftOp op = applyT ''LiftOperation [varT $ mkName $ unpack op] ------------------------- iTypeable name = typeT ''Typeable [name] -------------------------------------------
src/Data/Morpheus/Execution/Server/Encode.hs view
@@ -34,7 +34,6 @@ import GHC.Generics -- MORPHEUS-import Data.Morpheus.Error.Internal ( internalResolvingError ) import Data.Morpheus.Execution.Server.Decode ( DecodeType , decodeArguments@@ -57,46 +56,43 @@ import Data.Morpheus.Types.Internal.AST ( Name , Operation(..)- , ValidOperation- , Key , MUTATION , OperationType , QUERY , SUBSCRIPTION- , Selection(..)- , SelectionContent(..)- , ValidSelection , GQLValue(..) , ValidValue- , ValidSelectionSet ) import Data.Morpheus.Types.Internal.Resolving ( MapStrategy(..) , LiftOperation- , Resolver(..)- , resolving+ , Resolver+ , unsafeBind , toResolver- , ResolvingStrategy(..)- , withObject- , Validation- , failure , DataResolver(..) , resolveObject , resolve__typename- , resolveEnum , FieldRes+ , ResponseStream+ , runResolver+ , runDataResolver+ , Context(..) ) class Encode resolver o e (m :: * -> *) where- encode :: resolver -> (Key, ValidSelection) -> ResolvingStrategy o e m ValidValue+ encode :: resolver -> Resolver o e m ValidValue -instance {-# OVERLAPPABLE #-} (EncodeKind (KIND a) a o e m , LiftOperation o ResolvingStrategy) => Encode a o e m where+instance {-# OVERLAPPABLE #-} (EncodeKind (KIND a) a o e m , LiftOperation o) => Encode a o e m where encode resolver = encodeKind (VContext resolver :: VContext (KIND a) a) -- MAYBE-instance (Monad m , LiftOperation o ResolvingStrategy,Encode a o e m) => Encode (Maybe a) o e m where- encode = maybe (const $ pure gqlNull) encode+instance (Monad m , LiftOperation o,Encode a o e m) => Encode (Maybe a) o e m where+ encode = maybe (pure gqlNull) encode +-- LIST []+instance (Monad m, Encode a o e m, LiftOperation o) => Encode [a] o e m where+ encode = fmap gqlList . (traverse encode)+ -- Tuple (a,b) instance Encode (Pair k v) o e m => Encode (k, v) o e m where encode (key, value) = encode (Pair key value)@@ -106,68 +102,35 @@ encode = encode . S.toList -- Map-instance (Eq k, Monad m,LiftOperation o Resolver, Encode (MapKind k v (Resolver o e m)) o e m) => Encode (Map k v) o e m where+instance (Eq k, Monad m,LiftOperation o, Encode (MapKind k v (Resolver o e m)) o e m) => Encode (Map k v) o e m where encode value = encode ((mapKindFromList $ M.toList value) :: MapKind k v (Resolver o e m)) --- LIST []-instance (Monad m, Encode a o e m, LiftOperation o ResolvingStrategy) => Encode [a] o e m where- encode list query = gqlList <$> traverse (`encode` query) list- -- GQL a -> Resolver b, MUTATION, SUBSCRIPTION, QUERY-instance (DecodeType a,Generic a, Monad m,LiftOperation fo Resolver, MapStrategy fo o, Encode b fo e m) => Encode (a -> Resolver fo e m b) o e m where- encode resolver selection@(_, Selection { selectionArguments }) =- mapStrategy $ resolving encode (toResolver args resolver) selection- where- args :: Validation a- args = decodeArguments selectionArguments+instance (DecodeType a,Generic a, Monad m,LiftOperation fo, MapStrategy fo o, Encode b fo e m) => Encode (a -> Resolver fo e m b) o e m where+ encode resolver = mapStrategy $ (toResolver decodeArguments resolver) `unsafeBind` encode -- GQL a -> Resolver b, MUTATION, SUBSCRIPTION, QUERY-instance (Monad m,LiftOperation fo Resolver, MapStrategy fo o, Encode b fo e m) => Encode (Resolver fo e m b) o e m where- encode resolver = mapStrategy . resolving encode resolver+instance (Monad m,LiftOperation fo, MapStrategy fo o, Encode b fo e m) => Encode (Resolver fo e m b) o e m where+ encode = mapStrategy . (`unsafeBind` encode) -- ENCODE GQL KIND class EncodeKind (kind :: GQL_KIND) a o e (m :: * -> *) where- encodeKind :: LiftOperation o ResolvingStrategy => VContext kind a -> (Key, ValidSelection) -> ResolvingStrategy o e m ValidValue+ encodeKind :: LiftOperation o => VContext kind a -> Resolver o e m ValidValue -- SCALAR instance (GQLScalar a, Monad m) => EncodeKind SCALAR a o e m where- encodeKind = pure . pure . gqlScalar . serialize . unVContext+ encodeKind = pure . gqlScalar . serialize . unVContext -- ENUM instance (Generic a, EnumRep (Rep a), Monad m) => EncodeKind ENUM a o e m where- encodeKind = pure . pure . gqlString . encodeRep . from . unVContext+ encodeKind = pure . gqlString . encodeRep . from . unVContext instance (Monad m,Generic a, GQLType a,ExploreResolvers (CUSTOM a) a o e m) => EncodeKind OUTPUT a o e m where- encodeKind (VContext value) (key, sel@Selection { selectionContent }) =- encodeNode (exploreResolvers (Proxy @(CUSTOM a)) value) selectionContent- where- encodeNode (ObjectRes fields) _ = withObject encodeObject (key, sel)- where- encodeObject selection =- resolveObject selection- $ ObjectRes- $ resolve__typename (__typeName (Proxy @a))- : fields- encodeNode (EnumRes enum) _ =- resolveEnum (__typeName (Proxy @a)) enum selectionContent- -- Type References --------------------------------------------------------------- encodeNode (UnionRef (fieldTypeName, fieldResolver)) (UnionSelection selections)- = fieldResolver- (key, sel { selectionContent = SelectionSet currentSelection })- where currentSelection = pickSelection fieldTypeName selections- -- RECORDS ----------------------------------------------------------------------------- encodeNode (UnionRes (name, fields)) (UnionSelection selections) =- resolveObject selection resolvers- where- selection = pickSelection name selections- resolvers = ObjectRes (resolve__typename name : fields)- encodeNode _ _ = failure $ internalResolvingError- "union Resolver should only recieve UnionSelection"-+ encodeKind (VContext value) = runDataResolver (__typeName (Proxy @a)) (exploreResolvers (Proxy @(CUSTOM a)) value) convertNode- :: (Monad m, LiftOperation o ResolvingStrategy)+ :: (Monad m, LiftOperation o) => ResNode o e m -> DataResolver o e m convertNode ResNode { resKind = REP_OBJECT, resFields } =@@ -191,8 +154,7 @@ -- Types & Constrains ------------------------------------------------------- type GQL_RES a = (Generic a, GQLType a) -type EncodeOperator o e m a- = a -> ValidOperation -> ResolvingStrategy o e m ValidValue+type EncodeOperation e m a = a -> Context -> ResponseStream e m ValidValue type EncodeCon o e m a = (GQL_RES a, ExploreResolvers (CUSTOM a) a o e m) @@ -212,7 +174,7 @@ class ExploreResolvers (custom :: Bool) a (o :: OperationType) e (m :: * -> *) where exploreResolvers :: Proxy custom -> a -> DataResolver o e m -instance (Generic a,Monad m,LiftOperation o ResolvingStrategy,TypeRep (Rep a) o e m ) => ExploreResolvers 'False a o e m where+instance (Generic a,Monad m,LiftOperation o,TypeRep (Rep a) o e m ) => ExploreResolvers 'False a o e m where exploreResolvers _ value = convertNode $ typeResolvers (ResContext :: ResContext OUTPUT o e m value) (from value) @@ -224,8 +186,9 @@ , EncodeCon QUERY event m query ) => schema (Resolver QUERY event m)- -> EncodeOperator QUERY event m query+ -> EncodeOperation event m query encodeQuery schema = encodeOperationWith+ (Proxy @QUERY) (Just $ objectResolvers (Proxy :: Proxy (CUSTOM (schema (Resolver QUERY event m)))) schema@@ -234,22 +197,23 @@ encodeMutation :: forall event m mut . (Monad m, EncodeCon MUTATION event m mut)- => EncodeOperator MUTATION event m mut-encodeMutation = encodeOperationWith Nothing+ => EncodeOperation event m mut+encodeMutation = encodeOperationWith (Proxy @MUTATION) Nothing encodeSubscription :: forall m event mut . (Monad m, EncodeCon SUBSCRIPTION event m mut)- => EncodeOperator SUBSCRIPTION event m mut-encodeSubscription = encodeOperationWith Nothing+ => EncodeOperation event m mut+encodeSubscription = encodeOperationWith (Proxy @SUBSCRIPTION) Nothing encodeOperationWith- :: forall o e m a- . (Monad m, EncodeCon o e m a, LiftOperation o ResolvingStrategy)- => Maybe (DataResolver o e m)- -> EncodeOperator o e m a-encodeOperationWith externalRes rootResolver Operation { operationSelection } =- resolveObject operationSelection (rootDataRes <> extDataRes)+ :: forall (o :: OperationType) e m a+ . (Monad m, EncodeCon o e m a, LiftOperation o)+ => Proxy o+ -> Maybe (DataResolver o e m)+ -> EncodeOperation e m a+encodeOperationWith _ externalRes rootResolver ctx@Context { operation = Operation { operationSelection } } =+ runResolver (resolveObject operationSelection (rootDataRes <> extDataRes)) ctx where rootDataRes = objectResolvers (Proxy :: Proxy (CUSTOM a)) rootResolver extDataRes = fromMaybe (ObjectRes []) externalRes@@ -260,10 +224,6 @@ -- NEW AUTOMATIC DERIVATION SYSTEM--pickSelection :: Name -> [(Name, ValidSelectionSet)] -> ValidSelectionSet-pickSelection name = fromMaybe [] . lookup name- data REP_KIND = REP_UNION | REP_OBJECT data ResNode o e m = ResNode {@@ -277,7 +237,7 @@ data FieldNode o e m = FieldNode { fieldTypeName :: Name, fieldSelName :: Name,- fieldResolver :: (Key, ValidSelection) -> ResolvingStrategy o e m ValidValue,+ fieldResolver :: Resolver o e m ValidValue, isFieldObject :: Bool } @@ -329,4 +289,3 @@ instance FieldRep U1 o e m where fieldRep _ _ = []-
src/Data/Morpheus/Execution/Server/Interpreter.hs view
@@ -35,7 +35,7 @@ , streamResolver , coreResolver )-import Data.Morpheus.Execution.Subscription.ClientRegister+import Data.Morpheus.Execution.Server.Subscription ( GQLState ) import Data.Morpheus.Types.Internal.Resolving ( GQLRootResolver(..)
src/Data/Morpheus/Execution/Server/Resolve.hs view
@@ -42,9 +42,9 @@ , introspectObjectFields , TypeScope(..) )-import Data.Morpheus.Execution.Subscription.ClientRegister+import Data.Morpheus.Execution.Server.Subscription ( GQLState- , publishUpdates+ , publishEvent ) import Data.Morpheus.Parsing.Request.Parser ( parseGQL )@@ -56,7 +56,6 @@ import Data.Morpheus.Types.GQLType ( GQLType(CUSTOM) ) import Data.Morpheus.Types.Internal.AST ( Operation(..)- , ValidOperation , DataFingerprint(..) , DataTypeContent(..) , Schema(..)@@ -70,11 +69,12 @@ , Name , DataField , VALIDATION_MODE(..)+ , Selection(..)+ , SelectionContent(..) ) import Data.Morpheus.Types.Internal.Resolving ( GQLRootResolver(..)- , Resolver(..)- , toResponseRes+ , Resolver , GQLChannel(..) , ResponseEvent(..) , ResponseStream@@ -84,6 +84,7 @@ , unpackEvents , Failure(..) , resolveUpdates+ , Context(..) ) import Data.Morpheus.Types.IO ( GQLRequest(..) , GQLResponse(..)@@ -145,6 +146,7 @@ streamResolver root req = ResultT $ pure . renderResponse <$> runResultT (coreResolver root req) + coreResolver :: forall event m query mut sub . (Monad m, RootResCon m event query mut sub)@@ -155,22 +157,30 @@ = validRequest >>= execOperator where validRequest- :: Monad m => ResponseStream event m (Schema, ValidOperation)+ :: Monad m => ResponseStream event m Context validRequest = cleanEvents $ ResultT $ pure $ do- schema <- fullSchema $ Identity root- query <- parseGQL request >>= validateRequest schema FULL_VALIDATION- pure (schema, query)+ schema <- fullSchema $ Identity root+ operation <- parseGQL request >>= validateRequest schema FULL_VALIDATION+ pure $ Context {+ schema+ , operation+ , currentSelection = (+ "Root"+ , Selection {+ selectionArguments = []+ , selectionPosition = (operationPosition operation)+ , selectionAlias = Nothing+ , selectionContent = SelectionSet (operationSelection operation)+ } + )+ } ----------------------------------------------------------- execOperator (schema, operation@Operation { operationType = Query }) =- toResponseRes (encodeQuery (schemaAPI schema) queryResolver operation)- execOperator (_, operation@Operation { operationType = Mutation }) =- toResponseRes (encodeMutation mutationResolver operation)- execOperator (_, operation@Operation { operationType = Subscription }) =- response- where- response =- toResponseRes (encodeSubscription subscriptionResolver operation)-+ execOperator ctx@Context {schema ,operation = Operation{ operationType} } = execOperationBy operationType ctx+ where+ execOperationBy Query = encodeQuery (schemaAPI schema) queryResolver+ execOperationBy Mutation = encodeMutation mutationResolver+ execOperationBy Subscription = encodeSubscription subscriptionResolver+ statefulResolver :: (EventCon event, MonadIO m) => GQLState m event@@ -182,7 +192,7 @@ mapM_ execute (unpackEvents res) pure $ encode $ renderResponse res where- execute (Publish updates) = publishUpdates state updates+ execute (Publish events) = publishEvent state events execute Subscribe{} = pure () fullSchema
+ src/Data/Morpheus/Execution/Server/Subscription.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE NamedFieldPuns , FlexibleContexts #-}++module Data.Morpheus.Execution.Server.Subscription+ ( ClientDB+ , GQLState+ , initGQLState+ , connectClient+ , disconnectClient+ , startSubscription+ , endSubscription+ , publishEvent+ )+where++import Control.Monad.IO.Class ( MonadIO(liftIO) )+import Control.Concurrent ( MVar+ , modifyMVar+ , modifyMVar_+ , newMVar+ , readMVar+ )+import Data.Foldable ( traverse_ )+import Data.List ( intersect )+import Data.UUID.V4 ( nextRandom )+import Network.WebSockets ( Connection+ , sendTextData+ )+import Data.HashMap.Lazy ( empty+ , insert+ , delete+ , adjust+ , toList+ )++-- MORPHEUS+import Data.Morpheus.Types.Internal.Apollo+ ( toApolloResponse )+import Data.Morpheus.Types.Internal.Resolving+ ( Event(..)+ , GQLChannel(..)+ , SubEvent+ )+import Data.Morpheus.Types.Internal.WebSocket+ ( ClientID+ , GQLClient(..)+ , ClientDB+ , GQLState+ , SesionID+ )++-- | initializes empty GraphQL state+initGQLState :: IO (GQLState m e)+initGQLState = newMVar empty+ +connectClient :: MonadIO m => Connection -> GQLState m e -> IO (GQLClient m e)+connectClient clientConnection gqlState = do+ clientID <- nextRandom+ let client = GQLClient { clientID , clientConnection, clientSessions = empty }+ modifyMVar_ gqlState (pure . insert clientID client)+ return client++disconnectClient :: GQLClient m e -> GQLState m e -> IO (ClientDB m e)+disconnectClient GQLClient { clientID } state = modifyMVar state removeUser+ where+ removeUser db = let s' = delete clientID db in return (s', s')++updateClientByID+ :: MonadIO m =>+ ClientID+ -> (GQLClient m e -> GQLClient m e)+ -> MVar (ClientDB m e)+ -> m ()+updateClientByID key f state = liftIO $ modifyMVar_ state (return . adjust f key)++publishEvent+ :: (Eq (StreamChannel e), GQLChannel e, MonadIO m) => GQLState m e -> e -> m ()+publishEvent gqlState event = liftIO (readMVar gqlState) >>= traverse_ sendMessage + where+ sendMessage GQLClient { clientSessions, clientConnection } + | null clientSessions = return ()+ | otherwise = mapM_ send (filterByChannels clientSessions)+ where+ send (sid, Event { content = subscriptionRes }) = do+ res <- subscriptionRes event+ let apolloRes = toApolloResponse sid res+ liftIO $ sendTextData clientConnection apolloRes+ ---------------------------+ filterByChannels = filter+ ( not+ . null+ . intersect (streamChannels event)+ . channels+ . snd+ ) . toList++endSubscription :: MonadIO m => ClientID -> SesionID -> GQLState m e -> m ()+endSubscription cid sid = updateClientByID cid stopSubscription+ where+ stopSubscription client = client { clientSessions = delete sid (clientSessions client) }++startSubscription :: MonadIO m => ClientID -> SubEvent m e -> SesionID -> GQLState m e -> m ()+startSubscription cid subscriptions sid = updateClientByID cid startSubscription+ where+ startSubscription client = client+ { clientSessions = insert sid subscriptions (clientSessions client) }
− src/Data/Morpheus/Execution/Subscription/Apollo.hs
@@ -1,92 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Execution.Subscription.Apollo- ( SubAction(..)- , apolloFormat- , acceptApolloSubProtocol- , toApolloResponse- ) where--import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), eitherDecode, encode, pairs,- withObject, (.:), (.:?), (.=))-import Data.ByteString.Lazy.Char8 (ByteString)-import Data.Morpheus.Types (GQLRequest (..))-import Data.Morpheus.Types.IO (GQLResponse)-import Data.Semigroup ((<>))-import Data.Text (Text)-import GHC.Generics (Generic)-import Network.WebSockets (AcceptRequest (..), RequestHead, getRequestSubprotocols)--type ApolloID = Text--data ApolloSubscription payload =- ApolloSubscription- { apolloId :: Maybe ApolloID- , apolloType :: Text- , apolloPayload :: Maybe payload- }- deriving (Show, Generic)--instance FromJSON a => FromJSON (ApolloSubscription a) where- parseJSON = withObject "ApolloSubscription" objectParser- where- objectParser o =- ApolloSubscription <$> o .:? "id" <*> o .: "type" <*> o .:? "payload"--data RequestPayload =- RequestPayload- { payloadOperationName :: Maybe Text- , payloadQuery :: Maybe Text- , payloadVariables :: Maybe Value- }- deriving (Show, Generic)--instance FromJSON RequestPayload where- parseJSON = withObject "ApolloPayload" objectParser- where- objectParser o =- RequestPayload <$> o .:? "operationName" <*> o .:? "query" <*>- o .:? "variables"--instance ToJSON a => ToJSON (ApolloSubscription a) where- toEncoding (ApolloSubscription id' type' payload') =- pairs $ "id" .= id' <> "type" .= type' <> "payload" .= payload'--acceptApolloSubProtocol :: RequestHead -> AcceptRequest-acceptApolloSubProtocol reqHead =- apolloProtocol (getRequestSubprotocols reqHead)- where- apolloProtocol ["graphql-subscriptions"] =- AcceptRequest (Just "graphql-subscriptions") []- apolloProtocol ["graphql-ws"] = AcceptRequest (Just "graphql-ws") []- apolloProtocol _ = AcceptRequest Nothing []--toApolloResponse :: ApolloID -> GQLResponse -> ByteString-toApolloResponse sid val =- encode $ ApolloSubscription (Just sid) "data" (Just val)--data SubAction- = RemoveSub ApolloID- | AddSub ApolloID GQLRequest- | SubError String--apolloFormat :: ByteString -> SubAction-apolloFormat = toWsAPI . eitherDecode- where- toWsAPI :: Either String (ApolloSubscription RequestPayload) -> SubAction- toWsAPI (Right ApolloSubscription { apolloType = "start"- , apolloId = Just sessionId- , apolloPayload = Just RequestPayload { payloadQuery = Just query- , payloadOperationName = operationName- , payloadVariables = variables- }- }) =- AddSub sessionId (GQLRequest {query, operationName, variables})- toWsAPI (Right ApolloSubscription { apolloType = "stop"- , apolloId = Just sessionId- }) = RemoveSub sessionId- toWsAPI (Right x) = SubError (show x)- toWsAPI (Left x) = SubError x
− src/Data/Morpheus/Execution/Subscription/ClientRegister.hs
@@ -1,126 +0,0 @@-{-# LANGUAGE NamedFieldPuns , FlexibleContexts #-}--module Data.Morpheus.Execution.Subscription.ClientRegister- ( ClientRegister- , GQLState- , initGQLState- , connectClient- , disconnectClient- , updateClientByID- , publishUpdates- , addClientSubscription- , removeClientSubscription- )-where--import Control.Monad.IO.Class ( MonadIO(liftIO) )-import Control.Concurrent ( MVar- , modifyMVar- , modifyMVar_- , newMVar- , readMVar- )-import Data.Foldable ( traverse_ )-import Data.List ( intersect )-import Data.Text ( Text )-import Data.UUID.V4 ( nextRandom )-import Network.WebSockets ( Connection- , sendTextData- )--- MORPHEUS-import Data.Morpheus.Execution.Subscription.Apollo- ( toApolloResponse )-import Data.Morpheus.Types.Internal.Resolving- ( Event(..)- , GQLChannel(..)- , SubEvent- )-import Data.Morpheus.Types.Internal.WebSocket- ( ClientID- , ClientSession(..)- , GQLClient(..)- )--type ClientRegister m e = [(ClientID, GQLClient m e)]---- | shared GraphQL state between __websocket__ and __http__ server,--- stores information about subscriptions-type GQLState m e = MVar (ClientRegister m e) -- SharedState---- | initializes empty GraphQL state-initGQLState :: IO (GQLState m e)-initGQLState = newMVar []--connectClient :: MonadIO m => Connection -> GQLState m e -> IO (GQLClient m e)-connectClient clientConnection varState' = do- client' <- newClient- modifyMVar_ varState' (addClient client')- return (snd client')- where- newClient = do- clientID <- nextRandom- return- (clientID, GQLClient { clientID, clientConnection, clientSessions = [] })- addClient client' state' = return (client' : state')--disconnectClient :: GQLClient m e -> GQLState m e -> IO (ClientRegister m e)-disconnectClient client state = modifyMVar state removeUser- where- removeUser state' = let s' = removeClient state' in return (s', s')- removeClient :: ClientRegister m e -> ClientRegister m e- removeClient = filter ((/= clientID client) . fst)--updateClientByID- :: MonadIO m =>- ClientID- -> (GQLClient m e -> GQLClient m e)- -> MVar (ClientRegister m e)- -> m ()-updateClientByID id' updateFunc state = liftIO $ modifyMVar_- state- (return . map updateClient)- where- updateClient (key, client') | key == id' = (key, updateFunc client')- updateClient state' = state'--publishUpdates- :: (Eq (StreamChannel e), GQLChannel e, MonadIO m) => GQLState m e -> e -> m ()-publishUpdates state event = do- state' <- liftIO $ readMVar state- traverse_ sendMessage state'- where- sendMessage (_, GQLClient { clientSessions = [] } ) = return ()- sendMessage (_, GQLClient { clientSessions, clientConnection }) = mapM_- __send- (filterByChannels clientSessions)- where- __send ClientSession { sessionId, sessionSubscription = Event { content = subscriptionRes } } = do- res <- subscriptionRes event- let apolloRes = toApolloResponse sessionId res- liftIO $ sendTextData clientConnection apolloRes- ---------------------------- filterByChannels = filter- ( not- . null- . intersect (streamChannels event)- . channels- . sessionSubscription- )--removeClientSubscription :: MonadIO m => ClientID -> Text -> GQLState m e -> m ()-removeClientSubscription id' sid' = updateClientByID id' stopSubscription- where- stopSubscription client' = client'- { clientSessions = filter ((sid' /=) . sessionId) (clientSessions client')- }--addClientSubscription- :: MonadIO m => ClientID -> SubEvent m e -> Text -> GQLState m e -> m ()-addClientSubscription id' sessionSubscription sessionId = updateClientByID- id'- startSubscription- where- startSubscription client' = client'- { clientSessions = ClientSession { sessionId, sessionSubscription }- : clientSessions client'- }
src/Data/Morpheus/Schema/SchemaAPI.hs view
@@ -41,7 +41,7 @@ , lookupDataType ) import Data.Morpheus.Types.Internal.Resolving- ( Resolver(..)+ ( Resolver , resolveUpdates )
src/Data/Morpheus/Server.hs view
@@ -30,20 +30,20 @@ ( RootResCon , coreResolver )-import Data.Morpheus.Execution.Subscription.Apollo+import Data.Morpheus.Types.Internal.Apollo ( SubAction(..) , acceptApolloSubProtocol , apolloFormat , toApolloResponse )-import Data.Morpheus.Execution.Subscription.ClientRegister+import Data.Morpheus.Execution.Server.Subscription ( GQLState- , addClientSubscription , connectClient , disconnectClient , initGQLState- , publishUpdates- , removeClientSubscription+ , publishEvent+ , startSubscription+ , endSubscription ) import Data.Morpheus.Types.Internal.Resolving ( GQLRootResolver(..)@@ -75,8 +75,8 @@ clientConnection (toApolloResponse sessionId $ Errors errors) where- execute (Publish pub) = publishUpdates state pub- execute (Subscribe sub) = addClientSubscription clientID sub sessionId state+ execute (Publish pub) = publishEvent state pub+ execute (Subscribe sub) = startSubscription clientID sub sessionId state -- | Wai WebSocket Server App for GraphQL subscriptions gqlSocketMonadIOApp@@ -102,7 +102,7 @@ resolveMessage (AddSub sessionId request) = handleSubscription client state sessionId (coreResolver gqlRoot request) resolveMessage (RemoveSub sessionId) =- removeClientSubscription (clientID client) sessionId state+ endSubscription (clientID client) sessionId state -- | Same as above but specific to IO gqlSocketApp
src/Data/Morpheus/Types.hs view
@@ -21,7 +21,7 @@ , IORes , IOMutRes , IOSubRes- , Resolver(..)+ , Resolver , QUERY , MUTATION , SUBSCRIPTION@@ -32,6 +32,10 @@ , ResolveS , failRes , WithOperation+ , publish+ , subscribe+ , unsafeInternalContext+ , SubField ) where @@ -57,11 +61,16 @@ import Data.Morpheus.Types.Internal.Resolving ( Event(..) , GQLRootResolver(..)- , Resolver(..)+ , Resolver , WithOperation , lift , failure , Failure+ , pushEvents+ , PushEvents(..)+ , subscribe+ , unsafeInternalContext+ , UnSubResolver ) import Data.Morpheus.Types.IO ( GQLRequest(..) , GQLResponse(..)@@ -81,12 +90,20 @@ type ResolveM e m a = MutRes e m (a (MutRes e m)) type ResolveS e m a = SubRes e m (a (Res e m)) +-- Subsciption Object Resolver Fields+type SubField m a = (m (a (UnSubResolver m))) ++publish :: Monad m => [e] -> Resolver MUTATION e m ()+publish = pushEvents+ -- resolves constant value on any argument constRes :: (WithOperation o, Monad m) => b -> a -> Resolver o e m b constRes = const . pure constMutRes :: Monad m => [e] -> a -> args -> MutRes e m a-constMutRes events value = const $ MutResolver $ pure (events, value)+constMutRes events value = const $ do + publish events + pure value failRes :: (WithOperation o, Monad m) => String -> Resolver o e m a failRes = failure . pack
src/Data/Morpheus/Types/GQLType.hs view
@@ -43,7 +43,7 @@ , QUERY ) import Data.Morpheus.Types.Internal.Resolving- ( Resolver(..) )+ ( Resolver ) type TRUE = 'True
+ src/Data/Morpheus/Types/Internal/Apollo.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Types.Internal.Apollo+ ( SubAction(..)+ , apolloFormat+ , acceptApolloSubProtocol+ , toApolloResponse+ ) where++import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), eitherDecode, encode, pairs,+ withObject, (.:), (.:?), (.=))+import Data.ByteString.Lazy.Char8 (ByteString)+import Data.Morpheus.Types (GQLRequest (..))+import Data.Morpheus.Types.IO (GQLResponse)+import Data.Semigroup ((<>))+import Data.Text (Text)+import GHC.Generics (Generic)+import Network.WebSockets (AcceptRequest (..), RequestHead, getRequestSubprotocols)++type ApolloID = Text++data ApolloSubscription payload =+ ApolloSubscription+ { apolloId :: Maybe ApolloID+ , apolloType :: Text+ , apolloPayload :: Maybe payload+ }+ deriving (Show, Generic)++instance FromJSON a => FromJSON (ApolloSubscription a) where+ parseJSON = withObject "ApolloSubscription" objectParser+ where+ objectParser o =+ ApolloSubscription <$> o .:? "id" <*> o .: "type" <*> o .:? "payload"++data RequestPayload =+ RequestPayload+ { payloadOperationName :: Maybe Text+ , payloadQuery :: Maybe Text+ , payloadVariables :: Maybe Value+ }+ deriving (Show, Generic)++instance FromJSON RequestPayload where+ parseJSON = withObject "ApolloPayload" objectParser+ where+ objectParser o =+ RequestPayload <$> o .:? "operationName" <*> o .:? "query" <*>+ o .:? "variables"++instance ToJSON a => ToJSON (ApolloSubscription a) where+ toEncoding (ApolloSubscription id' type' payload') =+ pairs $ "id" .= id' <> "type" .= type' <> "payload" .= payload'++acceptApolloSubProtocol :: RequestHead -> AcceptRequest+acceptApolloSubProtocol reqHead =+ apolloProtocol (getRequestSubprotocols reqHead)+ where+ apolloProtocol ["graphql-subscriptions"] =+ AcceptRequest (Just "graphql-subscriptions") []+ apolloProtocol ["graphql-ws"] = AcceptRequest (Just "graphql-ws") []+ apolloProtocol _ = AcceptRequest Nothing []++toApolloResponse :: ApolloID -> GQLResponse -> ByteString+toApolloResponse sid val =+ encode $ ApolloSubscription (Just sid) "data" (Just val)++data SubAction+ = RemoveSub ApolloID+ | AddSub ApolloID GQLRequest+ | SubError String++apolloFormat :: ByteString -> SubAction+apolloFormat = toWsAPI . eitherDecode+ where+ toWsAPI :: Either String (ApolloSubscription RequestPayload) -> SubAction+ toWsAPI (Right ApolloSubscription { apolloType = "start"+ , apolloId = Just sessionId+ , apolloPayload = Just RequestPayload { payloadQuery = Just query+ , payloadOperationName = operationName+ , payloadVariables = variables+ }+ }) =+ AddSub sessionId (GQLRequest {query, operationName, variables})+ toWsAPI (Right ApolloSubscription { apolloType = "stop"+ , apolloId = Just sessionId+ }) = RemoveSub sessionId+ toWsAPI (Right x) = SubError (show x)+ toWsAPI (Left x) = SubError x
src/Data/Morpheus/Types/Internal/Resolving.hs view
@@ -2,14 +2,12 @@ ( Event(..) , GQLRootResolver(..) , UnSubResolver- , Resolver(..)- , ResolvingStrategy(..)+ , Resolver , MapStrategy(..) , LiftOperation , resolveObject- , toResponseRes- , withObject- , resolving+ , runResolver+ , unsafeBind , toResolver , lift , SubEvent@@ -27,11 +25,15 @@ , GQLErrors , GQLError(..) , Position- , resolveEnum , resolve__typename , DataResolver(..) , FieldRes , WithOperation+ , PushEvents(..)+ , runDataResolver+ , subscribe+ , Context(..)+ , unsafeInternalContext ) where
src/Data/Morpheus/Types/Internal/Resolving/Core.hs view
@@ -1,12 +1,15 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-} module Data.Morpheus.Types.Internal.Resolving.Core ( GQLError(..)@@ -16,15 +19,16 @@ , Result(..) , Failure(..) , ResultT(..)- , fromEither- , fromEitherSingle , unpackEvents , LibUpdater , resolveUpdates , mapEvent- , mapFailure , cleanEvents , StatelessResT+ , Event(..)+ , Channel(..)+ , GQLChannel(..)+ , PushEvents(..) ) where @@ -64,6 +68,39 @@ type StatelessResT = ResultT () GQLError 'True type Validation = Result () GQLError 'True ++-- EVENTS+class PushEvents e m where + pushEvents :: [e] -> m () ++-- Channel+newtype Channel event = Channel {+ _unChannel :: StreamChannel event+}++instance (Eq (StreamChannel event)) => Eq (Channel event) where+ Channel x == Channel y = x == y++class GQLChannel a where+ type StreamChannel a :: *+ streamChannels :: a -> [Channel a]++instance GQLChannel () where+ type StreamChannel () = ()+ streamChannels _ = []++instance GQLChannel (Event channel content) where+ type StreamChannel (Event channel content) = channel+ streamChannels Event { channels } = map Channel channels++data Event e c = Event+ { channels :: [e], content :: c}+++unpackEvents :: Result event c e a -> [event]+unpackEvents Success { events } = events+unpackEvents _ = []+ -- -- Result --@@ -93,18 +130,10 @@ failure text = Failure [GQLError { message = "INTERNAL ERROR: " <> text, locations = [] }] -unpackEvents :: Result event c e a -> [event]-unpackEvents Success { events } = events-unpackEvents _ = []+instance PushEvents events (Result events err con) where+ pushEvents events = Success { result = (), warnings = [], events } -fromEither :: Either [er] a -> Result ev er co a-fromEither (Left e) = Failure e-fromEither (Right a) = Success a [] [] -fromEitherSingle :: Either er a -> Result ev er co a-fromEitherSingle (Left e) = Failure [e]-fromEitherSingle (Right a) = Success a [] []- -- ResultT newtype ResultT event error (concurency :: Bool) (m :: * -> * ) a = ResultT { runResultT :: m (Result event error concurency a ) } deriving (Functor)@@ -135,6 +164,13 @@ failure x = ResultT $ pure $ Failure [GQLError { message = pack x, locations = [] }] +instance Monad m => Failure GQLErrors (ResultT event GQLError concurency m) where+ failure = ResultT . pure . failure++instance Applicative m => PushEvents events (ResultT events err con m) where+ pushEvents = ResultT . pure . pushEvents++ cleanEvents :: Functor m => ResultT e1 error concurency m a@@ -154,17 +190,6 @@ mapEv Success { result, warnings, events } = Success { result, warnings, events = map func events } mapEv (Failure err) = Failure err--mapFailure- :: Monad m- => (er1 -> er2)- -> ResultT ev er1 con m value- -> ResultT ev er2 con m value-mapFailure f (ResultT ma) = ResultT $ mapF <$> ma- where- mapF (Failure x ) = Failure (map f x)- mapF (Success x w e) = Success x (map f w) e- -- Helper Functions type LibUpdater lib = lib -> Validation lib
src/Data/Morpheus/Types/Internal/Resolving/Resolver.hs view
@@ -1,32 +1,33 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Data.Morpheus.Types.Internal.Resolving.Resolver ( Event(..) , GQLRootResolver(..) , UnSubResolver- , Resolver(..)- , ResolvingStrategy(..)+ , Resolver , MapStrategy(..) , LiftOperation , resolveObject- , resolveEnum- , toResponseRes- , withObject- , resolving+ , runDataResolver+ , runResolver+ , unsafeBind , toResolver , lift , SubEvent@@ -37,23 +38,25 @@ , DataResolver(..) , FieldRes , WithOperation+ , subscribe+ , Context(..)+ , unsafeInternalContext ) where -import Control.Monad.Trans.Class ( MonadTrans(..) )+import Control.Monad.Fail (MonadFail(..))+import Control.Monad.Trans.Class ( MonadTrans(..))+import Control.Monad.IO.Class ( MonadIO(..) ) import Data.Maybe ( fromMaybe ) import Data.Semigroup ( (<>) , Semigroup(..) )-import Data.Text ( unpack- , pack- )+import Control.Monad.Trans.Reader (ReaderT(..), ask,mapReaderT, withReaderT)+import Data.Text (pack) -- MORPHEUS import Data.Morpheus.Error.Internal ( internalResolvingError )-import Data.Morpheus.Error.Selection ( resolvingFailedError- , subfieldsNotSelected- )+import Data.Morpheus.Error.Selection ( subfieldsNotSelected ) import Data.Morpheus.Types.Internal.AST.Selection ( Selection(..) , SelectionContent(..)@@ -61,6 +64,8 @@ , ValidSelectionRec , ValidSelectionSet , ValidSelection+ , ValidArguments+ , ValidOperation ) import Data.Morpheus.Types.Internal.AST.Base ( Message@@ -72,20 +77,22 @@ , OperationType , QUERY , SUBSCRIPTION+ , Schema ) import Data.Morpheus.Types.Internal.Resolving.Core ( GQLErrors- , GQLError+ , GQLError(..) , Validation , Result(..) , Failure(..) , ResultT(..)- , fromEither- , fromEitherSingle , cleanEvents- , mapFailure , mapEvent- , StatelessResT+ , Event(..)+ , Channel(..)+ , StreamChannel+ , GQLChannel(..)+ , PushEvents(..) ) import Data.Morpheus.Types.Internal.AST.Value ( GQLValue(..)@@ -94,13 +101,8 @@ import Data.Morpheus.Types.IO ( renderResponse , GQLResponse )--- MORPHEUS -class LiftOperation (o::OperationType) res where- type ResError res :: *- liftOperation :: Monad m => m (Either (ResError res) a) -> res o event m a--type WithOperation (o :: OperationType) = LiftOperation o Resolver+type WithOperation (o :: OperationType) = LiftOperation o type ResponseStream event m = ResultT (ResponseEvent m event) GQLError 'True m @@ -110,329 +112,330 @@ type SubEvent m event = Event (Channel event) (event -> m GQLResponse) -------------------------------------------------------------------------------------------- Recursive Resolver-newtype RecResolver m a b = RecResolver {- unRecResolver :: a -> StatelessResT m b-}+data Context = Context {+ currentSelection :: (Name,ValidSelection),+ schema :: Schema,+ operation :: ValidOperation+} deriving (Show) -instance Functor m => Functor (RecResolver m a) where- fmap f (RecResolver x) = RecResolver recX where recX event = f <$> x event+-- Resolver Internal State+newtype ResolverState event m a = ResolverState {+ runResolverState :: ReaderT Context (ResultT event GQLError 'True m) a+} deriving (Functor, Applicative, Monad) -instance Monad m => Applicative (RecResolver m a) where- pure = RecResolver . const . pure- (RecResolver f) <*> (RecResolver res) = RecResolver recX- where recX event = f event <*> res event+instance Monad m => MonadFail (ResolverState event m) where + fail = failure . pack -instance Monad m => Monad (RecResolver m a) where- (RecResolver x) >>= next = RecResolver recX- where recX event = x event >>= (\v -> v event) . unRecResolver . next-------------------------------------------------------------+instance MonadTrans (ResolverState e) where+ lift = ResolverState . lift . lift ---- GraphQLT-data ResolvingStrategy (o::OperationType) event (m:: * -> *) value where- ResolveQ ::{ unResolveQ :: ResultT () GQLError 'True m value } -> ResolvingStrategy QUERY event m value- ResolveM ::{ unResolveM :: ResultT event GQLError 'True m value } -> ResolvingStrategy MUTATION event m value- ResolveS ::{ unResolveS :: ResultT (Channel event) GQLError 'True m (RecResolver m event value) } -> ResolvingStrategy SUBSCRIPTION event m value+instance (Monad m) => Failure Message (ResolverState e m) where+ failure message = ResolverState $ do + selection <- currentSelection <$> ask + lift $ failure [resolverFailureMessage selection message] --- Functor-instance Monad m => Functor (ResolvingStrategy o e m) where- fmap f (ResolveQ res) = ResolveQ $ f <$> res- fmap f (ResolveM res) = ResolveM $ f <$> res- fmap f (ResolveS res) = ResolveS $ (<$>) f <$> res+instance (Monad m) => Failure GQLErrors (ResolverState e m) where+ failure = ResolverState . lift . failure --- Applicative-instance (LiftOperation o ResolvingStrategy, Monad m) => Applicative (ResolvingStrategy o e m) where- pure = liftOperation . pure . pure- -------------------------------------- (ResolveQ f) <*> (ResolveQ res) = ResolveQ (f <*> res)- ------------------------------------------------------------------------- (ResolveM f) <*> (ResolveM res) = ResolveM (f <*> res)- --------------------------------------------------------------- (ResolveS f) <*> (ResolveS res) = ResolveS $ (<*>) <$> f <*> res+instance (Monad m) => PushEvents e (ResolverState e m) where+ pushEvents = ResolverState . lift . pushEvents --- LiftOperation-instance LiftOperation QUERY ResolvingStrategy where- type ResError ResolvingStrategy = GQLErrors- liftOperation = ResolveQ . ResultT . fmap fromEither -instance LiftOperation MUTATION ResolvingStrategy where- type ResError ResolvingStrategy = GQLErrors- liftOperation = ResolveM . ResultT . fmap fromEither+mapResolverState :: + ( ReaderT Context (ResultT e1 GQLError 'True m1) a1 + -> ReaderT Context (ResultT e2 GQLError 'True m2) a2 + ) -> ResolverState e1 m1 a1 + -> ResolverState e2 m2 a2+mapResolverState f (ResolverState x) = ResolverState (f x) -instance LiftOperation SUBSCRIPTION ResolvingStrategy where- type ResError ResolvingStrategy = GQLErrors- liftOperation = ResolveS . ResultT . fmap (fromEither . fmap pure) - -- Failure-instance (LiftOperation o ResolvingStrategy, Monad m) => Failure GQLErrors (ResolvingStrategy o e m) where- failure = liftOperation . pure . Left---- DataResolver-data DataResolver o e m =- EnumRes Name- | UnionRes (Name,[FieldRes o e m])- | ObjectRes [FieldRes o e m ]- | UnionRef (FieldRes o e m)- | InvalidRes Name--instance Semigroup (DataResolver o e m) where- ObjectRes x <> ObjectRes y = ObjectRes (x <> y)- _ <> _ = InvalidRes "can't merge: incompatible resolvers"--withObject- :: (LiftOperation o ResolvingStrategy, Monad m)- => (ValidSelectionSet -> ResolvingStrategy o e m value)- -> (Key, ValidSelection)- -> ResolvingStrategy o e m value-withObject f (_, Selection { selectionContent = SelectionSet selection }) =- f selection-withObject _ (key, Selection { selectionPosition }) =- failure (subfieldsNotSelected key "" selectionPosition)--resolveObject- :: (Monad m, LiftOperation o ResolvingStrategy)- => ValidSelectionSet- -> DataResolver o e m- -> ResolvingStrategy o e m ValidValue-resolveObject selectionSet (ObjectRes resolvers) =- gqlObject <$> traverse selectResolver selectionSet- where- selectResolver (key, selection@Selection { selectionAlias }) =- (fromMaybe key selectionAlias, ) <$> lookupRes selection- where- lookupRes sel =- (fromMaybe (const $ pure gqlNull) $ lookup key resolvers) (key, sel)-resolveObject _ _ =- failure $ internalResolvingError "expected object as resolver"--resolveEnum- :: (Monad m, LiftOperation o ResolvingStrategy)- => Name- -> Name- -> ValidSelectionRec- -> ResolvingStrategy o e m ValidValue-resolveEnum _ enum SelectionField = pure $ gqlString enum-resolveEnum typeName enum (UnionSelection selections) = resolveObject- currentSelection- resolvers- where- enumObjectTypeName = typeName <> "EnumObject"- currentSelection = fromMaybe [] $ lookup enumObjectTypeName selections- resolvers = ObjectRes- [ ("enum", const $ pure $ gqlString enum)- , resolve__typename enumObjectTypeName- ]-resolveEnum _ _ _ =- failure $ internalResolvingError "wrong selection on enum value"+getState :: (Monad m) => ResolverState e m (Name,ValidSelection)+getState = ResolverState $ currentSelection <$> ask +setState :: (Name,ValidSelection) -> ResolverState e m a -> ResolverState e m a+setState currentSelection = mapResolverState (withReaderT (\ctx -> ctx { currentSelection } )) -resolve__typename- :: (Monad m, LiftOperation o ResolvingStrategy)- => Name- -> (Key, (Key, ValidSelection) -> ResolvingStrategy o e m ValidValue)-resolve__typename name = ("__typename", const $ pure $ gqlString name)+-- clear evets and starts new resolver with diferenct type of events but with same value+-- use properly. only if you know what you are doing+clearStateResolverEvents :: (Functor m) => ResolverState e1 m a -> ResolverState e2 m a+clearStateResolverEvents = mapResolverState (mapReaderT cleanEvents) -toResponseRes- :: Monad m- => ResolvingStrategy o event m ValidValue- -> ResponseStream event m ValidValue-toResponseRes (ResolveQ resT) = cleanEvents resT-toResponseRes (ResolveM resT) = mapEvent Publish resT-toResponseRes (ResolveS resT) = ResultT $ handleActions <$> runResultT resT- where- handleActions (Failure gqlError ) = Failure gqlError- handleActions (Success subRes warnings channels) = Success- { result = gqlNull- , warnings- , events = [Subscribe $ Event channels eventResolver]- }- where- eventResolver event =- renderResponse <$> runResultT (unRecResolver subRes event)+resolverFailureMessage :: (Name,ValidSelection) -> Message -> GQLError+resolverFailureMessage (name, Selection { selectionPosition }) message = GQLError+ { message = "Failure on Resolving Field \"" <> name <> "\": " <> message+ , locations = [selectionPosition]+ } --- -- -- GraphQL Field Resolver --------ResultT GQLError 'True m (RecResolver m event value) --------------------------------------------------------------- data Resolver (o::OperationType) event (m :: * -> * ) value where- QueryResolver::{ unQueryResolver :: ResultT () String 'True m value } -> Resolver QUERY event m value- MutResolver ::{ unMutResolver :: ResultT event String 'True m ([event],value) } -> Resolver MUTATION event m value- SubResolver ::{- subChannels :: [StreamChannel event] ,- subResolver :: event -> Resolver QUERY event m value- } -> Resolver SUBSCRIPTION event m value+ 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 --- Functor-instance Functor m => Functor (Resolver o e m) where- fmap f (QueryResolver res) = QueryResolver $ fmap f res- fmap f (MutResolver res) = MutResolver $ tupleMap <$> res- where tupleMap (e, v) = (e, f v)- fmap f (SubResolver events mResolver) = SubResolver events- (eventFmap mResolver)- where eventFmap res event = fmap f (res event)+deriving instance (Functor m) => Functor (Resolver o e m) -- Applicative-instance (LiftOperation o Resolver ,Monad m) => Applicative (Resolver o e m) where- pure = liftOperation . pure . pure- -------------------------------------- (QueryResolver f) <*> (QueryResolver res) = QueryResolver (f <*> res)- ---------------------------------------------------------------------- MutResolver res1 <*> MutResolver res2 = MutResolver $ join <$> res1 <*> res2- where join (e1, f) (e2, v) = (e1 <> e2, f v)- --------------------------------------------------------------- (SubResolver e1 f) <*> (SubResolver e2 res) = SubResolver (e1 <> e2) subRes- where subRes event = f event <*> res event+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 -- Monad instance (Monad m) => Monad (Resolver QUERY e m) where return = pure- ------------------------------------------------------ (QueryResolver f) >>= nextM = QueryResolver (f >>= unQueryResolver . nextM)+ (>>=) = unsafeBind instance (Monad m) => Monad (Resolver MUTATION e m) where return = pure- ------------------------------------------------------ (MutResolver m1) >>= mFunc = MutResolver $ do- (e1, v1) <- m1- (e2, v2) <- unMutResolver $ mFunc v1- pure (e1 <> e2, v2)+ (>>=) = unsafeBind +-- MonadIO+instance (MonadIO m) => MonadIO (Resolver QUERY e m) where+ liftIO = lift . liftIO+ +instance (MonadIO m) => MonadIO (Resolver MUTATION e m) where+ liftIO = lift . liftIO+ -- Monad Transformers instance MonadTrans (Resolver QUERY e) where- lift = liftOperation . fmap pure+ lift = packResolver . lift instance MonadTrans (Resolver MUTATION e) where- lift = liftOperation . fmap pure+ lift = packResolver . lift --- LiftOperation-instance LiftOperation QUERY Resolver where- type ResError Resolver = String- liftOperation = QueryResolver . ResultT . fmap fromEitherSingle+-- Failure+instance (LiftOperation o, Monad m) => Failure Message (Resolver o e m) where+ failure = packResolver .failure -instance LiftOperation MUTATION Resolver where- type ResError Resolver = String- liftOperation = MutResolver . ResultT . fmap (fromEitherSingle . fmap ([], ))+instance (LiftOperation o, Monad m) => Failure GQLErrors (Resolver o e m) where+ failure = packResolver . failure -instance LiftOperation SUBSCRIPTION Resolver where- type ResError Resolver = String- liftOperation = SubResolver [] . const . liftOperation+-- PushEvents+instance (Monad m) => PushEvents e (Resolver MUTATION e m) where+ pushEvents = packResolver . pushEvents --- Failure-instance (LiftOperation o Resolver, Monad m) => Failure Message (Resolver o e m) where- failure = liftOperation . pure . Left . unpack+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 --- Type Helpers -type family UnSubResolver (a :: * -> *) :: (* -> *)+-- packResolver+instance LiftOperation QUERY where+ packResolver = ResolverQ . clearStateResolverEvents+ withResolver ctxRes toRes = ResolverQ $ do + v <- clearStateResolverEvents ctxRes + runResolverQ $ toRes v -type instance UnSubResolver (Resolver SUBSCRIPTION m e) = Resolver QUERY m e+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 --- RESOLVING-type FieldRes o e m- = (Key, (Key, ValidSelection) -> ResolvingStrategy o e m ValidValue)+setSelection :: Monad m => (Name, ValidSelection) -> Resolver o e m a -> Resolver o e m a +setSelection sel (ResolverQ res) = ResolverQ (setState sel res)+setSelection sel (ResolverM res) = ResolverM (setState sel res) +setSelection sel (ResolverS resM) = ResolverS $ do+ res <- resM+ pure $ ReaderT $ \e -> ResolverQ $ setState sel (runResolverQ (runReaderT res e)) -toResolver- :: (LiftOperation o Resolver, Monad m)- => Validation a+-- unsafe variant of >>= , not for public api. user can be confused: +-- ignores `channels` on second Subsciption, only returns events from first Subscription monad.+-- reason: second monad is waiting for `event` until he does not have some event can't tell which +-- channel does it want to listen+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-toResolver Success { result } f = f result-toResolver (Failure errors) _ =- failure ("TODO: errors" <> pack (show errors) :: Message)+ -> 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 -resolving- :: forall o e m value- . Monad m- => (value -> (Key, ValidSelection) -> ResolvingStrategy o e m ValidValue)- -> Resolver o e m value- -> (Key, ValidSelection)- -> ResolvingStrategy o e m ValidValue-resolving encode gResolver selection@(fieldName, Selection { selectionPosition })- = _resolve gResolver- where- convert :: Monad m => ResultT ev String con m a -> ResultT ev GQLError con m a- convert =- mapFailure (resolvingFailedError selectionPosition fieldName . pack)- ------------------------------- _encode = (`encode` selection)- -------------------------------------------------------------------- _resolve (QueryResolver res) =- ResolveQ $ convert res >>= unResolveQ . _encode- ---------------------------------------------------------------------------------------------------------------------------------------- _resolve (MutResolver res) =- ResolveM $ replace (convert res) >>= unResolveM . _encode- where- replace (ResultT mx) = ResultT $ do- value <- mx- pure $ case value of- Success { warnings, events, result = (events2, result) } ->- Success { result, warnings, events = events <> events2 }- Failure x -> Failure x- --------------------------------------------------------------------------------------------------------------------------------- _resolve (SubResolver subChannels res) = ResolveS $ ResultT $ pure $ Success- { events = map Channel subChannels- , result = RecResolver eventResolver- , warnings = []- }- where- eventResolver :: e -> StatelessResT m ValidValue- eventResolver event =- convert (unQueryResolver $ res event) >>= unPureSub . _encode- where- unPureSub- :: Monad m- => ResolvingStrategy SUBSCRIPTION e m ValidValue- -> StatelessResT m ValidValue- unPureSub (ResolveS x) = cleanEvents x >>= passEvent- where passEvent (RecResolver f) = f event+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 ++-- Converts Subscription Resolver Type to Query Resolver+type family UnSubResolver (a :: * -> * ) :: (* -> *)+type instance UnSubResolver (Resolver SUBSCRIPTION e m) = Resolver QUERY e m+ -- map Resolving strategies class MapStrategy (from :: OperationType) (to :: OperationType) where- mapStrategy :: Monad m => ResolvingStrategy from e m a -> ResolvingStrategy to e m a+ mapStrategy :: Monad m => Resolver from e m a -> Resolver to e m a instance MapStrategy o o where mapStrategy = id instance MapStrategy QUERY SUBSCRIPTION where- mapStrategy (ResolveQ x) = ResolveS $ pure <$> cleanEvents x+ mapStrategy = ResolverS . pure . lift ----------------------------------------------------------------------- | GraphQL Root resolver, also the interpreter generates a GQL schema from it.--- 'queryResolver' is required, 'mutationResolver' and 'subscriptionResolver' are optional,--- if your schema does not supports __mutation__ or __subscription__ , you can use __()__ for it.-data GQLRootResolver (m :: * -> *) event (query :: (* -> *) -> * ) (mut :: (* -> *) -> * ) (sub :: (* -> *) -> * ) = GQLRootResolver- { queryResolver :: query (Resolver QUERY event m)- , mutationResolver :: mut (Resolver MUTATION event m)- , subscriptionResolver :: sub (Resolver SUBSCRIPTION event m)- }+--+-- Selection Processing+--+type FieldRes o e m+ = (Key, Resolver o e m ValidValue) - -- EVENTS+toResolver+ :: forall o e m a b. (LiftOperation o, Monad m)+ => (ValidArguments -> Validation a)+ -> (a -> Resolver o e m b)+ -> Resolver o e m b+toResolver toArgs = withResolver args + where + args :: ResolverState e m a+ args = do+ (_,Selection { selectionArguments }) <- getState+ let resT = ResultT $ pure $ toArgs selectionArguments+ ResolverState $ lift $ cleanEvents resT +-- DataResolver+data DataResolver o e m =+ EnumRes Name+ | UnionRes (Name,[FieldRes o e m])+ | ObjectRes [FieldRes o e m ]+ | UnionRef (FieldRes o e m)+ | InvalidRes Name --- Channel+instance Semigroup (DataResolver o e m) where+ ObjectRes x <> ObjectRes y = ObjectRes (x <> y)+ _ <> _ = InvalidRes "can't merge: incompatible resolvers" -newtype Channel event = Channel {- _unChannel :: StreamChannel event-}+pickSelection :: Name -> [(Name, ValidSelectionSet)] -> ValidSelectionSet+pickSelection name = fromMaybe [] . lookup name -instance (Eq (StreamChannel event)) => Eq (Channel event) where- Channel x == Channel y = x == y+resolve__typename+ :: (Monad m, LiftOperation o)+ => Name+ -> (Key, Resolver o e m ValidValue)+resolve__typename name = ("__typename", pure $ gqlString name) -class GQLChannel a where- type StreamChannel a :: *- streamChannels :: a -> [Channel a]+resolveEnum+ :: (Monad m, LiftOperation o)+ => Name+ -> Name+ -> ValidSelectionRec+ -> Resolver o e m ValidValue+resolveEnum _ enum SelectionField = pure $ gqlString enum+resolveEnum typeName enum (UnionSelection selections) = resolveObject+ currentSelection+ resolvers+ where+ enumObjectTypeName = typeName <> "EnumObject"+ currentSelection = fromMaybe [] $ lookup enumObjectTypeName selections+ resolvers = ObjectRes+ [ ("enum", pure $ gqlString enum)+ , resolve__typename enumObjectTypeName+ ]+resolveEnum _ _ _ =+ failure $ internalResolvingError "wrong selection on enum value" -instance GQLChannel () where- type StreamChannel () = ()- streamChannels _ = []+withObject+ :: (LiftOperation o, Monad m)+ => (ValidSelectionSet -> Resolver o e m value)+ -> (Key, ValidSelection)+ -> Resolver o e m value+withObject f (key, Selection { selectionContent , selectionPosition }) = checkContent selectionContent+ where+ checkContent (SelectionSet selection) = f selection+ checkContent _ = failure (subfieldsNotSelected key "" selectionPosition) -instance GQLChannel (Event channel content) where- type StreamChannel (Event channel content) = channel- streamChannels Event { channels } = map Channel channels+lookupRes :: (LiftOperation o, Monad m) => Name -> [(Name,Resolver o e m ValidValue)] -> Resolver o e m ValidValue+lookupRes key = fromMaybe (pure gqlNull) . lookup key -data Event e c = Event- { channels :: [e], content :: c}+outputSelectionName :: (Name,ValidSelection) -> Name+outputSelectionName (name,Selection { selectionAlias }) = fromMaybe name selectionAlias++resolveObject+ :: forall o e m. (LiftOperation o , Monad m)+ => ValidSelectionSet+ -> DataResolver o e m+ -> Resolver o e m ValidValue+resolveObject selectionSet (ObjectRes resolvers) =+ gqlObject <$> traverse resolver selectionSet+ where+ resolver :: (Name,ValidSelection) -> Resolver o e m (Name,ValidValue)+ resolver sel@(name,_) = setSelection sel $ (outputSelectionName sel, ) <$> lookupRes name resolvers+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) => Name -> DataResolver o e m -> Resolver o e m ValidValue+runDataResolver typename = withResolver getState . __encode+ where+ __encode obj (key, sel@Selection { selectionContent }) = encodeNode obj selectionContent + where + -- Object -----------------+ encodeNode (ObjectRes fields) _ = withObject encodeObject (key, sel)+ where+ encodeObject selection =+ resolveObject selection+ $ ObjectRes+ $ resolve__typename typename+ : fields+ encodeNode (EnumRes enum) _ =+ resolveEnum typename enum selectionContent+ -- Type Reference --------+ encodeNode (UnionRef (fieldTypeName, fieldResolver)) (UnionSelection selections)+ = setSelection (key, sel { selectionContent = SelectionSet currentSelection }) fieldResolver+ where currentSelection = pickSelection fieldTypeName selections+ -- Union Record ----------------+ encodeNode (UnionRes (name, fields)) (UnionSelection selections) =+ resolveObject selection resolver+ where+ selection = pickSelection name selections+ resolver = ObjectRes (resolve__typename name : fields)+ encodeNode _ _ = failure $ internalResolvingError+ "union Resolver should only recieve UnionSelection"++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 :: Result (Channel event1) GQLError 'True (ReaderT event (Resolver QUERY event m) ValidValue)) <- 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+ } ++-------------------------------------------------------------------+-- | GraphQL Root resolver, also the interpreter generates a GQL schema from it.+-- 'queryResolver' is required, 'mutationResolver' and 'subscriptionResolver' are optional,+-- if your schema does not supports __mutation__ or __subscription__ , you can use __()__ for it.+data GQLRootResolver (m :: * -> *) event (query :: (* -> *) -> * ) (mut :: (* -> *) -> * ) (sub :: (* -> *) -> * ) = GQLRootResolver+ { queryResolver :: query (Resolver QUERY event m)+ , mutationResolver :: mut (Resolver MUTATION event m)+ , subscriptionResolver :: sub (Resolver SUBSCRIPTION event m)+ }
src/Data/Morpheus/Types/Internal/WebSocket.hs view
@@ -3,7 +3,9 @@ module Data.Morpheus.Types.Internal.WebSocket ( GQLClient(..) , ClientID- , ClientSession(..)+ , ClientDB+ , GQLState+ , SesionID ) where @@ -11,28 +13,29 @@ import Data.Text ( Text ) import Data.UUID ( UUID ) import Network.WebSockets ( Connection )+import Data.HashMap.Lazy ( HashMap , keys)+import Control.Concurrent ( MVar ) -- MORPHEUS import Data.Morpheus.Types.Internal.Resolving ( SubEvent ) -type ClientID = UUID -data ClientSession m e =- ClientSession- { sessionId :: Text- , sessionSubscription :: SubEvent m e- }+-- | shared GraphQL state between __websocket__ and __http__ server,+-- stores information about subscriptions+type GQLState m e = MVar (ClientDB m e) -- SharedState -instance (Show e) => Show (ClientSession m e ) where- show ClientSession { sessionId } =- "GQLSession { id: " <> show sessionId <> ", sessions: " <> "" <> " }"+type ClientDB m e = HashMap ClientID (GQLClient m e) +type ClientID = UUID++type SesionID = Text+ data GQLClient m e = GQLClient { clientID :: ClientID , clientConnection :: Connection- , clientSessions :: [ClientSession m e ]+ , clientSessions :: HashMap SesionID (SubEvent m e) } instance (Show e) => Show (GQLClient m e) where@@ -40,5 +43,5 @@ "GQLClient {id:" <> show clientID <> ", sessions:"- <> show clientSessions+ <> show (keys clientSessions) <> "}"
test/Feature/Holistic/API.hs view
@@ -26,9 +26,9 @@ , GQLType(..) , ID(..) , ScalarValue(..)- , Resolver(..) , failRes , liftEither+ , subscribe ) import Data.Text ( Text ) import GHC.Generics ( Generic )@@ -68,13 +68,7 @@ , fail2 = failRes "fail with failRes" } , mutationResolver = Mutation { createUser = const user }- , subscriptionResolver = Subscription-- { newUser = SubResolver- { subChannels = [Channel]- , subResolver = const user- }- }+ , subscriptionResolver = Subscription { newUser = subscribe [Channel] (pure $ const user)} } where user :: Applicative m => m (User m)
test/Feature/WrappedTypeName/API.hs view
@@ -10,7 +10,7 @@ import Data.Morpheus (interpreter) import Data.Morpheus.Types (Event, GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), IORes,- Resolver (..), constRes)+ constRes, subscribe) import Data.Text (Text) import GHC.Generics (Generic) @@ -43,9 +43,9 @@ type EVENT = Event Channel () data Subscription (m :: * -> *) = Subscription- { sub1 :: () -> m (Maybe (WA (IORes EVENT)))- , sub2 :: () -> m (Maybe (Wrapped Int Int))- , sub3 :: () -> m (Maybe (Wrapped (Wrapped Text Int) Text))+ { sub1 :: m (Maybe (WA (IORes EVENT)))+ , sub2 :: m (Maybe (Wrapped Int Int))+ , sub3 :: m (Maybe (Wrapped (Wrapped Text Int) Text)) } deriving (Generic, GQLType) rootResolver :: GQLRootResolver IO EVENT Query Mutation Subscription@@ -54,9 +54,9 @@ { queryResolver = Query {a1 = WA {aText = const $ pure "test1", aInt = 0}, a2 = Nothing, a3 = Nothing} , mutationResolver = Mutation {mut1 = Nothing, mut2 = Nothing, mut3 = Nothing} , subscriptionResolver = Subscription- { sub1 = const SubResolver {subChannels = [Channel], subResolver = constRes Nothing}- , sub2 = const SubResolver {subChannels = [Channel], subResolver = constRes Nothing}- , sub3 = const SubResolver {subChannels = [Channel], subResolver = constRes Nothing}+ { sub1 = subscribe [Channel] (pure $ constRes Nothing)+ , sub2 = subscribe [Channel] (pure $ constRes Nothing)+ , sub3 = subscribe [Channel] (pure $ constRes Nothing) } }