From 772e9ec7f8c677bb2b0c8b4f4f1e6ebcdd824927 Mon Sep 17 00:00:00 2001 From: tolysz Date: Mon, 14 Jul 2014 12:08:46 +0100 Subject: [PATCH 01/10] Add versions with exceptions Add versions of commands which execute IO () actions on exceptions. --- yesod-websockets/Yesod/WebSockets.hs | 37 ++++++++++++++++++++++++++++ 1 file changed, 37 insertions(+) diff --git a/yesod-websockets/Yesod/WebSockets.hs b/yesod-websockets/Yesod/WebSockets.hs index 58146f9b..75f795f3 100644 --- a/yesod-websockets/Yesod/WebSockets.hs +++ b/yesod-websockets/Yesod/WebSockets.hs @@ -30,6 +30,7 @@ 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 +import qualified Control.Exception as E -- | A transformer for a WebSockets handler. -- @@ -67,18 +68,54 @@ webSockets inner = do receiveData :: (MonadIO m, WS.WebSocketsData a) => WebSocketsT m a receiveData = ReaderT $ liftIO . WS.receiveData +-- | Receive a piece of data from the client. +-- Execute IO () action on WebSocket Exception +-- Since 0.1.1.3 +receiveDataX :: (MonadIO m, WS.WebSocketsData a) => IO () -> a -> WebSocketsT m a +receiveDataX ex d = ReaderT $ \c -> liftIO $ (WS.receiveData c) `E.catch` (\(_ :: E.SomeException) -> ex >> return d) + -- | Send a textual message to the client. -- -- Since 0.1.0 sendTextData :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m () sendTextData x = ReaderT $ liftIO . flip WS.sendTextData x +-- | Send a textual message to the client. +-- Execute IO () action on WebSocket Exception +-- Since 0.1.1.3 +sendTextDataX :: (MonadIO m, WS.WebSocketsData a) => IO () -> a -> WebSocketsT m () +sendTextDataX ex x = ReaderT $ \c -> liftIO $ (flip WS.sendTextData x $ c) `E.catch` (\(_ :: E.SomeException) -> ex) + -- | Send a binary message to the client. -- -- Since 0.1.0 sendBinaryData :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m () sendBinaryData x = ReaderT $ liftIO . flip WS.sendBinaryData x +-- | Send a ping message to the client. +-- +-- Since 0.1.1.3 +sendPing :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m () +sendPing x = ReaderT $ liftIO $ flip WS.sendPing x + +-- | Send a ping message to the client. +-- Execute IO () action on WebSocket Exception +-- Since 0.1.1.3 +sendPingX :: (MonadIO m, WS.WebSocketsData a) => IO () -> a -> WebSocketsT m () +sendPingX ex x = ReaderT $ \c -> liftIO $ (flip WS.sendPing x $ c) `E.catch` (\(_ :: E.SomeException) -> ex) + +-- | Send a close request to the client. +-- +-- Since 0.1.1.3 +sendClose :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m () +sendClose x = ReaderT $ liftIO . flip WS.sendClose x + +-- | Send a close request to the client. +-- Execute IO () action on WebSocket Exception +-- Since 0.1.1.3 +sendCloseX :: (MonadIO m, WS.WebSocketsData a) => IO () -> a -> WebSocketsT m () +sendCloseX ex x = ReaderT $ \c -> liftIO $ (flip WS.sendClose x $ c) `E.catch` (\(_ :: E.SomeException) -> ex) + -- | A @Source@ of WebSockets data from the user. -- -- Since 0.1.0 From 50728f6b59929dfc988764351ab5345360a03ab5 Mon Sep 17 00:00:00 2001 From: tolysz Date: Mon, 14 Jul 2014 12:09:47 +0100 Subject: [PATCH 02/10] bump verision --- yesod-websockets/yesod-websockets.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-websockets/yesod-websockets.cabal b/yesod-websockets/yesod-websockets.cabal index 9e1d0acb..11bb691a 100644 --- a/yesod-websockets/yesod-websockets.cabal +++ b/yesod-websockets/yesod-websockets.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: yesod-websockets -version: 0.1.1.2 +version: 0.1.1.3 synopsis: WebSockets support for Yesod description: WebSockets support for Yesod homepage: https://github.com/yesodweb/yesod From 65c0bd5c64bfa920e1d0a95f98458e6a751e72a3 Mon Sep 17 00:00:00 2001 From: tolysz Date: Mon, 14 Jul 2014 12:14:01 +0100 Subject: [PATCH 03/10] fix exports --- yesod-websockets/Yesod/WebSockets.hs | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/yesod-websockets/Yesod/WebSockets.hs b/yesod-websockets/Yesod/WebSockets.hs index 75f795f3..57778faa 100644 --- a/yesod-websockets/Yesod/WebSockets.hs +++ b/yesod-websockets/Yesod/WebSockets.hs @@ -6,8 +6,15 @@ module Yesod.WebSockets WebSocketsT , webSockets , receiveData + , receiveDataX + , sendPing + , sendPingX + , sendClose + , sendCloseX , sendTextData + , sendTextDataX , sendBinaryData + , sendBinaryDataX -- * Conduit API , sourceWS , sinkWSText @@ -92,6 +99,13 @@ sendTextDataX ex x = ReaderT $ \c -> liftIO $ (flip WS.sendTextData x $ c) `E.ca sendBinaryData :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m () sendBinaryData x = ReaderT $ liftIO . flip WS.sendBinaryData x +-- | Send a binary message to the client. +-- Execute IO () action on WebSocket Exception +-- Since 0.1.1.3 +sendBinaryDataX :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m () +sendBinaryDataX ex x = ReaderT $ \c -> liftIO $ (flip WS.sendBinaryData x $ c) `E.catch` (\(_ :: E.SomeException) -> ex) + + -- | Send a ping message to the client. -- -- Since 0.1.1.3 From 4a6f7045f4f21beebd71ee89b451a9b0e4b559cd Mon Sep 17 00:00:00 2001 From: tolysz Date: Mon, 14 Jul 2014 12:22:44 +0100 Subject: [PATCH 04/10] copy and paste typo --- yesod-websockets/Yesod/WebSockets.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-websockets/Yesod/WebSockets.hs b/yesod-websockets/Yesod/WebSockets.hs index 57778faa..9d68ee1e 100644 --- a/yesod-websockets/Yesod/WebSockets.hs +++ b/yesod-websockets/Yesod/WebSockets.hs @@ -110,7 +110,7 @@ sendBinaryDataX ex x = ReaderT $ \c -> liftIO $ (flip WS.sendBinaryData x $ c) ` -- -- Since 0.1.1.3 sendPing :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m () -sendPing x = ReaderT $ liftIO $ flip WS.sendPing x +sendPing x = ReaderT $ liftIO . flip WS.sendPing x -- | Send a ping message to the client. -- Execute IO () action on WebSocket Exception From 56da66d937a71b14d570ea942d54bf48cd729e3e Mon Sep 17 00:00:00 2001 From: tolysz Date: Mon, 14 Jul 2014 12:33:07 +0100 Subject: [PATCH 05/10] add missing ScopedTypeVariables --- yesod-websockets/Yesod/WebSockets.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/yesod-websockets/Yesod/WebSockets.hs b/yesod-websockets/Yesod/WebSockets.hs index 9d68ee1e..8046f875 100644 --- a/yesod-websockets/Yesod/WebSockets.hs +++ b/yesod-websockets/Yesod/WebSockets.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} module Yesod.WebSockets ( -- * Core API WebSocketsT From 038c94d1cf124c52ac1984f9fa35198a3c1389b7 Mon Sep 17 00:00:00 2001 From: tolysz Date: Mon, 14 Jul 2014 12:41:37 +0100 Subject: [PATCH 06/10] copy and paste --- yesod-websockets/Yesod/WebSockets.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-websockets/Yesod/WebSockets.hs b/yesod-websockets/Yesod/WebSockets.hs index 8046f875..0f6cff7e 100644 --- a/yesod-websockets/Yesod/WebSockets.hs +++ b/yesod-websockets/Yesod/WebSockets.hs @@ -103,7 +103,7 @@ sendBinaryData x = ReaderT $ liftIO . flip WS.sendBinaryData x -- | Send a binary message to the client. -- Execute IO () action on WebSocket Exception -- Since 0.1.1.3 -sendBinaryDataX :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m () +sendBinaryDataX :: (MonadIO m, WS.WebSocketsData a) => IO () -> a -> WebSocketsT m () sendBinaryDataX ex x = ReaderT $ \c -> liftIO $ (flip WS.sendBinaryData x $ c) `E.catch` (\(_ :: E.SomeException) -> ex) From 89cd52ad104979e881908fa144f42c7ae702f53f Mon Sep 17 00:00:00 2001 From: tolysz Date: Mon, 14 Jul 2014 15:02:32 +0100 Subject: [PATCH 07/10] Rewrite to Either SomeException a Rewrite to use suggested `enclosed-exceptions` package and `Either` pattern for capturing exceptions --- yesod-websockets/Yesod/WebSockets.hs | 62 ++++++++++++++++------------ 1 file changed, 36 insertions(+), 26 deletions(-) diff --git a/yesod-websockets/Yesod/WebSockets.hs b/yesod-websockets/Yesod/WebSockets.hs index 0f6cff7e..b47b021e 100644 --- a/yesod-websockets/Yesod/WebSockets.hs +++ b/yesod-websockets/Yesod/WebSockets.hs @@ -7,15 +7,15 @@ module Yesod.WebSockets WebSocketsT , webSockets , receiveData - , receiveDataX + , receiveDataE , sendPing - , sendPingX + , sendPingE , sendClose - , sendCloseX + , sendCloseE , sendTextData - , sendTextDataX + , sendTextDataE , sendBinaryData - , sendBinaryDataX + , sendBinaryDataE -- * Conduit API , sourceWS , sinkWSText @@ -33,12 +33,14 @@ 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 Data.Either 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 -import qualified Control.Exception as E +import Control.Exception (SomeException) +import Control.Exception.Enclosed (tryAny) -- | A transformer for a WebSockets handler. -- @@ -70,6 +72,13 @@ webSockets inner = do src sink + +wrapWSE :: (MonadIO m, WS.WebSocketsData a) => (WS.Connection -> a -> IO ())-> a -> WebSocketsT m (Either SomeException ()) +wrapWSE ws x = ReaderT $ liftIO . tryAny . flip ws x + +wrapWS :: (MonadIO m, WS.WebSocketsData a) => (WS.Connection -> a -> IO ()) -> a -> WebSocketsT m () +wrapWS ws x = ReaderT $ liftIO . flip ws x + -- | Receive a piece of data from the client. -- -- Since 0.1.0 @@ -77,59 +86,60 @@ receiveData :: (MonadIO m, WS.WebSocketsData a) => WebSocketsT m a receiveData = ReaderT $ liftIO . WS.receiveData -- | Receive a piece of data from the client. --- Execute IO () action on WebSocket Exception +-- Capture SomeException as the result or operation -- Since 0.1.1.3 -receiveDataX :: (MonadIO m, WS.WebSocketsData a) => IO () -> a -> WebSocketsT m a -receiveDataX ex d = ReaderT $ \c -> liftIO $ (WS.receiveData c) `E.catch` (\(_ :: E.SomeException) -> ex >> return d) +receiveDataE :: (MonadIO m, WS.WebSocketsData a) => WebSocketsT m (Either SomeException a) +receiveDataE = ReaderT $ liftIO . tryAny . WS.receiveData -- | Send a textual message to the client. -- -- Since 0.1.0 sendTextData :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m () -sendTextData x = ReaderT $ liftIO . flip WS.sendTextData x +sendTextData = wrapWS WS.sendTextData -- | Send a textual message to the client. --- Execute IO () action on WebSocket Exception +-- Capture SomeException as the result or operation +-- and can be used like +-- `either handle_exception return =<< sendTextDataE ("Welcome" :: Text)` -- Since 0.1.1.3 -sendTextDataX :: (MonadIO m, WS.WebSocketsData a) => IO () -> a -> WebSocketsT m () -sendTextDataX ex x = ReaderT $ \c -> liftIO $ (flip WS.sendTextData x $ c) `E.catch` (\(_ :: E.SomeException) -> ex) +sendTextDataE :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m (Either SomeException ()) +sendTextDataE = wrapWS WS.sendTextData -- | Send a binary message to the client. -- -- Since 0.1.0 sendBinaryData :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m () -sendBinaryData x = ReaderT $ liftIO . flip WS.sendBinaryData x +sendBinaryData = wrapWS WS.sendBinaryData -- | Send a binary message to the client. --- Execute IO () action on WebSocket Exception +-- Capture SomeException as the result or operation -- Since 0.1.1.3 -sendBinaryDataX :: (MonadIO m, WS.WebSocketsData a) => IO () -> a -> WebSocketsT m () -sendBinaryDataX ex x = ReaderT $ \c -> liftIO $ (flip WS.sendBinaryData x $ c) `E.catch` (\(_ :: E.SomeException) -> ex) - +sendBinaryDataE :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m (Either SomeException ()) +sendBinaryDataE = wrapWSE WS.sendBinaryData -- | Send a ping message to the client. -- -- Since 0.1.1.3 sendPing :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m () -sendPing x = ReaderT $ liftIO . flip WS.sendPing x +sendPing = wrapWS WS.sendPing -- | Send a ping message to the client. --- Execute IO () action on WebSocket Exception +-- Capture SomeException as the result of operation -- Since 0.1.1.3 -sendPingX :: (MonadIO m, WS.WebSocketsData a) => IO () -> a -> WebSocketsT m () -sendPingX ex x = ReaderT $ \c -> liftIO $ (flip WS.sendPing x $ c) `E.catch` (\(_ :: E.SomeException) -> ex) +sendPingE :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m (Either SomeException ()) +sendPingE = wrapWSE WS.sendPing -- | Send a close request to the client. -- -- Since 0.1.1.3 sendClose :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m () -sendClose x = ReaderT $ liftIO . flip WS.sendClose x +sendClose = wrapWS WS.sendClose -- | Send a close request to the client. --- Execute IO () action on WebSocket Exception +-- Capture SomeException as the result of operation -- Since 0.1.1.3 -sendCloseX :: (MonadIO m, WS.WebSocketsData a) => IO () -> a -> WebSocketsT m () -sendCloseX ex x = ReaderT $ \c -> liftIO $ (flip WS.sendClose x $ c) `E.catch` (\(_ :: E.SomeException) -> ex) +sendCloseE :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m (Either SomeException ()) +sendCloseE = wrapWSE WS.sendClose -- | A @Source@ of WebSockets data from the user. -- From acd2bb61e493aa43b1c14f008c373fd1a8a2d0f7 Mon Sep 17 00:00:00 2001 From: tolysz Date: Mon, 14 Jul 2014 15:04:17 +0100 Subject: [PATCH 08/10] add enclosed-exceptions --- yesod-websockets/yesod-websockets.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/yesod-websockets/yesod-websockets.cabal b/yesod-websockets/yesod-websockets.cabal index 11bb691a..0d1a82f9 100644 --- a/yesod-websockets/yesod-websockets.cabal +++ b/yesod-websockets/yesod-websockets.cabal @@ -28,6 +28,7 @@ library , monad-control >= 0.3 , conduit >= 1.0.15.1 , async >= 2.0.1.5 + , enclosed-exceptions >= 1.0 source-repository head type: git From 8a8bfa7ec7a13fe5738fbbe3be770494c8013b83 Mon Sep 17 00:00:00 2001 From: tolysz Date: Mon, 14 Jul 2014 15:10:50 +0100 Subject: [PATCH 09/10] correct the wrapper --- yesod-websockets/Yesod/WebSockets.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/yesod-websockets/Yesod/WebSockets.hs b/yesod-websockets/Yesod/WebSockets.hs index b47b021e..ff1c31f4 100644 --- a/yesod-websockets/Yesod/WebSockets.hs +++ b/yesod-websockets/Yesod/WebSockets.hs @@ -72,7 +72,7 @@ webSockets inner = do src sink - +-- | Wrapper for capturing exceptions wrapWSE :: (MonadIO m, WS.WebSocketsData a) => (WS.Connection -> a -> IO ())-> a -> WebSocketsT m (Either SomeException ()) wrapWSE ws x = ReaderT $ liftIO . tryAny . flip ws x @@ -103,7 +103,7 @@ sendTextData = wrapWS WS.sendTextData -- `either handle_exception return =<< sendTextDataE ("Welcome" :: Text)` -- Since 0.1.1.3 sendTextDataE :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m (Either SomeException ()) -sendTextDataE = wrapWS WS.sendTextData +sendTextDataE = wrapWSE WS.sendTextData -- | Send a binary message to the client. -- @@ -112,7 +112,7 @@ sendBinaryData :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m () sendBinaryData = wrapWS WS.sendBinaryData -- | Send a binary message to the client. --- Capture SomeException as the result or operation +-- Capture SomeException as the result of operation -- Since 0.1.1.3 sendBinaryDataE :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m (Either SomeException ()) sendBinaryDataE = wrapWSE WS.sendBinaryData From a4894d54afc4c5187ca62324265eaa4c0babe12a Mon Sep 17 00:00:00 2001 From: tolysz Date: Mon, 14 Jul 2014 15:37:46 +0100 Subject: [PATCH 10/10] remove not needed extension --- yesod-websockets/Yesod/WebSockets.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/yesod-websockets/Yesod/WebSockets.hs b/yesod-websockets/Yesod/WebSockets.hs index ff1c31f4..5d250109 100644 --- a/yesod-websockets/Yesod/WebSockets.hs +++ b/yesod-websockets/Yesod/WebSockets.hs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} module Yesod.WebSockets ( -- * Core API WebSocketsT