{-# 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,
)
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
( 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 :: m (Input SUB)
connect = UUID -> Input SUB
InitConnection (UUID -> Input SUB) -> m UUID -> m (Input SUB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID -> m UUID
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UUID
nextRandom
disconnect :: ApiContext SUB e m -> Input SUB -> m ()
disconnect :: ApiContext SUB e m -> Input SUB -> m ()
disconnect SubContext {(ClientConnectionStore e m -> ClientConnectionStore e m) -> m ()
updateStore :: forall event (m :: * -> *).
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 (UUID -> ClientConnectionStore e m -> ClientConnectionStore e m
forall e (m :: * -> *). UUID -> StoreMap e m
delete UUID
clientID)
data Store e m = Store
{ Store e m -> m (ClientConnectionStore e m)
readStore :: m (ClientConnectionStore 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 :: Store (Event channel cont) m -> Event channel cont -> m ()
publishEventWith Store (Event channel cont) m
store Event channel cont
event = Store (Event channel cont) m
-> m (ClientConnectionStore (Event channel cont) m)
forall e (m :: * -> *). Store e m -> m (ClientConnectionStore e m)
readStore Store (Event channel cont) m
store m (ClientConnectionStore (Event channel cont) m)
-> (ClientConnectionStore (Event channel cont) m -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Event channel cont
-> ClientConnectionStore (Event channel cont) m -> m ()
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 :: m2 (Store (Event ch con) m)
initDefaultStore = do
MVar (ClientConnectionStore (Event ch con) m)
store <- IO (MVar (ClientConnectionStore (Event ch con) m))
-> m2 (MVar (ClientConnectionStore (Event ch con) m))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar (ClientConnectionStore (Event ch con) m))
-> m2 (MVar (ClientConnectionStore (Event ch con) m)))
-> IO (MVar (ClientConnectionStore (Event ch con) m))
-> m2 (MVar (ClientConnectionStore (Event ch con) m))
forall a b. (a -> b) -> a -> b
$ ClientConnectionStore (Event ch con) m
-> IO (MVar (ClientConnectionStore (Event ch con) m))
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar ClientConnectionStore (Event ch con) m
forall coll. Empty coll => coll
empty
Store (Event ch con) m -> m2 (Store (Event ch con) m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
Store :: forall e (m :: * -> *).
m (ClientConnectionStore e m)
-> ((ClientConnectionStore e m -> ClientConnectionStore e m)
-> m ())
-> Store e m
Store
{ readStore :: m (ClientConnectionStore (Event ch con) m)
readStore = IO (ClientConnectionStore (Event ch con) m)
-> m (ClientConnectionStore (Event ch con) m)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ClientConnectionStore (Event ch con) m)
-> m (ClientConnectionStore (Event ch con) m))
-> IO (ClientConnectionStore (Event ch con) m)
-> m (ClientConnectionStore (Event ch con) m)
forall a b. (a -> b) -> a -> b
$ MVar (ClientConnectionStore (Event ch con) m)
-> IO (ClientConnectionStore (Event ch con) m)
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 -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar (ClientConnectionStore (Event ch con) m)
-> (ClientConnectionStore (Event ch con) m
-> IO (ClientConnectionStore (Event ch con) m))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (ClientConnectionStore (Event ch con) m)
store (ClientConnectionStore (Event ch con) m
-> IO (ClientConnectionStore (Event ch con) m)
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientConnectionStore (Event ch con) m
-> IO (ClientConnectionStore (Event ch con) m))
-> (ClientConnectionStore (Event ch con) m
-> ClientConnectionStore (Event ch con) m)
-> ClientConnectionStore (Event ch con) m
-> IO (ClientConnectionStore (Event ch con) m)
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 :: m () -> m () -> m ()
finallyM m ()
loop m ()
end = ((forall a. m a -> IO a) -> IO ()) -> m ()
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO ()) -> m ())
-> ((forall a. m a -> IO a) -> IO ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runIO -> IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
finally (m () -> IO ()
forall a. m a -> IO a
runIO m ()
loop) (m () -> IO ()
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 :: 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 <- m (Input SUB)
forall (m :: * -> *). MonadIO m => m (Input SUB)
connect
m () -> m () -> m ()
forall (m :: * -> *). MonadUnliftIO m => m () -> m () -> m ()
finallyM
(App (Event ch con) m
-> ApiContext SUB (Event ch con) m -> Input SUB -> m ()
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)
(ApiContext SUB (Event ch con) m -> Input SUB -> m ()
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 :: 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 =
m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever
(m () -> m ()) -> (Input SUB -> m ()) -> Input SUB -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApiContext SUB (Event ch con) m
-> Output SUB (Event ch con) m -> m ()
forall (m :: * -> *) e.
Monad m =>
ApiContext SUB e m -> Output SUB e m -> m ()
runStreamWS ApiContext SUB (Event ch con) m
scope
(Output SUB (Event ch con) m -> m ())
-> (Input SUB -> Output SUB (Event ch con) m) -> Input SUB -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. App (Event ch con) m -> Input SUB -> Output SUB (Event ch con) m
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 :: App (Event ch con) m -> Input api -> Output api (Event ch con) m
streamApp App (Event ch con) m
app = (GQLRequest -> ResponseStream (Event ch con) m (Value VALID))
-> Input api -> Output api (Event ch con) m
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 (App (Event ch con) m
-> GQLRequest -> ResponseStream (Event ch con) m (Value VALID)
forall (m :: * -> *) event.
Monad m =>
App event m -> GQLRequest -> ResponseStream event m (Value VALID)
runAppStream App (Event ch con) m
app)