From 3956110876c94d7d6d8fafaa44e1989551509db0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 15 Jan 2018 21:07:54 +0200 Subject: [PATCH] Fix yesod-websockets --- yesod-websockets/Yesod/WebSockets.hs | 151 ++++++++++++++++-------- yesod-websockets/yesod-websockets.cabal | 3 +- 2 files changed, 105 insertions(+), 49 deletions(-) diff --git a/yesod-websockets/Yesod/WebSockets.hs b/yesod-websockets/Yesod/WebSockets.hs index 2346b03c..5a54c553 100644 --- a/yesod-websockets/Yesod/WebSockets.hs +++ b/yesod-websockets/Yesod/WebSockets.hs @@ -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 diff --git a/yesod-websockets/yesod-websockets.cabal b/yesod-websockets/yesod-websockets.cabal index 23f6b800..3734b307 100644 --- a/yesod-websockets/yesod-websockets.cabal +++ b/yesod-websockets/yesod-websockets.cabal @@ -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