{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Subscriptions.Internal
( connect,
disconnect,
connectionThread,
runStreamWS,
runStreamHTTP,
ApiContext (..),
Input (..),
PUB,
SUB,
Store (..),
ClientConnectionStore,
acceptApolloRequest,
SessionID,
publish,
initDefaultStore,
publishEventWith,
empty,
toList,
connectionSessionIds,
storedSessions,
storedChannels,
streamApp,
ApolloSubscription (..),
ApolloAction (..),
)
where
import Control.Concurrent
( modifyMVar_,
)
import Control.Exception (finally)
import Control.Monad.IO.Unlift
( MonadUnliftIO,
withRunInIO,
)
import Data.Morpheus.App
( App,
runAppStream,
)
import Data.Morpheus.Internal.Utils
( empty,
)
import Data.Morpheus.Subscriptions.Apollo
( ApolloAction (..),
ApolloSubscription (..),
acceptApolloRequest,
)
import Data.Morpheus.Subscriptions.ClientConnectionStore
( ClientConnectionStore,
SessionID,
connectionSessionIds,
delete,
publish,
storedChannels,
storedSessions,
toList,
)
import Data.Morpheus.Subscriptions.Event
( Event,
)
import Data.Morpheus.Subscriptions.Stream
( ApiContext (..),
Input (..),
Output,
PUB,
SUB,
runStreamHTTP,
runStreamWS,
toOutStream,
)
import Data.UUID.V4 (nextRandom)
import Relude hiding (empty, toList)
connect :: MonadIO m => m (Input SUB)
connect :: forall (m :: * -> *). MonadIO m => m (Input SUB)
connect = UUID -> Input SUB
InitConnection forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UUID
nextRandom
disconnect :: ApiContext SUB e m -> Input SUB -> m ()
disconnect :: forall e (m :: * -> *). ApiContext SUB e m -> Input SUB -> m ()
disconnect SubContext {(ClientConnectionStore e m -> ClientConnectionStore e m) -> m ()
updateStore :: forall (m :: * -> *) event.
ApiContext SUB event m
-> (ClientConnectionStore event m -> ClientConnectionStore event m)
-> m ()
updateStore :: (ClientConnectionStore e m -> ClientConnectionStore e m) -> m ()
updateStore} (InitConnection UUID
clientID) =
(ClientConnectionStore e m -> ClientConnectionStore e m) -> m ()
updateStore (forall e (m :: * -> *). UUID -> StoreMap e m
delete UUID
clientID)
data Store e m = Store
{ forall e (m :: * -> *). Store e m -> m (ClientConnectionStore e m)
readStore :: m (ClientConnectionStore e m),
forall e (m :: * -> *).
Store e m
-> (ClientConnectionStore e m -> ClientConnectionStore e m) -> m ()
writeStore :: (ClientConnectionStore e m -> ClientConnectionStore e m) -> m ()
}
publishEventWith ::
( MonadIO m,
Eq channel,
Hashable channel,
Show channel
) =>
Store (Event channel cont) m ->
Event channel cont ->
m ()
publishEventWith :: forall (m :: * -> *) channel cont.
(MonadIO m, Eq channel, Hashable channel, Show channel) =>
Store (Event channel cont) m -> Event channel cont -> m ()
publishEventWith Store (Event channel cont) m
store Event channel cont
event = forall e (m :: * -> *). Store e m -> m (ClientConnectionStore e m)
readStore Store (Event channel cont) m
store forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) channel content.
(Monad m, Eq channel, Hashable channel, Show channel) =>
Event channel content
-> ClientConnectionStore (Event channel content) m -> m ()
publish Event channel cont
event
initDefaultStore ::
( MonadIO m,
MonadIO m2
) =>
m2 (Store (Event ch con) m)
initDefaultStore :: forall (m :: * -> *) (m2 :: * -> *) ch con.
(MonadIO m, MonadIO m2) =>
m2 (Store (Event ch con) m)
initDefaultStore = do
MVar (ClientConnectionStore (Event ch con) m)
store <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar forall coll. Empty coll => coll
empty
forall (f :: * -> *) a. Applicative f => a -> f a
pure
Store
{ readStore :: m (ClientConnectionStore (Event ch con) m)
readStore = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar MVar (ClientConnectionStore (Event ch con) m)
store,
writeStore :: (ClientConnectionStore (Event ch con) m
-> ClientConnectionStore (Event ch con) m)
-> m ()
writeStore = \ClientConnectionStore (Event ch con) m
-> ClientConnectionStore (Event ch con) m
changes -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (ClientConnectionStore (Event ch con) m)
store (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientConnectionStore (Event ch con) m
-> ClientConnectionStore (Event ch con) m
changes)
}
finallyM :: MonadUnliftIO m => m () -> m () -> m ()
finallyM :: forall (m :: * -> *). MonadUnliftIO m => m () -> m () -> m ()
finallyM m ()
loop m ()
end = forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runIO -> forall a b. IO a -> IO b -> IO a
finally (forall a. m a -> IO a
runIO m ()
loop) (forall a. m a -> IO a
runIO m ()
end)
connectionThread ::
( MonadUnliftIO m,
Eq ch,
Hashable ch
) =>
App (Event ch con) m ->
ApiContext SUB (Event ch con) m ->
m ()
connectionThread :: forall (m :: * -> *) ch con.
(MonadUnliftIO m, Eq ch, Hashable ch) =>
App (Event ch con) m -> ApiContext SUB (Event ch con) m -> m ()
connectionThread App (Event ch con) m
api ApiContext SUB (Event ch con) m
scope = do
Input SUB
input <- forall (m :: * -> *). MonadIO m => m (Input SUB)
connect
forall (m :: * -> *). MonadUnliftIO m => m () -> m () -> m ()
finallyM
(forall (m :: * -> *) ch con.
(Monad m, Eq ch, Hashable ch) =>
App (Event ch con) m
-> ApiContext SUB (Event ch con) m -> Input SUB -> m ()
connectionLoop App (Event ch con) m
api ApiContext SUB (Event ch con) m
scope Input SUB
input)
(forall e (m :: * -> *). ApiContext SUB e m -> Input SUB -> m ()
disconnect ApiContext SUB (Event ch con) m
scope Input SUB
input)
connectionLoop ::
(Monad m, Eq ch, Hashable ch) =>
App (Event ch con) m ->
ApiContext SUB (Event ch con) m ->
Input SUB ->
m ()
connectionLoop :: forall (m :: * -> *) ch con.
(Monad m, Eq ch, Hashable ch) =>
App (Event ch con) m
-> ApiContext SUB (Event ch con) m -> Input SUB -> m ()
connectionLoop App (Event ch con) m
app ApiContext SUB (Event ch con) m
scope =
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e.
Monad m =>
ApiContext SUB e m -> Output SUB e m -> m ()
runStreamWS ApiContext SUB (Event ch con) m
scope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ch (m :: * -> *) con (api :: API).
(Eq ch, Monad m, Hashable ch) =>
App (Event ch con) m -> Input api -> Output api (Event ch con) m
streamApp App (Event ch con) m
app
streamApp ::
(Eq ch, Monad m, Hashable ch) =>
App (Event ch con) m ->
Input api ->
Output api (Event ch con) m
streamApp :: forall ch (m :: * -> *) con (api :: API).
(Eq ch, Monad m, Hashable ch) =>
App (Event ch con) m -> Input api -> Output api (Event ch con) m
streamApp App (Event ch con) m
app = forall (m :: * -> *) ch con (api :: API).
(Monad m, Eq ch, Hashable ch) =>
(GQLRequest -> ResponseStream (Event ch con) m (Value VALID))
-> Input api -> Output api (Event ch con) m
toOutStream (forall (m :: * -> *) event.
Monad m =>
App event m -> GQLRequest -> ResponseStream event m (Value VALID)
runAppStream App (Event ch con) m
app)