websockets 0.9.2.2 → 0.9.3.0
raw patch · 5 files changed
+78/−68 lines, 5 filesdep ~basedep ~blaze-builder
Dependency ranges changed: base, blaze-builder
Files
- CHANGELOG +5/−0
- src/Network/WebSockets/Client.hs +7/−5
- src/Network/WebSockets/Connection.hs +38/−42
- src/Network/WebSockets/Server.hs +25/−18
- websockets.cabal +3/−3
CHANGELOG view
@@ -1,3 +1,8 @@+- 0.9.3.0+ * Use a shared closed state for connection input/output stream+ * Make sure `runServer` doesn't leak any sockets+ * Bump `blaze-builder` dependency+ - 0.9.2.2 * Bump `random` dependency
src/Network/WebSockets/Client.hs view
@@ -101,15 +101,17 @@ parse <- decodeMessages protocol stream write <- encodeMessages protocol ClientConnection stream - parseState <- newMVar (Available parse)- writeState <- newMVar (Available write)- sentRef <- newIORef False+ parseLock <- newMVar ()+ writeLock <- newMVar ()+ stream' <- newIORef (DecoderEncoder parse write)+ sentRef <- newIORef False app Connection { connectionOptions = opts , connectionType = ClientConnection , connectionProtocol = protocol- , connectionParse = parseState- , connectionWrite = writeState+ , connectionParseLock = parseLock+ , connectionWriteLock = writeLock+ , connectionStream = stream' , connectionSentClose = sentRef } where
src/Network/WebSockets/Connection.hs view
@@ -9,7 +9,7 @@ , acceptRequestWith , rejectRequest - , Available (..)+ , DecoderEncoder (..) , Connection (..) , ConnectionOptions (..)@@ -33,9 +33,9 @@ -------------------------------------------------------------------------------- import qualified Blaze.ByteString.Builder as Builder import Control.Concurrent (forkIO, threadDelay)-import Control.Concurrent.MVar (MVar, newMVar, putMVar, takeMVar)+import Control.Concurrent.MVar (MVar, newMVar, withMVar) import Control.Exception (AsyncException, fromException,- handle, mask, onException, throwIO)+ handle, onException, throwIO) import Control.Monad (unless) import qualified Data.ByteString as B import Data.IORef (IORef, newIORef, readIORef,@@ -103,15 +103,17 @@ parse <- decodeMessages protocol (pendingStream pc) write <- encodeMessages protocol ServerConnection (pendingStream pc) - parseState <- newMVar (Available parse)- writeState <- newMVar (Available write)+ parseLock <- newMVar ()+ writeLock <- newMVar ()+ stream <- newIORef (DecoderEncoder parse write) sentRef <- newIORef False let connection = Connection { connectionOptions = pendingOptions pc , connectionType = ServerConnection , connectionProtocol = protocol- , connectionParse = parseState- , connectionWrite = writeState+ , connectionParseLock = parseLock+ , connectionWriteLock = writeLock+ , connectionStream = stream , connectionSentClose = sentRef } @@ -129,10 +131,10 @@ ----------------------------------------------------------------------------------- | Type protecting the 'connectionParse' and 'connectionWrite' IO actions. By--- using this inside an 'MVar' we can protect from concurrent writes/reads, and--- writes/reads to closed channels.-data Available a = Available !a | Unavailable+-- | Type representing an available or unavailable stream.+data DecoderEncoder a+ = DecoderEncoder !(IO (Maybe a)) !(a -> IO ())+ | Closed --------------------------------------------------------------------------------@@ -140,8 +142,9 @@ { connectionOptions :: !ConnectionOptions , connectionType :: !ConnectionType , connectionProtocol :: !Protocol- , connectionParse :: !(MVar (Available (IO (Maybe Message))))- , connectionWrite :: !(MVar (Available (Message -> IO ())))+ , connectionParseLock :: !(MVar ())+ , connectionWriteLock :: !(MVar ())+ , connectionStream :: !(IORef (DecoderEncoder Message)) , connectionSentClose :: !(IORef Bool) -- ^ According to the RFC, both the client and the server MUST send -- a close control message to each other. Either party can initiate@@ -169,16 +172,18 @@ -------------------------------------------------------------------------------- receive :: Connection -> IO Message-receive conn = withMVarEx m Unavailable $ \state ->- case state of- Unavailable -> throwIO ConnectionClosed- Available parse -> do- mbMsg <- parse- case mbMsg of- Nothing -> throwIO ConnectionClosed- Just msg -> return msg+receive conn = withMVar (connectionParseLock conn) $ \() ->+ tryParse `onException` (writeIORef (connectionStream conn) Closed) where- m = connectionParse conn+ tryParse = do+ stream <- readIORef (connectionStream conn)+ case stream of+ Closed -> throwIO ConnectionClosed+ DecoderEncoder parse _ -> do+ mbMsg <- parse+ case mbMsg of+ Nothing -> throwIO ConnectionClosed+ Just msg -> return msg --------------------------------------------------------------------------------@@ -222,15 +227,18 @@ -------------------------------------------------------------------------------- send :: Connection -> Message -> IO ()-send conn msg = withMVarEx m Unavailable $ \state -> do- case msg of- (ControlMessage (Close _ _)) -> writeIORef (connectionSentClose conn) True- _ -> return ()- case state of- Unavailable -> throwIO ConnectionClosed- Available write -> write msg+send conn msg = withMVar (connectionWriteLock conn) $ \() ->+ trySend `onException` writeIORef (connectionStream conn) Closed where- m = connectionWrite conn+ trySend = do+ stream <- readIORef (connectionStream conn)+ case msg of+ (ControlMessage (Close _ _)) ->+ writeIORef (connectionSentClose conn) True+ _ -> return ()+ case stream of+ Closed -> throwIO ConnectionClosed+ DecoderEncoder _ write -> write msg --------------------------------------------------------------------------------@@ -299,15 +307,3 @@ ignore e = case fromException e of 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
@@ -13,9 +13,10 @@ ---------------------------------------------------------------------------------import Control.Concurrent (forkIO)-import Control.Exception (finally, throwIO)-import Control.Monad (forever)+import Control.Concurrent (forkIOWithUnmask)+import Control.Exception (bracket, bracketOnError,+ finally, throwIO, mask_)+import Control.Monad (forever, void) import Network.Socket (Socket) import qualified Network.Socket as S @@ -47,28 +48,34 @@ -------------------------------------------------------------------------------- -- | A version of 'runServer' which allows you to customize some options. runServerWith :: String -> Int -> ConnectionOptions -> ServerApp -> IO ()-runServerWith host port opts app = S.withSocketsDo $ do- sock <- makeListenSocket host port- _ <- forever $ do- -- TODO: top level handle- (conn, _) <- S.accept sock- _ <- forkIO $ finally (runApp conn opts app) (S.sClose conn)- return ()- S.sClose sock+runServerWith host port opts app = S.withSocketsDo $+ bracket+ (makeListenSocket host port)+ S.sClose+ (\sock ->+ forever $ mask_ $ do+ (conn, _) <- S.accept sock+ void $ forkIOWithUnmask $ \unmask ->+ finally (unmask $ runApp conn opts app) (S.sClose conn)+ ) + -------------------------------------------------------------------------------- -- | Create a standardized socket on which you can listen for incomming -- connections. Should only be used for a quick and dirty solution! Should be -- preceded by the call 'Network.Socket.withSocketsDo'. makeListenSocket :: String -> Int -> IO Socket-makeListenSocket host port = do- sock <- S.socket S.AF_INET S.Stream S.defaultProtocol- _ <- S.setSocketOption sock S.ReuseAddr 1- host' <- S.inet_addr host- S.bindSocket sock (S.SockAddrInet (fromIntegral port) host')- S.listen sock 5- return sock+makeListenSocket host port = bracketOnError+ (S.socket S.AF_INET S.Stream S.defaultProtocol)+ S.sClose+ (\sock -> do+ _ <- S.setSocketOption sock S.ReuseAddr 1+ host' <- S.inet_addr host+ S.bindSocket sock (S.SockAddrInet (fromIntegral port) host')+ S.listen sock 5+ return sock+ ) --------------------------------------------------------------------------------
websockets.cabal view
@@ -1,5 +1,5 @@ Name: websockets-Version: 0.9.2.2+Version: 0.9.3.0 Synopsis: A sensible and clean way to write WebSocket-capable servers in Haskell.@@ -68,7 +68,7 @@ base >= 4 && < 5, base64-bytestring >= 0.1 && < 1.1, binary >= 0.5 && < 0.8,- blaze-builder >= 0.3 && < 0.4,+ blaze-builder >= 0.3 && < 0.5, bytestring >= 0.9 && < 0.11, case-insensitive >= 0.3 && < 1.3, containers >= 0.3 && < 0.6,@@ -103,7 +103,7 @@ base >= 4 && < 5, base64-bytestring >= 0.1 && < 1.1, binary >= 0.5 && < 0.8,- blaze-builder >= 0.3 && < 0.4,+ blaze-builder >= 0.3 && < 0.5, bytestring >= 0.9 && < 0.11, case-insensitive >= 0.3 && < 1.3, containers >= 0.3 && < 0.6,