module Network.WebSockets.Trans where
import Network.WebSockets (ConnectionOptions, ClientApp, ServerApp, Connection, PendingConnection)
import Network.Wai.Handler.WebSockets (websocketsOr)
import Network.Wai.Trans (MiddlewareT, runApplicationT, liftApplication)
import Data.Singleton.Class (Extractable (runSingleton))
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Trans.Control.Aligned (MonadBaseControl (liftBaseWith))
type ServerAppT m = PendingConnection -> m ()
liftServerApp :: MonadIO m
=> ServerApp
-> ServerAppT m
liftServerApp s = liftIO . s
runServerAppT :: MonadBaseControl IO m stM
=> Extractable stM
=> ServerAppT m
-> m ServerApp
runServerAppT s = liftBaseWith $ \runInBase ->
pure $ \pending -> runSingleton <$> runInBase (s pending)
type ClientAppT m a = Connection -> m a
liftClientApp :: MonadIO m
=> ClientApp a
-> ClientAppT m a
liftClientApp c = liftIO . c
runClientAppT :: MonadBaseControl IO m stM
=> Extractable stM
=> ClientAppT m a
-> m (ClientApp a)
runClientAppT c = liftBaseWith $ \runInBase ->
pure $ \conn -> runSingleton <$> runInBase (c conn)
websocketsOrT :: MonadBaseControl IO m stM
=> Extractable stM
=> ConnectionOptions
-> ServerAppT m
-> MiddlewareT m
websocketsOrT cOpts server app req respond = do
server' <- runServerAppT server
app' <- runApplicationT app
liftApplication (websocketsOr cOpts server' app') req respond