{-# LANGUAGE FlexibleContexts #-}

module Network.Wai.Handler.WebSockets.Trans (

-- * ServerApp
  ServerAppT
, liftServerApp
, runServerAppT

-- * ClientApp
, ClientAppT
, liftClientApp
, runClientAppT

-- * WebSocket
, websocketsOrT

) where

import Control.Monad.IO.Unlift
import Network.Wai.Handler.WebSockets
import Network.WebSockets

import Network.Wai.Trans

-- | A type synonym for a websockets 'ServerApp' which has been lifted from the 'IO' monad.
type ServerAppT m = PendingConnection -> m ()

-- | Lift a websockets 'ServerApp' to a 'ServerAppT'.
liftServerApp :: MonadIO m
              => ServerApp
              -> ServerAppT m
liftServerApp :: ServerApp -> ServerAppT m
liftServerApp ServerApp
serverApp = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> ServerApp -> ServerAppT m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerApp
serverApp

-- | Run a 'ServerAppT' in the inner monad.
runServerAppT :: MonadUnliftIO m
              => ServerAppT m
              -> m ServerApp
runServerAppT :: ServerAppT m -> m ServerApp
runServerAppT ServerAppT m
serverAppT = ((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
runInIO ->
  ServerApp -> IO ServerApp
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerApp -> IO ServerApp) -> ServerApp -> IO ServerApp
forall a b. (a -> b) -> a -> b
$ m () -> IO ()
forall a. m a -> IO a
runInIO (m () -> IO ()) -> ServerAppT m -> ServerApp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerAppT m
serverAppT

-- | A type synonym for a websockets 'ClientApp' which has been lifted from the 'IO' monad.
type ClientAppT m a = Connection -> m a

-- | Lift a websockets 'ClientApp' to a 'ClientAppT'.
liftClientApp :: MonadIO m
              => ClientApp a
              -> ClientAppT m a
liftClientApp :: ClientApp a -> ClientAppT m a
liftClientApp ClientApp a
clientApp = IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> ClientApp a -> ClientAppT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientApp a
clientApp

-- | Run a 'ClientAppT' in the inner monad.
runClientAppT :: MonadUnliftIO m
              => ClientAppT m a
              -> m (ClientApp a)
runClientAppT :: ClientAppT m a -> m (ClientApp a)
runClientAppT ClientAppT m a
clientAppT = ((forall a. m a -> IO a) -> IO (ClientApp a)) -> m (ClientApp a)
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO (ClientApp a)) -> m (ClientApp a))
-> ((forall a. m a -> IO a) -> IO (ClientApp a)) -> m (ClientApp a)
forall a b. (a -> b) -> a -> b
$ \ forall a. m a -> IO a
runInIO ->
  ClientApp a -> IO (ClientApp a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientApp a -> IO (ClientApp a))
-> ClientApp a -> IO (ClientApp a)
forall a b. (a -> b) -> a -> b
$ m a -> IO a
forall a. m a -> IO a
runInIO (m a -> IO a) -> ClientAppT m a -> ClientApp a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientAppT m a
clientAppT

{- | Upgrade a 'ServerAppT' to a 'MiddlewareT'.
  This function is based on 'websocketsOr'.
-}
websocketsOrT :: MonadUnliftIO m
              => ConnectionOptions
              -> ServerAppT m
              -> MiddlewareT m
websocketsOrT :: ConnectionOptions -> ServerAppT m -> MiddlewareT m
websocketsOrT ConnectionOptions
options ServerAppT m
serverAppT ApplicationT m
appT Request
request Response -> m ResponseReceived
respond = do
  ServerApp
serverApp <- ServerAppT m -> m ServerApp
forall (m :: * -> *).
MonadUnliftIO m =>
ServerAppT m -> m ServerApp
runServerAppT ServerAppT m
serverAppT
  Application
app <- ApplicationT m -> m Application
forall (m :: * -> *).
MonadUnliftIO m =>
ApplicationT m -> m Application
runApplicationT ApplicationT m
appT
  (Application -> ApplicationT m
forall (m :: * -> *).
MonadUnliftIO m =>
Application -> ApplicationT m
liftApplication (Application -> ApplicationT m) -> Application -> ApplicationT m
forall a b. (a -> b) -> a -> b
$ ConnectionOptions -> ServerApp -> Application -> Application
websocketsOr ConnectionOptions
options ServerApp
serverApp Application
app) Request
request Response -> m ResponseReceived
respond