diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 diff --git a/example/server.lhs b/example/server.lhs --- a/example/server.lhs +++ b/example/server.lhs @@ -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. diff --git a/src/Network/WebSockets.hs b/src/Network/WebSockets.hs --- a/src/Network/WebSockets.hs +++ b/src/Network/WebSockets.hs @@ -80,6 +80,7 @@ , newClientConnection -- * Utilities + , withPingThread , forkPingThread ) where diff --git a/src/Network/WebSockets/Client.hs b/src/Network/WebSockets/Client.hs --- a/src/Network/WebSockets/Client.hs +++ b/src/Network/WebSockets/Client.hs @@ -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 -------------------------------------------------------------------------------- diff --git a/src/Network/WebSockets/Connection.hs b/src/Network/WebSockets/Connection.hs --- a/src/Network/WebSockets/Connection.hs +++ b/src/Network/WebSockets/Connection.hs @@ -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 diff --git a/src/Network/WebSockets/Stream.hs b/src/Network/WebSockets/Stream.hs --- a/src/Network/WebSockets/Stream.hs +++ b/src/Network/WebSockets/Stream.hs @@ -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 -------------------------------------------------------------------------------- diff --git a/websockets.cabal b/websockets.cabal --- a/websockets.cabal +++ b/websockets.cabal @@ -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,