Fix yesod-websockets
This commit is contained in:
Michael Snoyman
parent
f2926e60f0
commit
3956110876
@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
module Yesod.WebSockets
|
||||
@ -34,10 +33,9 @@ module Yesod.WebSockets
|
||||
, WS.ConnectionOptions (..)
|
||||
) where
|
||||
|
||||
import Control.Monad (forever, void, when)
|
||||
import Control.Monad.Trans.Reader (ReaderT (ReaderT, runReaderT))
|
||||
import qualified Data.Conduit as C
|
||||
import qualified Data.Conduit.List as CL
|
||||
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
|
||||
@ -55,28 +53,28 @@ type WebSocketsT = ReaderT WS.Connection
|
||||
-- instead.
|
||||
--
|
||||
-- Since 0.1.0
|
||||
webSockets :: (Y.MonadUnliftIO m, Y.MonadHandler m) => WebSocketsT m () -> m ()
|
||||
webSockets
|
||||
:: (MonadUnliftIO m, Y.MonadHandler m)
|
||||
=> WebSocketsT m ()
|
||||
-> m ()
|
||||
webSockets = webSocketsOptions WS.defaultConnectionOptions
|
||||
|
||||
-- | Varient of 'webSockets' which allows you to specify
|
||||
-- the WS.ConnectionOptions setttings when upgrading to a websocket connection.
|
||||
--
|
||||
-- Since 0.2.5
|
||||
webSocketsOptions :: (Y.MonadUnliftIO m, Y.MonadHandler m)
|
||||
=> WS.ConnectionOptions
|
||||
-> WebSocketsT m ()
|
||||
-> m ()
|
||||
#if MIN_VERSION_websockets(0,10,0)
|
||||
webSocketsOptions
|
||||
:: (MonadUnliftIO m, Y.MonadHandler m)
|
||||
=> WS.ConnectionOptions
|
||||
-> WebSocketsT m ()
|
||||
-> m ()
|
||||
webSocketsOptions opts = webSocketsOptionsWith opts $ const $ return $ Just $ WS.AcceptRequest Nothing []
|
||||
#else
|
||||
webSocketsOptions opts = webSocketsOptionsWith opts $ const $ return $ Just $ WS.AcceptRequest Nothing
|
||||
#endif
|
||||
|
||||
-- | Varient of 'webSockets' which allows you to specify the 'WS.AcceptRequest'
|
||||
-- setttings when upgrading to a websocket connection.
|
||||
--
|
||||
-- Since 0.2.4
|
||||
webSocketsWith :: (Y.MonadUnliftIO m, Y.MonadHandler m)
|
||||
webSocketsWith :: (MonadUnliftIO m, Y.MonadHandler m)
|
||||
=> (WS.RequestHead -> m (Maybe WS.AcceptRequest))
|
||||
-- ^ A Nothing indicates that the websocket upgrade request should not happen
|
||||
-- and instead the rest of the handler will be called instead. This allows
|
||||
@ -93,7 +91,7 @@ webSocketsWith = webSocketsOptionsWith WS.defaultConnectionOptions
|
||||
-- setttings when upgrading to a websocket connection.
|
||||
--
|
||||
-- Since 0.2.5
|
||||
webSocketsOptionsWith :: (Y.MonadUnliftIO m, Y.MonadHandler m)
|
||||
webSocketsOptionsWith :: (MonadUnliftIO m, Y.MonadHandler m)
|
||||
=> WS.ConnectionOptions
|
||||
-- ^ Custom websockets options
|
||||
-> (WS.RequestHead -> m (Maybe WS.AcceptRequest))
|
||||
@ -125,100 +123,157 @@ webSocketsOptionsWith wsConnOpts buildAr inner = do
|
||||
sink
|
||||
|
||||
-- | Wrapper for capturing exceptions
|
||||
wrapWSE :: MonadIO m => (WS.Connection -> a -> IO ())-> a -> WebSocketsT m (Either SomeException ())
|
||||
wrapWSE ws x = ReaderT $ liftIO . tryAny . flip ws x
|
||||
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 => (WS.Connection -> a -> IO ()) -> a -> WebSocketsT m ()
|
||||
wrapWS ws x = ReaderT $ liftIO . flip ws x
|
||||
wrapWS :: (MonadIO m, MonadReader WS.Connection m)
|
||||
=> (WS.Connection -> a -> IO ())
|
||||
-> a
|
||||
-> m ()
|
||||
wrapWS ws x = do
|
||||
conn <- ask
|
||||
liftIO $ ws conn x
|
||||
|
||||
-- | Receive a piece of data from the client.
|
||||
--
|
||||
-- Since 0.1.0
|
||||
receiveData :: (MonadIO m, WS.WebSocketsData a) => WebSocketsT m a
|
||||
receiveData = ReaderT $ liftIO . WS.receiveData
|
||||
receiveData
|
||||
:: (MonadIO m, MonadReader WS.Connection m, WS.WebSocketsData a)
|
||||
=> m a
|
||||
receiveData = do
|
||||
conn <- ask
|
||||
liftIO $ WS.receiveData conn
|
||||
|
||||
-- | Receive a piece of data from the client.
|
||||
-- Capture SomeException as the result or operation
|
||||
-- Since 0.2.2
|
||||
receiveDataE :: (MonadIO m, WS.WebSocketsData a) => WebSocketsT m (Either SomeException a)
|
||||
receiveDataE = ReaderT $ liftIO . tryAny . WS.receiveData
|
||||
receiveDataE
|
||||
:: (MonadIO m, MonadReader WS.Connection m, WS.WebSocketsData a)
|
||||
=> m (Either SomeException a)
|
||||
receiveDataE = do
|
||||
conn <- ask
|
||||
liftIO $ tryAny $ WS.receiveData conn
|
||||
|
||||
-- | Receive an application message.
|
||||
-- Capture SomeException as the result or operation
|
||||
-- Since 0.2.3
|
||||
receiveDataMessageE :: (MonadIO m) => WebSocketsT m (Either SomeException WS.DataMessage)
|
||||
receiveDataMessageE = ReaderT $ liftIO . tryAny . WS.receiveDataMessage
|
||||
receiveDataMessageE
|
||||
:: (MonadIO m, MonadReader WS.Connection m)
|
||||
=> m (Either SomeException WS.DataMessage)
|
||||
receiveDataMessageE = do
|
||||
conn <- ask
|
||||
liftIO $ tryAny $ WS.receiveDataMessage conn
|
||||
|
||||
-- | Send a textual message to the client.
|
||||
--
|
||||
-- Since 0.1.0
|
||||
sendTextData :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m ()
|
||||
sendTextData
|
||||
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
|
||||
=> a
|
||||
-> m ()
|
||||
sendTextData = wrapWS WS.sendTextData
|
||||
|
||||
-- | Send a textual message to the client.
|
||||
-- Capture SomeException as the result or operation
|
||||
-- and can be used like
|
||||
-- and can be used like
|
||||
-- `either handle_exception return =<< sendTextDataE ("Welcome" :: Text)`
|
||||
-- Since 0.2.2
|
||||
sendTextDataE :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m (Either SomeException ())
|
||||
sendTextDataE
|
||||
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
|
||||
=> a
|
||||
-> m (Either SomeException ())
|
||||
sendTextDataE = wrapWSE WS.sendTextData
|
||||
|
||||
-- | Send a binary message to the client.
|
||||
--
|
||||
-- Since 0.1.0
|
||||
sendBinaryData :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m ()
|
||||
sendBinaryData
|
||||
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
|
||||
=> a
|
||||
-> m ()
|
||||
sendBinaryData = wrapWS WS.sendBinaryData
|
||||
|
||||
-- | Send a binary message to the client.
|
||||
-- Capture SomeException as the result of operation
|
||||
-- Since 0.2.2
|
||||
sendBinaryDataE :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m (Either SomeException ())
|
||||
sendBinaryDataE
|
||||
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
|
||||
=> a
|
||||
-> m (Either SomeException ())
|
||||
sendBinaryDataE = wrapWSE WS.sendBinaryData
|
||||
|
||||
-- | Send a ping message to the client.
|
||||
--
|
||||
-- Since 0.2.2
|
||||
sendPing :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m ()
|
||||
sendPing
|
||||
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
|
||||
=> a
|
||||
-> WebSocketsT m ()
|
||||
sendPing = wrapWS WS.sendPing
|
||||
|
||||
-- | Send a ping message to the client.
|
||||
-- | Send a ping message to the client.
|
||||
-- Capture SomeException as the result of operation
|
||||
-- Since 0.2.2
|
||||
sendPingE :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m (Either SomeException ())
|
||||
sendPingE
|
||||
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
|
||||
=> a
|
||||
-> m (Either SomeException ())
|
||||
sendPingE = wrapWSE WS.sendPing
|
||||
|
||||
-- | Send a DataMessage to the client.
|
||||
-- | Send a DataMessage to the client.
|
||||
-- Capture SomeException as the result of operation
|
||||
-- Since 0.2.3
|
||||
sendDataMessageE :: (MonadIO m) => WS.DataMessage -> WebSocketsT m (Either SomeException ())
|
||||
sendDataMessageE x = ReaderT $ liftIO . tryAny . (`WS.sendDataMessage` x)
|
||||
sendDataMessageE
|
||||
:: (MonadIO m, MonadReader WS.Connection m)
|
||||
=> WS.DataMessage
|
||||
-> m (Either SomeException ())
|
||||
sendDataMessageE x = do
|
||||
conn <- ask
|
||||
liftIO $ tryAny $ WS.sendDataMessage conn x
|
||||
|
||||
-- | Send a close request to the client.
|
||||
--
|
||||
-- | Send a close request to the client.
|
||||
--
|
||||
-- Since 0.2.2
|
||||
sendClose :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m ()
|
||||
sendClose
|
||||
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
|
||||
=> a
|
||||
-> WebSocketsT m ()
|
||||
sendClose = wrapWS WS.sendClose
|
||||
|
||||
-- | Send a close request to the client.
|
||||
-- | Send a close request to the client.
|
||||
-- Capture SomeException as the result of operation
|
||||
-- Since 0.2.2
|
||||
sendCloseE :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m (Either SomeException ())
|
||||
sendCloseE
|
||||
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
|
||||
=> a
|
||||
-> m (Either SomeException ())
|
||||
sendCloseE = wrapWSE WS.sendClose
|
||||
|
||||
-- | A @Source@ of WebSockets data from the user.
|
||||
--
|
||||
-- Since 0.1.0
|
||||
sourceWS :: (MonadIO m, WS.WebSocketsData a) => C.Producer (WebSocketsT m) a
|
||||
sourceWS = forever $ Y.lift receiveData >>= C.yield
|
||||
sourceWS
|
||||
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
|
||||
=> ConduitT i a m ()
|
||||
sourceWS = forever $ lift receiveData >>= yield
|
||||
|
||||
-- | A @Sink@ for sending textual data to the user.
|
||||
--
|
||||
-- Since 0.1.0
|
||||
sinkWSText :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebSocketsT m) ()
|
||||
sinkWSText = CL.mapM_ sendTextData
|
||||
sinkWSText
|
||||
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
|
||||
=> ConduitT a o m ()
|
||||
sinkWSText = mapM_C sendTextData
|
||||
|
||||
-- | A @Sink@ for sending binary data to the user.
|
||||
--
|
||||
-- Since 0.1.0
|
||||
sinkWSBinary :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebSocketsT m) ()
|
||||
sinkWSBinary = CL.mapM_ sendBinaryData
|
||||
sinkWSBinary
|
||||
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
|
||||
=> ConduitT a o m ()
|
||||
sinkWSBinary = mapM_C sendBinaryData
|
||||
|
||||
@ -21,11 +21,12 @@ library
|
||||
, wai
|
||||
|
||||
, wai-websockets >= 2.1
|
||||
, websockets >= 0.9
|
||||
, websockets >= 0.10
|
||||
, transformers >= 0.2
|
||||
, yesod-core >= 1.6
|
||||
, unliftio
|
||||
, conduit >= 1.3
|
||||
, mtl
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
|
||||
Loading…
Reference in New Issue
Block a user