websockets 0.9.2.0 → 0.9.2.1
raw patch · 6 files changed
+34/−23 lines, 6 files
Files
- CHANGELOG +3/−0
- src/Network/WebSockets/Client.hs +2/−2
- src/Network/WebSockets/Connection.hs +24/−16
- src/Network/WebSockets/Server.hs +2/−2
- src/Network/WebSockets/Stream.hs +2/−2
- websockets.cabal +1/−1
CHANGELOG view
@@ -1,3 +1,6 @@+- 0.9.2.1+ * Fix exception handling issues+ - 0.9.2.0 * Make sending and receiving messages thread-safe by default * Export `forkPingThread`
src/Network/WebSockets/Client.hs view
@@ -13,7 +13,7 @@ -------------------------------------------------------------------------------- import qualified Blaze.ByteString.Builder as Builder import Control.Concurrent.MVar (newMVar)-import Control.Exception (finally, throw)+import Control.Exception (finally, throwIO) import Data.IORef (newIORef) import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -93,7 +93,7 @@ mbResponse <- Stream.parse stream decodeResponseHead response <- case mbResponse of Just response -> return response- Nothing -> throw $ OtherHandshakeException $+ Nothing -> throwIO $ OtherHandshakeException $ "Network.WebSockets.Client.runClientWithStream: no handshake " ++ "response from server" -- Note that we pattern match to evaluate the result here
src/Network/WebSockets/Connection.hs view
@@ -35,7 +35,7 @@ import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.MVar (MVar, newMVar, putMVar, takeMVar) import Control.Exception (AsyncException, fromException,- handle, onException, throw)+ handle, mask, onException, throwIO) import Control.Monad (unless) import qualified Data.ByteString as B import Data.IORef (IORef, newIORef, readIORef,@@ -95,7 +95,7 @@ acceptRequestWith pc ar = case find (flip compatible request) protocols of Nothing -> do sendResponse pc $ response400 versionHeader ""- throw NotSupported+ throwIO NotSupported Just protocol -> do let subproto = maybe [] (\p -> [("Sec-WebSocket-Protocol", p)]) $ acceptSubprotocol ar response = finishRequest protocol request subproto@@ -169,15 +169,14 @@ -------------------------------------------------------------------------------- receive :: Connection -> IO Message-receive conn = do- state <- takeMVar m+receive conn = withMVarEx m Unavailable $ \state -> case state of- Unavailable -> putMVar m Unavailable >> throw ConnectionClosed+ Unavailable -> throwIO ConnectionClosed Available parse -> do- mbMsg <- parse `onException` putMVar m Unavailable+ mbMsg <- parse case mbMsg of- Nothing -> putMVar m Unavailable >> throw ConnectionClosed- Just msg -> putMVar m (Available parse) >> return msg+ Nothing -> throwIO ConnectionClosed+ Just msg -> return msg where m = connectionParse conn @@ -202,7 +201,7 @@ Close i closeMsg -> do hasSentClose <- readIORef $ connectionSentClose conn unless hasSentClose $ send conn msg- throw $ CloseRequest i closeMsg+ throwIO $ CloseRequest i closeMsg Pong _ -> do connectionOnPong (connectionOptions conn) receiveDataMessage conn@@ -223,16 +222,13 @@ -------------------------------------------------------------------------------- send :: Connection -> Message -> IO ()-send conn msg = do- state <- takeMVar m+send conn msg = withMVarEx m Unavailable $ \state -> do case msg of (ControlMessage (Close _ _)) -> writeIORef (connectionSentClose conn) True _ -> return () case state of- Unavailable -> putMVar m Unavailable >> throw ConnectionClosed- Available write -> do- write msg `onException` putMVar m Unavailable- putMVar m (Available write)+ Unavailable -> throwIO ConnectionClosed+ Available write -> write msg where m = connectionWrite conn @@ -301,5 +297,17 @@ go (i + 1) ignore e = case fromException e of- Just async -> throw (async :: AsyncException)+ Just async -> throwIO (async :: AsyncException) Nothing -> return ()+++-- Like 'withMVar' but in case of exceptions it puts the given alternative+-- value back into the MVar.+withMVarEx :: MVar a -> a -> (a -> IO b) -> IO b+withMVarEx m x io =+ mask $ \restore -> do+ a <- takeMVar m+ b <- restore (io a) `onException` putMVar m x+ putMVar m a+ return b+{-# INLINE withMVarEx #-}
src/Network/WebSockets/Server.hs view
@@ -14,7 +14,7 @@ -------------------------------------------------------------------------------- import Control.Concurrent (forkIO)-import Control.Exception (finally, throw)+import Control.Exception (finally, throwIO) import Control.Monad (forever) import Network.Socket (Socket) import qualified Network.Socket as S@@ -90,7 +90,7 @@ -- TODO: we probably want to send a 40x if the request is bad? mbRequest <- Stream.parse stream (decodeRequestHead False) case mbRequest of- Nothing -> throw ConnectionClosed+ Nothing -> throwIO ConnectionClosed Just request -> return PendingConnection { pendingOptions = opts , pendingRequest = request
src/Network/WebSockets/Stream.hs view
@@ -13,7 +13,7 @@ import Control.Applicative ((<$>)) import qualified Control.Concurrent.Chan as Chan-import Control.Exception (throw)+import Control.Exception (throwIO) import Control.Monad (forM_) import qualified Data.Attoparsec.ByteString as Atto import qualified Data.ByteString as B@@ -112,7 +112,7 @@ case mbBs of Nothing -> go (f B.empty) True Just bs -> go (f bs) False- go (Atto.Fail _ _ err) _ = throw (ParseException err)+ go (Atto.Fail _ _ err) _ = throwIO (ParseException err) --------------------------------------------------------------------------------
websockets.cabal view
@@ -1,5 +1,5 @@ Name: websockets-Version: 0.9.2.0+Version: 0.9.2.1 Synopsis: A sensible and clean way to write WebSocket-capable servers in Haskell.