{-# 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 = forall a. Connection -> Int -> IO () -> IO a -> IO a
WS.withPingThread Connection
connection Int
30 (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 :: forall (m :: * -> *) e.
MonadIO m =>
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
{ listener :: m ByteString
listener = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
connection),
callback :: ByteString -> m ()
callback = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall (m :: * -> *) e.
(MonadUnliftIO m, MonadIO m) =>
Store e m -> (ApiContext SUB e m -> m ()) -> m ServerApp
webSocketsWrapper Store e m
store ApiContext SUB e m -> m ()
handler =
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 (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
\PendingConnection
pending -> do
Connection
conn <- forall (m :: * -> *).
MonadIO m =>
PendingConnection -> m Connection
acceptApolloRequest PendingConnection
pending
Connection -> IO () -> IO ()
pingThread
Connection
conn
forall a b. (a -> b) -> a -> b
$ forall a. m a -> IO a
runIO (ApiContext SUB e m -> m ()
handler (forall (m :: * -> *) e.
MonadIO m =>
Store e m -> Connection -> ApiContext SUB e m
defaultWSScope Store e m
store Connection
conn))