[ { "path": ".ghci", "content": ":set -isrc -itests/haskell\n" }, { "path": ".github/workflows/ci.yml", "content": "name: \"build & test\"\non:\n push:\n pull_request:\n branches: [master]\n\njobs:\n build:\n name: GHC ${{ matrix.ghc-version }} on ${{ matrix.os }}\n runs-on: ${{ matrix.os }}\n strategy:\n fail-fast: false\n matrix:\n os: [ubuntu-latest]\n ghc-version: ['9.8', '9.6', '9.4', '9.2', '9.0']\n\n include:\n - os: windows-latest\n ghc-version: '9.8'\n - os: macos-latest\n ghc-version: '9.8'\n\n steps:\n - uses: actions/checkout@v4\n\n - name: Set up GHC ${{ matrix.ghc-version }}\n uses: haskell-actions/setup@v2\n id: setup\n with:\n ghc-version: ${{ matrix.ghc-version }}\n # Defaults, added for clarity:\n cabal-version: 'latest'\n cabal-update: true\n\n - name: Configure the build\n run: |\n cabal configure --enable-tests --enable-benchmarks --disable-documentation\n cabal build all --dry-run\n # The last step generates dist-newstyle/cache/plan.json for the cache key.\n\n - name: Restore cached dependencies\n uses: actions/cache/restore@v3\n id: cache\n env:\n key: ${{ runner.os }}-ghc-${{ steps.setup.outputs.ghc-version }}-cabal-${{ steps.setup.outputs.cabal-version }}\n with:\n path: ${{ steps.setup.outputs.cabal-store }}\n key: ${{ env.key }}-plan-${{ hashFiles('**/plan.json') }}\n restore-keys: ${{ env.key }}-\n\n - name: Install dependencies\n # If we had an exact cache hit, the dependencies will be up to date.\n if: steps.cache.outputs.cache-hit != 'true'\n run: cabal build all --only-dependencies\n\n # Cache dependencies already here, so that we do not have to rebuild them should the subsequent steps fail.\n - name: Save cached dependencies\n uses: actions/cache/save@v3\n # If we had an exact cache hit, trying to save the cache would error because of key clash.\n if: steps.cache.outputs.cache-hit != 'true'\n with:\n path: ${{ steps.setup.outputs.cabal-store }}\n key: ${{ steps.cache.outputs.cache-primary-key }}\n\n - name: Build\n run: cabal build all\n\n - name: Run tests\n run: cabal test all\n\n - name: Build documentation\n run: cabal haddock all\n\n - name: Install virtualenv\n if: matrix.os == 'ubuntu-latest'\n run: | \n sudo apt-get install --yes virtualenv python2.7-dev\n pip install virtualenv\n\n - name: Run autobahn tests\n if: matrix.os == 'ubuntu-latest'\n run: bash tests/autobahn/autobahn.sh" }, { "path": ".gitignore", "content": "*.hi\n*.o\n\n.hpc\ndist\ntests/coverage\n\ntests/haskell/TestSuite\n\n.stack-work/\n" }, { "path": "CHANGELOG", "content": "# CHANGELOG\n\n- 0.13.0.0 (2023-12-30)\n * **BREAKING**: Remove `serverRequirePong` option in favor of the new\n implementation.\n * **BREAKING**: Client: Rejecting request raises\n `RequestRejected RequestHead ResponseHead`\n * Timeout initial socket connection after 30s.\n * If the socket is closed unexpectedly, raise `ConnectionClosed`.\n * Added a way to manually send a Pong message.\n * `runServer` now cleans up threads correctly.\n * Remove redundant bytestring-builder dependency.\n * Introduce `Network.WebSockets.Connection.PingPong` to\n handle ping pong for any Connection, be it Client or Server.\n * Bump `text `dependency upper bound to 2.2\n * Bump `random `dependency lower bound to 1.0.1\n\n- 0.12.7.3 (2021-10-26)\n * Bump `attoparsec` dependency upper bound to 0.15\n\n- 0.12.7.2 (2020-12-07)\n * Bump `QuickCheck` dependency upper bound to 2.15\n * Bump `base64-bytestring` dependency upper bound to 1.3\n * Bump `bytestring` dependency upper bound to 0.12\n * Bump `random` dependency upper bound to 1.3\n\n- 0.12.7.1 (2020-05-03)\n * Bump `base64-bytestring` dependency upper bound to 1.2\n\n- 0.12.7.0 (2019-12-31)\n * Bump `base` lower bound to 4.8, this drops support for GHC 7.6 and 7.8\n * Add a new `runServerWithOptions` that can be extended in a more\n future-compatible way\n * Add a connection killer setting in `runServerWithOptions`\n * Fix an unsafe read issue in `decodeResponseHead`\n\n- 0.12.6.1 (2019-10-29)\n * Bump `network` dependency to 3.1\n\n- 0.12.6.0 (2019-10-28)\n * Expose a lower-level API to construct client connections (by Philipp\n Balzarek)\n * Close underlying stream only on synchronous exceptions, not asynchronous\n exceptions (by kamoii)\n * Add a `withPingThread` and lower-level `pingThread` to replace\n `forkPingThread`\n * Bump `QuickCheck` dependency to 2.13\n\n- 0.12.5.3 (2019-01-31)\n * Bump `network` dependency to 3.0\n\n- 0.12.5.2 (2018-09-25)\n * Bump `containers` dependency to 0.6\n * Bump `network` dependency to 2.8\n * Bump `QuickCheck` dependency to 2.12\n * Bump `binary` dependency to 0.10\n\n- 0.12.5.1 (2018-06-12)\n * Fix build with GHC 7.6 and 7.8\n\n- 0.12.5.0 (2018-06-01)\n * Add `newClientConnection` (by Renzo Carbonara)\n\n- 0.12.4.1 (2018-05-11)\n * Bump `network` dependency to 2.7\n\n- 0.12.4.0 (2018-03-13)\n * Remove `blaze-builder` dependency\n * Bump `streaming-commons` dependency to 0.2\n * Bump `QuickCheck` dependency to 2.11\n * Fix compatibility with old GHC versions\n * Re-export more functions from `Network.WebSockets`\n - `sendDataMessages`\n - `sendBinaryDatas`\n - `sendCloseCode`\n * Don't crash when sending the empty list of messages\n * Add `SemiGroup` instance for `SizeLimit`\n\n- 0.12.3.1 (2018-01-10)\n * Bump CHANGELOG with IPv6 warning\n * Run all autobahn tests during CI\n\n- 0.12.3.0 (2018-01-02)\n * Fix error thrown from runClient functions\n * Bump `QuickCheck` dependency to 2.10\n * Bump `entropy` dependency to 0.4\n * Bump `binary` dependency to 0.10\n\n- 0.12.2.0 (2017-07-28)\n * Don't use LambdaCase, we want to support older GHC versions\n\n- 0.12.1.0 (2017-07-22)\n * Fix Monoid import on older base versions\n * Increase lower bound on `binary` to 0.8.1 (by Jonathan Daugherty)\n\n- 0.12.0.0\n * Add limit options for frame and message size to prevent against (D)DoS\n attacks\n * Fix space leak in encodeMessages (by Roman Borschel)\n * Stricter frame/encoding decoding for ping/close frames (by Lars Petersen)\n\n- 0.11.2.0\n * Fix 0-width reason phrase parsing\n * Change receive buffer from 1024 to 8192 bytes (by Ondrej Palkovsky)\n * Implement fast masking in C (by Ondrej Palkovsky and myself)\n * Some haddock improvements\n * Bump `HUnit` dependency to 1.6\n\n- 0.11.1.0\n * Fix compilation issue with GHC-7.8\n\n- 0.11.0.0\n * Support for IPv6 in the built-in server, client and tests (by agentm).\n This can cause issues on backends that do not enable IPv6. For more\n information and a workaround, see this issue:\n .\n * Faster masking (by Dmitry Ivanov)\n * Support for `permessage-deflate` extension (by Marcin Tolysz)\n * Strict unicode checking and proper extension mechanism\n\n- 0.10.0.0\n * Fix client specifying empty path\n * Allow sending collections of messages (by David Turner)\n * Allow sending extra headers when accepting request (by James Deery)\n\n- 0.9.8.2\n * Bump `HUnit` dependency to 1.5\n\n- 0.9.8.1\n * Restore state of the package to version `0.9.7.0`\n\n- 0.9.8.0\n * This release contained a feature which broke backwards-compatibility.\n Hence, it was marked as broken a new release containing the changes will\n be uploaded as `0.10.0.0`.\n\n- 0.9.7.0\n * Fix issue trying to kill builtin server\n * Bump `QuickCheck` dependency to 2.9\n\n- 0.9.6.2\n * Bump `binary` dependency for GHC 8.0 compatibility\n\n- 0.9.6.1\n * Fix issue with fragmentation test\n\n- 0.9.6.0\n * Optionally include example server in the cabal file\n * Send correct port from client\n * Set `TCP_NO_DELAY` in builtin server\n * Bump `HUnit` dependency\n * Drop dependency on `mtl`\n * Fix `QuickCheck` dependency lower bound\n\n- 0.9.5.0\n * Bugfixes wrt closing sockets and streams\n\n- 0.9.4.0\n * Add `makePendingConnectionFromStream` function\n * Bump `attoparsec` dependency\n\n- 0.9.3.1\n * Bump `QuickCheck` dependency\n\n- 0.9.3.0\n * Use a shared closed state for connection input/output stream\n * Make sure `runServer` doesn't leak any sockets\n * Bump `blaze-builder` dependency\n\n- 0.9.2.2\n * Bump `random` dependency\n\n- 0.9.2.1\n * Fix exception handling issues\n\n- 0.9.2.0\n * Make sending and receiving messages thread-safe by default\n * Export `forkPingThread`\n * Fix Windows `withSocketsDo` issue\n\n- 0.9.1.0\n * Don't use Network.ByteString.Lazy.sendAll on Windows\n\n- 0.9.0.1\n * Allow compilation with older bytestring versions\n * Bump text dependency\n\n- 0.9.0.0\n * Bump various dependencies\n * Remove io-streams dependency\n * New close mechanism\n * More flexible API interface\n\n- 0.8.2.6\n * Bump QuickCheck dependency\n\n- 0.8.2.5\n * Bump attoparsec dependency\n\n- 0.8.2.4\n * Bump entropy dependency\n\n- 0.8.2.3\n * Bump mtl dependency\n\n- 0.8.2.2\n * Bump network dependency\n\n- 0.8.2.1\n * Add benchmark with many open connections\n * Update example to use gender-neutral language\n\n- 0.8.2.0\n * Fix possible leaking of client sockets when connection times out\n" }, { "path": "LICENCE", "content": "Copyright Jasper Van der Jeugt, 2011\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n\n * Redistributions of source code must retain the above copyright\n notice, this list of conditions and the following disclaimer.\n\n * Redistributions in binary form must reproduce the above\n copyright notice, this list of conditions and the following\n disclaimer in the documentation and/or other materials provided\n with the distribution.\n\n * Neither the name of Siniša Biđin nor the names of other\n contributors may be used to endorse or promote products derived\n from this software without specific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS\n\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT\nLIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR\nA PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT\nOWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,\nSPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT\nLIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,\nDATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY\nTHEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\n(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\nOF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\n" }, { "path": "README.md", "content": "# websockets\n\n![Hackage Version](https://img.shields.io/hackage/v/websockets)\n![GitHub Workflow Status (with event)](https://img.shields.io/github/actions/workflow/status/jaspervdj/websockets/ci.yml)\n\nProvides a sensible, clean and simple way to write WebSocket\nserver and client in Haskell.\n\n## Features\n\n- Provides Server/Client implementations of the websocket protocol\n- `withPingPong` helper for stale connection checking\n- TLS support via [wuss](https://hackage.haskell.org/package/wuss) package\n\n## Caveats\n\n- [`send` doesn't support streaming](https://github.com/jaspervdj/websockets/issues/119)\n- [Requires careful handling of exceptions](https://github.com/jaspervdj/websockets/issues/48)\n- [DeflateCompression isn't thread-safe](https://github.com/jaspervdj/websockets/issues/208)\n\n## Introduction\n\nSee [server](./example/server.lhs) and [client](./example/client.hs) implementations.\n\n## Installation\n\nUsing cabal:\n\n```\n$ cabal install websockets\n```\n\n## Authors\n\nAn initial WebSockets library was written in 2010 by Siniša Biđin. In 2011, it\nwas rewritten from scratch, and extended to its current state by Jasper Van der\nJeugt, who is also the current maintainer.\n\nContributors:\n\n- Alex Lang\n- Carl Chatfield\n- Fedor Gogolev\n- Marcin Tolysz\n- Nathan Howell\n- Steffen Schuldenzucker\n- Yi Huang\n- Domen Kožar\n\n## Development\n\nPull requests are always welcome!\n\nThis library is production-quality. Therefore we have very high standards in\nterms of code style, API quality and testing.\n\nWe have three kinds of tests:\n\n- Haskell-based tests (`tests/haskell`), which use the `test-framework` library\n- Integration tests, available in `tests/javascript`. These require a browser to\n run.\n- We also run the extensive [autobahn testsuite].\n\n[autobahn testsuite]: https://github.com/crossbario/autobahn-testsuite\n" }, { "path": "Setup.hs", "content": "import Distribution.Simple\nmain = defaultMain\n" }, { "path": "benchmarks/echo.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\nimport Control.Monad (forever)\nimport qualified Network.WebSockets as WS\n\necho :: WS.Connection -> IO ()\necho conn = forever $ do\n msg <- WS.receiveDataMessage conn\n WS.sendDataMessage conn msg\n\nmain :: IO ()\nmain = WS.runServer \"0.0.0.0\" 9160 $ \\pending -> do\n conn <- WS.acceptRequest pending\n echo conn\n" }, { "path": "benchmarks/echo.js", "content": "/* This WebSockets client opens an increasingly larger number of connections to\n * localhost and sends messages on all connections.\n *\n * It is written in JavaScript since benchmarking my own library using my own\n * library might give a skewed perspective.\n *\n * Requires the `ws` npm module, install using:\n *\n * npm install --user-install ws\n *\n * */\nvar WebSocket = require('ws');\n\n/* Configuration. */\nvar websocketPort = 9160;\nvar spawnClientInterval = 100;\nvar nextClientId = 0;\nvar messageInterval = 100;\n\nsetInterval(function() {\n var numberOfSentMessages = 0;\n\n var clientId = nextClientId;\n nextClientId += 1;\n console.log('Client ' + clientId + ': spawning...');\n\n var sentMessage = undefined;\n\n var ws = new WebSocket('http://localhost:' + websocketPort + '/echo');\n\n ws.on('open', function() {\n ws.on('message', function(msg) {\n msg = msg.toString();\n if (msg === sentMessage && numberOfSentMessages % 100 === 0) {\n console.log('Client ' + clientId + ': ' + numberOfSentMessages +\n ' OK messages');\n }\n if (msg !== sentMessage) {\n console.error('Client ' + clientId + ': unexpected response: ' +\n 'got \"' + msg + '\", expected: \"' + sentMessage + '\"');\n }\n });\n\n setInterval(function() {\n sentMessage = 'Hello ' + Math.floor(Math.random() * 10);\n ws.send(sentMessage, {binary: true, mask: false});\n numberOfSentMessages++;\n }, messageInterval);\n });\n}, spawnClientInterval);\n" }, { "path": "benchmarks/mask.hs", "content": "{-# language BangPatterns #-}\n{-# language OverloadedStrings #-}\n\nimport Criterion\nimport Criterion.Main\nimport qualified Data.Binary.Get as Get\n\nimport Network.WebSockets.Hybi13.Mask\n\nimport Data.Bits (shiftR, xor)\nimport qualified Data.ByteString as B\nimport qualified Data.ByteString.Lazy as BL\n\nsetupEnv = do\n let kilo = BL.replicate 1024 37\n mega = BL.replicate (1024 * 1024) 37\n megaU = BL.fromChunks [B.drop 1 (B.replicate (1024 * 1024) 37)]\n megaS = BL.fromChunks [B.replicate (1024 * 1024) 37]\n return (kilo, mega, megaU, megaS)\n\nmaskPayload' :: Maybe B.ByteString -> BL.ByteString -> BL.ByteString\nmaskPayload' Nothing = id\nmaskPayload' (Just mask) = snd . BL.mapAccumL f (cycle $ B.unpack mask)\n where\n f [] !c = ([], c)\n f (m:ms) !c = (ms, m `xor` c)\n\nmain = defaultMain [\n env setupEnv $ \\ ~(kilo, mega, megaU, megaS) -> bgroup \"main\"\n [ bgroup \"kilobyte payload\"\n [ bgroup \"zero_mask\"\n [ bench \"current\" $ nf (maskPayload (mkMask $ \"\\x00\\x00\\x00\\x00\")) kilo\n , bench \"old\" $ nf (maskPayload' (Just \"\\x00\\x00\\x00\\x00\")) kilo\n ]\n , bgroup \"full_mask\"\n [ bench \"current\" $ nf (maskPayload (mkMask \"\\xFF\\xFF\\xFF\\xFF\")) kilo\n , bench \"current-unaligned\" $ nf (maskPayload (mkMask \"\\xFF\\xFF\\xFF\\xFF\")) (BL.drop 1 kilo)\n , bench \"old\" $ nf (maskPayload' (Just \"\\xFF\\xFF\\xFF\\xFF\")) kilo\n ]\n , bgroup \"one_byte_mask\"\n [ bench \"current\" $ nf (maskPayload (mkMask \"\\xCC\\xCC\\xCC\\xCC\")) kilo\n , bench \"old\" $ nf (maskPayload' (Just \"\\xCC\\xCC\\xCC\\xCC\")) kilo\n ]\n , bgroup \"other_mask\"\n [ bench \"current\" $ nf (maskPayload (mkMask \"\\xB0\\xA2\\xB0\\xA2\")) kilo\n , bench \"old\" $ nf (maskPayload' (Just \"\\xB0\\xA2\\xB0\\xA2\")) kilo\n ]\n ]\n , bgroup \"megabyte payload\"\n [ bgroup \"zero_mask\"\n [ bench \"current\" $ nf (maskPayload (mkMask \"\\x00\\x00\\x00\\x00\")) mega\n , bench \"old\" $ nf (maskPayload' (Just \"\\x00\\x00\\x00\\x00\")) mega\n ]\n , bgroup \"full_mask\"\n [ bench \"current\" $ nf (maskPayload (mkMask \"\\xFF\\xFF\\xFF\\xFF\")) mega\n , bench \"current-unaligned\" $ nf (maskPayload (mkMask \"\\xFF\\xFF\\xFF\\xFF\")) megaU\n , bench \"current-aligned\" $ nf (maskPayload (mkMask \"\\xFF\\xFF\\xFF\\xFF\")) megaS\n , bench \"old\" $ nf (maskPayload' (Just \"\\xFF\\xFF\\xFF\\xFF\")) mega\n ]\n , bgroup \"one_byte_mask\"\n [ bench \"current\" $ nf (maskPayload (mkMask \"\\xCC\\xCC\\xCC\\xCC\")) mega\n , bench \"old\" $ nf (maskPayload' (Just \"\\xCC\\xCC\\xCC\\xCC\")) mega\n ]\n , bgroup \"other_mask\"\n [ bench \"current\" $ nf (maskPayload (mkMask \"\\xB0\\xA2\\xB0\\xA2\")) mega\n , bench \"old\" $ nf (maskPayload' (Just \"\\xB0\\xA2\\xB0\\xA2\")) mega\n ]\n ]\n ]\n ]\n where\n mkMask b = Just $ Get.runGet parseMask b\n" }, { "path": "benchmarks/ping.hs", "content": "--------------------------------------------------------------------------------\n{-# LANGUAGE OverloadedStrings #-}\nmodule Main where\n\n\n--------------------------------------------------------------------------------\nimport Control.Monad (forever)\nimport qualified Data.ByteString as B\nimport qualified Data.ByteString.Char8 as BC\nimport qualified Network.WebSockets as WS\n\n\n--------------------------------------------------------------------------------\nping :: WS.ServerApp\nping pending = do\n conn <- WS.acceptRequest pending\n WS.sendTextData conn (\"Ping 0\" :: B.ByteString)\n forever $ do\n msg <- WS.receiveData conn\n let n = read (BC.unpack (B.drop 5 msg)) :: Int\n WS.sendTextData conn $ BC.pack $ \"Ping \" ++ show (n + 1)\n\n\n--------------------------------------------------------------------------------\nmain :: IO ()\nmain = WS.runServer \"0.0.0.0\" 8088 ping\n" }, { "path": "benchmarks/ping.html", "content": "\n\n \n Ping benchmark\n \n \n \n \n

Ping benchmark

\n
\n
\n \n\n" }, { "path": "cbits/cbits.c", "content": "#include \n#include \n#include \n#include \n\n/* Taken from:\n *\n * \n */\nstatic inline uint32_t rotr32(uint32_t n, unsigned int c) {\n const unsigned int mask = (CHAR_BIT*sizeof(n)-1);\n c &= mask; /* avoid undef behaviour with NDEBUG. 0 overhead for most types / compilers */\n return (n>>c) | (n<<( (-c)&mask ));\n}\n\n/* - `mask` is the 4-byte mask to apply to the source. It is stored in the\n * hosts' native byte ordering.\n * - `mask_offset` is the initial offset in the mask. It is specified in bytes\n * and should be between 0 and 3 (inclusive). This is necessary for when we\n * are dealing with multiple chunks.\n * - `src` is the source pointer.\n * - `len` is the size of the source (and destination) in bytes.\n * - `dst` is the destination.\n */\nvoid _hs_mask_chunk(\n uint32_t mask, int mask_offset,\n uint8_t *src, size_t len,\n uint8_t *dst) {\n const uint8_t *src_end = src + len;\n\n /* We have two fast paths: one for `x86_64` and one for `i386`\n * architectures. In these fast paths, we mask 8 (or 4) bytes at a time.\n *\n * Note that we use unaligned loads and stores (allowed on these\n * architectures). This makes the code much easier to write, since we don't\n * need to guarantee that `src` and `dst` have the same alignment.\n *\n * It only causes a minor slowdown, around 5% on my machine (TM).\n */\n#if defined(__x86_64__)\n uint64_t mask64;\n /* Set up 64 byte mask. */\n mask64 = (uint64_t)(rotr32(mask, 8 * mask_offset));\n mask64 |= (mask64 << 32);\n /* Take the fast road. */\n while (src < src_end - 7) {\n *(uint64_t *)dst = *(uint64_t*)src ^ mask64;\n src += 8;\n dst += 8;\n }\n#elif defined(__i386__)\n /* Set up 32 byte mask. */\n uint32_t mask32;\n mask32 = (uint32_t)(rotr32(mask, 8 * mask_offset));\n\n /* Take the fast road. */\n while (src < src_end - 3) {\n *(uint32_t *)dst = *(uint32_t*)src ^ mask32;\n src += 4;\n dst += 4;\n }\n#endif\n\n /* This is the slow path which also handles the un-aligned suffix. */\n uint8_t *mask_ptr = (uint8_t *) &mask;\n while (src != src_end) {\n *dst = *src ^ *(mask_ptr + mask_offset);\n src++;\n dst++;\n mask_offset = (mask_offset + 1) & 0x3;\n }\n}\n" }, { "path": "coverage.sh", "content": "#!/bin/bash\n\nEXCLUDES=$(find tests/haskell -name '*.hs' |\n xargs sed -n 's/^module //p' |\n sed 's/^/--exclude=/' |\n xargs echo)\n\nTARGET=websockets-tests\n\ncabal configure --enable-tests --ghc-options='-fhpc' && cabal build\n./dist/build/$TARGET/$TARGET\n\nmkdir -p tests/coverage\nhpc markup --destdir=tests/coverage --exclude=Main $EXCLUDES $TARGET.tix\nhpc report --exclude=Main $EXCLUDES $TARGET.tix\nrm $TARGET.tix\n\necho \"Output written to tests/coverage/hpc_index.html\"\n" }, { "path": "example/client.hs", "content": "--------------------------------------------------------------------------------\n{-# LANGUAGE OverloadedStrings #-}\nmodule Main\n ( main\n ) where\n\n\n--------------------------------------------------------------------------------\nimport Control.Concurrent (forkIO)\nimport Control.Monad (forever, unless)\nimport Control.Monad.Trans (liftIO)\nimport Network.Socket (withSocketsDo)\nimport Data.Text (Text)\nimport qualified Data.Text as T\nimport qualified Data.Text.IO as T\nimport qualified Network.WebSockets as WS\n\n\n--------------------------------------------------------------------------------\napp :: WS.ClientApp ()\napp conn = do\n putStrLn \"Connected!\"\n\n -- Fork a thread that writes WS data to stdout\n _ <- forkIO $ forever $ do\n msg <- WS.receiveData conn\n liftIO $ T.putStrLn msg\n\n -- Read from stdin and write to WS\n let loop = do\n line <- T.getLine\n unless (T.null line) $ WS.sendTextData conn line >> loop\n\n loop\n WS.sendClose conn (\"Bye!\" :: Text)\n\n\n--------------------------------------------------------------------------------\nmain :: IO ()\nmain = withSocketsDo $ WS.runClient \"echo.websocket.org\" 80 \"/\" app\n" }, { "path": "example/client.html", "content": "\n\n \n Haskell WebSockets example\n \n \n \n \n \n

Haskell WebSockets example

\n
\n
\n
\n
\n

Join

\n
\n \n \n \n
\n
\n
\n

Users

\n
    \n
\n
\n
\n

Chat

\n
\n
\n
\n
\n \n \n
\n
\n
\n
\n Source code available here\n
\n \n\n" }, { "path": "example/client.js", "content": "function createChatSocket() {\n if(window.location.host == '') {\n /* Running on localhost */\n return new WebSocket('ws://localhost:9160/');\n } else {\n /* Running in \"production\" */\n return new WebSocket('wss://jaspervdj.be/websockets/example/chat/');\n }\n}\n\nvar users = [];\n\nfunction refreshUsers() {\n $('#users').html('');\n for(i in users) {\n $('#users').append($(document.createElement('li')).text(users[i]));\n }\n}\n\nfunction onMessage(event) {\n var p = $(document.createElement('p')).text(event.data);\n\n $('#messages').append(p);\n $('#messages').animate({scrollTop: $('#messages')[0].scrollHeight});\n\n if(event.data.match(/^[^:]* joined/)) {\n var user = event.data.replace(/ .*/, '');\n users.push(user);\n refreshUsers();\n }\n\n if(event.data.match(/^[^:]* disconnected/)) {\n var user = event.data.replace(/ .*/, '');\n var idx = users.indexOf(user);\n users = users.slice(0, idx).concat(users.slice(idx + 1));\n refreshUsers();\n }\n}\n\n$(document).ready(function () {\n $('#join-form').submit(function () {\n $('#warnings').html('');\n var user = $('#user').val();\n var ws = createChatSocket();\n\n ws.onopen = function() {\n ws.send('Hi! I am ' + user);\n };\n\n ws.onmessage = function(event) {\n if(event.data.match('^Welcome! Users: ')) {\n /* Calculate the list of initial users */\n var str = event.data.replace(/^Welcome! Users: /, '');\n if(str != \"\") {\n users = str.split(\", \");\n refreshUsers();\n }\n\n $('#join-section').hide();\n $('#chat-section').show();\n $('#users-section').show();\n\n ws.onmessage = onMessage;\n\n $('#message-form').submit(function () {\n var text = $('#text').val();\n ws.send(text);\n $('#text').val('');\n return false;\n });\n } else {\n $('#warnings').append(event.data);\n ws.close();\n }\n };\n\n $('#join').append('Connecting...');\n\n return false;\n });\n});\n" }, { "path": "example/screen.css", "content": "html {\n font-family: sans-serif;\n background-color: #335;\n font-size: 16px;\n}\n\nbody {\n}\n\nh1 {\n text-align: center;\n font-size: 20px;\n color: #fff;\n padding: 10px 10px 20px 10px;\n}\n\nh2 {\n border-bottom: 1px solid black;\n display: block;\n font-size: 18px;\n}\n\ndiv#main {\n width: 600px;\n margin: 0px auto 0px auto;\n padding: 0px;\n background-color: #fff;\n height: 460px;\n}\n\ndiv#warnings {\n color: red;\n font-weight: bold;\n margin: 10px;\n}\n\ndiv#join-section {\n float: left;\n margin: 10px;\n}\n\ndiv#users-section {\n width: 170px;\n float: right;\n padding: 0px;\n margin: 10px;\n}\n\nul#users {\n list-style-type: none;\n padding-left: 0px;\n height: 300px;\n overflow: auto;\n}\n\ndiv#chat-section {\n width: 390px;\n float: left;\n margin: 10px;\n}\n\ndiv#messages {\n margin: 0px;\n height: 300px;\n overflow: auto;\n}\n\ndiv#messages p {\n margin: 0px;\n padding: 0px;\n}\n\ndiv#footer {\n text-align: center;\n font-size: 12px;\n color: #fff;\n margin: 10px 0px 30px 0px;\n}\n\ndiv#footer a {\n color: #fff;\n}\n\ndiv.clear {\n clear: both;\n}\n" }, { "path": "example/server.lhs", "content": "websockets example\n==================\n\nThis is the Haskell implementation of the example for the WebSockets library. We\nimplement a simple multi-user chat program. A live demo of the example is\navailable [here](/example/client.html). In order to understand this example,\nkeep the [reference](/reference/) nearby to check out the functions we use.\n\n> {-# LANGUAGE OverloadedStrings #-}\n> module Main where\n> import Data.Char (isPunctuation, isSpace)\n> import Data.Monoid (mappend)\n> import Data.Text (Text)\n> import Control.Exception (finally)\n> import Control.Monad (forM_, forever)\n> import Control.Concurrent (MVar, newMVar, modifyMVar_, modifyMVar, readMVar)\n> import qualified Data.Text as T\n> import qualified Data.Text.IO as T\n\n> import qualified Network.WebSockets as WS\n\nWe represent a client by their username and a `WS.Connection`. We will see how we\nobtain this `WS.Connection` later on.\n\n> type Client = (Text, WS.Connection)\n\nThe state kept on the server is simply a list of connected clients. We've added\nan alias and some utility functions, so it will be easier to extend this state\nlater on.\n\n> type ServerState = [Client]\n\nCreate a new, initial state:\n\n> newServerState :: ServerState\n> newServerState = []\n\nGet the number of active clients:\n\n> numClients :: ServerState -> Int\n> numClients = length\n\nCheck if a user already exists (based on username):\n\n> clientExists :: Client -> ServerState -> Bool\n> clientExists client = any ((== fst client) . fst)\n\nAdd a client (this does not check if the client already exists, you should do\nthis yourself using `clientExists`):\n\n> addClient :: Client -> ServerState -> ServerState\n> addClient client clients = client : clients\n\nRemove a client:\n\n> removeClient :: Client -> ServerState -> ServerState\n> removeClient client = filter ((/= fst client) . fst)\n\nSend a message to all clients, and log it on stdout:\n\n> broadcast :: Text -> ServerState -> IO ()\n> broadcast message clients = do\n> T.putStrLn message\n> forM_ clients $ \\(_, conn) -> WS.sendTextData conn message\n\nThe main function first creates a new state for the server, then spawns the\nactual server. For this purpose, we use the simple server provided by\n`WS.runServer`.\n\n> main :: IO ()\n> main = do\n> state <- newMVar newServerState\n> WS.runServer \"127.0.0.1\" 9160 $ application state\n\nOur main application has the type:\n\n> application :: MVar ServerState -> WS.ServerApp\n\nNote that `WS.ServerApp` is nothing but a type synonym for\n`WS.PendingConnection -> IO ()`.\n\nOur application starts by accepting the connection. In a more realistic\napplication, you probably want to check the path and headers provided by the\npending request.\n\nWe also fork a pinging thread in the background. This will ensure the connection\nstays alive on some browsers.\n\n> application state pending = do\n> conn <- WS.acceptRequest pending\n> WS.withPingThread conn 30 (return ()) $ do\n\nWhen a client is succesfully connected, we read the first message. This should\nbe in the format of \"Hi! I am Jasper\", where Jasper is the requested username.\n\n> msg <- WS.receiveData conn\n> clients <- readMVar state\n> case msg of\n\nCheck that the first message has the right format:\n\n> _ | not (prefix `T.isPrefixOf` msg) ->\n> WS.sendTextData conn (\"Wrong announcement\" :: Text)\n\nCheck the validity of the username:\n\n> | any ($ fst client)\n> [T.null, T.any isPunctuation, T.any isSpace] ->\n> WS.sendTextData conn (\"Name cannot \" <>\n> \"contain punctuation or whitespace, and \" <>\n> \"cannot be empty\" :: Text)\n\nCheck that the given username is not already taken:\n\n> | clientExists client clients ->\n> WS.sendTextData conn (\"User already exists\" :: Text)\n\nAll is right! We're going to allow the client, but for safety reasons we *first*\nsetup a `disconnect` function that will be run when the connection is closed.\n\n> | otherwise -> flip finally disconnect $ do\n\nWe send a \"Welcome!\", according to our own little protocol. We add the client to\nthe list and broadcast the fact that he has joined. Then, we give control to the\n'talk' function.\n\n> modifyMVar_ state $ \\s -> do\n> let s' = addClient client s\n> WS.sendTextData conn $\n> \"Welcome! Users: \" <>\n> T.intercalate \", \" (map fst s)\n> broadcast (fst client <> \" joined\") s'\n> return s'\n> talk client state\n> where\n> prefix = \"Hi! I am \"\n> client = (T.drop (T.length prefix) msg, conn)\n> disconnect = do\n> -- Remove client and return new state\n> s <- modifyMVar state $ \\s ->\n> let s' = removeClient client s in return (s', s')\n> broadcast (fst client <> \" disconnected\") s\n\nThe talk function continues to read messages from a single client until he\ndisconnects. All messages are broadcasted to the other clients.\n\n> talk :: Client -> MVar ServerState -> IO ()\n> talk (user, conn) state = forever $ do\n> msg <- WS.receiveData conn\n> readMVar state >>= broadcast\n> (user `mappend` \": \" `mappend` msg)\n" }, { "path": "src/Network/WebSockets/Client.hs", "content": "--------------------------------------------------------------------------------\n-- | This part of the library provides you with utilities to create WebSockets\n-- clients (in addition to servers).\nmodule Network.WebSockets.Client\n ( ClientApp\n , runClient\n , runClientWith\n , runClientWithSocket\n , runClientWithStream\n , newClientConnection\n -- * Low level functionality\n , createRequest\n , Protocol(..)\n , defaultProtocol\n , checkServerResponse\n , streamToClientConnection\n ) where\n\n\n--------------------------------------------------------------------------------\nimport qualified Data.ByteString.Builder as Builder\nimport Control.Exception (bracket, finally, throwIO)\nimport Control.Concurrent.MVar (newEmptyMVar)\nimport Control.Monad (void)\nimport Data.IORef (newIORef)\nimport qualified Data.Text as T\nimport qualified Data.Text.Encoding as T\nimport qualified Network.Socket as S\nimport System.Timeout (timeout)\n\n\n--------------------------------------------------------------------------------\nimport Network.WebSockets.Connection\nimport Network.WebSockets.Http\nimport Network.WebSockets.Protocol\nimport Network.WebSockets.Stream (Stream)\nimport qualified Network.WebSockets.Stream as Stream\nimport Network.WebSockets.Types\n\n\n--------------------------------------------------------------------------------\n-- | A client application interacting with a single server. Once this 'IO'\n-- action finished, the underlying socket is closed automatically.\ntype ClientApp a = Connection -> IO a\n\n\n--------------------------------------------------------------------------------\n-- TODO: Maybe this should all be strings\nrunClient :: String -- ^ Host\n -> Int -- ^ Port\n -> String -- ^ Path\n -> ClientApp a -- ^ Client application\n -> IO a\nrunClient host port path ws =\n runClientWith host port path defaultConnectionOptions [] ws\n\n\n--------------------------------------------------------------------------------\nrunClientWith :: String -- ^ Host\n -> Int -- ^ Port\n -> String -- ^ Path\n -> ConnectionOptions -- ^ Options\n -> Headers -- ^ Custom headers to send\n -> ClientApp a -- ^ Client application\n -> IO a\nrunClientWith host port path0 opts customHeaders app = do\n -- Create and connect socket\n let hints = S.defaultHints\n {S.addrSocketType = S.Stream}\n\n -- Correct host and path.\n fullHost = if port == 80 then host else (host ++ \":\" ++ show port)\n path = if null path0 then \"/\" else path0\n addr:_ <- S.getAddrInfo (Just hints) (Just host) (Just $ show port)\n sock <- S.socket (S.addrFamily addr) S.Stream S.defaultProtocol\n S.setSocketOption sock S.NoDelay 1\n\n -- Connect WebSocket and run client\n res <- bracket\n (timeout (connectionTimeout opts * 1000 * 1000) $ S.connect sock (S.addrAddress addr))\n (const $ S.close sock) $ \\maybeConnected -> case maybeConnected of\n Nothing -> throwIO $ ConnectionTimeout\n Just () -> runClientWithSocket sock fullHost path opts customHeaders app\n\n\n -- Clean up\n return res\n\n\n--------------------------------------------------------------------------------\n\nrunClientWithStream\n :: Stream\n -- ^ Stream\n -> String\n -- ^ Host\n -> String\n -- ^ Path\n -> ConnectionOptions\n -- ^ Connection options\n -> Headers\n -- ^ Custom headers to send\n -> ClientApp a\n -- ^ Client application\n -> IO a\nrunClientWithStream stream host path opts customHeaders app = do\n newClientConnection stream host path opts customHeaders >>= app\n\n-- | Build a new 'Connection' from the client's point of view.\n--\n-- /WARNING/: Be sure to call 'Stream.close' on the given 'Stream' after you are\n-- done using the 'Connection' in order to properly close the communication\n-- channel. 'runClientWithStream' handles this for you, prefer to use it when\n-- possible.\nnewClientConnection\n :: Stream\n -- ^ Stream that will be used by the new 'Connection'.\n -> String\n -- ^ Host\n -> String\n -- ^ Path\n -> ConnectionOptions\n -- ^ Connection options\n -> Headers\n -- ^ Custom headers to send\n -> IO Connection\nnewClientConnection stream host path opts customHeaders = do\n -- Create the request and send it\n request <- createRequest protocol bHost bPath False customHeaders\n Stream.write stream (Builder.toLazyByteString $ encodeRequestHead request)\n checkServerResponse stream request\n streamToClientConnection stream opts\n where\n protocol = defaultProtocol -- TODO\n bHost = T.encodeUtf8 $ T.pack host\n bPath = T.encodeUtf8 $ T.pack path\n\n-- | Check the response from the server.\n-- Throws 'OtherHandshakeException' on failure\ncheckServerResponse :: Stream -> RequestHead -> IO ()\ncheckServerResponse stream request = do\n mbResponse <- Stream.parse stream decodeResponseHead\n response <- case mbResponse of\n Just response -> return response\n Nothing -> throwIO $ OtherHandshakeException $\n \"Network.WebSockets.Client.newClientConnection: no handshake \" ++\n \"response from server\"\n void $ either throwIO return $ finishResponse protocol request response\n where\n protocol = defaultProtocol -- TODO\n\n\n-- | Build a 'Connection' from a pre-established stream with already finished\n-- handshake.\n--\n-- /NB/: this will not perform any handshaking.\nstreamToClientConnection :: Stream -> ConnectionOptions -> IO Connection\nstreamToClientConnection stream opts = do\n parse <- decodeMessages protocol\n (connectionFramePayloadSizeLimit opts)\n (connectionMessageDataSizeLimit opts) stream\n write <- encodeMessages protocol ClientConnection stream\n sentRef <- newIORef False\n heartbeat <- newEmptyMVar\n return $ Connection\n { connectionOptions = opts\n , connectionType = ClientConnection\n , connectionProtocol = protocol\n , connectionParse = parse\n , connectionWrite = write\n , connectionHeartbeat = heartbeat\n , connectionSentClose = sentRef\n }\n where\n protocol = defaultProtocol\n\n\n--------------------------------------------------------------------------------\nrunClientWithSocket :: S.Socket -- ^ Socket\n -> String -- ^ Host\n -> String -- ^ Path\n -> ConnectionOptions -- ^ Options\n -> Headers -- ^ Custom headers to send\n -> ClientApp a -- ^ Client application\n -> IO a\nrunClientWithSocket sock host path opts customHeaders app = bracket\n (Stream.makeSocketStream sock)\n Stream.close\n (\\stream ->\n runClientWithStream stream host path opts customHeaders app)\n" }, { "path": "src/Network/WebSockets/Connection/Options.hs", "content": "{-# LANGUAGE CPP #-}\n--------------------------------------------------------------------------------\nmodule Network.WebSockets.Connection.Options\n ( ConnectionOptions (..)\n , defaultConnectionOptions\n\n , CompressionOptions (..)\n , PermessageDeflate (..)\n , defaultPermessageDeflate\n\n , SizeLimit (..)\n , atMostSizeLimit\n ) where\n\n\n--------------------------------------------------------------------------------\nimport Data.Int (Int64)\nimport Data.Monoid (Monoid (..))\nimport Prelude\n\n\n--------------------------------------------------------------------------------\n-- | Set options for a 'Connection'. Please do not use this constructor\n-- directly, but rather use 'defaultConnectionOptions' and then set the fields\n-- you want, e.g.:\n--\n-- > myOptions = defaultConnectionOptions {connectionStrictUnicode = True}\n--\n-- This way your code does not break if the library introduces new fields.\ndata ConnectionOptions = ConnectionOptions\n { connectionOnPong :: !(IO ())\n -- ^ Whenever a 'pong' is received, this IO action is executed. It can be\n -- used to tickle connections or fire missiles.\n , connectionTimeout :: !Int\n -- ^ Timeout for connection establishment in seconds. Only used in the client.\n , connectionCompressionOptions :: !CompressionOptions\n -- ^ Enable 'PermessageDeflate'.\n , connectionStrictUnicode :: !Bool\n -- ^ Enable strict unicode on the connection. This means that if a client\n -- (or server) sends invalid UTF-8, we will throw a 'UnicodeException'\n -- rather than replacing it by the unicode replacement character U+FFFD.\n , connectionFramePayloadSizeLimit :: !SizeLimit\n -- ^ The maximum size for incoming frame payload size in bytes. If a\n -- frame exceeds this limit, a 'ParseException' is thrown.\n , connectionMessageDataSizeLimit :: !SizeLimit\n -- ^ 'connectionFrameSizeLimit' is often not enough since a malicious\n -- client can send many small frames to create a huge message. This limit\n -- allows you to protect from that. If a message exceeds this limit, a\n -- 'ParseException' is thrown.\n --\n -- Note that, if compression is enabled, we check the size of the\n -- compressed messages, as well as the size of the uncompressed messages\n -- as we are deflating them to ensure we don't use too much memory in any\n -- case.\n }\n\n\n--------------------------------------------------------------------------------\n-- | The default connection options:\n--\n-- * Nothing happens when a pong is received.\n-- * Compression is disabled.\n-- * Lenient unicode decoding.\n-- * 30 second timeout for connection establishment.\ndefaultConnectionOptions :: ConnectionOptions\ndefaultConnectionOptions = ConnectionOptions\n { connectionOnPong = return ()\n , connectionTimeout = 30\n , connectionCompressionOptions = NoCompression\n , connectionStrictUnicode = False\n , connectionFramePayloadSizeLimit = mempty\n , connectionMessageDataSizeLimit = mempty\n }\n\n\n--------------------------------------------------------------------------------\ndata CompressionOptions\n = NoCompression\n | PermessageDeflateCompression PermessageDeflate\n deriving (Eq, Show)\n\n\n--------------------------------------------------------------------------------\n-- | Four extension parameters are defined for \"permessage-deflate\" to\n-- help endpoints manage per-connection resource usage.\n--\n-- - \"server_no_context_takeover\"\n-- - \"client_no_context_takeover\"\n-- - \"server_max_window_bits\"\n-- - \"client_max_window_bits\"\ndata PermessageDeflate = PermessageDeflate\n { serverNoContextTakeover :: Bool\n , clientNoContextTakeover :: Bool\n , serverMaxWindowBits :: Int\n , clientMaxWindowBits :: Int\n , pdCompressionLevel :: Int\n } deriving (Eq, Show)\n\n\n--------------------------------------------------------------------------------\ndefaultPermessageDeflate :: PermessageDeflate\ndefaultPermessageDeflate = PermessageDeflate False False 15 15 8\n\n\n--------------------------------------------------------------------------------\n-- | A size limit, in bytes. The 'Monoid' instance takes the minimum limit.\ndata SizeLimit\n = NoSizeLimit\n | SizeLimit !Int64\n deriving (Eq, Show)\n\n\n--------------------------------------------------------------------------------\ninstance Monoid SizeLimit where\n mempty = NoSizeLimit\n\n#if !MIN_VERSION_base(4,11,0)\n mappend NoSizeLimit y = y\n mappend x NoSizeLimit = x\n mappend (SizeLimit x) (SizeLimit y) = SizeLimit (min x y)\n#else\ninstance Semigroup SizeLimit where\n (<>) NoSizeLimit y = y\n (<>) x NoSizeLimit = x\n (<>) (SizeLimit x) (SizeLimit y) = SizeLimit (min x y)\n#endif\n\n--------------------------------------------------------------------------------\natMostSizeLimit :: Int64 -> SizeLimit -> Bool\natMostSizeLimit _ NoSizeLimit = True\natMostSizeLimit s (SizeLimit l) = s <= l\n{-# INLINE atMostSizeLimit #-}\n" }, { "path": "src/Network/WebSockets/Connection/PingPong.hs", "content": "module Network.WebSockets.Connection.PingPong\n ( withPingPong\n , PingPongOptions(..)\n , PongTimeout(..)\n , defaultPingPongOptions\n ) where \n\nimport Control.Concurrent.Async as Async\nimport Control.Exception\nimport Control.Monad (void)\nimport Network.WebSockets.Connection (Connection, connectionHeartbeat, pingThread)\nimport Control.Concurrent.MVar (takeMVar)\nimport System.Timeout (timeout)\n\n\n-- | Exception type used to kill connections if there\n-- is a pong timeout.\ndata PongTimeout = PongTimeout deriving Show\n\ninstance Exception PongTimeout\n\n\n-- | Options for ping-pong\n-- \n-- Make sure that the ping interval is less than the pong timeout,\n-- for example N/2.\ndata PingPongOptions = PingPongOptions {\n pingInterval :: Int, -- ^ Interval in seconds\n pongTimeout :: Int, -- ^ Timeout in seconds\n pingAction :: IO () -- ^ Action to perform after sending a ping\n}\n\n-- | Default options for ping-pong\n-- \n-- Ping every 15 seconds, timeout after 30 seconds\ndefaultPingPongOptions :: PingPongOptions\ndefaultPingPongOptions = PingPongOptions {\n pingInterval = 15,\n pongTimeout = 30,\n pingAction = return ()\n}\n\n-- | Run an application with ping-pong enabled. Raises 'PongTimeout' if a pong\n-- is not received.\n--\n-- Can used with Client and Server connections.\n--\n-- The implementation uses multiple threads, so if you want to call this from a\n-- Monad other than 'IO', we recommend using\n-- [unliftio](https://hackage.haskell.org/package/unliftio), e.g. using a\n-- wrapper like this:\n--\n-- > withPingPongUnlifted\n-- > :: MonadUnliftIO m\n-- > => PingPongOptions -> Connection -> (Connection -> m ()) -> m ()\n-- > withPingPongUnlifted options connection app = withRunInIO $ \\run ->\n-- > withPingPong options connection (run . app)\nwithPingPong :: PingPongOptions -> Connection -> (Connection -> IO ()) -> IO ()\nwithPingPong options connection app = void $ \n withAsync (app connection) $ \\appAsync -> do\n withAsync (pingThread connection (pingInterval options) (pingAction options)) $ \\pingAsync -> do\n withAsync (heartbeat >> throwIO PongTimeout) $ \\heartbeatAsync -> do\n waitAnyCancel [appAsync, pingAsync, heartbeatAsync]\n where\n heartbeat = whileJust $ timeout (pongTimeout options * 1000 * 1000) \n $ takeMVar (connectionHeartbeat connection)\n\n -- Loop until action returns Nothing\n whileJust :: IO (Maybe a) -> IO ()\n whileJust action = do\n result <- action\n case result of\n Nothing -> return ()\n Just _ -> whileJust action" }, { "path": "src/Network/WebSockets/Connection.hs", "content": "--------------------------------------------------------------------------------\n-- | This module exposes connection internals\n{-# LANGUAGE OverloadedStrings #-}\nmodule Network.WebSockets.Connection\n ( PendingConnection (..)\n , acceptRequest\n , AcceptRequest(..)\n , defaultAcceptRequest\n , acceptRequestWith\n , rejectRequest\n , RejectRequest(..)\n , defaultRejectRequest\n , rejectRequestWith\n\n , Connection (..)\n\n , ConnectionOptions (..)\n , defaultConnectionOptions\n\n , receive\n , receiveDataMessage\n , receiveData\n , send\n , sendDataMessage\n , sendDataMessages\n , sendTextData\n , sendTextDatas\n , sendBinaryData\n , sendBinaryDatas\n , sendClose\n , sendCloseCode\n , sendPing\n , sendPong\n\n , withPingThread\n , forkPingThread\n , pingThread\n\n , CompressionOptions (..)\n , PermessageDeflate (..)\n , defaultPermessageDeflate\n\n , SizeLimit (..)\n ) where\n\n\n--------------------------------------------------------------------------------\nimport Control.Applicative ((<$>))\nimport Control.Concurrent (forkIO,\n threadDelay)\nimport qualified Control.Concurrent.Async as Async\nimport Control.Concurrent.MVar (MVar, newEmptyMVar, tryPutMVar)\nimport Control.Exception (AsyncException,\n fromException,\n handle,\n throwIO)\nimport Control.Monad (foldM, unless,\n when)\nimport qualified Data.ByteString as B\nimport qualified Data.ByteString.Builder as Builder\nimport qualified Data.ByteString.Char8 as B8\nimport Data.IORef (IORef,\n newIORef,\n readIORef,\n writeIORef)\nimport Data.List (find)\nimport Data.Maybe (catMaybes)\nimport qualified Data.Text as T\nimport Data.Word (Word16)\nimport Prelude\n\n\n--------------------------------------------------------------------------------\nimport Network.WebSockets.Connection.Options\nimport Network.WebSockets.Extensions as Extensions\nimport Network.WebSockets.Extensions.PermessageDeflate\nimport Network.WebSockets.Extensions.StrictUnicode\nimport Network.WebSockets.Http\nimport Network.WebSockets.Protocol\nimport Network.WebSockets.Stream (Stream)\nimport qualified Network.WebSockets.Stream as Stream\nimport Network.WebSockets.Types\n\n\n--------------------------------------------------------------------------------\n-- | A new client connected to the server. We haven't accepted the connection\n-- yet, though.\ndata PendingConnection = PendingConnection\n { pendingOptions :: !ConnectionOptions\n -- ^ Options, passed as-is to the 'Connection'\n , pendingRequest :: !RequestHead\n -- ^ Useful for e.g. inspecting the request path.\n , pendingOnAccept :: !(Connection -> IO ())\n -- ^ One-shot callback fired when a connection is accepted, i.e., *after*\n -- the accepting response is sent to the client.\n , pendingStream :: !Stream\n -- ^ Input/output stream\n }\n\n\n--------------------------------------------------------------------------------\n-- | This datatype allows you to set options for 'acceptRequestWith'. It is\n-- strongly recommended to use 'defaultAcceptRequest' and then modify the\n-- various fields, that way new fields introduced in the library do not break\n-- your code.\ndata AcceptRequest = AcceptRequest\n { acceptSubprotocol :: !(Maybe B.ByteString)\n -- ^ The subprotocol to speak with the client. If 'pendingSubprotcols' is\n -- non-empty, 'acceptSubprotocol' must be one of the subprotocols from the\n -- list.\n , acceptHeaders :: !Headers\n -- ^ Extra headers to send with the response.\n }\n\n\n--------------------------------------------------------------------------------\ndefaultAcceptRequest :: AcceptRequest\ndefaultAcceptRequest = AcceptRequest Nothing []\n\n\n--------------------------------------------------------------------------------\n-- | Utility\nsendResponse :: PendingConnection -> Response -> IO ()\nsendResponse pc rsp = Stream.write (pendingStream pc)\n (Builder.toLazyByteString (encodeResponse rsp))\n\n\n--------------------------------------------------------------------------------\n-- | Accept a pending connection, turning it into a 'Connection'.\nacceptRequest :: PendingConnection -> IO Connection\nacceptRequest pc = acceptRequestWith pc defaultAcceptRequest\n\n\n--------------------------------------------------------------------------------\n-- | This function is like 'acceptRequest' but allows you to set custom options\n-- using the 'AcceptRequest' datatype.\nacceptRequestWith :: PendingConnection -> AcceptRequest -> IO Connection\nacceptRequestWith pc ar = case find (flip compatible request) protocols of\n Nothing -> do\n sendResponse pc $ response400 versionHeader \"\"\n throwIO NotSupported\n Just protocol -> do\n\n -- Get requested list of exceptions from client.\n rqExts <- either throwIO return $\n getRequestSecWebSocketExtensions request\n\n -- Set up permessage-deflate extension if configured.\n pmdExt <- case connectionCompressionOptions (pendingOptions pc) of\n NoCompression -> return Nothing\n PermessageDeflateCompression pmd0 ->\n case negotiateDeflate (connectionMessageDataSizeLimit options) (Just pmd0) rqExts of\n Left err -> do\n rejectRequestWith pc defaultRejectRequest {rejectMessage = B8.pack err}\n throwIO NotSupported\n Right pmd1 -> return (Just pmd1)\n\n -- Set up strict utf8 extension if configured.\n let unicodeExt =\n if connectionStrictUnicode (pendingOptions pc)\n then Just strictUnicode else Nothing\n\n -- Final extension list.\n let exts = catMaybes [pmdExt, unicodeExt]\n\n let subproto = maybe [] (\\p -> [(\"Sec-WebSocket-Protocol\", p)]) $ acceptSubprotocol ar\n headers = subproto ++ acceptHeaders ar ++ concatMap extHeaders exts\n response = finishRequest protocol request headers\n\n either throwIO (sendResponse pc) response\n\n parseRaw <- decodeMessages\n protocol\n (connectionFramePayloadSizeLimit options)\n (connectionMessageDataSizeLimit options)\n (pendingStream pc)\n writeRaw <- encodeMessages protocol ServerConnection (pendingStream pc)\n\n write <- foldM (\\x ext -> extWrite ext x) writeRaw exts\n parse <- foldM (\\x ext -> extParse ext x) parseRaw exts\n\n sentRef <- newIORef False\n heartbeat <- newEmptyMVar\n let connection = Connection\n { connectionOptions = options\n , connectionType = ServerConnection\n , connectionProtocol = protocol\n , connectionParse = parse\n , connectionWrite = write\n , connectionHeartbeat = heartbeat\n , connectionSentClose = sentRef\n }\n\n pendingOnAccept pc connection\n return connection\n where\n options = pendingOptions pc\n request = pendingRequest pc\n versionHeader = [(\"Sec-WebSocket-Version\",\n B.intercalate \", \" $ concatMap headerVersions protocols)]\n\n\n--------------------------------------------------------------------------------\n-- | Parameters that allow you to tweak how a request is rejected. Please use\n-- 'defaultRejectRequest' and modify fields using record syntax so your code\n-- will not break when new fields are added.\ndata RejectRequest = RejectRequest\n { -- | The status code, 400 by default.\n rejectCode :: !Int\n , -- | The message, \"Bad Request\" by default\n rejectMessage :: !B.ByteString\n , -- | Extra headers to be sent with the response.\n rejectHeaders :: Headers\n , -- | Reponse body of the rejection.\n rejectBody :: !B.ByteString\n }\n\n\n--------------------------------------------------------------------------------\ndefaultRejectRequest :: RejectRequest\ndefaultRejectRequest = RejectRequest\n { rejectCode = 400\n , rejectMessage = \"Bad Request\"\n , rejectHeaders = []\n , rejectBody = \"\"\n }\n\n\n--------------------------------------------------------------------------------\n-- | Requires calling 'pendingStream' and 'Stream.close'.\nrejectRequestWith\n :: PendingConnection -- ^ Connection to reject\n -> RejectRequest -- ^ Params on how to reject the request\n -> IO ()\nrejectRequestWith pc reject = sendResponse pc $ Response\n ResponseHead\n { responseCode = rejectCode reject\n , responseMessage = rejectMessage reject\n , responseHeaders = rejectHeaders reject\n }\n (rejectBody reject)\n\n\n--------------------------------------------------------------------------------\n-- | Requires calling 'pendingStream' and 'Stream.close'.\nrejectRequest\n :: PendingConnection -- ^ Connection to reject\n -> B.ByteString -- ^ Rejection response body\n -> IO ()\nrejectRequest pc body = rejectRequestWith pc\n defaultRejectRequest {rejectBody = body}\n\n\n--------------------------------------------------------------------------------\ndata Connection = Connection\n { connectionOptions :: !ConnectionOptions\n , connectionType :: !ConnectionType\n , connectionProtocol :: !Protocol\n , connectionHeartbeat :: !(MVar ())\n -- ^ This MVar is filled whenever a pong is received. This is used by\n -- 'withPingPong' to timeout the connection if a pong is not received.\n , connectionParse :: !(IO (Maybe Message))\n , connectionWrite :: !([Message] -> IO ())\n , connectionSentClose :: !(IORef Bool)\n -- ^ According to the RFC, both the client and the server MUST send\n -- a close control message to each other. Either party can initiate\n -- the first close message but then the other party must respond. Finally,\n -- the server is in charge of closing the TCP connection. This IORef tracks\n -- if we have sent a close message and are waiting for the peer to respond.\n }\n\n\n--------------------------------------------------------------------------------\nreceive :: Connection -> IO Message\nreceive conn = do\n mbMsg <- connectionParse conn\n case mbMsg of\n Nothing -> throwIO ConnectionClosed\n Just msg -> return msg\n\n\n--------------------------------------------------------------------------------\n-- | Receive an application message. Automatically respond to control messages.\n--\n-- When the peer sends a close control message, an exception of type 'CloseRequest'\n-- is thrown. The peer can send a close control message either to initiate a\n-- close or in response to a close message we have sent to the peer. In either\n-- case the 'CloseRequest' exception will be thrown. The RFC specifies that\n-- the server is responsible for closing the TCP connection, which should happen\n-- after receiving the 'CloseRequest' exception from this function.\n--\n-- This will throw 'ConnectionClosed' if the TCP connection dies unexpectedly.\nreceiveDataMessage :: Connection -> IO DataMessage\nreceiveDataMessage conn = do\n msg <- receive conn\n case msg of\n DataMessage _ _ _ am -> return am\n ControlMessage cm -> case cm of\n Close i closeMsg -> do\n hasSentClose <- readIORef $ connectionSentClose conn\n unless hasSentClose $ send conn msg\n throwIO $ CloseRequest i closeMsg\n Pong _ -> do\n _ <- tryPutMVar (connectionHeartbeat conn) ()\n connectionOnPong (connectionOptions conn)\n receiveDataMessage conn\n Ping pl -> do\n send conn (ControlMessage (Pong pl))\n receiveDataMessage conn\n\n\n--------------------------------------------------------------------------------\n-- | Receive a message, converting it to whatever format is needed.\nreceiveData :: WebSocketsData a => Connection -> IO a\nreceiveData conn = fromDataMessage <$> receiveDataMessage conn\n\n\n--------------------------------------------------------------------------------\nsend :: Connection -> Message -> IO ()\nsend conn = sendAll conn . return\n\n--------------------------------------------------------------------------------\nsendAll :: Connection -> [Message] -> IO ()\nsendAll _ [] = return ()\nsendAll conn msgs = do\n when (any isCloseMessage msgs) $\n writeIORef (connectionSentClose conn) True\n connectionWrite conn msgs\n where\n isCloseMessage (ControlMessage (Close _ _)) = True\n isCloseMessage _ = False\n\n--------------------------------------------------------------------------------\n-- | Send a 'DataMessage'. This allows you send both human-readable text and\n-- binary data. This is a slightly more low-level interface than 'sendTextData'\n-- or 'sendBinaryData'.\nsendDataMessage :: Connection -> DataMessage -> IO ()\nsendDataMessage conn = sendDataMessages conn . return\n\n--------------------------------------------------------------------------------\n-- | Send a collection of 'DataMessage's. This is more efficient than calling\n-- 'sendDataMessage' many times.\nsendDataMessages :: Connection -> [DataMessage] -> IO ()\nsendDataMessages conn = sendAll conn . map (DataMessage False False False)\n\n--------------------------------------------------------------------------------\n-- | Send a textual message. The message will be encoded as UTF-8. This should\n-- be the default choice for human-readable text-based protocols such as JSON.\nsendTextData :: WebSocketsData a => Connection -> a -> IO ()\nsendTextData conn = sendTextDatas conn . return\n\n--------------------------------------------------------------------------------\n-- | Send a number of textual messages. This is more efficient than calling\n-- 'sendTextData' many times.\nsendTextDatas :: WebSocketsData a => Connection -> [a] -> IO ()\nsendTextDatas conn =\n sendDataMessages conn .\n map (\\x -> Text (toLazyByteString x) Nothing)\n\n--------------------------------------------------------------------------------\n-- | Send a binary message. This is useful for sending binary blobs, e.g.\n-- images, data encoded with MessagePack, images...\nsendBinaryData :: WebSocketsData a => Connection -> a -> IO ()\nsendBinaryData conn = sendBinaryDatas conn . return\n\n--------------------------------------------------------------------------------\n-- | Send a number of binary messages. This is more efficient than calling\n-- 'sendBinaryData' many times.\nsendBinaryDatas :: WebSocketsData a => Connection -> [a] -> IO ()\nsendBinaryDatas conn = sendDataMessages conn . map (Binary . toLazyByteString)\n\n--------------------------------------------------------------------------------\n-- | Send a friendly close message. Note that after sending this message,\n-- you should still continue calling 'receiveDataMessage' to process any\n-- in-flight messages. The peer will eventually respond with a close control\n-- message of its own which will cause 'receiveDataMessage' to throw the\n-- 'CloseRequest' exception. This exception is when you can finally consider\n-- the connection closed.\nsendClose :: WebSocketsData a => Connection -> a -> IO ()\nsendClose conn = sendCloseCode conn 1000\n\n\n--------------------------------------------------------------------------------\n-- | Send a friendly close message and close code. Similar to 'sendClose',\n-- you should continue calling 'receiveDataMessage' until you receive a\n-- 'CloseRequest' exception.\n--\n-- See for a list of close\n-- codes.\nsendCloseCode :: WebSocketsData a => Connection -> Word16 -> a -> IO ()\nsendCloseCode conn code =\n send conn . ControlMessage . Close code . toLazyByteString\n\n\n--------------------------------------------------------------------------------\n-- | Send a ping\nsendPing :: WebSocketsData a => Connection -> a -> IO ()\nsendPing conn = send conn . ControlMessage . Ping . toLazyByteString\n\n--------------------------------------------------------------------------------\n-- | Send a pong\nsendPong :: WebSocketsData a => Connection -> a -> IO ()\nsendPong conn = send conn . ControlMessage . Pong . toLazyByteString\n\n--------------------------------------------------------------------------------\n-- | Forks a ping thread, sending a ping message every @n@ seconds over the\n-- connection. The thread is killed when the inner IO action is finished.\n--\n-- This is useful to keep idle connections open through proxies and whatnot.\n-- Many (but not all) proxies have a 60 second default timeout, so based on that\n-- sending a ping every 30 seconds is a good idea.\n--\n-- Note that usually you want to use 'Network.WebSockets.Connection.PingPong.withPingPong'\n-- to timeout the connection if a pong is not received.\nwithPingThread\n :: Connection\n -> Int -- ^ Second interval in which pings should be sent.\n -> IO () -- ^ Repeat this after sending a ping.\n -> IO a -- ^ Application to wrap with a ping thread.\n -> IO a -- ^ Executes application and kills ping thread when done.\nwithPingThread conn n action app =\n Async.withAsync (pingThread conn n action) (\\_ -> app)\n\n--------------------------------------------------------------------------------\n-- | DEPRECATED: Use 'withPingThread' instead.\n--\n-- Forks a ping thread, sending a ping message every @n@ seconds over the\n-- connection. The thread dies silently if the connection crashes or is closed.\n--\n-- This is useful to keep idle connections open through proxies and whatnot.\n-- Many (but not all) proxies have a 60 second default timeout, so based on that\n-- sending a ping every 30 seconds is a good idea.\nforkPingThread :: Connection -> Int -> IO ()\nforkPingThread conn n = do\n _ <- forkIO $ pingThread conn n (return ())\n return ()\n{-# DEPRECATED forkPingThread \"Use 'withPingThread' instead\" #-}\n\n\n--------------------------------------------------------------------------------\n-- | Use this if you want to run the ping thread yourself.\n--\n-- See also 'withPingThread'.\npingThread :: Connection -> Int -> IO () -> IO ()\npingThread conn n action\n | n <= 0 = return ()\n | otherwise = ignore `handle` go 1\n where\n go :: Int -> IO ()\n go i = do\n threadDelay (n * 1000 * 1000)\n sendPing conn (T.pack $ show i)\n action\n go (i + 1)\n\n ignore e = case fromException e of\n Just async -> throwIO (async :: AsyncException)\n Nothing -> return ()\n" }, { "path": "src/Network/WebSockets/Extensions/Description.hs", "content": "-- | Code for parsing extensions headers.\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE RecordWildCards #-}\nmodule Network.WebSockets.Extensions.Description\n ( ExtensionParam\n , ExtensionDescription (..)\n , ExtensionDescriptions\n\n , parseExtensionDescriptions\n , encodeExtensionDescriptions\n ) where\n\nimport Control.Applicative ((*>), (<*))\nimport qualified Data.Attoparsec.ByteString as A\nimport qualified Data.Attoparsec.ByteString.Char8 as AC8\nimport qualified Data.ByteString as B\nimport Data.Monoid (mconcat, mappend)\nimport Prelude\n\ntype ExtensionParam = (B.ByteString, Maybe B.ByteString)\n\ndata ExtensionDescription = ExtensionDescription\n { extName :: !B.ByteString\n , extParams :: ![ExtensionParam]\n } deriving (Eq, Show)\n\nparseExtensionDescription :: A.Parser ExtensionDescription\nparseExtensionDescription = do\n extName <- parseIdentifier\n extParams <- A.many' (token ';' *> parseParam)\n return ExtensionDescription {..}\n where\n parseIdentifier = AC8.takeWhile isIdentifierChar <* AC8.skipSpace\n\n token c = AC8.char8 c <* AC8.skipSpace\n\n isIdentifierChar c =\n (c >= 'a' && c <= 'z') ||\n (c >= 'A' && c <= 'Z') ||\n (c >= '0' && c <= '9') ||\n c == '-' || c == '_'\n\n parseParam :: A.Parser ExtensionParam\n parseParam = do\n name <- parseIdentifier\n val <- A.option Nothing $ fmap Just $ token '=' *> parseIdentifier\n return (name, val)\n\nencodeExtensionDescription :: ExtensionDescription -> B.ByteString\nencodeExtensionDescription ExtensionDescription {..} =\n mconcat (extName : map encodeParam extParams)\n where\n encodeParam (key, Nothing) = \";\" `mappend` key\n encodeParam (key, Just val) = \";\" `mappend` key `mappend` \"=\" `mappend` val\n\ntype ExtensionDescriptions = [ExtensionDescription]\n\nparseExtensionDescriptions :: B.ByteString -> Either String ExtensionDescriptions\nparseExtensionDescriptions = A.parseOnly $\n AC8.skipSpace *>\n A.sepBy parseExtensionDescription (AC8.char8 ',' <* AC8.skipSpace) <*\n A.endOfInput\n\nencodeExtensionDescriptions :: ExtensionDescriptions -> B.ByteString\nencodeExtensionDescriptions = B.intercalate \",\" . map encodeExtensionDescription\n" }, { "path": "src/Network/WebSockets/Extensions/PermessageDeflate.hs", "content": "--------------------------------------------------------------------------------\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TupleSections #-}\nmodule Network.WebSockets.Extensions.PermessageDeflate\n ( defaultPermessageDeflate\n , PermessageDeflate(..)\n , negotiateDeflate\n\n -- * Considered internal\n , makeMessageInflater\n , makeMessageDeflater\n ) where\n\n\n--------------------------------------------------------------------------------\nimport Control.Applicative ((<$>))\nimport Control.Exception (throwIO)\nimport Control.Monad (foldM, unless)\nimport qualified Data.ByteString as B\nimport qualified Data.ByteString.Char8 as B8\nimport qualified Data.ByteString.Lazy as BL\nimport qualified Data.ByteString.Lazy.Char8 as BL8\nimport qualified Data.ByteString.Lazy.Internal as BL\nimport Data.Int (Int64)\nimport Data.Monoid\nimport qualified Data.Streaming.Zlib as Zlib\nimport Network.WebSockets.Connection.Options\nimport Network.WebSockets.Extensions\nimport Network.WebSockets.Extensions.Description\nimport Network.WebSockets.Http\nimport Network.WebSockets.Types\nimport Prelude\nimport Text.Read (readMaybe)\n\n\n--------------------------------------------------------------------------------\n-- | Convert the parameters to an 'ExtensionDescription' that we can put in a\n-- 'Sec-WebSocket-Extensions' header.\ntoExtensionDescription :: PermessageDeflate -> ExtensionDescription\ntoExtensionDescription PermessageDeflate {..} = ExtensionDescription\n { extName = \"permessage-deflate\"\n , extParams =\n [(\"server_no_context_takeover\", Nothing) | serverNoContextTakeover] ++\n [(\"client_no_context_takeover\", Nothing) | clientNoContextTakeover] ++\n [(\"server_max_window_bits\", param serverMaxWindowBits) | serverMaxWindowBits /= 15] ++\n [(\"client_max_window_bits\", param clientMaxWindowBits) | clientMaxWindowBits /= 15]\n }\n where\n param = Just . B8.pack . show\n\n\n--------------------------------------------------------------------------------\ntoHeaders :: PermessageDeflate -> Headers\ntoHeaders pmd =\n [ ( \"Sec-WebSocket-Extensions\"\n , encodeExtensionDescriptions [toExtensionDescription pmd]\n )\n ]\n\n\n--------------------------------------------------------------------------------\nnegotiateDeflate\n :: SizeLimit -> Maybe PermessageDeflate -> NegotiateExtension\nnegotiateDeflate messageLimit pmd0 exts0 = do\n (headers, pmd1) <- negotiateDeflateOpts exts0 pmd0\n return Extension\n { extHeaders = headers\n , extParse = \\parseRaw -> do\n inflate <- makeMessageInflater messageLimit pmd1\n return $ do\n msg <- parseRaw\n case msg of\n Nothing -> return Nothing\n Just m -> fmap Just (inflate m)\n\n , extWrite = \\writeRaw -> do\n deflate <- makeMessageDeflater pmd1\n return $ \\msgs ->\n mapM deflate msgs >>= writeRaw\n }\n where\n negotiateDeflateOpts\n :: ExtensionDescriptions\n -> Maybe PermessageDeflate\n -> Either String (Headers, Maybe PermessageDeflate)\n\n negotiateDeflateOpts (ext : _) (Just x)\n | extName ext == \"x-webkit-deflate-frame\" = Right\n ([(\"Sec-WebSocket-Extensions\", \"x-webkit-deflate-frame\")], Just x)\n\n negotiateDeflateOpts (ext : _) (Just x)\n | extName ext == \"permessage-deflate\" = do\n x' <- foldM setParam x (extParams ext)\n Right (toHeaders x', Just x')\n\n negotiateDeflateOpts (_ : exts) (Just x) =\n negotiateDeflateOpts exts (Just x)\n\n negotiateDeflateOpts _ _ = Right ([], Nothing)\n\n\n--------------------------------------------------------------------------------\nsetParam\n :: PermessageDeflate -> ExtensionParam -> Either String PermessageDeflate\nsetParam pmd (\"server_no_context_takeover\", _) =\n Right pmd {serverNoContextTakeover = True}\n\nsetParam pmd (\"client_no_context_takeover\", _) =\n Right pmd {clientNoContextTakeover = True}\n\nsetParam pmd (\"server_max_window_bits\", Nothing) =\n Right pmd {serverMaxWindowBits = 15}\n\nsetParam pmd (\"server_max_window_bits\", Just param) = do\n w <- parseWindow param\n Right pmd {serverMaxWindowBits = w}\n\nsetParam pmd (\"client_max_window_bits\", Nothing) = do\n Right pmd {clientMaxWindowBits = 15}\n\nsetParam pmd (\"client_max_window_bits\", Just param) = do\n w <- parseWindow param\n Right pmd {clientMaxWindowBits = w}\n\nsetParam pmd (_, _) = Right pmd\n\n\n--------------------------------------------------------------------------------\nparseWindow :: B.ByteString -> Either String Int\nparseWindow bs8 = case readMaybe (B8.unpack bs8) of\n Just w\n | w >= 8 && w <= 15 -> Right w\n | otherwise -> Left $ \"Window out of bounds: \" ++ show w\n Nothing -> Left $ \"Can't parse window: \" ++ show bs8\n\n\n--------------------------------------------------------------------------------\n-- | If the window_bits parameter is set to 8, we must set it to 9 instead.\n--\n-- Related issues:\n-- - https://github.com/haskell/zlib/issues/11\n-- - https://github.com/madler/zlib/issues/94\n--\n-- Quote from zlib manual:\n--\n-- For the current implementation of deflate(), a windowBits value of 8 (a\n-- window size of 256 bytes) is not supported. As a result, a request for 8 will\n-- result in 9 (a 512-byte window). In that case, providing 8 to inflateInit2()\n-- will result in an error when the zlib header with 9 is checked against the\n-- initialization of inflate(). The remedy is to not use 8 with deflateInit2()\n-- with this initialization, or at least in that case use 9 with inflateInit2().\nfixWindowBits :: Int -> Int\nfixWindowBits n\n | n < 9 = 9\n | n > 15 = 15\n | otherwise = n\n\n\n--------------------------------------------------------------------------------\nappTailL :: BL.ByteString\nappTailL = BL.pack [0x00,0x00,0xff,0xff]\n\n\n--------------------------------------------------------------------------------\nmaybeStrip :: BL.ByteString -> BL.ByteString\nmaybeStrip x | appTailL `BL.isSuffixOf` x = BL.take (BL.length x - 4) x\nmaybeStrip x = x\n\n\n--------------------------------------------------------------------------------\nrejectExtensions :: Message -> IO Message\nrejectExtensions (DataMessage rsv1 rsv2 rsv3 _) | rsv1 || rsv2 || rsv3 =\n throwIO $ CloseRequest 1002 \"Protocol Error\"\nrejectExtensions x = return x\n\n\n--------------------------------------------------------------------------------\nmakeMessageDeflater\n :: Maybe PermessageDeflate -> IO (Message -> IO Message)\nmakeMessageDeflater Nothing = return rejectExtensions\nmakeMessageDeflater (Just pmd)\n | serverNoContextTakeover pmd = do\n return $ \\msg -> do\n ptr <- initDeflate pmd\n deflateMessageWith (deflateBody ptr) msg\n | otherwise = do\n ptr <- initDeflate pmd\n return $ \\msg ->\n deflateMessageWith (deflateBody ptr) msg\n where\n ----------------------------------------------------------------------------\n initDeflate :: PermessageDeflate -> IO Zlib.Deflate\n initDeflate PermessageDeflate {..} =\n Zlib.initDeflate\n pdCompressionLevel\n (Zlib.WindowBits (- (fixWindowBits serverMaxWindowBits)))\n\n\n ----------------------------------------------------------------------------\n deflateMessageWith\n :: (BL.ByteString -> IO BL.ByteString)\n -> Message -> IO Message\n deflateMessageWith deflater (DataMessage False False False (Text x _)) = do\n x' <- deflater x\n return (DataMessage True False False (Text x' Nothing))\n deflateMessageWith deflater (DataMessage False False False (Binary x)) = do\n x' <- deflater x\n return (DataMessage True False False (Binary x'))\n deflateMessageWith _ x = return x\n\n\n ----------------------------------------------------------------------------\n deflateBody :: Zlib.Deflate -> BL.ByteString -> IO BL.ByteString\n deflateBody ptr = fmap maybeStrip . go . BL.toChunks\n where\n go [] =\n dePopper (Zlib.flushDeflate ptr)\n go (c : cs) = do\n chunk <- Zlib.feedDeflate ptr c >>= dePopper\n (chunk <>) <$> go cs\n\n\n--------------------------------------------------------------------------------\ndePopper :: Zlib.Popper -> IO BL.ByteString\ndePopper p = p >>= \\res -> case res of\n Zlib.PRDone -> return BL.empty\n Zlib.PRNext c -> BL.chunk c <$> dePopper p\n Zlib.PRError x -> throwIO $ CloseRequest 1002 (BL8.pack (show x))\n\n\n--------------------------------------------------------------------------------\nmakeMessageInflater\n :: SizeLimit -> Maybe PermessageDeflate\n -> IO (Message -> IO Message)\nmakeMessageInflater _ Nothing = return rejectExtensions\nmakeMessageInflater messageLimit (Just pmd)\n | clientNoContextTakeover pmd =\n return $ \\msg -> do\n ptr <- initInflate pmd\n inflateMessageWith (inflateBody ptr) msg\n | otherwise = do\n ptr <- initInflate pmd\n return $ \\msg ->\n inflateMessageWith (inflateBody ptr) msg\n where\n --------------------------------------------------------------------------------\n initInflate :: PermessageDeflate -> IO Zlib.Inflate\n initInflate PermessageDeflate {..} =\n Zlib.initInflate\n (Zlib.WindowBits (- (fixWindowBits clientMaxWindowBits)))\n\n\n ----------------------------------------------------------------------------\n inflateMessageWith\n :: (BL.ByteString -> IO BL.ByteString)\n -> Message -> IO Message\n inflateMessageWith inflater (DataMessage True a b (Text x _)) = do\n x' <- inflater x\n return (DataMessage False a b (Text x' Nothing))\n inflateMessageWith inflater (DataMessage True a b (Binary x)) = do\n x' <- inflater x\n return (DataMessage False a b (Binary x'))\n inflateMessageWith _ x = return x\n\n\n ----------------------------------------------------------------------------\n inflateBody :: Zlib.Inflate -> BL.ByteString -> IO BL.ByteString\n inflateBody ptr =\n go 0 . BL.toChunks . (<> appTailL)\n where\n go :: Int64 -> [B.ByteString] -> IO BL.ByteString\n go size0 [] = do\n chunk <- Zlib.flushInflate ptr\n checkSize (fromIntegral (B.length chunk) + size0)\n return (BL.fromStrict chunk)\n go size0 (c : cs) = do\n chunk <- Zlib.feedInflate ptr c >>= dePopper\n let size1 = size0 + BL.length chunk\n checkSize size1\n (chunk <>) <$> go size1 cs\n\n\n ----------------------------------------------------------------------------\n checkSize :: Int64 -> IO ()\n checkSize size = unless (atMostSizeLimit size messageLimit) $ throwIO $\n ParseException $ \"Message of size \" ++ show size ++ \" exceeded limit\"\n" }, { "path": "src/Network/WebSockets/Extensions/StrictUnicode.hs", "content": "--------------------------------------------------------------------------------\nmodule Network.WebSockets.Extensions.StrictUnicode\n ( strictUnicode\n ) where\n\n\n--------------------------------------------------------------------------------\nimport Control.Exception (throwIO)\nimport qualified Data.ByteString.Lazy as BL\nimport Network.WebSockets.Extensions\nimport Network.WebSockets.Types\n\n\n--------------------------------------------------------------------------------\nstrictUnicode :: Extension\nstrictUnicode = Extension\n { extHeaders = []\n , extParse = \\parseRaw -> return (parseRaw >>= strictParse)\n , extWrite = return\n }\n\n\n--------------------------------------------------------------------------------\nstrictParse :: Maybe Message -> IO (Maybe Message)\nstrictParse Nothing = return Nothing\nstrictParse (Just (DataMessage rsv1 rsv2 rsv3 (Text bl _))) =\n case decodeUtf8Strict bl of\n Left err -> throwIO err\n Right txt ->\n return (Just (DataMessage rsv1 rsv2 rsv3 (Text bl (Just txt))))\nstrictParse (Just msg@(ControlMessage (Close _ bl))) =\n -- If there is a body, the first two bytes of the body MUST be a 2-byte\n -- unsigned integer (in network byte order) representing a status code with\n -- value /code/ defined in Section 7.4. Following the 2-byte integer, the\n -- body MAY contain UTF-8-encoded data with value /reason/, the\n -- interpretation of which is not defined by this specification.\n case decodeUtf8Strict (BL.drop 2 bl) of\n Left err -> throwIO err\n Right _ -> return (Just msg)\nstrictParse (Just msg) = return (Just msg)\n" }, { "path": "src/Network/WebSockets/Extensions.hs", "content": "module Network.WebSockets.Extensions\n ( ExtensionDescription (..)\n , ExtensionDescriptions\n , parseExtensionDescriptions\n\n , NegotiateExtension\n , Extension (..)\n ) where\n\nimport Network.WebSockets.Extensions.Description\nimport Network.WebSockets.Http\nimport Network.WebSockets.Types\n\ntype NegotiateExtension = ExtensionDescriptions -> Either String Extension\n\n-- | An extension is currently allowed to set extra headers and transform the\n-- parse/write functions of 'Connection'.\n--\n-- This type is very likely to change as other extensions are introduced.\ndata Extension = Extension\n { extHeaders :: Headers\n , extParse :: IO (Maybe Message) -> IO (IO (Maybe Message))\n , extWrite :: ([Message] -> IO ()) -> IO ([Message] -> IO ())\n }\n" }, { "path": "src/Network/WebSockets/Http.hs", "content": "--------------------------------------------------------------------------------\n-- | Module dealing with HTTP: request data types, encoding and decoding...\n{-# LANGUAGE DeriveDataTypeable #-}\n{-# LANGUAGE OverloadedStrings #-}\nmodule Network.WebSockets.Http\n ( Headers\n , RequestHead (..)\n , Request (..)\n , ResponseHead (..)\n , Response (..)\n , HandshakeException (..)\n\n , encodeRequestHead\n , encodeRequest\n , decodeRequestHead\n\n , encodeResponseHead\n , encodeResponse\n , decodeResponseHead\n , decodeResponse\n\n , response101\n , response400\n\n , getRequestHeader\n , getResponseHeader\n , getRequestSecWebSocketVersion\n , getRequestSubprotocols\n , getRequestSecWebSocketExtensions\n ) where\n\n\n--------------------------------------------------------------------------------\nimport qualified Data.ByteString.Builder as Builder\nimport qualified Data.ByteString.Builder.Extra as Builder\nimport Control.Applicative (pure, (*>), (<$>),\n (<*), (<*>))\nimport Control.Exception (Exception)\nimport qualified Data.Attoparsec.ByteString as A\nimport Data.ByteString (ByteString)\nimport qualified Data.ByteString as B\nimport Data.ByteString.Char8 ()\nimport qualified Data.ByteString.Char8 as BC\nimport Data.ByteString.Internal (c2w)\nimport qualified Data.CaseInsensitive as CI\nimport Data.Dynamic (Typeable)\nimport Data.Monoid (mappend, mconcat)\nimport qualified Network.WebSockets.Extensions.Description as Extensions\n\n\n--------------------------------------------------------------------------------\n-- | Request headers\ntype Headers = [(CI.CI ByteString, ByteString)]\n\n\n--------------------------------------------------------------------------------\n-- | An HTTP request. The request body is not yet read.\ndata RequestHead = RequestHead\n { requestPath :: !B.ByteString\n , requestHeaders :: Headers\n , requestSecure :: Bool\n } deriving (Show)\n\n\n--------------------------------------------------------------------------------\n-- | A request with a body\ndata Request = Request RequestHead B.ByteString\n deriving (Show)\n\n\n--------------------------------------------------------------------------------\n-- | HTTP response, without body.\ndata ResponseHead = ResponseHead\n { responseCode :: !Int\n , responseMessage :: !B.ByteString\n , responseHeaders :: Headers\n } deriving (Show)\n\n\n--------------------------------------------------------------------------------\n-- | A response including a body\ndata Response = Response ResponseHead B.ByteString\n deriving (Show)\n\n\n--------------------------------------------------------------------------------\n-- | Error in case of failed handshake. Will be thrown as an 'Exception'.\n--\n-- TODO: This should probably be in the Handshake module, and is solely here to\n-- prevent a cyclic dependency.\ndata HandshakeException\n -- | We don't have a match for the protocol requested by the client.\n -- todo: version parameter\n = NotSupported\n -- | The request was somehow invalid (missing headers or wrong security\n -- token)\n | MalformedRequest RequestHead String\n -- | The servers response was somehow invalid (missing headers or wrong\n -- security token)\n | MalformedResponse ResponseHead String\n -- | The request was well-formed, but the library user rejected it.\n -- (e.g. \"unknown path\")\n | RequestRejected RequestHead ResponseHead\n -- | The connection timed out\n | ConnectionTimeout\n -- | for example \"EOF came too early\" (which is actually a parse error)\n -- or for your own errors. (like \"unknown path\"?)\n | OtherHandshakeException String\n deriving (Show, Typeable)\n\n\n--------------------------------------------------------------------------------\ninstance Exception HandshakeException\n\n\n--------------------------------------------------------------------------------\nencodeRequestHead :: RequestHead -> Builder.Builder\nencodeRequestHead (RequestHead path headers _) =\n Builder.byteStringCopy \"GET \" `mappend`\n Builder.byteStringCopy path `mappend`\n Builder.byteStringCopy \" HTTP/1.1\" `mappend`\n Builder.byteString \"\\r\\n\" `mappend`\n mconcat (map header headers) `mappend`\n Builder.byteStringCopy \"\\r\\n\"\n where\n header (k, v) = mconcat $ map Builder.byteStringCopy\n [CI.original k, \": \", v, \"\\r\\n\"]\n\n\n--------------------------------------------------------------------------------\nencodeRequest :: Request -> Builder.Builder\nencodeRequest (Request head' body) =\n encodeRequestHead head' `mappend` Builder.byteStringCopy body\n\n\n--------------------------------------------------------------------------------\n-- | Parse an initial request\ndecodeRequestHead :: Bool -> A.Parser RequestHead\ndecodeRequestHead isSecure = RequestHead\n <$> requestLine\n <*> A.manyTill decodeHeaderLine newline\n <*> pure isSecure\n where\n space = A.word8 (c2w ' ')\n newline = A.string \"\\r\\n\"\n\n requestLine = A.string \"GET\" *> space *> A.takeWhile1 (/= c2w ' ')\n <* space\n <* A.string \"HTTP/1.1\" <* newline\n\n\n--------------------------------------------------------------------------------\n-- | Encode an HTTP upgrade response\nencodeResponseHead :: ResponseHead -> Builder.Builder\nencodeResponseHead (ResponseHead code msg headers) =\n Builder.byteStringCopy \"HTTP/1.1 \" `mappend`\n Builder.stringUtf8 (show code) `mappend`\n Builder.charUtf8 ' ' `mappend`\n Builder.byteString msg `mappend`\n Builder.byteString \"\\r\\n\" `mappend`\n mconcat (map header headers) `mappend`\n Builder.byteStringCopy \"\\r\\n\"\n where\n header (k, v) = mconcat $ map Builder.byteStringCopy\n [CI.original k, \": \", v, \"\\r\\n\"]\n\n\n--------------------------------------------------------------------------------\nencodeResponse :: Response -> Builder.Builder\nencodeResponse (Response head' body) =\n encodeResponseHead head' `mappend` Builder.byteStringCopy body\n\n\n--------------------------------------------------------------------------------\n-- | An upgrade response\nresponse101 :: Headers -> B.ByteString -> Response\nresponse101 headers = Response\n (ResponseHead 101 \"WebSocket Protocol Handshake\"\n ((\"Upgrade\", \"websocket\") : (\"Connection\", \"Upgrade\") : headers))\n\n\n--------------------------------------------------------------------------------\n-- | Bad request\nresponse400 :: Headers -> B.ByteString -> Response\nresponse400 headers = Response (ResponseHead 400 \"Bad Request\" headers)\n\n\n--------------------------------------------------------------------------------\n-- | HTTP response parser\ndecodeResponseHead :: A.Parser ResponseHead\ndecodeResponseHead = ResponseHead\n <$> fmap (read . BC.unpack) code\n <*> message\n <*> A.manyTill decodeHeaderLine newline\n where\n space = A.word8 (c2w ' ')\n newline = A.string \"\\r\\n\"\n\n code = A.string \"HTTP/1.1\" *> space *> A.takeWhile1 digit <* space\n digit = \\x -> x >= c2w '0' && x <= c2w '9'\n message = A.takeWhile (/= c2w '\\r') <* newline\n\n\n--------------------------------------------------------------------------------\ndecodeResponse :: A.Parser Response\ndecodeResponse = Response <$> decodeResponseHead <*> A.takeByteString\n\n\n--------------------------------------------------------------------------------\ngetRequestHeader :: RequestHead\n -> CI.CI ByteString\n -> Either HandshakeException ByteString\ngetRequestHeader rq key = case lookup key (requestHeaders rq) of\n Just t -> Right t\n Nothing -> Left $ MalformedRequest rq $\n \"Header missing: \" ++ BC.unpack (CI.original key)\n\n\n--------------------------------------------------------------------------------\ngetResponseHeader :: ResponseHead\n -> CI.CI ByteString\n -> Either HandshakeException ByteString\ngetResponseHeader rsp key = case lookup key (responseHeaders rsp) of\n Just t -> Right t\n Nothing -> Left $ MalformedResponse rsp $\n \"Header missing: \" ++ BC.unpack (CI.original key)\n\n\n--------------------------------------------------------------------------------\n-- | Get the @Sec-WebSocket-Version@ header\ngetRequestSecWebSocketVersion :: RequestHead -> Maybe B.ByteString\ngetRequestSecWebSocketVersion p =\n lookup \"Sec-WebSocket-Version\" (requestHeaders p)\n\n\n--------------------------------------------------------------------------------\n-- | List of subprotocols specified by the client, in order of preference.\n-- If the client did not specify a list of subprotocols, this will be the\n-- empty list.\ngetRequestSubprotocols :: RequestHead -> [B.ByteString]\ngetRequestSubprotocols rh = maybe [] parse mproto\n where\n mproto = lookup \"Sec-WebSocket-Protocol\" $ requestHeaders rh\n parse = filter (not . B.null) . BC.splitWith (\\o -> o == ',' || o == ' ')\n\n\n--------------------------------------------------------------------------------\n-- | Get the @Sec-WebSocket-Extensions@ header\ngetRequestSecWebSocketExtensions\n :: RequestHead -> Either HandshakeException Extensions.ExtensionDescriptions\ngetRequestSecWebSocketExtensions rq =\n case lookup \"Sec-WebSocket-Extensions\" (requestHeaders rq) of\n Nothing -> Right []\n Just ext -> case Extensions.parseExtensionDescriptions ext of\n Right x -> Right x\n Left err -> Left $ MalformedRequest rq $\n \"Malformed Sec-WebSockets-Extensions: \" ++ err\n\n\n--------------------------------------------------------------------------------\ndecodeHeaderLine :: A.Parser (CI.CI ByteString, ByteString)\ndecodeHeaderLine = (,)\n <$> (CI.mk <$> A.takeWhile1 (/= c2w ':'))\n <* A.word8 (c2w ':')\n <* A.option (c2w ' ') (A.word8 (c2w ' '))\n <*> A.takeWhile (/= c2w '\\r')\n <* A.string \"\\r\\n\"\n" }, { "path": "src/Network/WebSockets/Hybi13/Demultiplex.hs", "content": "--------------------------------------------------------------------------------\n-- | Demultiplexing of frames into messages\n{-# LANGUAGE DeriveDataTypeable #-}\n{-# LANGUAGE OverloadedStrings #-}\nmodule Network.WebSockets.Hybi13.Demultiplex\n ( FrameType (..)\n , Frame (..)\n , DemultiplexState\n , emptyDemultiplexState\n , DemultiplexResult (..)\n , demultiplex\n ) where\n\n\n--------------------------------------------------------------------------------\nimport Data.ByteString.Builder (Builder)\nimport qualified Data.ByteString.Builder as B\nimport Control.Exception (Exception)\nimport Data.Binary.Get (getWord16be, runGet)\nimport qualified Data.ByteString.Lazy as BL\nimport Data.Int (Int64)\nimport Data.Monoid (mappend)\nimport Data.Typeable (Typeable)\nimport Network.WebSockets.Connection.Options\nimport Network.WebSockets.Types\n\n\n--------------------------------------------------------------------------------\n-- | A low-level representation of a WebSocket packet\ndata Frame = Frame\n { frameFin :: !Bool\n , frameRsv1 :: !Bool\n , frameRsv2 :: !Bool\n , frameRsv3 :: !Bool\n , frameType :: !FrameType\n , framePayload :: !BL.ByteString\n } deriving (Eq, Show)\n\n\n--------------------------------------------------------------------------------\n-- | The type of a frame. Not all types are allowed for all protocols.\ndata FrameType\n = ContinuationFrame\n | TextFrame\n | BinaryFrame\n | CloseFrame\n | PingFrame\n | PongFrame\n deriving (Eq, Show)\n\n\n--------------------------------------------------------------------------------\n-- | Thrown if the client sends invalid multiplexed data\ndata DemultiplexException = DemultiplexException\n deriving (Show, Typeable)\n\n\n--------------------------------------------------------------------------------\ninstance Exception DemultiplexException\n\n\n--------------------------------------------------------------------------------\n-- | Internal state used by the demultiplexer\ndata DemultiplexState\n = EmptyDemultiplexState\n | DemultiplexState !Int64 !Builder !(Builder -> Message)\n\n\n--------------------------------------------------------------------------------\nemptyDemultiplexState :: DemultiplexState\nemptyDemultiplexState = EmptyDemultiplexState\n\n\n--------------------------------------------------------------------------------\n-- | Result of demultiplexing\ndata DemultiplexResult\n = DemultiplexSuccess Message\n | DemultiplexError ConnectionException\n | DemultiplexContinue\n\n\n--------------------------------------------------------------------------------\ndemultiplex :: SizeLimit\n -> DemultiplexState\n -> Frame\n -> (DemultiplexResult, DemultiplexState)\n\ndemultiplex _ state (Frame True False False False PingFrame pl)\n | BL.length pl > 125 =\n (DemultiplexError $ CloseRequest 1002 \"Protocol Error\", emptyDemultiplexState)\n | otherwise =\n (DemultiplexSuccess $ ControlMessage (Ping pl), state)\n\ndemultiplex _ state (Frame True False False False PongFrame pl) =\n (DemultiplexSuccess (ControlMessage (Pong pl)), state)\n\ndemultiplex _ _ (Frame True False False False CloseFrame pl) =\n (DemultiplexSuccess (ControlMessage (uncurry Close parsedClose)), emptyDemultiplexState)\n where\n -- The Close frame MAY contain a body (the \"Application data\" portion of the\n -- frame) that indicates a reason for closing, such as an endpoint shutting\n -- down, an endpoint having received a frame too large, or an endpoint\n -- having received a frame that does not conform to the format expected by\n -- the endpoint. If there is a body, the first two bytes of the body MUST\n -- be a 2-byte unsigned integer (in network byte order) representing a\n -- status code with value /code/ defined in Section 7.4.\n parsedClose\n | BL.length pl >= 2 = case runGet getWord16be pl of\n a | a < 1000 || a `elem` [1004,1005,1006\n ,1014,1015,1016\n ,1100,2000,2999\n ,5000,65535] -> (1002, BL.empty)\n a -> (a, BL.drop 2 pl)\n | BL.length pl == 1 = (1002, BL.empty)\n | otherwise = (1000, BL.empty)\n\ndemultiplex sizeLimit EmptyDemultiplexState (Frame fin rsv1 rsv2 rsv3 tp pl) = case tp of\n _ | not (atMostSizeLimit size sizeLimit) ->\n ( DemultiplexError $ ParseException $\n \"Message of size \" ++ show size ++ \" exceeded limit\"\n , emptyDemultiplexState\n )\n\n TextFrame\n | fin ->\n (DemultiplexSuccess (text pl), emptyDemultiplexState)\n | otherwise ->\n (DemultiplexContinue, DemultiplexState size plb (text . B.toLazyByteString))\n\n\n BinaryFrame\n | fin -> (DemultiplexSuccess (binary pl), emptyDemultiplexState)\n | otherwise -> (DemultiplexContinue, DemultiplexState size plb (binary . B.toLazyByteString))\n\n _ -> (DemultiplexError $ CloseRequest 1002 \"Protocol Error\", emptyDemultiplexState)\n\n where\n size = BL.length pl\n plb = B.lazyByteString pl\n text x = DataMessage rsv1 rsv2 rsv3 (Text x Nothing)\n binary x = DataMessage rsv1 rsv2 rsv3 (Binary x)\n\ndemultiplex sizeLimit (DemultiplexState size0 b f) (Frame fin False False False ContinuationFrame pl)\n | not (atMostSizeLimit size1 sizeLimit) =\n ( DemultiplexError $ ParseException $\n \"Message of size \" ++ show size1 ++ \" exceeded limit\"\n , emptyDemultiplexState\n )\n | fin = (DemultiplexSuccess (f b'), emptyDemultiplexState)\n | otherwise = (DemultiplexContinue, DemultiplexState size1 b' f)\n where\n size1 = size0 + BL.length pl\n b' = b `mappend` plb\n plb = B.lazyByteString pl\n\ndemultiplex _ _ _ =\n (DemultiplexError (CloseRequest 1002 \"Protocol Error\"), emptyDemultiplexState)\n" }, { "path": "src/Network/WebSockets/Hybi13/Mask.hs", "content": "--------------------------------------------------------------------------------\n-- | Masking of fragmes using a simple XOR algorithm\n{-# LANGUAGE BangPatterns #-}\n{-# LANGUAGE ForeignFunctionInterface #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE ScopedTypeVariables #-}\nmodule Network.WebSockets.Hybi13.Mask\n ( Mask\n , parseMask\n , encodeMask\n , randomMask\n\n , maskPayload\n ) where\n\n\n--------------------------------------------------------------------------------\nimport qualified Data.ByteString.Builder as Builder\nimport qualified Data.ByteString.Builder.Extra as Builder\nimport Data.Binary.Get (Get, getWord32host)\nimport qualified Data.ByteString.Internal as B\nimport qualified Data.ByteString.Lazy as BL\nimport qualified Data.ByteString.Lazy.Internal as BL\nimport Data.Word (Word32, Word8)\nimport Foreign.C.Types (CChar (..), CInt (..),\n CSize (..))\nimport Foreign.ForeignPtr (withForeignPtr)\nimport Foreign.Ptr (Ptr, plusPtr)\nimport System.Random (RandomGen, random)\n\n\n--------------------------------------------------------------------------------\nforeign import ccall unsafe \"_hs_mask_chunk\" c_mask_chunk\n :: Word32 -> CInt -> Ptr CChar -> CSize -> Ptr Word8 -> IO ()\n\n\n--------------------------------------------------------------------------------\n-- | A mask is sequence of 4 bytes. We store this in a 'Word32' in the host's\n-- native byte ordering.\nnewtype Mask = Mask {unMask :: Word32}\n\n\n--------------------------------------------------------------------------------\n-- | Parse a mask.\nparseMask :: Get Mask\nparseMask = fmap Mask getWord32host\n\n\n--------------------------------------------------------------------------------\n-- | Encode a mask\nencodeMask :: Mask -> Builder.Builder\nencodeMask = Builder.word32Host . unMask\n\n\n--------------------------------------------------------------------------------\n-- | Create a random mask\nrandomMask :: forall g. RandomGen g => g -> (Mask, g)\nrandomMask gen = (Mask int, gen')\n where\n (!int, !gen') = random gen :: (Word32, g)\n\n\n--------------------------------------------------------------------------------\n-- | Mask a lazy bytestring. Uses 'c_mask_chunk' under the hood.\nmaskPayload :: Maybe Mask -> BL.ByteString -> BL.ByteString\nmaskPayload Nothing = id\nmaskPayload (Just (Mask 0)) = id\nmaskPayload (Just (Mask mask)) = go 0\n where\n go _ BL.Empty = BL.Empty\n go !maskOffset (BL.Chunk (B.PS payload off len) rest) =\n BL.Chunk maskedChunk (go ((maskOffset + len) `rem` 4) rest)\n where\n maskedChunk =\n B.unsafeCreate len $ \\dst ->\n withForeignPtr payload $ \\src ->\n c_mask_chunk mask\n (fromIntegral maskOffset)\n (src `plusPtr` off)\n (fromIntegral len)\n dst\n" }, { "path": "src/Network/WebSockets/Hybi13.hs", "content": "--------------------------------------------------------------------------------\n{-# LANGUAGE BangPatterns #-}\n{-# LANGUAGE OverloadedStrings #-}\nmodule Network.WebSockets.Hybi13\n ( headerVersions\n , finishRequest\n , finishResponse\n , encodeMessage\n , encodeMessages\n , decodeMessages\n , createRequest\n\n -- Internal (used for testing)\n , encodeFrame\n , parseFrame\n ) where\n\n\n--------------------------------------------------------------------------------\nimport qualified Data.ByteString.Builder as B\nimport Control.Applicative (pure, (<$>))\nimport Control.Arrow (first)\nimport Control.Exception (throwIO)\nimport Control.Monad (forM, liftM, unless,\n when)\nimport Data.Binary.Get (Get, getInt64be,\n getLazyByteString,\n getWord16be, getWord8)\nimport Data.Binary.Put (putWord16be, runPut)\nimport Data.Bits ((.&.), (.|.))\nimport Data.ByteString (ByteString)\nimport qualified Data.ByteString.Base64 as B64\nimport Data.ByteString.Char8 ()\nimport qualified Data.ByteString.Lazy as BL\nimport Data.Digest.Pure.SHA (bytestringDigest, sha1)\nimport Data.IORef\nimport Data.Monoid (mappend, mconcat,\n mempty)\nimport Data.Tuple (swap)\nimport System.Entropy as R\nimport System.Random (RandomGen, newStdGen)\n\n\n--------------------------------------------------------------------------------\nimport Network.WebSockets.Connection.Options\nimport Network.WebSockets.Http\nimport Network.WebSockets.Hybi13.Demultiplex\nimport Network.WebSockets.Hybi13.Mask\nimport Network.WebSockets.Stream (Stream)\nimport qualified Network.WebSockets.Stream as Stream\nimport Network.WebSockets.Types\n\n\n--------------------------------------------------------------------------------\nheaderVersions :: [ByteString]\nheaderVersions = [\"13\"]\n\n\n--------------------------------------------------------------------------------\nfinishRequest :: RequestHead\n -> Headers\n -> Either HandshakeException Response\nfinishRequest reqHttp headers = do\n !key <- getRequestHeader reqHttp \"Sec-WebSocket-Key\"\n let !hash = hashKey key\n !encoded = B64.encode hash\n return $ response101 ((\"Sec-WebSocket-Accept\", encoded):headers) \"\"\n\n\n--------------------------------------------------------------------------------\nfinishResponse :: RequestHead\n -> ResponseHead\n -> Either HandshakeException Response\nfinishResponse request response = do\n -- Response message should be one of\n --\n -- - WebSocket Protocol Handshake\n -- - Switching Protocols\n --\n -- But we don't check it for now\n when (responseCode response == 400) $ Left $\n RequestRejected request response \n when (responseCode response /= 101) $ Left $\n MalformedResponse response \"Wrong response status or message.\"\n\n key <- getRequestHeader request \"Sec-WebSocket-Key\"\n responseHash <- getResponseHeader response \"Sec-WebSocket-Accept\"\n let challengeHash = B64.encode $ hashKey key\n when (responseHash /= challengeHash) $ Left $\n MalformedResponse response \"Challenge and response hashes do not match.\"\n\n return $ Response response \"\"\n\n\n--------------------------------------------------------------------------------\nencodeMessage :: RandomGen g => ConnectionType -> g -> Message -> (g, B.Builder)\nencodeMessage conType gen msg = (gen', builder)\n where\n mkFrame = Frame True False False False\n (mask, gen') = case conType of\n ServerConnection -> (Nothing, gen)\n ClientConnection -> first Just (randomMask gen)\n builder = encodeFrame mask $ case msg of\n (ControlMessage (Close code pl)) -> mkFrame CloseFrame $\n runPut (putWord16be code) `mappend` pl\n (ControlMessage (Ping pl)) -> mkFrame PingFrame pl\n (ControlMessage (Pong pl)) -> mkFrame PongFrame pl\n (DataMessage rsv1 rsv2 rsv3 (Text pl _)) -> Frame True rsv1 rsv2 rsv3 TextFrame pl\n (DataMessage rsv1 rsv2 rsv3 (Binary pl)) -> Frame True rsv1 rsv2 rsv3 BinaryFrame pl\n\n\n--------------------------------------------------------------------------------\nencodeMessages\n :: ConnectionType\n -> Stream\n -> IO ([Message] -> IO ())\nencodeMessages conType stream = do\n genRef <- newIORef =<< newStdGen\n return $ \\msgs -> do\n builders <- forM msgs $ \\msg ->\n atomicModifyIORef' genRef $ \\s -> encodeMessage conType s msg\n Stream.write stream (B.toLazyByteString $ mconcat builders)\n\n\n--------------------------------------------------------------------------------\nencodeFrame :: Maybe Mask -> Frame -> B.Builder\nencodeFrame mask f = B.word8 byte0 `mappend`\n B.word8 byte1 `mappend` len `mappend` maskbytes `mappend`\n B.lazyByteString (maskPayload mask payload)\n where\n\n byte0 = fin .|. rsv1 .|. rsv2 .|. rsv3 .|. opcode\n fin = if frameFin f then 0x80 else 0x00\n rsv1 = if frameRsv1 f then 0x40 else 0x00\n rsv2 = if frameRsv2 f then 0x20 else 0x00\n rsv3 = if frameRsv3 f then 0x10 else 0x00\n payload = case frameType f of\n ContinuationFrame -> framePayload f\n TextFrame -> framePayload f\n BinaryFrame -> framePayload f\n CloseFrame -> BL.take 125 $ framePayload f\n PingFrame -> BL.take 125 $ framePayload f\n PongFrame -> BL.take 125 $ framePayload f\n opcode = case frameType f of\n ContinuationFrame -> 0x00\n TextFrame -> 0x01\n BinaryFrame -> 0x02\n CloseFrame -> 0x08\n PingFrame -> 0x09\n PongFrame -> 0x0a\n (maskflag, maskbytes) = case mask of\n Nothing -> (0x00, mempty)\n Just m -> (0x80, encodeMask m)\n\n byte1 = maskflag .|. lenflag\n len' = BL.length payload\n (lenflag, len)\n | len' < 126 = (fromIntegral len', mempty)\n | len' < 0x10000 = (126, B.word16BE (fromIntegral len'))\n | otherwise = (127, B.word64BE (fromIntegral len'))\n\n\n--------------------------------------------------------------------------------\ndecodeMessages\n :: SizeLimit\n -> SizeLimit\n -> Stream\n -> IO (IO (Maybe Message))\ndecodeMessages frameLimit messageLimit stream = do\n dmRef <- newIORef emptyDemultiplexState\n return $ go dmRef\n where\n go dmRef = do\n mbFrame <- Stream.parseBin stream (parseFrame frameLimit)\n case mbFrame of\n Nothing -> return Nothing\n Just frame -> do\n demultiplexResult <- atomicModifyIORef' dmRef $\n \\s -> swap $ demultiplex messageLimit s frame\n case demultiplexResult of\n DemultiplexError err -> throwIO err\n DemultiplexContinue -> go dmRef\n DemultiplexSuccess msg -> return (Just msg)\n\n\n--------------------------------------------------------------------------------\n-- | Parse a frame\nparseFrame :: SizeLimit -> Get Frame\nparseFrame frameSizeLimit = do\n byte0 <- getWord8\n let fin = byte0 .&. 0x80 == 0x80\n rsv1 = byte0 .&. 0x40 == 0x40\n rsv2 = byte0 .&. 0x20 == 0x20\n rsv3 = byte0 .&. 0x10 == 0x10\n opcode = byte0 .&. 0x0f\n\n byte1 <- getWord8\n let mask = byte1 .&. 0x80 == 0x80\n lenflag = byte1 .&. 0x7f\n\n len <- case lenflag of\n 126 -> fromIntegral <$> getWord16be\n 127 -> getInt64be\n _ -> return (fromIntegral lenflag)\n\n -- Check size against limit.\n unless (atMostSizeLimit len frameSizeLimit) $\n fail $ \"Frame of size \" ++ show len ++ \" exceeded limit\"\n\n ft <- case opcode of\n 0x00 -> return ContinuationFrame\n 0x01 -> return TextFrame\n 0x02 -> return BinaryFrame\n 0x08 -> enforceControlFrameRestrictions len fin >> return CloseFrame\n 0x09 -> enforceControlFrameRestrictions len fin >> return PingFrame\n 0x0a -> enforceControlFrameRestrictions len fin >> return PongFrame\n _ -> fail $ \"Unknown opcode: \" ++ show opcode\n\n masker <- maskPayload <$> if mask then Just <$> parseMask else pure Nothing\n\n chunks <- getLazyByteString len\n\n return $ Frame fin rsv1 rsv2 rsv3 ft (masker chunks)\n\n where\n enforceControlFrameRestrictions len fin\n | not fin = fail \"Control Frames must not be fragmented!\"\n | len > 125 = fail \"Control Frames must not carry payload > 125 bytes!\"\n | otherwise = pure ()\n\n--------------------------------------------------------------------------------\nhashKey :: ByteString -> ByteString\nhashKey key = unlazy $ bytestringDigest $ sha1 $ lazy $ key `mappend` guid\n where\n guid = \"258EAFA5-E914-47DA-95CA-C5AB0DC85B11\"\n lazy = BL.fromChunks . return\n unlazy = mconcat . BL.toChunks\n\n\n--------------------------------------------------------------------------------\ncreateRequest :: ByteString\n -> ByteString\n -> Bool\n -> Headers\n -> IO RequestHead\ncreateRequest hostname path secure customHeaders = do\n key <- B64.encode `liftM` getEntropy 16\n return $ RequestHead path (headers key ++ customHeaders) secure\n where\n headers key =\n [ (\"Host\" , hostname )\n , (\"Connection\" , \"Upgrade\" )\n , (\"Upgrade\" , \"websocket\" )\n , (\"Sec-WebSocket-Key\" , key )\n , (\"Sec-WebSocket-Version\" , versionNumber)\n ]\n\n versionNumber = head headerVersions\n" }, { "path": "src/Network/WebSockets/Protocol.hs", "content": "--------------------------------------------------------------------------------\n-- | Wrapper for supporting multiple protocol versions\n{-# LANGUAGE ExistentialQuantification #-}\nmodule Network.WebSockets.Protocol\n ( Protocol (..)\n , defaultProtocol\n , protocols\n , compatible\n , headerVersions\n , finishRequest\n , finishResponse\n , encodeMessages\n , decodeMessages\n , createRequest\n ) where\n\n\n--------------------------------------------------------------------------------\nimport Data.ByteString (ByteString)\nimport qualified Data.ByteString as B\n\n\n--------------------------------------------------------------------------------\nimport Network.WebSockets.Connection.Options\nimport Network.WebSockets.Http\nimport qualified Network.WebSockets.Hybi13 as Hybi13\nimport Network.WebSockets.Stream (Stream)\nimport Network.WebSockets.Types\n\n\n--------------------------------------------------------------------------------\ndata Protocol\n = Hybi13\n deriving (Show)\n\n\n--------------------------------------------------------------------------------\ndefaultProtocol :: Protocol\ndefaultProtocol = Hybi13\n\n\n--------------------------------------------------------------------------------\nprotocols :: [Protocol]\nprotocols = [Hybi13]\n\n\n--------------------------------------------------------------------------------\nheaderVersions :: Protocol -> [ByteString]\nheaderVersions Hybi13 = Hybi13.headerVersions\n\n\n--------------------------------------------------------------------------------\ncompatible :: Protocol -> RequestHead -> Bool\ncompatible protocol req = case getRequestSecWebSocketVersion req of\n Just v -> v `elem` headerVersions protocol\n _ -> True -- Whatever?\n\n\n--------------------------------------------------------------------------------\nfinishRequest\n :: Protocol -> RequestHead -> Headers -> Either HandshakeException Response\nfinishRequest Hybi13 = Hybi13.finishRequest\n\n\n--------------------------------------------------------------------------------\nfinishResponse\n :: Protocol -> RequestHead -> ResponseHead\n -> Either HandshakeException Response\nfinishResponse Hybi13 = Hybi13.finishResponse\n\n\n--------------------------------------------------------------------------------\nencodeMessages\n :: Protocol -> ConnectionType -> Stream\n -> IO ([Message] -> IO ())\nencodeMessages Hybi13 = Hybi13.encodeMessages\n\n\n--------------------------------------------------------------------------------\ndecodeMessages\n :: Protocol -> SizeLimit -> SizeLimit -> Stream\n -> IO (IO (Maybe Message))\ndecodeMessages Hybi13 frameLimit messageLimit =\n Hybi13.decodeMessages frameLimit messageLimit\n\n\n--------------------------------------------------------------------------------\ncreateRequest\n :: Protocol -> B.ByteString -> B.ByteString -> Bool -> Headers\n -> IO RequestHead\ncreateRequest Hybi13 = Hybi13.createRequest\n" }, { "path": "src/Network/WebSockets/Server.hs", "content": "--------------------------------------------------------------------------------\n-- | This provides a simple stand-alone server for 'WebSockets' applications.\n-- Note that in production you want to use a real webserver such as snap or\n-- warp.\n{-# LANGUAGE OverloadedStrings #-}\nmodule Network.WebSockets.Server\n ( ServerApp\n , runServer\n , ServerOptions (..)\n , defaultServerOptions\n , runServerWithOptions\n , runServerWith\n , makeListenSocket\n , makePendingConnection\n , makePendingConnectionFromStream\n\n , PongTimeout\n ) where\n\n\n--------------------------------------------------------------------------------\nimport Control.Concurrent (forkIOWithUnmask,\n myThreadId,\n killThread\n )\nimport Control.Exception (bracket,\n bracketOnError, finally, mask_,\n throwIO)\nimport Control.Monad (forever, forM_)\nimport Data.IORef (newIORef,\n readIORef,\n modifyIORef'\n )\nimport qualified Data.Set as Set\nimport Network.Socket (Socket)\nimport qualified Network.Socket as S\n\n--------------------------------------------------------------------------------\nimport Network.WebSockets.Connection\nimport Network.WebSockets.Connection.PingPong (PongTimeout(..))\nimport Network.WebSockets.Http\nimport qualified Network.WebSockets.Stream as Stream\nimport Network.WebSockets.Types\n\n\n--------------------------------------------------------------------------------\n-- | WebSockets application that can be ran by a server. Once this 'IO' action\n-- finishes, the underlying socket is closed automatically.\ntype ServerApp = PendingConnection -> IO ()\n\n\n--------------------------------------------------------------------------------\n-- | Provides a simple server. This function blocks forever. Note that this\n-- is merely provided for quick-and-dirty or internal applications, but for real\n-- applications, you should use a real server.\n--\n-- For example:\n--\n-- * Performance is reasonable under load, but:\n-- * No protection against DoS attacks is provided.\n-- * No logging is performed.\n-- * ...\n--\n-- Glue for using this package with real servers is provided by:\n--\n-- * \n--\n-- * \nrunServer :: String -- ^ Address to bind\n -> Int -- ^ Port to listen on\n -> ServerApp -- ^ Application\n -> IO () -- ^ Never returns\nrunServer host port app = runServerWith host port defaultConnectionOptions app\n\n\n--------------------------------------------------------------------------------\n-- | A version of 'runServer' which allows you to customize some options.\nrunServerWith :: String -> Int -> ConnectionOptions -> ServerApp -> IO ()\nrunServerWith host port opts = runServerWithOptions defaultServerOptions\n { serverHost = host\n , serverPort = port\n , serverConnectionOptions = opts\n }\n{-# DEPRECATED runServerWith \"Use 'runServerWithOptions' instead\" #-}\n\n\n--------------------------------------------------------------------------------\ndata ServerOptions = ServerOptions\n { serverHost :: String\n , serverPort :: Int\n , serverConnectionOptions :: ConnectionOptions\n }\n\n\n--------------------------------------------------------------------------------\ndefaultServerOptions :: ServerOptions\ndefaultServerOptions = ServerOptions\n { serverHost = \"127.0.0.1\"\n , serverPort = 8080\n , serverConnectionOptions = defaultConnectionOptions\n }\n\n\n--------------------------------------------------------------------------------\n-- | Customizable version of 'runServer'. Never returns until killed.\n--\n-- Please use the 'defaultServerOptions' combined with record updates to set the\n-- fields you want. This way your code is unlikely to break on future changes.\nrunServerWithOptions :: ServerOptions -> ServerApp -> IO a\nrunServerWithOptions opts app = S.withSocketsDo $ do\n appThreads <- newIORef Set.empty\n\n let killAllApps :: IO ()\n killAllApps = do\n apps <- readIORef appThreads\n forM_ apps $ killThread\n\n bracket\n (makeListenSocket (serverHost opts) (serverPort opts))\n (\\sock -> killAllApps >> S.close sock)\n (\\sock -> do\n let mainThread :: IO a\n mainThread = forever $ do\n (conn, _) <- S.accept sock\n\n let cleanupApp = do\n S.close conn\n me <- myThreadId\n modifyIORef' appThreads $ Set.delete me\n\n appThread <- forkIOWithUnmask\n (\\unmask -> unmask (runApp conn (serverConnectionOptions opts) app) `finally` cleanupApp)\n\n modifyIORef' appThreads $ Set.insert appThread\n\n mask_ mainThread\n )\n\n\n--------------------------------------------------------------------------------\n-- | Create a standardized socket on which you can listen for incomming\n-- connections. Should only be used for a quick and dirty solution! Should be\n-- preceded by the call 'Network.Socket.withSocketsDo'.\nmakeListenSocket :: String -> Int -> IO Socket\nmakeListenSocket host port = do\n addr:_ <- S.getAddrInfo (Just hints) (Just host) (Just (show port))\n bracketOnError\n (S.socket (S.addrFamily addr) S.Stream S.defaultProtocol)\n S.close\n (\\sock -> do\n _ <- S.setSocketOption sock S.ReuseAddr 1\n _ <- S.setSocketOption sock S.NoDelay 1\n S.bind sock (S.addrAddress addr)\n S.listen sock 5\n return sock\n )\n where\n hints = S.defaultHints { S.addrSocketType = S.Stream }\n\n\n--------------------------------------------------------------------------------\nrunApp :: Socket\n -> ConnectionOptions\n -> ServerApp\n -> IO ()\nrunApp socket opts app =\n bracket\n (makePendingConnection socket opts)\n (Stream.close . pendingStream)\n app\n\n\n--------------------------------------------------------------------------------\n-- | Turns a socket, connected to some client, into a 'PendingConnection'. The\n-- 'PendingConnection' should be closed using 'pendingStream' and 'Stream.close' later.\nmakePendingConnection\n :: Socket -> ConnectionOptions -> IO PendingConnection\nmakePendingConnection socket opts = do\n stream <- Stream.makeSocketStream socket\n makePendingConnectionFromStream stream opts\n\n\n-- | More general version of 'makePendingConnection' for 'Stream.Stream'\n-- instead of a 'Socket'.\nmakePendingConnectionFromStream\n :: Stream.Stream -> ConnectionOptions -> IO PendingConnection\nmakePendingConnectionFromStream stream opts = do\n -- TODO: we probably want to send a 40x if the request is bad?\n mbRequest <- Stream.parse stream (decodeRequestHead False)\n case mbRequest of\n Nothing -> throwIO ConnectionClosed\n Just request -> return PendingConnection\n { pendingOptions = opts\n , pendingRequest = request\n , pendingOnAccept = \\_ -> return ()\n , pendingStream = stream\n }\n" }, { "path": "src/Network/WebSockets/Stream.hs", "content": "--------------------------------------------------------------------------------\n-- | Lightweight abstraction over an input/output stream.\n{-# LANGUAGE CPP #-}\nmodule Network.WebSockets.Stream\n ( Stream\n , makeStream\n , makeSocketStream\n , makeEchoStream\n , parse\n , parseBin\n , write\n , close\n ) where\n\nimport Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar,\n putMVar, takeMVar, withMVar)\nimport Control.Exception (SomeException, SomeAsyncException, throwIO, catch, try, fromException)\nimport Control.Monad (forM_)\nimport qualified Data.Attoparsec.ByteString as Atto\nimport qualified Data.Binary.Get as BIN\nimport qualified Data.ByteString as B\nimport qualified Data.ByteString.Lazy as BL\nimport Data.IORef (IORef, atomicModifyIORef',\n newIORef, readIORef,\n writeIORef)\nimport qualified Network.Socket as S\nimport qualified Network.Socket.ByteString as SB (recv)\n\n#if !defined(mingw32_HOST_OS)\nimport qualified Network.Socket.ByteString.Lazy as SBL (sendAll)\n#else\nimport qualified Network.Socket.ByteString as SB (sendAll)\n#endif\nimport System.IO.Error (isResourceVanishedError)\n\nimport Network.WebSockets.Types\n\n\n--------------------------------------------------------------------------------\n-- | State of the stream\ndata StreamState\n = Closed !B.ByteString -- Remainder\n | Open !B.ByteString -- Buffer\n\n\n--------------------------------------------------------------------------------\n-- | Lightweight abstraction over an input/output stream.\ndata Stream = Stream\n { streamIn :: IO (Maybe B.ByteString)\n , streamOut :: (Maybe BL.ByteString -> IO ())\n , streamState :: !(IORef StreamState)\n }\n\n\n--------------------------------------------------------------------------------\n-- | Create a stream from a \"receive\" and \"send\" action. The following\n-- properties apply:\n--\n-- - Regardless of the provided \"receive\" and \"send\" functions, reading and\n-- writing from the stream will be thread-safe, i.e. this function will create\n-- a receive and write lock to be used internally.\n--\n-- - Reading from or writing to a closed 'Stream' will always throw an\n-- exception, even if the underlying \"receive\" and \"send\" functions do not\n-- (we do the bookkeeping).\n--\n-- - Streams should always be closed.\nmakeStream\n :: IO (Maybe B.ByteString) -- ^ Reading\n -> (Maybe BL.ByteString -> IO ()) -- ^ Writing\n -> IO Stream -- ^ Resulting stream\nmakeStream receive send = do\n ref <- newIORef (Open B.empty)\n receiveLock <- newMVar ()\n sendLock <- newMVar ()\n return $ Stream (receive' ref receiveLock) (send' ref sendLock) ref\n where\n closeRef :: IORef StreamState -> IO ()\n closeRef ref = atomicModifyIORef' ref $ \\state -> case state of\n Open buf -> (Closed buf, ())\n Closed buf -> (Closed buf, ())\n\n -- Throw a 'ConnectionClosed' is the connection is not 'Open'.\n assertOpen :: IORef StreamState -> IO ()\n assertOpen ref = do\n state <- readIORef ref\n case state of\n Closed _ -> throwIO ConnectionClosed\n Open _ -> return ()\n\n receive' :: IORef StreamState -> MVar () -> IO (Maybe B.ByteString)\n receive' ref lock = withMVar lock $ \\() -> do\n assertOpen ref\n mbBs <- onSyncException receive (closeRef ref)\n case mbBs of\n Nothing -> closeRef ref >> return Nothing\n Just bs -> return (Just bs)\n\n send' :: IORef StreamState -> MVar () -> (Maybe BL.ByteString -> IO ())\n send' ref lock mbBs = withMVar lock $ \\() -> do\n case mbBs of\n Nothing -> closeRef ref\n Just _ -> assertOpen ref\n onSyncException (send mbBs) (closeRef ref)\n\n onSyncException :: IO a -> IO b -> IO a\n onSyncException io what =\n catch io $ \\e -> do\n case fromException (e :: SomeException) :: Maybe SomeAsyncException of\n Just _ -> pure ()\n Nothing -> what *> pure ()\n throwIO e\n\n\n--------------------------------------------------------------------------------\nmakeSocketStream :: S.Socket -> IO Stream\nmakeSocketStream socket = makeStream receive send\n where\n receive = do\n bs <- try $ SB.recv socket 8192\n case bs of\n -- If the resource vanished, the socket was closed\n Left e | isResourceVanishedError e -> return Nothing\n | otherwise -> throwIO e\n Right bs' | B.null bs' -> return Nothing\n | otherwise -> return $ Just bs'\n\n send Nothing = return ()\n send (Just bs) = do\n#if !defined(mingw32_HOST_OS)\n SBL.sendAll socket bs\n#else\n forM_ (BL.toChunks bs) (SB.sendAll socket)\n#endif\n\n\n--------------------------------------------------------------------------------\nmakeEchoStream :: IO Stream\nmakeEchoStream = do\n mvar <- newEmptyMVar\n makeStream (takeMVar mvar) $ \\mbBs -> case mbBs of\n Nothing -> putMVar mvar Nothing\n Just bs -> forM_ (BL.toChunks bs) $ \\c -> putMVar mvar (Just c)\n\n\n--------------------------------------------------------------------------------\nparseBin :: Stream -> BIN.Get a -> IO (Maybe a)\nparseBin stream parser = do\n state <- readIORef (streamState stream)\n case state of\n Closed remainder\n | B.null remainder -> return Nothing\n | otherwise -> go (BIN.runGetIncremental parser `BIN.pushChunk` remainder) True\n Open buffer\n | B.null buffer -> do\n mbBs <- streamIn stream\n case mbBs of\n Nothing -> do\n writeIORef (streamState stream) (Closed B.empty)\n return Nothing\n Just bs -> go (BIN.runGetIncremental parser `BIN.pushChunk` bs) False\n | otherwise -> go (BIN.runGetIncremental parser `BIN.pushChunk` buffer) False\n where\n -- Buffer is empty when entering this function.\n go (BIN.Done remainder _ x) closed = do\n writeIORef (streamState stream) $\n if closed then Closed remainder else Open remainder\n return (Just x)\n go (BIN.Partial f) closed\n | closed = go (f Nothing) True\n | otherwise = do\n mbBs <- streamIn stream\n case mbBs of\n Nothing -> go (f Nothing) True\n Just bs -> go (f (Just bs)) False\n go (BIN.Fail _ _ err) _ = throwIO (ParseException err)\n\n\nparse :: Stream -> Atto.Parser a -> IO (Maybe a)\nparse stream parser = do\n state <- readIORef (streamState stream)\n case state of\n Closed remainder\n | B.null remainder -> return Nothing\n | otherwise -> go (Atto.parse parser remainder) True\n Open buffer\n | B.null buffer -> do\n mbBs <- streamIn stream\n case mbBs of\n Nothing -> do\n writeIORef (streamState stream) (Closed B.empty)\n return Nothing\n Just bs -> go (Atto.parse parser bs) False\n | otherwise -> go (Atto.parse parser buffer) False\n where\n -- Buffer is empty when entering this function.\n go (Atto.Done remainder x) closed = do\n writeIORef (streamState stream) $\n if closed then Closed remainder else Open remainder\n return (Just x)\n go (Atto.Partial f) closed\n | closed = go (f B.empty) True\n | otherwise = do\n mbBs <- streamIn stream\n case mbBs of\n Nothing -> go (f B.empty) True\n Just bs -> go (f bs) False\n go (Atto.Fail _ _ err) _ = throwIO (ParseException err)\n\n\n--------------------------------------------------------------------------------\nwrite :: Stream -> BL.ByteString -> IO ()\nwrite stream = streamOut stream . Just\n\n\n--------------------------------------------------------------------------------\nclose :: Stream -> IO ()\nclose stream = streamOut stream Nothing\n" }, { "path": "src/Network/WebSockets/Types.hs", "content": "--------------------------------------------------------------------------------\n-- | Primary types\n{-# LANGUAGE DeriveDataTypeable #-}\nmodule Network.WebSockets.Types\n ( Message (..)\n , ControlMessage (..)\n , DataMessage (..)\n , WebSocketsData (..)\n\n , HandshakeException (..)\n , ConnectionException (..)\n\n , ConnectionType (..)\n\n , decodeUtf8Lenient\n , decodeUtf8Strict\n ) where\n\n\n--------------------------------------------------------------------------------\nimport Control.Exception (Exception (..))\nimport Control.Exception (throw, try)\nimport qualified Data.ByteString as B\nimport qualified Data.ByteString.Lazy as BL\nimport qualified Data.Text as T\nimport qualified Data.Text.Encoding.Error as TL\nimport qualified Data.Text.Lazy as TL\nimport qualified Data.Text.Lazy.Encoding as TL\nimport Data.Typeable (Typeable)\nimport Data.Word (Word16)\nimport System.IO.Unsafe (unsafePerformIO)\n\n\n--------------------------------------------------------------------------------\nimport Network.WebSockets.Http\n\n\n--------------------------------------------------------------------------------\n-- | The kind of message a server application typically deals with\ndata Message\n = ControlMessage ControlMessage\n -- | Reserved bits, actual message\n | DataMessage Bool Bool Bool DataMessage\n deriving (Eq, Show)\n\n\n--------------------------------------------------------------------------------\n-- | Different control messages\ndata ControlMessage\n = Close Word16 BL.ByteString\n | Ping BL.ByteString\n | Pong BL.ByteString\n deriving (Eq, Show)\n\n\n--------------------------------------------------------------------------------\n-- | For an end-user of this library, dealing with 'Frame's would be a bit\n-- low-level. This is why define another type on top of it, which represents\n-- data for the application layer.\n--\n-- There are currently two kinds of data messages supported by the WebSockets\n-- protocol:\n--\n-- * Textual UTF-8 encoded data. This corresponds roughly to sending a String\n-- in JavaScript.\n--\n-- * Binary data. This corresponds roughly to send an ArrayBuffer in\n-- JavaScript.\ndata DataMessage\n -- | A textual message. The second field /might/ contain the decoded UTF-8\n -- text for caching reasons. This field is computed lazily so if it's not\n -- accessed, it should have no performance impact.\n = Text BL.ByteString (Maybe TL.Text)\n -- | A binary message.\n | Binary BL.ByteString\n deriving (Eq, Show)\n\n\n--------------------------------------------------------------------------------\n-- | In order to have an even more high-level API, we define a typeclass for\n-- values the user can receive from and send to the socket. A few warnings\n-- apply:\n--\n-- * Natively, everything is represented as a 'BL.ByteString', so this is the\n-- fastest instance\n--\n-- * You should only use the 'TL.Text' or the 'T.Text' instance when you are\n-- sure that the data is UTF-8 encoded (which is the case for 'Text'\n-- messages).\n--\n-- * Messages can be very large. If this is the case, it might be inefficient to\n-- use the strict 'B.ByteString' and 'T.Text' instances.\nclass WebSocketsData a where\n fromDataMessage :: DataMessage -> a\n\n fromLazyByteString :: BL.ByteString -> a\n toLazyByteString :: a -> BL.ByteString\n\n\n--------------------------------------------------------------------------------\ninstance WebSocketsData BL.ByteString where\n fromDataMessage (Text bl _) = bl\n fromDataMessage (Binary bl) = bl\n\n fromLazyByteString = id\n toLazyByteString = id\n\n\n--------------------------------------------------------------------------------\ninstance WebSocketsData B.ByteString where\n fromDataMessage (Text bl _) = fromLazyByteString bl\n fromDataMessage (Binary bl) = fromLazyByteString bl\n\n fromLazyByteString = B.concat . BL.toChunks\n toLazyByteString = BL.fromChunks . return\n\n\n--------------------------------------------------------------------------------\ninstance WebSocketsData TL.Text where\n fromDataMessage (Text _ (Just tl)) = tl\n fromDataMessage (Text bl Nothing) = fromLazyByteString bl\n fromDataMessage (Binary bl) = fromLazyByteString bl\n\n\n fromLazyByteString = TL.decodeUtf8\n toLazyByteString = TL.encodeUtf8\n\n\n--------------------------------------------------------------------------------\ninstance WebSocketsData T.Text where\n fromDataMessage (Text _ (Just tl)) = T.concat (TL.toChunks tl)\n fromDataMessage (Text bl Nothing) = fromLazyByteString bl\n fromDataMessage (Binary bl) = fromLazyByteString bl\n\n fromLazyByteString = T.concat . TL.toChunks . fromLazyByteString\n toLazyByteString = toLazyByteString . TL.fromChunks . return\n\n\n--------------------------------------------------------------------------------\n-- | Various exceptions that can occur while receiving or transmitting messages\ndata ConnectionException\n -- | The peer has requested that the connection be closed, and included\n -- a close code and a reason for closing. When receiving this exception,\n -- no more messages can be sent. Also, the server is responsible for\n -- closing the TCP connection once this exception is received.\n --\n -- See for a list of close\n -- codes.\n = CloseRequest Word16 BL.ByteString\n\n -- | The peer unexpectedly closed the connection while we were trying to\n -- receive some data. This is a violation of the websocket RFC since the\n -- TCP connection should only be closed after sending and receiving close\n -- control messages.\n | ConnectionClosed\n\n -- | The client sent garbage, i.e. we could not parse the WebSockets stream.\n | ParseException String\n\n -- | The client sent invalid UTF-8. Note that this exception will only be\n -- thrown if strict decoding is set in the connection options.\n | UnicodeException String\n deriving (Eq, Show, Typeable)\n\n\n--------------------------------------------------------------------------------\ninstance Exception ConnectionException\n\n\n--------------------------------------------------------------------------------\ndata ConnectionType = ServerConnection | ClientConnection\n deriving (Eq, Ord, Show)\n\n\n--------------------------------------------------------------------------------\n-- | Replace an invalid input byte with the Unicode replacement character\n-- U+FFFD.\ndecodeUtf8Lenient :: BL.ByteString -> TL.Text\ndecodeUtf8Lenient = TL.decodeUtf8With TL.lenientDecode\n\n\n--------------------------------------------------------------------------------\n-- | Throw an error if there is an invalid input byte.\ndecodeUtf8Strict :: BL.ByteString -> Either ConnectionException TL.Text\ndecodeUtf8Strict bl = unsafePerformIO $ try $\n let txt = TL.decodeUtf8With (\\err _ -> throw (UnicodeException err)) bl in\n TL.length txt `seq` return txt\n" }, { "path": "src/Network/WebSockets/Util/PubSub.hs", "content": "-- | This is a simple utility module to implement a publish-subscribe pattern.\n-- Note that this only allows communication in a single direction: pusing data\n-- from the server to connected clients (browsers).\n--\n-- Usage:\n--\n-- * Create a new 'PubSub' handle using 'newPubSub'\n--\n-- * Subscribe your clients using the 'subscribe' call\n--\n-- * Push new updates from the server using the 'publish' call\n--\n{-# LANGUAGE Rank2Types, ScopedTypeVariables #-}\nmodule Network.WebSockets.Util.PubSub\n ( PubSub\n , newPubSub\n , publish\n , subscribe\n ) where\n\nimport Control.Applicative ((<$>))\nimport Control.Exception (IOException, handle)\nimport Control.Monad (foldM, forever)\nimport Control.Monad.Trans (liftIO)\nimport Data.IntMap (IntMap)\nimport Data.List (foldl')\nimport qualified Control.Concurrent.MVar as MV\n\nimport qualified Data.IntMap as IM\n\nimport Network.WebSockets\n\ndata PubSub_ p = PubSub_\n { pubSubNextId :: Int\n , pubSubSinks :: IntMap (Sink p)\n }\n\naddClient :: Sink p -> PubSub_ p -> (PubSub_ p, Int)\naddClient sink (PubSub_ nid sinks) =\n (PubSub_ (nid + 1) (IM.insert nid sink sinks), nid)\n\nremoveClient :: Int -> PubSub_ p -> PubSub_ p\nremoveClient ref ps = ps {pubSubSinks = IM.delete ref (pubSubSinks ps)}\n\n-- | A handle which keeps track of subscribed clients\nnewtype PubSub p = PubSub (MV.MVar (PubSub_ p))\n\n-- | Create a new 'PubSub' handle, with no clients initally connected\nnewPubSub :: IO (PubSub p)\nnewPubSub = PubSub <$> MV.newMVar PubSub_\n { pubSubNextId = 0\n , pubSubSinks = IM.empty\n }\n\n-- | Broadcast a message to all connected clients\npublish :: PubSub p -> Message p -> IO ()\npublish (PubSub mvar) msg = MV.modifyMVar_ mvar $ \\pubSub -> do\n -- Take care to detect and remove broken clients\n broken <- foldM publish' [] (IM.toList $ pubSubSinks pubSub)\n return $ foldl' (\\p b -> removeClient b p) pubSub broken\n where\n -- Publish the message to a single client, add it to the broken list if an\n -- IOException occurs\n publish' broken (i, s) =\n handle (\\(_ :: IOException) -> return (i : broken)) $ do\n sendSink s msg\n return broken\n\n-- | Blocks forever\nsubscribe :: Protocol p => PubSub p -> WebSockets p ()\nsubscribe (PubSub mvar) = do\n sink <- getSink\n ref <- liftIO $ MV.modifyMVar mvar $ return . addClient sink\n catchWsError loop $ const $ liftIO $\n MV.modifyMVar_ mvar $ return . removeClient ref\n where\n loop = forever $ do\n _ <- receiveDataMessage\n return ()\n" }, { "path": "src/Network/WebSockets.hs", "content": "--------------------------------------------------------------------------------\n{-# LANGUAGE ScopedTypeVariables #-}\nmodule Network.WebSockets\n ( -- * Incoming connections and handshaking\n PendingConnection\n , pendingRequest\n , acceptRequest\n , AcceptRequest(..)\n , defaultAcceptRequest\n , acceptRequestWith\n , rejectRequest\n , RejectRequest(..)\n , defaultRejectRequest\n , rejectRequestWith\n\n -- * Main connection type\n , Connection\n\n -- * Options for connections\n , ConnectionOptions (..)\n , defaultConnectionOptions\n\n -- ** Compression options\n , CompressionOptions (..)\n , PermessageDeflate (..)\n , defaultPermessageDeflate\n\n -- ** Protection limits\n , SizeLimit (..)\n\n -- * Sending and receiving messages\n , receive\n , receiveDataMessage\n , receiveData\n , send\n , sendDataMessage\n , sendDataMessages\n , sendTextData\n , sendTextDatas\n , sendBinaryData\n , sendBinaryDatas\n , sendClose\n , sendCloseCode\n , sendPing\n\n -- * HTTP Types\n , Headers\n , Request (..)\n , RequestHead (..)\n , getRequestSubprotocols\n , Response (..)\n , ResponseHead (..)\n\n -- * WebSocket message types\n , Message (..)\n , ControlMessage (..)\n , DataMessage (..)\n , WebSocketsData (..)\n\n -- * Exceptions\n , HandshakeException (..)\n , ConnectionException (..)\n\n -- * Running a standalone server\n , ServerApp\n , runServer\n , runServerWith\n , ServerOptions (..)\n , defaultServerOptions\n , runServerWithOptions\n\n -- * Utilities for writing your own server\n , makeListenSocket\n , makePendingConnection\n , makePendingConnectionFromStream\n\n -- * Running a client\n , ClientApp\n , runClient\n , runClientWith\n , runClientWithSocket\n , runClientWithStream\n , newClientConnection\n\n -- * Utilities\n , PingPongOptions(..)\n , defaultPingPongOptions\n , withPingPong\n , withPingThread\n , forkPingThread\n ) where\n\n\n--------------------------------------------------------------------------------\nimport Network.WebSockets.Client\nimport Network.WebSockets.Connection\nimport Network.WebSockets.Connection.PingPong\nimport Network.WebSockets.Http\nimport Network.WebSockets.Server\nimport Network.WebSockets.Types\n" }, { "path": "stack.yaml", "content": "resolver: nightly-2023-12-26\nsave-hackage-creds: false\nflags:\n websockets:\n example: true\nextra-deps:\n- 'hakyll-4.15.1.0'\nnix:\n packages:\n - 'zlib'\n" }, { "path": "tests/autobahn/autobahn.sh", "content": "#!/usr/bin/bash\nset -o errexit -o pipefail\n\n# Finding the right python\nAUTOBAHN_PYTHON=\"python2.7\"\n\n# Note that this script will be executed from the project root.\nAUTOBAHN_ENV=\"$HOME/.virtualenvs/autobahn\"\necho \"Setting up virtualenv...\"\nif [[ ! -e \"$AUTOBAHN_ENV\" ]]; then\n virtualenv --python=\"$AUTOBAHN_PYTHON\" \"$AUTOBAHN_ENV\"\n source \"$AUTOBAHN_ENV/bin/activate\"\n pip install 'autobahn>=0.18'\n pip install autobahntestsuite\nelse\n source \"$AUTOBAHN_ENV/bin/activate\"\nfi\n\necho \"Launching websockets server in background...\"\n(cabal run websockets-autobahn -f Example) & WEBSOCKETS_AUTOBAHN_PID=\"$!\"\n\nsleep 10\n\necho \"Getting config...\"\ncp tests/autobahn/fuzzingclient.json .\n\necho \"Running autobahn testsuite...\"\nwstest -m fuzzingclient\n\necho \"Killing websockets server...\"\nkill \"$WEBSOCKETS_AUTOBAHN_PID\"\n\necho \"Producing report...\"\npython tests/autobahn/mini-report.py reports/servers/index.json\n" }, { "path": "tests/autobahn/exclude-cases.py", "content": "# Travis only allows 50-minute jobs so we unfortunately cannot run all test\n# cases. This script selects all the long cases based on a report from a\n# previous test run. These can then be added to the 'exclude-cases' field.\n#\n# There are also some inherently broken cases. See:\n#\n# \n\nimport argparse\nimport json\n\nBROKEN_CASES = [\n '12.4.5',\n '12.4.6',\n '12.4.11',\n '12.4.18',\n '12.4.13',\n '12.4.10',\n '12.4.17',\n '12.4.16',\n '12.4.15',\n '12.4.14',\n '12.4.9',\n '12.4.8',\n '12.5.5',\n '12.5.6',\n '12.5.8',\n '12.5.9',\n '12.5.10',\n '12.5.11',\n '12.5.13',\n '12.5.14',\n '12.5.15',\n '12.5.16',\n '12.5.17',\n '12.5.18'\n]\n\nif __name__ == '__main__':\n parser = argparse.ArgumentParser()\n parser.add_argument('report', help='JSON report', nargs='?')\n parser.add_argument('--duration', type=int, help='Duration treshold',\n default=1000)\n options = parser.parse_args()\n\n exclude_cases = []\n\n # Exclude long tests from report\n if options.report:\n with open(options.report) as f:\n report = json.load(f)\n\n for server in report:\n server_report = report[server]\n for case_name in server_report:\n case_report = server_report[case_name]\n if case_report['duration'] >= options.duration:\n exclude_cases += [case_name]\n\n # Exclude broken tests\n for case_name in BROKEN_CASES:\n if not case_name in exclude_cases:\n exclude_cases += [case_name]\n\n print(json.dumps(exclude_cases))\n" }, { "path": "tests/autobahn/fuzzingclient.json", "content": "{\n \"outdir\": \"./reports/servers\",\n \"servers\": [\n {\n \"url\": \"ws://127.0.0.1:9001\"\n }\n ],\n \"cases\": [\"*\"],\n \"exclude-cases\": [\n \"12.4.5\",\n \"12.4.6\",\n \"12.4.8\",\n \"12.4.9\",\n \"12.4.10\",\n \"12.4.11\",\n \"12.4.13\",\n \"12.4.14\",\n \"12.4.15\",\n \"12.4.16\",\n \"12.4.17\",\n \"12.4.18\"\n ],\n \"exclude-agent-cases\": {}\n}\n" }, { "path": "tests/autobahn/mini-report.py", "content": "# `wstest` doesn't actually set an informational error code so we'll need to do\n# it ourselves.\n\nimport argparse\nimport json\nimport sys\n\nif __name__ == '__main__':\n parser = argparse.ArgumentParser()\n parser.add_argument('report', help='JSON report')\n options = parser.parse_args()\n\n with open(options.report) as f:\n report = json.load(f)\n\n behaviors = {}\n\n for server in report:\n server_report = report[server]\n for case_name in server_report:\n case_report = server_report[case_name]\n behavior = case_report['behavior']\n if behavior in behaviors:\n behaviors[behavior] += [case_name]\n else:\n behaviors[behavior] = [case_name]\n\n if 'FAILED' in behaviors:\n print(' Failed cases:')\n for case_name in behaviors['FAILED']:\n print('- ' + case_name)\n sys.exit(1)\n else:\n print(str(len(behaviors['OK'])) + ' cases passed')\n" }, { "path": "tests/autobahn/server.hs", "content": "--------------------------------------------------------------------------------\n-- | The server part of the tests\n{-# LANGUAGE OverloadedStrings #-}\nmodule Main\n ( main\n ) where\n\n{-\n\n## once\nvirtualenv pyt\nsource pyt/bin/activate\n### pip install --upgrade setuptools ### possibly\npip install autobahntestsuite\n\n## each time\nsource pyt/bin/activate\nmkdir -p test && cd test\nwstest -m fuzzingclient\nwebsockets-autobahn\n-}\n\n\n--------------------------------------------------------------------------------\nimport Control.Exception (catch)\nimport Data.ByteString.Lazy.Char8 ()\nimport Data.String (fromString)\nimport Data.Version (showVersion)\n\n\n--------------------------------------------------------------------------------\nimport qualified Network.WebSockets as WS\nimport qualified Paths_websockets\n\n\n--------------------------------------------------------------------------------\nechoDataMessage :: WS.Connection -> IO ()\nechoDataMessage conn = go 0\n where\n go :: Int -> IO ()\n go x = do\n msg <- WS.receiveDataMessage conn\n WS.sendDataMessage conn msg\n go (x + 1)\n\n\n--------------------------------------------------------------------------------\ninfoHeaders :: WS.Headers\ninfoHeaders =\n [ ( \"Server\"\n , fromString $ \"websockets/\" ++ showVersion Paths_websockets.version\n )\n ]\n\n\n--------------------------------------------------------------------------------\n-- | Application\napplication :: WS.ServerApp\napplication pc = do\n conn <- WS.acceptRequestWith pc WS.defaultAcceptRequest\n { WS.acceptHeaders = infoHeaders\n }\n echoDataMessage conn `catch` handleClose\n\n where\n handleClose (WS.CloseRequest i \"\") =\n putStrLn $ \"Clean close (\" ++ show i ++ \")\"\n handleClose (WS.CloseRequest i msg) =\n putStrLn $ \"Clean close (\" ++ show i ++ \"): \" ++ show msg\n handleClose WS.ConnectionClosed =\n putStrLn \"Unexpected connection closed exception\"\n handleClose (WS.ParseException e) =\n putStrLn $ \"Recevied parse exception: \" ++ show e\n handleClose (WS.UnicodeException e) =\n putStrLn $ \"Recevied unicode exception: \" ++ show e\n\n\n--------------------------------------------------------------------------------\n-- | Accepts clients, spawns a single handler for each one.\nmain :: IO ()\nmain = WS.runServerWithOptions options application\n where\n options = WS.defaultServerOptions\n { WS.serverHost = \"0.0.0.0\"\n , WS.serverPort = 9001\n , WS.serverConnectionOptions = WS.defaultConnectionOptions\n { WS.connectionCompressionOptions =\n WS.PermessageDeflateCompression WS.defaultPermessageDeflate\n , WS.connectionStrictUnicode = True\n }\n }\n" }, { "path": "tests/haskell/Network/WebSockets/Extensions/PermessageDeflate/Tests.hs", "content": "--------------------------------------------------------------------------------\n{-# LANGUAGE OverloadedStrings #-}\nmodule Network.WebSockets.Extensions.PermessageDeflate.Tests\n ( tests\n ) where\n\n\n--------------------------------------------------------------------------------\nimport Control.Exception (try)\nimport qualified Data.ByteString.Lazy as BL\nimport Network.WebSockets.Extensions.PermessageDeflate\nimport Network.WebSockets.Types\nimport Network.WebSockets.Connection.Options\nimport Test.Framework (Test,\n testGroup)\nimport Test.Framework.Providers.HUnit (testCase)\nimport Test.HUnit (Assertion,\n (@?=))\n\n\n--------------------------------------------------------------------------------\ntests :: Test\ntests = testGroup \"Network.WebSockets.Extensions.PermessageDeflate.Tests\"\n [ testCase \"OK 1\" $ do\n inflater <- makeMessageInflater\n (SizeLimit 100) (Just defaultPermessageDeflate)\n message <- inflater $ DataMessage True False False (Binary deflated100)\n message @?=\n DataMessage False False False (Binary inflated100)\n , testCase \"Exceed 1\" $ do\n inflater <- makeMessageInflater\n (SizeLimit 99) (Just defaultPermessageDeflate)\n assertParseException $\n inflater $ DataMessage True False False (Binary deflated100)\n ]\n where\n assertParseException :: IO a -> Assertion\n assertParseException io = do\n errOrX <- try io\n case errOrX of\n Left (ParseException _) -> return ()\n _ -> fail \"Excepted ParseException\"\n\n -- This inflates to 100 bytes.\n deflated100 = \"b`\\160=\\NUL\\NUL\"\n inflated100 = BL.replicate 100 0\n" }, { "path": "tests/haskell/Network/WebSockets/Extensions/Tests.hs", "content": "--------------------------------------------------------------------------------\n{-# LANGUAGE OverloadedStrings #-}\nmodule Network.WebSockets.Extensions.Tests\n ( tests\n ) where\n\n\n--------------------------------------------------------------------------------\nimport Network.WebSockets.Extensions\nimport Test.Framework (Test, testGroup)\nimport Test.Framework.Providers.HUnit (testCase)\nimport Test.HUnit ((@?=))\n\n\n--------------------------------------------------------------------------------\ntests :: Test\ntests = testGroup \"Network.WebSockets.Extensions.Tests\"\n [ testCase \"parseExtensionDescriptions 01\" $ do\n parseExtensionDescriptions \"permessage-deflate\" @?= Right\n [ ExtensionDescription \"permessage-deflate\" [] ]\n\n , testCase \"parseExtensionDescriptions 02\" $ do\n parseExtensionDescriptions \"permessage-deflate; client_max_window_bits; server_max_window_bits=10\" @?= Right\n [ ExtensionDescription \"permessage-deflate\"\n [ (\"client_max_window_bits\", Nothing)\n , (\"server_max_window_bits\", Just \"10\")\n ]\n ]\n\n , testCase \"parseExtensionDescriptions 03\" $ do\n 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\n [ ExtensionDescription \"permessage-deflate\"\n [ (\"client_max_window_bits\", Just \"15\")\n , (\"server_max_window_bits\", Just \"10\")\n ]\n , ExtensionDescription \"permessage-deflate\"\n [ (\"client_max_window_bits\", Nothing)\n ]\n , ExtensionDescription \"permessage-deflate\"\n [ (\"client_max_window_bits\", Just \"15\")\n , (\"client_max_window_bits\", Just \"10\")\n ]\n ]\n ]\n" }, { "path": "tests/haskell/Network/WebSockets/Handshake/Tests.hs", "content": "--------------------------------------------------------------------------------\n{-# LANGUAGE OverloadedStrings #-}\nmodule Network.WebSockets.Handshake.Tests\n ( tests\n ) where\n\n\n--------------------------------------------------------------------------------\nimport Control.Concurrent (forkIO)\nimport Control.Exception (handle)\nimport Data.ByteString.Char8 ()\nimport Data.IORef (newIORef, readIORef,\n writeIORef)\nimport Data.Maybe (fromJust)\nimport Test.Framework (Test, testGroup)\nimport Test.Framework.Providers.HUnit (testCase)\nimport Test.HUnit (Assertion, assert, (@?=))\n\n\n--------------------------------------------------------------------------------\nimport Network.WebSockets\nimport Network.WebSockets.Connection\nimport Network.WebSockets.Http\nimport qualified Network.WebSockets.Stream as Stream\n\n\n--------------------------------------------------------------------------------\ntests :: Test\ntests = testGroup \"Network.WebSockets.Handshake.Test\"\n [ testCase \"handshake Hybi13\" testHandshakeHybi13\n , testCase \"handshake Hybi13 with subprotocols\" testHandshakeHybi13WithProto\n , testCase \"handshake Hybi13 with headers\" testHandshakeHybi13WithHeaders\n , testCase \"handshake Hybi13 with subprotocols and headers\" testHandshakeHybi13WithProtoAndHeaders\n , testCase \"handshake reject\" testHandshakeReject\n , testCase \"handshake reject with custom code\" testHandshakeRejectWithCode\n , testCase \"handshake Hybi9000\" testHandshakeHybi9000\n ]\n\n\n--------------------------------------------------------------------------------\ntestHandshake :: RequestHead -> (PendingConnection -> IO a) -> IO ResponseHead\ntestHandshake rq app = do\n echo <- Stream.makeEchoStream\n _ <- forkIO $ do\n _ <- app (PendingConnection defaultConnectionOptions rq nullify echo)\n return ()\n mbRh <- Stream.parse echo decodeResponseHead\n Stream.close echo\n case mbRh of\n Nothing -> fail \"testHandshake: No response\"\n Just rh -> return rh\n where\n nullify _ = return ()\n\n\n--------------------------------------------------------------------------------\n(!) :: Eq a => [(a, b)] -> a -> b\nassoc ! key = fromJust (lookup key assoc)\n\n\n--------------------------------------------------------------------------------\nrq13 :: RequestHead\nrq13 = RequestHead \"/mychat\"\n [ (\"Host\", \"server.example.com\")\n , (\"Upgrade\", \"websocket\")\n , (\"Connection\", \"Upgrade\")\n , (\"Sec-WebSocket-Key\", \"x3JJHMbDL1EzLkh9GBhXDw==\")\n , (\"Sec-WebSocket-Protocol\", \"chat, superchat\")\n , (\"Sec-WebSocket-Version\", \"13\")\n , (\"Origin\", \"http://example.com\")\n ]\n False\n\n\n--------------------------------------------------------------------------------\ntestHandshakeHybi13 :: Assertion\ntestHandshakeHybi13 = do\n onAcceptFired <- newIORef False\n ResponseHead code message headers <- testHandshake rq13 $ \\pc ->\n acceptRequest pc {pendingOnAccept = \\_ -> writeIORef onAcceptFired True}\n\n readIORef onAcceptFired >>= assert\n code @?= 101\n message @?= \"WebSocket Protocol Handshake\"\n headers ! \"Sec-WebSocket-Accept\" @?= \"HSmrc0sMlYUkAGmm5OPpG2HaGWk=\"\n headers ! \"Connection\" @?= \"Upgrade\"\n lookup \"Sec-WebSocket-Protocol\" headers @?= Nothing\n\n--------------------------------------------------------------------------------\ntestHandshakeHybi13WithProto :: Assertion\ntestHandshakeHybi13WithProto = do\n onAcceptFired <- newIORef False\n ResponseHead code message headers <- testHandshake rq13 $ \\pc -> do\n getRequestSubprotocols (pendingRequest pc) @?= [\"chat\", \"superchat\"]\n acceptRequestWith pc {pendingOnAccept = \\_ -> writeIORef onAcceptFired True}\n (AcceptRequest (Just \"superchat\") [])\n\n readIORef onAcceptFired >>= assert\n code @?= 101\n message @?= \"WebSocket Protocol Handshake\"\n headers ! \"Sec-WebSocket-Accept\" @?= \"HSmrc0sMlYUkAGmm5OPpG2HaGWk=\"\n headers ! \"Connection\" @?= \"Upgrade\"\n headers ! \"Sec-WebSocket-Protocol\" @?= \"superchat\"\n\n--------------------------------------------------------------------------------\ntestHandshakeHybi13WithHeaders :: Assertion\ntestHandshakeHybi13WithHeaders = do\n onAcceptFired <- newIORef False\n ResponseHead code message headers <- testHandshake rq13 $ \\pc -> do\n getRequestSubprotocols (pendingRequest pc) @?= [\"chat\", \"superchat\"]\n acceptRequestWith pc {pendingOnAccept = \\_ -> writeIORef onAcceptFired True}\n (AcceptRequest Nothing [(\"Set-Cookie\",\"sid=foo\")])\n\n readIORef onAcceptFired >>= assert\n code @?= 101\n message @?= \"WebSocket Protocol Handshake\"\n headers ! \"Sec-WebSocket-Accept\" @?= \"HSmrc0sMlYUkAGmm5OPpG2HaGWk=\"\n headers ! \"Connection\" @?= \"Upgrade\"\n headers ! \"Set-Cookie\" @?= \"sid=foo\"\n lookup \"Sec-WebSocket-Protocol\" headers @?= Nothing\n\n--------------------------------------------------------------------------------\ntestHandshakeHybi13WithProtoAndHeaders :: Assertion\ntestHandshakeHybi13WithProtoAndHeaders = do\n onAcceptFired <- newIORef False\n ResponseHead code message headers <- testHandshake rq13 $ \\pc -> do\n getRequestSubprotocols (pendingRequest pc) @?= [\"chat\", \"superchat\"]\n acceptRequestWith pc {pendingOnAccept = \\_ -> writeIORef onAcceptFired True}\n (AcceptRequest (Just \"superchat\") [(\"Set-Cookie\",\"sid=foo\")])\n\n readIORef onAcceptFired >>= assert\n code @?= 101\n message @?= \"WebSocket Protocol Handshake\"\n headers ! \"Sec-WebSocket-Accept\" @?= \"HSmrc0sMlYUkAGmm5OPpG2HaGWk=\"\n headers ! \"Connection\" @?= \"Upgrade\"\n headers ! \"Sec-WebSocket-Protocol\" @?= \"superchat\"\n headers ! \"Set-Cookie\" @?= \"sid=foo\"\n\n\n--------------------------------------------------------------------------------\ntestHandshakeReject :: Assertion\ntestHandshakeReject = do\n ResponseHead code _ _ <- testHandshake rq13 $ \\pc ->\n rejectRequest pc \"YOU SHALL NOT PASS\"\n\n code @?= 400\n\n\n--------------------------------------------------------------------------------\ntestHandshakeRejectWithCode :: Assertion\ntestHandshakeRejectWithCode = do\n ResponseHead code _ _ <- testHandshake rq13 $ \\pc ->\n rejectRequestWith pc defaultRejectRequest\n { rejectBody = \"YOU SHALL NOT PASS\"\n , rejectCode = 401\n }\n\n code @?= 401\n\n\n--------------------------------------------------------------------------------\n-- I don't believe this one is supported yet\nrq9000 :: RequestHead\nrq9000 = RequestHead \"/chat\"\n [ (\"Host\", \"server.example.com\")\n , (\"Upgrade\", \"websocket\")\n , (\"Connection\", \"Upgrade\")\n , (\"Sec-WebSocket-Key\", \"dGhlIHNhbXBsZSBub25jZQ==\")\n , (\"Sec-WebSocket-Origin\", \"http://example.com\")\n , (\"Sec-WebSocket-Protocol\", \"chat, superchat\")\n , (\"Sec-WebSocket-Version\", \"9000\")\n ]\n False\n\n\n--------------------------------------------------------------------------------\ntestHandshakeHybi9000 :: Assertion\ntestHandshakeHybi9000 = do\n ResponseHead code _ headers <- testHandshake rq9000 $ \\pc ->\n flip handle (acceptRequest pc) $ \\e -> case e of\n NotSupported -> return undefined\n _ -> error $ \"Unexpected Exception: \" ++ show e\n\n code @?= 400\n headers ! \"Sec-WebSocket-Version\" @?= \"13\"\n" }, { "path": "tests/haskell/Network/WebSockets/Http/Tests.hs", "content": "--------------------------------------------------------------------------------\n{-# LANGUAGE OverloadedStrings #-}\nmodule Network.WebSockets.Http.Tests\n ( tests\n ) where\n\n\n--------------------------------------------------------------------------------\nimport qualified Data.Attoparsec.ByteString as A\nimport qualified Data.ByteString.Char8 as BC\nimport Test.Framework (Test, testGroup)\nimport Test.Framework.Providers.HUnit (testCase)\nimport Test.HUnit (Assertion, assert)\n\n\n--------------------------------------------------------------------------------\nimport Network.WebSockets.Http\n\n\n--------------------------------------------------------------------------------\ntests :: Test\ntests = testGroup \"Network.WebSockets.Http.Tests\"\n [ testCase \"jwebsockets response\" jWebSocketsResponse\n , testCase \"chromium response\" chromiumResponse\n , testCase \"matchbook response\" matchbookResponse\n ]\n\n\n--------------------------------------------------------------------------------\n-- | This is a specific response sent by jwebsockets which caused trouble\njWebSocketsResponse :: Assertion\njWebSocketsResponse = assert $ case A.parseOnly decodeResponseHead input of\n Left err -> error err\n Right _ -> True\n where\n input = BC.intercalate \"\\r\\n\"\n [ \"HTTP/1.1 101 Switching Protocols\"\n , \"Upgrade: websocket\"\n , \"Connection: Upgrade\"\n , \"Sec-WebSocket-Accept: Ha0QR1T9CoYx/nqwHsVnW8KVTSo=\"\n , \"Sec-WebSocket-Origin: \"\n , \"Sec-WebSocket-Location: ws://127.0.0.1\"\n , \"Set-Cookie: JWSSESSIONID=2e0690e2e328f327056a5676b6a890e3; HttpOnly\"\n , \"\"\n , \"\"\n ]\n\n\n--------------------------------------------------------------------------------\n-- | This is a specific response sent by chromium which caused trouble\nchromiumResponse :: Assertion\nchromiumResponse = assert $ case A.parseOnly decodeResponseHead input of\n Left err -> error err\n Right _ -> True\n where\n input = BC.intercalate \"\\r\\n\"\n [ \"HTTP/1.1 500 Internal Error\"\n , \"Content-Type:text/html\"\n , \"Content-Length:23\"\n , \"\"\n , \"No such target id: 20_1\"\n ]\n\n--------------------------------------------------------------------------------\n-- | This is a specific response sent by Matchbook.com which caused trouble\n\nmatchbookResponse :: Assertion\nmatchbookResponse = assert $ case A.parseOnly decodeResponseHead input of\n Left err -> error err\n Right _ -> True\n where\n input = BC.intercalate \"\\r\\n\"\n [ \"HTTP/1.1 101 \"\n , \"Date: Mon, 22 May 2017 19:39:08 GMT\"\n , \"Connection: upgrade\"\n , \"Set-Cookie: __cfduid=deadbeefdeadbeefdeadbeefdeadbeefdeadbeefdea; expires=Tue, 22-May-18 19:39:08 GMT; path=/; domain=.matchbook.com; HttpOnly\"\n , \"X-Content-Type-Options: nosniff\"\n , \"X-XSS-Protection: 1; mode=block\"\n , \"X-Frame-Options: DENY\"\n , \"Upgrade: websocket\"\n , \"Sec-WebSocket-Accept: dEadB33fDeadbEEfD3aDbE3Fdea=\"\n , \"X-MB-HA: edge-socket\"\n , \"X-MB-HAP: haproxy01aws\"\n , \"Server: cloudflare-nginx\"\n , \"CF-RAY: 3632deadbeef5b33-HEL\"\n , \"\"\n , \"\"\n ]\n" }, { "path": "tests/haskell/Network/WebSockets/Hybi13/Demultiplex/Tests.hs", "content": "--------------------------------------------------------------------------------\n{-# LANGUAGE OverloadedStrings #-}\nmodule Network.WebSockets.Hybi13.Demultiplex.Tests\n ( tests\n ) where\n\n\n--------------------------------------------------------------------------------\nimport Control.Applicative ((<$>))\nimport qualified Data.ByteString.Lazy as BL\nimport Network.WebSockets\nimport Network.WebSockets.Hybi13.Demultiplex\nimport Prelude\nimport Test.Framework (Test, testGroup)\nimport Test.Framework.Providers.HUnit (testCase)\nimport Test.HUnit (Assertion, (@=?))\n\n\n--------------------------------------------------------------------------------\ntests :: Test\ntests = testGroup \"Network.WebSockets.Hybi13.Demultiplex.Tests\"\n [ testMessageDataSizeLimit\n ]\n\n\n--------------------------------------------------------------------------------\ntestMessageDataSizeLimit :: Test\ntestMessageDataSizeLimit = testGroup \"testMessageDataSizeLimit Hybi13\"\n [ testCase \"OK 1\" $\n Right [DataMessage False False False (Binary (mkZeroes 100))] @=?\n testDemultiplex (SizeLimit 100) (fragmented 5 20)\n , testCase \"Exceeds 1\" $\n assertLeft $\n testDemultiplex (SizeLimit 99) (fragmented 5 20)\n , testCase \"Exceeds 2\" $\n assertLeft $\n testDemultiplex (SizeLimit 100) (fragmented 6 20)\n , testCase \"Exceeds 3\" $\n assertLeft $\n testDemultiplex (SizeLimit 100) (fragmented 101 1)\n , testCase \"Exceeds 4\" $\n assertLeft $\n testDemultiplex (SizeLimit 100) (fragmented 1 101)\n ]\n where\n fragmented :: Int -> Int -> [Frame]\n fragmented n size =\n let payload = mkZeroes size in\n [Frame False False False False BinaryFrame payload] ++\n replicate (n - 2) (Frame False False False False ContinuationFrame payload) ++\n [Frame True False False False ContinuationFrame payload]\n\n mkZeroes :: Int -> BL.ByteString\n mkZeroes size = BL.replicate (fromIntegral size) 0\n\n assertLeft :: Either a b -> Assertion\n assertLeft (Left _) = return ()\n assertLeft (Right _) = fail \"Expecting test to fail\"\n\n\n--------------------------------------------------------------------------------\ntestDemultiplex\n :: SizeLimit\n -> [Frame]\n -> Either ConnectionException [Message]\ntestDemultiplex messageLimit = go emptyDemultiplexState\n where\n go _state0 [] = return []\n go state0 (frame : frames) = case demultiplex messageLimit state0 frame of\n (DemultiplexContinue, state1) -> go state1 frames\n (DemultiplexError err, _) -> Left err\n (DemultiplexSuccess m, state1) -> (m :) <$> go state1 frames\n" }, { "path": "tests/haskell/Network/WebSockets/Mask/Tests.hs", "content": "--------------------------------------------------------------------------------\n{-# LANGUAGE BangPatterns #-}\n{-# LANGUAGE OverloadedStrings #-}\nmodule Network.WebSockets.Mask.Tests\n ( tests\n ) where\n\n\n--------------------------------------------------------------------------------\nimport qualified Data.Binary.Get as Get\nimport Data.Bits (xor)\nimport qualified Data.ByteString as B\nimport qualified Data.ByteString.Lazy as BL\nimport Network.WebSockets.Hybi13.Mask\nimport Test.Framework (Test, testGroup)\nimport Test.Framework.Providers.QuickCheck2 (testProperty)\nimport Test.QuickCheck (Arbitrary (..), (===))\nimport qualified Test.QuickCheck as QC\n\n\n--------------------------------------------------------------------------------\nimport Network.WebSockets.Tests.Util\n\ntests :: Test\ntests = testGroup \"Network.WebSockets.Masks.Tests\"\n [ testProperty \"correct fast masking\" testMasking ]\n\nmaskPayload' :: Maybe B.ByteString -> BL.ByteString -> BL.ByteString\nmaskPayload' Nothing = id\nmaskPayload' (Just mask) = snd . BL.mapAccumL f (cycle $ B.unpack mask)\n where\n f [] !c = ([], c)\n f (m:ms) !c = (ms, m `xor` c)\n\nnewtype AMask = AMask B.ByteString deriving (Show)\ninstance Arbitrary AMask where\n arbitrary = do\n c1 <- arbitrary\n c2 <- arbitrary\n c3 <- arbitrary\n c4 <- arbitrary\n return (AMask (B.pack [c1,c2,c3,c4]))\n\nnewtype APkt = APkt BL.ByteString deriving (Show)\ninstance Arbitrary APkt where\n arbitrary = do\n b1 <- arbitraryByteString\n b2 <- arbitraryByteString\n return $ APkt (b1 `BL.append` b2) -- Just for sure to test correctly different alignments\n shrink (APkt bs) =\n map APkt [ BL.append a b | (a, b) <- zip (BL.inits bs) (tail $ BL.tails bs) ]\n\ntestMasking :: QC.Property\ntestMasking =\n QC.forAllShrink QC.arbitrary QC.shrink $ \\(AMask mask, APkt pkt) ->\n let wmask = Get.runGet parseMask (BL.fromStrict mask)\n in maskPayload' (Just mask) pkt === maskPayload (Just wmask) pkt\n" }, { "path": "tests/haskell/Network/WebSockets/Server/Tests.hs", "content": "--------------------------------------------------------------------------------\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE ScopedTypeVariables #-}\nmodule Network.WebSockets.Server.Tests\n ( tests\n ) where\n\n\n--------------------------------------------------------------------------------\nimport Control.Applicative ((<$>), (<|>))\nimport Control.Concurrent (forkIO, killThread,\n threadDelay)\nimport Control.Concurrent.Async (Async, async, cancel)\nimport Control.Exception (SomeException, catch, handle)\nimport Control.Monad (forever, replicateM, unless)\nimport Data.IORef (IORef, newIORef, readIORef,\n writeIORef)\n\n--------------------------------------------------------------------------------\nimport qualified Data.ByteString.Lazy as BL\nimport Data.Text (Text)\nimport System.Environment (getEnvironment)\nimport Test.Framework (Test, testGroup)\nimport Test.Framework.Providers.HUnit (testCase)\nimport Test.HUnit (Assertion, assert, (@=?))\nimport Test.QuickCheck (Arbitrary, arbitrary)\nimport Test.QuickCheck.Gen (Gen (..))\nimport Test.QuickCheck.Random (newQCGen)\n\n\n--------------------------------------------------------------------------------\nimport Network.WebSockets\nimport Network.WebSockets.Tests.Util\n\n\n--------------------------------------------------------------------------------\ntests :: Test\ntests = testGroup \"Network.WebSockets.Server.Tests\"\n [ testCase \"simple server/client\" testSimpleServerClient\n , testCase \"bulk server/client\" testBulkServerClient\n , testCase \"onPong\" testOnPong\n , testCase \"ipv6 server\" testIpv6Server\n , testCase \"reject request\" testRejectRequest \n ]\n\n\n--------------------------------------------------------------------------------\ntestSimpleServerClient :: Assertion\ntestSimpleServerClient = testServerClient \"127.0.0.1\" $ \\conn -> mapM_ (sendTextData conn)\n\n\n--------------------------------------------------------------------------------\n-- | This is a bit ugly but it seems CI services don't support ipv6 in 2018.\nskipIpv6Incompatible :: Assertion -> Assertion\nskipIpv6Incompatible assertion = do\n env <- getEnvironment\n case lookup \"TRAVIS\" env <|> lookup \"CIRCLECI\" env of\n Just \"true\" -> return ()\n _ -> assertion\n\n--------------------------------------------------------------------------------\ntestIpv6Server :: Assertion\ntestIpv6Server = skipIpv6Incompatible $\n testServerClient \"::1\" $ \\conn -> mapM_ (sendTextData conn)\n\n--------------------------------------------------------------------------------\ntestBulkServerClient :: Assertion\ntestBulkServerClient = testServerClient \"127.0.0.1\" sendTextDatas\n\n--------------------------------------------------------------------------------\ntestServerClient :: String -> (Connection -> [BL.ByteString] -> IO ()) -> Assertion\ntestServerClient host sendMessages = withEchoServer host 42940 \"Bye\" $ do\n texts <- map unArbitraryUtf8 <$> sample\n texts' <- runClient host 42940 \"/chat\" $ client texts\n texts @=? texts'\n where\n client :: [BL.ByteString] -> ClientApp [BL.ByteString]\n client texts conn = do\n sendMessages conn texts\n texts' <- replicateM (length texts) (receiveData conn)\n sendClose conn (\"Bye\" :: BL.ByteString)\n expectCloseException conn \"Bye\"\n return texts'\n\n--------------------------------------------------------------------------------\ntestRejectRequest :: Assertion\ntestRejectRequest = withRejectingServer\n where\n client :: ClientApp ()\n client _ = error \"Client should not be able to connect\"\n\n server :: ServerApp\n server pendingConnection = rejectRequest pendingConnection \"Bye\"\n\n withRejectingServer :: IO ()\n withRejectingServer = do\n serverThread <- async $ runServer \"127.0.0.1\" 42940 server\n waitSome\n () <- runClient \"127.0.0.1\" 42940 \"/chat\" client `catch` handler\n waitSome\n cancel serverThread\n return ()\n\n handler :: HandshakeException -> IO ()\n handler (RequestRejected _ response) = do\n responseCode response @=? 400\n handler exc = error $ \"Unexpected exception \" ++ show exc\n\n--------------------------------------------------------------------------------\ntestOnPong :: Assertion\ntestOnPong = withEchoServer \"127.0.0.1\" 42941 \"Bye\" $ do\n gotPong <- newIORef False\n let opts = defaultConnectionOptions\n { connectionOnPong = writeIORef gotPong True\n }\n\n rcv <- runClientWith \"127.0.0.1\" 42941 \"/\" opts [] client\n assert rcv\n assert =<< readIORef gotPong\n where\n client :: ClientApp Bool\n client conn = do\n sendPing conn (\"What's a fish without an eye?\" :: Text)\n sendTextData conn (\"A fsh!\" :: Text)\n msg <- receiveData conn\n sendCloseCode conn 1000 (\"Bye\" :: BL.ByteString)\n expectCloseException conn \"Bye\"\n return $ \"A fsh!\" == (msg :: Text)\n\n\n--------------------------------------------------------------------------------\nsample :: Arbitrary a => IO [a]\nsample = do\n gen <- newQCGen\n return $ (unGen arbitrary) gen 512\n\n\n--------------------------------------------------------------------------------\nwaitSome :: IO ()\nwaitSome = threadDelay $ 200 * 1000\n\n--------------------------------------------------------------------------------\nwithEchoServer :: String -> Int -> BL.ByteString -> IO a -> IO a\nwithEchoServer host port expectedClose action = do\n cRef <- newIORef False\n serverThread <- async $ runServer host port (\\c -> server c `catch` handleClose cRef)\n waitSome\n result <- action\n waitSome\n cancel serverThread\n closeCalled <- readIORef cRef\n unless closeCalled $ error \"Expecting the CloseRequest exception\"\n return result\n where\n server :: ServerApp\n server pc = do\n conn <- acceptRequest pc\n forever $ do\n msg <- receiveDataMessage conn\n sendDataMessage conn msg\n\n handleClose :: IORef Bool -> ConnectionException -> IO ()\n handleClose cRef (CloseRequest i msg) = do\n i @=? 1000\n msg @=? expectedClose\n writeIORef cRef True\n handleClose _ ConnectionClosed =\n error \"Unexpected connection closed exception\"\n handleClose _ (ParseException _) =\n error \"Unexpected parse exception\"\n handleClose _ (UnicodeException _) =\n error \"Unexpected unicode exception\"\n\n\n--------------------------------------------------------------------------------\nexpectCloseException :: Connection -> BL.ByteString -> IO ()\nexpectCloseException conn msg = act `catch` handler\n where\n act = receiveDataMessage conn >> error \"Expecting CloseRequest exception\"\n handler (CloseRequest i msg') = do\n i @=? 1000\n msg' @=? msg\n handler ConnectionClosed = error \"Unexpected connection closed\"\n handler (ParseException _) = error \"Unexpected parse exception\"\n handler (UnicodeException _) = error \"Unexpected unicode exception\"\n" }, { "path": "tests/haskell/Network/WebSockets/Tests/Util.hs", "content": "--------------------------------------------------------------------------------\nmodule Network.WebSockets.Tests.Util\n ( ArbitraryUtf8 (..)\n , arbitraryUtf8\n , arbitraryByteString\n ) where\n\n\n--------------------------------------------------------------------------------\nimport Control.Applicative ((<$>))\nimport qualified Data.ByteString.Lazy as BL\nimport qualified Data.Text.Lazy as TL\nimport qualified Data.Text.Lazy.Encoding as TL\nimport Test.QuickCheck (Arbitrary (..), Gen)\n\n\n--------------------------------------------------------------------------------\nimport Network.WebSockets.Types\n\n\n--------------------------------------------------------------------------------\nnewtype ArbitraryUtf8 = ArbitraryUtf8 {unArbitraryUtf8 :: BL.ByteString}\n deriving (Eq, Ord, Show)\n\n\n--------------------------------------------------------------------------------\ninstance Arbitrary ArbitraryUtf8 where\n arbitrary = ArbitraryUtf8 <$> arbitraryUtf8\n\n\n--------------------------------------------------------------------------------\narbitraryUtf8 :: Gen BL.ByteString\narbitraryUtf8 = toLazyByteString . TL.encodeUtf8 . TL.pack <$> arbitrary\n\n\n--------------------------------------------------------------------------------\narbitraryByteString :: Gen BL.ByteString\narbitraryByteString = BL.pack <$> arbitrary\n" }, { "path": "tests/haskell/Network/WebSockets/Tests.hs", "content": "--------------------------------------------------------------------------------\n{-# LANGUAGE OverloadedStrings #-}\n{-# OPTIONS_GHC -fno-warn-orphans #-}\nmodule Network.WebSockets.Tests\n ( tests\n ) where\n\n\n--------------------------------------------------------------------------------\nimport qualified Data.ByteString.Builder as Builder\nimport Control.Applicative ((<$>))\nimport Control.Concurrent (forkIO)\nimport Control.Exception (try)\nimport Control.Monad (replicateM)\nimport Data.Binary.Get (runGetOrFail)\nimport qualified Data.ByteString.Lazy as BL\nimport Data.List (intersperse)\nimport Data.Maybe (catMaybes)\nimport Data.Monoid (mempty, mconcat)\nimport Network.WebSockets\nimport qualified Network.WebSockets.Hybi13 as Hybi13\nimport Network.WebSockets.Hybi13.Demultiplex\nimport Network.WebSockets.Protocol\nimport qualified Network.WebSockets.Stream as Stream\nimport Network.WebSockets.Tests.Util\nimport Network.WebSockets.Types\nimport Test.Framework (Test, testGroup)\nimport Test.Framework.Providers.HUnit (testCase)\nimport Test.Framework.Providers.QuickCheck2 (testProperty)\nimport Test.HUnit ((@=?))\nimport Test.QuickCheck (Arbitrary (..), Gen,\n Property)\nimport qualified Test.QuickCheck as QC\nimport qualified Test.QuickCheck.Monadic as QC\nimport Prelude\n\n\n--------------------------------------------------------------------------------\ntests :: Test\ntests = testGroup \"Network.WebSockets.Test\"\n [ testProperty \"simple encode/decode Hybi13\" (testSimpleEncodeDecode Hybi13)\n , testProperty \"fragmented Hybi13\" testFragmentedHybi13\n , testRfc_6455_5_5_1\n , testRfc_6455_5_5_2\n , testFramePayloadSizeLimit\n ]\n\n--------------------------------------------------------------------------------\ntestSimpleEncodeDecode :: Protocol -> Property\ntestSimpleEncodeDecode protocol = QC.monadicIO $\n QC.forAllM QC.arbitrary $ \\msgs -> QC.run $ do\n echo <- Stream.makeEchoStream\n parse <- decodeMessages protocol mempty mempty echo\n write <- encodeMessages protocol ClientConnection echo\n _ <- forkIO $ write msgs\n msgs' <- catMaybes <$> replicateM (length msgs) parse\n Stream.close echo\n msgs @=? msgs'\n\n\n--------------------------------------------------------------------------------\ntestFragmentedHybi13 :: Property\ntestFragmentedHybi13 = QC.monadicIO $\n QC.forAllM QC.arbitrary $ \\fragmented -> QC.run $ do\n echo <- Stream.makeEchoStream\n parse <- Hybi13.decodeMessages mempty mempty echo\n -- is' <- Streams.filter isDataMessage =<< Hybi13.decodeMessages is\n\n -- Simple hacky encoding of all frames\n _ <- forkIO $ do\n mapM_ (Stream.write echo)\n [ Builder.toLazyByteString (Hybi13.encodeFrame Nothing f)\n | FragmentedMessage _ frames <- fragmented\n , f <- frames\n ]\n Stream.close echo\n\n -- Check if we got all data\n msgs <- filter isDataMessage <$> parseAll parse\n [msg | FragmentedMessage msg _ <- fragmented] @=? msgs\n where\n isDataMessage (ControlMessage _) = False\n isDataMessage (DataMessage _ _ _ _) = True\n\n parseAll parse = do\n mbMsg <- try parse\n case mbMsg of\n Left ConnectionClosed -> return []\n Left _ -> return []\n Right (Just msg) -> (msg :) <$> parseAll parse\n Right Nothing -> return []\n\n--------------------------------------------------------------------------------\ntestRfc_6455_5_5_1 :: Test\ntestRfc_6455_5_5_1 =\n testCase \"RFC 6455, 5.5: Frame encoder shall truncate control frame payload to 125 bytes\" $ do\n 260 @=? BL.length (encodedFrame ContinuationFrame)\n 260 @=? BL.length (encodedFrame TextFrame)\n 260 @=? BL.length (encodedFrame BinaryFrame)\n 127 @=? BL.length (encodedFrame CloseFrame)\n 127 @=? BL.length (encodedFrame PingFrame)\n 127 @=? BL.length (encodedFrame PongFrame)\n where\n payload256 = BL.replicate 256 0\n encodedFrame ft\n = Builder.toLazyByteString\n $ Hybi13.encodeFrame Nothing (Frame True False False False ft payload256)\n\n--------------------------------------------------------------------------------\ntestRfc_6455_5_5_2 :: Test\ntestRfc_6455_5_5_2 =\n testCase \"RFC 6455, 5.5: Frame decoder shall fail if control frame payload length > 125 bytes\" $\n Left (BL.drop 4 ping126, 4, errMsg) @=? runGetOrFail (Hybi13.parseFrame mempty) ping126\n where\n errMsg = \"Control Frames must not carry payload > 125 bytes!\"\n ping126 = mconcat\n [ \"\\137\\254\\NUL~\\219\\SI\\190\\252\\219\\SI\\190\\252\\219\\SI\\190\\252\\219\"\n , \"\\SI\\190\\252\\219\\SI\\190\\252\\219\\SI\\190\\252\\219\\SI\\190\\252\\219\"\n , \"\\SI\\190\\252\\219\\SI\\190\\252\\219\\SI\\190\\252\\219\\SI\\190\\252\\219\"\n , \"\\SI\\190\\252\\219\\SI\\190\\252\\219\\SI\\190\\252\\219\\SI\\190\\252\\219\"\n , \"\\SI\\190\\252\\219\\SI\\190\\252\\219\\SI\\190\\252\\219\\SI\\190\\252\\219\"\n , \"\\SI\\190\\252\\219\\SI\\190\\252\\219\\SI\\190\\252\\219\\SI\\190\\252\\219\"\n , \"\\SI\\190\\252\\219\\SI\\190\\252\\219\\SI\\190\\252\\219\\SI\\190\\252\\219\"\n , \"\\SI\\190\\252\\219\\SI\\190\\252\\219\\SI\\190\\252\\219\\SI\\190\\252\\219\"\n , \"\\SI\\190\\252\\219\\SI\"\n ]\n\ntestFramePayloadSizeLimit :: Test\ntestFramePayloadSizeLimit = testGroup \"FramePayloadSizeLimit Hybi13\"\n [ testCase \"OK 1\" $ case parse (frame 99) of\n Right _ -> return ()\n Left _ -> fail \"Expecting successful parse.\"\n , testCase \"OK 2\" $ case parse (frame 100) of\n Right _ -> return ()\n Left _ -> fail \"Expecting successful parse.\"\n , testCase \"Exceed\" $ case parse (frame 101) of\n Right _ -> fail \"Expecting parse to fail.\"\n Left _ -> return ()\n ]\n where\n parse = runGetOrFail (Hybi13.parseFrame (SizeLimit 100))\n frame n = Builder.toLazyByteString $ Hybi13.encodeFrame Nothing $\n Frame True False False False BinaryFrame (BL.replicate n 20)\n\n\n--------------------------------------------------------------------------------\ninstance Arbitrary Message where\n arbitrary = QC.oneof\n [ do\n payload <- BL.take 125 . BL.pack <$> arbitrary\n return $ ControlMessage (Ping payload)\n , do\n payload <- BL.take 125 . BL.pack <$> arbitrary\n return $ ControlMessage (Pong payload)\n , do\n payload <- BL.pack <$> arbitrary\n return $ DataMessage False False False (Text payload Nothing)\n , do\n payload <- BL.pack <$> arbitrary\n return $ DataMessage False False False (Binary payload)\n ]\n\n\n--------------------------------------------------------------------------------\ndata FragmentedMessage = FragmentedMessage Message [Frame]\n deriving (Show)\n\n\n--------------------------------------------------------------------------------\ninstance Arbitrary FragmentedMessage where\n arbitrary = do\n -- Pick a frametype and a corresponding random payload\n ft <- QC.elements [TextFrame, BinaryFrame]\n payload <- case ft of\n TextFrame -> arbitraryUtf8\n _ -> arbitraryByteString\n\n fragments <- arbitraryFragmentation payload\n let fs = makeFrames $ zip (ft : repeat ContinuationFrame) fragments\n msg = case ft of\n TextFrame -> DataMessage False False False (Text payload Nothing)\n BinaryFrame -> DataMessage False False False (Binary payload)\n _ -> error \"Arbitrary FragmentedMessage crashed\"\n\n interleaved <- arbitraryInterleave genControlFrame fs\n return $ FragmentedMessage msg interleaved\n -- return $ FragmentedMessage msg fs\n where\n makeFrames [] = []\n makeFrames [(ft, pl)] = [Frame True False False False ft pl]\n makeFrames ((ft, pl) : fr) =\n Frame False False False False ft pl : makeFrames fr\n\n genControlFrame = QC.elements\n [ Frame True False False False PingFrame \"Herp\"\n , Frame True False False False PongFrame \"Derp\"\n ]\n\n\n--------------------------------------------------------------------------------\narbitraryFragmentation :: BL.ByteString -> Gen [BL.ByteString]\narbitraryFragmentation bs = arbitraryFragmentation' bs\n where\n len :: Int\n len = fromIntegral $ BL.length bs\n arbitraryFragmentation' bs' = do\n -- TODO: we currently can't send packets of length 0. We should\n -- investigate why (regardless of the spec).\n n <- QC.choose (1, len - 1)\n let (l, r) = BL.splitAt (fromIntegral n) bs'\n case r of\n \"\" -> return [l]\n _ -> (l :) <$> arbitraryFragmentation' r\n\n\n--------------------------------------------------------------------------------\narbitraryInterleave :: Gen a -> [a] -> Gen [a]\narbitraryInterleave sep xs = fmap concat $ sequence $\n [sep'] ++ intersperse sep' [return [x] | x <- xs] ++ [sep']\n where\n sep' = QC.sized $ \\size -> do\n num <- QC.choose (1, size)\n replicateM num sep\n" }, { "path": "tests/haskell/TestSuite.hs", "content": "--------------------------------------------------------------------------------\nimport qualified Network.WebSockets.Extensions.Tests\nimport qualified Network.WebSockets.Extensions.PermessageDeflate.Tests\nimport qualified Network.WebSockets.Handshake.Tests\nimport qualified Network.WebSockets.Http.Tests\nimport qualified Network.WebSockets.Hybi13.Demultiplex.Tests\nimport qualified Network.WebSockets.Mask.Tests\nimport qualified Network.WebSockets.Server.Tests\nimport qualified Network.WebSockets.Tests\nimport Test.Framework (defaultMain)\n\n\n--------------------------------------------------------------------------------\nmain :: IO ()\nmain = defaultMain\n [ Network.WebSockets.Extensions.Tests.tests\n , Network.WebSockets.Extensions.PermessageDeflate.Tests.tests\n , Network.WebSockets.Handshake.Tests.tests\n , Network.WebSockets.Http.Tests.tests\n , Network.WebSockets.Hybi13.Demultiplex.Tests.tests\n , Network.WebSockets.Server.Tests.tests\n , Network.WebSockets.Mask.Tests.tests\n , Network.WebSockets.Tests.tests\n ]\n" }, { "path": "tests/issue-158/Main.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\nmodule Main where\n\nimport Control.Concurrent (threadDelay)\nimport qualified Control.Concurrent.Async as Async\nimport qualified Control.Exception as E\nimport Control.Monad (forever)\nimport qualified Data.Text as T\nimport qualified Network.WebSockets as WS\n\nshowException :: String -> IO a -> IO a\nshowException area m = do\n errOrX <- E.try m\n case errOrX of\n Right x -> return x\n Left (E.SomeException e) -> do\n putStrLn $ \"-> Caught exception in \" ++ area ++ \": \" ++ show e\n E.throwIO e\n\nclientApp :: WS.ClientApp ()\nclientApp = \\connection -> do\n WS.sendTextData connection $ T.pack \"Hello world!\"\n forever $ do\n msg <- showException \"receiveData\" $ WS.receiveData connection\n putStrLn $ \"Received message: \" ++ T.unpack msg\n\nmain :: IO ()\nmain = do\n client <- Async.async $ WS.runClient \"echo.websocket.org\" 80 \"\"\n (\\c -> showException \"clientApp\" (clientApp c))\n\n _canceller <- Async.async $ do\n threadDelay $ 3 * 1000 * 1000\n putStrLn \"Cancelling client from canceller...\"\n Async.cancel client\n\n putStrLn \"Awaiting result from client...\"\n result <- Async.waitCatch client\n putStrLn $ \"Result: \" ++ show result\n" }, { "path": "tests/javascript/client.html", "content": "\n\n \n websockets tests\n \n \n \n \n \n \n \n

websockets tests

\n

\n
\n

\n
    \n
    Test markup, will be hidden
    \n \n\n" }, { "path": "tests/javascript/client.js", "content": "/*******************************************************************************\n* Utilities *\n*******************************************************************************/\n\nfunction createWebSocket(path, subproto) {\n var host = window.location.hostname;\n if(host == '') host = 'localhost';\n var uri = 'ws://' + host + ':8000' + path;\n\n var Socket = \"MozWebSocket\" in window ? MozWebSocket : WebSocket;\n if (subproto) {\n return new Socket(uri, subproto);\n } else {\n return new Socket(uri);\n }\n}\n\n\n/*******************************************************************************\n* Actual tests *\n*******************************************************************************/\n\ntest('demo', function() {\n ok(true, 'Demo test');\n});\n\nasyncTest('echo-text', function() {\n var ws = createWebSocket('/echo-text');\n var messages = ['Hi folks', 'Hello there', 'λ±…'];\n\n ws.onopen = function() {\n ws.send(messages[0]);\n };\n\n ws.onmessage = function(event) {\n var message = event.data;\n equal(message, messages[0]);\n messages = messages.slice(1);\n if(messages.length > 0) {\n ws.send(messages[0]);\n } else {\n ws.close(4002, \"Goodbye\");\n }\n };\n\n ws.onclose = function(event) {\n equal(event.code, 4002);\n equal(event.reason, \"Goodbye\");\n start();\n };\n});\n\nasyncTest('close me', function() {\n var ws = createWebSocket('/close-me');\n ws.onopen = function() {\n ws.send('Close me!');\n };\n ws.onclose = function(event) {\n equal(event.code, 1000);\n equal(event.reason, \"Closing\");\n start();\n };\n});\n\nasyncTest('ping', function() {\n var ws = createWebSocket('/ping');\n\n ws.onmessage = function(event) {\n if(event.data == 'OK') {\n ws.close();\n ok(true, 'ping');\n start();\n }\n };\n});\n\nasyncTest('blob', function() {\n var ws = createWebSocket('/echo');\n\n ws.onopen = function() {\n ws.binaryType = 'blob';\n var b = new Blob(['Hello world.'], {\"type\": \"text/plain\"});\n ws.send(b);\n };\n\n ws.onmessage = function(event){\n console.log(event.data)\n console.log(event.data.type)\n ws.close();\n };\n\n ws.onclose = function(event) {\n equal(event.code, 1000);\n equal(event.reason, \"\");\n start();\n };\n});\n\nasyncTest('subprotocol', function() {\n var ws = createWebSocket(\"/subprotocol\", [\"abc\", \"def\"]);\n\n ws.onopen = function() {\n ws.send(\"Foo\");\n };\n\n ws.onmessage = function(event) {\n var message = event.data;\n equal(message, \"Foo\");\n ws.close(4711, \"Bar\");\n };\n\n ws.onclose = function(event) {\n equal(event.code, 4711);\n equal(event.reason, \"Bar\");\n start();\n };\n});\n" }, { "path": "tests/javascript/server.hs", "content": "--------------------------------------------------------------------------------\n-- | The server part of the tests\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE PatternGuards #-}\nmodule Main\n ( main\n ) where\n\n\n--------------------------------------------------------------------------------\nimport Control.Exception (catch)\nimport Control.Monad (forM_, forever, void)\nimport Control.Monad.Trans (liftIO)\nimport Data.ByteString (ByteString)\nimport Data.ByteString.Lazy.Char8 ()\nimport Data.Text (Text)\nimport qualified Data.Text.Lazy as TL\nimport qualified Network.WebSockets as WS\n\n\n--------------------------------------------------------------------------------\nechoText :: WS.Connection -> IO ()\nechoText conn = forever $ do\n msg <- WS.receiveData conn\n liftIO $ putStrLn $ show (msg :: TL.Text)\n WS.sendTextData conn msg\n\n\n--------------------------------------------------------------------------------\ncloseMe :: WS.Connection -> IO ()\ncloseMe conn = do\n msg <- WS.receiveData conn\n case (msg :: TL.Text) of\n \"Close me!\" -> do\n WS.sendClose conn (\"Closing\" :: ByteString)\n void $ WS.receiveDataMessage conn\n error \"Expecting receiveDataMessage to throw CloseRequest exception\"\n _ -> error \"closeme: unexpected input\"\n\n\n--------------------------------------------------------------------------------\nping :: WS.Connection -> IO ()\nping conn = do\n forM_ [\"Hai\", \"Come again?\", \"Right!\"] $ \\msg -> do\n WS.send conn $ WS.ControlMessage $ WS.Ping msg\n rsp <- WS.receive conn\n case rsp of\n WS.ControlMessage (WS.Pong msg')\n | msg' == msg -> return ()\n | otherwise -> error \"wrong message from client\"\n _ -> error \"ping: client closed socket too soon\"\n\n WS.sendTextData conn (\"OK\" :: Text)\n\n\n--------------------------------------------------------------------------------\necho :: WS.Connection -> IO ()\necho conn = forever $ WS.receive conn >>= WS.send conn\n\n\n--------------------------------------------------------------------------------\ntests :: [(ByteString, WS.Connection -> IO ())]\ntests =\n [ (\"/echo-text\", echoText)\n , (\"/close-me\", closeMe)\n , (\"/ping\", ping)\n , (\"/echo\", echo)\n , (\"/subprotocol\", echoText)\n ]\n\n\n--------------------------------------------------------------------------------\n-- | Application\napplication :: WS.ServerApp\napplication pc = do\n let name = WS.requestPath rq\n -- When a client succesfully connects, lookup the requested test and\n -- run it\n conn <- case name of\n \"/subprotocol\" -> WS.acceptRequestWith pc $ WS.defaultAcceptRequest\n {WS.acceptSubprotocol = Just \"abc\"}\n _ -> WS.acceptRequest pc\n -- version'' <- WS.getVersion\n liftIO $ putStrLn $ \"===================================\"\n liftIO $ putStrLn $ \"Requested client version: \" ++ show version'\n -- liftIO $ putStrLn $ \"Selected version: \" ++ version''\n liftIO $ putStrLn $ \"Requested subprotocols: \" ++ show (WS.getRequestSubprotocols rq)\n liftIO $ putStrLn $ \"Starting test \" ++ show name\n let Just test = lookup name tests in test conn `catch` handleClose\n liftIO $ putStrLn $ \"Test \" ++ show name ++ \" finished\"\n where\n rq = WS.pendingRequest pc\n version' = lookup \"Sec-WebSocket-Version\" (WS.requestHeaders rq)\n handleClose (WS.CloseRequest i msg) =\n putStrLn $ \"Recevied close request \" ++ show i ++ \" : \" ++ show msg\n handleClose WS.ConnectionClosed =\n putStrLn \"Unexpected connection closed exception\"\n handleClose (WS.ParseException e) =\n putStrLn $ \"Recevied parse exception: \" ++ show e\n handleClose (WS.UnicodeException e) =\n putStrLn $ \"Recevied unicode exception: \" ++ show e\n\n\n--------------------------------------------------------------------------------\n-- | Accepts clients, spawns a single handler for each one.\nmain :: IO ()\nmain = WS.runServerWith \"0.0.0.0\" 8000 options application\n where\n options = WS.defaultConnectionOptions\n" }, { "path": "websockets.cabal", "content": "Name: websockets\nVersion: 0.13.0.0\n\nSynopsis:\n A sensible and clean way to write WebSocket-capable servers in Haskell.\n\nDescription:\n This library allows you to write WebSocket-capable servers.\n .\n An example server:\n \n .\n An example client:\n \n .\n This package only supports insecure (@ws:\\/\\/...@) WebSockets.\n If you need secure (@wss:\\/\\/...@) websockets, consider using Wuss:\n \n .\n See also:\n .\n * The specification of the WebSocket protocol:\n \n .\n * The JavaScript API for dealing with WebSockets:\n \n\nLicense: BSD3\nLicense-file: LICENCE\nCopyright: (c) 2010-2011 Siniša Biđin\n (c) 2011-2018 Jasper Van der Jeugt\n (c) 2011 Steffen Schuldenzucker\n (c) 2011 Alex Lang\nAuthor: Siniša Biđin \n Jasper Van der Jeugt \n Steffen Schuldenzucker \n Alex Lang \n Domen Kožar\nMaintainer: Jasper Van der Jeugt \nStability: experimental\nCategory: Network\nBuild-type: Simple\nCabal-version: >= 1.10\n\nHomepage: http://jaspervdj.be/websockets\nBug-reports: https://github.com/jaspervdj/websockets/issues\n\nExtra-source-files:\n CHANGELOG\n\nSource-repository head\n Type: git\n Location: https://github.com/jaspervdj/websockets\n\nFlag Example\n Description: Build the example server\n Default: False\n Manual: True\n\nLibrary\n Hs-source-dirs: src\n Ghc-options: -Wall\n C-sources: cbits/cbits.c\n Default-language: Haskell2010\n\n Exposed-modules:\n Network.WebSockets\n Network.WebSockets.Client\n Network.WebSockets.Connection\n Network.WebSockets.Connection.PingPong\n Network.WebSockets.Extensions\n Network.WebSockets.Stream\n -- Network.WebSockets.Util.PubSub TODO\n\n Other-modules:\n Network.WebSockets.Connection.Options\n Network.WebSockets.Extensions.Description\n Network.WebSockets.Extensions.PermessageDeflate\n Network.WebSockets.Extensions.StrictUnicode\n Network.WebSockets.Http\n Network.WebSockets.Hybi13\n Network.WebSockets.Hybi13.Demultiplex\n Network.WebSockets.Hybi13.Mask\n Network.WebSockets.Protocol\n Network.WebSockets.Server\n Network.WebSockets.Types\n\n Build-depends:\n async >= 2.2 && < 2.3,\n attoparsec >= 0.10 && < 0.15,\n base >= 4.14 && < 5,\n base64-bytestring >= 0.1 && < 1.3,\n binary >= 0.8.1 && < 0.11,\n bytestring >= 0.9 && < 0.13,\n case-insensitive >= 0.3 && < 1.3,\n containers >= 0.3 && < 0.8,\n network >= 2.3 && < 3.3,\n random >= 1.0.1 && < 1.3,\n SHA >= 1.5 && < 1.7,\n streaming-commons >= 0.1 && < 0.3,\n text >= 0.10 && < 2.2,\n entropy >= 0.2.1 && < 0.5\n\nTest-suite websockets-tests\n Type: exitcode-stdio-1.0\n Hs-source-dirs: src tests/haskell\n Main-is: TestSuite.hs\n Ghc-options: -Wall\n C-sources: cbits/cbits.c\n Default-language: Haskell2010\n\n Other-modules:\n Network.WebSockets\n Network.WebSockets.Client\n Network.WebSockets.Connection\n Network.WebSockets.Connection.Options\n Network.WebSockets.Connection.PingPong\n Network.WebSockets.Extensions\n Network.WebSockets.Extensions.Description\n Network.WebSockets.Extensions.PermessageDeflate\n Network.WebSockets.Extensions.PermessageDeflate.Tests\n Network.WebSockets.Extensions.StrictUnicode\n Network.WebSockets.Extensions.Tests\n Network.WebSockets.Handshake.Tests\n Network.WebSockets.Http\n Network.WebSockets.Http.Tests\n Network.WebSockets.Hybi13\n Network.WebSockets.Hybi13.Demultiplex\n Network.WebSockets.Hybi13.Demultiplex.Tests\n Network.WebSockets.Hybi13.Mask\n Network.WebSockets.Mask.Tests\n Network.WebSockets.Protocol\n Network.WebSockets.Server\n Network.WebSockets.Server.Tests\n Network.WebSockets.Stream\n Network.WebSockets.Tests\n Network.WebSockets.Tests.Util\n Network.WebSockets.Types\n Paths_websockets\n\n Build-depends:\n HUnit >= 1.2 && < 1.7,\n QuickCheck >= 2.7 && < 2.15,\n test-framework >= 0.4 && < 0.9,\n test-framework-hunit >= 0.2 && < 0.4,\n test-framework-quickcheck2 >= 0.2 && < 0.4,\n -- Copied from regular dependencies...\n async >= 2.2 && < 2.3,\n attoparsec >= 0.10 && < 0.15,\n base >= 4.14 && < 5,\n base64-bytestring >= 0.1 && < 1.3,\n binary >= 0.8.1 && < 0.11,\n bytestring >= 0.9 && < 0.13,\n case-insensitive >= 0.3 && < 1.3,\n containers >= 0.3 && < 0.8,\n network >= 2.3 && < 3.3,\n random >= 1.0 && < 1.3,\n SHA >= 1.5 && < 1.7,\n streaming-commons >= 0.1 && < 0.3,\n text >= 0.10 && < 2.2,\n entropy >= 0.2.1 && < 0.5\n\nExecutable websockets-server-example\n If !flag(Example)\n Buildable: False\n\n Hs-source-dirs: example\n Main-is: server.lhs\n Ghc-options: -Wall\n Default-language: Haskell2010\n\n Build-depends:\n base,\n websockets,\n text\n\nExecutable websockets-client-example\n If !flag(Example)\n Buildable: False\n\n Hs-source-dirs: example\n Main-is: client.hs\n Ghc-options: -Wall\n Default-language: Haskell2010\n\n Build-depends:\n base,\n websockets,\n text,\n network,\n mtl\n\nExecutable websockets-autobahn\n If !flag(Example)\n Buildable: False\n\n Hs-source-dirs: tests/autobahn\n Main-is: server.hs\n Ghc-options: -Wall -threaded -O2 -rtsopts \"-with-rtsopts=-N\"\n Default-language: Haskell2010\n\n Other-modules:\n Paths_websockets\n\n Build-depends:\n websockets,\n -- Copied from regular dependencies...\n async >= 2.2 && < 2.3,\n attoparsec >= 0.10 && < 0.15,\n base >= 4.14 && < 5,\n base64-bytestring >= 0.1 && < 1.3,\n binary >= 0.8.1 && < 0.11,\n bytestring >= 0.9 && < 0.13,\n case-insensitive >= 0.3 && < 1.3,\n containers >= 0.3 && < 0.8,\n network >= 2.3 && < 3.3,\n random >= 1.0 && < 1.3,\n SHA >= 1.5 && < 1.7,\n text >= 0.10 && < 2.2,\n entropy >= 0.2.1 && < 0.5\n\nBenchmark bench-mask\n Type: exitcode-stdio-1.0\n Main-is: mask.hs\n C-sources: cbits/cbits.c\n Hs-source-dirs: benchmarks, src\n Default-language: Haskell2010\n\n Other-modules:\n Network.WebSockets.Hybi13.Mask\n\n Build-depends:\n criterion,\n -- Copied from regular dependencies...\n async >= 2.2 && < 2.3,\n attoparsec >= 0.10 && < 0.15,\n base >= 4.14 && < 5,\n base64-bytestring >= 0.1 && < 1.3,\n binary >= 0.8.1 && < 0.11,\n bytestring >= 0.9 && < 0.13,\n case-insensitive >= 0.3 && < 1.3,\n containers >= 0.3 && < 0.8,\n network >= 2.3 && < 3.3,\n random >= 1.0 && < 1.3,\n SHA >= 1.5 && < 1.7,\n text >= 0.10 && < 2.2,\n entropy >= 0.2.1 && < 0.5\n" } ]