websockets 0.9.8.2 → 0.13.0.0
raw patch · 33 files changed
Files
- CHANGELOG +125/−0
- benchmarks/mask.hs +72/−0
- cbits/cbits.c +72/−0
- example/client.hs +40/−0
- example/server.lhs +36/−36
- src/Network/WebSockets.hs +26/−1
- src/Network/WebSockets/Client.hs +77/−19
- src/Network/WebSockets/Connection.hs +241/−66
- src/Network/WebSockets/Connection/Options.hs +132/−0
- src/Network/WebSockets/Connection/PingPong.hs +62/−0
- src/Network/WebSockets/Extensions.hs +24/−0
- src/Network/WebSockets/Extensions/Description.hs +65/−0
- src/Network/WebSockets/Extensions/PermessageDeflate.hs +287/−0
- src/Network/WebSockets/Extensions/StrictUnicode.hs +40/−0
- src/Network/WebSockets/Http.hs +56/−38
- src/Network/WebSockets/Hybi13.hs +96/−83
- src/Network/WebSockets/Hybi13/Demultiplex.hs +86/−46
- src/Network/WebSockets/Hybi13/Mask.hs +60/−25
- src/Network/WebSockets/Protocol.hs +14/−9
- src/Network/WebSockets/Server.hs +69/−22
- src/Network/WebSockets/Stream.hs +67/−15
- src/Network/WebSockets/Types.hs +67/−11
- tests/autobahn/server.hs +91/−0
- tests/haskell/Network/WebSockets/Extensions/PermessageDeflate/Tests.hs +46/−0
- tests/haskell/Network/WebSockets/Extensions/Tests.hs +44/−0
- tests/haskell/Network/WebSockets/Handshake/Tests.hs +51/−1
- tests/haskell/Network/WebSockets/Http/Tests.hs +27/−0
- tests/haskell/Network/WebSockets/Hybi13/Demultiplex/Tests.hs +72/−0
- tests/haskell/Network/WebSockets/Mask/Tests.hs +57/−0
- tests/haskell/Network/WebSockets/Server/Tests.hs +66/−27
- tests/haskell/Network/WebSockets/Tests.hs +86/−53
- tests/haskell/TestSuite.hs +10/−5
- websockets.cabal +147/−51
CHANGELOG view
@@ -1,3 +1,128 @@+# CHANGELOG++- 0.13.0.0 (2023-12-30)+ * **BREAKING**: Remove `serverRequirePong` option in favor of the new+ implementation.+ * **BREAKING**: Client: Rejecting request raises+ `RequestRejected RequestHead ResponseHead`+ * Timeout initial socket connection after 30s.+ * If the socket is closed unexpectedly, raise `ConnectionClosed`.+ * Added a way to manually send a Pong message.+ * `runServer` now cleans up threads correctly.+ * Remove redundant bytestring-builder dependency.+ * Introduce `Network.WebSockets.Connection.PingPong` to+ handle ping pong for any Connection, be it Client or Server.+ * Bump `text `dependency upper bound to 2.2+ * Bump `random `dependency lower bound to 1.0.1++- 0.12.7.3 (2021-10-26)+ * Bump `attoparsec` dependency upper bound to 0.15++- 0.12.7.2 (2020-12-07)+ * Bump `QuickCheck` dependency upper bound to 2.15+ * Bump `base64-bytestring` dependency upper bound to 1.3+ * Bump `bytestring` dependency upper bound to 0.12+ * Bump `random` dependency upper bound to 1.3++- 0.12.7.1 (2020-05-03)+ * Bump `base64-bytestring` dependency upper bound to 1.2++- 0.12.7.0 (2019-12-31)+ * Bump `base` lower bound to 4.8, this drops support for GHC 7.6 and 7.8+ * Add a new `runServerWithOptions` that can be extended in a more+ future-compatible way+ * Add a connection killer setting in `runServerWithOptions`+ * Fix an unsafe read issue in `decodeResponseHead`++- 0.12.6.1 (2019-10-29)+ * Bump `network` dependency to 3.1++- 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++- 0.12.5.2 (2018-09-25)+ * Bump `containers` dependency to 0.6+ * Bump `network` dependency to 2.8+ * Bump `QuickCheck` dependency to 2.12+ * Bump `binary` dependency to 0.10++- 0.12.5.1 (2018-06-12)+ * Fix build with GHC 7.6 and 7.8++- 0.12.5.0 (2018-06-01)+ * Add `newClientConnection` (by Renzo Carbonara)++- 0.12.4.1 (2018-05-11)+ * Bump `network` dependency to 2.7++- 0.12.4.0 (2018-03-13)+ * Remove `blaze-builder` dependency+ * Bump `streaming-commons` dependency to 0.2+ * Bump `QuickCheck` dependency to 2.11+ * Fix compatibility with old GHC versions+ * Re-export more functions from `Network.WebSockets`+ - `sendDataMessages`+ - `sendBinaryDatas`+ - `sendCloseCode`+ * Don't crash when sending the empty list of messages+ * Add `SemiGroup` instance for `SizeLimit`++- 0.12.3.1 (2018-01-10)+ * Bump CHANGELOG with IPv6 warning+ * Run all autobahn tests during CI++- 0.12.3.0 (2018-01-02)+ * Fix error thrown from runClient functions+ * Bump `QuickCheck` dependency to 2.10+ * Bump `entropy` dependency to 0.4+ * Bump `binary` dependency to 0.10++- 0.12.2.0 (2017-07-28)+ * Don't use LambdaCase, we want to support older GHC versions++- 0.12.1.0 (2017-07-22)+ * Fix Monoid import on older base versions+ * Increase lower bound on `binary` to 0.8.1 (by Jonathan Daugherty)++- 0.12.0.0+ * Add limit options for frame and message size to prevent against (D)DoS+ attacks+ * Fix space leak in encodeMessages (by Roman Borschel)+ * Stricter frame/encoding decoding for ping/close frames (by Lars Petersen)++- 0.11.2.0+ * Fix 0-width reason phrase parsing+ * Change receive buffer from 1024 to 8192 bytes (by Ondrej Palkovsky)+ * Implement fast masking in C (by Ondrej Palkovsky and myself)+ * Some haddock improvements+ * Bump `HUnit` dependency to 1.6++- 0.11.1.0+ * Fix compilation issue with GHC-7.8++- 0.11.0.0+ * Support for IPv6 in the built-in server, client and tests (by agentm).+ This can cause issues on backends that do not enable IPv6. For more+ information and a workaround, see this issue:+ <https://github.com/jaspervdj/websockets/issues/140#issuecomment-296732964>.+ * Faster masking (by Dmitry Ivanov)+ * Support for `permessage-deflate` extension (by Marcin Tolysz)+ * Strict unicode checking and proper extension mechanism++- 0.10.0.0+ * Fix client specifying empty path+ * Allow sending collections of messages (by David Turner)+ * Allow sending extra headers when accepting request (by James Deery)+ - 0.9.8.2 * Bump `HUnit` dependency to 1.5
+ benchmarks/mask.hs view
@@ -0,0 +1,72 @@+{-# language BangPatterns #-}+{-# language OverloadedStrings #-}++import Criterion+import Criterion.Main+import qualified Data.Binary.Get as Get++import Network.WebSockets.Hybi13.Mask++import Data.Bits (shiftR, xor)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL++setupEnv = do+ let kilo = BL.replicate 1024 37+ mega = BL.replicate (1024 * 1024) 37+ megaU = BL.fromChunks [B.drop 1 (B.replicate (1024 * 1024) 37)]+ megaS = BL.fromChunks [B.replicate (1024 * 1024) 37]+ return (kilo, mega, megaU, megaS)++maskPayload' :: Maybe B.ByteString -> BL.ByteString -> BL.ByteString+maskPayload' Nothing = id+maskPayload' (Just mask) = snd . BL.mapAccumL f (cycle $ B.unpack mask)+ where+ f [] !c = ([], c)+ f (m:ms) !c = (ms, m `xor` c)++main = defaultMain [+ env setupEnv $ \ ~(kilo, mega, megaU, megaS) -> bgroup "main"+ [ bgroup "kilobyte payload"+ [ bgroup "zero_mask"+ [ bench "current" $ nf (maskPayload (mkMask $ "\x00\x00\x00\x00")) kilo+ , bench "old" $ nf (maskPayload' (Just "\x00\x00\x00\x00")) kilo+ ]+ , bgroup "full_mask"+ [ bench "current" $ nf (maskPayload (mkMask "\xFF\xFF\xFF\xFF")) kilo+ , bench "current-unaligned" $ nf (maskPayload (mkMask "\xFF\xFF\xFF\xFF")) (BL.drop 1 kilo)+ , bench "old" $ nf (maskPayload' (Just "\xFF\xFF\xFF\xFF")) kilo+ ]+ , bgroup "one_byte_mask"+ [ bench "current" $ nf (maskPayload (mkMask "\xCC\xCC\xCC\xCC")) kilo+ , bench "old" $ nf (maskPayload' (Just "\xCC\xCC\xCC\xCC")) kilo+ ]+ , bgroup "other_mask"+ [ bench "current" $ nf (maskPayload (mkMask "\xB0\xA2\xB0\xA2")) kilo+ , bench "old" $ nf (maskPayload' (Just "\xB0\xA2\xB0\xA2")) kilo+ ]+ ]+ , bgroup "megabyte payload"+ [ bgroup "zero_mask"+ [ bench "current" $ nf (maskPayload (mkMask "\x00\x00\x00\x00")) mega+ , bench "old" $ nf (maskPayload' (Just "\x00\x00\x00\x00")) mega+ ]+ , bgroup "full_mask"+ [ bench "current" $ nf (maskPayload (mkMask "\xFF\xFF\xFF\xFF")) mega+ , bench "current-unaligned" $ nf (maskPayload (mkMask "\xFF\xFF\xFF\xFF")) megaU+ , bench "current-aligned" $ nf (maskPayload (mkMask "\xFF\xFF\xFF\xFF")) megaS+ , bench "old" $ nf (maskPayload' (Just "\xFF\xFF\xFF\xFF")) mega+ ]+ , bgroup "one_byte_mask"+ [ bench "current" $ nf (maskPayload (mkMask "\xCC\xCC\xCC\xCC")) mega+ , bench "old" $ nf (maskPayload' (Just "\xCC\xCC\xCC\xCC")) mega+ ]+ , bgroup "other_mask"+ [ bench "current" $ nf (maskPayload (mkMask "\xB0\xA2\xB0\xA2")) mega+ , bench "old" $ nf (maskPayload' (Just "\xB0\xA2\xB0\xA2")) mega+ ]+ ]+ ]+ ]+ where+ mkMask b = Just $ Get.runGet parseMask b
+ cbits/cbits.c view
@@ -0,0 +1,72 @@+#include <stdint.h>+#include <string.h>+#include <limits.h>+#include <assert.h>++/* Taken from:+ *+ * <http://stackoverflow.com/questions/776508/best-practices-for-circular-shift-rotate-operations-in-c>+ */+static inline uint32_t rotr32(uint32_t n, unsigned int c) {+ const unsigned int mask = (CHAR_BIT*sizeof(n)-1);+ c &= mask; /* avoid undef behaviour with NDEBUG. 0 overhead for most types / compilers */+ return (n>>c) | (n<<( (-c)&mask ));+}++/* - `mask` is the 4-byte mask to apply to the source. It is stored in the+ * hosts' native byte ordering.+ * - `mask_offset` is the initial offset in the mask. It is specified in bytes+ * and should be between 0 and 3 (inclusive). This is necessary for when we+ * are dealing with multiple chunks.+ * - `src` is the source pointer.+ * - `len` is the size of the source (and destination) in bytes.+ * - `dst` is the destination.+ */+void _hs_mask_chunk(+ uint32_t mask, int mask_offset,+ uint8_t *src, size_t len,+ uint8_t *dst) {+ const uint8_t *src_end = src + len;++ /* We have two fast paths: one for `x86_64` and one for `i386`+ * architectures. In these fast paths, we mask 8 (or 4) bytes at a time.+ *+ * Note that we use unaligned loads and stores (allowed on these+ * architectures). This makes the code much easier to write, since we don't+ * need to guarantee that `src` and `dst` have the same alignment.+ *+ * It only causes a minor slowdown, around 5% on my machine (TM).+ */+#if defined(__x86_64__)+ uint64_t mask64;+ /* Set up 64 byte mask. */+ mask64 = (uint64_t)(rotr32(mask, 8 * mask_offset));+ mask64 |= (mask64 << 32);+ /* Take the fast road. */+ while (src < src_end - 7) {+ *(uint64_t *)dst = *(uint64_t*)src ^ mask64;+ src += 8;+ dst += 8;+ }+#elif defined(__i386__)+ /* Set up 32 byte mask. */+ uint32_t mask32;+ mask32 = (uint32_t)(rotr32(mask, 8 * mask_offset));++ /* Take the fast road. */+ while (src < src_end - 3) {+ *(uint32_t *)dst = *(uint32_t*)src ^ mask32;+ src += 4;+ dst += 4;+ }+#endif++ /* This is the slow path which also handles the un-aligned suffix. */+ uint8_t *mask_ptr = (uint8_t *) &mask;+ while (src != src_end) {+ *dst = *src ^ *(mask_ptr + mask_offset);+ src++;+ dst++;+ mask_offset = (mask_offset + 1) & 0x3;+ }+}
+ example/client.hs view
@@ -0,0 +1,40 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+module Main+ ( main+ ) where+++--------------------------------------------------------------------------------+import Control.Concurrent (forkIO)+import Control.Monad (forever, unless)+import Control.Monad.Trans (liftIO)+import Network.Socket (withSocketsDo)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Network.WebSockets as WS+++--------------------------------------------------------------------------------+app :: WS.ClientApp ()+app conn = do+ putStrLn "Connected!"++ -- Fork a thread that writes WS data to stdout+ _ <- forkIO $ forever $ do+ msg <- WS.receiveData conn+ liftIO $ T.putStrLn msg++ -- Read from stdin and write to WS+ let loop = do+ line <- T.getLine+ unless (T.null line) $ WS.sendTextData conn line >> loop++ loop+ WS.sendClose conn ("Bye!" :: Text)+++--------------------------------------------------------------------------------+main :: IO ()+main = withSocketsDo $ WS.runClient "echo.websocket.org" 80 "/" app
example/server.lhs view
@@ -3,11 +3,11 @@ This is the Haskell implementation of the example for the WebSockets library. We implement a simple multi-user chat program. A live demo of the example is-available [here](http://jaspervdj.be/websockets-example). In order to understand-this example, keep the [reference](http://jaspervdj.be/websockets/reference)-nearby to check out the functions we use.+available [here](/example/client.html). In order to understand this example,+keep the [reference](/reference/) nearby to check out the functions we use. > {-# LANGUAGE OverloadedStrings #-}+> module Main where > import Data.Char (isPunctuation, isSpace) > import Data.Monoid (mappend) > import Data.Text (Text)@@ -70,7 +70,7 @@ > main :: IO () > main = do > state <- newMVar newServerState-> WS.runServer "0.0.0.0" 9160 $ application state+> WS.runServer "127.0.0.1" 9160 $ application state Our main application has the type: @@ -88,64 +88,64 @@ > 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 conn state client-> 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. -> talk :: WS.Connection -> MVar ServerState -> Client -> IO ()-> talk conn state (user, _) = forever $ do+> talk :: Client -> MVar ServerState -> IO ()+> talk (user, conn) state = forever $ do > msg <- WS.receiveData conn > readMVar state >>= broadcast > (user `mappend` ": " `mappend` msg)
src/Network/WebSockets.hs view
@@ -4,10 +4,14 @@ ( -- * Incoming connections and handshaking PendingConnection , pendingRequest- , AcceptRequest(..) , acceptRequest+ , AcceptRequest(..)+ , defaultAcceptRequest , acceptRequestWith , rejectRequest+ , RejectRequest(..)+ , defaultRejectRequest+ , rejectRequestWith -- * Main connection type , Connection@@ -16,15 +20,27 @@ , ConnectionOptions (..) , defaultConnectionOptions + -- ** Compression options+ , CompressionOptions (..)+ , PermessageDeflate (..)+ , defaultPermessageDeflate++ -- ** Protection limits+ , SizeLimit (..)+ -- * Sending and receiving messages , receive , receiveDataMessage , receiveData , send , sendDataMessage+ , sendDataMessages , sendTextData+ , sendTextDatas , sendBinaryData+ , sendBinaryDatas , sendClose+ , sendCloseCode , sendPing -- * HTTP Types@@ -49,6 +65,9 @@ , ServerApp , runServer , runServerWith+ , ServerOptions (..)+ , defaultServerOptions+ , runServerWithOptions -- * Utilities for writing your own server , makeListenSocket@@ -61,8 +80,13 @@ , runClientWith , runClientWithSocket , runClientWithStream+ , newClientConnection -- * Utilities+ , PingPongOptions(..)+ , defaultPingPongOptions+ , withPingPong+ , withPingThread , forkPingThread ) where @@ -70,6 +94,7 @@ -------------------------------------------------------------------------------- import Network.WebSockets.Client import Network.WebSockets.Connection+import Network.WebSockets.Connection.PingPong import Network.WebSockets.Http import Network.WebSockets.Server import Network.WebSockets.Types
src/Network/WebSockets/Client.hs view
@@ -7,16 +7,26 @@ , runClientWith , runClientWithSocket , runClientWithStream+ , newClientConnection+ -- * Low level functionality+ , createRequest+ , Protocol(..)+ , defaultProtocol+ , checkServerResponse+ , streamToClientConnection ) where ---------------------------------------------------------------------------------import qualified Blaze.ByteString.Builder as Builder+import qualified Data.ByteString.Builder as Builder import Control.Exception (bracket, finally, throwIO)+import Control.Concurrent.MVar (newEmptyMVar)+import Control.Monad (void) import Data.IORef (newIORef) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Network.Socket as S+import System.Timeout (timeout) --------------------------------------------------------------------------------@@ -53,26 +63,32 @@ -> Headers -- ^ Custom headers to send -> ClientApp a -- ^ Client application -> IO a-runClientWith host port path opts customHeaders app = do+runClientWith host port path0 opts customHeaders app = do -- Create and connect socket let hints = S.defaultHints- {S.addrFamily = S.AF_INET, S.addrSocketType = S.Stream}+ {S.addrSocketType = S.Stream}++ -- Correct host and path. fullHost = if port == 80 then host else (host ++ ":" ++ show port)- addrInfos <- S.getAddrInfo (Just hints) (Just host) (Just $ show port)- sock <- S.socket S.AF_INET S.Stream S.defaultProtocol+ path = if null path0 then "/" else path0+ addr:_ <- S.getAddrInfo (Just hints) (Just host) (Just $ show port)+ sock <- S.socket (S.addrFamily addr) S.Stream S.defaultProtocol S.setSocketOption sock S.NoDelay 1 -- Connect WebSocket and run client- res <- finally- (S.connect sock (S.addrAddress $ head addrInfos) >>- runClientWithSocket sock fullHost path opts customHeaders app)- (S.sClose sock)+ res <- bracket+ (timeout (connectionTimeout opts * 1000 * 1000) $ S.connect sock (S.addrAddress addr))+ (const $ S.close sock) $ \maybeConnected -> case maybeConnected of+ Nothing -> throwIO $ ConnectionTimeout+ Just () -> runClientWithSocket sock fullHost path opts customHeaders app + -- Clean up return res --------------------------------------------------------------------------------+ runClientWithStream :: Stream -- ^ Stream@@ -88,33 +104,75 @@ -- ^ Client application -> IO a runClientWithStream stream host path opts customHeaders app = do+ newClientConnection stream host path opts customHeaders >>= app++-- | Build a new 'Connection' from the client's point of view.+--+-- /WARNING/: Be sure to call 'Stream.close' on the given 'Stream' after you are+-- done using the 'Connection' in order to properly close the communication+-- channel. 'runClientWithStream' handles this for you, prefer to use it when+-- possible.+newClientConnection+ :: Stream+ -- ^ Stream that will be used by the new 'Connection'.+ -> String+ -- ^ Host+ -> String+ -- ^ Path+ -> ConnectionOptions+ -- ^ Connection options+ -> Headers+ -- ^ Custom headers to send+ -> IO Connection+newClientConnection stream host path opts customHeaders = do -- 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 Nothing -> throwIO $ OtherHandshakeException $- "Network.WebSockets.Client.runClientWithStream: no handshake " +++ "Network.WebSockets.Client.newClientConnection: no handshake " ++ "response from server"- -- Note that we pattern match to evaluate the result here- Response _ _ <- return $ finishResponse protocol request response- parse <- decodeMessages protocol stream- write <- encodeMessages protocol ClientConnection stream- sentRef <- newIORef False+ void $ either throwIO return $ finishResponse protocol request response+ where+ protocol = defaultProtocol -- TODO - app Connection++-- | 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+ heartbeat <- newEmptyMVar+ return $ Connection { connectionOptions = opts , connectionType = ClientConnection , connectionProtocol = protocol , connectionParse = parse , connectionWrite = write+ , connectionHeartbeat = heartbeat , 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
@@ -1,13 +1,16 @@ ----------------------------------------------------------------------------------- | This module exposes connection internals and should only be used if you--- really know what you are doing.+-- | This module exposes connection internals {-# LANGUAGE OverloadedStrings #-} module Network.WebSockets.Connection ( PendingConnection (..)- , AcceptRequest(..) , acceptRequest+ , AcceptRequest(..)+ , defaultAcceptRequest , acceptRequestWith , rejectRequest+ , RejectRequest(..)+ , defaultRejectRequest+ , rejectRequestWith , Connection (..) @@ -19,35 +22,63 @@ , receiveData , send , sendDataMessage+ , sendDataMessages , sendTextData+ , sendTextDatas , sendBinaryData+ , sendBinaryDatas , sendClose , sendCloseCode , sendPing+ , sendPong + , withPingThread , forkPingThread+ , pingThread++ , CompressionOptions (..)+ , PermessageDeflate (..)+ , defaultPermessageDeflate++ , SizeLimit (..) ) where ---------------------------------------------------------------------------------import qualified Blaze.ByteString.Builder as Builder-import Control.Concurrent (forkIO, threadDelay)-import Control.Exception (AsyncException, fromException,- handle, throwIO)-import Control.Monad (unless)-import qualified Data.ByteString as B-import Data.IORef (IORef, newIORef, readIORef,- writeIORef)-import Data.List (find)-import qualified Data.Text as T-import Data.Word (Word16)+import Control.Applicative ((<$>))+import Control.Concurrent (forkIO,+ threadDelay)+import qualified Control.Concurrent.Async as Async+import Control.Concurrent.MVar (MVar, newEmptyMVar, tryPutMVar)+import Control.Exception (AsyncException,+ fromException,+ handle,+ throwIO)+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,+ readIORef,+ writeIORef)+import Data.List (find)+import Data.Maybe (catMaybes)+import qualified Data.Text as T+import Data.Word (Word16)+import Prelude --------------------------------------------------------------------------------+import Network.WebSockets.Connection.Options+import Network.WebSockets.Extensions as Extensions+import Network.WebSockets.Extensions.PermessageDeflate+import Network.WebSockets.Extensions.StrictUnicode import Network.WebSockets.Http import Network.WebSockets.Protocol-import Network.WebSockets.Stream (Stream)-import qualified Network.WebSockets.Stream as Stream+import Network.WebSockets.Stream (Stream)+import qualified Network.WebSockets.Stream as Stream import Network.WebSockets.Types @@ -68,15 +99,26 @@ --------------------------------------------------------------------------------+-- | This datatype allows you to set options for 'acceptRequestWith'. It is+-- strongly recommended to use 'defaultAcceptRequest' and then modify the+-- various fields, that way new fields introduced in the library do not break+-- your code. data AcceptRequest = AcceptRequest { acceptSubprotocol :: !(Maybe B.ByteString) -- ^ The subprotocol to speak with the client. If 'pendingSubprotcols' is -- non-empty, 'acceptSubprotocol' must be one of the subprotocols from the -- list.+ , acceptHeaders :: !Headers+ -- ^ Extra headers to send with the response. } --------------------------------------------------------------------------------+defaultAcceptRequest :: AcceptRequest+defaultAcceptRequest = AcceptRequest Nothing []+++-------------------------------------------------------------------------------- -- | Utility sendResponse :: PendingConnection -> Response -> IO () sendResponse pc rsp = Stream.write (pendingStream pc)@@ -84,53 +126,140 @@ --------------------------------------------------------------------------------+-- | Accept a pending connection, turning it into a 'Connection'. acceptRequest :: PendingConnection -> IO Connection-acceptRequest pc = acceptRequestWith pc $ AcceptRequest Nothing+acceptRequest pc = acceptRequestWith pc defaultAcceptRequest --------------------------------------------------------------------------------+-- | This function is like 'acceptRequest' but allows you to set custom options+-- using the 'AcceptRequest' datatype. acceptRequestWith :: PendingConnection -> AcceptRequest -> IO Connection acceptRequestWith pc ar = case find (flip compatible request) protocols of Nothing -> do sendResponse pc $ response400 versionHeader "" throwIO NotSupported Just protocol -> do++ -- Get requested list of exceptions from client.+ rqExts <- either throwIO return $+ getRequestSecWebSocketExtensions request++ -- Set up permessage-deflate extension if configured.+ pmdExt <- case connectionCompressionOptions (pendingOptions pc) of+ NoCompression -> return Nothing+ PermessageDeflateCompression pmd0 ->+ case negotiateDeflate (connectionMessageDataSizeLimit options) (Just pmd0) rqExts of+ Left err -> do+ rejectRequestWith pc defaultRejectRequest {rejectMessage = B8.pack err}+ throwIO NotSupported+ Right pmd1 -> return (Just pmd1)++ -- Set up strict utf8 extension if configured.+ let unicodeExt =+ if connectionStrictUnicode (pendingOptions pc)+ then Just strictUnicode else Nothing++ -- Final extension list.+ let exts = catMaybes [pmdExt, unicodeExt]+ let subproto = maybe [] (\p -> [("Sec-WebSocket-Protocol", p)]) $ acceptSubprotocol ar- response = finishRequest protocol request subproto- sendResponse pc response- parse <- decodeMessages protocol (pendingStream pc)- write <- encodeMessages protocol ServerConnection (pendingStream pc)+ headers = subproto ++ acceptHeaders ar ++ concatMap extHeaders exts+ response = finishRequest protocol request headers - sentRef <- newIORef False+ either throwIO (sendResponse pc) response++ parseRaw <- decodeMessages+ protocol+ (connectionFramePayloadSizeLimit options)+ (connectionMessageDataSizeLimit options)+ (pendingStream pc)+ writeRaw <- encodeMessages protocol ServerConnection (pendingStream pc)++ write <- foldM (\x ext -> extWrite ext x) writeRaw exts+ parse <- foldM (\x ext -> extParse ext x) parseRaw exts++ sentRef <- newIORef False+ heartbeat <- newEmptyMVar let connection = Connection- { connectionOptions = pendingOptions pc+ { connectionOptions = options , connectionType = ServerConnection , connectionProtocol = protocol , connectionParse = parse , connectionWrite = write+ , connectionHeartbeat = heartbeat , connectionSentClose = sentRef } pendingOnAccept pc connection return connection where+ options = pendingOptions pc request = pendingRequest pc versionHeader = [("Sec-WebSocket-Version", B.intercalate ", " $ concatMap headerVersions protocols)] ---------------------------------------------------------------------------------rejectRequest :: PendingConnection -> B.ByteString -> IO ()-rejectRequest pc message = sendResponse pc $ response400 [] message+-- | Parameters that allow you to tweak how a request is rejected. Please use+-- 'defaultRejectRequest' and modify fields using record syntax so your code+-- will not break when new fields are added.+data RejectRequest = RejectRequest+ { -- | The status code, 400 by default.+ rejectCode :: !Int+ , -- | The message, "Bad Request" by default+ rejectMessage :: !B.ByteString+ , -- | Extra headers to be sent with the response.+ rejectHeaders :: Headers+ , -- | Reponse body of the rejection.+ rejectBody :: !B.ByteString+ } --------------------------------------------------------------------------------+defaultRejectRequest :: RejectRequest+defaultRejectRequest = RejectRequest+ { rejectCode = 400+ , rejectMessage = "Bad Request"+ , rejectHeaders = []+ , rejectBody = ""+ }+++--------------------------------------------------------------------------------+rejectRequestWith+ :: PendingConnection -- ^ Connection to reject+ -> RejectRequest -- ^ Params on how to reject the request+ -> IO ()+rejectRequestWith pc reject = sendResponse pc $ Response+ ResponseHead+ { responseCode = rejectCode reject+ , responseMessage = rejectMessage reject+ , responseHeaders = rejectHeaders reject+ }+ (rejectBody reject)+++--------------------------------------------------------------------------------+-- | Requires calling 'pendingStream' and 'Stream.close'.+rejectRequest+ :: PendingConnection -- ^ Connection to reject+ -> B.ByteString -- ^ Rejection response body+ -> IO ()+rejectRequest pc body = rejectRequestWith pc+ defaultRejectRequest {rejectBody = body}+++-------------------------------------------------------------------------------- data Connection = Connection { connectionOptions :: !ConnectionOptions , connectionType :: !ConnectionType , connectionProtocol :: !Protocol+ , connectionHeartbeat :: !(MVar ())+ -- ^ This MVar is filled whenever a pong is received. This is used by+ -- 'withPingPong' to timeout the connection if a pong is not received. , connectionParse :: !(IO (Maybe Message))- , connectionWrite :: !(Message -> IO ())+ , connectionWrite :: !([Message] -> IO ()) , 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@@ -141,22 +270,6 @@ ----------------------------------------------------------------------------------- | Set options for a 'Connection'.-data ConnectionOptions = ConnectionOptions- { connectionOnPong :: !(IO ())- -- ^ Whenever a 'pong' is received, this IO action is executed. It can be- -- used to tickle connections or fire missiles.- }------------------------------------------------------------------------------------defaultConnectionOptions :: ConnectionOptions-defaultConnectionOptions = ConnectionOptions- { connectionOnPong = return ()- }----------------------------------------------------------------------------------- receive :: Connection -> IO Message receive conn = do mbMsg <- connectionParse conn@@ -180,13 +293,14 @@ receiveDataMessage conn = do msg <- receive conn case msg of- DataMessage am -> return am- ControlMessage cm -> case cm of+ DataMessage _ _ _ am -> return am+ ControlMessage cm -> case cm of Close i closeMsg -> do hasSentClose <- readIORef $ connectionSentClose conn unless hasSentClose $ send conn msg throwIO $ CloseRequest i closeMsg Pong _ -> do+ _ <- tryPutMVar (connectionHeartbeat conn) () connectionOnPong (connectionOptions conn) receiveDataMessage conn Ping pl -> do@@ -197,40 +311,62 @@ -------------------------------------------------------------------------------- -- | Receive a message, converting it to whatever format is needed. receiveData :: WebSocketsData a => Connection -> IO a-receiveData conn = do- dm <- receiveDataMessage conn- case dm of- Text x -> return (fromLazyByteString x)- Binary x -> return (fromLazyByteString x)+receiveData conn = fromDataMessage <$> receiveDataMessage conn -------------------------------------------------------------------------------- send :: Connection -> Message -> IO ()-send conn msg = do- case msg of- (ControlMessage (Close _ _)) ->- writeIORef (connectionSentClose conn) True- _ -> return ()- connectionWrite conn msg+send conn = sendAll conn . return +--------------------------------------------------------------------------------+sendAll :: Connection -> [Message] -> IO ()+sendAll _ [] = return ()+sendAll conn msgs = do+ when (any isCloseMessage msgs) $+ writeIORef (connectionSentClose conn) True+ connectionWrite conn msgs+ where+ isCloseMessage (ControlMessage (Close _ _)) = True+ isCloseMessage _ = False ----------------------------------------------------------------------------------- | Send a 'DataMessage'+-- | Send a 'DataMessage'. This allows you send both human-readable text and+-- binary data. This is a slightly more low-level interface than 'sendTextData'+-- or 'sendBinaryData'. sendDataMessage :: Connection -> DataMessage -> IO ()-sendDataMessage conn = send conn . DataMessage+sendDataMessage conn = sendDataMessages conn . return +--------------------------------------------------------------------------------+-- | Send a collection of 'DataMessage's. This is more efficient than calling+-- 'sendDataMessage' many times.+sendDataMessages :: Connection -> [DataMessage] -> IO ()+sendDataMessages conn = sendAll conn . map (DataMessage False False False) ----------------------------------------------------------------------------------- | Send a message as text+-- | Send a textual message. The message will be encoded as UTF-8. This should+-- be the default choice for human-readable text-based protocols such as JSON. sendTextData :: WebSocketsData a => Connection -> a -> IO ()-sendTextData conn = sendDataMessage conn . Text . toLazyByteString+sendTextData conn = sendTextDatas conn . return +--------------------------------------------------------------------------------+-- | Send a number of textual messages. This is more efficient than calling+-- 'sendTextData' many times.+sendTextDatas :: WebSocketsData a => Connection -> [a] -> IO ()+sendTextDatas conn =+ sendDataMessages conn .+ map (\x -> Text (toLazyByteString x) Nothing) ----------------------------------------------------------------------------------- | Send a message as binary data+-- | Send a binary message. This is useful for sending binary blobs, e.g.+-- images, data encoded with MessagePack, images... sendBinaryData :: WebSocketsData a => Connection -> a -> IO ()-sendBinaryData conn = sendDataMessage conn . Binary . toLazyByteString+sendBinaryData conn = sendBinaryDatas conn . return +--------------------------------------------------------------------------------+-- | Send a number of binary messages. This is more efficient than calling+-- 'sendBinaryData' many times.+sendBinaryDatas :: WebSocketsData a => Connection -> [a] -> IO ()+sendBinaryDatas conn = sendDataMessages conn . map (Binary . toLazyByteString) -------------------------------------------------------------------------------- -- | Send a friendly close message. Note that after sending this message,@@ -260,21 +396,60 @@ sendPing :: WebSocketsData a => Connection -> a -> IO () sendPing conn = send conn . ControlMessage . Ping . toLazyByteString +--------------------------------------------------------------------------------+-- | Send a pong+sendPong :: WebSocketsData a => Connection -> a -> IO ()+sendPong conn = send conn . ControlMessage . Pong . toLazyByteString -------------------------------------------------------------------------------- -- | 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.+--+-- Note that usually you want to use 'Network.WebSockets.Connection.PingPong.withPingPong'+-- to timeout the connection if a pong is not received.+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/Connection/Options.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE CPP #-}+--------------------------------------------------------------------------------+module Network.WebSockets.Connection.Options+ ( ConnectionOptions (..)+ , defaultConnectionOptions++ , CompressionOptions (..)+ , PermessageDeflate (..)+ , defaultPermessageDeflate++ , SizeLimit (..)+ , atMostSizeLimit+ ) where+++--------------------------------------------------------------------------------+import Data.Int (Int64)+import Data.Monoid (Monoid (..))+import Prelude+++--------------------------------------------------------------------------------+-- | Set options for a 'Connection'. Please do not use this constructor+-- directly, but rather use 'defaultConnectionOptions' and then set the fields+-- you want, e.g.:+--+-- > myOptions = defaultConnectionOptions {connectionStrictUnicode = True}+--+-- This way your code does not break if the library introduces new fields.+data ConnectionOptions = ConnectionOptions+ { connectionOnPong :: !(IO ())+ -- ^ Whenever a 'pong' is received, this IO action is executed. It can be+ -- used to tickle connections or fire missiles.+ , connectionTimeout :: !Int+ -- ^ Timeout for connection establishment in seconds. Only used in the client.+ , connectionCompressionOptions :: !CompressionOptions+ -- ^ Enable 'PermessageDeflate'.+ , connectionStrictUnicode :: !Bool+ -- ^ Enable strict unicode on the connection. This means that if a client+ -- (or server) sends invalid UTF-8, we will throw a 'UnicodeException'+ -- rather than replacing it by the unicode replacement character U+FFFD.+ , connectionFramePayloadSizeLimit :: !SizeLimit+ -- ^ The maximum size for incoming frame payload size in bytes. If a+ -- frame exceeds this limit, a 'ParseException' is thrown.+ , connectionMessageDataSizeLimit :: !SizeLimit+ -- ^ 'connectionFrameSizeLimit' is often not enough since a malicious+ -- client can send many small frames to create a huge message. This limit+ -- allows you to protect from that. If a message exceeds this limit, a+ -- 'ParseException' is thrown.+ --+ -- Note that, if compression is enabled, we check the size of the+ -- compressed messages, as well as the size of the uncompressed messages+ -- as we are deflating them to ensure we don't use too much memory in any+ -- case.+ }+++--------------------------------------------------------------------------------+-- | The default connection options:+--+-- * Nothing happens when a pong is received.+-- * Compression is disabled.+-- * Lenient unicode decoding.+-- * 30 second timeout for connection establishment.+defaultConnectionOptions :: ConnectionOptions+defaultConnectionOptions = ConnectionOptions+ { connectionOnPong = return ()+ , connectionTimeout = 30+ , connectionCompressionOptions = NoCompression+ , connectionStrictUnicode = False+ , connectionFramePayloadSizeLimit = mempty+ , connectionMessageDataSizeLimit = mempty+ }+++--------------------------------------------------------------------------------+data CompressionOptions+ = NoCompression+ | PermessageDeflateCompression PermessageDeflate+ deriving (Eq, Show)+++--------------------------------------------------------------------------------+-- | Four extension parameters are defined for "permessage-deflate" to+-- help endpoints manage per-connection resource usage.+--+-- - "server_no_context_takeover"+-- - "client_no_context_takeover"+-- - "server_max_window_bits"+-- - "client_max_window_bits"+data PermessageDeflate = PermessageDeflate+ { serverNoContextTakeover :: Bool+ , clientNoContextTakeover :: Bool+ , serverMaxWindowBits :: Int+ , clientMaxWindowBits :: Int+ , pdCompressionLevel :: Int+ } deriving (Eq, Show)+++--------------------------------------------------------------------------------+defaultPermessageDeflate :: PermessageDeflate+defaultPermessageDeflate = PermessageDeflate False False 15 15 8+++--------------------------------------------------------------------------------+-- | A size limit, in bytes. The 'Monoid' instance takes the minimum limit.+data SizeLimit+ = NoSizeLimit+ | SizeLimit !Int64+ deriving (Eq, Show)+++--------------------------------------------------------------------------------+instance Monoid SizeLimit where+ mempty = NoSizeLimit++#if !MIN_VERSION_base(4,11,0)+ mappend NoSizeLimit y = y+ mappend x NoSizeLimit = x+ mappend (SizeLimit x) (SizeLimit y) = SizeLimit (min x y)+#else+instance Semigroup SizeLimit where+ (<>) NoSizeLimit y = y+ (<>) x NoSizeLimit = x+ (<>) (SizeLimit x) (SizeLimit y) = SizeLimit (min x y)+#endif++--------------------------------------------------------------------------------+atMostSizeLimit :: Int64 -> SizeLimit -> Bool+atMostSizeLimit _ NoSizeLimit = True+atMostSizeLimit s (SizeLimit l) = s <= l+{-# INLINE atMostSizeLimit #-}
+ src/Network/WebSockets/Connection/PingPong.hs view
@@ -0,0 +1,62 @@+module Network.WebSockets.Connection.PingPong+ ( withPingPong+ , PingPongOptions(..)+ , PongTimeout(..)+ , defaultPingPongOptions+ ) where ++import Control.Concurrent.Async as Async+import Control.Exception+import Control.Monad (void)+import Network.WebSockets.Connection (Connection, connectionHeartbeat, pingThread)+import Control.Concurrent.MVar (takeMVar)+import System.Timeout (timeout)+++-- | Exception type used to kill connections if there+-- is a pong timeout.+data PongTimeout = PongTimeout deriving Show++instance Exception PongTimeout+++-- | Options for ping-pong+-- +-- Make sure that the ping interval is less than the pong timeout,+-- for example N/2.+data PingPongOptions = PingPongOptions {+ pingInterval :: Int, -- ^ Interval in seconds+ pongTimeout :: Int, -- ^ Timeout in seconds+ pingAction :: IO () -- ^ Action to perform after sending a ping+}++-- | Default options for ping-pong+-- +-- Ping every 15 seconds, timeout after 30 seconds+defaultPingPongOptions :: PingPongOptions+defaultPingPongOptions = PingPongOptions {+ pingInterval = 15,+ pongTimeout = 30,+ pingAction = return ()+}++-- | Run an application with ping-pong enabled. Raises PongTimeout if a pong is not received.+-- +-- Can used with Client and Server connections.+withPingPong :: PingPongOptions -> Connection -> (Connection -> IO ()) -> IO ()+withPingPong options connection app = void $ + withAsync (app connection) $ \appAsync -> do+ withAsync (pingThread connection (pingInterval options) (pingAction options)) $ \pingAsync -> do+ withAsync (heartbeat >> throwIO PongTimeout) $ \heartbeatAsync -> do+ waitAnyCancel [appAsync, pingAsync, heartbeatAsync]+ where+ heartbeat = whileJust $ timeout (pongTimeout options * 1000 * 1000) + $ takeMVar (connectionHeartbeat connection)++ -- Loop until action returns Nothing+ whileJust :: IO (Maybe a) -> IO ()+ whileJust action = do+ result <- action+ case result of+ Nothing -> return ()+ Just _ -> whileJust action
+ src/Network/WebSockets/Extensions.hs view
@@ -0,0 +1,24 @@+module Network.WebSockets.Extensions+ ( ExtensionDescription (..)+ , ExtensionDescriptions+ , parseExtensionDescriptions++ , NegotiateExtension+ , Extension (..)+ ) where++import Network.WebSockets.Extensions.Description+import Network.WebSockets.Http+import Network.WebSockets.Types++type NegotiateExtension = ExtensionDescriptions -> Either String Extension++-- | An extension is currently allowed to set extra headers and transform the+-- parse/write functions of 'Connection'.+--+-- This type is very likely to change as other extensions are introduced.+data Extension = Extension+ { extHeaders :: Headers+ , extParse :: IO (Maybe Message) -> IO (IO (Maybe Message))+ , extWrite :: ([Message] -> IO ()) -> IO ([Message] -> IO ())+ }
+ src/Network/WebSockets/Extensions/Description.hs view
@@ -0,0 +1,65 @@+-- | Code for parsing extensions headers.+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Network.WebSockets.Extensions.Description+ ( ExtensionParam+ , ExtensionDescription (..)+ , ExtensionDescriptions++ , parseExtensionDescriptions+ , encodeExtensionDescriptions+ ) where++import Control.Applicative ((*>), (<*))+import qualified Data.Attoparsec.ByteString as A+import qualified Data.Attoparsec.ByteString.Char8 as AC8+import qualified Data.ByteString as B+import Data.Monoid (mconcat, mappend)+import Prelude++type ExtensionParam = (B.ByteString, Maybe B.ByteString)++data ExtensionDescription = ExtensionDescription+ { extName :: !B.ByteString+ , extParams :: ![ExtensionParam]+ } deriving (Eq, Show)++parseExtensionDescription :: A.Parser ExtensionDescription+parseExtensionDescription = do+ extName <- parseIdentifier+ extParams <- A.many' (token ';' *> parseParam)+ return ExtensionDescription {..}+ where+ parseIdentifier = AC8.takeWhile isIdentifierChar <* AC8.skipSpace++ token c = AC8.char8 c <* AC8.skipSpace++ isIdentifierChar c =+ (c >= 'a' && c <= 'z') ||+ (c >= 'A' && c <= 'Z') ||+ (c >= '0' && c <= '9') ||+ c == '-' || c == '_'++ parseParam :: A.Parser ExtensionParam+ parseParam = do+ name <- parseIdentifier+ val <- A.option Nothing $ fmap Just $ token '=' *> parseIdentifier+ return (name, val)++encodeExtensionDescription :: ExtensionDescription -> B.ByteString+encodeExtensionDescription ExtensionDescription {..} =+ mconcat (extName : map encodeParam extParams)+ where+ encodeParam (key, Nothing) = ";" `mappend` key+ encodeParam (key, Just val) = ";" `mappend` key `mappend` "=" `mappend` val++type ExtensionDescriptions = [ExtensionDescription]++parseExtensionDescriptions :: B.ByteString -> Either String ExtensionDescriptions+parseExtensionDescriptions = A.parseOnly $+ AC8.skipSpace *>+ A.sepBy parseExtensionDescription (AC8.char8 ',' <* AC8.skipSpace) <*+ A.endOfInput++encodeExtensionDescriptions :: ExtensionDescriptions -> B.ByteString+encodeExtensionDescriptions = B.intercalate "," . map encodeExtensionDescription
+ src/Network/WebSockets/Extensions/PermessageDeflate.hs view
@@ -0,0 +1,287 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+module Network.WebSockets.Extensions.PermessageDeflate+ ( defaultPermessageDeflate+ , PermessageDeflate(..)+ , negotiateDeflate++ -- * Considered internal+ , makeMessageInflater+ , makeMessageDeflater+ ) where+++--------------------------------------------------------------------------------+import Control.Applicative ((<$>))+import Control.Exception (throwIO)+import Control.Monad (foldM, unless)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BL8+import qualified Data.ByteString.Lazy.Internal as BL+import Data.Int (Int64)+import Data.Monoid+import qualified Data.Streaming.Zlib as Zlib+import Network.WebSockets.Connection.Options+import Network.WebSockets.Extensions+import Network.WebSockets.Extensions.Description+import Network.WebSockets.Http+import Network.WebSockets.Types+import Prelude+import Text.Read (readMaybe)+++--------------------------------------------------------------------------------+-- | Convert the parameters to an 'ExtensionDescription' that we can put in a+-- 'Sec-WebSocket-Extensions' header.+toExtensionDescription :: PermessageDeflate -> ExtensionDescription+toExtensionDescription PermessageDeflate {..} = ExtensionDescription+ { extName = "permessage-deflate"+ , extParams =+ [("server_no_context_takeover", Nothing) | serverNoContextTakeover] +++ [("client_no_context_takeover", Nothing) | clientNoContextTakeover] +++ [("server_max_window_bits", param serverMaxWindowBits) | serverMaxWindowBits /= 15] +++ [("client_max_window_bits", param clientMaxWindowBits) | clientMaxWindowBits /= 15]+ }+ where+ param = Just . B8.pack . show+++--------------------------------------------------------------------------------+toHeaders :: PermessageDeflate -> Headers+toHeaders pmd =+ [ ( "Sec-WebSocket-Extensions"+ , encodeExtensionDescriptions [toExtensionDescription pmd]+ )+ ]+++--------------------------------------------------------------------------------+negotiateDeflate+ :: SizeLimit -> Maybe PermessageDeflate -> NegotiateExtension+negotiateDeflate messageLimit pmd0 exts0 = do+ (headers, pmd1) <- negotiateDeflateOpts exts0 pmd0+ return Extension+ { extHeaders = headers+ , extParse = \parseRaw -> do+ inflate <- makeMessageInflater messageLimit pmd1+ return $ do+ msg <- parseRaw+ case msg of+ Nothing -> return Nothing+ Just m -> fmap Just (inflate m)++ , extWrite = \writeRaw -> do+ deflate <- makeMessageDeflater pmd1+ return $ \msgs ->+ mapM deflate msgs >>= writeRaw+ }+ where+ negotiateDeflateOpts+ :: ExtensionDescriptions+ -> Maybe PermessageDeflate+ -> Either String (Headers, Maybe PermessageDeflate)++ negotiateDeflateOpts (ext : _) (Just x)+ | extName ext == "x-webkit-deflate-frame" = Right+ ([("Sec-WebSocket-Extensions", "x-webkit-deflate-frame")], Just x)++ negotiateDeflateOpts (ext : _) (Just x)+ | extName ext == "permessage-deflate" = do+ x' <- foldM setParam x (extParams ext)+ Right (toHeaders x', Just x')++ negotiateDeflateOpts (_ : exts) (Just x) =+ negotiateDeflateOpts exts (Just x)++ negotiateDeflateOpts _ _ = Right ([], Nothing)+++--------------------------------------------------------------------------------+setParam+ :: PermessageDeflate -> ExtensionParam -> Either String PermessageDeflate+setParam pmd ("server_no_context_takeover", _) =+ Right pmd {serverNoContextTakeover = True}++setParam pmd ("client_no_context_takeover", _) =+ Right pmd {clientNoContextTakeover = True}++setParam pmd ("server_max_window_bits", Nothing) =+ Right pmd {serverMaxWindowBits = 15}++setParam pmd ("server_max_window_bits", Just param) = do+ w <- parseWindow param+ Right pmd {serverMaxWindowBits = w}++setParam pmd ("client_max_window_bits", Nothing) = do+ Right pmd {clientMaxWindowBits = 15}++setParam pmd ("client_max_window_bits", Just param) = do+ w <- parseWindow param+ Right pmd {clientMaxWindowBits = w}++setParam pmd (_, _) = Right pmd+++--------------------------------------------------------------------------------+parseWindow :: B.ByteString -> Either String Int+parseWindow bs8 = case readMaybe (B8.unpack bs8) of+ Just w+ | w >= 8 && w <= 15 -> Right w+ | otherwise -> Left $ "Window out of bounds: " ++ show w+ Nothing -> Left $ "Can't parse window: " ++ show bs8+++--------------------------------------------------------------------------------+-- | If the window_bits parameter is set to 8, we must set it to 9 instead.+--+-- Related issues:+-- - https://github.com/haskell/zlib/issues/11+-- - https://github.com/madler/zlib/issues/94+--+-- Quote from zlib manual:+--+-- For the current implementation of deflate(), a windowBits value of 8 (a+-- window size of 256 bytes) is not supported. As a result, a request for 8 will+-- result in 9 (a 512-byte window). In that case, providing 8 to inflateInit2()+-- will result in an error when the zlib header with 9 is checked against the+-- initialization of inflate(). The remedy is to not use 8 with deflateInit2()+-- with this initialization, or at least in that case use 9 with inflateInit2().+fixWindowBits :: Int -> Int+fixWindowBits n+ | n < 9 = 9+ | n > 15 = 15+ | otherwise = n+++--------------------------------------------------------------------------------+appTailL :: BL.ByteString+appTailL = BL.pack [0x00,0x00,0xff,0xff]+++--------------------------------------------------------------------------------+maybeStrip :: BL.ByteString -> BL.ByteString+maybeStrip x | appTailL `BL.isSuffixOf` x = BL.take (BL.length x - 4) x+maybeStrip x = x+++--------------------------------------------------------------------------------+rejectExtensions :: Message -> IO Message+rejectExtensions (DataMessage rsv1 rsv2 rsv3 _) | rsv1 || rsv2 || rsv3 =+ throwIO $ CloseRequest 1002 "Protocol Error"+rejectExtensions x = return x+++--------------------------------------------------------------------------------+makeMessageDeflater+ :: Maybe PermessageDeflate -> IO (Message -> IO Message)+makeMessageDeflater Nothing = return rejectExtensions+makeMessageDeflater (Just pmd)+ | serverNoContextTakeover pmd = do+ return $ \msg -> do+ ptr <- initDeflate pmd+ deflateMessageWith (deflateBody ptr) msg+ | otherwise = do+ ptr <- initDeflate pmd+ return $ \msg ->+ deflateMessageWith (deflateBody ptr) msg+ where+ ----------------------------------------------------------------------------+ initDeflate :: PermessageDeflate -> IO Zlib.Deflate+ initDeflate PermessageDeflate {..} =+ Zlib.initDeflate+ pdCompressionLevel+ (Zlib.WindowBits (- (fixWindowBits serverMaxWindowBits)))+++ ----------------------------------------------------------------------------+ deflateMessageWith+ :: (BL.ByteString -> IO BL.ByteString)+ -> Message -> IO Message+ deflateMessageWith deflater (DataMessage False False False (Text x _)) = do+ x' <- deflater x+ return (DataMessage True False False (Text x' Nothing))+ deflateMessageWith deflater (DataMessage False False False (Binary x)) = do+ x' <- deflater x+ return (DataMessage True False False (Binary x'))+ deflateMessageWith _ x = return x+++ ----------------------------------------------------------------------------+ deflateBody :: Zlib.Deflate -> BL.ByteString -> IO BL.ByteString+ deflateBody ptr = fmap maybeStrip . go . BL.toChunks+ where+ go [] =+ dePopper (Zlib.flushDeflate ptr)+ go (c : cs) = do+ chunk <- Zlib.feedDeflate ptr c >>= dePopper+ (chunk <>) <$> go cs+++--------------------------------------------------------------------------------+dePopper :: Zlib.Popper -> IO BL.ByteString+dePopper p = p >>= \res -> case res of+ Zlib.PRDone -> return BL.empty+ Zlib.PRNext c -> BL.chunk c <$> dePopper p+ Zlib.PRError x -> throwIO $ CloseRequest 1002 (BL8.pack (show x))+++--------------------------------------------------------------------------------+makeMessageInflater+ :: SizeLimit -> Maybe PermessageDeflate+ -> IO (Message -> IO Message)+makeMessageInflater _ Nothing = return rejectExtensions+makeMessageInflater messageLimit (Just pmd)+ | clientNoContextTakeover pmd =+ return $ \msg -> do+ ptr <- initInflate pmd+ inflateMessageWith (inflateBody ptr) msg+ | otherwise = do+ ptr <- initInflate pmd+ return $ \msg ->+ inflateMessageWith (inflateBody ptr) msg+ where+ --------------------------------------------------------------------------------+ initInflate :: PermessageDeflate -> IO Zlib.Inflate+ initInflate PermessageDeflate {..} =+ Zlib.initInflate+ (Zlib.WindowBits (- (fixWindowBits clientMaxWindowBits)))+++ ----------------------------------------------------------------------------+ inflateMessageWith+ :: (BL.ByteString -> IO BL.ByteString)+ -> Message -> IO Message+ inflateMessageWith inflater (DataMessage True a b (Text x _)) = do+ x' <- inflater x+ return (DataMessage False a b (Text x' Nothing))+ inflateMessageWith inflater (DataMessage True a b (Binary x)) = do+ x' <- inflater x+ return (DataMessage False a b (Binary x'))+ inflateMessageWith _ x = return x+++ ----------------------------------------------------------------------------+ inflateBody :: Zlib.Inflate -> BL.ByteString -> IO BL.ByteString+ inflateBody ptr =+ go 0 . BL.toChunks . (<> appTailL)+ where+ go :: Int64 -> [B.ByteString] -> IO BL.ByteString+ go size0 [] = do+ chunk <- Zlib.flushInflate ptr+ checkSize (fromIntegral (B.length chunk) + size0)+ return (BL.fromStrict chunk)+ go size0 (c : cs) = do+ chunk <- Zlib.feedInflate ptr c >>= dePopper+ let size1 = size0 + BL.length chunk+ checkSize size1+ (chunk <>) <$> go size1 cs+++ ----------------------------------------------------------------------------+ checkSize :: Int64 -> IO ()+ checkSize size = unless (atMostSizeLimit size messageLimit) $ throwIO $+ ParseException $ "Message of size " ++ show size ++ " exceeded limit"
+ src/Network/WebSockets/Extensions/StrictUnicode.hs view
@@ -0,0 +1,40 @@+--------------------------------------------------------------------------------+module Network.WebSockets.Extensions.StrictUnicode+ ( strictUnicode+ ) where+++--------------------------------------------------------------------------------+import Control.Exception (throwIO)+import qualified Data.ByteString.Lazy as BL+import Network.WebSockets.Extensions+import Network.WebSockets.Types+++--------------------------------------------------------------------------------+strictUnicode :: Extension+strictUnicode = Extension+ { extHeaders = []+ , extParse = \parseRaw -> return (parseRaw >>= strictParse)+ , extWrite = return+ }+++--------------------------------------------------------------------------------+strictParse :: Maybe Message -> IO (Maybe Message)+strictParse Nothing = return Nothing+strictParse (Just (DataMessage rsv1 rsv2 rsv3 (Text bl _))) =+ case decodeUtf8Strict bl of+ Left err -> throwIO err+ Right txt ->+ return (Just (DataMessage rsv1 rsv2 rsv3 (Text bl (Just txt))))+strictParse (Just msg@(ControlMessage (Close _ bl))) =+ -- If there is a body, the first two bytes of the body MUST be a 2-byte+ -- unsigned integer (in network byte order) representing a status code with+ -- value /code/ defined in Section 7.4. Following the 2-byte integer, the+ -- body MAY contain UTF-8-encoded data with value /reason/, the+ -- interpretation of which is not defined by this specification.+ case decodeUtf8Strict (BL.drop 2 bl) of+ Left err -> throwIO err+ Right _ -> return (Just msg)+strictParse (Just msg) = return (Just msg)
src/Network/WebSockets/Http.hs view
@@ -26,24 +26,26 @@ , getResponseHeader , getRequestSecWebSocketVersion , getRequestSubprotocols+ , getRequestSecWebSocketExtensions ) where ---------------------------------------------------------------------------------import qualified Blaze.ByteString.Builder as Builder-import qualified Blaze.ByteString.Builder.Char.Utf8 as Builder-import Control.Applicative (pure, (*>), (<$>), (<*),- (<*>))-import Control.Exception (Exception, throw)-import qualified Data.Attoparsec.ByteString as A-import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import Data.ByteString.Char8 ()-import qualified Data.ByteString.Char8 as BC-import Data.ByteString.Internal (c2w)-import qualified Data.CaseInsensitive as CI-import Data.Dynamic (Typeable)-import Data.Monoid (mappend, mconcat)+import qualified Data.ByteString.Builder as Builder+import qualified Data.ByteString.Builder.Extra as Builder+import Control.Applicative (pure, (*>), (<$>),+ (<*), (<*>))+import Control.Exception (Exception)+import qualified Data.Attoparsec.ByteString as A+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.ByteString.Char8 ()+import qualified Data.ByteString.Char8 as BC+import Data.ByteString.Internal (c2w)+import qualified Data.CaseInsensitive as CI+import Data.Dynamic (Typeable)+import Data.Monoid (mappend, mconcat)+import qualified Network.WebSockets.Extensions.Description as Extensions --------------------------------------------------------------------------------@@ -98,7 +100,9 @@ | MalformedResponse ResponseHead String -- | The request was well-formed, but the library user rejected it. -- (e.g. "unknown path")- | RequestRejected Request String+ | RequestRejected RequestHead ResponseHead+ -- | The connection timed out+ | ConnectionTimeout -- | for example "EOF came too early" (which is actually a parse error) -- or for your own errors. (like "unknown path"?) | OtherHandshakeException String@@ -112,21 +116,21 @@ -------------------------------------------------------------------------------- encodeRequestHead :: RequestHead -> Builder.Builder encodeRequestHead (RequestHead path headers _) =- Builder.copyByteString "GET " `mappend`- Builder.copyByteString path `mappend`- Builder.copyByteString " HTTP/1.1" `mappend`- Builder.fromByteString "\r\n" `mappend`+ Builder.byteStringCopy "GET " `mappend`+ Builder.byteStringCopy path `mappend`+ Builder.byteStringCopy " HTTP/1.1" `mappend`+ Builder.byteString "\r\n" `mappend` mconcat (map header headers) `mappend`- Builder.copyByteString "\r\n"+ Builder.byteStringCopy "\r\n" where- header (k, v) = mconcat $ map Builder.copyByteString+ header (k, v) = mconcat $ map Builder.byteStringCopy [CI.original k, ": ", v, "\r\n"] -------------------------------------------------------------------------------- encodeRequest :: Request -> Builder.Builder encodeRequest (Request head' body) =- encodeRequestHead head' `mappend` Builder.copyByteString body+ encodeRequestHead head' `mappend` Builder.byteStringCopy body --------------------------------------------------------------------------------@@ -149,22 +153,22 @@ -- | Encode an HTTP upgrade response encodeResponseHead :: ResponseHead -> Builder.Builder encodeResponseHead (ResponseHead code msg headers) =- Builder.copyByteString "HTTP/1.1 " `mappend`- Builder.fromString (show code) `mappend`- Builder.fromChar ' ' `mappend`- Builder.fromByteString msg `mappend`- Builder.fromByteString "\r\n" `mappend`+ Builder.byteStringCopy "HTTP/1.1 " `mappend`+ Builder.stringUtf8 (show code) `mappend`+ Builder.charUtf8 ' ' `mappend`+ Builder.byteString msg `mappend`+ Builder.byteString "\r\n" `mappend` mconcat (map header headers) `mappend`- Builder.copyByteString "\r\n"+ Builder.byteStringCopy "\r\n" where- header (k, v) = mconcat $ map Builder.copyByteString+ header (k, v) = mconcat $ map Builder.byteStringCopy [CI.original k, ": ", v, "\r\n"] -------------------------------------------------------------------------------- encodeResponse :: Response -> Builder.Builder encodeResponse (Response head' body) =- encodeResponseHead head' `mappend` Builder.copyByteString body+ encodeResponseHead head' `mappend` Builder.byteStringCopy body --------------------------------------------------------------------------------@@ -192,8 +196,9 @@ space = A.word8 (c2w ' ') newline = A.string "\r\n" - code = A.string "HTTP/1.1" *> space *> A.takeWhile1 (/= c2w ' ') <* space- message = A.takeWhile1 (/= c2w '\r') <* newline+ code = A.string "HTTP/1.1" *> space *> A.takeWhile1 digit <* space+ digit = \x -> x >= c2w '0' && x <= c2w '9'+ message = A.takeWhile (/= c2w '\r') <* newline --------------------------------------------------------------------------------@@ -204,20 +209,20 @@ -------------------------------------------------------------------------------- getRequestHeader :: RequestHead -> CI.CI ByteString- -> ByteString+ -> Either HandshakeException ByteString getRequestHeader rq key = case lookup key (requestHeaders rq) of- Just t -> t- Nothing -> throw $ MalformedRequest rq $+ Just t -> Right t+ Nothing -> Left $ MalformedRequest rq $ "Header missing: " ++ BC.unpack (CI.original key) -------------------------------------------------------------------------------- getResponseHeader :: ResponseHead -> CI.CI ByteString- -> ByteString+ -> Either HandshakeException ByteString getResponseHeader rsp key = case lookup key (responseHeaders rsp) of- Just t -> t- Nothing -> throw $ MalformedResponse rsp $+ Just t -> Right t+ Nothing -> Left $ MalformedResponse rsp $ "Header missing: " ++ BC.unpack (CI.original key) @@ -237,6 +242,19 @@ where mproto = lookup "Sec-WebSocket-Protocol" $ requestHeaders rh parse = filter (not . B.null) . BC.splitWith (\o -> o == ',' || o == ' ')+++--------------------------------------------------------------------------------+-- | Get the @Sec-WebSocket-Extensions@ header+getRequestSecWebSocketExtensions+ :: RequestHead -> Either HandshakeException Extensions.ExtensionDescriptions+getRequestSecWebSocketExtensions rq =+ case lookup "Sec-WebSocket-Extensions" (requestHeaders rq) of+ Nothing -> Right []+ Just ext -> case Extensions.parseExtensionDescriptions ext of+ Right x -> Right x+ Left err -> Left $ MalformedRequest rq $+ "Malformed Sec-WebSockets-Extensions: " ++ err --------------------------------------------------------------------------------
src/Network/WebSockets/Hybi13.hs view
@@ -5,23 +5,27 @@ ( headerVersions , finishRequest , finishResponse+ , encodeMessage , encodeMessages , decodeMessages , createRequest -- Internal (used for testing) , encodeFrame+ , parseFrame ) where ---------------------------------------------------------------------------------import qualified Blaze.ByteString.Builder as B+import qualified Data.ByteString.Builder as B import Control.Applicative (pure, (<$>))-import Control.Exception (throw)-import Control.Monad (liftM)-import qualified Data.Attoparsec.ByteString as A-import Data.Binary.Get (getWord16be,- getWord64be, runGet)+import Control.Arrow (first)+import Control.Exception (throwIO)+import Control.Monad (forM, liftM, unless,+ when)+import Data.Binary.Get (Get, getInt64be,+ getLazyByteString,+ getWord16be, getWord8) import Data.Binary.Put (putWord16be, runPut) import Data.Bits ((.&.), (.|.)) import Data.ByteString (ByteString)@@ -29,7 +33,6 @@ import Data.ByteString.Char8 () import qualified Data.ByteString.Lazy as BL import Data.Digest.Pure.SHA (bytestringDigest, sha1)-import Data.Int (Int64) import Data.IORef import Data.Monoid (mappend, mconcat, mempty)@@ -39,6 +42,7 @@ --------------------------------------------------------------------------------+import Network.WebSockets.Connection.Options import Network.WebSockets.Http import Network.WebSockets.Hybi13.Demultiplex import Network.WebSockets.Hybi13.Mask@@ -55,77 +59,88 @@ -------------------------------------------------------------------------------- finishRequest :: RequestHead -> Headers- -> Response-finishRequest reqHttp headers =- let !key = getRequestHeader reqHttp "Sec-WebSocket-Key"- !hash = hashKey key+ -> Either HandshakeException Response+finishRequest reqHttp headers = do+ !key <- getRequestHeader reqHttp "Sec-WebSocket-Key"+ let !hash = hashKey key !encoded = B64.encode hash- in response101 (("Sec-WebSocket-Accept", encoded):headers) ""+ return $ response101 (("Sec-WebSocket-Accept", encoded):headers) "" -------------------------------------------------------------------------------- finishResponse :: RequestHead -> ResponseHead- -> Response-finishResponse request response+ -> Either HandshakeException Response+finishResponse request response = do -- Response message should be one of -- -- - WebSocket Protocol Handshake -- - Switching Protocols -- -- But we don't check it for now- | responseCode response /= 101 = throw $ MalformedResponse response- "Wrong response status or message."- | responseHash /= challengeHash = throw $ MalformedResponse response- "Challenge and response hashes do not match."- | otherwise =- Response response ""- where- key = getRequestHeader request "Sec-WebSocket-Key"- responseHash = getResponseHeader response "Sec-WebSocket-Accept"- challengeHash = B64.encode $ hashKey key+ when (responseCode response == 400) $ Left $+ RequestRejected request response + when (responseCode response /= 101) $ Left $+ MalformedResponse response "Wrong response status or message." + key <- getRequestHeader request "Sec-WebSocket-Key"+ responseHash <- getResponseHeader response "Sec-WebSocket-Accept"+ let challengeHash = B64.encode $ hashKey key+ when (responseHash /= challengeHash) $ Left $+ MalformedResponse response "Challenge and response hashes do not match." + return $ Response response ""++ -------------------------------------------------------------------------------- encodeMessage :: RandomGen g => ConnectionType -> g -> Message -> (g, B.Builder)-encodeMessage conType gen msg = (gen', builder `mappend` B.flush)+encodeMessage conType gen msg = (gen', builder) where mkFrame = Frame True False False False (mask, gen') = case conType of ServerConnection -> (Nothing, gen)- ClientConnection -> randomMask gen+ ClientConnection -> first Just (randomMask gen) builder = encodeFrame mask $ case msg of (ControlMessage (Close code pl)) -> mkFrame CloseFrame $ runPut (putWord16be code) `mappend` pl- (ControlMessage (Ping pl)) -> mkFrame PingFrame pl- (ControlMessage (Pong pl)) -> mkFrame PongFrame pl- (DataMessage (Text pl)) -> mkFrame TextFrame pl- (DataMessage (Binary pl)) -> mkFrame BinaryFrame pl+ (ControlMessage (Ping pl)) -> mkFrame PingFrame pl+ (ControlMessage (Pong pl)) -> mkFrame PongFrame pl+ (DataMessage rsv1 rsv2 rsv3 (Text pl _)) -> Frame True rsv1 rsv2 rsv3 TextFrame pl+ (DataMessage rsv1 rsv2 rsv3 (Binary pl)) -> Frame True rsv1 rsv2 rsv3 BinaryFrame pl -------------------------------------------------------------------------------- encodeMessages :: ConnectionType -> Stream- -> IO (Message -> IO ())+ -> IO ([Message] -> IO ()) encodeMessages conType stream = do genRef <- newIORef =<< newStdGen- return $ \msg -> do- builder <- atomicModifyIORef genRef $ \s -> encodeMessage conType s msg- Stream.write stream (B.toLazyByteString builder)+ return $ \msgs -> do+ builders <- forM msgs $ \msg ->+ atomicModifyIORef' genRef $ \s -> encodeMessage conType s msg+ Stream.write stream (B.toLazyByteString $ mconcat builders) ---------------------------------------------------------------------------------encodeFrame :: Mask -> Frame -> B.Builder-encodeFrame mask f = B.fromWord8 byte0 `mappend`- B.fromWord8 byte1 `mappend` len `mappend` maskbytes `mappend`- B.fromLazyByteString (maskPayload mask (framePayload f))+encodeFrame :: Maybe Mask -> Frame -> B.Builder+encodeFrame mask f = B.word8 byte0 `mappend`+ B.word8 byte1 `mappend` len `mappend` maskbytes `mappend`+ B.lazyByteString (maskPayload mask payload) where+ byte0 = fin .|. rsv1 .|. rsv2 .|. rsv3 .|. opcode fin = if frameFin f then 0x80 else 0x00 rsv1 = if frameRsv1 f then 0x40 else 0x00 rsv2 = if frameRsv2 f then 0x20 else 0x00 rsv3 = if frameRsv3 f then 0x10 else 0x00+ payload = case frameType f of+ ContinuationFrame -> framePayload f+ TextFrame -> framePayload f+ BinaryFrame -> framePayload f+ CloseFrame -> BL.take 125 $ framePayload f+ PingFrame -> BL.take 125 $ framePayload f+ PongFrame -> BL.take 125 $ framePayload f opcode = case frameType f of ContinuationFrame -> 0x00 TextFrame -> 0x01@@ -133,87 +148,85 @@ CloseFrame -> 0x08 PingFrame -> 0x09 PongFrame -> 0x0a- (maskflag, maskbytes) = case mask of Nothing -> (0x00, mempty)- Just m -> (0x80, B.fromByteString m)+ Just m -> (0x80, encodeMask m) byte1 = maskflag .|. lenflag- len' = BL.length (framePayload f)+ len' = BL.length payload (lenflag, len) | len' < 126 = (fromIntegral len', mempty)- | len' < 0x10000 = (126, B.fromWord16be (fromIntegral len'))- | otherwise = (127, B.fromWord64be (fromIntegral len'))+ | len' < 0x10000 = (126, B.word16BE (fromIntegral len'))+ | otherwise = (127, B.word64BE (fromIntegral len')) -------------------------------------------------------------------------------- decodeMessages- :: Stream+ :: SizeLimit+ -> SizeLimit+ -> Stream -> IO (IO (Maybe Message))-decodeMessages stream = do+decodeMessages frameLimit messageLimit stream = do dmRef <- newIORef emptyDemultiplexState return $ go dmRef where go dmRef = do- mbFrame <- Stream.parse stream parseFrame+ mbFrame <- Stream.parseBin stream (parseFrame frameLimit) case mbFrame of Nothing -> return Nothing Just frame -> do- mbMsg <- atomicModifyIORef dmRef $- \s -> swap $ demultiplex s frame- case mbMsg of- Nothing -> go dmRef- Just msg -> return (Just msg)+ demultiplexResult <- atomicModifyIORef' dmRef $+ \s -> swap $ demultiplex messageLimit s frame+ case demultiplexResult of+ DemultiplexError err -> throwIO err+ DemultiplexContinue -> go dmRef+ DemultiplexSuccess msg -> return (Just msg) -------------------------------------------------------------------------------- -- | Parse a frame-parseFrame :: A.Parser Frame-parseFrame = do- byte0 <- A.anyWord8+parseFrame :: SizeLimit -> Get Frame+parseFrame frameSizeLimit = do+ byte0 <- getWord8 let fin = byte0 .&. 0x80 == 0x80 rsv1 = byte0 .&. 0x40 == 0x40 rsv2 = byte0 .&. 0x20 == 0x20 rsv3 = byte0 .&. 0x10 == 0x10 opcode = byte0 .&. 0x0f - ft <- case opcode of- 0x00 -> return ContinuationFrame- 0x01 -> return TextFrame- 0x02 -> return BinaryFrame- 0x08 -> return CloseFrame- 0x09 -> return PingFrame- 0x0a -> return PongFrame- _ -> fail $ "Unknown opcode: " ++ show opcode-- byte1 <- A.anyWord8+ byte1 <- getWord8 let mask = byte1 .&. 0x80 == 0x80- lenflag = fromIntegral (byte1 .&. 0x7f)+ lenflag = byte1 .&. 0x7f len <- case lenflag of- 126 -> fromIntegral . runGet' getWord16be <$> A.take 2- 127 -> fromIntegral . runGet' getWord64be <$> A.take 8- _ -> return lenflag+ 126 -> fromIntegral <$> getWord16be+ 127 -> getInt64be+ _ -> return (fromIntegral lenflag) - masker <- maskPayload <$> if mask then Just <$> A.take 4 else pure Nothing+ -- Check size against limit.+ unless (atMostSizeLimit len frameSizeLimit) $+ fail $ "Frame of size " ++ show len ++ " exceeded limit" - chunks <- take64 len+ ft <- case opcode of+ 0x00 -> return ContinuationFrame+ 0x01 -> return TextFrame+ 0x02 -> return BinaryFrame+ 0x08 -> enforceControlFrameRestrictions len fin >> return CloseFrame+ 0x09 -> enforceControlFrameRestrictions len fin >> return PingFrame+ 0x0a -> enforceControlFrameRestrictions len fin >> return PongFrame+ _ -> fail $ "Unknown opcode: " ++ show opcode - return $ Frame fin rsv1 rsv2 rsv3 ft (masker $ BL.fromChunks chunks)- where- runGet' g = runGet g . BL.fromChunks . return+ masker <- maskPayload <$> if mask then Just <$> parseMask else pure Nothing - take64 :: Int64 -> A.Parser [ByteString]- take64 n- | n <= 0 = return []- | otherwise = do- let n' = min intMax n- chunk <- A.take (fromIntegral n')- (chunk :) <$> take64 (n - n')- where- intMax :: Int64- intMax = fromIntegral (maxBound :: Int)+ chunks <- getLazyByteString len + return $ Frame fin rsv1 rsv2 rsv3 ft (masker chunks)++ where+ enforceControlFrameRestrictions len fin+ | not fin = fail "Control Frames must not be fragmented!"+ | len > 125 = fail "Control Frames must not carry payload > 125 bytes!"+ | otherwise = pure () -------------------------------------------------------------------------------- hashKey :: ByteString -> ByteString
src/Network/WebSockets/Hybi13/Demultiplex.hs view
@@ -1,26 +1,27 @@ -------------------------------------------------------------------------------- -- | Demultiplexing of frames into messages-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-} module Network.WebSockets.Hybi13.Demultiplex ( FrameType (..) , Frame (..) , DemultiplexState , emptyDemultiplexState+ , DemultiplexResult (..) , demultiplex ) where ---------------------------------------------------------------------------------import Blaze.ByteString.Builder (Builder)-import qualified Blaze.ByteString.Builder as B-import Control.Exception (Exception, throw)-import Data.Binary.Get (runGet, getWord16be)-import qualified Data.ByteString.Lazy as BL-import Data.Monoid (mappend)-import Data.Typeable (Typeable)-----------------------------------------------------------------------------------+import Data.ByteString.Builder (Builder)+import qualified Data.ByteString.Builder as B+import Control.Exception (Exception)+import Data.Binary.Get (getWord16be, runGet)+import qualified Data.ByteString.Lazy as BL+import Data.Int (Int64)+import Data.Monoid (mappend)+import Data.Typeable (Typeable)+import Network.WebSockets.Connection.Options import Network.WebSockets.Types @@ -62,7 +63,7 @@ -- | Internal state used by the demultiplexer data DemultiplexState = EmptyDemultiplexState- | DemultiplexState !FrameType !Builder+ | DemultiplexState !Int64 !Builder !(Builder -> Message) --------------------------------------------------------------------------------@@ -71,40 +72,31 @@ ---------------------------------------------------------------------------------demultiplex :: DemultiplexState+-- | Result of demultiplexing+data DemultiplexResult+ = DemultiplexSuccess Message+ | DemultiplexError ConnectionException+ | DemultiplexContinue+++--------------------------------------------------------------------------------+demultiplex :: SizeLimit+ -> DemultiplexState -> Frame- -> (Maybe Message, DemultiplexState)-demultiplex state (Frame fin _ _ _ tp pl) = case tp of- -- Return control messages immediately, they have no influence on the state- CloseFrame -> (Just (ControlMessage (uncurry Close parsedClose)), state)- PingFrame -> (Just (ControlMessage (Ping pl)), state)- PongFrame -> (Just (ControlMessage (Pong pl)), state)- -- If we're dealing with a continuation...- ContinuationFrame -> case state of- -- We received a continuation but we don't have any state. Let's ignore- -- this fragment...- EmptyDemultiplexState -> (Nothing, EmptyDemultiplexState)- -- Append the payload to the state- -- TODO: protect against overflows- DemultiplexState amt b- | not fin -> (Nothing, DemultiplexState amt b')- | otherwise -> case amt of- TextFrame -> (Just (DataMessage (Text m)), e)- BinaryFrame -> (Just (DataMessage (Binary m)), e)- _ -> throw DemultiplexException- where- b' = b `mappend` plb- m = B.toLazyByteString b'- TextFrame- | fin -> (Just (DataMessage (Text pl)), e)- | otherwise -> (Nothing, DemultiplexState TextFrame plb)- BinaryFrame- | fin -> (Just (DataMessage (Binary pl)), e)- | otherwise -> (Nothing, DemultiplexState BinaryFrame plb)- where- e = emptyDemultiplexState- plb = B.fromLazyByteString pl+ -> (DemultiplexResult, DemultiplexState) +demultiplex _ state (Frame True False False False PingFrame pl)+ | BL.length pl > 125 =+ (DemultiplexError $ CloseRequest 1002 "Protocol Error", emptyDemultiplexState)+ | otherwise =+ (DemultiplexSuccess $ ControlMessage (Ping pl), state)++demultiplex _ state (Frame True False False False PongFrame pl) =+ (DemultiplexSuccess (ControlMessage (Pong pl)), state)++demultiplex _ _ (Frame True False False False CloseFrame pl) =+ (DemultiplexSuccess (ControlMessage (uncurry Close parsedClose)), emptyDemultiplexState)+ where -- The Close frame MAY contain a body (the "Application data" portion of the -- frame) that indicates a reason for closing, such as an endpoint shutting -- down, an endpoint having received a frame too large, or an endpoint@@ -113,5 +105,53 @@ -- be a 2-byte unsigned integer (in network byte order) representing a -- status code with value /code/ defined in Section 7.4. parsedClose- | BL.length pl >= 2 = (runGet getWord16be pl, BL.drop 2 pl)- | otherwise = (1000, BL.empty)+ | BL.length pl >= 2 = case runGet getWord16be pl of+ a | a < 1000 || a `elem` [1004,1005,1006+ ,1014,1015,1016+ ,1100,2000,2999+ ,5000,65535] -> (1002, BL.empty)+ a -> (a, BL.drop 2 pl)+ | BL.length pl == 1 = (1002, BL.empty)+ | otherwise = (1000, BL.empty)++demultiplex sizeLimit EmptyDemultiplexState (Frame fin rsv1 rsv2 rsv3 tp pl) = case tp of+ _ | not (atMostSizeLimit size sizeLimit) ->+ ( DemultiplexError $ ParseException $+ "Message of size " ++ show size ++ " exceeded limit"+ , emptyDemultiplexState+ )++ TextFrame+ | fin ->+ (DemultiplexSuccess (text pl), emptyDemultiplexState)+ | otherwise ->+ (DemultiplexContinue, DemultiplexState size plb (text . B.toLazyByteString))+++ BinaryFrame+ | fin -> (DemultiplexSuccess (binary pl), emptyDemultiplexState)+ | otherwise -> (DemultiplexContinue, DemultiplexState size plb (binary . B.toLazyByteString))++ _ -> (DemultiplexError $ CloseRequest 1002 "Protocol Error", emptyDemultiplexState)++ where+ size = BL.length pl+ plb = B.lazyByteString pl+ text x = DataMessage rsv1 rsv2 rsv3 (Text x Nothing)+ binary x = DataMessage rsv1 rsv2 rsv3 (Binary x)++demultiplex sizeLimit (DemultiplexState size0 b f) (Frame fin False False False ContinuationFrame pl)+ | not (atMostSizeLimit size1 sizeLimit) =+ ( DemultiplexError $ ParseException $+ "Message of size " ++ show size1 ++ " exceeded limit"+ , emptyDemultiplexState+ )+ | fin = (DemultiplexSuccess (f b'), emptyDemultiplexState)+ | otherwise = (DemultiplexContinue, DemultiplexState size1 b' f)+ where+ size1 = size0 + BL.length pl+ b' = b `mappend` plb+ plb = B.lazyByteString pl++demultiplex _ _ _ =+ (DemultiplexError (CloseRequest 1002 "Protocol Error"), emptyDemultiplexState)
src/Network/WebSockets/Hybi13/Mask.hs view
@@ -1,46 +1,81 @@ -------------------------------------------------------------------------------- -- | Masking of fragmes using a simple XOR algorithm-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} module Network.WebSockets.Hybi13.Mask ( Mask- , maskPayload+ , parseMask+ , encodeMask , randomMask++ , maskPayload ) where ---------------------------------------------------------------------------------import Data.Bits (shiftR, xor)-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import System.Random (RandomGen, random)+import qualified Data.ByteString.Builder as Builder+import qualified Data.ByteString.Builder.Extra as Builder+import Data.Binary.Get (Get, getWord32host)+import qualified Data.ByteString.Internal as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Internal as BL+import Data.Word (Word32, Word8)+import Foreign.C.Types (CChar (..), CInt (..),+ CSize (..))+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Ptr (Ptr, plusPtr)+import System.Random (RandomGen, random) ----------------------------------------------------------------------------------- | ByteString should be exactly 4 bytes long-type Mask = Maybe B.ByteString+foreign import ccall unsafe "_hs_mask_chunk" c_mask_chunk+ :: Word32 -> CInt -> Ptr CChar -> CSize -> Ptr Word8 -> IO () ----------------------------------------------------------------------------------- | Apply mask-maskPayload :: Mask -> BL.ByteString -> BL.ByteString-maskPayload Nothing = id-maskPayload (Just mask) = snd . BL.mapAccumL f 0- where- len = B.length mask- f !i !c =- let i' = (i + 1) `mod` len- m = mask `B.index` i- in (i', m `xor` c)+-- | A mask is sequence of 4 bytes. We store this in a 'Word32' in the host's+-- native byte ordering.+newtype Mask = Mask {unMask :: Word32} --------------------------------------------------------------------------------+-- | Parse a mask.+parseMask :: Get Mask+parseMask = fmap Mask getWord32host+++--------------------------------------------------------------------------------+-- | Encode a mask+encodeMask :: Mask -> Builder.Builder+encodeMask = Builder.word32Host . unMask+++-------------------------------------------------------------------------------- -- | Create a random mask randomMask :: forall g. RandomGen g => g -> (Mask, g)-randomMask gen = (Just (B.pack [b1, b2, b3, b4]), gen')+randomMask gen = (Mask int, gen') where- (!int, !gen') = random gen :: (Int, g)- !b1 = fromIntegral $ int `mod` 0x100- !b2 = fromIntegral $ int `shiftR` 8 `mod` 0x100- !b3 = fromIntegral $ int `shiftR` 16 `mod` 0x100- !b4 = fromIntegral $ int `shiftR` 24 `mod` 0x100+ (!int, !gen') = random gen :: (Word32, g)+++--------------------------------------------------------------------------------+-- | Mask a lazy bytestring. Uses 'c_mask_chunk' under the hood.+maskPayload :: Maybe Mask -> BL.ByteString -> BL.ByteString+maskPayload Nothing = id+maskPayload (Just (Mask 0)) = id+maskPayload (Just (Mask mask)) = go 0+ where+ go _ BL.Empty = BL.Empty+ go !maskOffset (BL.Chunk (B.PS payload off len) rest) =+ BL.Chunk maskedChunk (go ((maskOffset + len) `rem` 4) rest)+ where+ maskedChunk =+ B.unsafeCreate len $ \dst ->+ withForeignPtr payload $ \src ->+ c_mask_chunk mask+ (fromIntegral maskOffset)+ (src `plusPtr` off)+ (fromIntegral len)+ dst
src/Network/WebSockets/Protocol.hs view
@@ -16,14 +16,15 @@ ---------------------------------------------------------------------------------import Data.ByteString (ByteString)-import qualified Data.ByteString as B+import Data.ByteString (ByteString)+import qualified Data.ByteString as B --------------------------------------------------------------------------------+import Network.WebSockets.Connection.Options import Network.WebSockets.Http-import qualified Network.WebSockets.Hybi13 as Hybi13-import Network.WebSockets.Stream (Stream)+import qualified Network.WebSockets.Hybi13 as Hybi13+import Network.WebSockets.Stream (Stream) import Network.WebSockets.Types @@ -56,27 +57,31 @@ ---------------------------------------------------------------------------------finishRequest :: Protocol -> RequestHead -> Headers -> Response+finishRequest+ :: Protocol -> RequestHead -> Headers -> Either HandshakeException Response finishRequest Hybi13 = Hybi13.finishRequest ---------------------------------------------------------------------------------finishResponse :: Protocol -> RequestHead -> ResponseHead -> Response+finishResponse+ :: Protocol -> RequestHead -> ResponseHead+ -> Either HandshakeException Response finishResponse Hybi13 = Hybi13.finishResponse -------------------------------------------------------------------------------- encodeMessages :: Protocol -> ConnectionType -> Stream- -> IO (Message -> IO ())+ -> IO ([Message] -> IO ()) encodeMessages Hybi13 = Hybi13.encodeMessages -------------------------------------------------------------------------------- decodeMessages- :: Protocol -> Stream+ :: Protocol -> SizeLimit -> SizeLimit -> Stream -> IO (IO (Maybe Message))-decodeMessages Hybi13 = Hybi13.decodeMessages+decodeMessages Hybi13 frameLimit messageLimit =+ Hybi13.decodeMessages frameLimit messageLimit --------------------------------------------------------------------------------
src/Network/WebSockets/Server.hs view
@@ -6,25 +6,30 @@ module Network.WebSockets.Server ( ServerApp , runServer+ , ServerOptions (..)+ , defaultServerOptions+ , runServerWithOptions , runServerWith , makeListenSocket , makePendingConnection , makePendingConnectionFromStream++ , PongTimeout ) where ---------------------------------------------------------------------------------import Control.Concurrent (forkIOWithUnmask)-import Control.Exception (allowInterrupt, bracket,+import qualified Control.Concurrent.Async as Async+import Control.Exception (bracket, bracketOnError, finally, mask_, throwIO)-import Control.Monad (forever, void) import Network.Socket (Socket) import qualified Network.Socket as S -------------------------------------------------------------------------------- import Network.WebSockets.Connection+import Network.WebSockets.Connection.PingPong (PongTimeout(..)) import Network.WebSockets.Http import qualified Network.WebSockets.Stream as Stream import Network.WebSockets.Types@@ -37,10 +42,17 @@ ----------------------------------------------------------------------------------- | Provides a simple server. This function blocks forever. Note that this--- is merely provided for quick-and-dirty standalone applications, for real+-- | Provides a simple server. This function blocks forever. Note that this+-- is merely provided for quick-and-dirty or internal applications, but for real -- applications, you should use a real server. --+-- For example:+--+-- * Performance is reasonable under load, but:+-- * No protection against DoS attacks is provided.+-- * No logging is performed.+-- * ...+-- -- Glue for using this package with real servers is provided by: -- -- * <https://hackage.haskell.org/package/wai-websockets>@@ -56,36 +68,71 @@ -------------------------------------------------------------------------------- -- | A version of 'runServer' which allows you to customize some options. runServerWith :: String -> Int -> ConnectionOptions -> ServerApp -> IO ()-runServerWith host port opts app = S.withSocketsDo $- bracket- (makeListenSocket host port)- S.sClose- (\sock ->- mask_ $ forever $ do- allowInterrupt- (conn, _) <- S.accept sock- void $ forkIOWithUnmask $ \unmask ->- finally (unmask $ runApp conn opts app) (S.sClose conn)- )+runServerWith host port opts = runServerWithOptions defaultServerOptions+ { serverHost = host+ , serverPort = port+ , serverConnectionOptions = opts+ }+{-# DEPRECATED runServerWith "Use 'runServerWithOptions' instead" #-} +--------------------------------------------------------------------------------+data ServerOptions = ServerOptions+ { serverHost :: String+ , serverPort :: Int+ , serverConnectionOptions :: ConnectionOptions+ } + --------------------------------------------------------------------------------+defaultServerOptions :: ServerOptions+defaultServerOptions = ServerOptions+ { serverHost = "127.0.0.1"+ , serverPort = 8080+ , serverConnectionOptions = defaultConnectionOptions+ }+++--------------------------------------------------------------------------------+-- | Customizable version of 'runServer'. Never returns until killed.+--+-- Please use the 'defaultServerOptions' combined with record updates to set the+-- fields you want. This way your code is unlikely to break on future changes.+runServerWithOptions :: ServerOptions -> ServerApp -> IO a+runServerWithOptions opts app = S.withSocketsDo $+ bracket+ (makeListenSocket (serverHost opts) (serverPort opts))+ S.close+ (\sock ->+ let+ mainThread = do+ (conn, _) <- S.accept sock+ Async.withAsyncWithUnmask+ (\unmask -> unmask (runApp conn (serverConnectionOptions opts) app) `finally` S.close conn)+ (\_ -> mainThread)+ in mask_ mainThread+ )+++-------------------------------------------------------------------------------- -- | 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 = bracketOnError- (S.socket S.AF_INET S.Stream S.defaultProtocol)- S.sClose+makeListenSocket host port = do+ addr:_ <- S.getAddrInfo (Just hints) (Just host) (Just (show port))+ bracketOnError+ (S.socket (S.addrFamily addr) S.Stream S.defaultProtocol)+ S.close (\sock -> do _ <- S.setSocketOption sock S.ReuseAddr 1 _ <- S.setSocketOption sock S.NoDelay 1- host' <- S.inet_addr host- S.bindSocket sock (S.SockAddrInet (fromIntegral port) host')+ S.bind sock (S.addrAddress addr) S.listen sock 5 return sock )+ where+ hints = S.defaultHints { S.addrSocketType = S.Stream } --------------------------------------------------------------------------------@@ -102,7 +149,7 @@ -------------------------------------------------------------------------------- -- | Turns a socket, connected to some client, into a 'PendingConnection'. The--- 'PendingConnection' should be closed using 'Stream.close' later.+-- 'PendingConnection' should be closed using 'pendingStream' and 'Stream.close' later. makePendingConnection :: Socket -> ConnectionOptions -> IO PendingConnection makePendingConnection socket opts = do
src/Network/WebSockets/Stream.hs view
@@ -7,18 +7,20 @@ , makeSocketStream , makeEchoStream , parse+ , parseBin , write , close ) where import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar, withMVar)-import Control.Exception (onException, throwIO)-import Control.Monad (forM_, when)+import Control.Exception (SomeException, SomeAsyncException, throwIO, catch, try, fromException)+import Control.Monad (forM_) import qualified Data.Attoparsec.ByteString as Atto+import qualified Data.Binary.Get as BIN import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL-import Data.IORef (IORef, atomicModifyIORef,+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) import qualified Network.Socket as S@@ -29,6 +31,7 @@ #else import qualified Network.Socket.ByteString as SB (sendAll) #endif+import System.IO.Error (isResourceVanishedError) import Network.WebSockets.Types @@ -57,7 +60,7 @@ -- writing from the stream will be thread-safe, i.e. this function will create -- a receive and write lock to be used internally. ----- - Reading from or writing or to a closed 'Stream' will always throw an+-- - Reading from or writing to a closed 'Stream' will always throw an -- exception, even if the underlying "receive" and "send" functions do not -- (we do the bookkeeping). --@@ -73,37 +76,54 @@ return $ Stream (receive' ref receiveLock) (send' ref sendLock) ref where closeRef :: IORef StreamState -> IO ()- closeRef ref = atomicModifyIORef ref $ \state -> case state of+ closeRef ref = atomicModifyIORef' ref $ \state -> case state of Open buf -> (Closed buf, ()) Closed buf -> (Closed buf, ()) - assertNotClosed :: IORef StreamState -> IO a -> IO a- assertNotClosed ref io = do+ -- Throw a 'ConnectionClosed' is the connection is not 'Open'.+ assertOpen :: IORef StreamState -> IO ()+ assertOpen ref = do state <- readIORef ref case state of Closed _ -> throwIO ConnectionClosed- Open _ -> io+ Open _ -> return () receive' :: IORef StreamState -> MVar () -> IO (Maybe B.ByteString)- receive' ref lock = withMVar lock $ \() -> assertNotClosed ref $ do- mbBs <- onException receive (closeRef ref)+ receive' ref lock = withMVar lock $ \() -> do+ assertOpen ref+ mbBs <- onSyncException receive (closeRef ref) case mbBs of Nothing -> closeRef ref >> return Nothing Just bs -> return (Just bs) send' :: IORef StreamState -> MVar () -> (Maybe BL.ByteString -> IO ())- send' ref lock mbBs = withMVar lock $ \() -> assertNotClosed ref $ do- when (mbBs == Nothing) (closeRef ref)- onException (send mbBs) (closeRef ref)+ send' ref lock mbBs = withMVar lock $ \() -> do+ case mbBs of+ Nothing -> closeRef ref+ Just _ -> assertOpen 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 + -------------------------------------------------------------------------------- makeSocketStream :: S.Socket -> IO Stream makeSocketStream socket = makeStream receive send where receive = do- bs <- SB.recv socket 1024- return $ if B.null bs then Nothing else Just bs+ bs <- try $ SB.recv socket 8192+ case bs of+ -- If the resource vanished, the socket was closed+ Left e | isResourceVanishedError e -> return Nothing+ | otherwise -> throwIO e+ Right bs' | B.null bs' -> return Nothing+ | otherwise -> return $ Just bs' send Nothing = return () send (Just bs) = do@@ -124,6 +144,38 @@ --------------------------------------------------------------------------------+parseBin :: Stream -> BIN.Get a -> IO (Maybe a)+parseBin stream parser = do+ state <- readIORef (streamState stream)+ case state of+ Closed remainder+ | B.null remainder -> return Nothing+ | otherwise -> go (BIN.runGetIncremental parser `BIN.pushChunk` remainder) True+ Open buffer+ | B.null buffer -> do+ mbBs <- streamIn stream+ case mbBs of+ Nothing -> do+ writeIORef (streamState stream) (Closed B.empty)+ return Nothing+ Just bs -> go (BIN.runGetIncremental parser `BIN.pushChunk` bs) False+ | otherwise -> go (BIN.runGetIncremental parser `BIN.pushChunk` buffer) False+ where+ -- Buffer is empty when entering this function.+ go (BIN.Done remainder _ x) closed = do+ writeIORef (streamState stream) $+ if closed then Closed remainder else Open remainder+ return (Just x)+ go (BIN.Partial f) closed+ | closed = go (f Nothing) True+ | otherwise = do+ mbBs <- streamIn stream+ case mbBs of+ Nothing -> go (f Nothing) True+ Just bs -> go (f (Just bs)) False+ go (BIN.Fail _ _ err) _ = throwIO (ParseException err)++ parse :: Stream -> Atto.Parser a -> IO (Maybe a) parse stream parser = do state <- readIORef (streamState stream)
src/Network/WebSockets/Types.hs view
@@ -11,18 +11,24 @@ , ConnectionException (..) , ConnectionType (..)++ , decodeUtf8Lenient+ , decodeUtf8Strict ) where ---------------------------------------------------------------------------------import Control.Exception (Exception (..))-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Encoding as TL-import Data.Typeable (Typeable)-import Data.Word (Word16)+import Control.Exception (Exception (..))+import Control.Exception (throw, try)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Data.Text.Encoding.Error as TL+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL+import Data.Typeable (Typeable)+import Data.Word (Word16)+import System.IO.Unsafe (unsafePerformIO) --------------------------------------------------------------------------------@@ -33,7 +39,8 @@ -- | The kind of message a server application typically deals with data Message = ControlMessage ControlMessage- | DataMessage DataMessage+ -- | Reserved bits, actual message+ | DataMessage Bool Bool Bool DataMessage deriving (Eq, Show) @@ -50,8 +57,21 @@ -- | For an end-user of this library, dealing with 'Frame's would be a bit -- low-level. This is why define another type on top of it, which represents -- data for the application layer.+--+-- There are currently two kinds of data messages supported by the WebSockets+-- protocol:+--+-- * Textual UTF-8 encoded data. This corresponds roughly to sending a String+-- in JavaScript.+--+-- * Binary data. This corresponds roughly to send an ArrayBuffer in+-- JavaScript. data DataMessage- = Text BL.ByteString+ -- | A textual message. The second field /might/ contain the decoded UTF-8+ -- text for caching reasons. This field is computed lazily so if it's not+ -- accessed, it should have no performance impact.+ = Text BL.ByteString (Maybe TL.Text)+ -- | A binary message. | Binary BL.ByteString deriving (Eq, Show) @@ -71,30 +91,47 @@ -- * Messages can be very large. If this is the case, it might be inefficient to -- use the strict 'B.ByteString' and 'T.Text' instances. class WebSocketsData a where+ fromDataMessage :: DataMessage -> a+ fromLazyByteString :: BL.ByteString -> a toLazyByteString :: a -> BL.ByteString -------------------------------------------------------------------------------- instance WebSocketsData BL.ByteString where+ fromDataMessage (Text bl _) = bl+ fromDataMessage (Binary bl) = bl+ fromLazyByteString = id toLazyByteString = id -------------------------------------------------------------------------------- instance WebSocketsData B.ByteString where+ fromDataMessage (Text bl _) = fromLazyByteString bl+ fromDataMessage (Binary bl) = fromLazyByteString bl+ fromLazyByteString = B.concat . BL.toChunks toLazyByteString = BL.fromChunks . return -------------------------------------------------------------------------------- instance WebSocketsData TL.Text where+ fromDataMessage (Text _ (Just tl)) = tl+ fromDataMessage (Text bl Nothing) = fromLazyByteString bl+ fromDataMessage (Binary bl) = fromLazyByteString bl++ fromLazyByteString = TL.decodeUtf8 toLazyByteString = TL.encodeUtf8 -------------------------------------------------------------------------------- instance WebSocketsData T.Text where+ fromDataMessage (Text _ (Just tl)) = T.concat (TL.toChunks tl)+ fromDataMessage (Text bl Nothing) = fromLazyByteString bl+ fromDataMessage (Binary bl) = fromLazyByteString bl+ fromLazyByteString = T.concat . TL.toChunks . fromLazyByteString toLazyByteString = toLazyByteString . TL.fromChunks . return @@ -119,9 +156,13 @@ -- | The client sent garbage, i.e. we could not parse the WebSockets stream. | ParseException String- deriving (Show, Typeable) + -- | The client sent invalid UTF-8. Note that this exception will only be+ -- thrown if strict decoding is set in the connection options.+ | UnicodeException String+ deriving (Eq, Show, Typeable) + -------------------------------------------------------------------------------- instance Exception ConnectionException @@ -129,3 +170,18 @@ -------------------------------------------------------------------------------- data ConnectionType = ServerConnection | ClientConnection deriving (Eq, Ord, Show)+++--------------------------------------------------------------------------------+-- | Replace an invalid input byte with the Unicode replacement character+-- U+FFFD.+decodeUtf8Lenient :: BL.ByteString -> TL.Text+decodeUtf8Lenient = TL.decodeUtf8With TL.lenientDecode+++--------------------------------------------------------------------------------+-- | Throw an error if there is an invalid input byte.+decodeUtf8Strict :: BL.ByteString -> Either ConnectionException TL.Text+decodeUtf8Strict bl = unsafePerformIO $ try $+ let txt = TL.decodeUtf8With (\err _ -> throw (UnicodeException err)) bl in+ TL.length txt `seq` return txt
+ tests/autobahn/server.hs view
@@ -0,0 +1,91 @@+--------------------------------------------------------------------------------+-- | The server part of the tests+{-# LANGUAGE OverloadedStrings #-}+module Main+ ( main+ ) where++{-++## once+virtualenv pyt+source pyt/bin/activate+### pip install --upgrade setuptools ### possibly+pip install autobahntestsuite++## each time+source pyt/bin/activate+mkdir -p test && cd test+wstest -m fuzzingclient+websockets-autobahn+-}+++--------------------------------------------------------------------------------+import Control.Exception (catch)+import Data.ByteString.Lazy.Char8 ()+import Data.String (fromString)+import Data.Version (showVersion)+++--------------------------------------------------------------------------------+import qualified Network.WebSockets as WS+import qualified Paths_websockets+++--------------------------------------------------------------------------------+echoDataMessage :: WS.Connection -> IO ()+echoDataMessage conn = go 0+ where+ go :: Int -> IO ()+ go x = do+ msg <- WS.receiveDataMessage conn+ WS.sendDataMessage conn msg+ go (x + 1)+++--------------------------------------------------------------------------------+infoHeaders :: WS.Headers+infoHeaders =+ [ ( "Server"+ , fromString $ "websockets/" ++ showVersion Paths_websockets.version+ )+ ]+++--------------------------------------------------------------------------------+-- | Application+application :: WS.ServerApp+application pc = do+ conn <- WS.acceptRequestWith pc WS.defaultAcceptRequest+ { WS.acceptHeaders = infoHeaders+ }+ echoDataMessage conn `catch` handleClose++ where+ handleClose (WS.CloseRequest i "") =+ putStrLn $ "Clean close (" ++ show i ++ ")"+ handleClose (WS.CloseRequest i msg) =+ putStrLn $ "Clean close (" ++ show i ++ "): " ++ show msg+ handleClose WS.ConnectionClosed =+ putStrLn "Unexpected connection closed exception"+ handleClose (WS.ParseException e) =+ putStrLn $ "Recevied parse exception: " ++ show e+ handleClose (WS.UnicodeException e) =+ putStrLn $ "Recevied unicode exception: " ++ show e+++--------------------------------------------------------------------------------+-- | Accepts clients, spawns a single handler for each one.+main :: IO ()+main = WS.runServerWithOptions options application+ where+ options = WS.defaultServerOptions+ { WS.serverHost = "0.0.0.0"+ , WS.serverPort = 9001+ , WS.serverConnectionOptions = WS.defaultConnectionOptions+ { WS.connectionCompressionOptions =+ WS.PermessageDeflateCompression WS.defaultPermessageDeflate+ , WS.connectionStrictUnicode = True+ }+ }
+ tests/haskell/Network/WebSockets/Extensions/PermessageDeflate/Tests.hs view
@@ -0,0 +1,46 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+module Network.WebSockets.Extensions.PermessageDeflate.Tests+ ( tests+ ) where+++--------------------------------------------------------------------------------+import Control.Exception (try)+import qualified Data.ByteString.Lazy as BL+import Network.WebSockets.Extensions.PermessageDeflate+import Network.WebSockets.Types+import Network.WebSockets.Connection.Options+import Test.Framework (Test,+ testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (Assertion,+ (@?=))+++--------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Network.WebSockets.Extensions.PermessageDeflate.Tests"+ [ testCase "OK 1" $ do+ inflater <- makeMessageInflater+ (SizeLimit 100) (Just defaultPermessageDeflate)+ message <- inflater $ DataMessage True False False (Binary deflated100)+ message @?=+ DataMessage False False False (Binary inflated100)+ , testCase "Exceed 1" $ do+ inflater <- makeMessageInflater+ (SizeLimit 99) (Just defaultPermessageDeflate)+ assertParseException $+ inflater $ DataMessage True False False (Binary deflated100)+ ]+ where+ assertParseException :: IO a -> Assertion+ assertParseException io = do+ errOrX <- try io+ case errOrX of+ Left (ParseException _) -> return ()+ _ -> fail "Excepted ParseException"++ -- This inflates to 100 bytes.+ deflated100 = "b`\160=\NUL\NUL"+ inflated100 = BL.replicate 100 0
+ tests/haskell/Network/WebSockets/Extensions/Tests.hs view
@@ -0,0 +1,44 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+module Network.WebSockets.Extensions.Tests+ ( tests+ ) where+++--------------------------------------------------------------------------------+import Network.WebSockets.Extensions+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@?=))+++--------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Network.WebSockets.Extensions.Tests"+ [ testCase "parseExtensionDescriptions 01" $ do+ parseExtensionDescriptions "permessage-deflate" @?= Right+ [ ExtensionDescription "permessage-deflate" [] ]++ , testCase "parseExtensionDescriptions 02" $ do+ parseExtensionDescriptions "permessage-deflate; client_max_window_bits; server_max_window_bits=10" @?= Right+ [ ExtensionDescription "permessage-deflate"+ [ ("client_max_window_bits", Nothing)+ , ("server_max_window_bits", Just "10")+ ]+ ]++ , testCase "parseExtensionDescriptions 03" $ do+ parseExtensionDescriptions "permessage-deflate; client_max_window_bits=15; server_max_window_bits=10, permessage-deflate; client_max_window_bits,permessage-deflate; client_max_window_bits=15; client_max_window_bits=10" @?= Right+ [ ExtensionDescription "permessage-deflate"+ [ ("client_max_window_bits", Just "15")+ , ("server_max_window_bits", Just "10")+ ]+ , ExtensionDescription "permessage-deflate"+ [ ("client_max_window_bits", Nothing)+ ]+ , ExtensionDescription "permessage-deflate"+ [ ("client_max_window_bits", Just "15")+ , ("client_max_window_bits", Just "10")+ ]+ ]+ ]
tests/haskell/Network/WebSockets/Handshake/Tests.hs view
@@ -29,7 +29,10 @@ tests = testGroup "Network.WebSockets.Handshake.Test" [ testCase "handshake Hybi13" testHandshakeHybi13 , testCase "handshake Hybi13 with subprotocols" testHandshakeHybi13WithProto+ , testCase "handshake Hybi13 with headers" testHandshakeHybi13WithHeaders+ , testCase "handshake Hybi13 with subprotocols and headers" testHandshakeHybi13WithProtoAndHeaders , testCase "handshake reject" testHandshakeReject+ , testCase "handshake reject with custom code" testHandshakeRejectWithCode , testCase "handshake Hybi9000" testHandshakeHybi9000 ] @@ -90,7 +93,7 @@ ResponseHead code message headers <- testHandshake rq13 $ \pc -> do getRequestSubprotocols (pendingRequest pc) @?= ["chat", "superchat"] acceptRequestWith pc {pendingOnAccept = \_ -> writeIORef onAcceptFired True}- (AcceptRequest $ Just "superchat")+ (AcceptRequest (Just "superchat") []) readIORef onAcceptFired >>= assert code @?= 101@@ -100,12 +103,59 @@ headers ! "Sec-WebSocket-Protocol" @?= "superchat" --------------------------------------------------------------------------------+testHandshakeHybi13WithHeaders :: Assertion+testHandshakeHybi13WithHeaders = do+ onAcceptFired <- newIORef False+ ResponseHead code message headers <- testHandshake rq13 $ \pc -> do+ getRequestSubprotocols (pendingRequest pc) @?= ["chat", "superchat"]+ acceptRequestWith pc {pendingOnAccept = \_ -> writeIORef onAcceptFired True}+ (AcceptRequest Nothing [("Set-Cookie","sid=foo")])++ readIORef onAcceptFired >>= assert+ code @?= 101+ message @?= "WebSocket Protocol Handshake"+ headers ! "Sec-WebSocket-Accept" @?= "HSmrc0sMlYUkAGmm5OPpG2HaGWk="+ headers ! "Connection" @?= "Upgrade"+ headers ! "Set-Cookie" @?= "sid=foo"+ lookup "Sec-WebSocket-Protocol" headers @?= Nothing++--------------------------------------------------------------------------------+testHandshakeHybi13WithProtoAndHeaders :: Assertion+testHandshakeHybi13WithProtoAndHeaders = do+ onAcceptFired <- newIORef False+ ResponseHead code message headers <- testHandshake rq13 $ \pc -> do+ getRequestSubprotocols (pendingRequest pc) @?= ["chat", "superchat"]+ acceptRequestWith pc {pendingOnAccept = \_ -> writeIORef onAcceptFired True}+ (AcceptRequest (Just "superchat") [("Set-Cookie","sid=foo")])++ readIORef onAcceptFired >>= assert+ code @?= 101+ message @?= "WebSocket Protocol Handshake"+ headers ! "Sec-WebSocket-Accept" @?= "HSmrc0sMlYUkAGmm5OPpG2HaGWk="+ headers ! "Connection" @?= "Upgrade"+ headers ! "Sec-WebSocket-Protocol" @?= "superchat"+ headers ! "Set-Cookie" @?= "sid=foo"+++-------------------------------------------------------------------------------- testHandshakeReject :: Assertion testHandshakeReject = do ResponseHead code _ _ <- testHandshake rq13 $ \pc -> rejectRequest pc "YOU SHALL NOT PASS" code @?= 400+++--------------------------------------------------------------------------------+testHandshakeRejectWithCode :: Assertion+testHandshakeRejectWithCode = do+ ResponseHead code _ _ <- testHandshake rq13 $ \pc ->+ rejectRequestWith pc defaultRejectRequest+ { rejectBody = "YOU SHALL NOT PASS"+ , rejectCode = 401+ }++ code @?= 401 --------------------------------------------------------------------------------
tests/haskell/Network/WebSockets/Http/Tests.hs view
@@ -22,6 +22,7 @@ tests = testGroup "Network.WebSockets.Http.Tests" [ testCase "jwebsockets response" jWebSocketsResponse , testCase "chromium response" chromiumResponse+ , testCase "matchbook response" matchbookResponse ] @@ -58,4 +59,30 @@ , "Content-Length:23" , "" , "No such target id: 20_1"+ ]++--------------------------------------------------------------------------------+-- | This is a specific response sent by Matchbook.com which caused trouble++matchbookResponse :: Assertion+matchbookResponse = assert $ case A.parseOnly decodeResponseHead input of+ Left err -> error err+ Right _ -> True+ where+ input = BC.intercalate "\r\n"+ [ "HTTP/1.1 101 "+ , "Date: Mon, 22 May 2017 19:39:08 GMT"+ , "Connection: upgrade"+ , "Set-Cookie: __cfduid=deadbeefdeadbeefdeadbeefdeadbeefdeadbeefdea; expires=Tue, 22-May-18 19:39:08 GMT; path=/; domain=.matchbook.com; HttpOnly"+ , "X-Content-Type-Options: nosniff"+ , "X-XSS-Protection: 1; mode=block"+ , "X-Frame-Options: DENY"+ , "Upgrade: websocket"+ , "Sec-WebSocket-Accept: dEadB33fDeadbEEfD3aDbE3Fdea="+ , "X-MB-HA: edge-socket"+ , "X-MB-HAP: haproxy01aws"+ , "Server: cloudflare-nginx"+ , "CF-RAY: 3632deadbeef5b33-HEL"+ , ""+ , "" ]
+ tests/haskell/Network/WebSockets/Hybi13/Demultiplex/Tests.hs view
@@ -0,0 +1,72 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+module Network.WebSockets.Hybi13.Demultiplex.Tests+ ( tests+ ) where+++--------------------------------------------------------------------------------+import Control.Applicative ((<$>))+import qualified Data.ByteString.Lazy as BL+import Network.WebSockets+import Network.WebSockets.Hybi13.Demultiplex+import Prelude+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (Assertion, (@=?))+++--------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Network.WebSockets.Hybi13.Demultiplex.Tests"+ [ testMessageDataSizeLimit+ ]+++--------------------------------------------------------------------------------+testMessageDataSizeLimit :: Test+testMessageDataSizeLimit = testGroup "testMessageDataSizeLimit Hybi13"+ [ testCase "OK 1" $+ Right [DataMessage False False False (Binary (mkZeroes 100))] @=?+ testDemultiplex (SizeLimit 100) (fragmented 5 20)+ , testCase "Exceeds 1" $+ assertLeft $+ testDemultiplex (SizeLimit 99) (fragmented 5 20)+ , testCase "Exceeds 2" $+ assertLeft $+ testDemultiplex (SizeLimit 100) (fragmented 6 20)+ , testCase "Exceeds 3" $+ assertLeft $+ testDemultiplex (SizeLimit 100) (fragmented 101 1)+ , testCase "Exceeds 4" $+ assertLeft $+ testDemultiplex (SizeLimit 100) (fragmented 1 101)+ ]+ where+ fragmented :: Int -> Int -> [Frame]+ fragmented n size =+ let payload = mkZeroes size in+ [Frame False False False False BinaryFrame payload] +++ replicate (n - 2) (Frame False False False False ContinuationFrame payload) +++ [Frame True False False False ContinuationFrame payload]++ mkZeroes :: Int -> BL.ByteString+ mkZeroes size = BL.replicate (fromIntegral size) 0++ assertLeft :: Either a b -> Assertion+ assertLeft (Left _) = return ()+ assertLeft (Right _) = fail "Expecting test to fail"+++--------------------------------------------------------------------------------+testDemultiplex+ :: SizeLimit+ -> [Frame]+ -> Either ConnectionException [Message]+testDemultiplex messageLimit = go emptyDemultiplexState+ where+ go _state0 [] = return []+ go state0 (frame : frames) = case demultiplex messageLimit state0 frame of+ (DemultiplexContinue, state1) -> go state1 frames+ (DemultiplexError err, _) -> Left err+ (DemultiplexSuccess m, state1) -> (m :) <$> go state1 frames
+ tests/haskell/Network/WebSockets/Mask/Tests.hs view
@@ -0,0 +1,57 @@+--------------------------------------------------------------------------------+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+module Network.WebSockets.Mask.Tests+ ( tests+ ) where+++--------------------------------------------------------------------------------+import qualified Data.Binary.Get as Get+import Data.Bits (xor)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Network.WebSockets.Hybi13.Mask+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck (Arbitrary (..), (===))+import qualified Test.QuickCheck as QC+++--------------------------------------------------------------------------------+import Network.WebSockets.Tests.Util++tests :: Test+tests = testGroup "Network.WebSockets.Masks.Tests"+ [ testProperty "correct fast masking" testMasking ]++maskPayload' :: Maybe B.ByteString -> BL.ByteString -> BL.ByteString+maskPayload' Nothing = id+maskPayload' (Just mask) = snd . BL.mapAccumL f (cycle $ B.unpack mask)+ where+ f [] !c = ([], c)+ f (m:ms) !c = (ms, m `xor` c)++newtype AMask = AMask B.ByteString deriving (Show)+instance Arbitrary AMask where+ arbitrary = do+ c1 <- arbitrary+ c2 <- arbitrary+ c3 <- arbitrary+ c4 <- arbitrary+ return (AMask (B.pack [c1,c2,c3,c4]))++newtype APkt = APkt BL.ByteString deriving (Show)+instance Arbitrary APkt where+ arbitrary = do+ b1 <- arbitraryByteString+ b2 <- arbitraryByteString+ return $ APkt (b1 `BL.append` b2) -- Just for sure to test correctly different alignments+ shrink (APkt bs) =+ map APkt [ BL.append a b | (a, b) <- zip (BL.inits bs) (tail $ BL.tails bs) ]++testMasking :: QC.Property+testMasking =+ QC.forAllShrink QC.arbitrary QC.shrink $ \(AMask mask, APkt pkt) ->+ let wmask = Get.runGet parseMask (BL.fromStrict mask)+ in maskPayload' (Just mask) pkt === maskPayload (Just wmask) pkt
tests/haskell/Network/WebSockets/Server/Tests.hs view
@@ -7,17 +7,19 @@ ---------------------------------------------------------------------------------import Control.Applicative ((<$>))+import Control.Applicative ((<$>), (<|>)) import Control.Concurrent (forkIO, killThread, threadDelay)-import Control.Exception (SomeException, handle, catch)-import Control.Monad (forM_, forever, replicateM, unless)-import Data.IORef (newIORef, readIORef, IORef,+import Control.Concurrent.Async (Async, async, cancel)+import Control.Exception (SomeException, catch, handle)+import Control.Monad (forever, replicateM, unless)+import Data.IORef (IORef, newIORef, readIORef, writeIORef) -------------------------------------------------------------------------------- import qualified Data.ByteString.Lazy as BL import Data.Text (Text)+import System.Environment (getEnvironment) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion, assert, (@=?))@@ -28,7 +30,6 @@ -------------------------------------------------------------------------------- import Network.WebSockets-import Network.WebSockets.Connection import Network.WebSockets.Tests.Util @@ -36,29 +37,78 @@ tests :: Test tests = testGroup "Network.WebSockets.Server.Tests" [ testCase "simple server/client" testSimpleServerClient+ , testCase "bulk server/client" testBulkServerClient , testCase "onPong" testOnPong+ , testCase "ipv6 server" testIpv6Server+ , testCase "reject request" testRejectRequest ] -------------------------------------------------------------------------------- testSimpleServerClient :: Assertion-testSimpleServerClient = withEchoServer 42940 "Bye" $ do+testSimpleServerClient = testServerClient "127.0.0.1" $ \conn -> mapM_ (sendTextData conn)+++--------------------------------------------------------------------------------+-- | This is a bit ugly but it seems CI services don't support ipv6 in 2018.+skipIpv6Incompatible :: Assertion -> Assertion+skipIpv6Incompatible assertion = do+ env <- getEnvironment+ case lookup "TRAVIS" env <|> lookup "CIRCLECI" env of+ Just "true" -> return ()+ _ -> assertion++--------------------------------------------------------------------------------+testIpv6Server :: Assertion+testIpv6Server = skipIpv6Incompatible $+ testServerClient "::1" $ \conn -> mapM_ (sendTextData conn)++--------------------------------------------------------------------------------+testBulkServerClient :: Assertion+testBulkServerClient = testServerClient "127.0.0.1" sendTextDatas++--------------------------------------------------------------------------------+testServerClient :: String -> (Connection -> [BL.ByteString] -> IO ()) -> Assertion+testServerClient host sendMessages = withEchoServer host 42940 "Bye" $ do texts <- map unArbitraryUtf8 <$> sample- texts' <- retry $ runClient "127.0.0.1" 42940 "/chat" $ client texts+ texts' <- runClient host 42940 "/chat" $ client texts texts @=? texts' where client :: [BL.ByteString] -> ClientApp [BL.ByteString] client texts conn = do- forM_ texts (sendTextData conn)+ sendMessages conn texts texts' <- replicateM (length texts) (receiveData conn) sendClose conn ("Bye" :: BL.ByteString) expectCloseException conn "Bye" return texts' +--------------------------------------------------------------------------------+testRejectRequest :: Assertion+testRejectRequest = withRejectingServer+ where+ client :: ClientApp ()+ client _ = error "Client should not be able to connect" + server :: ServerApp+ server pendingConnection = rejectRequest pendingConnection "Bye"++ withRejectingServer :: IO ()+ withRejectingServer = do+ serverThread <- async $ runServer "127.0.0.1" 42940 server+ waitSome+ () <- runClient "127.0.0.1" 42940 "/chat" client `catch` handler+ waitSome+ cancel serverThread+ return ()++ handler :: HandshakeException -> IO ()+ handler (RequestRejected _ response) = do+ responseCode response @=? 400+ handler exc = error $ "Unexpected exception " ++ show exc+ -------------------------------------------------------------------------------- testOnPong :: Assertion-testOnPong = withEchoServer 42941 "Bye" $ do+testOnPong = withEchoServer "127.0.0.1" 42941 "Bye" $ do gotPong <- newIORef False let opts = defaultConnectionOptions { connectionOnPong = writeIORef gotPong True@@ -89,29 +139,15 @@ waitSome :: IO () waitSome = threadDelay $ 200 * 1000 - ----------------------------------------------------------------------------------- HOLY SHIT WHAT SORT OF ATROCITY IS THIS?!?!?!------ The problem is that sometimes, the server hasn't been brought down yet--- before the next test, which will cause it not to be able to bind to the--- same port again. In this case, we just retry.------ The same is true for our client: possibly, the server is not up yet--- before we run the client. We also want to retry in that case.-retry :: IO a -> IO a-retry action = (\(_ :: SomeException) -> waitSome >> action) `handle` action------------------------------------------------------------------------------------withEchoServer :: Int -> BL.ByteString -> IO a -> IO a-withEchoServer port expectedClose action = do+withEchoServer :: String -> Int -> BL.ByteString -> IO a -> IO a+withEchoServer host port expectedClose action = do cRef <- newIORef False- serverThread <- forkIO $ retry $ runServer "0.0.0.0" port (\c -> server c `catch` handleClose cRef)+ serverThread <- async $ runServer host port (\c -> server c `catch` handleClose cRef) waitSome result <- action waitSome- killThread serverThread+ cancel serverThread closeCalled <- readIORef cRef unless closeCalled $ error "Expecting the CloseRequest exception" return result@@ -132,6 +168,8 @@ error "Unexpected connection closed exception" handleClose _ (ParseException _) = error "Unexpected parse exception"+ handleClose _ (UnicodeException _) =+ error "Unexpected unicode exception" --------------------------------------------------------------------------------@@ -144,3 +182,4 @@ msg' @=? msg handler ConnectionClosed = error "Unexpected connection closed" handler (ParseException _) = error "Unexpected parse exception"+ handler (UnicodeException _) = error "Unexpected unicode exception"
tests/haskell/Network/WebSockets/Tests.hs view
@@ -7,24 +7,16 @@ ---------------------------------------------------------------------------------import qualified Blaze.ByteString.Builder as Builder+import qualified Data.ByteString.Builder as Builder import Control.Applicative ((<$>)) import Control.Concurrent (forkIO) import Control.Exception (try)-import Control.Monad (forM_, replicateM)+import Control.Monad (replicateM)+import Data.Binary.Get (runGetOrFail) import qualified Data.ByteString.Lazy as BL import Data.List (intersperse) import Data.Maybe (catMaybes)-import Test.Framework (Test, testGroup)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.HUnit ((@=?))-import Test.QuickCheck (Arbitrary (..), Gen,- Property)-import qualified Test.QuickCheck as QC-import qualified Test.QuickCheck.Monadic as QC-----------------------------------------------------------------------------------+import Data.Monoid (mempty, mconcat) import Network.WebSockets import qualified Network.WebSockets.Hybi13 as Hybi13 import Network.WebSockets.Hybi13.Demultiplex@@ -32,6 +24,15 @@ import qualified Network.WebSockets.Stream as Stream import Network.WebSockets.Tests.Util import Network.WebSockets.Types+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.HUnit ((@=?))+import Test.QuickCheck (Arbitrary (..), Gen,+ Property)+import qualified Test.QuickCheck as QC+import qualified Test.QuickCheck.Monadic as QC+import Prelude --------------------------------------------------------------------------------@@ -39,17 +40,19 @@ tests = testGroup "Network.WebSockets.Test" [ testProperty "simple encode/decode Hybi13" (testSimpleEncodeDecode Hybi13) , testProperty "fragmented Hybi13" testFragmentedHybi13+ , testRfc_6455_5_5_1+ , testRfc_6455_5_5_2+ , testFramePayloadSizeLimit ] - -------------------------------------------------------------------------------- testSimpleEncodeDecode :: Protocol -> Property testSimpleEncodeDecode protocol = QC.monadicIO $ QC.forAllM QC.arbitrary $ \msgs -> QC.run $ do echo <- Stream.makeEchoStream- parse <- decodeMessages protocol echo+ parse <- decodeMessages protocol mempty mempty echo write <- encodeMessages protocol ClientConnection echo- _ <- forkIO $ forM_ msgs write+ _ <- forkIO $ write msgs msgs' <- catMaybes <$> replicateM (length msgs) parse Stream.close echo msgs @=? msgs'@@ -60,7 +63,7 @@ testFragmentedHybi13 = QC.monadicIO $ QC.forAllM QC.arbitrary $ \fragmented -> QC.run $ do echo <- Stream.makeEchoStream- parse <- Hybi13.decodeMessages echo+ parse <- Hybi13.decodeMessages mempty mempty echo -- is' <- Streams.filter isDataMessage =<< Hybi13.decodeMessages is -- Simple hacky encoding of all frames@@ -76,8 +79,8 @@ msgs <- filter isDataMessage <$> parseAll parse [msg | FragmentedMessage msg _ <- fragmented] @=? msgs where- isDataMessage (ControlMessage _) = False- isDataMessage (DataMessage _) = True+ isDataMessage (ControlMessage _) = False+ isDataMessage (DataMessage _ _ _ _) = True parseAll parse = do mbMsg <- try parse@@ -87,45 +90,75 @@ Right (Just msg) -> (msg :) <$> parseAll parse Right Nothing -> return [] - ---------------------------------------------------------------------------------instance Arbitrary FrameType where- arbitrary = QC.elements- [ ContinuationFrame- , TextFrame- , BinaryFrame- , CloseFrame- , PingFrame- , PongFrame- ]-+testRfc_6455_5_5_1 :: Test+testRfc_6455_5_5_1 =+ testCase "RFC 6455, 5.5: Frame encoder shall truncate control frame payload to 125 bytes" $ do+ 260 @=? BL.length (encodedFrame ContinuationFrame)+ 260 @=? BL.length (encodedFrame TextFrame)+ 260 @=? BL.length (encodedFrame BinaryFrame)+ 127 @=? BL.length (encodedFrame CloseFrame)+ 127 @=? BL.length (encodedFrame PingFrame)+ 127 @=? BL.length (encodedFrame PongFrame)+ where+ payload256 = BL.replicate 256 0+ encodedFrame ft+ = Builder.toLazyByteString+ $ Hybi13.encodeFrame Nothing (Frame True False False False ft payload256) ---------------------------------------------------------------------------------instance Arbitrary Frame where- arbitrary = do- fin <- arbitrary- rsv1 <- arbitrary- rsv2 <- arbitrary- rsv3 <- arbitrary- t <- arbitrary- payload <- case t of- TextFrame -> arbitraryUtf8- _ -> BL.pack <$> arbitrary- return $ Frame fin rsv1 rsv2 rsv3 t payload+testRfc_6455_5_5_2 :: Test+testRfc_6455_5_5_2 =+ testCase "RFC 6455, 5.5: Frame decoder shall fail if control frame payload length > 125 bytes" $+ Left (BL.drop 4 ping126, 4, errMsg) @=? runGetOrFail (Hybi13.parseFrame mempty) ping126+ where+ errMsg = "Control Frames must not carry payload > 125 bytes!"+ ping126 = mconcat+ [ "\137\254\NUL~\219\SI\190\252\219\SI\190\252\219\SI\190\252\219"+ , "\SI\190\252\219\SI\190\252\219\SI\190\252\219\SI\190\252\219"+ , "\SI\190\252\219\SI\190\252\219\SI\190\252\219\SI\190\252\219"+ , "\SI\190\252\219\SI\190\252\219\SI\190\252\219\SI\190\252\219"+ , "\SI\190\252\219\SI\190\252\219\SI\190\252\219\SI\190\252\219"+ , "\SI\190\252\219\SI\190\252\219\SI\190\252\219\SI\190\252\219"+ , "\SI\190\252\219\SI\190\252\219\SI\190\252\219\SI\190\252\219"+ , "\SI\190\252\219\SI\190\252\219\SI\190\252\219\SI\190\252\219"+ , "\SI\190\252\219\SI"+ ] +testFramePayloadSizeLimit :: Test+testFramePayloadSizeLimit = testGroup "FramePayloadSizeLimit Hybi13"+ [ testCase "OK 1" $ case parse (frame 99) of+ Right _ -> return ()+ Left _ -> fail "Expecting successful parse."+ , testCase "OK 2" $ case parse (frame 100) of+ Right _ -> return ()+ Left _ -> fail "Expecting successful parse."+ , testCase "Exceed" $ case parse (frame 101) of+ Right _ -> fail "Expecting parse to fail."+ Left _ -> return ()+ ]+ where+ parse = runGetOrFail (Hybi13.parseFrame (SizeLimit 100))+ frame n = Builder.toLazyByteString $ Hybi13.encodeFrame Nothing $+ Frame True False False False BinaryFrame (BL.replicate n 20) + -------------------------------------------------------------------------------- instance Arbitrary Message where- arbitrary = do- payload <- BL.pack <$> arbitrary- closecode <- arbitrary- QC.elements- [ ControlMessage (Close closecode payload)- , ControlMessage (Ping payload)- , ControlMessage (Pong payload)- , DataMessage (Text payload)- , DataMessage (Binary payload)- ]+ arbitrary = QC.oneof+ [ do+ payload <- BL.take 125 . BL.pack <$> arbitrary+ return $ ControlMessage (Ping payload)+ , do+ payload <- BL.take 125 . BL.pack <$> arbitrary+ return $ ControlMessage (Pong payload)+ , do+ payload <- BL.pack <$> arbitrary+ return $ DataMessage False False False (Text payload Nothing)+ , do+ payload <- BL.pack <$> arbitrary+ return $ DataMessage False False False (Binary payload)+ ] --------------------------------------------------------------------------------@@ -145,8 +178,8 @@ fragments <- arbitraryFragmentation payload let fs = makeFrames $ zip (ft : repeat ContinuationFrame) fragments msg = case ft of- TextFrame -> DataMessage (Text payload)- BinaryFrame -> DataMessage (Binary payload)+ TextFrame -> DataMessage False False False (Text payload Nothing)+ BinaryFrame -> DataMessage False False False (Binary payload) _ -> error "Arbitrary FragmentedMessage crashed" interleaved <- arbitraryInterleave genControlFrame fs@@ -160,7 +193,7 @@ genControlFrame = QC.elements [ Frame True False False False PingFrame "Herp"- , Frame True True True True PongFrame "Derp"+ , Frame True False False False PongFrame "Derp" ]
tests/haskell/TestSuite.hs view
@@ -1,19 +1,24 @@ ---------------------------------------------------------------------------------import Test.Framework (defaultMain)-----------------------------------------------------------------------------------+import qualified Network.WebSockets.Extensions.Tests+import qualified Network.WebSockets.Extensions.PermessageDeflate.Tests import qualified Network.WebSockets.Handshake.Tests import qualified Network.WebSockets.Http.Tests+import qualified Network.WebSockets.Hybi13.Demultiplex.Tests+import qualified Network.WebSockets.Mask.Tests import qualified Network.WebSockets.Server.Tests import qualified Network.WebSockets.Tests+import Test.Framework (defaultMain) -------------------------------------------------------------------------------- main :: IO () main = defaultMain- [ Network.WebSockets.Handshake.Tests.tests+ [ Network.WebSockets.Extensions.Tests.tests+ , Network.WebSockets.Extensions.PermessageDeflate.Tests.tests+ , Network.WebSockets.Handshake.Tests.tests , Network.WebSockets.Http.Tests.tests+ , Network.WebSockets.Hybi13.Demultiplex.Tests.tests , Network.WebSockets.Server.Tests.tests+ , Network.WebSockets.Mask.Tests.tests , Network.WebSockets.Tests.tests ]
websockets.cabal view
@@ -1,5 +1,5 @@ Name: websockets-Version: 0.9.8.2+Version: 0.13.0.0 Synopsis: A sensible and clean way to write WebSocket-capable servers in Haskell.@@ -24,18 +24,19 @@ License: BSD3 License-file: LICENCE Copyright: (c) 2010-2011 Siniša Biđin- (c) 2011-2013 Jasper Van der Jeugt+ (c) 2011-2018 Jasper Van der Jeugt (c) 2011 Steffen Schuldenzucker (c) 2011 Alex Lang Author: Siniša Biđin <sinisa@bidin.cc> Jasper Van der Jeugt <m@jaspervdj.be> Steffen Schuldenzucker <steffen.schuldenzucker@googlemail.com> Alex Lang <lang@tsurucapital.com>+ Domen Kožar Maintainer: Jasper Van der Jeugt <m@jaspervdj.be> Stability: experimental Category: Network Build-type: Simple-Cabal-version: >= 1.8+Cabal-version: >= 1.10 Homepage: http://jaspervdj.be/websockets Bug-reports: https://github.com/jaspervdj/websockets/issues@@ -43,6 +44,10 @@ Extra-source-files: CHANGELOG +Source-repository head+ Type: git+ Location: https://github.com/jaspervdj/websockets+ Flag Example Description: Build the example server Default: False@@ -50,16 +55,24 @@ Library Hs-source-dirs: src- Ghc-options: -Wall+ Ghc-options: -Wall+ C-sources: cbits/cbits.c+ Default-language: Haskell2010 Exposed-modules: Network.WebSockets+ Network.WebSockets.Client Network.WebSockets.Connection+ Network.WebSockets.Connection.PingPong+ 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+ Network.WebSockets.Extensions.StrictUnicode Network.WebSockets.Http Network.WebSockets.Hybi13 Network.WebSockets.Hybi13.Demultiplex@@ -69,79 +82,162 @@ Network.WebSockets.Types Build-depends:- attoparsec >= 0.10 && < 0.14,- base >= 4.4 && < 5,- base64-bytestring >= 0.1 && < 1.1,- binary >= 0.5 && < 0.9,- blaze-builder >= 0.3 && < 0.5,- bytestring >= 0.9 && < 0.11,+ async >= 2.2 && < 2.3,+ attoparsec >= 0.10 && < 0.15,+ base >= 4.14 && < 5,+ base64-bytestring >= 0.1 && < 1.3,+ binary >= 0.8.1 && < 0.11,+ bytestring >= 0.9 && < 0.13, case-insensitive >= 0.3 && < 1.3,- containers >= 0.3 && < 0.6,- network >= 2.3 && < 2.7,- random >= 1.0 && < 1.2,+ containers >= 0.3 && < 0.7,+ network >= 2.3 && < 3.2,+ random >= 1.0.1 && < 1.3, SHA >= 1.5 && < 1.7,- text >= 0.10 && < 1.3,- entropy >= 0.2.1 && < 0.4+ streaming-commons >= 0.1 && < 0.3,+ text >= 0.10 && < 2.2,+ entropy >= 0.2.1 && < 0.5 Test-suite websockets-tests- Type: exitcode-stdio-1.0- Hs-source-dirs: src tests/haskell- Main-is: TestSuite.hs- Ghc-options: -Wall+ Type: exitcode-stdio-1.0+ Hs-source-dirs: src tests/haskell+ Main-is: TestSuite.hs+ Ghc-options: -Wall+ C-sources: cbits/cbits.c+ Default-language: Haskell2010 Other-modules:+ Network.WebSockets+ Network.WebSockets.Client+ Network.WebSockets.Connection+ Network.WebSockets.Connection.Options+ Network.WebSockets.Connection.PingPong+ Network.WebSockets.Extensions+ Network.WebSockets.Extensions.Description+ Network.WebSockets.Extensions.PermessageDeflate+ Network.WebSockets.Extensions.PermessageDeflate.Tests+ Network.WebSockets.Extensions.StrictUnicode+ Network.WebSockets.Extensions.Tests Network.WebSockets.Handshake.Tests+ Network.WebSockets.Http Network.WebSockets.Http.Tests+ Network.WebSockets.Hybi13+ Network.WebSockets.Hybi13.Demultiplex+ Network.WebSockets.Hybi13.Demultiplex.Tests+ Network.WebSockets.Hybi13.Mask+ Network.WebSockets.Mask.Tests+ Network.WebSockets.Protocol+ Network.WebSockets.Server Network.WebSockets.Server.Tests+ Network.WebSockets.Stream Network.WebSockets.Tests Network.WebSockets.Tests.Util+ Network.WebSockets.Types+ Paths_websockets Build-depends:- HUnit >= 1.2 && < 1.6,- QuickCheck >= 2.7 && < 2.10,+ HUnit >= 1.2 && < 1.7,+ QuickCheck >= 2.7 && < 2.15, test-framework >= 0.4 && < 0.9, test-framework-hunit >= 0.2 && < 0.4, test-framework-quickcheck2 >= 0.2 && < 0.4, -- Copied from regular dependencies...- attoparsec >= 0.10 && < 0.14,- base >= 4 && < 5,- base64-bytestring >= 0.1 && < 1.1,- binary >= 0.5 && < 0.9,- blaze-builder >= 0.3 && < 0.5,- bytestring >= 0.9 && < 0.11,+ async >= 2.2 && < 2.3,+ attoparsec >= 0.10 && < 0.15,+ base >= 4.14 && < 5,+ base64-bytestring >= 0.1 && < 1.3,+ binary >= 0.8.1 && < 0.11,+ bytestring >= 0.9 && < 0.13, case-insensitive >= 0.3 && < 1.3,- containers >= 0.3 && < 0.6,- network >= 2.3 && < 2.7,- random >= 1.0 && < 1.2,+ containers >= 0.3 && < 0.7,+ network >= 2.3 && < 3.2,+ random >= 1.0 && < 1.3, SHA >= 1.5 && < 1.7,- text >= 0.10 && < 1.3,- entropy >= 0.2.1 && < 0.4+ streaming-commons >= 0.1 && < 0.3,+ text >= 0.10 && < 2.2,+ entropy >= 0.2.1 && < 0.5 -Executable websockets-example+Executable websockets-server-example If !flag(Example) Buildable: False - Hs-source-dirs: example- Main-is: server.lhs- Ghc-options: -Wall+ Hs-source-dirs: example+ Main-is: server.lhs+ Ghc-options: -Wall+ Default-language: Haskell2010 Build-depends:+ base, websockets,+ text++Executable websockets-client-example+ If !flag(Example)+ Buildable: False++ Hs-source-dirs: example+ Main-is: client.hs+ Ghc-options: -Wall+ Default-language: Haskell2010++ Build-depends:+ base,+ websockets,+ text,+ network,+ mtl++Executable websockets-autobahn+ If !flag(Example)+ Buildable: False++ Hs-source-dirs: tests/autobahn+ Main-is: server.hs+ Ghc-options: -Wall -threaded -O2 -rtsopts "-with-rtsopts=-N"+ Default-language: Haskell2010++ Other-modules:+ Paths_websockets++ Build-depends:+ websockets, -- Copied from regular dependencies...- attoparsec >= 0.10 && < 0.14,- base >= 4 && < 5,- base64-bytestring >= 0.1 && < 1.1,- binary >= 0.5 && < 0.9,- blaze-builder >= 0.3 && < 0.5,- bytestring >= 0.9 && < 0.11,+ async >= 2.2 && < 2.3,+ attoparsec >= 0.10 && < 0.15,+ base >= 4.14 && < 5,+ base64-bytestring >= 0.1 && < 1.3,+ binary >= 0.8.1 && < 0.11,+ bytestring >= 0.9 && < 0.13, case-insensitive >= 0.3 && < 1.3,- containers >= 0.3 && < 0.6,- network >= 2.3 && < 2.7,- random >= 1.0 && < 1.2,+ containers >= 0.3 && < 0.7,+ network >= 2.3 && < 3.2,+ random >= 1.0 && < 1.3, SHA >= 1.5 && < 1.7,- text >= 0.10 && < 1.3,- entropy >= 0.2.1 && < 0.4+ text >= 0.10 && < 2.2,+ entropy >= 0.2.1 && < 0.5 -Source-repository head- Type: git- Location: https://github.com/jaspervdj/websockets+Benchmark bench-mask+ Type: exitcode-stdio-1.0+ Main-is: mask.hs+ C-sources: cbits/cbits.c+ Hs-source-dirs: benchmarks, src+ Default-language: Haskell2010++ Other-modules:+ Network.WebSockets.Hybi13.Mask++ Build-depends:+ criterion,+ -- Copied from regular dependencies...+ async >= 2.2 && < 2.3,+ attoparsec >= 0.10 && < 0.15,+ base >= 4.14 && < 5,+ base64-bytestring >= 0.1 && < 1.3,+ binary >= 0.8.1 && < 0.11,+ bytestring >= 0.9 && < 0.13,+ case-insensitive >= 0.3 && < 1.3,+ containers >= 0.3 && < 0.7,+ network >= 2.3 && < 3.2,+ random >= 1.0 && < 1.3,+ SHA >= 1.5 && < 1.7,+ text >= 0.10 && < 2.2,+ entropy >= 0.2.1 && < 0.5