Showing preview only (220K chars total). Download the full file or copy to clipboard to get everything.
Repository: jaspervdj/websockets
Branch: master
Commit: bfa5fe5d995f
Files: 58
Total size: 204.3 KB
Directory structure:
gitextract_ne4bbnpg/
├── .ghci
├── .github/
│ └── workflows/
│ └── ci.yml
├── .gitignore
├── CHANGELOG
├── LICENCE
├── README.md
├── Setup.hs
├── benchmarks/
│ ├── echo.hs
│ ├── echo.js
│ ├── mask.hs
│ ├── ping.hs
│ └── ping.html
├── cbits/
│ └── cbits.c
├── coverage.sh
├── example/
│ ├── client.hs
│ ├── client.html
│ ├── client.js
│ ├── screen.css
│ └── server.lhs
├── src/
│ └── Network/
│ ├── WebSockets/
│ │ ├── Client.hs
│ │ ├── Connection/
│ │ │ ├── Options.hs
│ │ │ └── PingPong.hs
│ │ ├── Connection.hs
│ │ ├── Extensions/
│ │ │ ├── Description.hs
│ │ │ ├── PermessageDeflate.hs
│ │ │ └── StrictUnicode.hs
│ │ ├── Extensions.hs
│ │ ├── Http.hs
│ │ ├── Hybi13/
│ │ │ ├── Demultiplex.hs
│ │ │ └── Mask.hs
│ │ ├── Hybi13.hs
│ │ ├── Protocol.hs
│ │ ├── Server.hs
│ │ ├── Stream.hs
│ │ ├── Types.hs
│ │ └── Util/
│ │ └── PubSub.hs
│ └── WebSockets.hs
├── stack.yaml
├── tests/
│ ├── autobahn/
│ │ ├── autobahn.sh
│ │ ├── exclude-cases.py
│ │ ├── fuzzingclient.json
│ │ ├── mini-report.py
│ │ └── server.hs
│ ├── haskell/
│ │ ├── Network/
│ │ │ └── WebSockets/
│ │ │ ├── Extensions/
│ │ │ │ ├── PermessageDeflate/
│ │ │ │ │ └── Tests.hs
│ │ │ │ └── Tests.hs
│ │ │ ├── Handshake/
│ │ │ │ └── Tests.hs
│ │ │ ├── Http/
│ │ │ │ └── Tests.hs
│ │ │ ├── Hybi13/
│ │ │ │ └── Demultiplex/
│ │ │ │ └── Tests.hs
│ │ │ ├── Mask/
│ │ │ │ └── Tests.hs
│ │ │ ├── Server/
│ │ │ │ └── Tests.hs
│ │ │ ├── Tests/
│ │ │ │ └── Util.hs
│ │ │ └── Tests.hs
│ │ └── TestSuite.hs
│ ├── issue-158/
│ │ └── Main.hs
│ └── javascript/
│ ├── client.html
│ ├── client.js
│ └── server.hs
└── websockets.cabal
================================================
FILE CONTENTS
================================================
================================================
FILE: .ghci
================================================
:set -isrc -itests/haskell
================================================
FILE: .github/workflows/ci.yml
================================================
name: "build & test"
on:
push:
pull_request:
branches: [master]
jobs:
build:
name: GHC ${{ matrix.ghc-version }} on ${{ matrix.os }}
runs-on: ${{ matrix.os }}
strategy:
fail-fast: false
matrix:
os: [ubuntu-latest]
ghc-version: ['9.8', '9.6', '9.4', '9.2', '9.0']
include:
- os: windows-latest
ghc-version: '9.8'
- os: macos-latest
ghc-version: '9.8'
steps:
- uses: actions/checkout@v4
- name: Set up GHC ${{ matrix.ghc-version }}
uses: haskell-actions/setup@v2
id: setup
with:
ghc-version: ${{ matrix.ghc-version }}
# Defaults, added for clarity:
cabal-version: 'latest'
cabal-update: true
- name: Configure the build
run: |
cabal configure --enable-tests --enable-benchmarks --disable-documentation
cabal build all --dry-run
# The last step generates dist-newstyle/cache/plan.json for the cache key.
- name: Restore cached dependencies
uses: actions/cache/restore@v3
id: cache
env:
key: ${{ runner.os }}-ghc-${{ steps.setup.outputs.ghc-version }}-cabal-${{ steps.setup.outputs.cabal-version }}
with:
path: ${{ steps.setup.outputs.cabal-store }}
key: ${{ env.key }}-plan-${{ hashFiles('**/plan.json') }}
restore-keys: ${{ env.key }}-
- name: Install dependencies
# If we had an exact cache hit, the dependencies will be up to date.
if: steps.cache.outputs.cache-hit != 'true'
run: cabal build all --only-dependencies
# Cache dependencies already here, so that we do not have to rebuild them should the subsequent steps fail.
- name: Save cached dependencies
uses: actions/cache/save@v3
# If we had an exact cache hit, trying to save the cache would error because of key clash.
if: steps.cache.outputs.cache-hit != 'true'
with:
path: ${{ steps.setup.outputs.cabal-store }}
key: ${{ steps.cache.outputs.cache-primary-key }}
- name: Build
run: cabal build all
- name: Run tests
run: cabal test all
- name: Build documentation
run: cabal haddock all
- name: Install virtualenv
if: matrix.os == 'ubuntu-latest'
run: |
sudo apt-get install --yes virtualenv python2.7-dev
pip install virtualenv
- name: Run autobahn tests
if: matrix.os == 'ubuntu-latest'
run: bash tests/autobahn/autobahn.sh
================================================
FILE: .gitignore
================================================
*.hi
*.o
.hpc
dist
tests/coverage
tests/haskell/TestSuite
.stack-work/
================================================
FILE: CHANGELOG
================================================
# CHANGELOG
- 0.13.0.0 (2023-12-30)
* **BREAKING**: Remove `serverRequirePong` option in favor of the new
implementation.
* **BREAKING**: Client: Rejecting request raises
`RequestRejected RequestHead ResponseHead`
* Timeout initial socket connection after 30s.
* If the socket is closed unexpectedly, raise `ConnectionClosed`.
* Added a way to manually send a Pong message.
* `runServer` now cleans up threads correctly.
* Remove redundant bytestring-builder dependency.
* Introduce `Network.WebSockets.Connection.PingPong` to
handle ping pong for any Connection, be it Client or Server.
* Bump `text `dependency upper bound to 2.2
* Bump `random `dependency lower bound to 1.0.1
- 0.12.7.3 (2021-10-26)
* Bump `attoparsec` dependency upper bound to 0.15
- 0.12.7.2 (2020-12-07)
* Bump `QuickCheck` dependency upper bound to 2.15
* Bump `base64-bytestring` dependency upper bound to 1.3
* Bump `bytestring` dependency upper bound to 0.12
* Bump `random` dependency upper bound to 1.3
- 0.12.7.1 (2020-05-03)
* Bump `base64-bytestring` dependency upper bound to 1.2
- 0.12.7.0 (2019-12-31)
* Bump `base` lower bound to 4.8, this drops support for GHC 7.6 and 7.8
* Add a new `runServerWithOptions` that can be extended in a more
future-compatible way
* Add a connection killer setting in `runServerWithOptions`
* Fix an unsafe read issue in `decodeResponseHead`
- 0.12.6.1 (2019-10-29)
* Bump `network` dependency to 3.1
- 0.12.6.0 (2019-10-28)
* Expose a lower-level API to construct client connections (by Philipp
Balzarek)
* Close underlying stream only on synchronous exceptions, not asynchronous
exceptions (by kamoii)
* Add a `withPingThread` and lower-level `pingThread` to replace
`forkPingThread`
* Bump `QuickCheck` dependency to 2.13
- 0.12.5.3 (2019-01-31)
* Bump `network` dependency to 3.0
- 0.12.5.2 (2018-09-25)
* Bump `containers` dependency to 0.6
* Bump `network` dependency to 2.8
* Bump `QuickCheck` dependency to 2.12
* Bump `binary` dependency to 0.10
- 0.12.5.1 (2018-06-12)
* Fix build with GHC 7.6 and 7.8
- 0.12.5.0 (2018-06-01)
* Add `newClientConnection` (by Renzo Carbonara)
- 0.12.4.1 (2018-05-11)
* Bump `network` dependency to 2.7
- 0.12.4.0 (2018-03-13)
* Remove `blaze-builder` dependency
* Bump `streaming-commons` dependency to 0.2
* Bump `QuickCheck` dependency to 2.11
* Fix compatibility with old GHC versions
* Re-export more functions from `Network.WebSockets`
- `sendDataMessages`
- `sendBinaryDatas`
- `sendCloseCode`
* Don't crash when sending the empty list of messages
* Add `SemiGroup` instance for `SizeLimit`
- 0.12.3.1 (2018-01-10)
* Bump CHANGELOG with IPv6 warning
* Run all autobahn tests during CI
- 0.12.3.0 (2018-01-02)
* Fix error thrown from runClient functions
* Bump `QuickCheck` dependency to 2.10
* Bump `entropy` dependency to 0.4
* Bump `binary` dependency to 0.10
- 0.12.2.0 (2017-07-28)
* Don't use LambdaCase, we want to support older GHC versions
- 0.12.1.0 (2017-07-22)
* Fix Monoid import on older base versions
* Increase lower bound on `binary` to 0.8.1 (by Jonathan Daugherty)
- 0.12.0.0
* Add limit options for frame and message size to prevent against (D)DoS
attacks
* Fix space leak in encodeMessages (by Roman Borschel)
* Stricter frame/encoding decoding for ping/close frames (by Lars Petersen)
- 0.11.2.0
* Fix 0-width reason phrase parsing
* Change receive buffer from 1024 to 8192 bytes (by Ondrej Palkovsky)
* Implement fast masking in C (by Ondrej Palkovsky and myself)
* Some haddock improvements
* Bump `HUnit` dependency to 1.6
- 0.11.1.0
* Fix compilation issue with GHC-7.8
- 0.11.0.0
* Support for IPv6 in the built-in server, client and tests (by agentm).
This can cause issues on backends that do not enable IPv6. For more
information and a workaround, see this issue:
<https://github.com/jaspervdj/websockets/issues/140#issuecomment-296732964>.
* Faster masking (by Dmitry Ivanov)
* Support for `permessage-deflate` extension (by Marcin Tolysz)
* Strict unicode checking and proper extension mechanism
- 0.10.0.0
* Fix client specifying empty path
* Allow sending collections of messages (by David Turner)
* Allow sending extra headers when accepting request (by James Deery)
- 0.9.8.2
* Bump `HUnit` dependency to 1.5
- 0.9.8.1
* Restore state of the package to version `0.9.7.0`
- 0.9.8.0
* This release contained a feature which broke backwards-compatibility.
Hence, it was marked as broken a new release containing the changes will
be uploaded as `0.10.0.0`.
- 0.9.7.0
* Fix issue trying to kill builtin server
* Bump `QuickCheck` dependency to 2.9
- 0.9.6.2
* Bump `binary` dependency for GHC 8.0 compatibility
- 0.9.6.1
* Fix issue with fragmentation test
- 0.9.6.0
* Optionally include example server in the cabal file
* Send correct port from client
* Set `TCP_NO_DELAY` in builtin server
* Bump `HUnit` dependency
* Drop dependency on `mtl`
* Fix `QuickCheck` dependency lower bound
- 0.9.5.0
* Bugfixes wrt closing sockets and streams
- 0.9.4.0
* Add `makePendingConnectionFromStream` function
* Bump `attoparsec` dependency
- 0.9.3.1
* Bump `QuickCheck` dependency
- 0.9.3.0
* Use a shared closed state for connection input/output stream
* Make sure `runServer` doesn't leak any sockets
* Bump `blaze-builder` dependency
- 0.9.2.2
* Bump `random` dependency
- 0.9.2.1
* Fix exception handling issues
- 0.9.2.0
* Make sending and receiving messages thread-safe by default
* Export `forkPingThread`
* Fix Windows `withSocketsDo` issue
- 0.9.1.0
* Don't use Network.ByteString.Lazy.sendAll on Windows
- 0.9.0.1
* Allow compilation with older bytestring versions
* Bump text dependency
- 0.9.0.0
* Bump various dependencies
* Remove io-streams dependency
* New close mechanism
* More flexible API interface
- 0.8.2.6
* Bump QuickCheck dependency
- 0.8.2.5
* Bump attoparsec dependency
- 0.8.2.4
* Bump entropy dependency
- 0.8.2.3
* Bump mtl dependency
- 0.8.2.2
* Bump network dependency
- 0.8.2.1
* Add benchmark with many open connections
* Update example to use gender-neutral language
- 0.8.2.0
* Fix possible leaking of client sockets when connection times out
================================================
FILE: LICENCE
================================================
Copyright Jasper Van der Jeugt, 2011
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Siniša Biđin nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
================================================
FILE: README.md
================================================
# websockets
Provides a sensible, clean and simple way to write WebSocket
server and client in Haskell.
## Features
- Provides Server/Client implementations of the websocket protocol
- `withPingPong` helper for stale connection checking
- TLS support via [wuss](https://hackage.haskell.org/package/wuss) package
## Caveats
- [`send` doesn't support streaming](https://github.com/jaspervdj/websockets/issues/119)
- [Requires careful handling of exceptions](https://github.com/jaspervdj/websockets/issues/48)
- [DeflateCompression isn't thread-safe](https://github.com/jaspervdj/websockets/issues/208)
## Introduction
See [server](./example/server.lhs) and [client](./example/client.hs) implementations.
## Installation
Using cabal:
```
$ cabal install websockets
```
## Authors
An initial WebSockets library was written in 2010 by Siniša Biđin. In 2011, it
was rewritten from scratch, and extended to its current state by Jasper Van der
Jeugt, who is also the current maintainer.
Contributors:
- Alex Lang
- Carl Chatfield
- Fedor Gogolev
- Marcin Tolysz
- Nathan Howell
- Steffen Schuldenzucker
- Yi Huang
- Domen Kožar
## Development
Pull requests are always welcome!
This library is production-quality. Therefore we have very high standards in
terms of code style, API quality and testing.
We have three kinds of tests:
- Haskell-based tests (`tests/haskell`), which use the `test-framework` library
- Integration tests, available in `tests/javascript`. These require a browser to
run.
- We also run the extensive [autobahn testsuite].
[autobahn testsuite]: https://github.com/crossbario/autobahn-testsuite
================================================
FILE: Setup.hs
================================================
import Distribution.Simple
main = defaultMain
================================================
FILE: benchmarks/echo.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
import Control.Monad (forever)
import qualified Network.WebSockets as WS
echo :: WS.Connection -> IO ()
echo conn = forever $ do
msg <- WS.receiveDataMessage conn
WS.sendDataMessage conn msg
main :: IO ()
main = WS.runServer "0.0.0.0" 9160 $ \pending -> do
conn <- WS.acceptRequest pending
echo conn
================================================
FILE: benchmarks/echo.js
================================================
/* This WebSockets client opens an increasingly larger number of connections to
* localhost and sends messages on all connections.
*
* It is written in JavaScript since benchmarking my own library using my own
* library might give a skewed perspective.
*
* Requires the `ws` npm module, install using:
*
* npm install --user-install ws
*
* */
var WebSocket = require('ws');
/* Configuration. */
var websocketPort = 9160;
var spawnClientInterval = 100;
var nextClientId = 0;
var messageInterval = 100;
setInterval(function() {
var numberOfSentMessages = 0;
var clientId = nextClientId;
nextClientId += 1;
console.log('Client ' + clientId + ': spawning...');
var sentMessage = undefined;
var ws = new WebSocket('http://localhost:' + websocketPort + '/echo');
ws.on('open', function() {
ws.on('message', function(msg) {
msg = msg.toString();
if (msg === sentMessage && numberOfSentMessages % 100 === 0) {
console.log('Client ' + clientId + ': ' + numberOfSentMessages +
' OK messages');
}
if (msg !== sentMessage) {
console.error('Client ' + clientId + ': unexpected response: ' +
'got "' + msg + '", expected: "' + sentMessage + '"');
}
});
setInterval(function() {
sentMessage = 'Hello ' + Math.floor(Math.random() * 10);
ws.send(sentMessage, {binary: true, mask: false});
numberOfSentMessages++;
}, messageInterval);
});
}, spawnClientInterval);
================================================
FILE: benchmarks/mask.hs
================================================
{-# language BangPatterns #-}
{-# language OverloadedStrings #-}
import Criterion
import Criterion.Main
import qualified Data.Binary.Get as Get
import Network.WebSockets.Hybi13.Mask
import Data.Bits (shiftR, xor)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
setupEnv = do
let kilo = BL.replicate 1024 37
mega = BL.replicate (1024 * 1024) 37
megaU = BL.fromChunks [B.drop 1 (B.replicate (1024 * 1024) 37)]
megaS = BL.fromChunks [B.replicate (1024 * 1024) 37]
return (kilo, mega, megaU, megaS)
maskPayload' :: Maybe B.ByteString -> BL.ByteString -> BL.ByteString
maskPayload' Nothing = id
maskPayload' (Just mask) = snd . BL.mapAccumL f (cycle $ B.unpack mask)
where
f [] !c = ([], c)
f (m:ms) !c = (ms, m `xor` c)
main = defaultMain [
env setupEnv $ \ ~(kilo, mega, megaU, megaS) -> bgroup "main"
[ bgroup "kilobyte payload"
[ bgroup "zero_mask"
[ bench "current" $ nf (maskPayload (mkMask $ "\x00\x00\x00\x00")) kilo
, bench "old" $ nf (maskPayload' (Just "\x00\x00\x00\x00")) kilo
]
, bgroup "full_mask"
[ bench "current" $ nf (maskPayload (mkMask "\xFF\xFF\xFF\xFF")) kilo
, bench "current-unaligned" $ nf (maskPayload (mkMask "\xFF\xFF\xFF\xFF")) (BL.drop 1 kilo)
, bench "old" $ nf (maskPayload' (Just "\xFF\xFF\xFF\xFF")) kilo
]
, bgroup "one_byte_mask"
[ bench "current" $ nf (maskPayload (mkMask "\xCC\xCC\xCC\xCC")) kilo
, bench "old" $ nf (maskPayload' (Just "\xCC\xCC\xCC\xCC")) kilo
]
, bgroup "other_mask"
[ bench "current" $ nf (maskPayload (mkMask "\xB0\xA2\xB0\xA2")) kilo
, bench "old" $ nf (maskPayload' (Just "\xB0\xA2\xB0\xA2")) kilo
]
]
, bgroup "megabyte payload"
[ bgroup "zero_mask"
[ bench "current" $ nf (maskPayload (mkMask "\x00\x00\x00\x00")) mega
, bench "old" $ nf (maskPayload' (Just "\x00\x00\x00\x00")) mega
]
, bgroup "full_mask"
[ bench "current" $ nf (maskPayload (mkMask "\xFF\xFF\xFF\xFF")) mega
, bench "current-unaligned" $ nf (maskPayload (mkMask "\xFF\xFF\xFF\xFF")) megaU
, bench "current-aligned" $ nf (maskPayload (mkMask "\xFF\xFF\xFF\xFF")) megaS
, bench "old" $ nf (maskPayload' (Just "\xFF\xFF\xFF\xFF")) mega
]
, bgroup "one_byte_mask"
[ bench "current" $ nf (maskPayload (mkMask "\xCC\xCC\xCC\xCC")) mega
, bench "old" $ nf (maskPayload' (Just "\xCC\xCC\xCC\xCC")) mega
]
, bgroup "other_mask"
[ bench "current" $ nf (maskPayload (mkMask "\xB0\xA2\xB0\xA2")) mega
, bench "old" $ nf (maskPayload' (Just "\xB0\xA2\xB0\xA2")) mega
]
]
]
]
where
mkMask b = Just $ Get.runGet parseMask b
================================================
FILE: benchmarks/ping.hs
================================================
--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
module Main where
--------------------------------------------------------------------------------
import Control.Monad (forever)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import qualified Network.WebSockets as WS
--------------------------------------------------------------------------------
ping :: WS.ServerApp
ping pending = do
conn <- WS.acceptRequest pending
WS.sendTextData conn ("Ping 0" :: B.ByteString)
forever $ do
msg <- WS.receiveData conn
let n = read (BC.unpack (B.drop 5 msg)) :: Int
WS.sendTextData conn $ BC.pack $ "Ping " ++ show (n + 1)
--------------------------------------------------------------------------------
main :: IO ()
main = WS.runServer "0.0.0.0" 8088 ping
================================================
FILE: benchmarks/ping.html
================================================
<!DOCTYPE html>
<html>
<head>
<title>Ping benchmark</title>
<script type="text/JavaScript"
src="http://code.jquery.com/jquery-1.6.3.min.js"></script>
<script type="text/JavaScript">
$(document).ready(function () {
var host = window.location.hostname;
if(host == '') host = 'localhost';
var uri = 'ws://' + host + ':8088';
/* Number of pings in the last second */
var pings = 0;
$('#stats').text('Opening WebSocket...');
Socket = "WebSocket" in window ? WebSocket : MozWebSocket;
var ws = new Socket(uri);
ws.onopen = function() {
window.setInterval(function () {
$('#stats').text(pings + ' ping/s');
pings = 0;
}, 1000);
};
ws.onmessage = function (event) {
var msg = event.data;
if(msg.substr(0, 5) == 'Ping ') {
var n = parseInt(msg.substr(5));
ws.send('Pong ' + n);
pings++;
}
};
});
</script>
</head>
<body>
<h1>Ping benchmark</h1>
<div id="stats">
</div>
</body>
</html>
================================================
FILE: cbits/cbits.c
================================================
#include <stdint.h>
#include <string.h>
#include <limits.h>
#include <assert.h>
/* Taken from:
*
* <http://stackoverflow.com/questions/776508/best-practices-for-circular-shift-rotate-operations-in-c>
*/
static inline uint32_t rotr32(uint32_t n, unsigned int c) {
const unsigned int mask = (CHAR_BIT*sizeof(n)-1);
c &= mask; /* avoid undef behaviour with NDEBUG. 0 overhead for most types / compilers */
return (n>>c) | (n<<( (-c)&mask ));
}
/* - `mask` is the 4-byte mask to apply to the source. It is stored in the
* hosts' native byte ordering.
* - `mask_offset` is the initial offset in the mask. It is specified in bytes
* and should be between 0 and 3 (inclusive). This is necessary for when we
* are dealing with multiple chunks.
* - `src` is the source pointer.
* - `len` is the size of the source (and destination) in bytes.
* - `dst` is the destination.
*/
void _hs_mask_chunk(
uint32_t mask, int mask_offset,
uint8_t *src, size_t len,
uint8_t *dst) {
const uint8_t *src_end = src + len;
/* We have two fast paths: one for `x86_64` and one for `i386`
* architectures. In these fast paths, we mask 8 (or 4) bytes at a time.
*
* Note that we use unaligned loads and stores (allowed on these
* architectures). This makes the code much easier to write, since we don't
* need to guarantee that `src` and `dst` have the same alignment.
*
* It only causes a minor slowdown, around 5% on my machine (TM).
*/
#if defined(__x86_64__)
uint64_t mask64;
/* Set up 64 byte mask. */
mask64 = (uint64_t)(rotr32(mask, 8 * mask_offset));
mask64 |= (mask64 << 32);
/* Take the fast road. */
while (src < src_end - 7) {
*(uint64_t *)dst = *(uint64_t*)src ^ mask64;
src += 8;
dst += 8;
}
#elif defined(__i386__)
/* Set up 32 byte mask. */
uint32_t mask32;
mask32 = (uint32_t)(rotr32(mask, 8 * mask_offset));
/* Take the fast road. */
while (src < src_end - 3) {
*(uint32_t *)dst = *(uint32_t*)src ^ mask32;
src += 4;
dst += 4;
}
#endif
/* This is the slow path which also handles the un-aligned suffix. */
uint8_t *mask_ptr = (uint8_t *) &mask;
while (src != src_end) {
*dst = *src ^ *(mask_ptr + mask_offset);
src++;
dst++;
mask_offset = (mask_offset + 1) & 0x3;
}
}
================================================
FILE: coverage.sh
================================================
#!/bin/bash
EXCLUDES=$(find tests/haskell -name '*.hs' |
xargs sed -n 's/^module //p' |
sed 's/^/--exclude=/' |
xargs echo)
TARGET=websockets-tests
cabal configure --enable-tests --ghc-options='-fhpc' && cabal build
./dist/build/$TARGET/$TARGET
mkdir -p tests/coverage
hpc markup --destdir=tests/coverage --exclude=Main $EXCLUDES $TARGET.tix
hpc report --exclude=Main $EXCLUDES $TARGET.tix
rm $TARGET.tix
echo "Output written to tests/coverage/hpc_index.html"
================================================
FILE: example/client.hs
================================================
--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
module Main
( main
) where
--------------------------------------------------------------------------------
import Control.Concurrent (forkIO)
import Control.Monad (forever, unless)
import Control.Monad.Trans (liftIO)
import Network.Socket (withSocketsDo)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Network.WebSockets as WS
--------------------------------------------------------------------------------
app :: WS.ClientApp ()
app conn = do
putStrLn "Connected!"
-- Fork a thread that writes WS data to stdout
_ <- forkIO $ forever $ do
msg <- WS.receiveData conn
liftIO $ T.putStrLn msg
-- Read from stdin and write to WS
let loop = do
line <- T.getLine
unless (T.null line) $ WS.sendTextData conn line >> loop
loop
WS.sendClose conn ("Bye!" :: Text)
--------------------------------------------------------------------------------
main :: IO ()
main = withSocketsDo $ WS.runClient "echo.websocket.org" 80 "/" app
================================================
FILE: example/client.html
================================================
<!DOCTYPE html>
<html>
<head>
<title>Haskell WebSockets example</title>
<script type="text/JavaScript"
src="https://code.jquery.com/jquery-1.6.3.min.js"></script>
<script type="text/JavaScript" src="client.js"></script>
<link rel="stylesheet" type="text/css" href="screen.css" />
</head>
<body>
<h1>Haskell WebSockets example</h1>
<div id="main">
<div id="warnings">
</div>
<div id="join-section">
<h2>Join</h2>
<form id="join-form" action="javascript: void(0)">
<label for="user">Username: </label>
<input id="user" type="text" size="12" />
<input id="welcome" type="submit" value="Join" />
</form>
</div>
<div id="users-section" style="display: none">
<h2>Users</h2>
<ul id="users">
</ul>
</div>
<div id="chat-section" style="display: none">
<h2>Chat</h2>
<div id="messages">
</div>
<br />
<form id="message-form" action="javascript: void(0)">
<input id="text" type="text" size="40" />
<input id="talk" type="submit" value="Send" />
</form>
</div>
</div>
<div id="footer">
Source code available <a href="http://github.com/jaspervdj/websockets/tree/master/example">here</a>
</div>
</body>
</html>
================================================
FILE: example/client.js
================================================
function createChatSocket() {
if(window.location.host == '') {
/* Running on localhost */
return new WebSocket('ws://localhost:9160/');
} else {
/* Running in "production" */
return new WebSocket('wss://jaspervdj.be/websockets/example/chat/');
}
}
var users = [];
function refreshUsers() {
$('#users').html('');
for(i in users) {
$('#users').append($(document.createElement('li')).text(users[i]));
}
}
function onMessage(event) {
var p = $(document.createElement('p')).text(event.data);
$('#messages').append(p);
$('#messages').animate({scrollTop: $('#messages')[0].scrollHeight});
if(event.data.match(/^[^:]* joined/)) {
var user = event.data.replace(/ .*/, '');
users.push(user);
refreshUsers();
}
if(event.data.match(/^[^:]* disconnected/)) {
var user = event.data.replace(/ .*/, '');
var idx = users.indexOf(user);
users = users.slice(0, idx).concat(users.slice(idx + 1));
refreshUsers();
}
}
$(document).ready(function () {
$('#join-form').submit(function () {
$('#warnings').html('');
var user = $('#user').val();
var ws = createChatSocket();
ws.onopen = function() {
ws.send('Hi! I am ' + user);
};
ws.onmessage = function(event) {
if(event.data.match('^Welcome! Users: ')) {
/* Calculate the list of initial users */
var str = event.data.replace(/^Welcome! Users: /, '');
if(str != "") {
users = str.split(", ");
refreshUsers();
}
$('#join-section').hide();
$('#chat-section').show();
$('#users-section').show();
ws.onmessage = onMessage;
$('#message-form').submit(function () {
var text = $('#text').val();
ws.send(text);
$('#text').val('');
return false;
});
} else {
$('#warnings').append(event.data);
ws.close();
}
};
$('#join').append('Connecting...');
return false;
});
});
================================================
FILE: example/screen.css
================================================
html {
font-family: sans-serif;
background-color: #335;
font-size: 16px;
}
body {
}
h1 {
text-align: center;
font-size: 20px;
color: #fff;
padding: 10px 10px 20px 10px;
}
h2 {
border-bottom: 1px solid black;
display: block;
font-size: 18px;
}
div#main {
width: 600px;
margin: 0px auto 0px auto;
padding: 0px;
background-color: #fff;
height: 460px;
}
div#warnings {
color: red;
font-weight: bold;
margin: 10px;
}
div#join-section {
float: left;
margin: 10px;
}
div#users-section {
width: 170px;
float: right;
padding: 0px;
margin: 10px;
}
ul#users {
list-style-type: none;
padding-left: 0px;
height: 300px;
overflow: auto;
}
div#chat-section {
width: 390px;
float: left;
margin: 10px;
}
div#messages {
margin: 0px;
height: 300px;
overflow: auto;
}
div#messages p {
margin: 0px;
padding: 0px;
}
div#footer {
text-align: center;
font-size: 12px;
color: #fff;
margin: 10px 0px 30px 0px;
}
div#footer a {
color: #fff;
}
div.clear {
clear: both;
}
================================================
FILE: example/server.lhs
================================================
websockets example
==================
This is the Haskell implementation of the example for the WebSockets library. We
implement a simple multi-user chat program. A live demo of the example is
available [here](/example/client.html). In order to understand this example,
keep the [reference](/reference/) nearby to check out the functions we use.
> {-# LANGUAGE OverloadedStrings #-}
> module Main where
> import Data.Char (isPunctuation, isSpace)
> import Data.Monoid (mappend)
> import Data.Text (Text)
> import Control.Exception (finally)
> import Control.Monad (forM_, forever)
> import Control.Concurrent (MVar, newMVar, modifyMVar_, modifyMVar, readMVar)
> import qualified Data.Text as T
> import qualified Data.Text.IO as T
> import qualified Network.WebSockets as WS
We represent a client by their username and a `WS.Connection`. We will see how we
obtain this `WS.Connection` later on.
> type Client = (Text, WS.Connection)
The state kept on the server is simply a list of connected clients. We've added
an alias and some utility functions, so it will be easier to extend this state
later on.
> type ServerState = [Client]
Create a new, initial state:
> newServerState :: ServerState
> newServerState = []
Get the number of active clients:
> numClients :: ServerState -> Int
> numClients = length
Check if a user already exists (based on username):
> clientExists :: Client -> ServerState -> Bool
> clientExists client = any ((== fst client) . fst)
Add a client (this does not check if the client already exists, you should do
this yourself using `clientExists`):
> addClient :: Client -> ServerState -> ServerState
> addClient client clients = client : clients
Remove a client:
> removeClient :: Client -> ServerState -> ServerState
> removeClient client = filter ((/= fst client) . fst)
Send a message to all clients, and log it on stdout:
> broadcast :: Text -> ServerState -> IO ()
> broadcast message clients = do
> T.putStrLn message
> forM_ clients $ \(_, conn) -> WS.sendTextData conn message
The main function first creates a new state for the server, then spawns the
actual server. For this purpose, we use the simple server provided by
`WS.runServer`.
> main :: IO ()
> main = do
> state <- newMVar newServerState
> WS.runServer "127.0.0.1" 9160 $ application state
Our main application has the type:
> application :: MVar ServerState -> WS.ServerApp
Note that `WS.ServerApp` is nothing but a type synonym for
`WS.PendingConnection -> IO ()`.
Our application starts by accepting the connection. In a more realistic
application, you probably want to check the path and headers provided by the
pending request.
We also fork a pinging thread in the background. This will ensure the connection
stays alive on some browsers.
> application state pending = do
> conn <- WS.acceptRequest pending
> WS.withPingThread conn 30 (return ()) $ do
When a client is succesfully connected, we read the first message. This should
be in the format of "Hi! I am Jasper", where Jasper is the requested username.
> msg <- WS.receiveData conn
> clients <- readMVar state
> case msg of
Check that the first message has the right format:
> _ | not (prefix `T.isPrefixOf` msg) ->
> WS.sendTextData conn ("Wrong announcement" :: Text)
Check the validity of the username:
> | any ($ fst client)
> [T.null, T.any isPunctuation, T.any isSpace] ->
> WS.sendTextData conn ("Name cannot " <>
> "contain punctuation or whitespace, and " <>
> "cannot be empty" :: Text)
Check that the given username is not already taken:
> | clientExists client clients ->
> WS.sendTextData conn ("User already exists" :: Text)
All is right! We're going to allow the client, but for safety reasons we *first*
setup a `disconnect` function that will be run when the connection is closed.
> | otherwise -> flip finally disconnect $ do
We send a "Welcome!", according to our own little protocol. We add the client to
the list and broadcast the fact that he has joined. Then, we give control to the
'talk' function.
> modifyMVar_ state $ \s -> do
> let s' = addClient client s
> WS.sendTextData conn $
> "Welcome! Users: " <>
> T.intercalate ", " (map fst s)
> broadcast (fst client <> " joined") s'
> return s'
> talk client state
> where
> prefix = "Hi! I am "
> client = (T.drop (T.length prefix) msg, conn)
> disconnect = do
> -- Remove client and return new state
> s <- modifyMVar state $ \s ->
> let s' = removeClient client s in return (s', s')
> broadcast (fst client <> " disconnected") s
The talk function continues to read messages from a single client until he
disconnects. All messages are broadcasted to the other clients.
> talk :: Client -> MVar ServerState -> IO ()
> talk (user, conn) state = forever $ do
> msg <- WS.receiveData conn
> readMVar state >>= broadcast
> (user `mappend` ": " `mappend` msg)
================================================
FILE: src/Network/WebSockets/Client.hs
================================================
--------------------------------------------------------------------------------
-- | This part of the library provides you with utilities to create WebSockets
-- clients (in addition to servers).
module Network.WebSockets.Client
( ClientApp
, runClient
, runClientWith
, runClientWithSocket
, runClientWithStream
, newClientConnection
-- * Low level functionality
, createRequest
, Protocol(..)
, defaultProtocol
, checkServerResponse
, streamToClientConnection
) where
--------------------------------------------------------------------------------
import qualified Data.ByteString.Builder as Builder
import Control.Exception (bracket, finally, throwIO)
import Control.Concurrent.MVar (newEmptyMVar)
import Control.Monad (void)
import Data.IORef (newIORef)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Network.Socket as S
import System.Timeout (timeout)
--------------------------------------------------------------------------------
import Network.WebSockets.Connection
import Network.WebSockets.Http
import Network.WebSockets.Protocol
import Network.WebSockets.Stream (Stream)
import qualified Network.WebSockets.Stream as Stream
import Network.WebSockets.Types
--------------------------------------------------------------------------------
-- | A client application interacting with a single server. Once this 'IO'
-- action finished, the underlying socket is closed automatically.
type ClientApp a = Connection -> IO a
--------------------------------------------------------------------------------
-- TODO: Maybe this should all be strings
runClient :: String -- ^ Host
-> Int -- ^ Port
-> String -- ^ Path
-> ClientApp a -- ^ Client application
-> IO a
runClient host port path ws =
runClientWith host port path defaultConnectionOptions [] ws
--------------------------------------------------------------------------------
runClientWith :: String -- ^ Host
-> Int -- ^ Port
-> String -- ^ Path
-> ConnectionOptions -- ^ Options
-> Headers -- ^ Custom headers to send
-> ClientApp a -- ^ Client application
-> IO a
runClientWith host port path0 opts customHeaders app = do
-- Create and connect socket
let hints = S.defaultHints
{S.addrSocketType = S.Stream}
-- Correct host and path.
fullHost = if port == 80 then host else (host ++ ":" ++ show port)
path = if null path0 then "/" else path0
addr:_ <- S.getAddrInfo (Just hints) (Just host) (Just $ show port)
sock <- S.socket (S.addrFamily addr) S.Stream S.defaultProtocol
S.setSocketOption sock S.NoDelay 1
-- Connect WebSocket and run client
res <- bracket
(timeout (connectionTimeout opts * 1000 * 1000) $ S.connect sock (S.addrAddress addr))
(const $ S.close sock) $ \maybeConnected -> case maybeConnected of
Nothing -> throwIO $ ConnectionTimeout
Just () -> runClientWithSocket sock fullHost path opts customHeaders app
-- Clean up
return res
--------------------------------------------------------------------------------
runClientWithStream
:: Stream
-- ^ Stream
-> String
-- ^ Host
-> String
-- ^ Path
-> ConnectionOptions
-- ^ Connection options
-> Headers
-- ^ Custom headers to send
-> ClientApp a
-- ^ Client application
-> IO a
runClientWithStream stream host path opts customHeaders app = do
newClientConnection stream host path opts customHeaders >>= app
-- | Build a new 'Connection' from the client's point of view.
--
-- /WARNING/: Be sure to call 'Stream.close' on the given 'Stream' after you are
-- done using the 'Connection' in order to properly close the communication
-- channel. 'runClientWithStream' handles this for you, prefer to use it when
-- possible.
newClientConnection
:: Stream
-- ^ Stream that will be used by the new 'Connection'.
-> String
-- ^ Host
-> String
-- ^ Path
-> ConnectionOptions
-- ^ Connection options
-> Headers
-- ^ Custom headers to send
-> IO Connection
newClientConnection stream host path opts customHeaders = do
-- Create the request and send it
request <- createRequest protocol bHost bPath False customHeaders
Stream.write stream (Builder.toLazyByteString $ encodeRequestHead request)
checkServerResponse stream request
streamToClientConnection stream opts
where
protocol = defaultProtocol -- TODO
bHost = T.encodeUtf8 $ T.pack host
bPath = T.encodeUtf8 $ T.pack path
-- | Check the response from the server.
-- Throws 'OtherHandshakeException' on failure
checkServerResponse :: Stream -> RequestHead -> IO ()
checkServerResponse stream request = do
mbResponse <- Stream.parse stream decodeResponseHead
response <- case mbResponse of
Just response -> return response
Nothing -> throwIO $ OtherHandshakeException $
"Network.WebSockets.Client.newClientConnection: no handshake " ++
"response from server"
void $ either throwIO return $ finishResponse protocol request response
where
protocol = defaultProtocol -- TODO
-- | Build a 'Connection' from a pre-established stream with already finished
-- handshake.
--
-- /NB/: this will not perform any handshaking.
streamToClientConnection :: Stream -> ConnectionOptions -> IO Connection
streamToClientConnection stream opts = do
parse <- decodeMessages protocol
(connectionFramePayloadSizeLimit opts)
(connectionMessageDataSizeLimit opts) stream
write <- encodeMessages protocol ClientConnection stream
sentRef <- newIORef False
heartbeat <- newEmptyMVar
return $ Connection
{ connectionOptions = opts
, connectionType = ClientConnection
, connectionProtocol = protocol
, connectionParse = parse
, connectionWrite = write
, connectionHeartbeat = heartbeat
, connectionSentClose = sentRef
}
where
protocol = defaultProtocol
--------------------------------------------------------------------------------
runClientWithSocket :: S.Socket -- ^ Socket
-> String -- ^ Host
-> String -- ^ Path
-> ConnectionOptions -- ^ Options
-> Headers -- ^ Custom headers to send
-> ClientApp a -- ^ Client application
-> IO a
runClientWithSocket sock host path opts customHeaders app = bracket
(Stream.makeSocketStream sock)
Stream.close
(\stream ->
runClientWithStream stream host path opts customHeaders app)
================================================
FILE: src/Network/WebSockets/Connection/Options.hs
================================================
{-# LANGUAGE CPP #-}
--------------------------------------------------------------------------------
module Network.WebSockets.Connection.Options
( ConnectionOptions (..)
, defaultConnectionOptions
, CompressionOptions (..)
, PermessageDeflate (..)
, defaultPermessageDeflate
, SizeLimit (..)
, atMostSizeLimit
) where
--------------------------------------------------------------------------------
import Data.Int (Int64)
import Data.Monoid (Monoid (..))
import Prelude
--------------------------------------------------------------------------------
-- | Set options for a 'Connection'. Please do not use this constructor
-- directly, but rather use 'defaultConnectionOptions' and then set the fields
-- you want, e.g.:
--
-- > myOptions = defaultConnectionOptions {connectionStrictUnicode = True}
--
-- This way your code does not break if the library introduces new fields.
data ConnectionOptions = ConnectionOptions
{ connectionOnPong :: !(IO ())
-- ^ Whenever a 'pong' is received, this IO action is executed. It can be
-- used to tickle connections or fire missiles.
, connectionTimeout :: !Int
-- ^ Timeout for connection establishment in seconds. Only used in the client.
, connectionCompressionOptions :: !CompressionOptions
-- ^ Enable 'PermessageDeflate'.
, connectionStrictUnicode :: !Bool
-- ^ Enable strict unicode on the connection. This means that if a client
-- (or server) sends invalid UTF-8, we will throw a 'UnicodeException'
-- rather than replacing it by the unicode replacement character U+FFFD.
, connectionFramePayloadSizeLimit :: !SizeLimit
-- ^ The maximum size for incoming frame payload size in bytes. If a
-- frame exceeds this limit, a 'ParseException' is thrown.
, connectionMessageDataSizeLimit :: !SizeLimit
-- ^ 'connectionFrameSizeLimit' is often not enough since a malicious
-- client can send many small frames to create a huge message. This limit
-- allows you to protect from that. If a message exceeds this limit, a
-- 'ParseException' is thrown.
--
-- Note that, if compression is enabled, we check the size of the
-- compressed messages, as well as the size of the uncompressed messages
-- as we are deflating them to ensure we don't use too much memory in any
-- case.
}
--------------------------------------------------------------------------------
-- | The default connection options:
--
-- * Nothing happens when a pong is received.
-- * Compression is disabled.
-- * Lenient unicode decoding.
-- * 30 second timeout for connection establishment.
defaultConnectionOptions :: ConnectionOptions
defaultConnectionOptions = ConnectionOptions
{ connectionOnPong = return ()
, connectionTimeout = 30
, connectionCompressionOptions = NoCompression
, connectionStrictUnicode = False
, connectionFramePayloadSizeLimit = mempty
, connectionMessageDataSizeLimit = mempty
}
--------------------------------------------------------------------------------
data CompressionOptions
= NoCompression
| PermessageDeflateCompression PermessageDeflate
deriving (Eq, Show)
--------------------------------------------------------------------------------
-- | Four extension parameters are defined for "permessage-deflate" to
-- help endpoints manage per-connection resource usage.
--
-- - "server_no_context_takeover"
-- - "client_no_context_takeover"
-- - "server_max_window_bits"
-- - "client_max_window_bits"
data PermessageDeflate = PermessageDeflate
{ serverNoContextTakeover :: Bool
, clientNoContextTakeover :: Bool
, serverMaxWindowBits :: Int
, clientMaxWindowBits :: Int
, pdCompressionLevel :: Int
} deriving (Eq, Show)
--------------------------------------------------------------------------------
defaultPermessageDeflate :: PermessageDeflate
defaultPermessageDeflate = PermessageDeflate False False 15 15 8
--------------------------------------------------------------------------------
-- | A size limit, in bytes. The 'Monoid' instance takes the minimum limit.
data SizeLimit
= NoSizeLimit
| SizeLimit !Int64
deriving (Eq, Show)
--------------------------------------------------------------------------------
instance Monoid SizeLimit where
mempty = NoSizeLimit
#if !MIN_VERSION_base(4,11,0)
mappend NoSizeLimit y = y
mappend x NoSizeLimit = x
mappend (SizeLimit x) (SizeLimit y) = SizeLimit (min x y)
#else
instance Semigroup SizeLimit where
(<>) NoSizeLimit y = y
(<>) x NoSizeLimit = x
(<>) (SizeLimit x) (SizeLimit y) = SizeLimit (min x y)
#endif
--------------------------------------------------------------------------------
atMostSizeLimit :: Int64 -> SizeLimit -> Bool
atMostSizeLimit _ NoSizeLimit = True
atMostSizeLimit s (SizeLimit l) = s <= l
{-# INLINE atMostSizeLimit #-}
================================================
FILE: src/Network/WebSockets/Connection/PingPong.hs
================================================
module Network.WebSockets.Connection.PingPong
( withPingPong
, PingPongOptions(..)
, PongTimeout(..)
, defaultPingPongOptions
) where
import Control.Concurrent.Async as Async
import Control.Exception
import Control.Monad (void)
import Network.WebSockets.Connection (Connection, connectionHeartbeat, pingThread)
import Control.Concurrent.MVar (takeMVar)
import System.Timeout (timeout)
-- | Exception type used to kill connections if there
-- is a pong timeout.
data PongTimeout = PongTimeout deriving Show
instance Exception PongTimeout
-- | Options for ping-pong
--
-- Make sure that the ping interval is less than the pong timeout,
-- for example N/2.
data PingPongOptions = PingPongOptions {
pingInterval :: Int, -- ^ Interval in seconds
pongTimeout :: Int, -- ^ Timeout in seconds
pingAction :: IO () -- ^ Action to perform after sending a ping
}
-- | Default options for ping-pong
--
-- Ping every 15 seconds, timeout after 30 seconds
defaultPingPongOptions :: PingPongOptions
defaultPingPongOptions = PingPongOptions {
pingInterval = 15,
pongTimeout = 30,
pingAction = return ()
}
-- | Run an application with ping-pong enabled. Raises 'PongTimeout' if a pong
-- is not received.
--
-- Can used with Client and Server connections.
--
-- The implementation uses multiple threads, so if you want to call this from a
-- Monad other than 'IO', we recommend using
-- [unliftio](https://hackage.haskell.org/package/unliftio), e.g. using a
-- wrapper like this:
--
-- > withPingPongUnlifted
-- > :: MonadUnliftIO m
-- > => PingPongOptions -> Connection -> (Connection -> m ()) -> m ()
-- > withPingPongUnlifted options connection app = withRunInIO $ \run ->
-- > withPingPong options connection (run . app)
withPingPong :: PingPongOptions -> Connection -> (Connection -> IO ()) -> IO ()
withPingPong options connection app = void $
withAsync (app connection) $ \appAsync -> do
withAsync (pingThread connection (pingInterval options) (pingAction options)) $ \pingAsync -> do
withAsync (heartbeat >> throwIO PongTimeout) $ \heartbeatAsync -> do
waitAnyCancel [appAsync, pingAsync, heartbeatAsync]
where
heartbeat = whileJust $ timeout (pongTimeout options * 1000 * 1000)
$ takeMVar (connectionHeartbeat connection)
-- Loop until action returns Nothing
whileJust :: IO (Maybe a) -> IO ()
whileJust action = do
result <- action
case result of
Nothing -> return ()
Just _ -> whileJust action
================================================
FILE: src/Network/WebSockets/Connection.hs
================================================
--------------------------------------------------------------------------------
-- | This module exposes connection internals
{-# LANGUAGE OverloadedStrings #-}
module Network.WebSockets.Connection
( PendingConnection (..)
, acceptRequest
, AcceptRequest(..)
, defaultAcceptRequest
, acceptRequestWith
, rejectRequest
, RejectRequest(..)
, defaultRejectRequest
, rejectRequestWith
, Connection (..)
, ConnectionOptions (..)
, defaultConnectionOptions
, receive
, receiveDataMessage
, receiveData
, send
, sendDataMessage
, sendDataMessages
, sendTextData
, sendTextDatas
, sendBinaryData
, sendBinaryDatas
, sendClose
, sendCloseCode
, sendPing
, sendPong
, withPingThread
, forkPingThread
, pingThread
, CompressionOptions (..)
, PermessageDeflate (..)
, defaultPermessageDeflate
, SizeLimit (..)
) where
--------------------------------------------------------------------------------
import Control.Applicative ((<$>))
import Control.Concurrent (forkIO,
threadDelay)
import qualified Control.Concurrent.Async as Async
import Control.Concurrent.MVar (MVar, newEmptyMVar, tryPutMVar)
import Control.Exception (AsyncException,
fromException,
handle,
throwIO)
import Control.Monad (foldM, unless,
when)
import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as Builder
import qualified Data.ByteString.Char8 as B8
import Data.IORef (IORef,
newIORef,
readIORef,
writeIORef)
import Data.List (find)
import Data.Maybe (catMaybes)
import qualified Data.Text as T
import Data.Word (Word16)
import Prelude
--------------------------------------------------------------------------------
import Network.WebSockets.Connection.Options
import Network.WebSockets.Extensions as Extensions
import Network.WebSockets.Extensions.PermessageDeflate
import Network.WebSockets.Extensions.StrictUnicode
import Network.WebSockets.Http
import Network.WebSockets.Protocol
import Network.WebSockets.Stream (Stream)
import qualified Network.WebSockets.Stream as Stream
import Network.WebSockets.Types
--------------------------------------------------------------------------------
-- | A new client connected to the server. We haven't accepted the connection
-- yet, though.
data PendingConnection = PendingConnection
{ pendingOptions :: !ConnectionOptions
-- ^ Options, passed as-is to the 'Connection'
, pendingRequest :: !RequestHead
-- ^ Useful for e.g. inspecting the request path.
, pendingOnAccept :: !(Connection -> IO ())
-- ^ One-shot callback fired when a connection is accepted, i.e., *after*
-- the accepting response is sent to the client.
, pendingStream :: !Stream
-- ^ Input/output stream
}
--------------------------------------------------------------------------------
-- | This datatype allows you to set options for 'acceptRequestWith'. It is
-- strongly recommended to use 'defaultAcceptRequest' and then modify the
-- various fields, that way new fields introduced in the library do not break
-- your code.
data AcceptRequest = AcceptRequest
{ acceptSubprotocol :: !(Maybe B.ByteString)
-- ^ The subprotocol to speak with the client. If 'pendingSubprotcols' is
-- non-empty, 'acceptSubprotocol' must be one of the subprotocols from the
-- list.
, acceptHeaders :: !Headers
-- ^ Extra headers to send with the response.
}
--------------------------------------------------------------------------------
defaultAcceptRequest :: AcceptRequest
defaultAcceptRequest = AcceptRequest Nothing []
--------------------------------------------------------------------------------
-- | Utility
sendResponse :: PendingConnection -> Response -> IO ()
sendResponse pc rsp = Stream.write (pendingStream pc)
(Builder.toLazyByteString (encodeResponse rsp))
--------------------------------------------------------------------------------
-- | Accept a pending connection, turning it into a 'Connection'.
acceptRequest :: PendingConnection -> IO Connection
acceptRequest pc = acceptRequestWith pc defaultAcceptRequest
--------------------------------------------------------------------------------
-- | This function is like 'acceptRequest' but allows you to set custom options
-- using the 'AcceptRequest' datatype.
acceptRequestWith :: PendingConnection -> AcceptRequest -> IO Connection
acceptRequestWith pc ar = case find (flip compatible request) protocols of
Nothing -> do
sendResponse pc $ response400 versionHeader ""
throwIO NotSupported
Just protocol -> do
-- Get requested list of exceptions from client.
rqExts <- either throwIO return $
getRequestSecWebSocketExtensions request
-- Set up permessage-deflate extension if configured.
pmdExt <- case connectionCompressionOptions (pendingOptions pc) of
NoCompression -> return Nothing
PermessageDeflateCompression pmd0 ->
case negotiateDeflate (connectionMessageDataSizeLimit options) (Just pmd0) rqExts of
Left err -> do
rejectRequestWith pc defaultRejectRequest {rejectMessage = B8.pack err}
throwIO NotSupported
Right pmd1 -> return (Just pmd1)
-- Set up strict utf8 extension if configured.
let unicodeExt =
if connectionStrictUnicode (pendingOptions pc)
then Just strictUnicode else Nothing
-- Final extension list.
let exts = catMaybes [pmdExt, unicodeExt]
let subproto = maybe [] (\p -> [("Sec-WebSocket-Protocol", p)]) $ acceptSubprotocol ar
headers = subproto ++ acceptHeaders ar ++ concatMap extHeaders exts
response = finishRequest protocol request headers
either throwIO (sendResponse pc) response
parseRaw <- decodeMessages
protocol
(connectionFramePayloadSizeLimit options)
(connectionMessageDataSizeLimit options)
(pendingStream pc)
writeRaw <- encodeMessages protocol ServerConnection (pendingStream pc)
write <- foldM (\x ext -> extWrite ext x) writeRaw exts
parse <- foldM (\x ext -> extParse ext x) parseRaw exts
sentRef <- newIORef False
heartbeat <- newEmptyMVar
let connection = Connection
{ connectionOptions = options
, connectionType = ServerConnection
, connectionProtocol = protocol
, connectionParse = parse
, connectionWrite = write
, connectionHeartbeat = heartbeat
, connectionSentClose = sentRef
}
pendingOnAccept pc connection
return connection
where
options = pendingOptions pc
request = pendingRequest pc
versionHeader = [("Sec-WebSocket-Version",
B.intercalate ", " $ concatMap headerVersions protocols)]
--------------------------------------------------------------------------------
-- | Parameters that allow you to tweak how a request is rejected. Please use
-- 'defaultRejectRequest' and modify fields using record syntax so your code
-- will not break when new fields are added.
data RejectRequest = RejectRequest
{ -- | The status code, 400 by default.
rejectCode :: !Int
, -- | The message, "Bad Request" by default
rejectMessage :: !B.ByteString
, -- | Extra headers to be sent with the response.
rejectHeaders :: Headers
, -- | Reponse body of the rejection.
rejectBody :: !B.ByteString
}
--------------------------------------------------------------------------------
defaultRejectRequest :: RejectRequest
defaultRejectRequest = RejectRequest
{ rejectCode = 400
, rejectMessage = "Bad Request"
, rejectHeaders = []
, rejectBody = ""
}
--------------------------------------------------------------------------------
-- | Requires calling 'pendingStream' and 'Stream.close'.
rejectRequestWith
:: PendingConnection -- ^ Connection to reject
-> RejectRequest -- ^ Params on how to reject the request
-> IO ()
rejectRequestWith pc reject = sendResponse pc $ Response
ResponseHead
{ responseCode = rejectCode reject
, responseMessage = rejectMessage reject
, responseHeaders = rejectHeaders reject
}
(rejectBody reject)
--------------------------------------------------------------------------------
-- | Requires calling 'pendingStream' and 'Stream.close'.
rejectRequest
:: PendingConnection -- ^ Connection to reject
-> B.ByteString -- ^ Rejection response body
-> IO ()
rejectRequest pc body = rejectRequestWith pc
defaultRejectRequest {rejectBody = body}
--------------------------------------------------------------------------------
data Connection = Connection
{ connectionOptions :: !ConnectionOptions
, connectionType :: !ConnectionType
, connectionProtocol :: !Protocol
, connectionHeartbeat :: !(MVar ())
-- ^ This MVar is filled whenever a pong is received. This is used by
-- 'withPingPong' to timeout the connection if a pong is not received.
, connectionParse :: !(IO (Maybe Message))
, connectionWrite :: !([Message] -> IO ())
, connectionSentClose :: !(IORef Bool)
-- ^ According to the RFC, both the client and the server MUST send
-- a close control message to each other. Either party can initiate
-- the first close message but then the other party must respond. Finally,
-- the server is in charge of closing the TCP connection. This IORef tracks
-- if we have sent a close message and are waiting for the peer to respond.
}
--------------------------------------------------------------------------------
receive :: Connection -> IO Message
receive conn = do
mbMsg <- connectionParse conn
case mbMsg of
Nothing -> throwIO ConnectionClosed
Just msg -> return msg
--------------------------------------------------------------------------------
-- | Receive an application message. Automatically respond to control messages.
--
-- When the peer sends a close control message, an exception of type 'CloseRequest'
-- is thrown. The peer can send a close control message either to initiate a
-- close or in response to a close message we have sent to the peer. In either
-- case the 'CloseRequest' exception will be thrown. The RFC specifies that
-- the server is responsible for closing the TCP connection, which should happen
-- after receiving the 'CloseRequest' exception from this function.
--
-- This will throw 'ConnectionClosed' if the TCP connection dies unexpectedly.
receiveDataMessage :: Connection -> IO DataMessage
receiveDataMessage conn = do
msg <- receive conn
case msg of
DataMessage _ _ _ am -> return am
ControlMessage cm -> case cm of
Close i closeMsg -> do
hasSentClose <- readIORef $ connectionSentClose conn
unless hasSentClose $ send conn msg
throwIO $ CloseRequest i closeMsg
Pong _ -> do
_ <- tryPutMVar (connectionHeartbeat conn) ()
connectionOnPong (connectionOptions conn)
receiveDataMessage conn
Ping pl -> do
send conn (ControlMessage (Pong pl))
receiveDataMessage conn
--------------------------------------------------------------------------------
-- | Receive a message, converting it to whatever format is needed.
receiveData :: WebSocketsData a => Connection -> IO a
receiveData conn = fromDataMessage <$> receiveDataMessage conn
--------------------------------------------------------------------------------
send :: Connection -> Message -> IO ()
send conn = sendAll conn . return
--------------------------------------------------------------------------------
sendAll :: Connection -> [Message] -> IO ()
sendAll _ [] = return ()
sendAll conn msgs = do
when (any isCloseMessage msgs) $
writeIORef (connectionSentClose conn) True
connectionWrite conn msgs
where
isCloseMessage (ControlMessage (Close _ _)) = True
isCloseMessage _ = False
--------------------------------------------------------------------------------
-- | Send a 'DataMessage'. This allows you send both human-readable text and
-- binary data. This is a slightly more low-level interface than 'sendTextData'
-- or 'sendBinaryData'.
sendDataMessage :: Connection -> DataMessage -> IO ()
sendDataMessage conn = sendDataMessages conn . return
--------------------------------------------------------------------------------
-- | Send a collection of 'DataMessage's. This is more efficient than calling
-- 'sendDataMessage' many times.
sendDataMessages :: Connection -> [DataMessage] -> IO ()
sendDataMessages conn = sendAll conn . map (DataMessage False False False)
--------------------------------------------------------------------------------
-- | Send a textual message. The message will be encoded as UTF-8. This should
-- be the default choice for human-readable text-based protocols such as JSON.
sendTextData :: WebSocketsData a => Connection -> a -> IO ()
sendTextData conn = sendTextDatas conn . return
--------------------------------------------------------------------------------
-- | Send a number of textual messages. This is more efficient than calling
-- 'sendTextData' many times.
sendTextDatas :: WebSocketsData a => Connection -> [a] -> IO ()
sendTextDatas conn =
sendDataMessages conn .
map (\x -> Text (toLazyByteString x) Nothing)
--------------------------------------------------------------------------------
-- | Send a binary message. This is useful for sending binary blobs, e.g.
-- images, data encoded with MessagePack, images...
sendBinaryData :: WebSocketsData a => Connection -> a -> IO ()
sendBinaryData conn = sendBinaryDatas conn . return
--------------------------------------------------------------------------------
-- | Send a number of binary messages. This is more efficient than calling
-- 'sendBinaryData' many times.
sendBinaryDatas :: WebSocketsData a => Connection -> [a] -> IO ()
sendBinaryDatas conn = sendDataMessages conn . map (Binary . toLazyByteString)
--------------------------------------------------------------------------------
-- | Send a friendly close message. Note that after sending this message,
-- you should still continue calling 'receiveDataMessage' to process any
-- in-flight messages. The peer will eventually respond with a close control
-- message of its own which will cause 'receiveDataMessage' to throw the
-- 'CloseRequest' exception. This exception is when you can finally consider
-- the connection closed.
sendClose :: WebSocketsData a => Connection -> a -> IO ()
sendClose conn = sendCloseCode conn 1000
--------------------------------------------------------------------------------
-- | Send a friendly close message and close code. Similar to 'sendClose',
-- you should continue calling 'receiveDataMessage' until you receive a
-- 'CloseRequest' exception.
--
-- See <http://tools.ietf.org/html/rfc6455#section-7.4> for a list of close
-- codes.
sendCloseCode :: WebSocketsData a => Connection -> Word16 -> a -> IO ()
sendCloseCode conn code =
send conn . ControlMessage . Close code . toLazyByteString
--------------------------------------------------------------------------------
-- | Send a ping
sendPing :: WebSocketsData a => Connection -> a -> IO ()
sendPing conn = send conn . ControlMessage . Ping . toLazyByteString
--------------------------------------------------------------------------------
-- | Send a pong
sendPong :: WebSocketsData a => Connection -> a -> IO ()
sendPong conn = send conn . ControlMessage . Pong . toLazyByteString
--------------------------------------------------------------------------------
-- | Forks a ping thread, sending a ping message every @n@ seconds over the
-- connection. The thread is killed when the inner IO action is finished.
--
-- This is useful to keep idle connections open through proxies and whatnot.
-- Many (but not all) proxies have a 60 second default timeout, so based on that
-- sending a ping every 30 seconds is a good idea.
--
-- Note that usually you want to use 'Network.WebSockets.Connection.PingPong.withPingPong'
-- to timeout the connection if a pong is not received.
withPingThread
:: Connection
-> Int -- ^ Second interval in which pings should be sent.
-> IO () -- ^ Repeat this after sending a ping.
-> IO a -- ^ Application to wrap with a ping thread.
-> IO a -- ^ Executes application and kills ping thread when done.
withPingThread conn n action app =
Async.withAsync (pingThread conn n action) (\_ -> app)
--------------------------------------------------------------------------------
-- | DEPRECATED: Use 'withPingThread' instead.
--
-- Forks a ping thread, sending a ping message every @n@ seconds over the
-- connection. The thread dies silently if the connection crashes or is closed.
--
-- This is useful to keep idle connections open through proxies and whatnot.
-- Many (but not all) proxies have a 60 second default timeout, so based on that
-- sending a ping every 30 seconds is a good idea.
forkPingThread :: Connection -> Int -> IO ()
forkPingThread conn n = do
_ <- forkIO $ pingThread conn n (return ())
return ()
{-# DEPRECATED forkPingThread "Use 'withPingThread' instead" #-}
--------------------------------------------------------------------------------
-- | Use this if you want to run the ping thread yourself.
--
-- See also 'withPingThread'.
pingThread :: Connection -> Int -> IO () -> IO ()
pingThread conn n action
| n <= 0 = return ()
| otherwise = ignore `handle` go 1
where
go :: Int -> IO ()
go i = do
threadDelay (n * 1000 * 1000)
sendPing conn (T.pack $ show i)
action
go (i + 1)
ignore e = case fromException e of
Just async -> throwIO (async :: AsyncException)
Nothing -> return ()
================================================
FILE: src/Network/WebSockets/Extensions/Description.hs
================================================
-- | Code for parsing extensions headers.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.WebSockets.Extensions.Description
( ExtensionParam
, ExtensionDescription (..)
, ExtensionDescriptions
, parseExtensionDescriptions
, encodeExtensionDescriptions
) where
import Control.Applicative ((*>), (<*))
import qualified Data.Attoparsec.ByteString as A
import qualified Data.Attoparsec.ByteString.Char8 as AC8
import qualified Data.ByteString as B
import Data.Monoid (mconcat, mappend)
import Prelude
type ExtensionParam = (B.ByteString, Maybe B.ByteString)
data ExtensionDescription = ExtensionDescription
{ extName :: !B.ByteString
, extParams :: ![ExtensionParam]
} deriving (Eq, Show)
parseExtensionDescription :: A.Parser ExtensionDescription
parseExtensionDescription = do
extName <- parseIdentifier
extParams <- A.many' (token ';' *> parseParam)
return ExtensionDescription {..}
where
parseIdentifier = AC8.takeWhile isIdentifierChar <* AC8.skipSpace
token c = AC8.char8 c <* AC8.skipSpace
isIdentifierChar c =
(c >= 'a' && c <= 'z') ||
(c >= 'A' && c <= 'Z') ||
(c >= '0' && c <= '9') ||
c == '-' || c == '_'
parseParam :: A.Parser ExtensionParam
parseParam = do
name <- parseIdentifier
val <- A.option Nothing $ fmap Just $ token '=' *> parseIdentifier
return (name, val)
encodeExtensionDescription :: ExtensionDescription -> B.ByteString
encodeExtensionDescription ExtensionDescription {..} =
mconcat (extName : map encodeParam extParams)
where
encodeParam (key, Nothing) = ";" `mappend` key
encodeParam (key, Just val) = ";" `mappend` key `mappend` "=" `mappend` val
type ExtensionDescriptions = [ExtensionDescription]
parseExtensionDescriptions :: B.ByteString -> Either String ExtensionDescriptions
parseExtensionDescriptions = A.parseOnly $
AC8.skipSpace *>
A.sepBy parseExtensionDescription (AC8.char8 ',' <* AC8.skipSpace) <*
A.endOfInput
encodeExtensionDescriptions :: ExtensionDescriptions -> B.ByteString
encodeExtensionDescriptions = B.intercalate "," . map encodeExtensionDescription
================================================
FILE: src/Network/WebSockets/Extensions/PermessageDeflate.hs
================================================
--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
module Network.WebSockets.Extensions.PermessageDeflate
( defaultPermessageDeflate
, PermessageDeflate(..)
, negotiateDeflate
-- * Considered internal
, makeMessageInflater
, makeMessageDeflater
) where
--------------------------------------------------------------------------------
import Control.Applicative ((<$>))
import Control.Exception (throwIO)
import Control.Monad (foldM, unless)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BL8
import qualified Data.ByteString.Lazy.Internal as BL
import Data.Int (Int64)
import Data.Monoid
import qualified Data.Streaming.Zlib as Zlib
import Network.WebSockets.Connection.Options
import Network.WebSockets.Extensions
import Network.WebSockets.Extensions.Description
import Network.WebSockets.Http
import Network.WebSockets.Types
import Prelude
import Text.Read (readMaybe)
--------------------------------------------------------------------------------
-- | Convert the parameters to an 'ExtensionDescription' that we can put in a
-- 'Sec-WebSocket-Extensions' header.
toExtensionDescription :: PermessageDeflate -> ExtensionDescription
toExtensionDescription PermessageDeflate {..} = ExtensionDescription
{ extName = "permessage-deflate"
, extParams =
[("server_no_context_takeover", Nothing) | serverNoContextTakeover] ++
[("client_no_context_takeover", Nothing) | clientNoContextTakeover] ++
[("server_max_window_bits", param serverMaxWindowBits) | serverMaxWindowBits /= 15] ++
[("client_max_window_bits", param clientMaxWindowBits) | clientMaxWindowBits /= 15]
}
where
param = Just . B8.pack . show
--------------------------------------------------------------------------------
toHeaders :: PermessageDeflate -> Headers
toHeaders pmd =
[ ( "Sec-WebSocket-Extensions"
, encodeExtensionDescriptions [toExtensionDescription pmd]
)
]
--------------------------------------------------------------------------------
negotiateDeflate
:: SizeLimit -> Maybe PermessageDeflate -> NegotiateExtension
negotiateDeflate messageLimit pmd0 exts0 = do
(headers, pmd1) <- negotiateDeflateOpts exts0 pmd0
return Extension
{ extHeaders = headers
, extParse = \parseRaw -> do
inflate <- makeMessageInflater messageLimit pmd1
return $ do
msg <- parseRaw
case msg of
Nothing -> return Nothing
Just m -> fmap Just (inflate m)
, extWrite = \writeRaw -> do
deflate <- makeMessageDeflater pmd1
return $ \msgs ->
mapM deflate msgs >>= writeRaw
}
where
negotiateDeflateOpts
:: ExtensionDescriptions
-> Maybe PermessageDeflate
-> Either String (Headers, Maybe PermessageDeflate)
negotiateDeflateOpts (ext : _) (Just x)
| extName ext == "x-webkit-deflate-frame" = Right
([("Sec-WebSocket-Extensions", "x-webkit-deflate-frame")], Just x)
negotiateDeflateOpts (ext : _) (Just x)
| extName ext == "permessage-deflate" = do
x' <- foldM setParam x (extParams ext)
Right (toHeaders x', Just x')
negotiateDeflateOpts (_ : exts) (Just x) =
negotiateDeflateOpts exts (Just x)
negotiateDeflateOpts _ _ = Right ([], Nothing)
--------------------------------------------------------------------------------
setParam
:: PermessageDeflate -> ExtensionParam -> Either String PermessageDeflate
setParam pmd ("server_no_context_takeover", _) =
Right pmd {serverNoContextTakeover = True}
setParam pmd ("client_no_context_takeover", _) =
Right pmd {clientNoContextTakeover = True}
setParam pmd ("server_max_window_bits", Nothing) =
Right pmd {serverMaxWindowBits = 15}
setParam pmd ("server_max_window_bits", Just param) = do
w <- parseWindow param
Right pmd {serverMaxWindowBits = w}
setParam pmd ("client_max_window_bits", Nothing) = do
Right pmd {clientMaxWindowBits = 15}
setParam pmd ("client_max_window_bits", Just param) = do
w <- parseWindow param
Right pmd {clientMaxWindowBits = w}
setParam pmd (_, _) = Right pmd
--------------------------------------------------------------------------------
parseWindow :: B.ByteString -> Either String Int
parseWindow bs8 = case readMaybe (B8.unpack bs8) of
Just w
| w >= 8 && w <= 15 -> Right w
| otherwise -> Left $ "Window out of bounds: " ++ show w
Nothing -> Left $ "Can't parse window: " ++ show bs8
--------------------------------------------------------------------------------
-- | If the window_bits parameter is set to 8, we must set it to 9 instead.
--
-- Related issues:
-- - https://github.com/haskell/zlib/issues/11
-- - https://github.com/madler/zlib/issues/94
--
-- Quote from zlib manual:
--
-- For the current implementation of deflate(), a windowBits value of 8 (a
-- window size of 256 bytes) is not supported. As a result, a request for 8 will
-- result in 9 (a 512-byte window). In that case, providing 8 to inflateInit2()
-- will result in an error when the zlib header with 9 is checked against the
-- initialization of inflate(). The remedy is to not use 8 with deflateInit2()
-- with this initialization, or at least in that case use 9 with inflateInit2().
fixWindowBits :: Int -> Int
fixWindowBits n
| n < 9 = 9
| n > 15 = 15
| otherwise = n
--------------------------------------------------------------------------------
appTailL :: BL.ByteString
appTailL = BL.pack [0x00,0x00,0xff,0xff]
--------------------------------------------------------------------------------
maybeStrip :: BL.ByteString -> BL.ByteString
maybeStrip x | appTailL `BL.isSuffixOf` x = BL.take (BL.length x - 4) x
maybeStrip x = x
--------------------------------------------------------------------------------
rejectExtensions :: Message -> IO Message
rejectExtensions (DataMessage rsv1 rsv2 rsv3 _) | rsv1 || rsv2 || rsv3 =
throwIO $ CloseRequest 1002 "Protocol Error"
rejectExtensions x = return x
--------------------------------------------------------------------------------
makeMessageDeflater
:: Maybe PermessageDeflate -> IO (Message -> IO Message)
makeMessageDeflater Nothing = return rejectExtensions
makeMessageDeflater (Just pmd)
| serverNoContextTakeover pmd = do
return $ \msg -> do
ptr <- initDeflate pmd
deflateMessageWith (deflateBody ptr) msg
| otherwise = do
ptr <- initDeflate pmd
return $ \msg ->
deflateMessageWith (deflateBody ptr) msg
where
----------------------------------------------------------------------------
initDeflate :: PermessageDeflate -> IO Zlib.Deflate
initDeflate PermessageDeflate {..} =
Zlib.initDeflate
pdCompressionLevel
(Zlib.WindowBits (- (fixWindowBits serverMaxWindowBits)))
----------------------------------------------------------------------------
deflateMessageWith
:: (BL.ByteString -> IO BL.ByteString)
-> Message -> IO Message
deflateMessageWith deflater (DataMessage False False False (Text x _)) = do
x' <- deflater x
return (DataMessage True False False (Text x' Nothing))
deflateMessageWith deflater (DataMessage False False False (Binary x)) = do
x' <- deflater x
return (DataMessage True False False (Binary x'))
deflateMessageWith _ x = return x
----------------------------------------------------------------------------
deflateBody :: Zlib.Deflate -> BL.ByteString -> IO BL.ByteString
deflateBody ptr = fmap maybeStrip . go . BL.toChunks
where
go [] =
dePopper (Zlib.flushDeflate ptr)
go (c : cs) = do
chunk <- Zlib.feedDeflate ptr c >>= dePopper
(chunk <>) <$> go cs
--------------------------------------------------------------------------------
dePopper :: Zlib.Popper -> IO BL.ByteString
dePopper p = p >>= \res -> case res of
Zlib.PRDone -> return BL.empty
Zlib.PRNext c -> BL.chunk c <$> dePopper p
Zlib.PRError x -> throwIO $ CloseRequest 1002 (BL8.pack (show x))
--------------------------------------------------------------------------------
makeMessageInflater
:: SizeLimit -> Maybe PermessageDeflate
-> IO (Message -> IO Message)
makeMessageInflater _ Nothing = return rejectExtensions
makeMessageInflater messageLimit (Just pmd)
| clientNoContextTakeover pmd =
return $ \msg -> do
ptr <- initInflate pmd
inflateMessageWith (inflateBody ptr) msg
| otherwise = do
ptr <- initInflate pmd
return $ \msg ->
inflateMessageWith (inflateBody ptr) msg
where
--------------------------------------------------------------------------------
initInflate :: PermessageDeflate -> IO Zlib.Inflate
initInflate PermessageDeflate {..} =
Zlib.initInflate
(Zlib.WindowBits (- (fixWindowBits clientMaxWindowBits)))
----------------------------------------------------------------------------
inflateMessageWith
:: (BL.ByteString -> IO BL.ByteString)
-> Message -> IO Message
inflateMessageWith inflater (DataMessage True a b (Text x _)) = do
x' <- inflater x
return (DataMessage False a b (Text x' Nothing))
inflateMessageWith inflater (DataMessage True a b (Binary x)) = do
x' <- inflater x
return (DataMessage False a b (Binary x'))
inflateMessageWith _ x = return x
----------------------------------------------------------------------------
inflateBody :: Zlib.Inflate -> BL.ByteString -> IO BL.ByteString
inflateBody ptr =
go 0 . BL.toChunks . (<> appTailL)
where
go :: Int64 -> [B.ByteString] -> IO BL.ByteString
go size0 [] = do
chunk <- Zlib.flushInflate ptr
checkSize (fromIntegral (B.length chunk) + size0)
return (BL.fromStrict chunk)
go size0 (c : cs) = do
chunk <- Zlib.feedInflate ptr c >>= dePopper
let size1 = size0 + BL.length chunk
checkSize size1
(chunk <>) <$> go size1 cs
----------------------------------------------------------------------------
checkSize :: Int64 -> IO ()
checkSize size = unless (atMostSizeLimit size messageLimit) $ throwIO $
ParseException $ "Message of size " ++ show size ++ " exceeded limit"
================================================
FILE: src/Network/WebSockets/Extensions/StrictUnicode.hs
================================================
--------------------------------------------------------------------------------
module Network.WebSockets.Extensions.StrictUnicode
( strictUnicode
) where
--------------------------------------------------------------------------------
import Control.Exception (throwIO)
import qualified Data.ByteString.Lazy as BL
import Network.WebSockets.Extensions
import Network.WebSockets.Types
--------------------------------------------------------------------------------
strictUnicode :: Extension
strictUnicode = Extension
{ extHeaders = []
, extParse = \parseRaw -> return (parseRaw >>= strictParse)
, extWrite = return
}
--------------------------------------------------------------------------------
strictParse :: Maybe Message -> IO (Maybe Message)
strictParse Nothing = return Nothing
strictParse (Just (DataMessage rsv1 rsv2 rsv3 (Text bl _))) =
case decodeUtf8Strict bl of
Left err -> throwIO err
Right txt ->
return (Just (DataMessage rsv1 rsv2 rsv3 (Text bl (Just txt))))
strictParse (Just msg@(ControlMessage (Close _ bl))) =
-- If there is a body, the first two bytes of the body MUST be a 2-byte
-- unsigned integer (in network byte order) representing a status code with
-- value /code/ defined in Section 7.4. Following the 2-byte integer, the
-- body MAY contain UTF-8-encoded data with value /reason/, the
-- interpretation of which is not defined by this specification.
case decodeUtf8Strict (BL.drop 2 bl) of
Left err -> throwIO err
Right _ -> return (Just msg)
strictParse (Just msg) = return (Just msg)
================================================
FILE: src/Network/WebSockets/Extensions.hs
================================================
module Network.WebSockets.Extensions
( ExtensionDescription (..)
, ExtensionDescriptions
, parseExtensionDescriptions
, NegotiateExtension
, Extension (..)
) where
import Network.WebSockets.Extensions.Description
import Network.WebSockets.Http
import Network.WebSockets.Types
type NegotiateExtension = ExtensionDescriptions -> Either String Extension
-- | An extension is currently allowed to set extra headers and transform the
-- parse/write functions of 'Connection'.
--
-- This type is very likely to change as other extensions are introduced.
data Extension = Extension
{ extHeaders :: Headers
, extParse :: IO (Maybe Message) -> IO (IO (Maybe Message))
, extWrite :: ([Message] -> IO ()) -> IO ([Message] -> IO ())
}
================================================
FILE: src/Network/WebSockets/Http.hs
================================================
--------------------------------------------------------------------------------
-- | Module dealing with HTTP: request data types, encoding and decoding...
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.WebSockets.Http
( Headers
, RequestHead (..)
, Request (..)
, ResponseHead (..)
, Response (..)
, HandshakeException (..)
, encodeRequestHead
, encodeRequest
, decodeRequestHead
, encodeResponseHead
, encodeResponse
, decodeResponseHead
, decodeResponse
, response101
, response400
, getRequestHeader
, getResponseHeader
, getRequestSecWebSocketVersion
, getRequestSubprotocols
, getRequestSecWebSocketExtensions
) where
--------------------------------------------------------------------------------
import qualified Data.ByteString.Builder as Builder
import qualified Data.ByteString.Builder.Extra as Builder
import Control.Applicative (pure, (*>), (<$>),
(<*), (<*>))
import Control.Exception (Exception)
import qualified Data.Attoparsec.ByteString as A
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.ByteString.Char8 ()
import qualified Data.ByteString.Char8 as BC
import Data.ByteString.Internal (c2w)
import qualified Data.CaseInsensitive as CI
import Data.Dynamic (Typeable)
import Data.Monoid (mappend, mconcat)
import qualified Network.WebSockets.Extensions.Description as Extensions
--------------------------------------------------------------------------------
-- | Request headers
type Headers = [(CI.CI ByteString, ByteString)]
--------------------------------------------------------------------------------
-- | An HTTP request. The request body is not yet read.
data RequestHead = RequestHead
{ requestPath :: !B.ByteString
, requestHeaders :: Headers
, requestSecure :: Bool
} deriving (Show)
--------------------------------------------------------------------------------
-- | A request with a body
data Request = Request RequestHead B.ByteString
deriving (Show)
--------------------------------------------------------------------------------
-- | HTTP response, without body.
data ResponseHead = ResponseHead
{ responseCode :: !Int
, responseMessage :: !B.ByteString
, responseHeaders :: Headers
} deriving (Show)
--------------------------------------------------------------------------------
-- | A response including a body
data Response = Response ResponseHead B.ByteString
deriving (Show)
--------------------------------------------------------------------------------
-- | Error in case of failed handshake. Will be thrown as an 'Exception'.
--
-- TODO: This should probably be in the Handshake module, and is solely here to
-- prevent a cyclic dependency.
data HandshakeException
-- | We don't have a match for the protocol requested by the client.
-- todo: version parameter
= NotSupported
-- | The request was somehow invalid (missing headers or wrong security
-- token)
| MalformedRequest RequestHead String
-- | The servers response was somehow invalid (missing headers or wrong
-- security token)
| MalformedResponse ResponseHead String
-- | The request was well-formed, but the library user rejected it.
-- (e.g. "unknown path")
| RequestRejected RequestHead ResponseHead
-- | The connection timed out
| ConnectionTimeout
-- | for example "EOF came too early" (which is actually a parse error)
-- or for your own errors. (like "unknown path"?)
| OtherHandshakeException String
deriving (Show, Typeable)
--------------------------------------------------------------------------------
instance Exception HandshakeException
--------------------------------------------------------------------------------
encodeRequestHead :: RequestHead -> Builder.Builder
encodeRequestHead (RequestHead path headers _) =
Builder.byteStringCopy "GET " `mappend`
Builder.byteStringCopy path `mappend`
Builder.byteStringCopy " HTTP/1.1" `mappend`
Builder.byteString "\r\n" `mappend`
mconcat (map header headers) `mappend`
Builder.byteStringCopy "\r\n"
where
header (k, v) = mconcat $ map Builder.byteStringCopy
[CI.original k, ": ", v, "\r\n"]
--------------------------------------------------------------------------------
encodeRequest :: Request -> Builder.Builder
encodeRequest (Request head' body) =
encodeRequestHead head' `mappend` Builder.byteStringCopy body
--------------------------------------------------------------------------------
-- | Parse an initial request
decodeRequestHead :: Bool -> A.Parser RequestHead
decodeRequestHead isSecure = RequestHead
<$> requestLine
<*> A.manyTill decodeHeaderLine newline
<*> pure isSecure
where
space = A.word8 (c2w ' ')
newline = A.string "\r\n"
requestLine = A.string "GET" *> space *> A.takeWhile1 (/= c2w ' ')
<* space
<* A.string "HTTP/1.1" <* newline
--------------------------------------------------------------------------------
-- | Encode an HTTP upgrade response
encodeResponseHead :: ResponseHead -> Builder.Builder
encodeResponseHead (ResponseHead code msg headers) =
Builder.byteStringCopy "HTTP/1.1 " `mappend`
Builder.stringUtf8 (show code) `mappend`
Builder.charUtf8 ' ' `mappend`
Builder.byteString msg `mappend`
Builder.byteString "\r\n" `mappend`
mconcat (map header headers) `mappend`
Builder.byteStringCopy "\r\n"
where
header (k, v) = mconcat $ map Builder.byteStringCopy
[CI.original k, ": ", v, "\r\n"]
--------------------------------------------------------------------------------
encodeResponse :: Response -> Builder.Builder
encodeResponse (Response head' body) =
encodeResponseHead head' `mappend` Builder.byteStringCopy body
--------------------------------------------------------------------------------
-- | An upgrade response
response101 :: Headers -> B.ByteString -> Response
response101 headers = Response
(ResponseHead 101 "WebSocket Protocol Handshake"
(("Upgrade", "websocket") : ("Connection", "Upgrade") : headers))
--------------------------------------------------------------------------------
-- | Bad request
response400 :: Headers -> B.ByteString -> Response
response400 headers = Response (ResponseHead 400 "Bad Request" headers)
--------------------------------------------------------------------------------
-- | HTTP response parser
decodeResponseHead :: A.Parser ResponseHead
decodeResponseHead = ResponseHead
<$> fmap (read . BC.unpack) code
<*> message
<*> A.manyTill decodeHeaderLine newline
where
space = A.word8 (c2w ' ')
newline = A.string "\r\n"
code = A.string "HTTP/1.1" *> space *> A.takeWhile1 digit <* space
digit = \x -> x >= c2w '0' && x <= c2w '9'
message = A.takeWhile (/= c2w '\r') <* newline
--------------------------------------------------------------------------------
decodeResponse :: A.Parser Response
decodeResponse = Response <$> decodeResponseHead <*> A.takeByteString
--------------------------------------------------------------------------------
getRequestHeader :: RequestHead
-> CI.CI ByteString
-> Either HandshakeException ByteString
getRequestHeader rq key = case lookup key (requestHeaders rq) of
Just t -> Right t
Nothing -> Left $ MalformedRequest rq $
"Header missing: " ++ BC.unpack (CI.original key)
--------------------------------------------------------------------------------
getResponseHeader :: ResponseHead
-> CI.CI ByteString
-> Either HandshakeException ByteString
getResponseHeader rsp key = case lookup key (responseHeaders rsp) of
Just t -> Right t
Nothing -> Left $ MalformedResponse rsp $
"Header missing: " ++ BC.unpack (CI.original key)
--------------------------------------------------------------------------------
-- | Get the @Sec-WebSocket-Version@ header
getRequestSecWebSocketVersion :: RequestHead -> Maybe B.ByteString
getRequestSecWebSocketVersion p =
lookup "Sec-WebSocket-Version" (requestHeaders p)
--------------------------------------------------------------------------------
-- | List of subprotocols specified by the client, in order of preference.
-- If the client did not specify a list of subprotocols, this will be the
-- empty list.
getRequestSubprotocols :: RequestHead -> [B.ByteString]
getRequestSubprotocols rh = maybe [] parse mproto
where
mproto = lookup "Sec-WebSocket-Protocol" $ requestHeaders rh
parse = filter (not . B.null) . BC.splitWith (\o -> o == ',' || o == ' ')
--------------------------------------------------------------------------------
-- | Get the @Sec-WebSocket-Extensions@ header
getRequestSecWebSocketExtensions
:: RequestHead -> Either HandshakeException Extensions.ExtensionDescriptions
getRequestSecWebSocketExtensions rq =
case lookup "Sec-WebSocket-Extensions" (requestHeaders rq) of
Nothing -> Right []
Just ext -> case Extensions.parseExtensionDescriptions ext of
Right x -> Right x
Left err -> Left $ MalformedRequest rq $
"Malformed Sec-WebSockets-Extensions: " ++ err
--------------------------------------------------------------------------------
decodeHeaderLine :: A.Parser (CI.CI ByteString, ByteString)
decodeHeaderLine = (,)
<$> (CI.mk <$> A.takeWhile1 (/= c2w ':'))
<* A.word8 (c2w ':')
<* A.option (c2w ' ') (A.word8 (c2w ' '))
<*> A.takeWhile (/= c2w '\r')
<* A.string "\r\n"
================================================
FILE: src/Network/WebSockets/Hybi13/Demultiplex.hs
================================================
--------------------------------------------------------------------------------
-- | Demultiplexing of frames into messages
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.WebSockets.Hybi13.Demultiplex
( FrameType (..)
, Frame (..)
, DemultiplexState
, emptyDemultiplexState
, DemultiplexResult (..)
, demultiplex
) where
--------------------------------------------------------------------------------
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Builder as B
import Control.Exception (Exception)
import Data.Binary.Get (getWord16be, runGet)
import qualified Data.ByteString.Lazy as BL
import Data.Int (Int64)
import Data.Monoid (mappend)
import Data.Typeable (Typeable)
import Network.WebSockets.Connection.Options
import Network.WebSockets.Types
--------------------------------------------------------------------------------
-- | A low-level representation of a WebSocket packet
data Frame = Frame
{ frameFin :: !Bool
, frameRsv1 :: !Bool
, frameRsv2 :: !Bool
, frameRsv3 :: !Bool
, frameType :: !FrameType
, framePayload :: !BL.ByteString
} deriving (Eq, Show)
--------------------------------------------------------------------------------
-- | The type of a frame. Not all types are allowed for all protocols.
data FrameType
= ContinuationFrame
| TextFrame
| BinaryFrame
| CloseFrame
| PingFrame
| PongFrame
deriving (Eq, Show)
--------------------------------------------------------------------------------
-- | Thrown if the client sends invalid multiplexed data
data DemultiplexException = DemultiplexException
deriving (Show, Typeable)
--------------------------------------------------------------------------------
instance Exception DemultiplexException
--------------------------------------------------------------------------------
-- | Internal state used by the demultiplexer
data DemultiplexState
= EmptyDemultiplexState
| DemultiplexState !Int64 !Builder !(Builder -> Message)
--------------------------------------------------------------------------------
emptyDemultiplexState :: DemultiplexState
emptyDemultiplexState = EmptyDemultiplexState
--------------------------------------------------------------------------------
-- | Result of demultiplexing
data DemultiplexResult
= DemultiplexSuccess Message
| DemultiplexError ConnectionException
| DemultiplexContinue
--------------------------------------------------------------------------------
demultiplex :: SizeLimit
-> DemultiplexState
-> Frame
-> (DemultiplexResult, DemultiplexState)
demultiplex _ state (Frame True False False False PingFrame pl)
| BL.length pl > 125 =
(DemultiplexError $ CloseRequest 1002 "Protocol Error", emptyDemultiplexState)
| otherwise =
(DemultiplexSuccess $ ControlMessage (Ping pl), state)
demultiplex _ state (Frame True False False False PongFrame pl) =
(DemultiplexSuccess (ControlMessage (Pong pl)), state)
demultiplex _ _ (Frame True False False False CloseFrame pl) =
(DemultiplexSuccess (ControlMessage (uncurry Close parsedClose)), emptyDemultiplexState)
where
-- The Close frame MAY contain a body (the "Application data" portion of the
-- frame) that indicates a reason for closing, such as an endpoint shutting
-- down, an endpoint having received a frame too large, or an endpoint
-- having received a frame that does not conform to the format expected by
-- the endpoint. If there is a body, the first two bytes of the body MUST
-- be a 2-byte unsigned integer (in network byte order) representing a
-- status code with value /code/ defined in Section 7.4.
parsedClose
| BL.length pl >= 2 = case runGet getWord16be pl of
a | a < 1000 || a `elem` [1004,1005,1006
,1014,1015,1016
,1100,2000,2999
,5000,65535] -> (1002, BL.empty)
a -> (a, BL.drop 2 pl)
| BL.length pl == 1 = (1002, BL.empty)
| otherwise = (1000, BL.empty)
demultiplex sizeLimit EmptyDemultiplexState (Frame fin rsv1 rsv2 rsv3 tp pl) = case tp of
_ | not (atMostSizeLimit size sizeLimit) ->
( DemultiplexError $ ParseException $
"Message of size " ++ show size ++ " exceeded limit"
, emptyDemultiplexState
)
TextFrame
| fin ->
(DemultiplexSuccess (text pl), emptyDemultiplexState)
| otherwise ->
(DemultiplexContinue, DemultiplexState size plb (text . B.toLazyByteString))
BinaryFrame
| fin -> (DemultiplexSuccess (binary pl), emptyDemultiplexState)
| otherwise -> (DemultiplexContinue, DemultiplexState size plb (binary . B.toLazyByteString))
_ -> (DemultiplexError $ CloseRequest 1002 "Protocol Error", emptyDemultiplexState)
where
size = BL.length pl
plb = B.lazyByteString pl
text x = DataMessage rsv1 rsv2 rsv3 (Text x Nothing)
binary x = DataMessage rsv1 rsv2 rsv3 (Binary x)
demultiplex sizeLimit (DemultiplexState size0 b f) (Frame fin False False False ContinuationFrame pl)
| not (atMostSizeLimit size1 sizeLimit) =
( DemultiplexError $ ParseException $
"Message of size " ++ show size1 ++ " exceeded limit"
, emptyDemultiplexState
)
| fin = (DemultiplexSuccess (f b'), emptyDemultiplexState)
| otherwise = (DemultiplexContinue, DemultiplexState size1 b' f)
where
size1 = size0 + BL.length pl
b' = b `mappend` plb
plb = B.lazyByteString pl
demultiplex _ _ _ =
(DemultiplexError (CloseRequest 1002 "Protocol Error"), emptyDemultiplexState)
================================================
FILE: src/Network/WebSockets/Hybi13/Mask.hs
================================================
--------------------------------------------------------------------------------
-- | Masking of fragmes using a simple XOR algorithm
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Network.WebSockets.Hybi13.Mask
( Mask
, parseMask
, encodeMask
, randomMask
, maskPayload
) where
--------------------------------------------------------------------------------
import qualified Data.ByteString.Builder as Builder
import qualified Data.ByteString.Builder.Extra as Builder
import Data.Binary.Get (Get, getWord32host)
import qualified Data.ByteString.Internal as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Internal as BL
import Data.Word (Word32, Word8)
import Foreign.C.Types (CChar (..), CInt (..),
CSize (..))
import Foreign.ForeignPtr (withForeignPtr)
import Foreign.Ptr (Ptr, plusPtr)
import System.Random (RandomGen, random)
--------------------------------------------------------------------------------
foreign import ccall unsafe "_hs_mask_chunk" c_mask_chunk
:: Word32 -> CInt -> Ptr CChar -> CSize -> Ptr Word8 -> IO ()
--------------------------------------------------------------------------------
-- | A mask is sequence of 4 bytes. We store this in a 'Word32' in the host's
-- native byte ordering.
newtype Mask = Mask {unMask :: Word32}
--------------------------------------------------------------------------------
-- | Parse a mask.
parseMask :: Get Mask
parseMask = fmap Mask getWord32host
--------------------------------------------------------------------------------
-- | Encode a mask
encodeMask :: Mask -> Builder.Builder
encodeMask = Builder.word32Host . unMask
--------------------------------------------------------------------------------
-- | Create a random mask
randomMask :: forall g. RandomGen g => g -> (Mask, g)
randomMask gen = (Mask int, gen')
where
(!int, !gen') = random gen :: (Word32, g)
--------------------------------------------------------------------------------
-- | Mask a lazy bytestring. Uses 'c_mask_chunk' under the hood.
maskPayload :: Maybe Mask -> BL.ByteString -> BL.ByteString
maskPayload Nothing = id
maskPayload (Just (Mask 0)) = id
maskPayload (Just (Mask mask)) = go 0
where
go _ BL.Empty = BL.Empty
go !maskOffset (BL.Chunk (B.PS payload off len) rest) =
BL.Chunk maskedChunk (go ((maskOffset + len) `rem` 4) rest)
where
maskedChunk =
B.unsafeCreate len $ \dst ->
withForeignPtr payload $ \src ->
c_mask_chunk mask
(fromIntegral maskOffset)
(src `plusPtr` off)
(fromIntegral len)
dst
================================================
FILE: src/Network/WebSockets/Hybi13.hs
================================================
--------------------------------------------------------------------------------
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.WebSockets.Hybi13
( headerVersions
, finishRequest
, finishResponse
, encodeMessage
, encodeMessages
, decodeMessages
, createRequest
-- Internal (used for testing)
, encodeFrame
, parseFrame
) where
--------------------------------------------------------------------------------
import qualified Data.ByteString.Builder as B
import Control.Applicative (pure, (<$>))
import Control.Arrow (first)
import Control.Exception (throwIO)
import Control.Monad (forM, liftM, unless,
when)
import Data.Binary.Get (Get, getInt64be,
getLazyByteString,
getWord16be, getWord8)
import Data.Binary.Put (putWord16be, runPut)
import Data.Bits ((.&.), (.|.))
import Data.ByteString (ByteString)
import qualified Data.ByteString.Base64 as B64
import Data.ByteString.Char8 ()
import qualified Data.ByteString.Lazy as BL
import Data.Digest.Pure.SHA (bytestringDigest, sha1)
import Data.IORef
import Data.Monoid (mappend, mconcat,
mempty)
import Data.Tuple (swap)
import System.Entropy as R
import System.Random (RandomGen, newStdGen)
--------------------------------------------------------------------------------
import Network.WebSockets.Connection.Options
import Network.WebSockets.Http
import Network.WebSockets.Hybi13.Demultiplex
import Network.WebSockets.Hybi13.Mask
import Network.WebSockets.Stream (Stream)
import qualified Network.WebSockets.Stream as Stream
import Network.WebSockets.Types
--------------------------------------------------------------------------------
headerVersions :: [ByteString]
headerVersions = ["13"]
--------------------------------------------------------------------------------
finishRequest :: RequestHead
-> Headers
-> Either HandshakeException Response
finishRequest reqHttp headers = do
!key <- getRequestHeader reqHttp "Sec-WebSocket-Key"
let !hash = hashKey key
!encoded = B64.encode hash
return $ response101 (("Sec-WebSocket-Accept", encoded):headers) ""
--------------------------------------------------------------------------------
finishResponse :: RequestHead
-> ResponseHead
-> Either HandshakeException Response
finishResponse request response = do
-- Response message should be one of
--
-- - WebSocket Protocol Handshake
-- - Switching Protocols
--
-- But we don't check it for now
when (responseCode response == 400) $ Left $
RequestRejected request response
when (responseCode response /= 101) $ Left $
MalformedResponse response "Wrong response status or message."
key <- getRequestHeader request "Sec-WebSocket-Key"
responseHash <- getResponseHeader response "Sec-WebSocket-Accept"
let challengeHash = B64.encode $ hashKey key
when (responseHash /= challengeHash) $ Left $
MalformedResponse response "Challenge and response hashes do not match."
return $ Response response ""
--------------------------------------------------------------------------------
encodeMessage :: RandomGen g => ConnectionType -> g -> Message -> (g, B.Builder)
encodeMessage conType gen msg = (gen', builder)
where
mkFrame = Frame True False False False
(mask, gen') = case conType of
ServerConnection -> (Nothing, gen)
ClientConnection -> first Just (randomMask gen)
builder = encodeFrame mask $ case msg of
(ControlMessage (Close code pl)) -> mkFrame CloseFrame $
runPut (putWord16be code) `mappend` pl
(ControlMessage (Ping pl)) -> mkFrame PingFrame pl
(ControlMessage (Pong pl)) -> mkFrame PongFrame pl
(DataMessage rsv1 rsv2 rsv3 (Text pl _)) -> Frame True rsv1 rsv2 rsv3 TextFrame pl
(DataMessage rsv1 rsv2 rsv3 (Binary pl)) -> Frame True rsv1 rsv2 rsv3 BinaryFrame pl
--------------------------------------------------------------------------------
encodeMessages
:: ConnectionType
-> Stream
-> IO ([Message] -> IO ())
encodeMessages conType stream = do
genRef <- newIORef =<< newStdGen
return $ \msgs -> do
builders <- forM msgs $ \msg ->
atomicModifyIORef' genRef $ \s -> encodeMessage conType s msg
Stream.write stream (B.toLazyByteString $ mconcat builders)
--------------------------------------------------------------------------------
encodeFrame :: Maybe Mask -> Frame -> B.Builder
encodeFrame mask f = B.word8 byte0 `mappend`
B.word8 byte1 `mappend` len `mappend` maskbytes `mappend`
B.lazyByteString (maskPayload mask payload)
where
byte0 = fin .|. rsv1 .|. rsv2 .|. rsv3 .|. opcode
fin = if frameFin f then 0x80 else 0x00
rsv1 = if frameRsv1 f then 0x40 else 0x00
rsv2 = if frameRsv2 f then 0x20 else 0x00
rsv3 = if frameRsv3 f then 0x10 else 0x00
payload = case frameType f of
ContinuationFrame -> framePayload f
TextFrame -> framePayload f
BinaryFrame -> framePayload f
CloseFrame -> BL.take 125 $ framePayload f
PingFrame -> BL.take 125 $ framePayload f
PongFrame -> BL.take 125 $ framePayload f
opcode = case frameType f of
ContinuationFrame -> 0x00
TextFrame -> 0x01
BinaryFrame -> 0x02
CloseFrame -> 0x08
PingFrame -> 0x09
PongFrame -> 0x0a
(maskflag, maskbytes) = case mask of
Nothing -> (0x00, mempty)
Just m -> (0x80, encodeMask m)
byte1 = maskflag .|. lenflag
len' = BL.length payload
(lenflag, len)
| len' < 126 = (fromIntegral len', mempty)
| len' < 0x10000 = (126, B.word16BE (fromIntegral len'))
| otherwise = (127, B.word64BE (fromIntegral len'))
--------------------------------------------------------------------------------
decodeMessages
:: SizeLimit
-> SizeLimit
-> Stream
-> IO (IO (Maybe Message))
decodeMessages frameLimit messageLimit stream = do
dmRef <- newIORef emptyDemultiplexState
return $ go dmRef
where
go dmRef = do
mbFrame <- Stream.parseBin stream (parseFrame frameLimit)
case mbFrame of
Nothing -> return Nothing
Just frame -> do
demultiplexResult <- atomicModifyIORef' dmRef $
\s -> swap $ demultiplex messageLimit s frame
case demultiplexResult of
DemultiplexError err -> throwIO err
DemultiplexContinue -> go dmRef
DemultiplexSuccess msg -> return (Just msg)
--------------------------------------------------------------------------------
-- | Parse a frame
parseFrame :: SizeLimit -> Get Frame
parseFrame frameSizeLimit = do
byte0 <- getWord8
let fin = byte0 .&. 0x80 == 0x80
rsv1 = byte0 .&. 0x40 == 0x40
rsv2 = byte0 .&. 0x20 == 0x20
rsv3 = byte0 .&. 0x10 == 0x10
opcode = byte0 .&. 0x0f
byte1 <- getWord8
let mask = byte1 .&. 0x80 == 0x80
lenflag = byte1 .&. 0x7f
len <- case lenflag of
126 -> fromIntegral <$> getWord16be
127 -> getInt64be
_ -> return (fromIntegral lenflag)
-- Check size against limit.
unless (atMostSizeLimit len frameSizeLimit) $
fail $ "Frame of size " ++ show len ++ " exceeded limit"
ft <- case opcode of
0x00 -> return ContinuationFrame
0x01 -> return TextFrame
0x02 -> return BinaryFrame
0x08 -> enforceControlFrameRestrictions len fin >> return CloseFrame
0x09 -> enforceControlFrameRestrictions len fin >> return PingFrame
0x0a -> enforceControlFrameRestrictions len fin >> return PongFrame
_ -> fail $ "Unknown opcode: " ++ show opcode
masker <- maskPayload <$> if mask then Just <$> parseMask else pure Nothing
chunks <- getLazyByteString len
return $ Frame fin rsv1 rsv2 rsv3 ft (masker chunks)
where
enforceControlFrameRestrictions len fin
| not fin = fail "Control Frames must not be fragmented!"
| len > 125 = fail "Control Frames must not carry payload > 125 bytes!"
| otherwise = pure ()
--------------------------------------------------------------------------------
hashKey :: ByteString -> ByteString
hashKey key = unlazy $ bytestringDigest $ sha1 $ lazy $ key `mappend` guid
where
guid = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"
lazy = BL.fromChunks . return
unlazy = mconcat . BL.toChunks
--------------------------------------------------------------------------------
createRequest :: ByteString
-> ByteString
-> Bool
-> Headers
-> IO RequestHead
createRequest hostname path secure customHeaders = do
key <- B64.encode `liftM` getEntropy 16
return $ RequestHead path (headers key ++ customHeaders) secure
where
headers key =
[ ("Host" , hostname )
, ("Connection" , "Upgrade" )
, ("Upgrade" , "websocket" )
, ("Sec-WebSocket-Key" , key )
, ("Sec-WebSocket-Version" , versionNumber)
]
versionNumber = head headerVersions
================================================
FILE: src/Network/WebSockets/Protocol.hs
================================================
--------------------------------------------------------------------------------
-- | Wrapper for supporting multiple protocol versions
{-# LANGUAGE ExistentialQuantification #-}
module Network.WebSockets.Protocol
( Protocol (..)
, defaultProtocol
, protocols
, compatible
, headerVersions
, finishRequest
, finishResponse
, encodeMessages
, decodeMessages
, createRequest
) where
--------------------------------------------------------------------------------
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
--------------------------------------------------------------------------------
import Network.WebSockets.Connection.Options
import Network.WebSockets.Http
import qualified Network.WebSockets.Hybi13 as Hybi13
import Network.WebSockets.Stream (Stream)
import Network.WebSockets.Types
--------------------------------------------------------------------------------
data Protocol
= Hybi13
deriving (Show)
--------------------------------------------------------------------------------
defaultProtocol :: Protocol
defaultProtocol = Hybi13
--------------------------------------------------------------------------------
protocols :: [Protocol]
protocols = [Hybi13]
--------------------------------------------------------------------------------
headerVersions :: Protocol -> [ByteString]
headerVersions Hybi13 = Hybi13.headerVersions
--------------------------------------------------------------------------------
compatible :: Protocol -> RequestHead -> Bool
compatible protocol req = case getRequestSecWebSocketVersion req of
Just v -> v `elem` headerVersions protocol
_ -> True -- Whatever?
--------------------------------------------------------------------------------
finishRequest
:: Protocol -> RequestHead -> Headers -> Either HandshakeException Response
finishRequest Hybi13 = Hybi13.finishRequest
--------------------------------------------------------------------------------
finishResponse
:: Protocol -> RequestHead -> ResponseHead
-> Either HandshakeException Response
finishResponse Hybi13 = Hybi13.finishResponse
--------------------------------------------------------------------------------
encodeMessages
:: Protocol -> ConnectionType -> Stream
-> IO ([Message] -> IO ())
encodeMessages Hybi13 = Hybi13.encodeMessages
--------------------------------------------------------------------------------
decodeMessages
:: Protocol -> SizeLimit -> SizeLimit -> Stream
-> IO (IO (Maybe Message))
decodeMessages Hybi13 frameLimit messageLimit =
Hybi13.decodeMessages frameLimit messageLimit
--------------------------------------------------------------------------------
createRequest
:: Protocol -> B.ByteString -> B.ByteString -> Bool -> Headers
-> IO RequestHead
createRequest Hybi13 = Hybi13.createRequest
================================================
FILE: src/Network/WebSockets/Server.hs
================================================
--------------------------------------------------------------------------------
-- | This provides a simple stand-alone server for 'WebSockets' applications.
-- Note that in production you want to use a real webserver such as snap or
-- warp.
{-# LANGUAGE OverloadedStrings #-}
module Network.WebSockets.Server
( ServerApp
, runServer
, ServerOptions (..)
, defaultServerOptions
, runServerWithOptions
, runServerWith
, makeListenSocket
, makePendingConnection
, makePendingConnectionFromStream
, PongTimeout
) where
--------------------------------------------------------------------------------
import Control.Concurrent (forkIOWithUnmask,
myThreadId,
killThread
)
import Control.Exception (bracket,
bracketOnError, finally, mask_,
throwIO)
import Control.Monad (forever, forM_)
import Data.IORef (newIORef,
readIORef,
modifyIORef'
)
import qualified Data.Set as Set
import Network.Socket (Socket)
import qualified Network.Socket as S
--------------------------------------------------------------------------------
import Network.WebSockets.Connection
import Network.WebSockets.Connection.PingPong (PongTimeout(..))
import Network.WebSockets.Http
import qualified Network.WebSockets.Stream as Stream
import Network.WebSockets.Types
--------------------------------------------------------------------------------
-- | WebSockets application that can be ran by a server. Once this 'IO' action
-- finishes, the underlying socket is closed automatically.
type ServerApp = PendingConnection -> IO ()
--------------------------------------------------------------------------------
-- | Provides a simple server. This function blocks forever. Note that this
-- is merely provided for quick-and-dirty or internal applications, but for real
-- applications, you should use a real server.
--
-- For example:
--
-- * Performance is reasonable under load, but:
-- * No protection against DoS attacks is provided.
-- * No logging is performed.
-- * ...
--
-- Glue for using this package with real servers is provided by:
--
-- * <https://hackage.haskell.org/package/wai-websockets>
--
-- * <https://hackage.haskell.org/package/websockets-snap>
runServer :: String -- ^ Address to bind
-> Int -- ^ Port to listen on
-> ServerApp -- ^ Application
-> IO () -- ^ Never returns
runServer host port app = runServerWith host port defaultConnectionOptions app
--------------------------------------------------------------------------------
-- | A version of 'runServer' which allows you to customize some options.
runServerWith :: String -> Int -> ConnectionOptions -> ServerApp -> IO ()
runServerWith host port opts = runServerWithOptions defaultServerOptions
{ serverHost = host
, serverPort = port
, serverConnectionOptions = opts
}
{-# DEPRECATED runServerWith "Use 'runServerWithOptions' instead" #-}
--------------------------------------------------------------------------------
data ServerOptions = ServerOptions
{ serverHost :: String
, serverPort :: Int
, serverConnectionOptions :: ConnectionOptions
}
--------------------------------------------------------------------------------
defaultServerOptions :: ServerOptions
defaultServerOptions = ServerOptions
{ serverHost = "127.0.0.1"
, serverPort = 8080
, serverConnectionOptions = defaultConnectionOptions
}
--------------------------------------------------------------------------------
-- | Customizable version of 'runServer'. Never returns until killed.
--
-- Please use the 'defaultServerOptions' combined with record updates to set the
-- fields you want. This way your code is unlikely to break on future changes.
runServerWithOptions :: ServerOptions -> ServerApp -> IO a
runServerWithOptions opts app = S.withSocketsDo $ do
appThreads <- newIORef Set.empty
let killAllApps :: IO ()
killAllApps = do
apps <- readIORef appThreads
forM_ apps $ killThread
bracket
(makeListenSocket (serverHost opts) (serverPort opts))
(\sock -> killAllApps >> S.close sock)
(\sock -> do
let mainThread :: IO a
mainThread = forever $ do
(conn, _) <- S.accept sock
let cleanupApp = do
S.close conn
me <- myThreadId
modifyIORef' appThreads $ Set.delete me
appThread <- forkIOWithUnmask
(\unmask -> unmask (runApp conn (serverConnectionOptions opts) app) `finally` cleanupApp)
modifyIORef' appThreads $ Set.insert appThread
mask_ mainThread
)
--------------------------------------------------------------------------------
-- | Create a standardized socket on which you can listen for incomming
-- connections. Should only be used for a quick and dirty solution! Should be
-- preceded by the call 'Network.Socket.withSocketsDo'.
makeListenSocket :: String -> Int -> IO Socket
makeListenSocket host port = do
addr:_ <- S.getAddrInfo (Just hints) (Just host) (Just (show port))
bracketOnError
(S.socket (S.addrFamily addr) S.Stream S.defaultProtocol)
S.close
(\sock -> do
_ <- S.setSocketOption sock S.ReuseAddr 1
_ <- S.setSocketOption sock S.NoDelay 1
S.bind sock (S.addrAddress addr)
S.listen sock 5
return sock
)
where
hints = S.defaultHints { S.addrSocketType = S.Stream }
--------------------------------------------------------------------------------
runApp :: Socket
-> ConnectionOptions
-> ServerApp
-> IO ()
runApp socket opts app =
bracket
(makePendingConnection socket opts)
(Stream.close . pendingStream)
app
--------------------------------------------------------------------------------
-- | Turns a socket, connected to some client, into a 'PendingConnection'. The
-- 'PendingConnection' should be closed using 'pendingStream' and 'Stream.close' later.
makePendingConnection
:: Socket -> ConnectionOptions -> IO PendingConnection
makePendingConnection socket opts = do
stream <- Stream.makeSocketStream socket
makePendingConnectionFromStream stream opts
-- | More general version of 'makePendingConnection' for 'Stream.Stream'
-- instead of a 'Socket'.
makePendingConnectionFromStream
:: Stream.Stream -> ConnectionOptions -> IO PendingConnection
makePendingConnectionFromStream stream opts = do
-- TODO: we probably want to send a 40x if the request is bad?
mbRequest <- Stream.parse stream (decodeRequestHead False)
case mbRequest of
Nothing -> throwIO ConnectionClosed
Just request -> return PendingConnection
{ pendingOptions = opts
, pendingRequest = request
, pendingOnAccept = \_ -> return ()
, pendingStream = stream
}
================================================
FILE: src/Network/WebSockets/Stream.hs
================================================
--------------------------------------------------------------------------------
-- | Lightweight abstraction over an input/output stream.
{-# LANGUAGE CPP #-}
module Network.WebSockets.Stream
( Stream
, makeStream
, makeSocketStream
, makeEchoStream
, parse
, parseBin
, write
, close
) where
import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar,
putMVar, takeMVar, withMVar)
import Control.Exception (SomeException, SomeAsyncException, throwIO, catch, try, fromException)
import Control.Monad (forM_)
import qualified Data.Attoparsec.ByteString as Atto
import qualified Data.Binary.Get as BIN
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.IORef (IORef, atomicModifyIORef',
newIORef, readIORef,
writeIORef)
import qualified Network.Socket as S
import qualified Network.Socket.ByteString as SB (recv)
#if !defined(mingw32_HOST_OS)
import qualified Network.Socket.ByteString.Lazy as SBL (sendAll)
#else
import qualified Network.Socket.ByteString as SB (sendAll)
#endif
import System.IO.Error (isResourceVanishedError)
import Network.WebSockets.Types
--------------------------------------------------------------------------------
-- | State of the stream
data StreamState
= Closed !B.ByteString -- Remainder
| Open !B.ByteString -- Buffer
--------------------------------------------------------------------------------
-- | Lightweight abstraction over an input/output stream.
data Stream = Stream
{ streamIn :: IO (Maybe B.ByteString)
, streamOut :: (Maybe BL.ByteString -> IO ())
, streamState :: !(IORef StreamState)
}
--------------------------------------------------------------------------------
-- | Create a stream from a "receive" and "send" action. The following
-- properties apply:
--
-- - Regardless of the provided "receive" and "send" functions, reading and
-- writing from the stream will be thread-safe, i.e. this function will create
-- a receive and write lock to be used internally.
--
-- - Reading from or writing to a closed 'Stream' will always throw an
-- exception, even if the underlying "receive" and "send" functions do not
-- (we do the bookkeeping).
--
-- - Streams should always be closed.
makeStream
:: IO (Maybe B.ByteString) -- ^ Reading
-> (Maybe BL.ByteString -> IO ()) -- ^ Writing
-> IO Stream -- ^ Resulting stream
makeStream receive send = do
ref <- newIORef (Open B.empty)
receiveLock <- newMVar ()
sendLock <- newMVar ()
return $ Stream (receive' ref receiveLock) (send' ref sendLock) ref
where
closeRef :: IORef StreamState -> IO ()
closeRef ref = atomicModifyIORef' ref $ \state -> case state of
Open buf -> (Closed buf, ())
Closed buf -> (Closed buf, ())
-- Throw a 'ConnectionClosed' is the connection is not 'Open'.
assertOpen :: IORef StreamState -> IO ()
assertOpen ref = do
state <- readIORef ref
case state of
Closed _ -> throwIO ConnectionClosed
Open _ -> return ()
receive' :: IORef StreamState -> MVar () -> IO (Maybe B.ByteString)
receive' ref lock = withMVar lock $ \() -> do
assertOpen ref
mbBs <- onSyncException receive (closeRef ref)
case mbBs of
Nothing -> closeRef ref >> return Nothing
Just bs -> return (Just bs)
send' :: IORef StreamState -> MVar () -> (Maybe BL.ByteString -> IO ())
send' ref lock mbBs = withMVar lock $ \() -> do
case mbBs of
Nothing -> closeRef ref
Just _ -> assertOpen ref
onSyncException (send mbBs) (closeRef ref)
onSyncException :: IO a -> IO b -> IO a
onSyncException io what =
catch io $ \e -> do
case fromException (e :: SomeException) :: Maybe SomeAsyncException of
Just _ -> pure ()
Nothing -> what *> pure ()
throwIO e
--------------------------------------------------------------------------------
makeSocketStream :: S.Socket -> IO Stream
makeSocketStream socket = makeStream receive send
where
receive = do
bs <- try $ SB.recv socket 8192
case bs of
-- If the resource vanished, the socket was closed
Left e | isResourceVanishedError e -> return Nothing
| otherwise -> throwIO e
Right bs' | B.null bs' -> return Nothing
| otherwise -> return $ Just bs'
send Nothing = return ()
send (Just bs) = do
#if !defined(mingw32_HOST_OS)
SBL.sendAll socket bs
#else
forM_ (BL.toChunks bs) (SB.sendAll socket)
#endif
--------------------------------------------------------------------------------
makeEchoStream :: IO Stream
makeEchoStream = do
mvar <- newEmptyMVar
makeStream (takeMVar mvar) $ \mbBs -> case mbBs of
Nothing -> putMVar mvar Nothing
Just bs -> forM_ (BL.toChunks bs) $ \c -> putMVar mvar (Just c)
--------------------------------------------------------------------------------
parseBin :: Stream -> BIN.Get a -> IO (Maybe a)
parseBin stream parser = do
state <- readIORef (streamState stream)
case state of
Closed remainder
| B.null remainder -> return Nothing
| otherwise -> go (BIN.runGetIncremental parser `BIN.pushChunk` remainder) True
Open buffer
| B.null buffer -> do
mbBs <- streamIn stream
case mbBs of
Nothing -> do
writeIORef (streamState stream) (Closed B.empty)
return Nothing
Just bs -> go (BIN.runGetIncremental parser `BIN.pushChunk` bs) False
| otherwise -> go (BIN.runGetIncremental parser `BIN.pushChunk` buffer) False
where
-- Buffer is empty when entering this function.
go (BIN.Done remainder _ x) closed = do
writeIORef (streamState stream) $
if closed then Closed remainder else Open remainder
return (Just x)
go (BIN.Partial f) closed
| closed = go (f Nothing) True
| otherwise = do
mbBs <- streamIn stream
case mbBs of
Nothing -> go (f Nothing) True
Just bs -> go (f (Just bs)) False
go (BIN.Fail _ _ err) _ = throwIO (ParseException err)
parse :: Stream -> Atto.Parser a -> IO (Maybe a)
parse stream parser = do
state <- readIORef (streamState stream)
case state of
Closed remainder
| B.null remainder -> return Nothing
| otherwise -> go (Atto.parse parser remainder) True
Open buffer
| B.null buffer -> do
mbBs <- streamIn stream
case mbBs of
Nothing -> do
writeIORef (streamState stream) (Closed B.empty)
return Nothing
Just bs -> go (Atto.parse parser bs) False
| otherwise -> go (Atto.parse parser buffer) False
where
-- Buffer is empty when entering this function.
go (Atto.Done remainder x) closed = do
writeIORef (streamState stream) $
if closed then Closed remainder else Open remainder
return (Just x)
go (Atto.Partial f) closed
| closed = go (f B.empty) True
| otherwise = do
mbBs <- streamIn stream
case mbBs of
Nothing -> go (f B.empty) True
Just bs -> go (f bs) False
go (Atto.Fail _ _ err) _ = throwIO (ParseException err)
--------------------------------------------------------------------------------
write :: Stream -> BL.ByteString -> IO ()
write stream = streamOut stream . Just
--------------------------------------------------------------------------------
close :: Stream -> IO ()
close stream = streamOut stream Nothing
================================================
FILE: src/Network/WebSockets/Types.hs
================================================
--------------------------------------------------------------------------------
-- | Primary types
{-# LANGUAGE DeriveDataTypeable #-}
module Network.WebSockets.Types
( Message (..)
, ControlMessage (..)
, DataMessage (..)
, WebSocketsData (..)
, HandshakeException (..)
, ConnectionException (..)
, ConnectionType (..)
, decodeUtf8Lenient
, decodeUtf8Strict
) where
--------------------------------------------------------------------------------
import Control.Exception (Exception (..))
import Control.Exception (throw, try)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import qualified Data.Text.Encoding.Error as TL
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import Data.Typeable (Typeable)
import Data.Word (Word16)
import System.IO.Unsafe (unsafePerformIO)
--------------------------------------------------------------------------------
import Network.WebSockets.Http
--------------------------------------------------------------------------------
-- | The kind of message a server application typically deals with
data Message
= ControlMessage ControlMessage
-- | Reserved bits, actual message
| DataMessage Bool Bool Bool DataMessage
deriving (Eq, Show)
--------------------------------------------------------------------------------
-- | Different control messages
data ControlMessage
= Close Word16 BL.ByteString
| Ping BL.ByteString
| Pong BL.ByteString
deriving (Eq, Show)
--------------------------------------------------------------------------------
-- | For an end-user of this library, dealing with 'Frame's would be a bit
-- low-level. This is why define another type on top of it, which represents
-- data for the application layer.
--
-- There are currently two kinds of data messages supported by the WebSockets
-- protocol:
--
-- * Textual UTF-8 encoded data. This corresponds roughly to sending a String
-- in JavaScript.
--
-- * Binary data. This corresponds roughly to send an ArrayBuffer in
-- JavaScript.
data DataMessage
-- | A textual message. The second field /might/ contain the decoded UTF-8
-- text for caching reasons. This field is computed lazily so if it's not
-- accessed, it should have no performance impact.
= Text BL.ByteString (Maybe TL.Text)
-- | A binary message.
| Binary BL.ByteString
deriving (Eq, Show)
--------------------------------------------------------------------------------
-- | In order to have an even more high-level API, we define a typeclass for
-- values the user can receive from and send to the socket. A few warnings
-- apply:
--
-- * Natively, everything is represented as a 'BL.ByteString', so this is the
-- fastest instance
--
-- * You should only use the 'TL.Text' or the 'T.Text' instance when you are
-- sure that the data is UTF-8 encoded (which is the case for 'Text'
-- messages).
--
-- * Messages can be very large. If this is the case, it might be inefficient to
-- use the strict 'B.ByteString' and 'T.Text' instances.
class WebSocketsData a where
fromDataMessage :: DataMessage -> a
fromLazyByteString :: BL.ByteString -> a
toLazyByteString :: a -> BL.ByteString
--------------------------------------------------------------------------------
instance WebSocketsData BL.ByteString where
fromDataMessage (Text bl _) = bl
fromDataMessage (Binary bl) = bl
fromLazyByteString = id
toLazyByteString = id
--------------------------------------------------------------------------------
instance WebSocketsData B.ByteString where
fromDataMessage (Text bl _) = fromLazyByteString bl
fromDataMessage (Binary bl) = fromLazyByteString bl
fromLazyByteString = B.concat . BL.toChunks
toLazyByteString = BL.fromChunks . return
--------------------------------------------------------------------------------
instance WebSocketsData TL.Text where
fromDataMessage (Text _ (Just tl)) = tl
fromDataMessage (Text bl Nothing) = fromLazyByteString bl
fromDataMessage (Binary bl) = fromLazyByteString bl
fromLazyByteString = TL.decodeUtf8
toLazyByteString = TL.encodeUtf8
--------------------------------------------------------------------------------
instance WebSocketsData T.Text where
fromDataMessage (Text _ (Just tl)) = T.concat (TL.toChunks tl)
fromDataMessage (Text bl Nothing) = fromLazyByteString bl
fromDataMessage (Binary bl) = fromLazyByteString bl
fromLazyByteString = T.concat . TL.toChunks . fromLazyByteString
toLazyByteString = toLazyByteString . TL.fromChunks . return
--------------------------------------------------------------------------------
-- | Various exceptions that can occur while receiving or transmitting messages
data ConnectionException
-- | The peer has requested that the connection be closed, and included
-- a close code and a reason for closing. When receiving this exception,
-- no more messages can be sent. Also, the server is responsible for
-- closing the TCP connection once this exception is received.
--
-- See <http://tools.ietf.org/html/rfc6455#section-7.4> for a list of close
-- codes.
= CloseRequest Word16 BL.ByteString
-- | The peer unexpectedly closed the connection while we were trying to
-- receive some data. This is a violation of the websocket RFC since the
-- TCP connection should only be closed after sending and receiving close
-- control messages.
| ConnectionClosed
-- | The client sent garbage, i.e. we could not parse the WebSockets stream.
| ParseException String
-- | The client sent invalid UTF-8. Note that this exception will only be
-- thrown if strict decoding is set in the connection options.
| UnicodeException String
deriving (Eq, Show, Typeable)
--------------------------------------------------------------------------------
instance Exception ConnectionException
--------------------------------------------------------------------------------
data ConnectionType = ServerConnection | ClientConnection
deriving (Eq, Ord, Show)
--------------------------------------------------------------------------------
-- | Replace an invalid input byte with the Unicode replacement character
-- U+FFFD.
decodeUtf8Lenient :: BL.ByteString -> TL.Text
decodeUtf8Lenient = TL.decodeUtf8With TL.lenientDecode
--------------------------------------------------------------------------------
-- | Throw an error if there is an invalid input byte.
decodeUtf8Strict :: BL.ByteString -> Either ConnectionException TL.Text
decodeUtf8Strict bl = unsafePerformIO $ try $
let txt = TL.decodeUtf8With (\err _ -> throw (UnicodeException err)) bl in
TL.length txt `seq` return txt
================================================
FILE: src/Network/WebSockets/Util/PubSub.hs
================================================
-- | This is a simple utility module to implement a publish-subscribe pattern.
-- Note that this only allows communication in a single direction: pusing data
-- from the server to connected clients (browsers).
--
-- Usage:
--
-- * Create a new 'PubSub' handle using 'newPubSub'
--
-- * Subscribe your clients using the 'subscribe' call
--
-- * Push new updates from the server using the 'publish' call
--
{-# LANGUAGE Rank2Types, ScopedTypeVariables #-}
module Network.WebSockets.Util.PubSub
( PubSub
, newPubSub
, publish
, subscribe
) where
import Control.Applicative ((<$>))
import Control.Exception (IOException, handle)
import Control.Monad (foldM, forever)
import Control.Monad.Trans (liftIO)
import Data.IntMap (IntMap)
import Data.List (foldl')
import qualified Control.Concurrent.MVar as MV
import qualified Data.IntMap as IM
import Network.WebSockets
data PubSub_ p = PubSub_
{ pubSubNextId :: Int
, pubSubSinks :: IntMap (Sink p)
}
addClient :: Sink p -> PubSub_ p -> (PubSub_ p, Int)
addClient sink (PubSub_ nid sinks) =
(PubSub_ (nid + 1) (IM.insert nid sink sinks), nid)
removeClient :: Int -> PubSub_ p -> PubSub_ p
removeClient ref ps = ps {pubSubSinks = IM.delete ref (pubSubSinks ps)}
-- | A handle which keeps track of subscribed clients
newtype PubSub p = PubSub (MV.MVar (PubSub_ p))
-- | Create a new 'PubSub' handle, with no clients initally connected
newPubSub :: IO (PubSub p)
newPubSub = PubSub <$> MV.newMVar PubSub_
{ pubSubNextId = 0
, pubSubSinks = IM.empty
}
-- | Broadcast a message to all connected clients
publish :: PubSub p -> Message p -> IO ()
publish (PubSub mvar) msg = MV.modifyMVar_ mvar $ \pubSub -> do
-- Take care to detect and remove broken clients
broken <- foldM publish' [] (IM.toList $ pubSubSinks pubSub)
return $ foldl' (\p b -> removeClient b p) pubSub broken
where
-- Publish the message to a single client, add it to the broken list if an
-- IOException occurs
publish' broken (i, s) =
handle (\(_ :: IOException) -> return (i : broken)) $ do
sendSink s msg
return broken
-- | Blocks forever
subscribe :: Protocol p => PubSub p -> WebSockets p ()
subscribe (PubSub mvar) = do
sink <- getSink
ref <- liftIO $ MV.modifyMVar mvar $ return . addClient sink
catchWsError loop $ const $ liftIO $
MV.modifyMVar_ mvar $ return . removeClient ref
where
loop = forever $ do
_ <- receiveDataMessage
return ()
================================================
FILE: src/Network/WebSockets.hs
================================================
--------------------------------------------------------------------------------
{-# LANGUAGE ScopedTypeVariables #-}
module Network.WebSockets
( -- * Incoming connections and handshaking
PendingConnection
, pendingRequest
, acceptRequest
, AcceptRequest(..)
, defaultAcceptRequest
, acceptRequestWith
, rejectRequest
, RejectRequest(..)
, defaultRejectRequest
, rejectRequestWith
-- * Main connection type
, Connection
-- * Options for connections
, ConnectionOptions (..)
, defaultConnectionOptions
-- ** Compression options
, CompressionOptions (..)
, PermessageDeflate (..)
, defaultPermessageDeflate
-- ** Protection limits
, SizeLimit (..)
-- * Sending and receiving messages
, receive
, receiveDataMessage
, receiveData
, send
, sendDataMessage
, sendDataMessages
, sendTextData
, sendTextDatas
, sendBinaryData
, sendBinaryDatas
, sendClose
, sendCloseCode
, sendPing
-- * HTTP Types
, Headers
, Request (..)
, RequestHead (..)
, getRequestSubprotocols
, Response (..)
, ResponseHead (..)
-- * WebSocket message types
, Message (..)
, ControlMessage (..)
, DataMessage (..)
, WebSocketsData (..)
-- * Exceptions
, HandshakeException (..)
, ConnectionException (..)
-- * Running a standalone server
, ServerApp
, runServer
, runServerWith
, ServerOptions (..)
, defaultServerOptions
, runServerWithOptions
-- * Utilities for writing your own server
, makeListenSocket
, makePendingConnection
, makePendingConnectionFromStream
-- * Running a client
, ClientApp
, runClient
, runClientWith
, runClientWithSocket
, runClientWithStream
, newClientConnection
-- * Utilities
, PingPongOptions(..)
, defaultPingPongOptions
, withPingPong
, withPingThread
, forkPingThread
) where
--------------------------------------------------------------------------------
import Network.WebSockets.Client
import Network.WebSockets.Connection
import Network.WebSockets.Connection.PingPong
import Network.WebSockets.Http
import Network.WebSockets.Server
import Network.WebSockets.Types
================================================
FILE: stack.yaml
================================================
resolver: nightly-2023-12-26
save-hackage-creds: false
flags:
websockets:
example: true
extra-deps:
- 'hakyll-4.15.1.0'
nix:
packages:
- 'zlib'
================================================
FILE: tests/autobahn/autobahn.sh
================================================
#!/usr/bin/bash
set -o errexit -o pipefail
# Finding the right python
AUTOBAHN_PYTHON="python2.7"
# Note that this script will be executed from the project root.
AUTOBAHN_ENV="$HOME/.virtualenvs/autobahn"
echo "Setting up virtualenv..."
if [[ ! -e "$AUTOBAHN_ENV" ]]; then
virtualenv --python="$AUTOBAHN_PYTHON" "$AUTOBAHN_ENV"
source "$AUTOBAHN_ENV/bin/activate"
pip install 'autobahn>=0.18'
pip install autobahntestsuite
else
source "$AUTOBAHN_ENV/bin/activate"
fi
echo "Launching websockets server in background..."
(cabal run websockets-autobahn -f Example) & WEBSOCKETS_AUTOBAHN_PID="$!"
sleep 10
echo "Getting config..."
cp tests/autobahn/fuzzingclient.json .
echo "Running autobahn testsuite..."
wstest -m fuzzingclient
echo "Killing websockets server..."
kill "$WEBSOCKETS_AUTOBAHN_PID"
echo "Producing report..."
python tests/autobahn/mini-report.py reports/servers/index.json
================================================
FILE: tests/autobahn/exclude-cases.py
================================================
# Travis only allows 50-minute jobs so we unfortunately cannot run all test
# cases. This script selects all the long cases based on a report from a
# previous test run. These can then be added to the 'exclude-cases' field.
#
# There are also some inherently broken cases. See:
#
# <http://autobahn.ws/reports/servers/>
import argparse
import json
BROKEN_CASES = [
'12.4.5',
'12.4.6',
'12.4.11',
'12.4.18',
'12.4.13',
'12.4.10',
'12.4.17',
'12.4.16',
'12.4.15',
'12.4.14',
'12.4.9',
'12.4.8',
'12.5.5',
'12.5.6',
'12.5.8',
'12.5.9',
'12.5.10',
'12.5.11',
'12.5.13',
'12.5.14',
'12.5.15',
'12.5.16',
'12.5.17',
'12.5.18'
]
if __name__ == '__main__':
parser = argparse.ArgumentParser()
parser.add_argument('report', help='JSON report', nargs='?')
parser.add_argument('--duration', type=int, help='Duration treshold',
default=1000)
options = parser.parse_args()
exclude_cases = []
# Exclude long tests from report
if options.report:
with open(options.report) as f:
report = json.load(f)
for server in report:
server_report = report[server]
for case_name in server_report:
case_report = server_report[case_name]
if case_report['duration'] >= options.duration:
exclude_cases += [case_name]
# Exclude broken tests
for case_name in BROKEN_CASES:
if not case_name in exclude_cases:
exclude_cases += [case_name]
print(json.dumps(exclude_cases))
================================================
FILE: tests/autobahn/fuzzingclient.json
================================================
{
"outdir": "./reports/servers",
"servers": [
{
"url": "ws://127.0.0.1:9001"
}
],
"cases": ["*"],
"exclude-cases": [
"12.4.5",
"12.4.6",
"12.4.8",
"12.4.9",
"12.4.10",
"12.4.11",
"12.4.13",
"12.4.14",
"12.4.15",
"12.4.16",
"12.4.17",
"12.4.18"
],
"exclude-agent-cases": {}
}
================================================
FILE: tests/autobahn/mini-report.py
================================================
# `wstest` doesn't actually set an informational error code so we'll need to do
# it ourselves.
import argparse
import json
import sys
if __name__ == '__main__':
parser = argparse.ArgumentParser()
parser.add_argument('report', help='JSON report')
options = parser.parse_args()
with open(options.report) as f:
report = json.load(f)
behaviors = {}
for server in report:
server_report = report[server]
for case_name in server_report:
case_report = server_report[case_name]
behavior = case_report['behavior']
if behavior in behaviors:
behaviors[behavior] += [case_name]
else:
behaviors[behavior] = [case_name]
if 'FAILED' in behaviors:
print(' Failed cases:')
for case_name in behaviors['FAILED']:
print('- ' + case_name)
sys.exit(1)
else:
print(str(len(behaviors['OK'])) + ' cases passed')
================================================
FILE: tests/autobahn/server.hs
================================================
--------------------------------------------------------------------------------
-- | The server part of the tests
{-# LANGUAGE OverloadedStrings #-}
module Main
( main
) where
{-
## once
virtualenv pyt
source pyt/bin/activate
### pip install --upgrade setuptools ### possibly
pip install autobahntestsuite
## each time
source pyt/bin/activate
mkdir -p test && cd test
wstest -m fuzzingclient
websockets-autobahn
-}
--------------------------------------------------------------------------------
import Control.Exception (catch)
import Data.ByteString.Lazy.Char8 ()
import Data.String (fromString)
import Data.Version (showVersion)
--------------------------------------------------------------------------------
import qualified Network.WebSockets as WS
import qualified Paths_websockets
--------------------------------------------------------------------------------
echoDataMessage :: WS.Connection -> IO ()
echoDataMessage conn = go 0
where
go :: Int -> IO ()
go x = do
msg <- WS.receiveDataMessage conn
WS.sendDataMessage conn msg
go (x + 1)
--------------------------------------------------------------------------------
infoHeaders :: WS.Headers
infoHeaders =
[ ( "Server"
, fromString $ "websockets/" ++ showVersion Paths_websockets.version
)
]
--------------------------------------------------------------------------------
-- | Application
application :: WS.ServerApp
application pc = do
conn <- WS.acceptRequestWith pc WS.defaultAcceptRequest
{ WS.acceptHeaders = infoHeaders
}
echoDataMessage conn `catch` handleClose
where
handleClose (WS.CloseRequest i "") =
putStrLn $ "Clean close (" ++ show i ++ ")"
handleClose (WS.CloseRequest i msg) =
putStrLn $ "Clean close (" ++ show i ++ "): " ++ show msg
handleClose WS.ConnectionClosed =
putStrLn "Unexpected connection closed exception"
handleClose (WS.ParseException e) =
putStrLn $ "Recevied parse exception: " ++ show e
handleClose (WS.UnicodeException e) =
putStrLn $ "Recevied unicode exception: " ++ show e
--------------------------------------------------------------------------------
-- | Accepts clients, spawns a single handler for each one.
main :: IO ()
main = WS.runServerWithOptions options application
where
options = WS.defaultServerOptions
{ WS.serverHost = "0.0.0.0"
, WS.serverPort = 9001
, WS.serverConnectionOptions = WS.defaultConnectionOptions
{ WS.connectionCompressionOptions =
WS.PermessageDeflateCompression WS.defaultPermessageDeflate
, WS.connectionStrictUnicode = True
}
}
================================================
FILE: tests/haskell/Network/WebSockets/Extensions/PermessageDeflate/Tests.hs
================================================
--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
module Network.WebSockets.Extensions.PermessageDeflate.Tests
( tests
) where
--------------------------------------------------------------------------------
import Control.Exception (try)
import qualified Data.ByteString.Lazy as BL
import Network.WebSockets.Extensions.PermessageDeflate
import Network.WebSockets.Types
import Network.WebSockets.Connection.Options
import Test.Framework (Test,
testGroup)
import Test.Framework.Providers.HUnit (testCase)
import Test.HUnit (Assertion,
(@?=))
--------------------------------------------------------------------------------
tests :: Test
tests = testGroup "Network.WebSockets.Extensions.PermessageDeflate.Tests"
[ testCase "OK 1" $ do
inflater <- makeMessageInflater
(SizeLimit 100) (Just defaultPermessageDeflate)
message <- inflater $ DataMessage True False False (Binary deflated100)
message @?=
DataMessage False False False (Binary inflated100)
, testCase "Exceed 1" $ do
inflater <- makeMessageInflater
(SizeLimit 99) (Just defaultPermessageDeflate)
assertParseException $
inflater $ DataMessage True False False (Binary deflated100)
]
where
assertParseException :: IO a -> Assertion
assertParseException io = do
errOrX <- try io
case errOrX of
Left (ParseException _) -> return ()
_ -> fail "Excepted ParseException"
-- This inflates to 100 bytes.
deflated100 = "b`\160=\NUL\NUL"
inflated100 = BL.replicate 100 0
================================================
FILE: tests/haskell/Network/WebSockets/Extensions/Tests.hs
================================================
--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
module Network.WebSockets.Extensions.Tests
( tests
) where
--------------------------------------------------------------------------------
import Network.WebSockets.Extensions
import Test.Framework (Test, testGroup)
import Test.Framework.Providers.HUnit (testCase)
import Test.HUnit ((@?=))
--------------------------------------------------------------------------------
tests :: Test
tests = testGroup "Network.WebSockets.Extensions.Tests"
[ testCase "parseExtensionDescriptions 01" $ do
parseExtensionDescriptions "permessage-deflate" @?= Right
[ ExtensionDescription "permessage-deflate" [] ]
, testCase "parseExtensionDescriptions 02" $ do
parseExtensionDescriptions "permessage-deflate; client_max_window_bits; server_max_window_bits=10" @?= Right
[ ExtensionDescription "permessage-deflate"
[ ("client_max_window_bits", Nothing)
, ("server_max_window_bits", Just "10")
]
]
, testCase "parseExtensionDescriptions 03" $ do
parseExtensionDescriptions "permessage-deflate; client_max_window_bits=15; server_max_window_bits=10, permessage-deflate; client_max_window_bits,permessage-deflate; client_max_window_bits=15; client_max_window_bits=10" @?= Right
[ ExtensionDescription "permessage-deflate"
[ ("client_max_window_bits", Just "15")
, ("server_max_window_bits", Just "10")
]
, ExtensionDescription "permessage-deflate"
[ ("client_max_window_bits", Nothing)
]
, ExtensionDescription "permessage-deflate"
[ ("client_max_window_bits", Just "15")
, ("client_max_window_bits", Just "10")
]
]
]
================================================
FILE: tests/haskell/Network/WebSockets/Handshake/Tests.hs
================================================
--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
module Network.WebSockets.Handshake.Tests
( tests
) where
--------------------------------------------------------------------------------
import Control.Concurrent (forkIO)
import Control.Exception (handle)
import Data.ByteString.Char8 ()
import Data.IORef (newIORef, readIORef,
writeIORef)
import Data.Maybe (fromJust)
import Test.Framework (Test, testGroup)
import Test.Framework.Providers.HUnit (testCase)
import Test.HUnit (Assertion, assert, (@?=))
--------------------------------------------------------------------------------
import Network.WebSockets
import Network.WebSockets.Connection
import Network.WebSockets.Http
import qualified Network.WebSockets.Stream as Stream
--------------------------------------------------------------------------------
tests :: Test
tests = testGroup "Network.WebSockets.Handshake.Test"
[ testCase "handshake Hybi13" testHandshakeHybi13
, testCase "handshake Hybi13 with subprotocols" testHandshakeHybi13WithProto
, testCase "handshake Hybi13 with headers" testHandshakeHybi13WithHeaders
, testCase "handshake Hybi13 with subprotocols and headers" testHandshakeHybi13WithProtoAndHeaders
, testCase "handshake reject" testHandshakeReject
, testCase "handshake reject with custom code" testHandshakeRejectWithCode
, testCase "handshake Hybi9000" testHandshakeHybi9000
]
--------------------------------------------------------------------------------
testHandshake :: RequestHead -> (PendingConnection -> IO a) -> IO ResponseHead
testHandshake rq app = do
echo <- Stream.makeEchoStream
_ <- forkIO $ do
_ <- app (PendingConnection defaultConnectionOptions rq nullify echo)
return ()
mbRh <- Stream.parse echo decodeResponseHead
Stream.close echo
case mbRh of
Nothing -> fail "testHandshake: No response"
Just rh -> return rh
where
nullify _ = return ()
--------------------------------------------------------------------------------
(!) :: Eq a => [(a, b)] -> a -> b
assoc ! key = fromJust (lookup key assoc)
--------------------------------------------------------------------------------
rq13 :: RequestHead
rq13 = RequestHead "/mychat"
[ ("Host", "server.example.com")
, ("Upgrade", "websocket")
, ("Connection", "Upgrade")
, ("Sec-WebSocket-Key", "x3JJHMbDL1EzLkh9GBhXDw==")
, ("Sec-WebSocket-Protocol", "chat, superchat")
, ("Sec-WebSocket-Version", "13")
, ("Origin", "http://example.com")
]
False
--------------------------------------------------------------------------------
testHandshakeHybi13 :: Assertion
testHandshakeHybi13 = do
onAcceptFired <- newIORef False
ResponseHead code message headers <- testHandshake rq13 $ \pc ->
acceptRequest pc {pendingOnAccept = \_ -> writeIORef onAcceptFired True}
readIORef onAcceptFired >>= assert
code @?= 101
message @?= "WebSocket Protocol Handshake"
headers ! "Sec-WebSocket-Accept" @?= "HSmrc0sMlYUkAGmm5OPpG2HaGWk="
headers ! "Connection" @?= "Upgrade"
lookup "Sec-WebSocket-Protocol" headers @?= Nothing
--------------------------------------------------------------------------------
testHandshakeHybi13WithProto :: Assertion
testHandshakeHybi13WithProto = do
onAcceptFired <- newIORef False
ResponseHead code message headers <- testHandshake rq13 $ \pc -> do
getRequestSubprotocols (pendingRequest pc) @?= ["chat", "superchat"]
acceptRequestWith pc {pendingOnAccept = \_ -> writeIORef onAcceptFired True}
(AcceptRequest (Just "superchat") [])
readIORef onAcceptFired >>= assert
code @?= 101
message @?= "WebSocket Protocol Handshake"
headers ! "Sec-WebSocket-Accept" @?= "HSmrc0sMlYUkAGmm5OPpG2HaGWk="
headers ! "Connection" @?= "Upgrade"
headers ! "Sec-WebSocket-Protocol" @?= "superchat"
--------------------------------------------------------------------------------
testHandshakeHybi13WithHeaders :: Assertion
testHandshakeHybi13WithHeaders = do
onAcceptFired <- newIORef False
ResponseHead code message headers <- testHandshake rq13 $ \pc -> do
getRequestSubprotocols (pendingRequest pc) @?= ["chat", "superchat"]
acceptRequestWith pc {pendingOnAccept = \_ -> writeIORef onAcceptFired True}
(AcceptRequest Nothing [("Set-Cookie","sid=foo")])
readIORef onAcceptFired >>= assert
code @?= 101
message @?= "WebSocket Protocol Handshake"
headers ! "Sec-WebSocket-Accept" @?= "HSmrc0sMlYUkAGmm5OPpG2HaGWk="
headers ! "Connection" @?= "Upgrade"
headers ! "Set-Cookie" @?= "sid=foo"
lookup "Sec-WebSocket-Protocol" headers @?= Nothing
--------------------------------------------------------------------------------
testHandshakeHybi13WithProtoAndHeaders :: Assertion
testHandshakeHybi13WithProtoAndHeaders = do
onAcceptFired <- newIORef False
ResponseHead code message headers <- testHandshake rq13 $ \pc -> do
getRequestSubprotocols (pendingRequest pc) @?= ["chat", "superchat"]
acceptRequestWith pc {pendingOnAccept = \_ -> writeIORef onAcceptFired True}
(AcceptRequest (Just "superchat") [("Set-Cookie","sid=foo")])
readIORef onAcceptFired >>= assert
code @?= 101
message @?= "WebSocket Protocol Handshake"
headers ! "Sec-WebSocket-Accept" @?= "HSmrc0sMlYUkAGmm5OPpG2HaGWk="
headers ! "Connection" @?= "Upgrade"
headers ! "Sec-WebSocket-Protocol" @?= "superchat"
headers ! "Set-Cookie" @?= "sid=foo"
--------------------------------------------------------------------------------
testHandshakeReject :: Assertion
testHandshakeReject = do
ResponseHead code _ _ <- testHandshake rq13 $ \pc ->
rejectRequest pc "YOU SHALL NOT PASS"
code @?= 400
--------------------------------------------------------------------------------
testHandshakeRejectWithCode :: Assertion
testHandshakeRejectWithCode = do
ResponseHead code _ _ <- testHandshake rq13 $ \pc ->
rejectRequestWith pc defaultRejectRequest
{ rejectBody = "YOU SHALL NOT PASS"
, rejectCode = 401
}
code @?= 401
--------------------------------------------------------------------------------
-- I don't believe this one is supported yet
rq9000 :: RequestHead
rq9000 = RequestHead "/chat"
[ ("Host", "server.example.com")
, ("Upgrade", "websocket")
, ("Connection", "Upgrade")
, ("Sec-WebSocket-Key", "dGhlIHNhbXBsZSBub25jZQ==")
, ("Sec-WebSocket-Origin", "http://example.com")
, ("Sec-WebSocket-Protocol", "chat, superchat")
, ("Sec-WebSocket-Version", "9000")
]
False
--------------------------------------------------------------------------------
testHandshakeHybi9000 :: Assertion
testHandshakeHybi9000 = do
ResponseHead code _ headers <- testHandshake rq9000 $ \pc ->
flip handle (acceptRequest pc) $ \e -> case e of
NotSupported -> return undefined
_ -> error $ "Unexpected Exception: " ++ show e
code @?= 400
headers ! "Sec-WebSocket-Version" @?= "13"
================================================
FILE: tests/haskell/Network/WebSockets/Http/Tests.hs
================================================
--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
module Network.WebSockets.Http.Tests
( tests
) where
--------------------------------------------------------------------------------
import qualified Data.Attoparsec.ByteString as A
import qualified Data.ByteString.Char8 as BC
import Test.Framework (Test, testGroup)
import Test.Framework.Providers.HUnit (testCase)
import Test.HUnit (Assertion, assert)
--------------------------------------------------------------------------------
import Network.WebSockets.Http
--------------------------------------------------------------------------------
tests :: Test
tests = testGroup "Network.WebSockets.Http.Tests"
[ testCase "jwebsockets response" jWebSocketsResponse
, testCase "chromium response" chromiumResponse
, testCase "matchbook response" matchbookResponse
]
--------------------------------------------------------------------------------
-- | This is a specific response sent by jwebsockets which caused trouble
jWebSocketsResponse :: Assertion
jWebSocketsResponse = assert $ case A.parseOnly decodeResponseHead input of
Left err -> error err
Right _ -> True
where
input = BC.intercalate "\r\n"
[ "HTTP/1.1 101 Switching Protocols"
, "Upgrade: websocket"
, "Connection: Upgrade"
, "Sec-WebSocket-Accept: Ha0QR1T9CoYx/nqwHsVnW8KVTSo="
, "Sec-WebSocket-Origin: "
, "Sec-WebSocket-Location: ws://127.0.0.1"
, "Set-Cookie: JWSSESSIONID=2e0690e2e328f327056a5676b6a890e3; HttpOnly"
, ""
, ""
]
--------------------------------------------------------------------------------
-- | This is a specific response sent by chromium which caused trouble
chromiumResponse :: Assertion
chromiumResponse = assert $ case A.parseOnly decodeResponseHead input of
Left err -> error err
Right _ -> True
where
input = BC.intercalate "\r\n"
[ "HTTP/1.1 500 Internal Error"
, "Content-Type:text/html"
, "Content-Length:23"
, ""
, "No such target id: 20_1"
]
--------------------------------------------------------------------------------
-- | This is a specific response sent by Matchbook.com which caused trouble
matchbookResponse :: Assertion
matchbookResponse = assert $ case A.parseOnly decodeResponseHead input of
Left err -> error err
Right _ -> True
where
input = BC.intercalate "\r\n"
[ "HTTP/1.1 101 "
, "Date: Mon, 22 May 2017 19:39:08 GMT"
, "Connection: upgrade"
, "Set-Cookie: __cfduid=deadbeefdeadbeefdeadbeefdeadbeefdeadbeefdea; expires=Tue, 22-May-18 19:39:08 GMT; path=/; domain=.matchbook.com; HttpOnly"
, "X-Content-Type-Options: nosniff"
, "X-XSS-Protection: 1; mode=block"
, "X-Frame-Options: DENY"
, "Upgrade: websocket"
, "Sec-WebSocket-Accept: dEadB33fDeadbEEfD3aDbE3Fdea="
, "X-MB-HA: edge-socket"
, "X-MB-HAP: haproxy01aws"
, "Server: cloudflare-nginx"
, "CF-RAY: 3632deadbeef5b33-HEL"
, ""
, ""
]
================================================
FILE: tests/haskell/Network/WebSockets/Hybi13/Demultiplex/Tests.hs
================================================
--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
module Network.WebSockets.Hybi13.Demultiplex.Tests
( tests
) where
--------------------------------------------------------------------------------
import Control.Applicative ((<$>))
import qualified Data.ByteString.Lazy as BL
import Network.WebSockets
import Network.WebSockets.Hybi13.Demultiplex
import Prelude
import Test.Framework (Test, testGroup)
import Test.Framework.Providers.HUnit (testCase)
import Test.HUnit (Assertion, (@=?))
--------------------------------------------------------------------------------
tests :: Test
tests = testGroup "Network.WebSockets.Hybi13.Demultiplex.Tests"
[ testMessageDataSizeLimit
]
--------------------------------------------------------------------------------
testMessageDataSizeLimit :: Test
testMessageDataSizeLimit = testGroup "testMessageDataSizeLimit Hybi13"
[ testCase "OK 1" $
Right [DataMessage False False False (Binary (mkZeroes 100))] @=?
testDemultiplex (SizeLimit 100) (fragmented 5 20)
, testCase "Exceeds 1" $
assertLeft $
testDemultiplex (SizeLimit 99) (fragmented 5 20)
, testCase "Exceeds 2" $
assertLeft $
testDemultiplex (SizeLimit 100) (fragmented 6 20)
, testCase "Exceeds 3" $
assertLeft $
testDemultiplex (SizeLimit 100) (fragmented 101 1)
, testCase "Exceeds 4" $
assertLeft $
testDemultiplex (SizeLimit 100) (fragmented 1 101)
]
where
fragmented :: Int -> Int -> [Frame]
fragmented n size =
let payload = mkZeroes size in
[Frame False False False False BinaryFrame payload] ++
replicate (n - 2) (Frame False False False False ContinuationFrame payload) ++
[Frame True False False False ContinuationFrame payload]
mkZeroes :: Int -> BL.ByteString
mkZeroes size = BL.replicate (fromIntegral size) 0
assertLeft :: Either a b -> Assertion
assertLeft (Left _) = return ()
assertLeft (Right _) = fail "Expecting test to fail"
--------------------------------------------------------------------------------
testDemultiplex
:: SizeLimit
-> [Frame]
-> Either ConnectionException [Message]
testDemultiplex messageLimit = go emptyDemultiplexState
where
go _state0 [] = return []
go state0 (frame : frames) = case demultiplex messageLimit state0 frame of
(DemultiplexContinue, state1) -> go state1 frames
(DemultiplexError err, _) -> Left err
(DemultiplexSuccess m, state1) -> (m :) <$> go state1 frames
================================================
FILE: tests/haskell/Network/WebSockets/Mask/Tests.hs
================================================
--------------------------------------------------------------------------------
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.WebSockets.Mask.Tests
( tests
) where
--------------------------------------------------------------------------------
import qualified Data.Binary.Get as Get
import Data.Bits (xor)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Network.WebSockets.Hybi13.Mask
import Test.Framework (Test, testGroup)
import Test.Framework.Providers.QuickCheck2 (testProperty)
import Test.QuickCheck (Arbitrary (..), (===))
import qualified Test.QuickCheck as QC
--------------------------------------------------------------------------------
import Network.WebSockets.Tests.Util
tests :: Test
tests = testGroup "Network.WebSockets.Masks.Tests"
[ testProperty "correct fast masking" testMasking ]
maskPayload' :: Maybe B.ByteString -> BL.ByteString -> BL.ByteString
maskPayload' Nothing = id
maskPayload' (Just mask) = snd . BL.mapAccumL f (cycle $ B.unpack mask)
where
f [] !c = ([], c)
f (m:ms) !c = (ms, m `xor` c)
newtype AMask = AMask B.ByteString deriving (Show)
instance Arbitrary AMask where
arbitrary = do
c1 <- arbitrary
c2 <- arbitrary
c3 <- arbitrary
c4 <- arbitrary
return (AMask (B.pack [c1,c2,c3,c4]))
newtype APkt = APkt BL.ByteString deriving (Show)
instance Arbitrary APkt where
arbitrary = do
b1 <- arbitraryByteString
b2 <- arbitraryByteString
return $ APkt (b1 `BL.append` b2) -- Just for sure to test correctly different alignments
shrink (APkt bs) =
map APkt [ BL.append a b | (a, b) <- zip (BL.inits bs) (tail $ BL.tails bs) ]
testMasking :: QC.Property
testMasking =
QC.forAllShrink QC.arbitrary QC.shrink $ \(AMask mask, APkt pkt) ->
let wmask = Get.runGet parseMask (BL.fromStrict mask)
in maskPayload' (Just mask) pkt === maskPayload (Just wmask) pkt
================================================
FILE: tests/haskell/Network/WebSockets/Server/Tests.hs
================================================
--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Network.WebSockets.Server.Tests
( tests
) where
--------------------------------------------------------------------------------
import Control.Applicative ((<$>), (<|>))
import Control.Concurrent (forkIO, killThread,
threadDelay)
import Control.Concurrent.Async (Async, async, cancel)
import Control.Exception (SomeException, catch, handle)
import Control.Monad (forever, replicateM, unless)
import Data.IORef (IORef, newIORef, readIORef,
writeIORef)
--------------------------------------------------------------------------------
import qualified Data.ByteString.Lazy as BL
import Data.Text (Text)
import System.Environment (getEnvironment)
import Test.Framework (Test, testGroup)
import Test.Framework.Providers.HUnit (testCase)
import Test.HUnit (Assertion, assert, (@=?))
import Test.QuickCheck (Arbitrary, arbitrary)
import Test.QuickCheck.Gen (Gen (..))
import Test.QuickCheck.Random (newQCGen)
--------------------------------------------------------------------------------
import Network.WebSockets
import Network.WebSockets.Tests.Util
--------------------------------------------------------------------------------
tests :: Test
tests = testGroup "Network.WebSockets.Server.Tests"
[ testCase "simple server/client" testSimpleServerClient
, testCase "bulk server/client" testBulkServerClient
, testCase "onPong" testOnPong
, testCase "ipv6 server" testIpv6Server
, testCase "reject request" testRejectRequest
]
--------------------------------------------------------------------------------
testSimpleServerClient :: Assertion
testSimpleServerClient = testServerClient "127.0.0.1" $ \conn -> mapM_ (sendTextData conn)
--------------------------------------------------------------------------------
-- | This is a bit ugly but it seems CI services don't support ipv6 in 2018.
skipIpv6Incompatible :: Assertion -> Assertion
skipIpv6Incompatible assertion = do
env <- getEnvironment
case lookup "TRAVIS" env <|> lookup "CIRCLECI" env of
Just "true" -> return ()
_ -> assertion
--------------------------------------------------------------------------------
testIpv6Server :: Assertion
testIpv6Server = skipIpv6Incompatible $
testServerClient "::1" $ \conn -> mapM_ (sendTextData conn)
--------------------------------------------------------------------------------
testBulkServerClient :: Assertion
testBulkServerClient = testServerClient "127.0.0.1" sendTextDatas
--------------------------------------------------------------------------------
testServerClient :: String -> (Connection -> [BL.ByteString] -> IO ()) -> Assertion
testServerClient host sendMessages = withEchoServer host 42940 "Bye" $ do
texts <- map unArbitraryUtf8 <$> sample
texts' <- runClient host 42940 "/chat" $ client texts
texts @=? texts'
where
client :: [BL.ByteString] -> ClientApp [BL.ByteString]
client texts conn = do
sendMessages conn texts
texts' <- replicateM (length texts) (receiveData conn)
sendClose conn ("Bye" :: BL.ByteString)
expectCloseException conn "Bye"
return texts'
--------------------------------------------------------------------------------
testRejectRequest :: Assertion
testRejectRequest = withRejectingServer
where
client :: ClientApp ()
client _ = error "Client should not be able to connect"
server :: ServerApp
server pendingConnection = rejectRequest pendingConnection "Bye"
withRejectingServer :: IO ()
withRejectingServer = do
serverThread <- async $ runServer "127.0.0.1" 42940 server
waitSome
() <- runClient "127.0.0.1" 42940 "/chat" client `catch` handler
waitSome
cancel serverThread
return ()
handler :: HandshakeException -> IO ()
handler (RequestRejected _ response) = do
responseCode response @=? 400
handler exc = error $ "Unexpected exception " ++ show exc
--------------------------------------------------------------------------------
testOnPong :: Assertion
testOnPong = withEchoServer "127.0.0.1" 42941 "Bye" $ do
gotPong <- newIORef False
let opts = defaultConnectionOptions
{ connectionOnPong = writeIORef gotPong True
}
rcv <- runClientWith "127.0.0.1" 42941 "/" opts [] client
assert rcv
assert =<< readIORef gotPong
where
client :: ClientApp Bool
client conn = do
sendPing conn ("What's a fish without an eye?" :: Text)
sendTextData conn ("A fsh!" :: Text)
msg <- receiveData conn
sendCloseCode conn 1000 ("Bye" :: BL.ByteString)
expectCloseException conn "Bye"
return $ "A fsh!" == (msg :: Text)
--------------------------------------------------------------------------------
sample :: Arbitrary a => IO [a]
sample = do
gen <- newQCGen
return $ (unGen arbitrary) gen 512
--------------------------------------------------------------------------------
waitSome :: IO ()
waitSome = threadDelay $ 200 * 1000
--------------------------------------------------------------------------------
withEchoServer :: String -> Int -> BL.ByteString -> IO a -> IO a
withEchoServer host port expectedClose action = do
cRef <- newIORef False
serverThread <- async $ runServer host port (\c -> server c `catch` handleClose cRef)
waitSome
result <- action
waitSome
cancel serverThread
closeCalled <- readIORef cRef
unless closeCalled $ error "Expecting the CloseRequest exception"
return result
where
server :: ServerApp
server pc = do
conn <- acceptRequest pc
forever $ do
msg <- receiveDataMessage conn
sendDataMessage conn msg
handleClose :: IORef Bool -> ConnectionException -> IO ()
handleClose cRef (CloseRequest i msg) = do
i @=? 1000
msg @=? expectedClose
writeIORef cRef True
handleClose _ ConnectionClosed =
error "Unexpected connection closed exception"
handleClose _ (ParseException _) =
error "Unexpected parse exception"
handleClose _ (UnicodeException _) =
error "Unexpected unicode exception"
--------------------------------------------------------------------------------
expectCloseException :: Connection -> BL.ByteString -> IO ()
expectCloseException conn msg = act `catch` handler
where
act = receiveDataMessage conn >> error "Expecting CloseRequest exception"
handler (CloseRequest i msg') = do
i @=? 1000
msg' @=? msg
handler ConnectionClosed = error "Unexpected connection closed"
handler (ParseException _) = error "Unexpected parse exception"
handler (UnicodeException _) = error "Unexpected unicode exception"
================================================
FILE: tests/haskell/Network/WebSockets/Tests/Util.hs
================================================
--------------------------------------------------------------------------------
module Network.WebSockets.Tests.Util
( ArbitraryUtf8 (..)
, arbitraryUtf8
, arbitraryByteString
) where
--------------------------------------------------------------------------------
import Control.Applicative ((<$>))
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import Test.QuickCheck (Arbitrary (..), Gen)
--------------------------------------------------------------------------------
import Network.WebSockets.Types
--------------------------------------------------------------------------------
newtype ArbitraryUtf8 = ArbitraryUtf8 {unArbitraryUtf8 :: BL.ByteString}
deriving (Eq, Ord, Show)
--------------------------------------------------------------------------------
instance Arbitrary ArbitraryUtf8 where
arbitrary = ArbitraryUtf8 <$> arbitraryUtf8
--------------------------------------------------------------------------------
arbitraryUtf8 :: Gen BL.ByteString
arbitraryUtf8 = toLazyByteString . TL.encodeUtf8 . TL.pack <$> arbitrary
--------------------------------------------------------------------------------
arbitraryByteString :: Gen BL.ByteString
arbitraryByteString = BL.pack <$> arbitrary
================================================
FILE: tests/haskell/Network/WebSockets/Tests.hs
================================================
--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Network.WebSockets.Tests
( tests
) where
--------------------------------------------------------------------------------
import qualified Data.ByteString.Builder as Builder
import Control.Applicative ((<$>))
import Control.Concurrent (forkIO)
import Control.Exception (try)
import Control.Monad (replicateM)
import Data.Binary.Get (runGetOrFail)
import qualified Data.ByteString.Lazy as BL
import Data.List (intersperse)
import Data.Maybe (catMaybes)
import Data.Monoid (mempty, mconcat)
import Network.WebSockets
import qualified Network.WebSockets.Hybi13 as Hybi13
import Network.WebSockets.Hybi13.Demultiplex
import Network.WebSockets.Protocol
import qualified Network.WebSockets.Stream as Stream
import Network.WebSockets.Tests.Util
import Network.WebSockets.Types
import Test.Framework (Test, testGroup)
import Test.Framework.Providers.HUnit (testCase)
import Test.Framework.Providers.QuickCheck2 (testProperty)
import Test.HUnit ((@=?))
import Test.QuickCheck (Arbitrary (..), Gen,
Property)
import qualified Test.QuickCheck as QC
import qualified Test.QuickCheck.Monadic as QC
import Prelude
--------------------------------------------------------------------------------
tests :: Test
tests = testGroup "Network.WebSockets.Test"
[ testProperty "simple encode/decode Hybi13" (testSimpleEncodeDecode Hybi13)
, testProperty "fragmented Hybi13" testFragmentedHybi13
, testRfc_6455_5_5_1
, testRfc_6455_5_5_2
, testFramePayloadSizeLimit
]
--------------------------------------------------------------------------------
testSimpleEncodeDecode :: Protocol -> Property
testSimpleEncodeDecode protocol = QC.monadicIO $
QC.forAllM QC.arbitrary $ \msgs -> QC.run $ do
echo <- Stream.makeEchoStream
parse <- decodeMessages protocol mempty mempty echo
write <- encodeMessages protocol ClientConnection echo
_ <- forkIO $ write msgs
msgs' <- catMaybes <$> replicateM (length msgs) parse
Stream.close echo
msgs @=? msgs'
--------------------------------------------------------------------------------
testFragmentedHybi13 :: Property
testFragmentedHybi13 = QC.monadicIO $
QC.forAllM QC.arbitrary $ \fragmented -> QC.run $ do
echo <- Stream.makeEchoStream
parse <- Hybi13.decodeMessages mempty mempty echo
-- is' <- Streams.filter isDataMessage =<< Hybi13.decodeMessages is
-- Simple hacky encoding of all frames
_ <- forkIO $ do
mapM_ (Stream.write echo)
[ Builder.toLazyByteString (Hybi13.encodeFrame Nothing f)
| FragmentedMessage _ frames <- fragmented
, f <- frames
]
Stream.close echo
-- Check if we got all data
msgs <- filter isDataMessage <$> parseAll parse
[msg | FragmentedMessage msg _ <- fragmented] @=? msgs
where
isDataMessage (ControlMessage _) = False
isDataMessage (DataMessage _ _ _ _) = True
parseAll parse = do
mbMsg <- try parse
case mbMsg of
Left ConnectionClosed -> return []
Left _ -> return []
Right (Just msg) -> (msg :) <$> parseAll parse
Right Nothing -> return []
--------------------------------------------------------------------------------
testRfc_6455_5_5_1 :: Test
testRfc_6455_5_5_1 =
testCase "RFC 6455, 5.5: Frame encoder shall truncate control frame payload to 125 bytes" $ do
260 @=? BL.length (encodedFrame ContinuationFrame)
260 @=? BL.length (encodedFrame TextFrame)
260 @=? BL.length (encodedFrame BinaryFrame)
127 @=? BL.length (encodedFrame CloseFrame)
127 @=? BL.length (encodedFrame PingFrame)
127 @=? BL.length (encodedFrame PongFrame)
where
payload256 = BL.replicate 256 0
encodedFrame ft
= Builder.toLazyByteString
$ Hybi13.encodeFrame Nothing (Frame True False False False ft payload256)
--------------------------------------------------------------------------------
testRfc_6455_5_5_2 :: Test
testRfc_6455_5_5_2 =
testCase "RFC 6455, 5.5: Frame decoder shall fail if control frame payload length > 125 bytes" $
Left (BL.drop 4 ping126, 4, errMsg) @=? runGetOrFail (Hybi13.parseFrame mempty) ping126
where
errMsg = "Control Frames must not carry payload > 125 bytes!"
ping126 = mconcat
[ "\137\254\NUL~\219\SI\190\252\219\SI\190\252\219\SI\190\252\219"
, "\SI\190\252\219\SI\190\252\219\SI\190\252\219\SI\190\252\219"
, "\SI\190\252\219\SI\190\252\219\SI\190\252\219\SI\190\252\219"
, "\SI\190\252\219\SI\190\252\219\SI\190\252\219\SI\190\252\219"
, "\SI\190\252\219\SI\190\252\219\SI\190\252\219\SI\190\252\219"
, "\SI\190\252\219\SI\190\252\219\SI\190\252\219\SI\190\252\219"
, "\SI\190\252\219\SI\190\252\219\SI\190\252\219\SI\190\252\219"
, "\SI\190\252\219\SI\190\252\219\SI\190\252\219\SI\190\252\219"
, "\SI\190\252\219\SI"
]
testFramePayloadSizeLimit :: Test
testFramePayloadSizeLimit = testGroup "FramePayloadSizeLimit Hybi13"
[ testCase "OK 1" $ case parse (frame 99) of
Right _ -> return ()
Left _ -> fail "Expecting successful parse."
, testCase "OK 2" $ case parse (frame 100) of
Right _ -> return ()
Left _ -> fail "Expecting successful parse."
, testCase "Exceed" $ case parse (frame 101) of
Right _ -> fail "Expecting parse to fail."
Left _ -> return ()
]
where
parse = runGetOrFail (Hybi13.parseFrame (SizeLimit 100))
frame n = Builder.toLazyByteString $ Hybi13.encodeFrame Nothing $
Frame True False False False BinaryFrame (BL.replicate n 20)
--------------------------------------------------------------------------------
instance Arbitrary Message where
arbitrary = QC.oneof
[ do
payload <- BL.take 125 . BL.pack <$> arbitrary
return $ ControlMessage (Ping payload)
, do
payload <- BL.take 125 . BL.pack <$> arbitrary
return $ ControlMessage (Pong payload)
, do
payload <- BL.pack <$> arbitrary
return $ DataMessage False False False (Text payload Nothing)
, do
payload <- BL.pack <$> arbitrary
return $ DataMessage False False False (Binary payload)
]
--------------------------------------------------------------------------------
data FragmentedMessage = FragmentedMessage Message [Frame]
deriving (Show)
--------------------------------------------------------------------------------
instance Arbitrary FragmentedMessage where
arbitrary = do
-- Pick a frametype and a corresponding random payload
ft <- QC.elements [TextFrame, BinaryFrame]
payload <- case ft of
TextFrame -> arbitraryUtf8
_ -> arbitraryByteString
fragments <- arbitraryFragmentation payload
let fs = makeFrames $ zip (ft : repeat ContinuationFrame) fragments
msg = case ft of
TextFrame -> DataMessage False False False (Text payload Nothing)
BinaryFrame -> DataMessage False False False (Binary payload)
_ -> error "Arbitrary FragmentedMessage crashed"
interleaved <- arbitraryInterleave genControlFrame fs
return $ FragmentedMessage msg interleaved
-- return $ FragmentedMessage msg fs
where
makeFrames [] = []
makeFrames [(ft, pl)] = [Frame True False False False ft pl]
makeFrames ((ft, pl) : fr) =
Frame False False False False ft pl : makeFrames fr
genControlFrame = QC.elements
[ Frame True False False False PingFrame "Herp"
, Frame True False False False PongFrame "Derp"
]
--------------------------------------------------------------------------------
arbitraryFragmentation :: BL.ByteString -> Gen [BL.ByteString]
arbitraryFragmentation bs = arbitraryFragmentation' bs
where
len :: Int
len = fromIntegral $ BL.length bs
arbitraryFragmentation' bs' = do
-- TODO: we currently can't send packets of length 0. We should
-- investigate why (regardless of the spec).
n <- QC.choose (1, len - 1)
let (l, r) = BL.splitAt (fromIntegral n) bs'
case r of
"" -> return [l]
_ -> (l :) <$> arbitraryFragmentation' r
--------------------------------------------------------------------------------
arbitraryInterleave :: Gen a -> [a] -> Gen [a]
arbitraryInterleave sep xs = fmap concat $ sequence $
[sep'] ++ intersperse sep' [return [x] | x <- xs] ++ [sep']
where
sep' = QC.sized $ \size -> do
num <- QC.choose (1, size)
replicateM num sep
================================================
FILE: tests/haskell/TestSuite.hs
================================================
--------------------------------------------------------------------------------
import qualified Network.WebSockets.Extensions.Tests
import qualified Network.WebSockets.Extensions.PermessageDeflate.Tests
import qualified Network.WebSockets.Handshake.Tests
import qualified Network.WebSockets.Http.Tests
import qualified Network.WebSockets.Hybi13.Demultiplex.Tests
import qualified Network.WebSockets.Mask.Tests
import qualified Network.WebSockets.Server.Tests
import qualified Network.WebSockets.Tests
import Test.Framework (defaultMain)
--------------------------------------------------------------------------------
main :: IO ()
main = defaultMain
[ Network.WebSockets.Extensions.Tests.tests
, Network.WebSockets.Extensions.PermessageDeflate.Tests.tests
, Network.WebSockets.Handshake.Tests.tests
, Network.WebSockets.Http.Tests.tests
, Network.WebSockets.Hybi13.Demultiplex.Tests.tests
, Network.WebSockets.Server.Tests.tests
, Network.WebSockets.Mask.Tests.tests
, Network.WebSockets.Tests.tests
]
================================================
FILE: tests/issue-158/Main.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Concurrent (threadDelay)
import qualified Control.Concurrent.Async as Async
import qualified Control.Exception as E
import Control.Monad (forever)
import qualified Data.Text as T
import qualified Network.WebSockets as WS
showException ::
gitextract_ne4bbnpg/ ├── .ghci ├── .github/ │ └── workflows/ │ └── ci.yml ├── .gitignore ├── CHANGELOG ├── LICENCE ├── README.md ├── Setup.hs ├── benchmarks/ │ ├── echo.hs │ ├── echo.js │ ├── mask.hs │ ├── ping.hs │ └── ping.html ├── cbits/ │ └── cbits.c ├── coverage.sh ├── example/ │ ├── client.hs │ ├── client.html │ ├── client.js │ ├── screen.css │ └── server.lhs ├── src/ │ └── Network/ │ ├── WebSockets/ │ │ ├── Client.hs │ │ ├── Connection/ │ │ │ ├── Options.hs │ │ │ └── PingPong.hs │ │ ├── Connection.hs │ │ ├── Extensions/ │ │ │ ├── Description.hs │ │ │ ├── PermessageDeflate.hs │ │ │ └── StrictUnicode.hs │ │ ├── Extensions.hs │ │ ├── Http.hs │ │ ├── Hybi13/ │ │ │ ├── Demultiplex.hs │ │ │ └── Mask.hs │ │ ├── Hybi13.hs │ │ ├── Protocol.hs │ │ ├── Server.hs │ │ ├── Stream.hs │ │ ├── Types.hs │ │ └── Util/ │ │ └── PubSub.hs │ └── WebSockets.hs ├── stack.yaml ├── tests/ │ ├── autobahn/ │ │ ├── autobahn.sh │ │ ├── exclude-cases.py │ │ ├── fuzzingclient.json │ │ ├── mini-report.py │ │ └── server.hs │ ├── haskell/ │ │ ├── Network/ │ │ │ └── WebSockets/ │ │ │ ├── Extensions/ │ │ │ │ ├── PermessageDeflate/ │ │ │ │ │ └── Tests.hs │ │ │ │ └── Tests.hs │ │ │ ├── Handshake/ │ │ │ │ └── Tests.hs │ │ │ ├── Http/ │ │ │ │ └── Tests.hs │ │ │ ├── Hybi13/ │ │ │ │ └── Demultiplex/ │ │ │ │ └── Tests.hs │ │ │ ├── Mask/ │ │ │ │ └── Tests.hs │ │ │ ├── Server/ │ │ │ │ └── Tests.hs │ │ │ ├── Tests/ │ │ │ │ └── Util.hs │ │ │ └── Tests.hs │ │ └── TestSuite.hs │ ├── issue-158/ │ │ └── Main.hs │ └── javascript/ │ ├── client.html │ ├── client.js │ └── server.hs └── websockets.cabal
SYMBOL INDEX (6 symbols across 3 files)
FILE: cbits/cbits.c
function rotr32 (line 10) | static inline uint32_t rotr32(uint32_t n, unsigned int c) {
function _hs_mask_chunk (line 25) | void _hs_mask_chunk(
FILE: example/client.js
function createChatSocket (line 1) | function createChatSocket() {
function refreshUsers (line 13) | function refreshUsers() {
function onMessage (line 20) | function onMessage(event) {
FILE: tests/javascript/client.js
function createWebSocket (line 5) | function createWebSocket(path, subproto) {
Condensed preview — 58 files, each showing path, character count, and a content snippet. Download the .json file or copy for the full structured content (220K chars).
[
{
"path": ".ghci",
"chars": 27,
"preview": ":set -isrc -itests/haskell\n"
},
{
"path": ".github/workflows/ci.yml",
"chars": 2600,
"preview": "name: \"build & test\"\non:\n push:\n pull_request:\n branches: [master]\n\njobs:\n build:\n name: GHC ${{ matrix.ghc-ver"
},
{
"path": ".gitignore",
"chars": 74,
"preview": "*.hi\n*.o\n\n.hpc\ndist\ntests/coverage\n\ntests/haskell/TestSuite\n\n.stack-work/\n"
},
{
"path": "CHANGELOG",
"chars": 6635,
"preview": "# CHANGELOG\n\n- 0.13.0.0 (2023-12-30)\n * **BREAKING**: Remove `serverRequirePong` option in favor of the new\n imp"
},
{
"path": "LICENCE",
"chars": 1526,
"preview": "Copyright Jasper Van der Jeugt, 2011\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or w"
},
{
"path": "README.md",
"chars": 1818,
"preview": "# websockets\n\n\n![GitHub Workflow Status (with event)](htt"
},
{
"path": "Setup.hs",
"chars": 46,
"preview": "import Distribution.Simple\nmain = defaultMain\n"
},
{
"path": "benchmarks/echo.hs",
"chars": 368,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nimport Control.Monad (forever)\nimport qualified Network.WebSockets as "
},
{
"path": "benchmarks/echo.js",
"chars": 1624,
"preview": "/* This WebSockets client opens an increasingly larger number of connections to\n * localhost and sends messages on all c"
},
{
"path": "benchmarks/mask.hs",
"chars": 3124,
"preview": "{-# language BangPatterns #-}\n{-# language OverloadedStrings #-}\n\nimport Criterion\nimport Criterion.Main\nimport qualifie"
},
{
"path": "benchmarks/ping.hs",
"chars": 893,
"preview": "--------------------------------------------------------------------------------\n{-# LANGUAGE OverloadedStrings #-}\nmodu"
},
{
"path": "benchmarks/ping.html",
"chars": 1399,
"preview": "<!DOCTYPE html>\n<html>\n <head>\n <title>Ping benchmark</title>\n <script type=\"text/JavaScript\"\n "
},
{
"path": "cbits/cbits.c",
"chars": 2417,
"preview": "#include <stdint.h>\n#include <string.h>\n#include <limits.h>\n#include <assert.h>\n\n/* Taken from:\n *\n * <http://stackoverf"
},
{
"path": "coverage.sh",
"chars": 477,
"preview": "#!/bin/bash\n\nEXCLUDES=$(find tests/haskell -name '*.hs' |\n xargs sed -n 's/^module //p' |\n sed 's/^/--exclude=/' |"
},
{
"path": "example/client.hs",
"chars": 1272,
"preview": "--------------------------------------------------------------------------------\n{-# LANGUAGE OverloadedStrings #-}\nmodu"
},
{
"path": "example/client.html",
"chars": 1598,
"preview": "<!DOCTYPE html>\n<html>\n <head>\n <title>Haskell WebSockets example</title>\n <script type=\"text/JavaScrip"
},
{
"path": "example/client.js",
"chars": 2290,
"preview": "function createChatSocket() {\n if(window.location.host == '') {\n /* Running on localhost */\n return new"
},
{
"path": "example/screen.css",
"chars": 1124,
"preview": "html {\n font-family: sans-serif;\n background-color: #335;\n font-size: 16px;\n}\n\nbody {\n}\n\nh1 {\n text-align: c"
},
{
"path": "example/server.lhs",
"chars": 5426,
"preview": "websockets example\n==================\n\nThis is the Haskell implementation of the example for the WebSockets library. We\n"
},
{
"path": "src/Network/WebSockets/Client.hs",
"chars": 7195,
"preview": "--------------------------------------------------------------------------------\n-- | This part of the library provides "
},
{
"path": "src/Network/WebSockets/Connection/Options.hs",
"chars": 5132,
"preview": "{-# LANGUAGE CPP #-}\n--------------------------------------------------------------------------------\nmodule Network.Web"
},
{
"path": "src/Network/WebSockets/Connection/PingPong.hs",
"chars": 2600,
"preview": "module Network.WebSockets.Connection.PingPong\n ( withPingPong\n , PingPongOptions(..)\n , PongTimeout(..)\n , d"
},
{
"path": "src/Network/WebSockets/Connection.hs",
"chars": 19515,
"preview": "--------------------------------------------------------------------------------\n-- | This module exposes connection int"
},
{
"path": "src/Network/WebSockets/Extensions/Description.hs",
"chars": 2295,
"preview": "-- | Code for parsing extensions headers.\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE RecordWildCards #-}\nmodule N"
},
{
"path": "src/Network/WebSockets/Extensions/PermessageDeflate.hs",
"chars": 11196,
"preview": "--------------------------------------------------------------------------------\n{-# LANGUAGE OverloadedStrings #-}\n{-# "
},
{
"path": "src/Network/WebSockets/Extensions/StrictUnicode.hs",
"chars": 1682,
"preview": "--------------------------------------------------------------------------------\nmodule Network.WebSockets.Extensions.St"
},
{
"path": "src/Network/WebSockets/Extensions.hs",
"chars": 801,
"preview": "module Network.WebSockets.Extensions\n ( ExtensionDescription (..)\n , ExtensionDescriptions\n , parseExtensionDes"
},
{
"path": "src/Network/WebSockets/Http.hs",
"chars": 10160,
"preview": "--------------------------------------------------------------------------------\n-- | Module dealing with HTTP: request "
},
{
"path": "src/Network/WebSockets/Hybi13/Demultiplex.hs",
"chars": 6118,
"preview": "--------------------------------------------------------------------------------\n-- | Demultiplexing of frames into mess"
},
{
"path": "src/Network/WebSockets/Hybi13/Mask.hs",
"chars": 3096,
"preview": "--------------------------------------------------------------------------------\n-- | Masking of fragmes using a simple "
},
{
"path": "src/Network/WebSockets/Hybi13.hs",
"chars": 10265,
"preview": "--------------------------------------------------------------------------------\n{-# LANGUAGE BangPatterns #-}\n{-# "
},
{
"path": "src/Network/WebSockets/Protocol.hs",
"chars": 3011,
"preview": "--------------------------------------------------------------------------------\n-- | Wrapper for supporting multiple pr"
},
{
"path": "src/Network/WebSockets/Server.hs",
"chars": 7622,
"preview": "--------------------------------------------------------------------------------\n-- | This provides a simple stand-alone"
},
{
"path": "src/Network/WebSockets/Stream.hs",
"chars": 8355,
"preview": "--------------------------------------------------------------------------------\n-- | Lightweight abstraction over an in"
},
{
"path": "src/Network/WebSockets/Types.hs",
"chars": 7046,
"preview": "--------------------------------------------------------------------------------\n-- | Primary types\n{-# LANGUAGE DeriveD"
},
{
"path": "src/Network/WebSockets/Util/PubSub.hs",
"chars": 2515,
"preview": "-- | This is a simple utility module to implement a publish-subscribe pattern.\n-- Note that this only allows communicati"
},
{
"path": "src/Network/WebSockets.hs",
"chars": 2377,
"preview": "--------------------------------------------------------------------------------\n{-# LANGUAGE ScopedTypeVariables #-}\nmo"
},
{
"path": "stack.yaml",
"chars": 154,
"preview": "resolver: nightly-2023-12-26\nsave-hackage-creds: false\nflags:\n websockets:\n example: true\nextra-deps:\n- 'hakyll-4.15"
},
{
"path": "tests/autobahn/autobahn.sh",
"chars": 914,
"preview": "#!/usr/bin/bash\nset -o errexit -o pipefail\n\n# Finding the right python\nAUTOBAHN_PYTHON=\"python2.7\"\n\n# Note that this scr"
},
{
"path": "tests/autobahn/exclude-cases.py",
"chars": 1643,
"preview": "# Travis only allows 50-minute jobs so we unfortunately cannot run all test\n# cases. This script selects all the long c"
},
{
"path": "tests/autobahn/fuzzingclient.json",
"chars": 389,
"preview": "{\n \"outdir\": \"./reports/servers\",\n \"servers\": [\n {\n \"url\": \"ws://127.0.0.1:9001\"\n }\n ],\n \"case"
},
{
"path": "tests/autobahn/mini-report.py",
"chars": 973,
"preview": "# `wstest` doesn't actually set an informational error code so we'll need to do\n# it ourselves.\n\nimport argparse\nimport "
},
{
"path": "tests/autobahn/server.hs",
"chars": 2841,
"preview": "--------------------------------------------------------------------------------\n-- | The server part of the tests\n{-# L"
},
{
"path": "tests/haskell/Network/WebSockets/Extensions/PermessageDeflate/Tests.hs",
"chars": 2027,
"preview": "--------------------------------------------------------------------------------\n{-# LANGUAGE OverloadedStrings #-}\nmodu"
},
{
"path": "tests/haskell/Network/WebSockets/Extensions/Tests.hs",
"chars": 2004,
"preview": "--------------------------------------------------------------------------------\n{-# LANGUAGE OverloadedStrings #-}\nmodu"
},
{
"path": "tests/haskell/Network/WebSockets/Handshake/Tests.hs",
"chars": 7702,
"preview": "--------------------------------------------------------------------------------\n{-# LANGUAGE OverloadedStrings #-}\nmodu"
},
{
"path": "tests/haskell/Network/WebSockets/Http/Tests.hs",
"chars": 3256,
"preview": "--------------------------------------------------------------------------------\n{-# LANGUAGE OverloadedStrings #-}\nmodu"
},
{
"path": "tests/haskell/Network/WebSockets/Hybi13/Demultiplex/Tests.hs",
"chars": 2805,
"preview": "--------------------------------------------------------------------------------\n{-# LANGUAGE OverloadedStrings #-}\nmodu"
},
{
"path": "tests/haskell/Network/WebSockets/Mask/Tests.hs",
"chars": 2182,
"preview": "--------------------------------------------------------------------------------\n{-# LANGUAGE BangPatterns #-}\n{-# "
},
{
"path": "tests/haskell/Network/WebSockets/Server/Tests.hs",
"chars": 7415,
"preview": "--------------------------------------------------------------------------------\n{-# LANGUAGE OverloadedStrings #-}\n{-"
},
{
"path": "tests/haskell/Network/WebSockets/Tests/Util.hs",
"chars": 1381,
"preview": "--------------------------------------------------------------------------------\nmodule Network.WebSockets.Tests.Util\n "
},
{
"path": "tests/haskell/Network/WebSockets/Tests.hs",
"chars": 9747,
"preview": "--------------------------------------------------------------------------------\n{-# LANGUAGE OverloadedStrings #-}\n{-# "
},
{
"path": "tests/haskell/TestSuite.hs",
"chars": 1082,
"preview": "--------------------------------------------------------------------------------\nimport qualified Network.WebSockets.Ext"
},
{
"path": "tests/issue-158/Main.hs",
"chars": 1336,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Main where\n\nimport Control.Concurrent (threadDelay)\nimport qua"
},
{
"path": "tests/javascript/client.html",
"chars": 870,
"preview": "<!DOCTYPE html>\n<html>\n <head>\n <title>websockets tests</title>\n <script type=\"text/JavaScript\" src=\"ht"
},
{
"path": "tests/javascript/client.js",
"chars": 2977,
"preview": "/*******************************************************************************\n* Utilities "
},
{
"path": "tests/javascript/server.hs",
"chars": 4208,
"preview": "--------------------------------------------------------------------------------\n-- | The server part of the tests\n{-# L"
},
{
"path": "websockets.cabal",
"chars": 7550,
"preview": "Name: websockets\nVersion: 0.13.0.0\n\nSynopsis:\n A sensible and clean way to write WebSocket-capable servers in Haskel"
}
]
About this extraction
This page contains the full source code of the jaspervdj/websockets GitHub repository, extracted and formatted as plain text for AI agents and large language models (LLMs). The extraction includes 58 files (204.3 KB), approximately 48.1k tokens, and a symbol index with 6 extracted functions, classes, methods, constants, and types. Use this with OpenClaw, Claude, ChatGPT, Cursor, Windsurf, or any other AI tool that accepts text input. You can copy the full output to your clipboard or download it as a .txt file.
Extracted by GitExtract — free GitHub repo to text converter for AI. Built by Nikandr Surkov.