module Yesod.WebSockets
(
WebSocketsT
, webSockets
, receiveData
, sendTextData
, sendBinaryData
, sourceWS
, sinkWSText
, sinkWSBinary
, race
, race_
, concurrently
, concurrently_
) where
import qualified Control.Concurrent.Async as A
import Control.Monad (forever, void, when)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Trans.Control (control)
import Control.Monad.Trans.Control (MonadBaseControl (liftBaseWith, restoreM))
import Control.Monad.Trans.Reader (ReaderT (ReaderT, runReaderT))
import qualified Data.Conduit as C
import qualified Data.Conduit.List as CL
import qualified Network.Wai.Handler.WebSockets as WaiWS
import qualified Network.WebSockets as WS
import qualified Yesod.Core as Y
type WebSocketsT = ReaderT WS.Connection
webSockets :: (Y.MonadBaseControl IO m, Y.MonadHandler m) => WebSocketsT m () -> m ()
webSockets inner = do
req <- Y.waiRequest
when (WaiWS.isWebSocketsReq req) $
Y.sendRawResponseNoConduit
$ \src sink -> control $ \runInIO -> WaiWS.runWebSockets
WS.defaultConnectionOptions
(WaiWS.getRequestHead req)
(\pconn -> do
conn <- WS.acceptRequest pconn
WS.forkPingThread conn 30
runInIO $ runReaderT inner conn)
src
sink
receiveData :: (MonadIO m, WS.WebSocketsData a) => WebSocketsT m a
receiveData = ReaderT $ liftIO . WS.receiveData
sendTextData :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m ()
sendTextData x = ReaderT $ liftIO . flip WS.sendTextData x
sendBinaryData :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m ()
sendBinaryData x = ReaderT $ liftIO . flip WS.sendBinaryData x
sourceWS :: (MonadIO m, WS.WebSocketsData a) => C.Producer (WebSocketsT m) a
sourceWS = forever $ Y.lift receiveData >>= C.yield
sinkWSText :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebSocketsT m) ()
sinkWSText = CL.mapM_ sendTextData
sinkWSBinary :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebSocketsT m) ()
sinkWSBinary = CL.mapM_ sendBinaryData
race :: MonadBaseControl IO m => m a -> m b -> m (Either a b)
race x y = liftBaseWith (\run -> A.race (run x) (run y))
>>= either (fmap Left . restoreM) (fmap Right . restoreM)
race_ :: MonadBaseControl IO m => m a -> m b -> m ()
race_ x y = void $ race x y
concurrently :: MonadBaseControl IO m => m a -> m b -> m (a, b)
concurrently x y = do
(resX, resY) <- liftBaseWith $ \run -> A.concurrently (run x) (run y)
x' <- restoreM resX
y' <- restoreM resY
return (x', y')
concurrently_ :: MonadBaseControl IO m => m a -> m b -> m ()
concurrently_ x y = void $ liftBaseWith $ \run -> A.concurrently (run x) (run y)