packages feed

websockets 0.6.0.4 → 0.13.0.0

raw patch · 47 files changed

Files

+ CHANGELOG view
@@ -0,0 +1,214 @@+# 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++- 0.8.2.5+    * Bump attoparsec dependency++- 0.8.2.4+    * Bump entropy dependency++- 0.8.2.3+    * Bump mtl dependency++- 0.8.2.2+    * Bump network dependency++- 0.8.2.1+    * Add benchmark with many open connections+    * Update example to use gender-neutral language++- 0.8.2.0+    * Fix possible leaking of client sockets when connection times out
+ 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
@@ -1,220 +1,100 @@--- | How do you use this library? Here's how:------ Get an enumerator/iteratee pair from your favorite web server (or use a--- library which provides integration). Alternatively, use 'I.runServer' to--- set up a simple standalone server.------ An application typically has the form of @I.Request -> I.WebSockets p ()@.--- The first thing to do is accept or reject the request, usually based upon--- the path in the 'I.Request'. An example:------ > {-# LANGUAGE OverloadedStrings #-}--- > import Network.WebSockets--- >--- > app :: Protocol p => Request -> WebSockets p ()--- > app rq = case requestPath rq of--- >    "/forbidden" -> rejectRequest rq "Forbidden!"--- >    _            -> do--- >        acceptRequest rq--- >        ... actual application ...------ You can now start using the socket for sending and receiving data. But what's--- with the @p@ in @WebSockets p ()@?------ Well, the answer is that this library aims to support many versions of the--- WebSockets protocol. Unfortunately, not all versions of the protocol have the--- same capabilities: for example, older versions are not able to send binary--- data.------ The library user (you!) choose which capabilities you need. Then, the browser--- and library will negotiate at runtime which version will be actually used.------ As an example, here are two applications which need different capabilities:------ > import Network.WebSockets--- > import qualified Data.ByteString as B--- > import qualified Data.Text as T--- > --- > app1 :: TextProtocol p => WebSockets p ()--- > app1 = sendTextData (T.pack "Hello world!")--- > --- > app2 :: BinaryProtocol p => WebSockets p ()--- > app2 = sendBinaryData (B.pack [0 .. 100])------ When you /tie the knot/, you will need to decide what protocol to use, to--- prevent ambiguousness. A good rule of thumb is to select the lowest protocol--- possible, since higher versions are generally backwards compatible in terms--- of features. . For example, the following application uses only--- /features from Hybi00/, and is therefore /compatible with Hybi10/ and later--- protocols.--- --- > app :: Request -> WebSockets Hybi00 ()--- > app _ = app1--- > --- > main :: IO ()--- > main = runServer "0.0.0.0" 8000 app--- --- In some cases, you want to escape from the 'I.WebSockets' monad and send data--- to the websocket from different threads. To this end, the 'I.getSink' method--- is provided. The next example spawns a thread which continuously spams the--- client in another thread:------ > import Control.Concurrent (forkIO)--- > import Control.Monad (forever)--- > import Control.Monad.Trans (liftIO)--- > import Network.WebSockets--- > import qualified Data.Text as T--- > --- > spam :: TextProtocol p => WebSockets p ()--- > spam = do--- >     sink <- getSink--- >     _ <- liftIO $ forkIO $ forever $--- >         sendSink sink $ textData (T.pack "SPAM SPAM SPAM!")--- >     sendTextData (T.pack "Hello world!")------ For safety reasons, you can only read from the socket in the 'I.WebSockets'--- monad.------ For a full example, see:------ <http://jaspervdj.be/websockets/example.html>+-------------------------------------------------------------------------------- {-# LANGUAGE ScopedTypeVariables #-} module Network.WebSockets-    ( -      -- * WebSocket type-      I.WebSocketsOptions (..)-    , I.defaultWebSocketsOptions-    , I.WebSockets-    , I.runWebSockets-    , I.runWebSocketsWith-    , I.runWebSocketsHandshake-    , I.runWebSocketsWithHandshake--      -- * Protocol versions-    , I.Protocol-    , I.TextProtocol-    , I.BinaryProtocol-    , I.Hybi00-    , I.Hybi10+    ( -- * Incoming connections and handshaking+      PendingConnection+    , pendingRequest+    , acceptRequest+    , AcceptRequest(..)+    , defaultAcceptRequest+    , acceptRequestWith+    , rejectRequest+    , RejectRequest(..)+    , defaultRejectRequest+    , rejectRequestWith -      -- * A simple standalone server-    , I.runServer-    , I.runWithSocket+      -- * Main connection type+    , Connection -      -- * Types-    , I.Headers-    , I.RequestHttpPart (..)-    , I.Request (..)-    , I.Response (..)-    , I.Message (..)-    , I.ControlMessage (..)-    , I.DataMessage (..)-    , I.WebSocketsData (..)+      -- * Options for connections+    , ConnectionOptions (..)+    , defaultConnectionOptions -      -- * Handshake-    , acceptRequest-    , rejectRequest+      -- ** Compression options+    , CompressionOptions (..)+    , PermessageDeflate (..)+    , defaultPermessageDeflate -      -- * Various-    , I.getVersion+      -- ** Protection limits+    , SizeLimit (..) -      -- * Receiving-    , I.receive+      -- * Sending and receiving messages+    , receive     , receiveDataMessage     , receiveData--      -- * Sending-    , I.send+    , send+    , sendDataMessage+    , sendDataMessages     , sendTextData+    , sendTextDatas     , sendBinaryData+    , sendBinaryDatas+    , sendClose+    , sendCloseCode+    , sendPing -      -- * Asynchronous sending-    , I.Sink-    , I.sendSink-    , I.getSink-    , I.close-    , I.ping-    , I.pong-    , I.textData-    , I.binaryData-    , I.spawnPingThread+      -- * HTTP Types+    , Headers+    , Request (..)+    , RequestHead (..)+    , getRequestSubprotocols+    , Response (..)+    , ResponseHead (..) -      -- * Error Handling-    , I.throwWsError-    , I.catchWsError-    , I.HandshakeError(..)-    , I.ConnectionError(..)-    ) where+      -- * WebSocket message types+    , Message (..)+    , ControlMessage (..)+    , DataMessage (..)+    , WebSocketsData (..) -import Control.Monad.Trans (liftIO)+      -- * Exceptions+    , HandshakeException (..)+    , ConnectionException (..) -import qualified Network.WebSockets.Handshake as I-import qualified Network.WebSockets.Handshake.Http as I-import qualified Network.WebSockets.Monad as I-import qualified Network.WebSockets.Protocol as I-import qualified Network.WebSockets.Protocol.Hybi00 as I-import qualified Network.WebSockets.Protocol.Hybi10 as I-import qualified Network.WebSockets.Protocol.Unsafe as Unsafe-import qualified Network.WebSockets.Socket as I-import qualified Network.WebSockets.Types as I+      -- * Running a standalone server+    , ServerApp+    , runServer+    , runServerWith+    , ServerOptions (..)+    , defaultServerOptions+    , runServerWithOptions --- This doesn't work this way any more. As the Protocol first has to be--- determined by the request, we can't provide this as a WebSockets action. See--- the various flavours of runWebSockets.+      -- * Utilities for writing your own server+    , makeListenSocket+    , makePendingConnection+    , makePendingConnectionFromStream --- | Receive an application message. Automatically respond to control messages.-receiveDataMessage :: I.Protocol p => I.WebSockets p (I.DataMessage p)-receiveDataMessage = do-    m <- I.receive-    case m of-        (I.DataMessage am) -> return am-        (I.ControlMessage cm) -> case cm of-            I.Close _ -> I.throwWsError I.ConnectionClosed-            I.Pong _  -> do-                options <- I.getOptions-                liftIO $ I.onPong options-                receiveDataMessage-            I.Ping pl -> do-                -- Note that we are using an /unsafe/ pong here. If the -                -- underlying protocol cannot encode this pong, our thread will-                -- crash. We assume, however that the protocol /is/ able to-                -- encode the pong, since it was able to encode a ping.-                I.send $ Unsafe.pong pl-                receiveDataMessage+      -- * Running a client+    , ClientApp+    , runClient+    , runClientWith+    , runClientWithSocket+    , runClientWithStream+    , newClientConnection --- | Receive a message, treating it as data transparently-receiveData :: (I.Protocol p, I.WebSocketsData a) => I.WebSockets p a-receiveData = do-    dm <- receiveDataMessage-    case dm of-        I.Text x   -> return (I.fromLazyByteString x)-        I.Binary x -> return (I.fromLazyByteString x)+      -- * Utilities+    , PingPongOptions(..)+    , defaultPingPongOptions+    , withPingPong+    , withPingThread+    , forkPingThread+    ) where --- | Send a 'I.Response' to the socket immediately.-sendResponse :: I.Protocol p => I.Response -> I.WebSockets p ()-sendResponse = I.sendBuilder . I.encodeResponse --- | Send a text message-sendTextData :: (I.TextProtocol p, I.WebSocketsData a) => a -> I.WebSockets p ()-sendTextData = I.send . I.textData---- | Send some binary data-sendBinaryData :: (I.BinaryProtocol p, I.WebSocketsData a)-               => a -> I.WebSockets p ()-sendBinaryData = I.send . I.binaryData---- | Reject a request, sending a 400 (Bad Request) to the client and throwing a--- RequestRejected (HandshakeError)-rejectRequest :: I.Protocol p-              => I.Request -> String -> I.WebSockets p a-rejectRequest req reason = failHandshakeWith $ I.RequestRejected req reason--failHandshakeWith :: forall p a. I.Protocol p-                  => I.HandshakeError -> I.WebSockets p a-failHandshakeWith err = do-    sendResponse $ I.responseError (undefined :: p) err-    I.throwWsError err---- | Accept a request. After this, you can start sending and receiving data.-acceptRequest :: I.Protocol p => I.Request -> I.WebSockets p ()-acceptRequest = sendResponse . I.requestResponse+--------------------------------------------------------------------------------+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
@@ -0,0 +1,190 @@+--------------------------------------------------------------------------------+-- | This part of the library provides you with utilities to create WebSockets+-- clients (in addition to servers).+module Network.WebSockets.Client+    ( ClientApp+    , runClient+    , runClientWith+    , runClientWithSocket+    , runClientWithStream+    , newClientConnection+    -- * Low level functionality+    , createRequest+    , Protocol(..)+    , defaultProtocol+    , checkServerResponse+    , streamToClientConnection+    ) where+++--------------------------------------------------------------------------------+import qualified Data.ByteString.Builder       as Builder+import           Control.Exception             (bracket, finally, throwIO)+import           Control.Concurrent.MVar       (newEmptyMVar)+import           Control.Monad                 (void)+import           Data.IORef                    (newIORef)+import qualified Data.Text                     as T+import qualified Data.Text.Encoding            as T+import qualified Network.Socket                as S+import           System.Timeout                (timeout)+++--------------------------------------------------------------------------------+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+++--------------------------------------------------------------------------------+-- | A client application interacting with a single server. Once this 'IO'+-- action finished, the underlying socket is closed automatically.+type ClientApp a = Connection -> IO a+++--------------------------------------------------------------------------------+-- TODO: Maybe this should all be strings+runClient :: String       -- ^ Host+          -> Int          -- ^ Port+          -> String       -- ^ Path+          -> ClientApp a  -- ^ Client application+          -> IO a+runClient host port path ws =+    runClientWith host port path defaultConnectionOptions [] ws+++--------------------------------------------------------------------------------+runClientWith :: String             -- ^ Host+              -> Int                -- ^ Port+              -> String             -- ^ Path+              -> ConnectionOptions  -- ^ Options+              -> Headers            -- ^ Custom headers to send+              -> ClientApp a        -- ^ Client application+              -> IO a+runClientWith host port path0 opts customHeaders app = do+    -- Create and connect socket+    let hints = S.defaultHints+                    {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 <- bracket+        (timeout (connectionTimeout opts * 1000 * 1000) $ S.connect sock (S.addrAddress addr))+        (const $ S.close sock) $ \maybeConnected -> case maybeConnected of+            Nothing -> throwIO $ ConnectionTimeout+            Just () -> runClientWithSocket sock fullHost path opts customHeaders app+++    -- Clean up+    return res+++--------------------------------------------------------------------------------++runClientWithStream+    :: Stream+    -- ^ Stream+    -> String+    -- ^ Host+    -> String+    -- ^ Path+    -> ConnectionOptions+    -- ^ Connection options+    -> Headers+    -- ^ Custom headers to send+    -> ClientApp a+    -- ^ Client application+    -> IO a+runClientWithStream stream host path opts customHeaders app = do+    newClientConnection stream host path opts customHeaders >>= app++-- | Build a new 'Connection' from the client's point of view.+--+-- /WARNING/: Be sure to call 'Stream.close' on the given 'Stream' after you are+-- done using the 'Connection' in order to properly close the communication+-- channel. 'runClientWithStream' handles this for you, prefer to use it when+-- possible.+newClientConnection+    :: Stream+    -- ^ Stream that will be used by the new 'Connection'.+    -> String+    -- ^ Host+    -> String+    -- ^ Path+    -> ConnectionOptions+    -- ^ Connection options+    -> Headers+    -- ^ Custom headers to send+    -> IO Connection+newClientConnection stream host path opts customHeaders = do+    -- Create the request and send it+    request    <- createRequest protocol bHost bPath False customHeaders+    Stream.write stream (Builder.toLazyByteString $ encodeRequestHead request)+    checkServerResponse stream request+    streamToClientConnection stream opts+  where+    protocol = defaultProtocol  -- TODO+    bHost    = T.encodeUtf8 $ T.pack host+    bPath    = T.encodeUtf8 $ T.pack path++-- | Check the response from the server.+-- Throws 'OtherHandshakeException' on failure+checkServerResponse :: Stream -> RequestHead -> IO ()+checkServerResponse stream request = do+    mbResponse <- Stream.parse stream decodeResponseHead+    response   <- case mbResponse of+        Just response -> return response+        Nothing       -> throwIO $ OtherHandshakeException $+            "Network.WebSockets.Client.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+                    -> String             -- ^ Path+                    -> ConnectionOptions  -- ^ Options+                    -> Headers            -- ^ Custom headers to send+                    -> ClientApp a        -- ^ Client application+                    -> IO a+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
@@ -0,0 +1,457 @@+--------------------------------------------------------------------------------+-- | This module exposes connection internals+{-# LANGUAGE OverloadedStrings #-}+module Network.WebSockets.Connection+    ( PendingConnection (..)+    , acceptRequest+    , AcceptRequest(..)+    , defaultAcceptRequest+    , acceptRequestWith+    , rejectRequest+    , RejectRequest(..)+    , defaultRejectRequest+    , rejectRequestWith++    , Connection (..)++    , ConnectionOptions (..)+    , defaultConnectionOptions++    , receive+    , receiveDataMessage+    , receiveData+    , send+    , sendDataMessage+    , sendDataMessages+    , sendTextData+    , sendTextDatas+    , sendBinaryData+    , sendBinaryDatas+    , sendClose+    , sendCloseCode+    , sendPing+    , sendPong++    , withPingThread+    , forkPingThread+    , pingThread++    , CompressionOptions (..)+    , PermessageDeflate (..)+    , defaultPermessageDeflate++    , SizeLimit (..)+    ) where+++--------------------------------------------------------------------------------+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+++--------------------------------------------------------------------------------+-- | A new client connected to the server. We haven't accepted the connection+-- yet, though.+data PendingConnection = PendingConnection+    { pendingOptions  :: !ConnectionOptions+    -- ^ Options, passed as-is to the 'Connection'+    , pendingRequest  :: !RequestHead+    -- ^ Useful for e.g. inspecting the request path.+    , pendingOnAccept :: !(Connection -> IO ())+    -- ^ One-shot callback fired when a connection is accepted, i.e., *after*+    -- the accepting response is sent to the client.+    , 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 = Stream.write (pendingStream pc)+    (Builder.toLazyByteString (encodeResponse rsp))+++--------------------------------------------------------------------------------+-- | Accept a pending connection, turning it into a 'Connection'.+acceptRequest :: PendingConnection -> IO Connection+acceptRequest pc = acceptRequestWith pc defaultAcceptRequest+++--------------------------------------------------------------------------------+-- | This function is like 'acceptRequest' but allows you to set custom options+-- using the 'AcceptRequest' datatype.+acceptRequestWith :: PendingConnection -> AcceptRequest -> IO Connection+acceptRequestWith pc ar = case find (flip compatible request) protocols of+    Nothing       -> do+        sendResponse pc $ response400 versionHeader ""+        throwIO NotSupported+    Just protocol -> do++        -- Get requested list of exceptions from client.+        rqExts <- either throwIO return $+            getRequestSecWebSocketExtensions request++        -- Set up permessage-deflate extension if configured.+        pmdExt <- case connectionCompressionOptions (pendingOptions pc) of+            NoCompression                     -> return Nothing+            PermessageDeflateCompression pmd0 ->+                case negotiateDeflate (connectionMessageDataSizeLimit options) (Just pmd0) rqExts of+                    Left err   -> do+                        rejectRequestWith pc defaultRejectRequest {rejectMessage = B8.pack err}+                        throwIO NotSupported+                    Right pmd1 -> return (Just pmd1)++        -- Set up strict utf8 extension if configured.+        let unicodeExt =+                if connectionStrictUnicode (pendingOptions pc)+                    then Just strictUnicode else Nothing++        -- Final extension list.+        let exts = catMaybes [pmdExt, unicodeExt]++        let subproto = maybe [] (\p -> [("Sec-WebSocket-Protocol", p)]) $ acceptSubprotocol ar+            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   = 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)]+++--------------------------------------------------------------------------------+-- | Parameters that allow you to tweak how a request is rejected.  Please use+-- 'defaultRejectRequest' and modify fields using record syntax so your code+-- will not break when new fields are added.+data RejectRequest = RejectRequest+    { -- | The status code, 400 by default.+      rejectCode    :: !Int+    , -- | The message, "Bad Request" by default+      rejectMessage :: !B.ByteString+    , -- | Extra headers to be sent with the response.+      rejectHeaders :: Headers+    , -- | Reponse body of the rejection.+      rejectBody    :: !B.ByteString+    }+++--------------------------------------------------------------------------------+defaultRejectRequest :: RejectRequest+defaultRejectRequest = RejectRequest+    { rejectCode    = 400+    , rejectMessage = "Bad Request"+    , rejectHeaders = []+    , rejectBody    = ""+    }+++--------------------------------------------------------------------------------+rejectRequestWith+    :: PendingConnection  -- ^ Connection to reject+    -> RejectRequest      -- ^ Params on how to reject the request+    -> IO ()+rejectRequestWith pc reject = sendResponse pc $ Response+    ResponseHead+        { responseCode    = rejectCode reject+        , responseMessage = rejectMessage reject+        , responseHeaders = rejectHeaders reject+        }+    (rejectBody reject)+++--------------------------------------------------------------------------------+-- | Requires calling 'pendingStream' and 'Stream.close'.+rejectRequest+    :: PendingConnection  -- ^ Connection to reject+    -> B.ByteString       -- ^ Rejection response body+    -> IO ()+rejectRequest pc body = rejectRequestWith pc+    defaultRejectRequest {rejectBody = body}+++--------------------------------------------------------------------------------+data Connection = Connection+    { connectionOptions   :: !ConnectionOptions+    , connectionType      :: !ConnectionType+    , connectionProtocol  :: !Protocol+    , connectionHeartbeat :: !(MVar ())+    -- ^ This MVar is filled whenever a pong is received.  This is used by+    -- 'withPingPong' to timeout the connection if a pong is not received.+    , connectionParse     :: !(IO (Maybe Message))+    , connectionWrite     :: !([Message] -> IO ())+    , 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+    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 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+                send conn (ControlMessage (Pong pl))+                receiveDataMessage conn+++--------------------------------------------------------------------------------+-- | Receive a message, converting it to whatever format is needed.+receiveData :: WebSocketsData a => Connection -> IO a+receiveData conn = fromDataMessage <$> receiveDataMessage conn+++--------------------------------------------------------------------------------+send :: Connection -> Message -> IO ()+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'.  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 = 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 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 = 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 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 = sendBinaryDatas conn . return++--------------------------------------------------------------------------------+-- | Send a number of binary messages.  This is more efficient than calling+-- 'sendBinaryData' many times.+sendBinaryDatas :: WebSocketsData a => Connection -> [a] -> IO ()+sendBinaryDatas conn = sendDataMessages conn . map (Binary . toLazyByteString)++--------------------------------------------------------------------------------+-- | Send a friendly close message.  Note that after sending this message,+-- 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 = 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/Handshake.hs 
@@ -1,37 +0,0 @@--- | Implementation of the WebSocket handshake-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}-module Network.WebSockets.Handshake-    ( HandshakeError (..)-    , handshake-    , responseError-    ) where--import Data.List (find)--import qualified Data.ByteString as B-import qualified Data.Enumerator as E--import Network.WebSockets.Handshake.Http-import Network.WebSockets.Protocol---- | Receives and checks the client handshake. If no suitable protocol is found--- (or the client sends garbage), a 'HandshakeError' will be thrown.-handshake :: (Monad m, Protocol p)-          => RequestHttpPart-          -> E.Iteratee B.ByteString m (Request, p)-handshake rhp = case find (flip supported rhp) implementations of-    Nothing -> E.throwError NotSupported-    Just p  -> do-        rq <- finishRequest p rhp-        return (rq, p)---- | Respond to errors encountered during handshake. First argument may be--- bottom.-responseError :: forall p. Protocol p => p -> HandshakeError -> Response-responseError _ err = response400 $ case err of-    -- TODO: fix-    NotSupported -> versionHeader  -- Version negotiation-    _            -> []-  where-    versionHeader = [("Sec-WebSocket-Version",-        B.intercalate ", " $ concatMap headerVersions (implementations :: [p]))]
− src/Network/WebSockets/Handshake/Http.hs 
@@ -1,129 +0,0 @@--- | Module dealing with HTTP: request data types, encoding and decoding...-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}-module Network.WebSockets.Handshake.Http-    ( Headers-    , RequestHttpPart (..)-    , Request (..)-    , Response (..)-    , HandshakeError (..)-    , getSecWebSocketVersion-    , decodeRequest-    , encodeResponse-    , response101-    , response400-    ) where--import Data.Dynamic (Typeable)-import Data.Monoid (mappend, mconcat)-import Control.Applicative (pure, (<$>), (<*>), (*>), (<*))-import Control.Exception (Exception)-import Control.Monad.Error (Error (..))--import Data.ByteString.Char8 ()-import Data.ByteString.Internal (c2w)-import qualified Data.Attoparsec as A-import qualified Blaze.ByteString.Builder as Builder-import qualified Blaze.ByteString.Builder.Char.Utf8 as Builder-import qualified Data.ByteString as B-import qualified Data.CaseInsensitive as CI---- | Request headers-type Headers = [(CI.CI B.ByteString, B.ByteString)]---- | (Internally used) HTTP headers and requested path.-data RequestHttpPart = RequestHttpPart-    { requestHttpPath    :: !B.ByteString-    , requestHttpHeaders :: Headers-    , requestHttpSecure  :: Bool-    } deriving (Eq, Show)---- | Full request type-data Request = Request-    { requestPath     :: !B.ByteString-    , requestHeaders  :: Headers-    , requestResponse :: Response-    }-    deriving (Show)---- | Response to a 'Request'-data Response = Response-    { responseCode    :: !Int-    , responseMessage :: !B.ByteString-    , responseHeaders :: Headers-    , responseBody    :: B.ByteString-    } deriving (Show)---- | Error in case of failed handshake. Will be thrown as an iteratee--- exception. ('Error' condition).------ TODO: This should probably be in the Handshake module, and is solely here to--- prevent a cyclic dependency.-data HandshakeError-    -- | We don't have a match for the protocol requested by the client.-    -- todo: version parameter-    = NotSupported-    -- | The request was somehow invalid (missing headers or wrong security-    -- token)-    | MalformedRequest RequestHttpPart String-    -- | The request was well-formed, but the library user rejected it.-    -- (e.g. "unknown path")-    | RequestRejected Request String-    -- | for example "EOF came too early" (which is actually a parse error)-    -- or for your own errors. (like "unknown path"?)-    | OtherHandshakeError String-    deriving (Show, Typeable)--instance Error HandshakeError where-    strMsg = OtherHandshakeError--instance Exception HandshakeError---- | Get the @Sec-WebSocket-Version@ header-getSecWebSocketVersion :: RequestHttpPart -> Maybe B.ByteString-getSecWebSocketVersion p = lookup "Sec-WebSocket-Version" (requestHttpHeaders p)---- | Parse an initial request-decodeRequest :: Bool -> A.Parser RequestHttpPart-decodeRequest isSecure = RequestHttpPart-    <$> requestLine-    <*> A.manyTill header newline-    <*> pure isSecure-  where-    space   = A.word8 (c2w ' ')-    newline = A.string "\r\n"--    requestLine = A.string "GET" *> space *> A.takeWhile1 (/= c2w ' ')-        <* space-        <* A.string "HTTP/1.1" <* newline--    header = (,)-        <$> (CI.mk <$> A.takeWhile1 (/= c2w ':'))-        <*  A.string ": "-        <*> A.takeWhile1 (/= c2w '\r')-        <*  newline---- | Encode an HTTP upgrade response-encodeResponse :: Response -> Builder.Builder-encodeResponse (Response code msg headers body) =-    Builder.copyByteString "HTTP/1.1 " `mappend`-    Builder.fromString (show code)     `mappend`-    Builder.fromChar ' '               `mappend`-    Builder.fromByteString msg         `mappend`-    Builder.fromByteString "\r\n"      `mappend`-    mconcat (map header headers)       `mappend`-    Builder.copyByteString "\r\n"      `mappend`-    Builder.copyByteString body  -- (body is empty except for version -00)-  where-    header (k, v) = mconcat $ map Builder.copyByteString-        [CI.original k, ": ", v, "\r\n"]---- | An upgrade response-response101 :: Headers -> B.ByteString -> Response-response101 headers body = Response 101 "WebSocket Protocol Handshake"-    (("Upgrade", "websocket") : ("Connection", "Upgrade") : headers)-    body---- | Bad request----response400 :: Headers -> Response-response400 headers = Response 400 "Bad Request" headers ""
+ src/Network/WebSockets/Http.hs view
@@ -0,0 +1,267 @@+--------------------------------------------------------------------------------+-- | Module dealing with HTTP: request data types, encoding and decoding...+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings  #-}+module Network.WebSockets.Http+    ( Headers+    , RequestHead (..)+    , Request (..)+    , ResponseHead (..)+    , Response (..)+    , HandshakeException (..)++    , encodeRequestHead+    , encodeRequest+    , decodeRequestHead++    , encodeResponseHead+    , encodeResponse+    , decodeResponseHead+    , decodeResponse++    , response101+    , response400++    , getRequestHeader+    , getResponseHeader+    , getRequestSecWebSocketVersion+    , getRequestSubprotocols+    , getRequestSecWebSocketExtensions+    ) where+++--------------------------------------------------------------------------------+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+++--------------------------------------------------------------------------------+-- | Request headers+type Headers = [(CI.CI ByteString, ByteString)]+++--------------------------------------------------------------------------------+-- | An HTTP request. The request body is not yet read.+data RequestHead = RequestHead+    { requestPath    :: !B.ByteString+    , requestHeaders :: Headers+    , requestSecure  :: Bool+    } deriving (Show)+++--------------------------------------------------------------------------------+-- | A request with a body+data Request = Request RequestHead B.ByteString+    deriving (Show)+++--------------------------------------------------------------------------------+-- | HTTP response, without body.+data ResponseHead = ResponseHead+    { responseCode    :: !Int+    , responseMessage :: !B.ByteString+    , responseHeaders :: Headers+    } deriving (Show)+++--------------------------------------------------------------------------------+-- | A response including a body+data Response = Response ResponseHead B.ByteString+    deriving (Show)+++--------------------------------------------------------------------------------+-- | Error in case of failed handshake. Will be thrown as an 'Exception'.+--+-- TODO: This should probably be in the Handshake module, and is solely here to+-- prevent a cyclic dependency.+data HandshakeException+    -- | We don't have a match for the protocol requested by the client.+    -- todo: version parameter+    = NotSupported+    -- | The request was somehow invalid (missing headers or wrong security+    -- token)+    | MalformedRequest RequestHead String+    -- | The servers response was somehow invalid (missing headers or wrong+    -- security token)+    | MalformedResponse ResponseHead String+    -- | The request was well-formed, but the library user rejected it.+    -- (e.g. "unknown path")+    | 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+    deriving (Show, Typeable)+++--------------------------------------------------------------------------------+instance Exception HandshakeException+++--------------------------------------------------------------------------------+encodeRequestHead :: RequestHead -> Builder.Builder+encodeRequestHead (RequestHead path headers _) =+    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.byteStringCopy "\r\n"+  where+    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.byteStringCopy body+++--------------------------------------------------------------------------------+-- | Parse an initial request+decodeRequestHead :: Bool -> A.Parser RequestHead+decodeRequestHead isSecure = RequestHead+    <$> requestLine+    <*> A.manyTill decodeHeaderLine newline+    <*> pure isSecure+  where+    space   = A.word8 (c2w ' ')+    newline = A.string "\r\n"++    requestLine = A.string "GET" *> space *> A.takeWhile1 (/= c2w ' ')+        <* space+        <* A.string "HTTP/1.1" <* newline+++--------------------------------------------------------------------------------+-- | Encode an HTTP upgrade response+encodeResponseHead :: ResponseHead -> Builder.Builder+encodeResponseHead (ResponseHead code msg headers) =+    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.byteStringCopy "\r\n"+  where+    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.byteStringCopy body+++--------------------------------------------------------------------------------+-- | An upgrade response+response101 :: Headers -> B.ByteString -> Response+response101 headers = Response+    (ResponseHead 101 "WebSocket Protocol Handshake"+        (("Upgrade", "websocket") : ("Connection", "Upgrade") : headers))+++--------------------------------------------------------------------------------+-- | Bad request+response400 :: Headers -> B.ByteString -> Response+response400 headers = Response (ResponseHead 400 "Bad Request" headers)+++--------------------------------------------------------------------------------+-- | HTTP response parser+decodeResponseHead :: A.Parser ResponseHead+decodeResponseHead = ResponseHead+    <$> fmap (read . BC.unpack) code+    <*> message+    <*> A.manyTill decodeHeaderLine newline+  where+    space = A.word8 (c2w ' ')+    newline = A.string "\r\n"++    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+++--------------------------------------------------------------------------------+decodeResponse :: A.Parser Response+decodeResponse = Response <$> decodeResponseHead <*> A.takeByteString+++--------------------------------------------------------------------------------+getRequestHeader :: RequestHead+                 -> CI.CI ByteString+                 -> Either HandshakeException ByteString+getRequestHeader rq key = case lookup key (requestHeaders rq) of+    Just t  -> Right t+    Nothing -> Left $ MalformedRequest rq $+        "Header missing: " ++ BC.unpack (CI.original key)+++--------------------------------------------------------------------------------+getResponseHeader :: ResponseHead+                  -> CI.CI ByteString+                  -> Either HandshakeException ByteString+getResponseHeader rsp key = case lookup key (responseHeaders rsp) of+    Just t  -> Right t+    Nothing -> Left $ MalformedResponse rsp $+        "Header missing: " ++ BC.unpack (CI.original key)+++--------------------------------------------------------------------------------+-- | Get the @Sec-WebSocket-Version@ header+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+++--------------------------------------------------------------------------------+decodeHeaderLine :: A.Parser (CI.CI ByteString, ByteString)+decodeHeaderLine = (,)+    <$> (CI.mk <$> A.takeWhile1 (/= c2w ':'))+    <*  A.word8 (c2w ':')+    <*  A.option (c2w ' ') (A.word8 (c2w ' '))+    <*> A.takeWhile (/= c2w '\r')+    <*  A.string "\r\n"
+ src/Network/WebSockets/Hybi13.hs view
@@ -0,0 +1,258 @@+--------------------------------------------------------------------------------+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE OverloadedStrings #-}+module Network.WebSockets.Hybi13+    ( headerVersions+    , finishRequest+    , finishResponse+    , encodeMessage+    , encodeMessages+    , decodeMessages+    , createRequest++      -- Internal (used for testing)+    , encodeFrame+    , parseFrame+    ) where+++--------------------------------------------------------------------------------+import qualified Data.ByteString.Builder               as B+import           Control.Applicative                   (pure, (<$>))+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.IORef+import           Data.Monoid                           (mappend, mconcat,+                                                        mempty)+import           Data.Tuple                            (swap)+import           System.Entropy                        as R+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+++--------------------------------------------------------------------------------+headerVersions :: [ByteString]+headerVersions = ["13"]+++--------------------------------------------------------------------------------+finishRequest :: RequestHead+              -> Headers+              -> Either HandshakeException Response+finishRequest reqHttp headers = do+    !key <- getRequestHeader reqHttp "Sec-WebSocket-Key"+    let !hash    = hashKey key+        !encoded = B64.encode hash+    return $ response101 (("Sec-WebSocket-Accept", encoded):headers) ""+++--------------------------------------------------------------------------------+finishResponse :: RequestHead+               -> ResponseHead+               -> 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+    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)+  where+    mkFrame      = Frame True False False False+    (mask, gen') = case conType of+        ServerConnection -> (Nothing, gen)+        ClientConnection -> first Just (randomMask gen)+    builder      = encodeFrame mask $ case msg of+        (ControlMessage (Close code pl)) -> mkFrame CloseFrame $+            runPut (putWord16be code) `mappend` pl+        (ControlMessage (Ping pl))               -> mkFrame PingFrame   pl+        (ControlMessage (Pong pl))               -> mkFrame PongFrame   pl+        (DataMessage rsv1 rsv2 rsv3 (Text pl _)) -> Frame True rsv1 rsv2 rsv3 TextFrame   pl+        (DataMessage rsv1 rsv2 rsv3 (Binary pl)) -> Frame True rsv1 rsv2 rsv3 BinaryFrame pl+++--------------------------------------------------------------------------------+encodeMessages+    :: ConnectionType+    -> Stream+    -> IO ([Message] -> IO ())+encodeMessages conType stream = do+    genRef <- newIORef =<< newStdGen+    return $ \msgs -> do+        builders <- forM msgs $ \msg ->+          atomicModifyIORef' genRef $ \s -> encodeMessage conType s msg+        Stream.write stream (B.toLazyByteString $ mconcat builders)+++--------------------------------------------------------------------------------+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+        BinaryFrame       -> 0x02+        CloseFrame        -> 0x08+        PingFrame         -> 0x09+        PongFrame         -> 0x0a+    (maskflag, maskbytes) = case mask of+        Nothing -> (0x00, mempty)+        Just m  -> (0x80, encodeMask m)++    byte1 = maskflag .|. lenflag+    len'  = BL.length payload+    (lenflag, len)+        | len' < 126     = (fromIntegral len', mempty)+        | len' < 0x10000 = (126, B.word16BE (fromIntegral len'))+        | otherwise      = (127, B.word64BE (fromIntegral len'))+++--------------------------------------------------------------------------------+decodeMessages+    :: SizeLimit+    -> SizeLimit+    -> Stream+    -> IO (IO (Maybe Message))+decodeMessages frameLimit messageLimit stream = do+    dmRef <- newIORef emptyDemultiplexState+    return $ go dmRef+  where+    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 :: 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++    byte1 <- getWord8+    let mask = byte1 .&. 0x80 == 0x80+        lenflag = byte1 .&. 0x7f++    len <- case lenflag of+        126 -> fromIntegral <$> getWord16be+        127 -> getInt64be+        _   -> return (fromIntegral lenflag)++    -- Check size against limit.+    unless (atMostSizeLimit len frameSizeLimit) $+        fail $ "Frame of size " ++ show len ++ " exceeded limit"++    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++    masker <- maskPayload <$> if mask then Just <$> parseMask else pure Nothing++    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+hashKey key = unlazy $ bytestringDigest $ sha1 $ lazy $ key `mappend` guid+  where+    guid = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"+    lazy = BL.fromChunks . return+    unlazy = mconcat . BL.toChunks+++--------------------------------------------------------------------------------+createRequest :: ByteString+              -> ByteString+              -> Bool+              -> Headers+              -> IO RequestHead+createRequest hostname path secure customHeaders = do+    key <- B64.encode `liftM`  getEntropy 16+    return $ RequestHead path (headers key ++ customHeaders) secure+  where+    headers key =+        [ ("Host"                   , hostname     )+        , ("Connection"             , "Upgrade"    )+        , ("Upgrade"                , "websocket"  )+        , ("Sec-WebSocket-Key"      , key          )+        , ("Sec-WebSocket-Version"  , versionNumber)+        ]++    versionNumber = head headerVersions
+ src/Network/WebSockets/Hybi13/Demultiplex.hs view
@@ -0,0 +1,157 @@+--------------------------------------------------------------------------------+-- | Demultiplexing of frames into messages+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings  #-}+module Network.WebSockets.Hybi13.Demultiplex+    ( FrameType (..)+    , Frame (..)+    , DemultiplexState+    , emptyDemultiplexState+    , DemultiplexResult (..)+    , demultiplex+    ) where+++--------------------------------------------------------------------------------+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+++--------------------------------------------------------------------------------+-- | A low-level representation of a WebSocket packet+data Frame = Frame+    { frameFin     :: !Bool+    , frameRsv1    :: !Bool+    , frameRsv2    :: !Bool+    , frameRsv3    :: !Bool+    , frameType    :: !FrameType+    , framePayload :: !BL.ByteString+    } deriving (Eq, Show)+++--------------------------------------------------------------------------------+-- | The type of a frame. Not all types are allowed for all protocols.+data FrameType+    = ContinuationFrame+    | TextFrame+    | BinaryFrame+    | CloseFrame+    | PingFrame+    | PongFrame+    deriving (Eq, Show)+++--------------------------------------------------------------------------------+-- | Thrown if the client sends invalid multiplexed data+data DemultiplexException = DemultiplexException+    deriving (Show, Typeable)+++--------------------------------------------------------------------------------+instance Exception DemultiplexException+++--------------------------------------------------------------------------------+-- | Internal state used by the demultiplexer+data DemultiplexState+    = EmptyDemultiplexState+    | DemultiplexState !Int64 !Builder !(Builder -> Message)+++--------------------------------------------------------------------------------+emptyDemultiplexState :: DemultiplexState+emptyDemultiplexState = EmptyDemultiplexState+++--------------------------------------------------------------------------------+-- | Result of demultiplexing+data DemultiplexResult+    = DemultiplexSuccess  Message+    | DemultiplexError    ConnectionException+    | DemultiplexContinue+++--------------------------------------------------------------------------------+demultiplex :: SizeLimit+            -> DemultiplexState+            -> Frame+            -> (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       ->+            (DemultiplexSuccess (text pl), emptyDemultiplexState)+        | otherwise ->+            (DemultiplexContinue, DemultiplexState size plb (text . B.toLazyByteString))+++    BinaryFrame+        | fin       -> (DemultiplexSuccess (binary pl), emptyDemultiplexState)+        | otherwise -> (DemultiplexContinue, DemultiplexState size plb (binary . B.toLazyByteString))++    _ -> (DemultiplexError $ CloseRequest 1002 "Protocol Error", emptyDemultiplexState)++  where+    size     = BL.length pl+    plb      = B.lazyByteString pl+    text   x = DataMessage rsv1 rsv2 rsv3 (Text x Nothing)+    binary x = DataMessage rsv1 rsv2 rsv3 (Binary x)++demultiplex sizeLimit (DemultiplexState size0 b f) (Frame fin False False False ContinuationFrame pl)+    | not (atMostSizeLimit size1 sizeLimit) =+        ( DemultiplexError $ ParseException $+            "Message of size " ++ show size1 ++ " exceeded limit"+        , emptyDemultiplexState+        )+    | fin         = (DemultiplexSuccess (f b'), emptyDemultiplexState)+    | otherwise   = (DemultiplexContinue, DemultiplexState size1 b' f)+  where+    size1 = size0 + BL.length pl+    b'    = b `mappend` plb+    plb   = B.lazyByteString pl++demultiplex _ _ _ =+    (DemultiplexError (CloseRequest 1002 "Protocol Error"), emptyDemultiplexState)
+ src/Network/WebSockets/Hybi13/Mask.hs view
@@ -0,0 +1,81 @@+--------------------------------------------------------------------------------+-- | Masking of fragmes using a simple XOR algorithm+{-# LANGUAGE BangPatterns             #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE OverloadedStrings        #-}+{-# LANGUAGE ScopedTypeVariables      #-}+module Network.WebSockets.Hybi13.Mask+    ( Mask+    , parseMask+    , encodeMask+    , randomMask++    , maskPayload+    ) where+++--------------------------------------------------------------------------------+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)+++--------------------------------------------------------------------------------+foreign import ccall unsafe "_hs_mask_chunk" c_mask_chunk+    :: Word32 -> CInt -> Ptr CChar -> CSize -> Ptr Word8 -> IO ()+++--------------------------------------------------------------------------------+-- | 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 = (Mask int, gen')+  where+    (!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/Internal.hs 
@@ -1,8 +0,0 @@--- | This module exports some extra functions. However, note that these--- utilities are primarily meant for internal use, and can change between minor--- releases.-module Network.WebSockets.Internal-    ( S.iterSocket-    ) where--import qualified Network.WebSockets.Socket as S
− src/Network/WebSockets/Monad.hs 
@@ -1,257 +0,0 @@--- | Provides a simple, clean monad to write websocket servers in-{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, OverloadedStrings,-        NoMonomorphismRestriction, Rank2Types, ScopedTypeVariables #-}-module Network.WebSockets.Monad-    ( WebSocketsOptions (..)-    , defaultWebSocketsOptions-    , WebSockets (..)-    , runWebSockets-    , runWebSocketsWith-    , runWebSocketsHandshake-    , runWebSocketsWithHandshake-    , runWebSocketsWith'-    , receive-    , sendBuilder-    , send-    , Sink-    , sendSink-    , getSink-    , getOptions-    , getProtocol-    , getVersion-    , throwWsError-    , catchWsError-    , spawnPingThread-    ) where--import Control.Applicative (Applicative, (<$>))-import Control.Concurrent (forkIO, threadDelay)-import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar)-import Control.Exception (Exception (..), SomeException, throw)-import Control.Monad (forever)-import Control.Monad.Reader (ReaderT, ask, runReaderT)-import Control.Monad.Trans (MonadIO, lift, liftIO)-import Data.Foldable (forM_)--import Blaze.ByteString.Builder (Builder)-import Data.ByteString (ByteString)-import Data.Enumerator (Enumerator, Iteratee, ($$), (>>==), (=$))-import qualified Blaze.ByteString.Builder as BB-import qualified Data.Attoparsec as A-import qualified Data.ByteString.Lazy as BL-import qualified Data.Attoparsec.Enumerator as AE-import qualified Data.Enumerator as E-import qualified Data.Enumerator.List as EL--import Network.WebSockets.Handshake-import Network.WebSockets.Handshake.Http-import Network.WebSockets.Protocol-import Network.WebSockets.Types---- | Options for the WebSocket program-data WebSocketsOptions = WebSocketsOptions-    { onPong       :: IO ()-    }---- | Default options-defaultWebSocketsOptions :: WebSocketsOptions-defaultWebSocketsOptions = WebSocketsOptions-    { onPong       = return ()-    }---- | Environment in which the 'WebSockets' monad actually runs-data WebSocketsEnv p = WebSocketsEnv-    { envOptions     :: WebSocketsOptions-    , envSendBuilder :: Builder -> IO ()-    , envSink        :: Sink p-    , envProtocol    :: p-    }---- | Used for asynchronous sending.-newtype Sink p = Sink-    { unSink :: MVar (E.Iteratee (Message p) IO ())-    }---- | The monad in which you can write WebSocket-capable applications-newtype WebSockets p a = WebSockets-    { unWebSockets :: ReaderT (WebSocketsEnv p) (Iteratee (Message p) IO) a-    } deriving (Applicative, Functor, Monad, MonadIO)---- | Receives the initial client handshake, then behaves like 'runWebSockets'.-runWebSocketsHandshake :: Protocol p-                       => Bool-                       -> (Request -> WebSockets p a)-                       -> Iteratee ByteString IO ()-                       -> Iteratee ByteString IO a-runWebSocketsHandshake = runWebSocketsWithHandshake defaultWebSocketsOptions---- | Receives the initial client handshake, then behaves like--- 'runWebSocketsWith'.-runWebSocketsWithHandshake :: Protocol p-                           => WebSocketsOptions-                           -> Bool-                           -> (Request -> WebSockets p a)-                           -> Iteratee ByteString IO ()-                           -> Iteratee ByteString IO a-runWebSocketsWithHandshake opts isSecure goWs outIter = do-    httpReq <- receiveIteratee $ decodeRequest isSecure-    runWebSocketsWith opts httpReq goWs outIter---- | Run a 'WebSockets' application on an 'Enumerator'/'Iteratee' pair, given--- that you (read: your web server) has already received the HTTP part of the--- initial request. If not, you might want to use 'runWebSocketsWithHandshake'--- instead.------ If the handshake failed, throws a 'HandshakeError'. Otherwise, executes the--- supplied continuation. You should still send a response to the client--- yourself.-runWebSockets :: Protocol p-              => RequestHttpPart-              -> (Request -> WebSockets p a)-              -> Iteratee ByteString IO ()-              -> Iteratee ByteString IO a-runWebSockets = runWebSocketsWith defaultWebSocketsOptions---- | Version of 'runWebSockets' which allows you to specify custom options-runWebSocketsWith :: forall p a. Protocol p-                  => WebSocketsOptions-                  -> RequestHttpPart-                  -> (Request -> WebSockets p a)-                  -> Iteratee ByteString IO ()-                  -> Iteratee ByteString IO a-runWebSocketsWith opts httpReq goWs outIter = E.catchError ok $ \e -> do-    -- If handshake went bad, send response-    forM_ (fromException e) $ \he ->-        let builder = encodeResponse $ responseError (undefined :: p) he-        in liftIO $ makeBuilderSender outIter builder-    -- Re-throw error-    E.throwError e-  where-    -- Perform handshake, call runWebSocketsWith'-    ok = do-        (rq, p) <- handshake httpReq-        runWebSocketsWith' opts p (goWs rq) outIter--runWebSocketsWith' :: Protocol p-                   => WebSocketsOptions-                   -> p-                   -> WebSockets p a-                   -> Iteratee ByteString IO ()-                   -> Iteratee ByteString IO a-runWebSocketsWith' opts proto ws outIter = do-    -- Create sink with a random source-    let sinkIter = encodeMessages proto =$ builderToByteString =$ outIter-    sink <- Sink <$> liftIO (newMVar sinkIter)--    let sender = makeBuilderSender outIter-        env    = WebSocketsEnv opts sender sink proto-        iter   = runReaderT (unWebSockets ws) env--    decodeMessages proto =$ iter--makeBuilderSender :: MonadIO m => Iteratee ByteString m b -> Builder -> m ()-makeBuilderSender outIter x = do-    ok <- E.run $ singleton x $$ builderToByteString $$ outIter-    case ok of-        Left err -> throw err-        Right _  -> return ()---- | @spawnPingThread n@ spawns a thread which sends a ping every @n@ seconds--- (if the protocol supports it). To be called after having sent the response.-spawnPingThread :: BinaryProtocol p => Int -> WebSockets p ()-spawnPingThread i = do-    sink <- getSink-    _ <- liftIO $ forkIO $ forever $ do-        -- An ugly hack here. We first sleep before sending the first-        -- ping, so the ping (hopefully) doesn't interfere with the-        -- intitial request/response.-        threadDelay (i * 1000 * 1000)  -- seconds-        sendSink sink $ ping ("Hi" :: ByteString)-    return ()---- | Receive arbitrary data.-receiveIteratee :: A.Parser a -> Iteratee ByteString IO a-receiveIteratee parser = do-    eof <- E.isEOF-    if eof-        then E.throwError ConnectionClosed-        else wrappingParseError . AE.iterParser $ parser---- | Execute an iteratee, wrapping attoparsec-enumeratee's ParseError into the--- ParseError constructor (which is a ConnectionError).-wrappingParseError :: (Monad m) => Iteratee a m b -> Iteratee a m b-wrappingParseError = flip E.catchError $ \e -> E.throwError $-    maybe e (toException . ParseError) $ fromException e---- | Receive a message-receive :: Protocol p => WebSockets p (Message p)-receive = liftIteratee $ do-    mmsg <- EL.head-    case mmsg of-        Nothing  -> E.throwError ConnectionClosed-        Just msg -> return msg---- | Send an arbitrary 'Builder'-sendBuilder :: Builder -> WebSockets p ()-sendBuilder builder = WebSockets $ do-    sb <- envSendBuilder <$> ask-    liftIO $ sb builder---- | Low-level sending with an arbitrary 'T.Message'-send :: Protocol p => Message p -> WebSockets p ()-send msg = getSink >>= \sink -> liftIO $ sendSink sink msg---- | Send a message to a sink. Might generate an exception if the underlying--- connection is closed.-sendSink :: Sink p -> Message p -> IO ()-sendSink sink msg = modifyMVar_ (unSink sink) $ \iter -> do-    step <- E.runIteratee $ singleton msg $$ iter-    case step of-        E.Error err -> throw err-        _           -> return $! E.returnI step---- | In case the user of the library wants to do asynchronous sending to the--- socket, he can extract a 'Sink' and pass this value around, for example,--- to other threads.-getSink :: Protocol p => WebSockets p (Sink p)-getSink = WebSockets $ envSink <$> ask--singleton :: Monad m => a -> Enumerator a m b-singleton c = E.checkContinue0 $ \_ f -> f (E.Chunks [c]) >>== E.returnI---- TODO: Figure out why Blaze.ByteString.Enumerator.builderToByteString doesn't--- work, then inform Simon or send a patch.-builderToByteString :: Monad m => E.Enumeratee Builder ByteString m a-builderToByteString = EL.concatMap $ BL.toChunks . BB.toLazyByteString---- | Get the current configuration-getOptions :: WebSockets p WebSocketsOptions-getOptions = WebSockets $ ask >>= return . envOptions---- | Get the underlying protocol-getProtocol :: WebSockets p p-getProtocol = WebSockets $ envProtocol <$> ask---- | Find out the 'WebSockets' version used at runtime-getVersion :: Protocol p => WebSockets p String-getVersion = version <$> getProtocol---- | Throw an iteratee error in the WebSockets monad-throwWsError :: (Exception e) => e -> WebSockets p a-throwWsError = liftIteratee . E.throwError---- | Catch an iteratee error in the WebSockets monad-catchWsError :: WebSockets p a-             -> (SomeException -> WebSockets p a)-             -> WebSockets p a-catchWsError act c = WebSockets $ do-    env <- ask-    let it  = peelWebSockets env $ act-        cit = peelWebSockets env . c-    lift $ it `E.catchError` cit-  where-    peelWebSockets env = flip runReaderT env . unWebSockets---- | Lift an Iteratee computation to WebSockets-liftIteratee :: Iteratee (Message p) IO a -> WebSockets p a-liftIteratee = WebSockets . lift
src/Network/WebSockets/Protocol.hs view
@@ -1,81 +1,91 @@+-------------------------------------------------------------------------------- -- | Wrapper for supporting multiple protocol versions {-# LANGUAGE ExistentialQuantification #-} module Network.WebSockets.Protocol     ( Protocol (..)-    , TextProtocol-    , BinaryProtocol-    , close-    , ping-    , pong-    , textData-    , binaryData+    , defaultProtocol+    , protocols+    , compatible+    , headerVersions+    , finishRequest+    , finishResponse+    , encodeMessages+    , decodeMessages+    , createRequest     ) where -import Blaze.ByteString.Builder (Builder)-import qualified Data.ByteString as B-import qualified Data.Enumerator as E -import Network.WebSockets.Types-import Network.WebSockets.Handshake.Http-import qualified Network.WebSockets.Protocol.Unsafe as Unsafe+--------------------------------------------------------------------------------+import           Data.ByteString                       (ByteString)+import qualified Data.ByteString                       as B -class Protocol p where-    -- | Unique identifier for us.-    version         :: p -> String -    -- | Version accepted in the "Sec-WebSocket-Version " header. This is-    -- usually not the same, or derivable from "version", e.g. for hybi10, it's-    -- "7", "8" or "17".-    headerVersions  :: p -> [B.ByteString]+--------------------------------------------------------------------------------+import           Network.WebSockets.Connection.Options+import           Network.WebSockets.Http+import qualified Network.WebSockets.Hybi13             as Hybi13+import           Network.WebSockets.Stream             (Stream)+import           Network.WebSockets.Types -    -- | Determine if the protocol is compatible with a requested version. A-    -- default implementation exists which uses the @headerVersions@ of the-    -- protocol.-    supported       :: p -> RequestHttpPart -> Bool-    supported p h   = case getSecWebSocketVersion h of-        Just v -> v `elem` headerVersions p-        _      -> False -    -- | Encodes messages to binary 'Builder's. Takes a random source so it is-    -- able to do masking of frames (needed in some cases).-    encodeMessages  :: Monad m-                    => p-                    -> E.Enumeratee (Message p) Builder m a+--------------------------------------------------------------------------------+data Protocol+    = Hybi13+    deriving (Show) -    -- | Decodes messages from binary 'B.ByteString's.-    decodeMessages  :: Monad m => p -> E.Enumeratee B.ByteString (Message p) m a -    -- | Parse and validate the rest of the request. For hybi10, this is just-    -- validation, but hybi00 also needs to fetch a "security token"-    ---    -- In case of failure, this function may throw a 'HandshakeError'.-    -- be amended with the RequestHttpPart for the user)-    finishRequest   :: Monad m-                    => p -> RequestHttpPart-                    -> E.Iteratee B.ByteString m Request+--------------------------------------------------------------------------------+defaultProtocol :: Protocol+defaultProtocol = Hybi13 -    -- | Implementations of the specification-    implementations :: [p] -class Protocol p => TextProtocol p-class TextProtocol p => BinaryProtocol p+--------------------------------------------------------------------------------+protocols :: [Protocol]+protocols = [Hybi13] --- | Construct a close message-close :: (TextProtocol p, WebSocketsData a) => a -> Message p-close = Unsafe.close --- | Construct a ping message-ping :: (BinaryProtocol p, WebSocketsData a) => a -> Message p-ping = Unsafe.ping+--------------------------------------------------------------------------------+headerVersions :: Protocol -> [ByteString]+headerVersions Hybi13 = Hybi13.headerVersions --- | Construct a pong message-pong :: (BinaryProtocol p, WebSocketsData a) => a -> Message p-pong = Unsafe.pong --- | Construct a text message-textData :: (TextProtocol p, WebSocketsData a) => a -> Message p-textData = Unsafe.textData+--------------------------------------------------------------------------------+compatible :: Protocol -> RequestHead -> Bool+compatible protocol req = case getRequestSecWebSocketVersion req of+    Just v -> v `elem` headerVersions protocol+    _      -> True  -- Whatever? --- | Construct a binary message-binaryData :: (BinaryProtocol p, WebSocketsData a) => a -> Message p-binaryData = Unsafe.binaryData++--------------------------------------------------------------------------------+finishRequest+    :: Protocol -> RequestHead -> Headers -> Either HandshakeException Response+finishRequest Hybi13 = Hybi13.finishRequest+++--------------------------------------------------------------------------------+finishResponse+    :: Protocol -> RequestHead -> ResponseHead+    -> Either HandshakeException Response+finishResponse Hybi13 = Hybi13.finishResponse+++--------------------------------------------------------------------------------+encodeMessages+    :: Protocol -> ConnectionType -> Stream+    -> IO ([Message] -> IO ())+encodeMessages Hybi13 = Hybi13.encodeMessages+++--------------------------------------------------------------------------------+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 Hybi13 = Hybi13.createRequest
− src/Network/WebSockets/Protocol/Hybi00.hs 
@@ -1,25 +0,0 @@-{-# LANGUAGE ExistentialQuantification, OverloadedStrings #-}-module Network.WebSockets.Protocol.Hybi00-       ( Hybi00_ (..)-       , Hybi00-       ) where--import Data.Enumerator ((=$))-import Data.Enumerator.List as EL-import Network.WebSockets.Protocol-import Network.WebSockets.Protocol.Hybi00.Internal-import Network.WebSockets.Protocol.Hybi10.Internal-import Network.WebSockets.Protocol.Unsafe--data Hybi00 = forall p. Protocol p => Hybi00 p--instance Protocol Hybi00 where-    version        (Hybi00 p)   = version p-    headerVersions (Hybi00 p)   = headerVersions p-    supported      (Hybi00 p) h = supported p h-    encodeMessages (Hybi00 p)   = (EL.map castMessage =$) . encodeMessages p-    decodeMessages (Hybi00 p)   = (decodeMessages p =$) . EL.map castMessage-    finishRequest  (Hybi00 p)   = finishRequest p-    implementations             = [Hybi00 Hybi10_, Hybi00 Hybi00_]--instance TextProtocol Hybi00
− src/Network/WebSockets/Protocol/Hybi00/Internal.hs 
@@ -1,102 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}-module Network.WebSockets.Protocol.Hybi00.Internal-       ( Hybi00_ (..)-       ) where--import Control.Applicative ((<|>))-import Data.Char (isDigit)--import Data.Binary (encode)-import Data.ByteString.Lazy.Char8 ()-import Data.Digest.Pure.MD5 (md5)-import Data.Int (Int32)-import qualified Blaze.ByteString.Builder as BB-import qualified Data.Attoparsec as A-import qualified Data.Attoparsec.Enumerator as A-import qualified Data.ByteString as B-import qualified Data.Enumerator as E-import qualified Data.Enumerator.List as EL-import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Lazy as BL-import qualified Data.CaseInsensitive as CI--import Network.WebSockets.Handshake.Http-import Network.WebSockets.Protocol-import Network.WebSockets.Types--data Hybi00_ = Hybi00_--instance Protocol Hybi00_ where-    version         Hybi00_   = "hybi00"-    headerVersions  Hybi00_   = []  -- The client will elide it-    supported       Hybi00_ h = getSecWebSocketVersion h == Nothing-    encodeMessages  Hybi00_   = EL.map encodeMessage-    decodeMessages  Hybi00_   = E.sequence (A.iterParser parseMessage)-    finishRequest   Hybi00_   = handshakeHybi00-    implementations           = [Hybi00_]--instance TextProtocol Hybi00_--encodeMessage :: Message p -> BB.Builder-encodeMessage (DataMessage (Text pl))    =-    BB.fromLazyByteString $ "\0" `BL.append` pl `BL.append` "\255"-encodeMessage (ControlMessage (Close _)) =-    BB.fromLazyByteString  "\255\0"-encodeMessage msg                        = error $-    "Network.WebSockets.Protocol.Hybi00.encodeFrame: unsupported message: " ++-    show msg--parseMessage :: A.Parser (Message p)-parseMessage = parseText <|> parseClose-  where-    parseText = do-        _ <- A.word8 0x00-        utf8string <- A.manyTill A.anyWord8 (A.try $ A.word8 0xff)-        return $ DataMessage $ Text $ BL.pack utf8string--    parseClose = do-        _ <- A.word8 0xff-        _ <- A.word8 0x00-        return $ ControlMessage $ Close ""--divBySpaces :: String -> Maybe Int32-divBySpaces str-    | spaces == 0 = Nothing-    | otherwise   = Just . fromIntegral $ number `div` spaces-  where-    number = read $ filter isDigit str :: Integer-    spaces = fromIntegral . length $ filter (== ' ') str--handshakeHybi00 :: Monad m-                => RequestHttpPart-                -> E.Iteratee B.ByteString m Request-handshakeHybi00 reqHttp@(RequestHttpPart path h isSecure) = do-    keyPart3 <- A.iterParser $ A.take 8-    keyPart1 <- numberFromToken =<< getHeader "Sec-WebSocket-Key1"-    keyPart2 <- numberFromToken =<< getHeader "Sec-WebSocket-Key2"--    let key = B.concat . BL.toChunks . encode . md5 $ BL.concat-                [keyPart1, keyPart2, BL.fromChunks [keyPart3]]--    host <- getHeader "Host"-    -- todo: origin right? (also applies to hybi10)-    origin <- getHeader "Origin"-    let schema = if isSecure then "wss://" else "ws://"-    let response = response101-            [ ("Sec-WebSocket-Location", B.concat [schema, host, path])-            , ("Sec-WebSocket-Origin", origin)-            ]-            key--    return $ Request path h response-  where-    getHeader k = case lookup k h of-        Just t  -> return t-        Nothing -> E.throwError $ MalformedRequest reqHttp $-            "Header missing: " ++ BC.unpack (CI.original k)--    numberFromToken token = case divBySpaces (BC.unpack token) of-        Just n  -> return $ encode n-        Nothing -> E.throwError $ MalformedRequest reqHttp-            "Security token does not contain enough spaces"
− src/Network/WebSockets/Protocol/Hybi10.hs 
@@ -1,24 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-module Network.WebSockets.Protocol.Hybi10-    ( Hybi10-    ) where--import Data.Enumerator ((=$))-import Data.Enumerator.List as EL-import Network.WebSockets.Protocol-import Network.WebSockets.Protocol.Hybi10.Internal-import Network.WebSockets.Protocol.Unsafe--data Hybi10 = forall p. Protocol p => Hybi10 p--instance Protocol Hybi10 where-    version        (Hybi10 p)   = version p-    headerVersions (Hybi10 p)   = headerVersions p-    supported      (Hybi10 p) h = supported p h-    encodeMessages (Hybi10 p)   = (EL.map castMessage =$) . encodeMessages p-    decodeMessages (Hybi10 p)   = (decodeMessages p =$) . EL.map castMessage-    finishRequest  (Hybi10 p)   = finishRequest p-    implementations             = [Hybi10 Hybi10_]--instance TextProtocol Hybi10-instance BinaryProtocol Hybi10
− src/Network/WebSockets/Protocol/Hybi10/Demultiplex.hs 
@@ -1,77 +0,0 @@--- | Demultiplexing of frames into messages-module Network.WebSockets.Protocol.Hybi10.Demultiplex-    ( FrameType (..)-    , Frame (..)-    , DemultiplexState-    , emptyDemultiplexState-    , demultiplex-    ) where--import Blaze.ByteString.Builder (Builder)-import Data.Monoid (mappend)-import qualified Blaze.ByteString.Builder as B-import qualified Data.ByteString.Lazy as BL--import Network.WebSockets.Types---- | A low-level representation of a WebSocket packet-data Frame = Frame-    { frameFin     :: !Bool-    , frameRsv1    :: !Bool-    , frameRsv2    :: !Bool-    , frameRsv3    :: !Bool-    , frameType    :: !FrameType-    , framePayload :: !BL.ByteString-    } deriving (Eq, Show)---- | The type of a frame. Not all types are allowed for all protocols.-data FrameType-    = ContinuationFrame-    | TextFrame-    | BinaryFrame-    | CloseFrame-    | PingFrame-    | PongFrame-    deriving (Eq, Show)---- | Internal state used by the demultiplexer-newtype DemultiplexState = DemultiplexState-    { unDemultiplexState :: Maybe (FrameType, Builder)-    }--emptyDemultiplexState :: DemultiplexState-emptyDemultiplexState = DemultiplexState Nothing--demultiplex :: DemultiplexState-            -> Frame-            -> (Maybe (Message p), 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)-                _           -> error "Demultiplex.demultiplex: Internal error"-          where-            b' = b `mappend` plb-            m = B.toLazyByteString b'-    TextFrame-        | fin       -> (Just (DataMessage (Text pl)), e)-        | otherwise -> (Nothing, DemultiplexState (Just (TextFrame, plb)))-    BinaryFrame-        | fin       -> (Just (DataMessage (Binary pl)), e)-        | otherwise -> (Nothing, DemultiplexState (Just (BinaryFrame, plb)))-  where-    e = emptyDemultiplexState-    plb = B.fromLazyByteString pl
− src/Network/WebSockets/Protocol/Hybi10/Internal.hs 
@@ -1,156 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Network.WebSockets.Protocol.Hybi10.Internal-    ( Hybi10_ (..)-    , encodeFrameHybi10-    ) where--import Control.Applicative (pure, (<$>))-import Data.Bits ((.&.), (.|.))-import Data.Maybe (maybeToList)-import Data.Monoid (mempty, mappend, mconcat)--import Data.Attoparsec (anyWord8)-import Data.Binary.Get (runGet, getWord16be, getWord64be)-import Data.ByteString (ByteString)-import Data.ByteString.Char8 ()-import Data.Digest.Pure.SHA (bytestringDigest, sha1)-import Data.Int (Int64)-import Data.Enumerator ((=$))-import qualified Blaze.ByteString.Builder as B-import qualified Data.Attoparsec as A-import qualified Data.Attoparsec.Enumerator as A-import qualified Data.ByteString.Base64 as B64-import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Lazy as BL-import qualified Data.CaseInsensitive as CI-import qualified Data.Enumerator as E-import qualified Data.Enumerator.List as EL--import Network.WebSockets.Handshake.Http-import Network.WebSockets.Protocol-import Network.WebSockets.Protocol.Hybi10.Demultiplex-import Network.WebSockets.Protocol.Hybi10.Mask-import Network.WebSockets.Types--data Hybi10_ = Hybi10_--instance Protocol Hybi10_ where-    version         Hybi10_ = "hybi10"-    headerVersions  Hybi10_ = ["13", "8", "7"]-    encodeMessages  Hybi10_ = EL.map encodeMessageHybi10-    decodeMessages  Hybi10_ = decodeMessagesHybi10-    finishRequest   Hybi10_ = handshakeHybi10-    implementations         = [Hybi10_]--instance TextProtocol Hybi10_-instance BinaryProtocol Hybi10_--encodeMessageHybi10 :: Message p -> B.Builder-encodeMessageHybi10 msg = builder-  where-    mkFrame = Frame True False False False-    builder = encodeFrameHybi10 $ 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---- | Encode a frame-encodeFrameHybi10 :: Frame -> B.Builder-encodeFrameHybi10 f = B.fromWord8 byte0 `mappend`-    B.fromWord8 byte1 `mappend` len `mappend`-    B.fromLazyByteString (framePayload f)-  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-    opcode = case frameType f of-        ContinuationFrame -> 0x00-        TextFrame         -> 0x01-        BinaryFrame       -> 0x02-        CloseFrame        -> 0x08-        PingFrame         -> 0x09-        PongFrame         -> 0x0a--    byte1 = lenflag-    len'  = BL.length (framePayload f)-    (lenflag, len)-        | len' < 126     = (fromIntegral len', mempty)-        | len' < 0x10000 = (126, B.fromWord16be (fromIntegral len'))-        | otherwise      = (127, B.fromWord64be (fromIntegral len'))--decodeMessagesHybi10 :: Monad m => E.Enumeratee ByteString (Message p) m a-decodeMessagesHybi10 =-    (E.sequence (A.iterParser parseFrame) =$) . demultiplexEnum--demultiplexEnum :: Monad m => E.Enumeratee Frame (Message p) m a-demultiplexEnum = EL.concatMapAccum step emptyDemultiplexState-  where-    step s f = let (m, s') = demultiplex s f in (s', maybeToList m)---- | Parse a frame-parseFrame :: A.Parser Frame-parseFrame = do-    byte0 <- anyWord8-    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-    let mask = byte1 .&. 0x80 == 0x80-        lenflag = fromIntegral (byte1 .&. 0x7f)--    len <- case lenflag of-        126 -> fromIntegral . runGet' getWord16be <$> A.take 2-        127 -> fromIntegral . runGet' getWord64be <$> A.take 8-        _   -> return lenflag--    masker <- maskPayload <$> if mask then Just <$> A.take 4 else pure Nothing--    chunks <- take64 len--    return $ Frame fin rsv1 rsv2 rsv3 ft (masker $ BL.fromChunks chunks)-  where-    runGet' g = runGet g . BL.fromChunks . return--    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)--handshakeHybi10 :: Monad m-                => RequestHttpPart-                -> E.Iteratee ByteString m Request-handshakeHybi10 reqHttp@(RequestHttpPart path h _) = do-    key <- getHeader "Sec-WebSocket-Key"-    let hash = unlazy $ bytestringDigest $ sha1 $ lazy $ key `mappend` guid-    let encoded = B64.encode hash-    return $ Request path h $ response101 [("Sec-WebSocket-Accept", encoded)] ""-  where-    guid = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"-    lazy = BL.fromChunks . return-    unlazy = mconcat . BL.toChunks-    getHeader k = case lookup k h of-        Just t  -> return t-        Nothing -> E.throwError $ MalformedRequest reqHttp $ -            "Header missing: " ++ BC.unpack (CI.original k)
− src/Network/WebSockets/Protocol/Hybi10/Mask.hs 
@@ -1,24 +0,0 @@--- | Masking of fragmes using a simple XOR algorithm-{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}-module Network.WebSockets.Protocol.Hybi10.Mask-    ( Mask-    , maskPayload-    ) where--import Data.Bits (xor)--import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL---- | ByteString should be exactly 4 bytes long-type Mask = Maybe B.ByteString---- | 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)
− src/Network/WebSockets/Protocol/Unsafe.hs 
@@ -1,35 +0,0 @@-module Network.WebSockets.Protocol.Unsafe-    ( castMessage-    , close-    , ping-    , pong-    , textData-    , binaryData-    ) where--import Network.WebSockets.Types--castMessage :: Message p1 -> Message p2-castMessage (ControlMessage m) = ControlMessage $ case m of-    Close b -> Close b-    Ping b  -> Ping b-    Pong b  -> Pong b-castMessage (DataMessage m)    = DataMessage $ case m of-    Text b   -> Text b-    Binary b -> Binary b-{-# INLINE castMessage #-}--close :: WebSocketsData a => a -> Message p-close = ControlMessage . Close . toLazyByteString--ping :: WebSocketsData a => a -> Message p-ping = ControlMessage . Ping . toLazyByteString--pong :: WebSocketsData a => a -> Message p-pong = ControlMessage . Pong . toLazyByteString--textData :: WebSocketsData a => a -> Message p-textData = DataMessage . Text . toLazyByteString--binaryData :: WebSocketsData a => a -> Message p-binaryData = DataMessage . Binary . toLazyByteString
+ src/Network/WebSockets/Server.hs view
@@ -0,0 +1,174 @@+--------------------------------------------------------------------------------+-- | This provides a simple stand-alone server for 'WebSockets' applications.+-- Note that in production you want to use a real webserver such as snap or+-- warp.+{-# LANGUAGE OverloadedStrings #-}+module Network.WebSockets.Server+    ( ServerApp+    , runServer+    , ServerOptions (..)+    , defaultServerOptions+    , runServerWithOptions+    , runServerWith+    , makeListenSocket+    , makePendingConnection+    , makePendingConnectionFromStream++    , PongTimeout+    ) where+++--------------------------------------------------------------------------------+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           Network.WebSockets.Connection+import           Network.WebSockets.Connection.PingPong (PongTimeout(..))+import           Network.WebSockets.Http+import qualified Network.WebSockets.Stream     as Stream+import           Network.WebSockets.Types+++--------------------------------------------------------------------------------+-- | WebSockets application that can be ran by a server. Once this 'IO' action+-- finishes, the underlying socket is closed automatically.+type ServerApp = PendingConnection -> IO ()+++--------------------------------------------------------------------------------+-- | 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+          -> IO ()      -- ^ Never returns+runServer host port app = runServerWith host port defaultConnectionOptions app+++--------------------------------------------------------------------------------+-- | A version of 'runServer' which allows you to customize some options.+runServerWith :: String -> Int -> ConnectionOptions -> ServerApp -> IO ()+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 =+    bracket+        (makePendingConnection socket opts)+        (Stream.close . pendingStream)+        app+++--------------------------------------------------------------------------------+-- | 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/Socket.hs 
@@ -1,78 +0,0 @@--- | Simple module which provides the low-level socket handling in case you want--- to write a stand-alone 'WebSockets' application.-{-# LANGUAGE OverloadedStrings #-}-module Network.WebSockets.Socket-    ( runServer-    , runWithSocket-    , iterSocket-    ) where--import Prelude hiding (catch)--import Control.Concurrent (forkIO)-import Control.Exception (SomeException, catch)-import Control.Monad (forever)-import Control.Monad.Trans (liftIO)--import Data.ByteString (ByteString)-import Data.Enumerator (Iteratee, ($$))-import Network.Socket (Socket)-import qualified Data.Enumerator as E-import qualified Network.Socket as S-import qualified Network.Socket.ByteString as SB-import qualified Network.Socket.Enumerator as SE--import Network.WebSockets.Handshake.Http-import Network.WebSockets.Monad-import Network.WebSockets.Protocol-import Network.WebSockets.Types---- | Provides a simple server. This function blocks forever. Note that this--- is merely provided for quick-and-dirty standalone applications, for real--- applications, you should use a real server.-runServer :: Protocol p-          => String                        -- ^ Address to bind to-          -> Int                           -- ^ Port to listen on-          -> (Request -> WebSockets p ())  -- ^ Application to serve-          -> IO ()                         -- ^ Never returns-runServer host port ws = 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-    flip catch (closeSock sock) $ forever $ do-        (conn, _) <- S.accept sock-        -- Voodoo fix: set this to True as soon as we notice the connection was-        -- closed. Will prevent iterSocket' from even trying to send anything.-        -- Without it, we got many "Couldn't decode text frame as UTF8" errors-        -- in the browser (although the payload is definitely UTF8).-        -- killRef <- newIORef False-        _ <- forkIO $ runWithSocket conn ws >> return ()-        return ()-  where-    closeSock :: Socket -> SomeException -> IO ()-    closeSock sock _ = S.sClose sock---- | This function wraps 'runWebSockets' in order to provide a simple API for--- stand-alone servers.-runWithSocket :: Protocol p-              => Socket -> (Request -> WebSockets p a) -> IO a-runWithSocket s ws = do-    r <- E.run $ SE.enumSocket 4096 s $$ runWebSocketsWithHandshake-        defaultWebSocketsOptions False ws (iterSocket s)-    S.sClose s-    either (error . show) return r---- | Create an iterator which writes to a socket. Throws a 'ConnectionClosed'--- exception if the user attempts to write to a closed socket.-iterSocket :: Socket -> Iteratee ByteString IO ()-iterSocket s = E.continue go-  where-    go (E.Chunks []) = E.continue go-    go (E.Chunks cs) = do-        b <- liftIO $ S.sIsWritable s-        if b-            then E.tryIO (SB.sendMany s cs) >> E.continue go-            else E.throwError ConnectionClosed-    go E.EOF         = E.continue go
+ 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
@@ -1,61 +1,82 @@--{-# LANGUAGE DeriveDataTypeable #-}-+-------------------------------------------------------------------------------- -- | Primary types+{-# LANGUAGE DeriveDataTypeable #-} module Network.WebSockets.Types     ( Message (..)     , ControlMessage (..)     , DataMessage (..)     , WebSocketsData (..) -    , ConnectionError (..)+    , HandshakeException (..)+    , ConnectionException (..)++    , ConnectionType (..)++    , decodeUtf8Lenient+    , decodeUtf8Strict     ) where -import Control.Exception (Exception(..))-import Data.Typeable (Typeable) -import qualified Data.Attoparsec.Enumerator as AE-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           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) --- | The connection couldn't be established or broke down unexpectedly. thrown--- as an iteratee exception.-data ConnectionError-    -- | The client sent malformed data.-    = ParseError AE.ParseError-    -- | the client closed the connection while-    -- we were trying to receive some data.-    ---    -- todo: Also want this for sending.-    | ConnectionClosed              -    deriving (Show, Typeable) -instance Exception ConnectionError+--------------------------------------------------------------------------------+import           Network.WebSockets.Http ++-------------------------------------------------------------------------------- -- | The kind of message a server application typically deals with-data Message p-    = ControlMessage (ControlMessage p)-    | DataMessage    (DataMessage p)+data Message+    = ControlMessage ControlMessage+    -- | Reserved bits, actual message+    | DataMessage Bool Bool Bool DataMessage     deriving (Eq, Show) ++-------------------------------------------------------------------------------- -- | Different control messages-data ControlMessage p-    = Close BL.ByteString+data ControlMessage+    = Close Word16 BL.ByteString     | Ping BL.ByteString     | Pong BL.ByteString     deriving (Eq, Show) ++-------------------------------------------------------------------------------- -- | 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.-data DataMessage p-    = Text BL.ByteString+--+-- 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+    -- | 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) ++-------------------------------------------------------------------------------- -- | In order to have an even more high-level API, we define a typeclass for -- values the user can receive from and send to the socket. A few warnings -- apply:@@ -70,21 +91,97 @@ -- * 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+++--------------------------------------------------------------------------------+-- | Various exceptions that can occur while receiving or transmitting messages+data ConnectionException+    -- | 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.+    --+    -- 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+++--------------------------------------------------------------------------------+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
− src/Network/WebSockets/Util/PubSub.hs 
@@ -1,79 +0,0 @@--- | This is a simple utility module to implement a publish-subscribe pattern.--- Note that this only allows communication in a single direction: pusing data--- from the server to connected clients (browsers).------ Usage:------ * Create a new 'PubSub' handle using 'newPubSub'------ * Subscribe your clients using the 'subscribe' call------ * Push new updates from the server using the 'publish' call----{-# LANGUAGE Rank2Types, ScopedTypeVariables #-}-module Network.WebSockets.Util.PubSub-    ( PubSub-    , newPubSub-    , publish-    , subscribe-    ) where--import Control.Applicative ((<$>))-import Control.Exception (IOException, handle)-import Control.Monad (foldM, forever)-import Control.Monad.Trans (liftIO)-import Data.IntMap (IntMap)-import Data.List (foldl')-import qualified Control.Concurrent.MVar as MV--import qualified Data.IntMap as IM--import Network.WebSockets--data PubSub_ p = PubSub_-    { pubSubNextId :: Int-    , pubSubSinks  :: IntMap (Sink p)-    }--addClient :: Sink p -> PubSub_ p -> (PubSub_ p, Int)-addClient sink (PubSub_ nid sinks) =-    (PubSub_ (nid + 1) (IM.insert nid sink sinks), nid)--removeClient :: Int -> PubSub_ p -> PubSub_ p-removeClient ref ps = ps {pubSubSinks = IM.delete ref (pubSubSinks ps)}---- | A handle which keeps track of subscribed clients-newtype PubSub p = PubSub (MV.MVar (PubSub_ p))---- | Create a new 'PubSub' handle, with no clients initally connected-newPubSub :: IO (PubSub p)-newPubSub = PubSub <$> MV.newMVar PubSub_-    { pubSubNextId  = 0-    , pubSubSinks  = IM.empty-    }---- | Broadcast a message to all connected clients-publish :: PubSub p -> Message p -> IO ()-publish (PubSub mvar) msg = MV.modifyMVar_ mvar $ \pubSub -> do-    -- Take care to detect and remove broken clients-    broken <- foldM publish' [] (IM.toList $ pubSubSinks pubSub)-    return $ foldl' (\p b -> removeClient b p) pubSub broken-  where-    -- Publish the message to a single client, add it to the broken list if an-    -- IOException occurs-    publish' broken (i, s) =-        handle (\(_ :: IOException) -> return (i : broken)) $ do-            sendSink s msg-            return broken---- | Blocks forever-subscribe :: Protocol p => PubSub p -> WebSockets p ()-subscribe (PubSub mvar) = do-    sink <- getSink-    ref  <- liftIO $ MV.modifyMVar mvar $ return . addClient sink-    catchWsError loop $ const $ liftIO $-        MV.modifyMVar_ mvar $ return . removeClient ref-  where-    loop = forever $ do-        _ <- receiveDataMessage-        return ()
+ 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
@@ -0,0 +1,185 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+module Network.WebSockets.Handshake.Tests+    ( tests+    ) where+++--------------------------------------------------------------------------------+import           Control.Concurrent             (forkIO)+import           Control.Exception              (handle)+import           Data.ByteString.Char8          ()+import           Data.IORef                     (newIORef, readIORef,+                                                 writeIORef)+import           Data.Maybe                     (fromJust)+import           Test.Framework                 (Test, testGroup)+import           Test.Framework.Providers.HUnit (testCase)+import           Test.HUnit                     (Assertion, assert, (@?=))+++--------------------------------------------------------------------------------+import           Network.WebSockets+import           Network.WebSockets.Connection+import           Network.WebSockets.Http+import qualified Network.WebSockets.Stream      as Stream+++--------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Network.WebSockets.Handshake.Test"+    [ testCase "handshake Hybi13"                   testHandshakeHybi13+    , testCase "handshake Hybi13 with subprotocols" testHandshakeHybi13WithProto+    , testCase "handshake Hybi13 with headers"      testHandshakeHybi13WithHeaders+    , testCase "handshake Hybi13 with subprotocols and headers" testHandshakeHybi13WithProtoAndHeaders+    , testCase "handshake reject"                   testHandshakeReject+    , testCase "handshake reject with custom code"  testHandshakeRejectWithCode+    , testCase "handshake Hybi9000"                 testHandshakeHybi9000+    ]+++--------------------------------------------------------------------------------+testHandshake :: RequestHead -> (PendingConnection -> IO a) -> IO ResponseHead+testHandshake rq app = do+    echo <- Stream.makeEchoStream+    _    <- forkIO $ do+        _ <- app (PendingConnection defaultConnectionOptions rq nullify echo)+        return ()+    mbRh <- Stream.parse echo decodeResponseHead+    Stream.close echo+    case mbRh of+        Nothing -> fail "testHandshake: No response"+        Just rh -> return rh+  where+    nullify _ = return ()+++--------------------------------------------------------------------------------+(!) :: Eq a => [(a, b)] -> a -> b+assoc ! key = fromJust (lookup key assoc)+++--------------------------------------------------------------------------------+rq13 :: RequestHead+rq13 = RequestHead "/mychat"+    [ ("Host", "server.example.com")+    , ("Upgrade", "websocket")+    , ("Connection", "Upgrade")+    , ("Sec-WebSocket-Key", "x3JJHMbDL1EzLkh9GBhXDw==")+    , ("Sec-WebSocket-Protocol", "chat, superchat")+    , ("Sec-WebSocket-Version", "13")+    , ("Origin", "http://example.com")+    ]+    False+++--------------------------------------------------------------------------------+testHandshakeHybi13 :: Assertion+testHandshakeHybi13 = do+    onAcceptFired                     <- newIORef False+    ResponseHead code message headers <- testHandshake rq13 $ \pc ->+        acceptRequest pc {pendingOnAccept = \_ -> writeIORef onAcceptFired True}++    readIORef onAcceptFired >>= assert+    code @?= 101+    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+++--------------------------------------------------------------------------------+-- I don't believe this one is supported yet+rq9000 :: RequestHead+rq9000 = RequestHead "/chat"+    [ ("Host", "server.example.com")+    , ("Upgrade", "websocket")+    , ("Connection", "Upgrade")+    , ("Sec-WebSocket-Key", "dGhlIHNhbXBsZSBub25jZQ==")+    , ("Sec-WebSocket-Origin", "http://example.com")+    , ("Sec-WebSocket-Protocol", "chat, superchat")+    , ("Sec-WebSocket-Version", "9000")+    ]+    False+++--------------------------------------------------------------------------------+testHandshakeHybi9000 :: Assertion+testHandshakeHybi9000 = do+    ResponseHead code _ headers <- testHandshake rq9000 $ \pc ->+        flip handle (acceptRequest pc) $ \e -> case e of+            NotSupported -> return undefined+            _            -> error $ "Unexpected Exception: " ++ show e++    code @?= 400+    headers ! "Sec-WebSocket-Version" @?= "13"
+ tests/haskell/Network/WebSockets/Http/Tests.hs view
@@ -0,0 +1,88 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+module Network.WebSockets.Http.Tests+    ( tests+    ) where+++--------------------------------------------------------------------------------+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)+import           Test.HUnit                     (Assertion, assert)+++--------------------------------------------------------------------------------+import           Network.WebSockets.Http+++--------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Network.WebSockets.Http.Tests"+    [ testCase "jwebsockets response" jWebSocketsResponse+    , testCase "chromium response"    chromiumResponse+    , testCase "matchbook response"   matchbookResponse+    ]+++--------------------------------------------------------------------------------+-- | This is a specific response sent by jwebsockets which caused trouble+jWebSocketsResponse :: Assertion+jWebSocketsResponse = assert $ case A.parseOnly decodeResponseHead input of+    Left err -> error err+    Right _  -> True+  where+    input = BC.intercalate "\r\n"+        [ "HTTP/1.1 101 Switching Protocols"+        , "Upgrade: websocket"+        , "Connection: Upgrade"+        , "Sec-WebSocket-Accept: Ha0QR1T9CoYx/nqwHsVnW8KVTSo="+        , "Sec-WebSocket-Origin: "+        , "Sec-WebSocket-Location: ws://127.0.0.1"+        , "Set-Cookie: JWSSESSIONID=2e0690e2e328f327056a5676b6a890e3; HttpOnly"+        , ""+        , ""+        ]+++--------------------------------------------------------------------------------+-- | This is a specific response sent by chromium which caused trouble+chromiumResponse :: Assertion+chromiumResponse = assert $ case A.parseOnly decodeResponseHead input of+    Left err -> error err+    Right _  -> True+  where+    input = BC.intercalate "\r\n"+        [ "HTTP/1.1 500 Internal Error"+        , "Content-Type:text/html"+        , "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
@@ -0,0 +1,185 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Network.WebSockets.Server.Tests+    ( tests+    ) where+++--------------------------------------------------------------------------------+import           Control.Applicative            ((<$>), (<|>))+import           Control.Concurrent             (forkIO, killThread,+                                                 threadDelay)+import           Control.Concurrent.Async       (Async, async, cancel)+import           Control.Exception              (SomeException, catch, handle)+import           Control.Monad                  (forever, replicateM, unless)+import           Data.IORef                     (IORef, newIORef, readIORef,+                                                 writeIORef)++--------------------------------------------------------------------------------+import qualified Data.ByteString.Lazy           as BL+import           Data.Text                      (Text)+import           System.Environment             (getEnvironment)+import           Test.Framework                 (Test, testGroup)+import           Test.Framework.Providers.HUnit (testCase)+import           Test.HUnit                     (Assertion, assert, (@=?))+import           Test.QuickCheck                (Arbitrary, arbitrary)+import           Test.QuickCheck.Gen            (Gen (..))+import           Test.QuickCheck.Random         (newQCGen)+++--------------------------------------------------------------------------------+import           Network.WebSockets+import           Network.WebSockets.Tests.Util+++--------------------------------------------------------------------------------+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 = 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' <- runClient host 42940 "/chat" $ client texts+    texts @=? texts'+  where+    client :: [BL.ByteString] -> ClientApp [BL.ByteString]+    client texts conn = do+        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 "127.0.0.1" 42941 "Bye" $ do+    gotPong <- newIORef False+    let opts = defaultConnectionOptions+                   { connectionOnPong = writeIORef gotPong True+                   }++    rcv <- runClientWith "127.0.0.1" 42941 "/" opts [] client+    assert rcv+    assert =<< readIORef gotPong+  where+    client :: ClientApp Bool+    client conn = do+        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 <- newQCGen+    return $ (unGen arbitrary) gen 512+++--------------------------------------------------------------------------------+waitSome :: IO ()+waitSome = threadDelay $ 200 * 1000++--------------------------------------------------------------------------------+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+    cancel serverThread+    closeCalled <- readIORef cRef+    unless closeCalled $ error "Expecting the CloseRequest exception"+    return result+  where+    server :: ServerApp+    server pc = do+        conn <- acceptRequest pc+        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
@@ -0,0 +1,223 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Network.WebSockets.Tests+    ( tests+    ) where+++--------------------------------------------------------------------------------+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           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           Prelude+++--------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Network.WebSockets.Test"+    [ testProperty "simple encode/decode Hybi13" (testSimpleEncodeDecode Hybi13)+    , testProperty "fragmented Hybi13"           testFragmentedHybi13+    , testRfc_6455_5_5_1+    , testRfc_6455_5_5_2+    , testFramePayloadSizeLimit+    ]++--------------------------------------------------------------------------------+testSimpleEncodeDecode :: Protocol -> Property+testSimpleEncodeDecode protocol = QC.monadicIO $+    QC.forAllM QC.arbitrary $ \msgs -> QC.run $ do+        echo  <- Stream.makeEchoStream+        parse <- decodeMessages protocol mempty mempty echo+        write <- encodeMessages protocol ClientConnection echo+        _     <- forkIO $ write msgs+        msgs' <- catMaybes <$> replicateM (length msgs) parse+        Stream.close echo+        msgs @=? msgs'+++--------------------------------------------------------------------------------+testFragmentedHybi13 :: Property+testFragmentedHybi13 = QC.monadicIO $+    QC.forAllM QC.arbitrary $ \fragmented -> QC.run $ do+        echo     <- Stream.makeEchoStream+        parse    <- Hybi13.decodeMessages mempty mempty echo+        -- is'      <- Streams.filter isDataMessage =<< Hybi13.decodeMessages is++        -- Simple hacky encoding of all frames+        _ <- 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 <- filter isDataMessage <$> parseAll parse+        [msg | FragmentedMessage msg _ <- fragmented] @=? msgs+  where+    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 []++--------------------------------------------------------------------------------+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)++--------------------------------------------------------------------------------+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 = 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)+        ]+++--------------------------------------------------------------------------------+data FragmentedMessage = FragmentedMessage Message [Frame]+    deriving (Show)+++--------------------------------------------------------------------------------+instance Arbitrary FragmentedMessage where+    arbitrary = do+        -- Pick a frametype and a corresponding random payload+        ft        <- QC.elements [TextFrame, BinaryFrame]+        payload   <- case ft of+            TextFrame -> arbitraryUtf8+            _         -> arbitraryByteString++        fragments <- arbitraryFragmentation payload+        let fs  = makeFrames $ zip (ft : repeat ContinuationFrame) fragments+            msg = case ft of+                TextFrame   -> DataMessage False False False (Text payload Nothing)+                BinaryFrame -> DataMessage False False False (Binary payload)+                _           -> error "Arbitrary FragmentedMessage crashed"++        interleaved <- arbitraryInterleave genControlFrame fs+        return $ FragmentedMessage msg interleaved+        -- return $ FragmentedMessage msg fs+      where+        makeFrames []              = []+        makeFrames [(ft, pl)]      = [Frame True False False False ft pl]+        makeFrames ((ft, pl) : fr) =+            Frame False False False False ft pl : makeFrames fr++        genControlFrame = QC.elements+            [ Frame True False False False PingFrame "Herp"+            , Frame True False False False PongFrame "Derp"+            ]+++--------------------------------------------------------------------------------+arbitraryFragmentation :: BL.ByteString -> Gen [BL.ByteString]+arbitraryFragmentation bs = arbitraryFragmentation' bs+  where+    len :: Int+    len = fromIntegral $ BL.length bs+    arbitraryFragmentation' bs' = do+        -- TODO: we currently can't send packets of length 0. We should+        -- investigate why (regardless of the spec).+        n <- QC.choose (1, len - 1)+        let (l, r) = BL.splitAt (fromIntegral n) bs'+        case r of+            "" -> return [l]+            _  -> (l :) <$> arbitraryFragmentation' r+++--------------------------------------------------------------------------------+arbitraryInterleave :: Gen a -> [a] -> Gen [a]+arbitraryInterleave sep xs = fmap concat $ sequence $+    [sep'] ++ intersperse sep' [return [x] | x <- xs] ++ [sep']+  where+    sep' = QC.sized $ \size -> do+        num <- QC.choose (1, size)+        replicateM num sep
+ tests/haskell/Network/WebSockets/Tests/Util.hs view
@@ -0,0 +1,38 @@+--------------------------------------------------------------------------------+module Network.WebSockets.Tests.Util+    ( ArbitraryUtf8 (..)+    , arbitraryUtf8+    , arbitraryByteString+    ) where+++--------------------------------------------------------------------------------+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)+++--------------------------------------------------------------------------------+import           Network.WebSockets.Types+++--------------------------------------------------------------------------------+newtype ArbitraryUtf8 = ArbitraryUtf8 {unArbitraryUtf8 :: BL.ByteString}+    deriving (Eq, Ord, Show)+++--------------------------------------------------------------------------------+instance Arbitrary ArbitraryUtf8 where+    arbitrary = ArbitraryUtf8 <$> arbitraryUtf8+++--------------------------------------------------------------------------------+arbitraryUtf8 :: Gen BL.ByteString+arbitraryUtf8 = toLazyByteString . TL.encodeUtf8 . TL.pack <$> arbitrary+++--------------------------------------------------------------------------------+arbitraryByteString :: Gen BL.ByteString+arbitraryByteString = BL.pack <$> arbitrary
tests/haskell/TestSuite.hs view
@@ -1,12 +1,24 @@-import Test.Framework (defaultMain)--import qualified Network.WebSockets.Tests+--------------------------------------------------------------------------------+import qualified Network.WebSockets.Extensions.Tests+import qualified Network.WebSockets.Extensions.PermessageDeflate.Tests import qualified Network.WebSockets.Handshake.Tests-import qualified Network.WebSockets.Socket.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.Tests.tests+    [ Network.WebSockets.Extensions.Tests.tests+    , Network.WebSockets.Extensions.PermessageDeflate.Tests.tests     , Network.WebSockets.Handshake.Tests.tests-    , Network.WebSockets.Socket.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.6.0.4+Version: 0.13.0.0  Synopsis:   A sensible and clean way to write WebSocket-capable servers in Haskell.@@ -7,10 +7,11 @@ Description:  This library allows you to write WebSocket-capable servers.  .- See an example: <http://jaspervdj.be/websockets/example.html>.+ An example server:+ <https://github.com/jaspervdj/websockets/blob/master/example/server.lhs>  .- The API of the 'Network.WebSockets' module should also contain enough- information to get you started.+ An example client:+ <https://github.com/jaspervdj/websockets/blob/master/example/client.hs>  .  See also:  .@@ -23,98 +24,220 @@ License:       BSD3 License-file:  LICENCE Copyright:     (c) 2010-2011 Siniša Biđin-               (c) 2011 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 +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.Internal-    Network.WebSockets.Util.PubSub+    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.Handshake-    Network.WebSockets.Handshake.Http-    Network.WebSockets.Monad+    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+    Network.WebSockets.Hybi13.Mask     Network.WebSockets.Protocol-    Network.WebSockets.Protocol.Hybi00-    Network.WebSockets.Protocol.Hybi00.Internal-    Network.WebSockets.Protocol.Hybi10-    Network.WebSockets.Protocol.Hybi10.Demultiplex-    Network.WebSockets.Protocol.Hybi10.Internal-    Network.WebSockets.Protocol.Hybi10.Mask-    Network.WebSockets.Protocol.Unsafe-    Network.WebSockets.Socket+    Network.WebSockets.Server     Network.WebSockets.Types    Build-depends:-    attoparsec               >= 0.9    && < 0.11,-    attoparsec-enumerator    >= 0.2    && < 0.4,-    base                     >= 4      && < 5,-    base64-bytestring        >= 0.1    && < 0.2,-    binary                   >= 0.5    && < 0.6,-    blaze-builder            >= 0.3    && < 0.4,-    blaze-builder-enumerator >= 0.2    && < 0.3,-    bytestring               >= 0.9    && < 0.10,-    case-insensitive         >= 0.3    && < 0.5,-    containers               >= 0.3    && < 0.6,-    enumerator               >= 0.4.13 && < 0.5,-    mtl                      >= 2.0    && < 2.2,-    network                  >= 2.3    && < 2.4,-    network-enumerator       >= 0.1    && < 0.2,-    random                   >= 1.0    && < 1.1,-    SHA                      >= 1.5    && < 1.6,-    text                     >= 0.10   && < 0.12,-    pureMD5                  >= 0.2.2  && < 2.2+    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  && < 1.3,+    SHA               >= 1.5    && < 1.7,+    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.5,-    test-framework             >= 0.4 && < 0.7,-    test-framework-hunit       >= 0.2 && < 0.3,-    test-framework-quickcheck2 >= 0.2 && < 0.3,+    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.11,-    attoparsec-enumerator    >= 0.2    && < 0.4,-    base                     >= 4      && < 5,-    base64-bytestring        >= 0.1    && < 0.2,-    binary                   >= 0.5    && < 0.6,-    blaze-builder            >= 0.3    && < 0.4,-    blaze-builder-enumerator >= 0.2    && < 0.3,-    bytestring               >= 0.9    && < 0.10,-    case-insensitive         >= 0.3    && < 0.5,-    containers               >= 0.3    && < 0.6,-    enumerator               >= 0.4.13 && < 0.5,-    mtl                      >= 2.0    && < 2.2,-    network                  >= 2.3    && < 2.4,-    network-enumerator       >= 0.1    && < 0.2,-    random                   >= 1.0    && < 1.1,-    SHA                      >= 1.5    && < 1.6,-    text                     >= 0.10   && < 0.12,-    pureMD5                  >= 0.2.2  && < 2.2+    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,+    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