packages feed

websockets 0.8.2.6 → 0.13.0.0

raw patch · 34 files changed

Files

CHANGELOG view
@@ -1,3 +1,196 @@+# 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++- 0.9.8.1+    * Restore state of the package to version `0.9.7.0`++- 0.9.8.0+    * This release contained a feature which broke backwards-compatibility.+      Hence, it was marked as broken a new release containing the changes will+      be uploaded as `0.10.0.0`.++- 0.9.7.0+    * Fix issue trying to kill builtin server+    * Bump `QuickCheck` dependency to 2.9++- 0.9.6.2+    * Bump `binary` dependency for GHC 8.0 compatibility++- 0.9.6.1+    * Fix issue with fragmentation test++- 0.9.6.0+    * Optionally include example server in the cabal file+    * Send correct port from client+    * Set `TCP_NO_DELAY` in builtin server+    * Bump `HUnit` dependency+    * Drop dependency on `mtl`+    * Fix `QuickCheck` dependency lower bound++- 0.9.5.0+    * Bugfixes wrt closing sockets and streams++- 0.9.4.0+    * Add `makePendingConnectionFromStream` function+    * Bump `attoparsec` dependency++- 0.9.3.1+    * Bump `QuickCheck` dependency++- 0.9.3.0+    * Use a shared closed state for connection input/output stream+    * Make sure `runServer` doesn't leak any sockets+    * Bump `blaze-builder` dependency++- 0.9.2.2+    * Bump `random` dependency++- 0.9.2.1+    * Fix exception handling issues++- 0.9.2.0+    * Make sending and receiving messages thread-safe by default+    * Export `forkPingThread`+    * Fix Windows `withSocketsDo` issue++- 0.9.1.0+    * Don't use Network.ByteString.Lazy.sendAll on Windows++- 0.9.0.1+    * Allow compilation with older bytestring versions+    * Bump text dependency++- 0.9.0.0+    * Bump various dependencies+    * Remove io-streams dependency+    * New close mechanism+    * More flexible API interface+ - 0.8.2.6     * Bump QuickCheck dependency
+ 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
@@ -0,0 +1,151 @@+websockets example+==================++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](/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)+> import Control.Exception (finally)+> import Control.Monad (forM_, forever)+> import Control.Concurrent (MVar, newMVar, modifyMVar_, modifyMVar, readMVar)+> import qualified Data.Text as T+> import qualified Data.Text.IO as T++> import qualified Network.WebSockets as WS++We represent a client by their username and a `WS.Connection`. We will see how we+obtain this `WS.Connection` later on.++> type Client = (Text, WS.Connection)++The state kept on the server is simply a list of connected clients. We've added+an alias and some utility functions, so it will be easier to extend this state+later on.++> type ServerState = [Client]++Create a new, initial state:++> newServerState :: ServerState+> newServerState = []++Get the number of active clients:++> numClients :: ServerState -> Int+> numClients = length++Check if a user already exists (based on username):++> clientExists :: Client -> ServerState -> Bool+> clientExists client = any ((== fst client) . fst)++Add a client (this does not check if the client already exists, you should do+this yourself using `clientExists`):++> addClient :: Client -> ServerState -> ServerState+> addClient client clients = client : clients++Remove a client:++> removeClient :: Client -> ServerState -> ServerState+> removeClient client = filter ((/= fst client) . fst)++Send a message to all clients, and log it on stdout:++> broadcast :: Text -> ServerState -> IO ()+> broadcast message clients = do+>     T.putStrLn message+>     forM_ clients $ \(_, conn) -> WS.sendTextData conn message++The main function first creates a new state for the server, then spawns the+actual server. For this purpose, we use the simple server provided by+`WS.runServer`.++> main :: IO ()+> main = do+>     state <- newMVar newServerState+>     WS.runServer "127.0.0.1" 9160 $ application state++Our main application has the type:++> application :: MVar ServerState -> WS.ServerApp++Note that `WS.ServerApp` is nothing but a type synonym for+`WS.PendingConnection -> IO ()`.++Our application starts by accepting the connection. In a more realistic+application, you probably want to check the path and headers provided by the+pending request.++We also fork a pinging thread in the background. This will ensure the connection+stays alive on some browsers.++> application state pending = do+>     conn <- WS.acceptRequest pending+>     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++Check that the first message has the right format:++>             _   | 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 " <>+>                             "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)++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++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: " <>+>                            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 :: 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
@@ -5,7 +5,13 @@       PendingConnection     , pendingRequest     , acceptRequest+    , AcceptRequest(..)+    , defaultAcceptRequest+    , acceptRequestWith     , rejectRequest+    , RejectRequest(..)+    , defaultRejectRequest+    , rejectRequestWith        -- * Main connection type     , Connection@@ -14,21 +20,34 @@     , 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     , Headers     , Request (..)     , RequestHead (..)+    , getRequestSubprotocols     , Response (..)     , ResponseHead (..) @@ -42,24 +61,40 @@     , HandshakeException (..)     , ConnectionException (..) -       -- * Running a standalone server     , ServerApp     , runServer     , runServerWith+    , ServerOptions (..)+    , defaultServerOptions+    , runServerWithOptions +      -- * Utilities for writing your own server+    , makeListenSocket+    , makePendingConnection+    , makePendingConnectionFromStream+       -- * Running a client     , ClientApp     , runClient     , runClientWith     , runClientWithSocket     , runClientWithStream+    , newClientConnection++      -- * Utilities+    , PingPongOptions(..)+    , defaultPingPongOptions+    , withPingPong+    , withPingThread+    , forkPingThread     ) where   -------------------------------------------------------------------------------- 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,24 +7,34 @@     , runClientWith     , runClientWithSocket     , runClientWithStream+    , newClientConnection+    -- * Low level functionality+    , createRequest+    , Protocol(..)+    , defaultProtocol+    , checkServerResponse+    , streamToClientConnection     ) where   ---------------------------------------------------------------------------------import qualified Blaze.ByteString.Builder      as Builder-import           Control.Exception             (finally)-import qualified Data.ByteString               as B+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 qualified System.IO.Streams             as Streams-import qualified System.IO.Streams.Attoparsec  as Streams+import           System.Timeout                (timeout)   -------------------------------------------------------------------------------- import           Network.WebSockets.Connection import           Network.WebSockets.Http import           Network.WebSockets.Protocol+import           Network.WebSockets.Stream     (Stream)+import qualified Network.WebSockets.Stream     as Stream import           Network.WebSockets.Types  @@ -53,26 +63,34 @@               -> 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}-    addrInfos <- S.getAddrInfo (Just hints) (Just host) (Just $ show port)-    sock      <- S.socket S.AF_INET S.Stream S.defaultProtocol+                    {S.addrSocketType = S.Stream} +        -- Correct host and path.+        fullHost = if port == 80 then host else (host ++ ":" ++ show port)+        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 host 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-    :: (Streams.InputStream B.ByteString, Streams.OutputStream B.ByteString)+    :: Stream     -- ^ Stream     -> String     -- ^ Host@@ -85,30 +103,78 @@     -> ClientApp a     -- ^ Client application     -> IO a-runClientWithStream (sIn, sOut) host path opts customHeaders app = do+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-    bOut        <- Streams.builderStream sOut-    Streams.write (Just $ encodeRequestHead request) bOut-    Streams.write (Just Builder.flush)               bOut-    response     <- Streams.parseFromStream decodeResponseHead sIn-    -- Note that we pattern match to evaluate the result here-    Response _ _ <- return $ finishResponse protocol request response-    mIn          <- decodeMessages protocol sIn-    mOut         <- encodeMessages protocol ClientConnection bOut-    app Connection-        { connectionOptions  = opts-        , connectionType     = ClientConnection-        , connectionProtocol = protocol-        , connectionIn       = mIn-        , connectionOut      = mOut-        }+    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.newClientConnection: no handshake " +++            "response from server"+    void $ either throwIO return $ finishResponse protocol request response+  where+    protocol = defaultProtocol -- TODO ++-- | Build a 'Connection' from a pre-established stream with already finished+-- handshake.+--+-- /NB/: this will not perform any handshaking.+streamToClientConnection :: Stream -> ConnectionOptions -> IO Connection+streamToClientConnection stream opts = do+    parse   <- decodeMessages protocol+                (connectionFramePayloadSizeLimit opts)+                (connectionMessageDataSizeLimit opts) stream+    write   <- encodeMessages protocol ClientConnection stream+    sentRef <- newIORef False+    heartbeat <- newEmptyMVar+    return $ Connection+        { connectionOptions   = opts+        , connectionType      = ClientConnection+        , connectionProtocol  = protocol+        , connectionParse     = parse+        , connectionWrite     = write+        , connectionHeartbeat = heartbeat+        , connectionSentClose = sentRef+        }+  where+    protocol = defaultProtocol++ -------------------------------------------------------------------------------- runClientWithSocket :: S.Socket           -- ^ Socket                     -> String             -- ^ Host@@ -117,6 +183,8 @@                     -> Headers            -- ^ Custom headers to send                     -> ClientApp a        -- ^ Client application                     -> IO a-runClientWithSocket sock host path opts customHeaders app = do-    stream <- Streams.socketToStreams sock-    runClientWithStream stream host path opts customHeaders app+runClientWithSocket sock host path opts customHeaders app = bracket+    (Stream.makeSocketStream sock)+    Stream.close+    (\stream ->+        runClientWithStream stream host path opts customHeaders app)
src/Network/WebSockets/Connection.hs view
@@ -1,9 +1,16 @@ --------------------------------------------------------------------------------+-- | This module exposes connection internals {-# LANGUAGE OverloadedStrings #-} module Network.WebSockets.Connection     ( PendingConnection (..)     , acceptRequest+    , AcceptRequest(..)+    , defaultAcceptRequest+    , acceptRequestWith     , rejectRequest+    , RejectRequest(..)+    , defaultRejectRequest+    , rejectRequestWith      , Connection (..) @@ -15,26 +22,63 @@     , receiveData     , send     , sendDataMessage+    , sendDataMessages     , sendTextData+    , sendTextDatas     , sendBinaryData+    , sendBinaryDatas     , sendClose+    , sendCloseCode     , sendPing+    , sendPong++    , withPingThread+    , forkPingThread+    , pingThread++    , CompressionOptions (..)+    , PermessageDeflate (..)+    , defaultPermessageDeflate++    , SizeLimit (..)     ) where   ---------------------------------------------------------------------------------import           Blaze.ByteString.Builder    (Builder)-import qualified Blaze.ByteString.Builder    as Builder-import           Control.Exception           (throw)-import qualified Data.ByteString             as B-import           Data.List                   (find)-import           System.IO.Streams           (InputStream, OutputStream)-import qualified System.IO.Streams           as Streams+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.Types  @@ -42,102 +86,221 @@ -- | A new client connected to the server. We haven't accepted the connection -- yet, though. data PendingConnection = PendingConnection-    { pendingOptions  :: ConnectionOptions+    { pendingOptions  :: !ConnectionOptions     -- ^ Options, passed as-is to the 'Connection'-    , pendingRequest  :: RequestHead+    , pendingRequest  :: !RequestHead     -- ^ Useful for e.g. inspecting the request path.-    , pendingOnAccept :: Connection -> IO ()+    , pendingOnAccept :: !(Connection -> IO ())     -- ^ One-shot callback fired when a connection is accepted, i.e., *after*     -- the accepting response is sent to the client.-    , pendingIn       :: InputStream B.ByteString-    -- ^ Input stream-    , pendingOut      :: OutputStream Builder-    -- ^ Output stream+    , pendingStream   :: !Stream+    -- ^ Input/output stream     }   --------------------------------------------------------------------------------+-- | 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 = do-    Streams.write (Just (encodeResponse rsp)) (pendingOut pc)-    Streams.write (Just Builder.flush)        (pendingOut pc)+sendResponse pc rsp = Stream.write (pendingStream pc)+    (Builder.toLazyByteString (encodeResponse rsp))   --------------------------------------------------------------------------------+-- | Accept a pending connection, turning it into a 'Connection'. acceptRequest :: PendingConnection -> IO Connection-acceptRequest pc = case find (flip compatible request) protocols of+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 ""-        throw NotSupported+        throwIO NotSupported     Just protocol -> do-        let response = finishRequest protocol request-        sendResponse pc response-        msgIn  <- decodeMessages protocol (pendingIn pc)-        msgOut <- encodeMessages protocol ServerConnection (pendingOut pc)++        -- 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+            headers = subproto ++ acceptHeaders ar ++ concatMap extHeaders exts+            response = finishRequest protocol request headers++        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-                , connectionType     = ServerConnection-                , connectionProtocol = protocol-                , connectionIn       = msgIn-                , connectionOut      = msgOut+                { 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+    }   ---------------------------------------------------------------------------------data Connection = Connection-    { connectionOptions  :: ConnectionOptions-    , connectionType     :: ConnectionType-    , connectionProtocol :: Protocol-    , connectionIn       :: InputStream Message-    , connectionOut      :: OutputStream Message+defaultRejectRequest :: RejectRequest+defaultRejectRequest = RejectRequest+    { rejectCode    = 400+    , rejectMessage = "Bad Request"+    , rejectHeaders = []+    , rejectBody    = ""     }   ---------------------------------------------------------------------------------data ConnectionOptions = ConnectionOptions-    { connectionOnPong :: IO ()-    }+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)   ---------------------------------------------------------------------------------defaultConnectionOptions :: ConnectionOptions-defaultConnectionOptions = ConnectionOptions-    { connectionOnPong = return ()+-- | 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 ())+    , 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+    -- the first close message but then the other party must respond.  Finally,+    -- the server is in charge of closing the TCP connection.  This IORef tracks+    -- if we have sent a close message and are waiting for the peer to respond.     }   -------------------------------------------------------------------------------- receive :: Connection -> IO Message receive conn = do-    mmsg <- Streams.read (connectionIn conn)-    case mmsg of-        Nothing  -> throw ConnectionClosed+    mbMsg <- connectionParse conn+    case mbMsg of+        Nothing  -> throwIO ConnectionClosed         Just msg -> return msg   -------------------------------------------------------------------------------- -- | Receive an application message. Automatically respond to control messages.+--+-- When the peer sends a close control message, an exception of type 'CloseRequest'+-- is thrown.  The peer can send a close control message either to initiate a+-- close or in response to a close message we have sent to the peer.  In either+-- case the 'CloseRequest' exception will be thrown.  The RFC specifies that+-- the server is responsible for closing the TCP connection, which should happen+-- after receiving the 'CloseRequest' exception from this function.+--+-- This will throw 'ConnectionClosed' if the TCP connection dies unexpectedly. receiveDataMessage :: Connection -> IO DataMessage receiveDataMessage conn = do     msg <- receive conn     case msg of-        DataMessage am    -> return am-        ControlMessage cm -> case cm of-            Close _   -> throw ConnectionClosed+        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@@ -148,43 +311,147 @@ -------------------------------------------------------------------------------- -- | 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 = Streams.write (Just msg) (connectionOut conn)+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+-- | Send a friendly close message.  Note that after sending this message,+-- you should still continue calling 'receiveDataMessage' to process any+-- in-flight messages.  The peer will eventually respond with a close control+-- message of its own which will cause 'receiveDataMessage' to throw the+-- 'CloseRequest' exception.  This exception is when you can finally consider+-- the connection closed. sendClose :: WebSocketsData a => Connection -> a -> IO ()-sendClose conn = send conn . ControlMessage . Close . toLazyByteString+sendClose conn = sendCloseCode conn 1000   --------------------------------------------------------------------------------+-- | Send a friendly close message and close code.  Similar to 'sendClose',+-- you should continue calling 'receiveDataMessage' until you receive a+-- 'CloseRequest' exception.+--+-- See <http://tools.ietf.org/html/rfc6455#section-7.4> for a list of close+-- codes.+sendCloseCode :: WebSocketsData a => Connection -> Word16 -> a -> IO ()+sendCloseCode conn code =+    send conn . ControlMessage . Close code . toLazyByteString+++-------------------------------------------------------------------------------- -- | Send a ping 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 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 = 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 = 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+        Just async -> throwIO (async :: AsyncException)+        Nothing    -> return ()
+ 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
@@ -25,25 +25,27 @@     , getRequestHeader     , 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           Control.Monad.Error                (Error (..))-import qualified Data.Attoparsec                    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@@ -106,32 +110,27 @@   ---------------------------------------------------------------------------------instance Error HandshakeException where-    strMsg = OtherHandshakeException----------------------------------------------------------------------------------- instance Exception HandshakeException   -------------------------------------------------------------------------------- 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   --------------------------------------------------------------------------------@@ -154,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   --------------------------------------------------------------------------------@@ -197,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   --------------------------------------------------------------------------------@@ -209,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)  @@ -231,6 +231,30 @@ getRequestSecWebSocketVersion :: RequestHead -> Maybe B.ByteString getRequestSecWebSocketVersion p =     lookup "Sec-WebSocket-Version" (requestHeaders p)+++--------------------------------------------------------------------------------+-- | List of subprotocols specified by the client, in order of preference.+-- If the client did not specify a list of subprotocols, this will be the+-- empty list.+getRequestSubprotocols :: RequestHead -> [B.ByteString]+getRequestSubprotocols rh = maybe [] parse mproto+    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,45 +5,49 @@     ( 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           Data.Attoparsec                       (anyWord8)-import qualified Data.Attoparsec                       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) import qualified Data.ByteString.Base64                as B64 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) import           Data.Tuple                            (swap) import           System.Entropy                        as R-import qualified System.IO.Streams                     as Streams-import qualified System.IO.Streams.Attoparsec          as Streams import           System.Random                         (RandomGen, newStdGen)   --------------------------------------------------------------------------------+import           Network.WebSockets.Connection.Options import           Network.WebSockets.Http import           Network.WebSockets.Hybi13.Demultiplex import           Network.WebSockets.Hybi13.Mask+import           Network.WebSockets.Stream             (Stream)+import qualified Network.WebSockets.Stream             as Stream import           Network.WebSockets.Types  @@ -54,79 +58,89 @@  -------------------------------------------------------------------------------- finishRequest :: RequestHead-              -> Response-finishRequest reqHttp =-    let !key     = getRequestHeader reqHttp "Sec-WebSocket-Key"-        !hash    = hashKey key+              -> Headers+              -> 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)] ""+    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 pl)) -> mkFrame CloseFrame  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 (Close code pl)) -> mkFrame CloseFrame $+            runPut (putWord16be code) `mappend` 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-               -> Streams.OutputStream B.Builder-               -> IO (Streams.OutputStream Message)-encodeMessages conType bStream = do+encodeMessages+    :: ConnectionType+    -> Stream+    -> IO ([Message] -> IO ())+encodeMessages conType stream = do     genRef <- newIORef =<< newStdGen-    Streams.lockingOutputStream =<< Streams.makeOutputStream (next genRef)-  where-    next :: RandomGen g => IORef g -> Maybe Message -> IO ()-    next _      Nothing    = return ()-    next genRef (Just msg) = do-        build <- atomicModifyIORef genRef $ \s -> encodeMessage conType s msg-        Streams.write (Just build) bStream+    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@@ -134,80 +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 :: Streams.InputStream ByteString-               -> IO (Streams.InputStream Message)-decodeMessages bsStream = do+decodeMessages+    :: SizeLimit+    -> SizeLimit+    -> Stream+    -> IO (IO (Maybe Message))+decodeMessages frameLimit messageLimit stream = do     dmRef <- newIORef emptyDemultiplexState-    Streams.makeInputStream $ next dmRef+    return $ go dmRef   where-    next dmRef = do-        frame <- Streams.parseFromStream parseFrame bsStream-        m     <- atomicModifyIORef dmRef $ \s -> swap $ demultiplex s frame-        maybe (next dmRef) (return . Just) m+    go dmRef = do+        mbFrame <- Stream.parseBin stream (parseFrame frameLimit)+        case mbFrame of+            Nothing    -> return Nothing+            Just frame -> do+                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 <- 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 -    let ft = case opcode of-            0x00 -> ContinuationFrame-            0x01 -> TextFrame-            0x02 -> BinaryFrame-            0x08 -> CloseFrame-            0x09 -> PingFrame-            0x0a -> PongFrame-            _    -> error "Unknown opcode"--    byte1 <- 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,25 +1,27 @@ -------------------------------------------------------------------------------- -- | Demultiplexing of frames into messages {-# 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 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  @@ -59,47 +61,97 @@  -------------------------------------------------------------------------------- -- | Internal state used by the demultiplexer-newtype DemultiplexState = DemultiplexState-    { unDemultiplexState :: Maybe (FrameType, Builder)-    }+data DemultiplexState+    = EmptyDemultiplexState+    | DemultiplexState !Int64 !Builder !(Builder -> Message)   -------------------------------------------------------------------------------- emptyDemultiplexState :: DemultiplexState-emptyDemultiplexState = DemultiplexState Nothing+emptyDemultiplexState = EmptyDemultiplexState   ---------------------------------------------------------------------------------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 (Close pl)), state)-    PingFrame   -> (Just (ControlMessage (Ping pl)), state)-    PongFrame   -> (Just (ControlMessage (Pong pl)), state)-    -- If we're dealing with a continuation...-    ContinuationFrame -> case unDemultiplexState state of-        -- We received a continuation but we don't have any state. Let's ignore-        -- this fragment...-        Nothing -> (Nothing, DemultiplexState Nothing)-        -- Append the payload to the state-        -- TODO: protect against overflows-        Just (amt, b)-            | not fin   -> (Nothing, DemultiplexState (Just (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'+            -> (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+    -- having received a frame that does not conform to the format expected by+    -- the endpoint. 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.+    parsedClose+       | 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       -> (Just (DataMessage (Text pl)), e)-        | otherwise -> (Nothing, DemultiplexState (Just (TextFrame, plb)))+        | fin       ->+            (DemultiplexSuccess (text pl), emptyDemultiplexState)+        | otherwise ->+            (DemultiplexContinue, DemultiplexState size plb (text . B.toLazyByteString))++     BinaryFrame-        | fin       -> (Just (DataMessage (Binary pl)), e)-        | otherwise -> (Nothing, DemultiplexState (Just (BinaryFrame, plb)))+        | fin       -> (DemultiplexSuccess (binary pl), emptyDemultiplexState)+        | otherwise -> (DemultiplexContinue, DemultiplexState size plb (binary . B.toLazyByteString))++    _ -> (DemultiplexError $ CloseRequest 1002 "Protocol Error", emptyDemultiplexState)+   where-    e = emptyDemultiplexState-    plb = B.fromLazyByteString pl+    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,15 +16,15 @@   ---------------------------------------------------------------------------------import           Blaze.ByteString.Builder  (Builder)-import           Data.ByteString           (ByteString)-import qualified Data.ByteString           as B-import qualified System.IO.Streams         as Streams+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 qualified Network.WebSockets.Hybi13             as Hybi13+import           Network.WebSockets.Stream             (Stream) import           Network.WebSockets.Types  @@ -57,29 +57,35 @@   ---------------------------------------------------------------------------------finishRequest :: Protocol -> RequestHead -> 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-               -> Streams.OutputStream Builder-               -> IO (Streams.OutputStream Message)+encodeMessages+    :: Protocol -> ConnectionType -> Stream+    -> IO ([Message] -> IO ()) encodeMessages Hybi13 = Hybi13.encodeMessages   ---------------------------------------------------------------------------------decodeMessages :: Protocol -> Streams.InputStream B.ByteString-               -> IO (Streams.InputStream Message)-decodeMessages Hybi13 = Hybi13.decodeMessages+decodeMessages+    :: Protocol -> SizeLimit -> SizeLimit -> Stream+    -> IO (IO (Maybe Message))+decodeMessages Hybi13 frameLimit messageLimit =+    Hybi13.decodeMessages frameLimit messageLimit   ---------------------------------------------------------------------------------createRequest :: Protocol -> B.ByteString -> B.ByteString -> Bool -> Headers-              -> IO RequestHead+createRequest+    :: Protocol -> B.ByteString -> B.ByteString -> Bool -> Headers+    -> IO RequestHead createRequest Hybi13 = Hybi13.createRequest
src/Network/WebSockets/Server.hs view
@@ -6,24 +6,33 @@ module Network.WebSockets.Server     ( ServerApp     , runServer+    , ServerOptions (..)+    , defaultServerOptions+    , runServerWithOptions     , runServerWith+    , makeListenSocket+    , makePendingConnection+    , makePendingConnectionFromStream++    , PongTimeout     ) where   ---------------------------------------------------------------------------------import           Control.Concurrent            (forkIO)-import           Control.Exception             (finally)-import           Control.Monad                 (forever)+import qualified Control.Concurrent.Async      as Async+import           Control.Exception             (bracket,+                                                bracketOnError, finally, mask_,+                                                throwIO) import           Network.Socket                (Socket) import qualified Network.Socket                as S-import qualified System.IO.Streams.Attoparsec  as Streams-import qualified System.IO.Streams.Builder     as Streams-import qualified System.IO.Streams.Network     as Streams   -------------------------------------------------------------------------------- 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   --------------------------------------------------------------------------------@@ -33,9 +42,22 @@   ----------------------------------------------------------------------------------- | 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>+--+-- * <https://hackage.haskell.org/package/websockets-snap> runServer :: String     -- ^ Address to bind           -> Int        -- ^ Port to listen on           -> ServerApp  -- ^ Application@@ -46,36 +68,107 @@ -------------------------------------------------------------------------------- -- | A version of 'runServer' which allows you to customize some options. runServerWith :: String -> Int -> ConnectionOptions -> ServerApp -> IO ()-runServerWith host port opts app = S.withSocketsDo $ do-    sock  <- S.socket S.AF_INET S.Stream S.defaultProtocol-    _     <- S.setSocketOption sock S.ReuseAddr 1-    host' <- S.inet_addr host-    S.bindSocket sock (S.SockAddrInet (fromIntegral port) host')-    S.listen sock 5-    _ <- forever $ do-        -- TODO: top level handle-        (conn, _) <- S.accept sock-        _         <- forkIO $ finally (runApp conn opts app) (S.sClose conn)-        return ()-    S.sClose sock+runServerWith host port opts = 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 = 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+        S.bind sock (S.addrAddress addr)+        S.listen sock 5+        return sock+        )+  where+    hints = S.defaultHints { S.addrSocketType = S.Stream }+++-------------------------------------------------------------------------------- runApp :: Socket        -> ConnectionOptions        -> ServerApp        -> IO ()-runApp socket opts app = do-    (sIn, sOut) <- Streams.socketToStreams socket-    bOut        <- Streams.builderStream sOut-    -- TODO: we probably want to send a 40x if the request is bad?-    request     <- Streams.parseFromStream (decodeRequestHead False) sIn-    let pc = PendingConnection-                { pendingOptions  = opts-                , pendingRequest  = request-                , pendingOnAccept = \_ -> return ()-                , pendingIn       = sIn-                , pendingOut      = bOut-                }+runApp socket opts app =+    bracket+        (makePendingConnection socket opts)+        (Stream.close . pendingStream)+        app -    app pc++--------------------------------------------------------------------------------+-- | Turns a socket, connected to some client, into a 'PendingConnection'. The+-- 'PendingConnection' should be closed using 'pendingStream' and 'Stream.close' later.+makePendingConnection+    :: Socket -> ConnectionOptions -> IO PendingConnection+makePendingConnection socket opts = do+    stream <- Stream.makeSocketStream socket+    makePendingConnectionFromStream stream opts+++-- | More general version of 'makePendingConnection' for 'Stream.Stream'+-- instead of a 'Socket'.+makePendingConnectionFromStream+    :: Stream.Stream -> ConnectionOptions -> IO PendingConnection+makePendingConnectionFromStream stream opts = do+    -- TODO: we probably want to send a 40x if the request is bad?+    mbRequest <- Stream.parse stream (decodeRequestHead False)+    case mbRequest of+        Nothing      -> throwIO ConnectionClosed+        Just request -> return PendingConnection+            { pendingOptions  = opts+            , pendingRequest  = request+            , pendingOnAccept = \_ -> return ()+            , pendingStream   = stream+            }
+ src/Network/WebSockets/Stream.hs view
@@ -0,0 +1,218 @@+--------------------------------------------------------------------------------+-- | Lightweight abstraction over an input/output stream.+{-# LANGUAGE CPP #-}+module Network.WebSockets.Stream+    ( Stream+    , makeStream+    , makeSocketStream+    , makeEchoStream+    , parse+    , parseBin+    , write+    , close+    ) where++import           Control.Concurrent.MVar        (MVar, newEmptyMVar, newMVar,+                                                 putMVar, takeMVar, withMVar)+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',+                                                 newIORef, readIORef,+                                                 writeIORef)+import qualified Network.Socket                 as S+import qualified Network.Socket.ByteString      as SB (recv)++#if !defined(mingw32_HOST_OS)+import qualified Network.Socket.ByteString.Lazy as SBL (sendAll)+#else+import qualified Network.Socket.ByteString      as SB (sendAll)+#endif+import           System.IO.Error                (isResourceVanishedError)++import           Network.WebSockets.Types+++--------------------------------------------------------------------------------+-- | State of the stream+data StreamState+    = Closed !B.ByteString  -- Remainder+    | Open   !B.ByteString  -- Buffer+++--------------------------------------------------------------------------------+-- | Lightweight abstraction over an input/output stream.+data Stream = Stream+    { streamIn    :: IO (Maybe B.ByteString)+    , streamOut   :: (Maybe BL.ByteString -> IO ())+    , streamState :: !(IORef StreamState)+    }+++--------------------------------------------------------------------------------+-- | Create a stream from a "receive" and "send" action. The following+-- properties apply:+--+-- - Regardless of the provided "receive" and "send" functions, reading and+--   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 to a closed 'Stream' will always throw an+--   exception, even if the underlying "receive" and "send" functions do not+--   (we do the bookkeeping).+--+-- - Streams should always be closed.+makeStream+    :: IO (Maybe B.ByteString)         -- ^ Reading+    -> (Maybe BL.ByteString -> IO ())  -- ^ Writing+    -> IO Stream                       -- ^ Resulting stream+makeStream receive send = do+    ref         <- newIORef (Open B.empty)+    receiveLock <- newMVar ()+    sendLock    <- newMVar ()+    return $ Stream (receive' ref receiveLock) (send' ref sendLock) ref+  where+    closeRef :: IORef StreamState -> IO ()+    closeRef ref = atomicModifyIORef' ref $ \state -> case state of+        Open   buf -> (Closed buf, ())+        Closed buf -> (Closed buf, ())++    -- 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   _ -> return ()++    receive' :: IORef StreamState -> MVar () -> IO (Maybe B.ByteString)+    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 $ \() -> 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 <- 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+#if !defined(mingw32_HOST_OS)+        SBL.sendAll socket bs+#else+        forM_ (BL.toChunks bs) (SB.sendAll socket)+#endif+++--------------------------------------------------------------------------------+makeEchoStream :: IO Stream+makeEchoStream = do+    mvar <- newEmptyMVar+    makeStream (takeMVar mvar) $ \mbBs -> case mbBs of+        Nothing -> putMVar mvar Nothing+        Just bs -> forM_ (BL.toChunks bs) $ \c -> putMVar mvar (Just c)+++--------------------------------------------------------------------------------+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)+    case state of+        Closed remainder+            | B.null remainder -> return Nothing+            | otherwise        -> go (Atto.parse parser 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 (Atto.parse parser bs) False+            | otherwise     -> go (Atto.parse parser buffer) False+  where+    -- Buffer is empty when entering this function.+    go (Atto.Done remainder x) closed = do+        writeIORef (streamState stream) $+            if closed then Closed remainder else Open remainder+        return (Just x)+    go (Atto.Partial f) closed+        | closed    = go (f B.empty) True+        | otherwise = do+            mbBs <- streamIn stream+            case mbBs of+                Nothing -> go (f B.empty) True+                Just bs -> go (f bs) False+    go (Atto.Fail _ _ err) _ = throwIO (ParseException err)+++--------------------------------------------------------------------------------+write :: Stream -> BL.ByteString -> IO ()+write stream = streamOut stream . Just+++--------------------------------------------------------------------------------+close :: Stream -> IO ()+close stream = streamOut stream Nothing
src/Network/WebSockets/Types.hs view
@@ -11,17 +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           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)   --------------------------------------------------------------------------------@@ -32,14 +39,15 @@ -- | 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)   -------------------------------------------------------------------------------- -- | Different control messages data ControlMessage-    = Close BL.ByteString+    = Close Word16 BL.ByteString     | Ping BL.ByteString     | Pong BL.ByteString     deriving (Eq, Show)@@ -49,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) @@ -70,46 +91,78 @@ -- * 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   ----------------------------------------------------------------------------------- | The connection couldn't be established or broke down unexpectedly. thrown--- as an iteratee exception.+-- | Various exceptions that can occur while receiving or transmitting messages data ConnectionException-    -- | the client unexpectedly closed the connection while we were trying to-    -- receive some data.+    -- | The peer has requested that the connection be closed, and included+    -- a close code and a reason for closing.  When receiving this exception,+    -- no more messages can be sent.  Also, the server is responsible for+    -- closing the TCP connection once this exception is received.     ---    -- todo: Also want this for sending.-    = ConnectionClosed-    deriving (Show, Typeable)+    -- See <http://tools.ietf.org/html/rfc6455#section-7.4> for a list of close+    -- codes.+    = CloseRequest Word16 BL.ByteString +    -- | The peer unexpectedly closed the connection while we were trying to+    -- receive some data.  This is a violation of the websocket RFC since the+    -- TCP connection should only be closed after sending and receiving close+    -- control messages.+    | ConnectionClosed +    -- | The client sent garbage, i.e. we could not parse the WebSockets stream.+    | ParseException String++    -- | 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 @@ -117,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
@@ -12,38 +12,43 @@ import           Data.IORef                     (newIORef, readIORef,                                                  writeIORef) import           Data.Maybe                     (fromJust)-import qualified System.IO.Streams.Attoparsec   as Streams-import qualified System.IO.Streams.Builder      as Streams import           Test.Framework                 (Test, testGroup) import           Test.Framework.Providers.HUnit (testCase)-import           Test.HUnit                     (Assertion, (@?=), assert)+import           Test.HUnit                     (Assertion, assert, (@?=))   -------------------------------------------------------------------------------- import           Network.WebSockets import           Network.WebSockets.Connection import           Network.WebSockets.Http-import           Network.WebSockets.Tests.Util+import qualified Network.WebSockets.Stream      as Stream   -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Network.WebSockets.Handshake.Test"-    [ testCase "handshake Hybi13"   testHandshakeHybi13-    , testCase "handshake reject"   testHandshakeReject-    , testCase "handshake Hybi9000" testHandshakeHybi9000+    [ 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     ]   -------------------------------------------------------------------------------- testHandshake :: RequestHead -> (PendingConnection -> IO a) -> IO ResponseHead testHandshake rq app = do-    (is, os) <- makeChanPipe-    os'      <- Streams.builderStream os-    _        <- forkIO $ do-        _ <- app (PendingConnection defaultConnectionOptions rq nullify is os')+    echo <- Stream.makeEchoStream+    _    <- forkIO $ do+        _ <- app (PendingConnection defaultConnectionOptions rq nullify echo)         return ()-    Streams.parseFromStream decodeResponseHead is+    mbRh <- Stream.parse echo decodeResponseHead+    Stream.close echo+    case mbRh of+        Nothing -> fail "testHandshake: No response"+        Just rh -> return rh   where     nullify _ = return () @@ -60,7 +65,7 @@     , ("Upgrade", "websocket")     , ("Connection", "Upgrade")     , ("Sec-WebSocket-Key", "x3JJHMbDL1EzLkh9GBhXDw==")-    , ("Sec-WebSocket-Protocol", "chat")+    , ("Sec-WebSocket-Protocol", "chat, superchat")     , ("Sec-WebSocket-Version", "13")     , ("Origin", "http://example.com")     ]@@ -79,15 +84,78 @@     message @?= "WebSocket Protocol Handshake"     headers ! "Sec-WebSocket-Accept" @?= "HSmrc0sMlYUkAGmm5OPpG2HaGWk="     headers ! "Connection"           @?= "Upgrade"+    lookup "Sec-WebSocket-Protocol" headers @?= Nothing +--------------------------------------------------------------------------------+testHandshakeHybi13WithProto :: Assertion+testHandshakeHybi13WithProto = 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") []) +    readIORef onAcceptFired >>= assert+    code @?= 101+    message @?= "WebSocket Protocol Handshake"+    headers ! "Sec-WebSocket-Accept" @?= "HSmrc0sMlYUkAGmm5OPpG2HaGWk="+    headers ! "Connection"           @?= "Upgrade"+    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
@@ -6,7 +6,7 @@   ---------------------------------------------------------------------------------import qualified Data.Attoparsec                as A+import qualified Data.Attoparsec.ByteString     as A import qualified Data.ByteString.Char8          as BC import           Test.Framework                 (Test, testGroup) import           Test.Framework.Providers.HUnit (testCase)@@ -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,24 +7,25 @@   ---------------------------------------------------------------------------------import           Control.Applicative            ((<$>))+import           Control.Applicative            ((<$>), (<|>)) import           Control.Concurrent             (forkIO, killThread,                                                  threadDelay)-import           Control.Exception              (SomeException, handle)-import           Control.Monad                  (forM_, forever, replicateM)-import           Data.IORef                     (newIORef, readIORef,+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.Random                  (newStdGen)+import           System.Environment             (getEnvironment) import           Test.Framework                 (Test, testGroup) import           Test.Framework.Providers.HUnit (testCase) import           Test.HUnit                     (Assertion, assert, (@=?)) import           Test.QuickCheck                (Arbitrary, arbitrary) import           Test.QuickCheck.Gen            (Gen (..))+import           Test.QuickCheck.Random         (newQCGen)   --------------------------------------------------------------------------------@@ -36,28 +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 $ 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 $ do+testOnPong = withEchoServer "127.0.0.1" 42941 "Bye" $ do     gotPong <- newIORef False     let opts = defaultConnectionOptions                    { connectionOnPong = writeIORef gotPong True@@ -72,13 +123,15 @@         sendPing conn ("What's a fish without an eye?" :: Text)         sendTextData conn ("A fsh!" :: Text)         msg <- receiveData conn+        sendCloseCode conn 1000 ("Bye" :: BL.ByteString)+        expectCloseException conn "Bye"         return $ "A fsh!" == (msg :: Text)   -------------------------------------------------------------------------------- sample :: Arbitrary a => IO [a] sample = do-    gen <- newStdGen+    gen <- newQCGen     return $ (unGen arbitrary) gen 512  @@ -86,28 +139,17 @@ 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 -> IO a -> IO a-withEchoServer port action = do-    serverThread <- forkIO $ retry $ runServer "0.0.0.0" port server+withEchoServer :: String -> Int -> BL.ByteString -> IO a -> IO a+withEchoServer host port expectedClose action = do+    cRef <- newIORef False+    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   where     server :: ServerApp@@ -116,3 +158,28 @@         forever $ do             msg <- receiveDataMessage conn             sendDataMessage conn msg++    handleClose :: IORef Bool -> ConnectionException -> IO ()+    handleClose cRef (CloseRequest i msg) = do+        i @=? 1000+        msg @=? expectedClose+        writeIORef cRef True+    handleClose _ ConnectionClosed =+        error "Unexpected connection closed exception"+    handleClose _ (ParseException _) =+        error "Unexpected parse exception"+    handleClose _ (UnicodeException _) =+        error "Unexpected unicode exception"+++--------------------------------------------------------------------------------+expectCloseException :: Connection -> BL.ByteString -> IO ()+expectCloseException conn msg = act `catch` handler+    where+        act = receiveDataMessage conn >> error "Expecting CloseRequest exception"+        handler (CloseRequest i msg') = do+            i @=? 1000+            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,49 +7,54 @@   ---------------------------------------------------------------------------------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                         (replicateM)+import           Data.Binary.Get                       (runGetOrFail) import qualified Data.ByteString.Lazy                  as BL import           Data.List                             (intersperse) import           Data.Maybe                            (catMaybes)-import qualified System.IO.Streams                     as Streams+import           Data.Monoid                           (mempty, mconcat)+import           Network.WebSockets+import qualified Network.WebSockets.Hybi13             as Hybi13+import           Network.WebSockets.Hybi13.Demultiplex+import           Network.WebSockets.Protocol+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           Network.WebSockets-import qualified Network.WebSockets.Hybi13             as Hybi13-import           Network.WebSockets.Hybi13.Demultiplex-import           Network.WebSockets.Protocol-import           Network.WebSockets.Tests.Util-import           Network.WebSockets.Types+import           Prelude   -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Network.WebSockets.Test"     [ testProperty "simple encode/decode Hybi13" (testSimpleEncodeDecode Hybi13)-    , testProperty "framgmented Hybi13"          testFragmentedHybi13+    , 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-        (is, os) <- makeChanPipe-        is'      <- decodeMessages protocol is-        os'      <- encodeMessages protocol ClientConnection =<<-            Streams.builderStream os-        Streams.writeList msgs os'-        msgs' <- catMaybes <$> replicateM (length msgs) (Streams.read is')+        echo  <- Stream.makeEchoStream+        parse <- decodeMessages protocol mempty mempty echo+        write <- encodeMessages protocol ClientConnection echo+        _     <- forkIO $ write msgs+        msgs' <- catMaybes <$> replicateM (length msgs) parse+        Stream.close echo         msgs @=? msgs'  @@ -57,64 +62,103 @@ testFragmentedHybi13 :: Property testFragmentedHybi13 = QC.monadicIO $     QC.forAllM QC.arbitrary $ \fragmented -> QC.run $ do-        (is, os) <- makeChanPipe-        is'      <- Streams.filter isDataMessage =<< Hybi13.decodeMessages is-        os'      <- Streams.builderStream os+        echo     <- Stream.makeEchoStream+        parse    <- Hybi13.decodeMessages mempty mempty echo+        -- is'      <- Streams.filter isDataMessage =<< Hybi13.decodeMessages is          -- Simple hacky encoding of all frames-        Streams.writeList-            [ Hybi13.encodeFrame Nothing f-            | FragmentedMessage _ frames <- fragmented-            , f                          <- frames-            ] os'-        Streams.write (Just Builder.flush) os'-        Streams.write Nothing os'+        _ <- forkIO $ do+            mapM_ (Stream.write echo)+                [ Builder.toLazyByteString (Hybi13.encodeFrame Nothing f)+                | FragmentedMessage _ frames <- fragmented+                , f                          <- frames+                ]+            Stream.close echo          -- Check if we got all data-        msgs <- catMaybes <$> replicateM (length fragmented) (Streams.read is')+        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+        case mbMsg of+            Left  ConnectionClosed -> return []+            Left  _                -> return []+            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-        QC.elements-            [ ControlMessage (Close 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)+        ]   --------------------------------------------------------------------------------@@ -134,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@@ -149,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/Network/WebSockets/Tests/Util.hs view
@@ -3,19 +3,15 @@     ( ArbitraryUtf8 (..)     , arbitraryUtf8     , arbitraryByteString-    , makeChanPipe     ) where   ---------------------------------------------------------------------------------import           Control.Applicative          ((<$>), (<*>))-import           Control.Concurrent.Chan      (newChan)-import qualified Data.ByteString.Lazy         as BL-import qualified Data.Text.Lazy               as TL-import qualified Data.Text.Lazy.Encoding      as TL-import           System.IO.Streams            (InputStream, OutputStream)-import qualified System.IO.Streams.Concurrent as Streams-import           Test.QuickCheck              (Arbitrary (..), Gen)+import           Control.Applicative      ((<$>))+import qualified Data.ByteString.Lazy     as BL+import qualified Data.Text.Lazy           as TL+import qualified Data.Text.Lazy.Encoding  as TL+import           Test.QuickCheck          (Arbitrary (..), Gen)   --------------------------------------------------------------------------------@@ -40,12 +36,3 @@ -------------------------------------------------------------------------------- arbitraryByteString :: Gen BL.ByteString arbitraryByteString = BL.pack <$> arbitrary-------------------------------------------------------------------------------------- | TODO: I added this function to the io-streams library but it isn't released--- yet, at some point we should be able to remove it here.-makeChanPipe :: IO (InputStream a, OutputStream a)-makeChanPipe = do-    chan <- newChan-    (,) <$> Streams.chanToInput chan <*> Streams.chanToOutput chan
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.8.2.6+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,17 +44,35 @@ Extra-source-files:   CHANGELOG +Source-repository head+  Type:     git+  Location: https://github.com/jaspervdj/websockets++Flag Example+  Description: Build the example server+  Default:     False+  Manual:      True+ 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@@ -63,58 +82,162 @@     Network.WebSockets.Types    Build-depends:-    attoparsec        >= 0.9    && < 0.13,-    base              >= 4      && < 5,-    base64-bytestring >= 0.1    && < 1.1,-    binary            >= 0.5    && < 0.8,-    blaze-builder     >= 0.3    && < 0.4,-    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,-    io-streams        >= 1.1    && < 1.2,-    mtl               >= 2.0    && < 2.3,-    network           >= 2.3    && < 2.6,-    random            >= 1.0    && < 1.1,+    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.2,-    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.3,-    QuickCheck                 >= 2.4 && < 2.8,+    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.9    && < 0.13,-    base              >= 4      && < 5,-    base64-bytestring >= 0.1    && < 1.1,-    binary            >= 0.5    && < 0.8,-    blaze-builder     >= 0.3    && < 0.4,-    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,-    io-streams        >= 1.1    && < 1.2,-    mtl               >= 2.0    && < 2.3,-    network           >= 2.3    && < 2.6,-    random            >= 1.0    && < 1.1,+    containers        >= 0.3    && < 0.7,+    network           >= 2.3    && < 3.2,+    random            >= 1.0    && < 1.3,     SHA               >= 1.5    && < 1.7,-    text              >= 0.10   && < 1.2,-    entropy           >= 0.2.1  && < 0.4+    streaming-commons >= 0.1    && < 0.3,+    text              >= 0.10   && < 2.2,+    entropy           >= 0.2.1  && < 0.5 -Source-repository head-  Type:     git-  Location: https://github.com/jaspervdj/websockets+Executable websockets-server-example+  If !flag(Example)+    Buildable: False++  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...+    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++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