{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Yesod.WebSockets
(
WebSocketsT
, webSockets
, webSocketsWith
, webSocketsOptions
, webSocketsOptionsWith
, receiveData
, receiveDataE
, receiveDataMessageE
, sendPing
, sendPingE
, sendClose
, sendCloseE
, sendTextData
, sendTextDataE
, sendBinaryData
, sendBinaryDataE
, sendDataMessageE
, sourceWS
, sinkWSText
, sinkWSBinary
, race
, race_
, concurrently
, concurrently_
, WS.defaultConnectionOptions
, WS.ConnectionOptions (..)
) where
import Control.Monad (forever, when)
import Control.Monad.Reader (ReaderT, runReaderT, MonadReader, ask)
import Conduit
import qualified Network.Wai.Handler.WebSockets as WaiWS
import qualified Network.WebSockets as WS
import qualified Yesod.Core as Y
import UnliftIO (SomeException, tryAny, MonadIO, liftIO, MonadUnliftIO, withRunInIO, race, race_, concurrently, concurrently_)
type WebSocketsT = ReaderT WS.Connection
webSockets
:: (MonadUnliftIO m, Y.MonadHandler m)
=> WebSocketsT m ()
-> m ()
webSockets = webSocketsOptions WS.defaultConnectionOptions
webSocketsOptions
:: (MonadUnliftIO m, Y.MonadHandler m)
=> WS.ConnectionOptions
-> WebSocketsT m ()
-> m ()
webSocketsOptions opts = webSocketsOptionsWith opts $ const $ return $ Just $ WS.AcceptRequest Nothing []
webSocketsWith :: (MonadUnliftIO m, Y.MonadHandler m)
=> (WS.RequestHead -> m (Maybe WS.AcceptRequest))
-> WebSocketsT m ()
-> m ()
webSocketsWith = webSocketsOptionsWith WS.defaultConnectionOptions
webSocketsOptionsWith :: (MonadUnliftIO m, Y.MonadHandler m)
=> WS.ConnectionOptions
-> (WS.RequestHead -> m (Maybe WS.AcceptRequest))
-> WebSocketsT m ()
-> m ()
webSocketsOptionsWith wsConnOpts buildAr inner = do
req <- Y.waiRequest
when (WaiWS.isWebSocketsReq req) $ do
let rhead = WaiWS.getRequestHead req
mar <- buildAr rhead
case mar of
Nothing -> return ()
Just ar ->
Y.sendRawResponseNoConduit
$ \src sink -> withRunInIO $ \runInIO -> WaiWS.runWebSockets
wsConnOpts
rhead
(\pconn -> do
conn <- WS.acceptRequestWith pconn ar
WS.forkPingThread conn 30
runInIO $ runReaderT inner conn)
src
sink
wrapWSE :: (MonadIO m, MonadReader WS.Connection m)
=> (WS.Connection -> a -> IO ())
-> a
-> m (Either SomeException ())
wrapWSE ws x = do
conn <- ask
liftIO $ tryAny $ ws conn x
wrapWS :: (MonadIO m, MonadReader WS.Connection m)
=> (WS.Connection -> a -> IO ())
-> a
-> m ()
wrapWS ws x = do
conn <- ask
liftIO $ ws conn x
receiveData
:: (MonadIO m, MonadReader WS.Connection m, WS.WebSocketsData a)
=> m a
receiveData = do
conn <- ask
liftIO $ WS.receiveData conn
receiveDataE
:: (MonadIO m, MonadReader WS.Connection m, WS.WebSocketsData a)
=> m (Either SomeException a)
receiveDataE = do
conn <- ask
liftIO $ tryAny $ WS.receiveData conn
receiveDataMessageE
:: (MonadIO m, MonadReader WS.Connection m)
=> m (Either SomeException WS.DataMessage)
receiveDataMessageE = do
conn <- ask
liftIO $ tryAny $ WS.receiveDataMessage conn
sendTextData
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
=> a
-> m ()
sendTextData = wrapWS WS.sendTextData
sendTextDataE
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
=> a
-> m (Either SomeException ())
sendTextDataE = wrapWSE WS.sendTextData
sendBinaryData
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
=> a
-> m ()
sendBinaryData = wrapWS WS.sendBinaryData
sendBinaryDataE
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
=> a
-> m (Either SomeException ())
sendBinaryDataE = wrapWSE WS.sendBinaryData
sendPing
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
=> a
-> WebSocketsT m ()
sendPing = wrapWS WS.sendPing
sendPingE
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
=> a
-> m (Either SomeException ())
sendPingE = wrapWSE WS.sendPing
sendDataMessageE
:: (MonadIO m, MonadReader WS.Connection m)
=> WS.DataMessage
-> m (Either SomeException ())
sendDataMessageE x = do
conn <- ask
liftIO $ tryAny $ WS.sendDataMessage conn x
sendClose
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
=> a
-> WebSocketsT m ()
sendClose = wrapWS WS.sendClose
sendCloseE
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
=> a
-> m (Either SomeException ())
sendCloseE = wrapWSE WS.sendClose
sourceWS
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
=> ConduitT i a m ()
sourceWS = forever $ lift receiveData >>= yield
sinkWSText
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
=> ConduitT a o m ()
sinkWSText = mapM_C sendTextData
sinkWSBinary
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
=> ConduitT a o m ()
sinkWSBinary = mapM_C sendBinaryData