{-# 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
)
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
)
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) }