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