websockets 0.12.5.3 → 0.12.6.0
raw patch · 7 files changed
+125/−46 lines, 7 filesdep +asyncdep ~QuickCheck
Dependencies added: async
Dependency ranges changed: QuickCheck
Files
- CHANGELOG +9/−0
- example/server.lhs +30/−30
- src/Network/WebSockets.hs +1/−0
- src/Network/WebSockets/Client.hs +28/−4
- src/Network/WebSockets/Connection.hs +38/−6
- src/Network/WebSockets/Stream.hs +11/−3
- websockets.cabal +8/−3
CHANGELOG view
@@ -1,5 +1,14 @@ # CHANGELOG +- 0.12.6.0 (2019-10-28)+ * Expose a lower-level API to construct client connections (by Philipp+ Balzarek)+ * Close underlying stream only on synchronous exceptions, not asynchronous+ exceptions (by kamoii)+ * Add a `withPingThread` and lower-level `pingThread` to replace+ `forkPingThread`+ * Bump `QuickCheck` dependency to 2.13+ - 0.12.5.3 (2019-01-31) * Bump `network` dependency to 3.0
example/server.lhs view
@@ -88,58 +88,58 @@ > application state pending = do > conn <- WS.acceptRequest pending-> WS.forkPingThread conn 30+> WS.withPingThread conn 30 (return ()) $ do When a client is succesfully connected, we read the first message. This should be in the format of "Hi! I am Jasper", where Jasper is the requested username. -> msg <- WS.receiveData conn-> clients <- readMVar state-> case msg of+> msg <- WS.receiveData conn+> clients <- readMVar state+> case msg of Check that the first message has the right format: -> _ | not (prefix `T.isPrefixOf` msg) ->-> WS.sendTextData conn ("Wrong announcement" :: Text)+> _ | not (prefix `T.isPrefixOf` msg) ->+> WS.sendTextData conn ("Wrong announcement" :: Text) Check the validity of the username: -> | any ($ fst client)-> [T.null, T.any isPunctuation, T.any isSpace] ->-> WS.sendTextData conn ("Name cannot " `mappend`-> "contain punctuation or whitespace, and " `mappend`-> "cannot be empty" :: Text)+> | any ($ fst client)+> [T.null, T.any isPunctuation, T.any isSpace] ->+> WS.sendTextData conn ("Name cannot " <>+> "contain punctuation or whitespace, and " <>+> "cannot be empty" :: Text) Check that the given username is not already taken: -> | clientExists client clients ->-> WS.sendTextData conn ("User already exists" :: Text)+> | clientExists client clients ->+> WS.sendTextData conn ("User already exists" :: Text) All is right! We're going to allow the client, but for safety reasons we *first* setup a `disconnect` function that will be run when the connection is closed. -> | otherwise -> flip finally disconnect $ do+> | otherwise -> flip finally disconnect $ do We send a "Welcome!", according to our own little protocol. We add the client to the list and broadcast the fact that he has joined. Then, we give control to the 'talk' function. -> modifyMVar_ state $ \s -> do-> let s' = addClient client s-> WS.sendTextData conn $-> "Welcome! Users: " `mappend`-> T.intercalate ", " (map fst s)-> broadcast (fst client `mappend` " joined") s'-> return s'-> talk client state-> where-> prefix = "Hi! I am "-> client = (T.drop (T.length prefix) msg, conn)-> disconnect = do-> -- Remove client and return new state-> s <- modifyMVar state $ \s ->-> let s' = removeClient client s in return (s', s')-> broadcast (fst client `mappend` " disconnected") s+> modifyMVar_ state $ \s -> do+> let s' = addClient client s+> WS.sendTextData conn $+> "Welcome! Users: " <>+> T.intercalate ", " (map fst s)+> broadcast (fst client <> " joined") s'+> return s'+> talk client state+> where+> prefix = "Hi! I am "+> client = (T.drop (T.length prefix) msg, conn)+> disconnect = do+> -- Remove client and return new state+> s <- modifyMVar state $ \s ->+> let s' = removeClient client s in return (s', s')+> broadcast (fst client <> " disconnected") s The talk function continues to read messages from a single client until he disconnects. All messages are broadcasted to the other clients.
src/Network/WebSockets.hs view
@@ -80,6 +80,7 @@ , newClientConnection -- * Utilities+ , withPingThread , forkPingThread ) where
src/Network/WebSockets/Client.hs view
@@ -8,6 +8,12 @@ , runClientWithSocket , runClientWithStream , newClientConnection+ -- * Low level functionality+ , createRequest+ , Protocol(..)+ , defaultProtocol+ , checkServerResponse+ , streamToClientConnection ) where @@ -118,6 +124,17 @@ -- Create the request and send it request <- createRequest protocol bHost bPath False customHeaders Stream.write stream (Builder.toLazyByteString $ encodeRequestHead request)+ checkServerResponse stream request+ streamToClientConnection stream opts+ where+ protocol = defaultProtocol -- TODO+ bHost = T.encodeUtf8 $ T.pack host+ bPath = T.encodeUtf8 $ T.pack path++-- | Check the response from the server.+-- Throws 'OtherHandshakeException' on failure+checkServerResponse :: Stream -> RequestHead -> IO ()+checkServerResponse stream request = do mbResponse <- Stream.parse stream decodeResponseHead response <- case mbResponse of Just response -> return response@@ -125,12 +142,21 @@ "Network.WebSockets.Client.newClientConnection: no handshake " ++ "response from server" void $ either throwIO return $ finishResponse protocol request response+ where+ protocol = defaultProtocol -- TODO+++-- | Build a 'Connection' from a pre-established stream with already finished+-- handshake.+--+-- /NB/: this will not perform any handshaking.+streamToClientConnection :: Stream -> ConnectionOptions -> IO Connection+streamToClientConnection stream opts = do parse <- decodeMessages protocol (connectionFramePayloadSizeLimit opts) (connectionMessageDataSizeLimit opts) stream write <- encodeMessages protocol ClientConnection stream sentRef <- newIORef False- return $ Connection { connectionOptions = opts , connectionType = ClientConnection@@ -140,9 +166,7 @@ , connectionSentClose = sentRef } where- protocol = defaultProtocol -- TODO- bHost = T.encodeUtf8 $ T.pack host- bPath = T.encodeUtf8 $ T.pack path+ protocol = defaultProtocol --------------------------------------------------------------------------------
src/Network/WebSockets/Connection.hs view
@@ -32,7 +32,9 @@ , sendCloseCode , sendPing + , withPingThread , forkPingThread+ , pingThread , CompressionOptions (..) , PermessageDeflate (..)@@ -43,10 +45,10 @@ ---------------------------------------------------------------------------------import qualified Data.ByteString.Builder as Builder import Control.Applicative ((<$>)) import Control.Concurrent (forkIO, threadDelay)+import qualified Control.Concurrent.Async as Async import Control.Exception (AsyncException, fromException, handle,@@ -54,6 +56,7 @@ import Control.Monad (foldM, unless, when) import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Char8 as B8 import Data.IORef (IORef, newIORef,@@ -388,22 +391,51 @@ -------------------------------------------------------------------------------- -- | Forks a ping thread, sending a ping message every @n@ seconds over the--- connection. The thread dies silently if the connection crashes or is closed.+-- connection. The thread is killed when the inner IO action is finished. -- -- This is useful to keep idle connections open through proxies and whatnot. -- Many (but not all) proxies have a 60 second default timeout, so based on that -- sending a ping every 30 seconds is a good idea.+withPingThread+ :: Connection+ -> Int -- ^ Second interval in which pings should be sent.+ -> IO () -- ^ Repeat this after sending a ping.+ -> IO a -- ^ Application to wrap with a ping thread.+ -> IO a -- ^ Executes application and kills ping thread when done.+withPingThread conn n action app =+ Async.withAsync (pingThread conn n action) (\_ -> app)+++--------------------------------------------------------------------------------+-- | DEPRECATED: Use 'withPingThread' instead.+--+-- Forks a ping thread, sending a ping message every @n@ seconds over the+-- connection. The thread dies silently if the connection crashes or is closed.+--+-- This is useful to keep idle connections open through proxies and whatnot.+-- Many (but not all) proxies have a 60 second default timeout, so based on that+-- sending a ping every 30 seconds is a good idea. forkPingThread :: Connection -> Int -> IO ()-forkPingThread conn n+forkPingThread conn n = do+ _ <- forkIO $ pingThread conn n (return ())+ return ()+{-# DEPRECATED forkPingThread "Use 'withPingThread' instead" #-}+++--------------------------------------------------------------------------------+-- | Use this if you want to run the ping thread yourself.+--+-- See also 'withPingThread'.+pingThread :: Connection -> Int -> IO () -> IO ()+pingThread conn n action | n <= 0 = return ()- | otherwise = do- _ <- forkIO (ignore `handle` go 1)- return ()+ | otherwise = ignore `handle` go 1 where go :: Int -> IO () go i = do threadDelay (n * 1000 * 1000) sendPing conn (T.pack $ show i)+ action go (i + 1) ignore e = case fromException e of
src/Network/WebSockets/Stream.hs view
@@ -14,7 +14,7 @@ import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar, withMVar)-import Control.Exception (onException, throwIO)+import Control.Exception (SomeException, SomeAsyncException, throwIO, catch, fromException) import Control.Monad (forM_) import qualified Data.Attoparsec.ByteString as Atto import qualified Data.Binary.Get as BIN@@ -90,7 +90,7 @@ receive' :: IORef StreamState -> MVar () -> IO (Maybe B.ByteString) receive' ref lock = withMVar lock $ \() -> do assertOpen ref- mbBs <- onException receive (closeRef ref)+ mbBs <- onSyncException receive (closeRef ref) case mbBs of Nothing -> closeRef ref >> return Nothing Just bs -> return (Just bs)@@ -100,7 +100,15 @@ case mbBs of Nothing -> closeRef ref Just _ -> assertOpen ref- onException (send mbBs) (closeRef ref)+ onSyncException (send mbBs) (closeRef ref)++ onSyncException :: IO a -> IO b -> IO a+ onSyncException io what =+ catch io $ \e -> do+ case fromException (e :: SomeException) :: Maybe SomeAsyncException of+ Just _ -> pure ()+ Nothing -> what *> pure ()+ throwIO e --------------------------------------------------------------------------------
websockets.cabal view
@@ -1,5 +1,5 @@ Name: websockets-Version: 0.12.5.3+Version: 0.12.6.0 Synopsis: A sensible and clean way to write WebSocket-capable servers in Haskell.@@ -59,13 +59,13 @@ Exposed-modules: Network.WebSockets+ Network.WebSockets.Client Network.WebSockets.Connection Network.WebSockets.Extensions Network.WebSockets.Stream -- Network.WebSockets.Util.PubSub TODO Other-modules:- Network.WebSockets.Client Network.WebSockets.Connection.Options Network.WebSockets.Extensions.Description Network.WebSockets.Extensions.PermessageDeflate@@ -79,6 +79,7 @@ Network.WebSockets.Types Build-depends:+ async >= 2.2 && < 2.3, attoparsec >= 0.10 && < 0.14, base >= 4.6 && < 5, base64-bytestring >= 0.1 && < 1.1,@@ -131,11 +132,12 @@ Build-depends: HUnit >= 1.2 && < 1.7,- QuickCheck >= 2.7 && < 2.13,+ QuickCheck >= 2.7 && < 2.14, test-framework >= 0.4 && < 0.9, test-framework-hunit >= 0.2 && < 0.4, test-framework-quickcheck2 >= 0.2 && < 0.4, -- Copied from regular dependencies...+ async >= 2.2 && < 2.3, attoparsec >= 0.10 && < 0.14, base >= 4 && < 5, base64-bytestring >= 0.1 && < 1.1,@@ -162,6 +164,7 @@ Build-depends: websockets, -- Copied from regular dependencies...+ async >= 2.2 && < 2.3, attoparsec >= 0.10 && < 0.14, base >= 4 && < 5, base64-bytestring >= 0.1 && < 1.1,@@ -190,6 +193,7 @@ Build-depends: websockets, -- Copied from regular dependencies...+ async >= 2.2 && < 2.3, attoparsec >= 0.10 && < 0.14, base >= 4 && < 5, base64-bytestring >= 0.1 && < 1.1,@@ -216,6 +220,7 @@ Build-depends: criterion, -- Copied from regular dependencies...+ async >= 2.2 && < 2.3, attoparsec >= 0.10 && < 0.14, base >= 4 && < 5, base64-bytestring >= 0.1 && < 1.1,