{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Subscriptions.WebSockets
( webSocketsWrapper,
)
where
import Control.Monad.IO.Unlift
( MonadUnliftIO,
withRunInIO,
)
import Data.Morpheus.Subscriptions.Internal
( ApiContext (..),
SUB,
Store (..),
acceptApolloRequest,
)
import Network.WebSockets
( Connection,
ServerApp,
receiveData,
sendTextData,
)
import qualified Network.WebSockets as WS
import Relude
pingThread :: Connection -> IO () -> IO ()
#if MIN_VERSION_websockets(0,12,6)
pingThread :: Connection -> IO () -> IO ()
pingThread Connection
connection = Connection -> Int -> IO () -> IO () -> IO ()
forall a. Connection -> Int -> IO () -> IO a -> IO a
WS.withPingThread Connection
connection Int
30 (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
#else
pingThread connection = (WS.forkPingThread connection 30 >>)
#endif
defaultWSScope :: MonadIO m => Store e m -> Connection -> ApiContext SUB e m
defaultWSScope :: Store e m -> Connection -> ApiContext SUB e m
defaultWSScope Store {(ClientConnectionStore e m -> ClientConnectionStore e m) -> m ()
writeStore :: forall e (m :: * -> *).
Store e m
-> (ClientConnectionStore e m -> ClientConnectionStore e m) -> m ()
writeStore :: (ClientConnectionStore e m -> ClientConnectionStore e m) -> m ()
writeStore} Connection
connection =
SubContext :: forall (m :: * -> *) event.
m ByteString
-> (ByteString -> m ())
-> ((ClientConnectionStore event m
-> ClientConnectionStore event m)
-> m ())
-> ApiContext SUB event m
SubContext
{ listener :: m ByteString
listener = IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
connection),
callback :: ByteString -> m ()
callback = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (ByteString -> IO ()) -> ByteString -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
connection,
updateStore :: (ClientConnectionStore e m -> ClientConnectionStore e m) -> m ()
updateStore = (ClientConnectionStore e m -> ClientConnectionStore e m) -> m ()
writeStore
}
webSocketsWrapper ::
(MonadUnliftIO m, MonadIO m) =>
Store e m ->
(ApiContext SUB e m -> m ()) ->
m ServerApp
webSocketsWrapper :: Store e m -> (ApiContext SUB e m -> m ()) -> m ServerApp
webSocketsWrapper Store e m
store ApiContext SUB e m -> m ()
handler =
((forall a. m a -> IO a) -> IO ServerApp) -> m ServerApp
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO ServerApp) -> m ServerApp)
-> ((forall a. m a -> IO a) -> IO ServerApp) -> m ServerApp
forall a b. (a -> b) -> a -> b
$
\forall a. m a -> IO a
runIO ->
ServerApp -> IO ServerApp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServerApp -> IO ServerApp) -> ServerApp -> IO ServerApp
forall a b. (a -> b) -> a -> b
$
\PendingConnection
pending -> do
Connection
conn <- PendingConnection -> IO Connection
forall (m :: * -> *).
MonadIO m =>
PendingConnection -> m Connection
acceptApolloRequest PendingConnection
pending
Connection -> IO () -> IO ()
pingThread
Connection
conn
(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ m () -> IO ()
forall a. m a -> IO a
runIO (ApiContext SUB e m -> m ()
handler (Store e m -> Connection -> ApiContext SUB e m
forall (m :: * -> *) e.
MonadIO m =>
Store e m -> Connection -> ApiContext SUB e m
defaultWSScope Store e m
store Connection
conn))