diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,214 @@ +# CHANGELOG + +- 0.13.0.0 (2023-12-30) + * **BREAKING**: Remove `serverRequirePong` option in favor of the new + implementation. + * **BREAKING**: Client: Rejecting request raises + `RequestRejected RequestHead ResponseHead` + * Timeout initial socket connection after 30s. + * If the socket is closed unexpectedly, raise `ConnectionClosed`. + * Added a way to manually send a Pong message. + * `runServer` now cleans up threads correctly. + * Remove redundant bytestring-builder dependency. + * Introduce `Network.WebSockets.Connection.PingPong` to + handle ping pong for any Connection, be it Client or Server. + * Bump `text `dependency upper bound to 2.2 + * Bump `random `dependency lower bound to 1.0.1 + +- 0.12.7.3 (2021-10-26) + * Bump `attoparsec` dependency upper bound to 0.15 + +- 0.12.7.2 (2020-12-07) + * Bump `QuickCheck` dependency upper bound to 2.15 + * Bump `base64-bytestring` dependency upper bound to 1.3 + * Bump `bytestring` dependency upper bound to 0.12 + * Bump `random` dependency upper bound to 1.3 + +- 0.12.7.1 (2020-05-03) + * Bump `base64-bytestring` dependency upper bound to 1.2 + +- 0.12.7.0 (2019-12-31) + * Bump `base` lower bound to 4.8, this drops support for GHC 7.6 and 7.8 + * Add a new `runServerWithOptions` that can be extended in a more + future-compatible way + * Add a connection killer setting in `runServerWithOptions` + * Fix an unsafe read issue in `decodeResponseHead` + +- 0.12.6.1 (2019-10-29) + * Bump `network` dependency to 3.1 + +- 0.12.6.0 (2019-10-28) + * Expose a lower-level API to construct client connections (by Philipp + Balzarek) + * Close underlying stream only on synchronous exceptions, not asynchronous + exceptions (by kamoii) + * Add a `withPingThread` and lower-level `pingThread` to replace + `forkPingThread` + * Bump `QuickCheck` dependency to 2.13 + +- 0.12.5.3 (2019-01-31) + * Bump `network` dependency to 3.0 + +- 0.12.5.2 (2018-09-25) + * Bump `containers` dependency to 0.6 + * Bump `network` dependency to 2.8 + * Bump `QuickCheck` dependency to 2.12 + * Bump `binary` dependency to 0.10 + +- 0.12.5.1 (2018-06-12) + * Fix build with GHC 7.6 and 7.8 + +- 0.12.5.0 (2018-06-01) + * Add `newClientConnection` (by Renzo Carbonara) + +- 0.12.4.1 (2018-05-11) + * Bump `network` dependency to 2.7 + +- 0.12.4.0 (2018-03-13) + * Remove `blaze-builder` dependency + * Bump `streaming-commons` dependency to 0.2 + * Bump `QuickCheck` dependency to 2.11 + * Fix compatibility with old GHC versions + * Re-export more functions from `Network.WebSockets` + - `sendDataMessages` + - `sendBinaryDatas` + - `sendCloseCode` + * Don't crash when sending the empty list of messages + * Add `SemiGroup` instance for `SizeLimit` + +- 0.12.3.1 (2018-01-10) + * Bump CHANGELOG with IPv6 warning + * Run all autobahn tests during CI + +- 0.12.3.0 (2018-01-02) + * Fix error thrown from runClient functions + * Bump `QuickCheck` dependency to 2.10 + * Bump `entropy` dependency to 0.4 + * Bump `binary` dependency to 0.10 + +- 0.12.2.0 (2017-07-28) + * Don't use LambdaCase, we want to support older GHC versions + +- 0.12.1.0 (2017-07-22) + * Fix Monoid import on older base versions + * Increase lower bound on `binary` to 0.8.1 (by Jonathan Daugherty) + +- 0.12.0.0 + * Add limit options for frame and message size to prevent against (D)DoS + attacks + * Fix space leak in encodeMessages (by Roman Borschel) + * Stricter frame/encoding decoding for ping/close frames (by Lars Petersen) + +- 0.11.2.0 + * Fix 0-width reason phrase parsing + * Change receive buffer from 1024 to 8192 bytes (by Ondrej Palkovsky) + * Implement fast masking in C (by Ondrej Palkovsky and myself) + * Some haddock improvements + * Bump `HUnit` dependency to 1.6 + +- 0.11.1.0 + * Fix compilation issue with GHC-7.8 + +- 0.11.0.0 + * Support for IPv6 in the built-in server, client and tests (by agentm). + This can cause issues on backends that do not enable IPv6. For more + information and a workaround, see this issue: + . + * Faster masking (by Dmitry Ivanov) + * Support for `permessage-deflate` extension (by Marcin Tolysz) + * Strict unicode checking and proper extension mechanism + +- 0.10.0.0 + * Fix client specifying empty path + * Allow sending collections of messages (by David Turner) + * Allow sending extra headers when accepting request (by James Deery) + +- 0.9.8.2 + * Bump `HUnit` dependency to 1.5 + +- 0.9.8.1 + * Restore state of the package to version `0.9.7.0` + +- 0.9.8.0 + * This release contained a feature which broke backwards-compatibility. + Hence, it was marked as broken a new release containing the changes will + be uploaded as `0.10.0.0`. + +- 0.9.7.0 + * Fix issue trying to kill builtin server + * Bump `QuickCheck` dependency to 2.9 + +- 0.9.6.2 + * Bump `binary` dependency for GHC 8.0 compatibility + +- 0.9.6.1 + * Fix issue with fragmentation test + +- 0.9.6.0 + * Optionally include example server in the cabal file + * Send correct port from client + * Set `TCP_NO_DELAY` in builtin server + * Bump `HUnit` dependency + * Drop dependency on `mtl` + * Fix `QuickCheck` dependency lower bound + +- 0.9.5.0 + * Bugfixes wrt closing sockets and streams + +- 0.9.4.0 + * Add `makePendingConnectionFromStream` function + * Bump `attoparsec` dependency + +- 0.9.3.1 + * Bump `QuickCheck` dependency + +- 0.9.3.0 + * Use a shared closed state for connection input/output stream + * Make sure `runServer` doesn't leak any sockets + * Bump `blaze-builder` dependency + +- 0.9.2.2 + * Bump `random` dependency + +- 0.9.2.1 + * Fix exception handling issues + +- 0.9.2.0 + * Make sending and receiving messages thread-safe by default + * Export `forkPingThread` + * Fix Windows `withSocketsDo` issue + +- 0.9.1.0 + * Don't use Network.ByteString.Lazy.sendAll on Windows + +- 0.9.0.1 + * Allow compilation with older bytestring versions + * Bump text dependency + +- 0.9.0.0 + * Bump various dependencies + * Remove io-streams dependency + * New close mechanism + * More flexible API interface + +- 0.8.2.6 + * Bump QuickCheck dependency + +- 0.8.2.5 + * Bump attoparsec dependency + +- 0.8.2.4 + * Bump entropy dependency + +- 0.8.2.3 + * Bump mtl dependency + +- 0.8.2.2 + * Bump network dependency + +- 0.8.2.1 + * Add benchmark with many open connections + * Update example to use gender-neutral language + +- 0.8.2.0 + * Fix possible leaking of client sockets when connection times out 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 new file mode 100644 --- /dev/null +++ b/example/server.lhs @@ -0,0 +1,151 @@ +websockets example +================== + +This is the Haskell implementation of the example for the WebSockets library. We +implement a simple multi-user chat program. A live demo of the example is +available [here](/example/client.html). In order to understand this example, +keep the [reference](/reference/) nearby to check out the functions we use. + +> {-# LANGUAGE OverloadedStrings #-} +> module Main where +> import Data.Char (isPunctuation, isSpace) +> import Data.Monoid (mappend) +> import Data.Text (Text) +> import Control.Exception (finally) +> import Control.Monad (forM_, forever) +> import Control.Concurrent (MVar, newMVar, modifyMVar_, modifyMVar, readMVar) +> import qualified Data.Text as T +> import qualified Data.Text.IO as T + +> import qualified Network.WebSockets as WS + +We represent a client by their username and a `WS.Connection`. We will see how we +obtain this `WS.Connection` later on. + +> type Client = (Text, WS.Connection) + +The state kept on the server is simply a list of connected clients. We've added +an alias and some utility functions, so it will be easier to extend this state +later on. + +> type ServerState = [Client] + +Create a new, initial state: + +> newServerState :: ServerState +> newServerState = [] + +Get the number of active clients: + +> numClients :: ServerState -> Int +> numClients = length + +Check if a user already exists (based on username): + +> clientExists :: Client -> ServerState -> Bool +> clientExists client = any ((== fst client) . fst) + +Add a client (this does not check if the client already exists, you should do +this yourself using `clientExists`): + +> addClient :: Client -> ServerState -> ServerState +> addClient client clients = client : clients + +Remove a client: + +> removeClient :: Client -> ServerState -> ServerState +> removeClient client = filter ((/= fst client) . fst) + +Send a message to all clients, and log it on stdout: + +> broadcast :: Text -> ServerState -> IO () +> broadcast message clients = do +> T.putStrLn message +> forM_ clients $ \(_, conn) -> WS.sendTextData conn message + +The main function first creates a new state for the server, then spawns the +actual server. For this purpose, we use the simple server provided by +`WS.runServer`. + +> main :: IO () +> main = do +> state <- newMVar newServerState +> WS.runServer "127.0.0.1" 9160 $ application state + +Our main application has the type: + +> application :: MVar ServerState -> WS.ServerApp + +Note that `WS.ServerApp` is nothing but a type synonym for +`WS.PendingConnection -> IO ()`. + +Our application starts by accepting the connection. In a more realistic +application, you probably want to check the path and headers provided by the +pending request. + +We also fork a pinging thread in the background. This will ensure the connection +stays alive on some browsers. + +> application state pending = do +> conn <- WS.acceptRequest pending +> WS.withPingThread conn 30 (return ()) $ do + +When a client is succesfully connected, we read the first message. This should +be in the format of "Hi! I am Jasper", where Jasper is the requested username. + +> msg <- WS.receiveData conn +> clients <- readMVar state +> case msg of + +Check that the first message has the right format: + +> _ | not (prefix `T.isPrefixOf` msg) -> +> WS.sendTextData conn ("Wrong announcement" :: Text) + +Check the validity of the username: + +> | any ($ fst client) +> [T.null, T.any isPunctuation, T.any isSpace] -> +> WS.sendTextData conn ("Name cannot " <> +> "contain punctuation or whitespace, and " <> +> "cannot be empty" :: Text) + +Check that the given username is not already taken: + +> | clientExists client clients -> +> WS.sendTextData conn ("User already exists" :: Text) + +All is right! We're going to allow the client, but for safety reasons we *first* +setup a `disconnect` function that will be run when the connection is closed. + +> | otherwise -> flip finally disconnect $ do + +We send a "Welcome!", according to our own little protocol. We add the client to +the list and broadcast the fact that he has joined. Then, we give control to the +'talk' function. + +> modifyMVar_ state $ \s -> do +> let s' = addClient client s +> WS.sendTextData conn $ +> "Welcome! Users: " <> +> T.intercalate ", " (map fst s) +> broadcast (fst client <> " joined") s' +> return s' +> talk client state +> where +> prefix = "Hi! I am " +> client = (T.drop (T.length prefix) msg, conn) +> disconnect = do +> -- Remove client and return new state +> s <- modifyMVar state $ \s -> +> let s' = removeClient client s in return (s', s') +> broadcast (fst client <> " disconnected") s + +The talk function continues to read messages from a single client until he +disconnects. All messages are broadcasted to the other clients. + +> talk :: Client -> MVar ServerState -> IO () +> talk (user, conn) state = forever $ do +> msg <- WS.receiveData conn +> readMVar state >>= broadcast +> (user `mappend` ": " `mappend` msg) diff --git a/src/Network/WebSockets.hs b/src/Network/WebSockets.hs --- a/src/Network/WebSockets.hs +++ b/src/Network/WebSockets.hs @@ -1,220 +1,100 @@ --- | How do you use this library? Here's how: --- --- Get an enumerator/iteratee pair from your favorite web server (or use a --- library which provides integration). Alternatively, use 'I.runServer' to --- set up a simple standalone server. --- --- An application typically has the form of @I.Request -> I.WebSockets p ()@. --- The first thing to do is accept or reject the request, usually based upon --- the path in the 'I.Request'. An example: --- --- > {-# LANGUAGE OverloadedStrings #-} --- > import Network.WebSockets --- > --- > app :: Protocol p => Request -> WebSockets p () --- > app rq = case requestPath rq of --- > "/forbidden" -> rejectRequest rq "Forbidden!" --- > _ -> do --- > acceptRequest rq --- > ... actual application ... --- --- You can now start using the socket for sending and receiving data. But what's --- with the @p@ in @WebSockets p ()@? --- --- Well, the answer is that this library aims to support many versions of the --- WebSockets protocol. Unfortunately, not all versions of the protocol have the --- same capabilities: for example, older versions are not able to send binary --- data. --- --- The library user (you!) choose which capabilities you need. Then, the browser --- and library will negotiate at runtime which version will be actually used. --- --- As an example, here are two applications which need different capabilities: --- --- > import Network.WebSockets --- > import qualified Data.ByteString as B --- > import qualified Data.Text as T --- > --- > app1 :: TextProtocol p => WebSockets p () --- > app1 = sendTextData (T.pack "Hello world!") --- > --- > app2 :: BinaryProtocol p => WebSockets p () --- > app2 = sendBinaryData (B.pack [0 .. 100]) --- --- When you /tie the knot/, you will need to decide what protocol to use, to --- prevent ambiguousness. A good rule of thumb is to select the lowest protocol --- possible, since higher versions are generally backwards compatible in terms --- of features. . For example, the following application uses only --- /features from Hybi00/, and is therefore /compatible with Hybi10/ and later --- protocols. --- --- > app :: Request -> WebSockets Hybi00 () --- > app _ = app1 --- > --- > main :: IO () --- > main = runServer "0.0.0.0" 8000 app --- --- In some cases, you want to escape from the 'I.WebSockets' monad and send data --- to the websocket from different threads. To this end, the 'I.getSink' method --- is provided. The next example spawns a thread which continuously spams the --- client in another thread: --- --- > import Control.Concurrent (forkIO) --- > import Control.Monad (forever) --- > import Control.Monad.Trans (liftIO) --- > import Network.WebSockets --- > import qualified Data.Text as T --- > --- > spam :: TextProtocol p => WebSockets p () --- > spam = do --- > sink <- getSink --- > _ <- liftIO $ forkIO $ forever $ --- > sendSink sink $ textData (T.pack "SPAM SPAM SPAM!") --- > sendTextData (T.pack "Hello world!") --- --- For safety reasons, you can only read from the socket in the 'I.WebSockets' --- monad. --- --- For a full example, see: --- --- +-------------------------------------------------------------------------------- {-# LANGUAGE ScopedTypeVariables #-} module Network.WebSockets - ( - -- * WebSocket type - I.WebSocketsOptions (..) - , I.defaultWebSocketsOptions - , I.WebSockets - , I.runWebSockets - , I.runWebSocketsWith - , I.runWebSocketsHandshake - , I.runWebSocketsWithHandshake - - -- * Protocol versions - , I.Protocol - , I.TextProtocol - , I.BinaryProtocol - , I.Hybi00 - , I.Hybi10 + ( -- * Incoming connections and handshaking + PendingConnection + , pendingRequest + , acceptRequest + , AcceptRequest(..) + , defaultAcceptRequest + , acceptRequestWith + , rejectRequest + , RejectRequest(..) + , defaultRejectRequest + , rejectRequestWith - -- * A simple standalone server - , I.runServer - , I.runWithSocket + -- * Main connection type + , Connection - -- * Types - , I.Headers - , I.RequestHttpPart (..) - , I.Request (..) - , I.Response (..) - , I.Message (..) - , I.ControlMessage (..) - , I.DataMessage (..) - , I.WebSocketsData (..) + -- * Options for connections + , ConnectionOptions (..) + , defaultConnectionOptions - -- * Handshake - , acceptRequest - , rejectRequest + -- ** Compression options + , CompressionOptions (..) + , PermessageDeflate (..) + , defaultPermessageDeflate - -- * Various - , I.getVersion + -- ** Protection limits + , SizeLimit (..) - -- * Receiving - , I.receive + -- * Sending and receiving messages + , receive , receiveDataMessage , receiveData - - -- * Sending - , I.send + , send + , sendDataMessage + , sendDataMessages , sendTextData + , sendTextDatas , sendBinaryData + , sendBinaryDatas + , sendClose + , sendCloseCode + , sendPing - -- * Asynchronous sending - , I.Sink - , I.sendSink - , I.getSink - , I.close - , I.ping - , I.pong - , I.textData - , I.binaryData - , I.spawnPingThread + -- * HTTP Types + , Headers + , Request (..) + , RequestHead (..) + , getRequestSubprotocols + , Response (..) + , ResponseHead (..) - -- * Error Handling - , I.throwWsError - , I.catchWsError - , I.HandshakeError(..) - , I.ConnectionError(..) - ) where + -- * WebSocket message types + , Message (..) + , ControlMessage (..) + , DataMessage (..) + , WebSocketsData (..) -import Control.Monad.Trans (liftIO) + -- * Exceptions + , HandshakeException (..) + , ConnectionException (..) -import qualified Network.WebSockets.Handshake as I -import qualified Network.WebSockets.Handshake.Http as I -import qualified Network.WebSockets.Monad as I -import qualified Network.WebSockets.Protocol as I -import qualified Network.WebSockets.Protocol.Hybi00 as I -import qualified Network.WebSockets.Protocol.Hybi10 as I -import qualified Network.WebSockets.Protocol.Unsafe as Unsafe -import qualified Network.WebSockets.Socket as I -import qualified Network.WebSockets.Types as I + -- * Running a standalone server + , ServerApp + , runServer + , runServerWith + , ServerOptions (..) + , defaultServerOptions + , runServerWithOptions --- This doesn't work this way any more. As the Protocol first has to be --- determined by the request, we can't provide this as a WebSockets action. See --- the various flavours of runWebSockets. + -- * Utilities for writing your own server + , makeListenSocket + , makePendingConnection + , makePendingConnectionFromStream --- | Receive an application message. Automatically respond to control messages. -receiveDataMessage :: I.Protocol p => I.WebSockets p (I.DataMessage p) -receiveDataMessage = do - m <- I.receive - case m of - (I.DataMessage am) -> return am - (I.ControlMessage cm) -> case cm of - I.Close _ -> I.throwWsError I.ConnectionClosed - I.Pong _ -> do - options <- I.getOptions - liftIO $ I.onPong options - receiveDataMessage - I.Ping pl -> do - -- Note that we are using an /unsafe/ pong here. If the - -- underlying protocol cannot encode this pong, our thread will - -- crash. We assume, however that the protocol /is/ able to - -- encode the pong, since it was able to encode a ping. - I.send $ Unsafe.pong pl - receiveDataMessage + -- * Running a client + , ClientApp + , runClient + , runClientWith + , runClientWithSocket + , runClientWithStream + , newClientConnection --- | Receive a message, treating it as data transparently -receiveData :: (I.Protocol p, I.WebSocketsData a) => I.WebSockets p a -receiveData = do - dm <- receiveDataMessage - case dm of - I.Text x -> return (I.fromLazyByteString x) - I.Binary x -> return (I.fromLazyByteString x) + -- * Utilities + , PingPongOptions(..) + , defaultPingPongOptions + , withPingPong + , withPingThread + , forkPingThread + ) where --- | Send a 'I.Response' to the socket immediately. -sendResponse :: I.Protocol p => I.Response -> I.WebSockets p () -sendResponse = I.sendBuilder . I.encodeResponse --- | Send a text message -sendTextData :: (I.TextProtocol p, I.WebSocketsData a) => a -> I.WebSockets p () -sendTextData = I.send . I.textData - --- | Send some binary data -sendBinaryData :: (I.BinaryProtocol p, I.WebSocketsData a) - => a -> I.WebSockets p () -sendBinaryData = I.send . I.binaryData - --- | Reject a request, sending a 400 (Bad Request) to the client and throwing a --- RequestRejected (HandshakeError) -rejectRequest :: I.Protocol p - => I.Request -> String -> I.WebSockets p a -rejectRequest req reason = failHandshakeWith $ I.RequestRejected req reason - -failHandshakeWith :: forall p a. I.Protocol p - => I.HandshakeError -> I.WebSockets p a -failHandshakeWith err = do - sendResponse $ I.responseError (undefined :: p) err - I.throwWsError err - --- | Accept a request. After this, you can start sending and receiving data. -acceptRequest :: I.Protocol p => I.Request -> I.WebSockets p () -acceptRequest = sendResponse . I.requestResponse +-------------------------------------------------------------------------------- +import Network.WebSockets.Client +import Network.WebSockets.Connection +import Network.WebSockets.Connection.PingPong +import Network.WebSockets.Http +import Network.WebSockets.Server +import Network.WebSockets.Types diff --git a/src/Network/WebSockets/Client.hs b/src/Network/WebSockets/Client.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Client.hs @@ -0,0 +1,190 @@ +-------------------------------------------------------------------------------- +-- | This part of the library provides you with utilities to create WebSockets +-- clients (in addition to servers). +module Network.WebSockets.Client + ( ClientApp + , runClient + , runClientWith + , runClientWithSocket + , runClientWithStream + , newClientConnection + -- * Low level functionality + , createRequest + , Protocol(..) + , defaultProtocol + , checkServerResponse + , streamToClientConnection + ) where + + +-------------------------------------------------------------------------------- +import qualified Data.ByteString.Builder as Builder +import Control.Exception (bracket, finally, throwIO) +import Control.Concurrent.MVar (newEmptyMVar) +import Control.Monad (void) +import Data.IORef (newIORef) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Network.Socket as S +import System.Timeout (timeout) + + +-------------------------------------------------------------------------------- +import Network.WebSockets.Connection +import Network.WebSockets.Http +import Network.WebSockets.Protocol +import Network.WebSockets.Stream (Stream) +import qualified Network.WebSockets.Stream as Stream +import Network.WebSockets.Types + + +-------------------------------------------------------------------------------- +-- | A client application interacting with a single server. Once this 'IO' +-- action finished, the underlying socket is closed automatically. +type ClientApp a = Connection -> IO a + + +-------------------------------------------------------------------------------- +-- TODO: Maybe this should all be strings +runClient :: String -- ^ Host + -> Int -- ^ Port + -> String -- ^ Path + -> ClientApp a -- ^ Client application + -> IO a +runClient host port path ws = + runClientWith host port path defaultConnectionOptions [] ws + + +-------------------------------------------------------------------------------- +runClientWith :: String -- ^ Host + -> Int -- ^ Port + -> String -- ^ Path + -> ConnectionOptions -- ^ Options + -> Headers -- ^ Custom headers to send + -> ClientApp a -- ^ Client application + -> IO a +runClientWith host port path0 opts customHeaders app = do + -- Create and connect socket + let hints = S.defaultHints + {S.addrSocketType = S.Stream} + + -- Correct host and path. + fullHost = if port == 80 then host else (host ++ ":" ++ show port) + path = if null path0 then "/" else path0 + addr:_ <- S.getAddrInfo (Just hints) (Just host) (Just $ show port) + sock <- S.socket (S.addrFamily addr) S.Stream S.defaultProtocol + S.setSocketOption sock S.NoDelay 1 + + -- Connect WebSocket and run client + res <- bracket + (timeout (connectionTimeout opts * 1000 * 1000) $ S.connect sock (S.addrAddress addr)) + (const $ S.close sock) $ \maybeConnected -> case maybeConnected of + Nothing -> throwIO $ ConnectionTimeout + Just () -> runClientWithSocket sock fullHost path opts customHeaders app + + + -- Clean up + return res + + +-------------------------------------------------------------------------------- + +runClientWithStream + :: Stream + -- ^ Stream + -> String + -- ^ Host + -> String + -- ^ Path + -> ConnectionOptions + -- ^ Connection options + -> Headers + -- ^ Custom headers to send + -> ClientApp a + -- ^ Client application + -> IO a +runClientWithStream stream host path opts customHeaders app = do + newClientConnection stream host path opts customHeaders >>= app + +-- | Build a new 'Connection' from the client's point of view. +-- +-- /WARNING/: Be sure to call 'Stream.close' on the given 'Stream' after you are +-- done using the 'Connection' in order to properly close the communication +-- channel. 'runClientWithStream' handles this for you, prefer to use it when +-- possible. +newClientConnection + :: Stream + -- ^ Stream that will be used by the new 'Connection'. + -> String + -- ^ Host + -> String + -- ^ Path + -> ConnectionOptions + -- ^ Connection options + -> Headers + -- ^ Custom headers to send + -> IO Connection +newClientConnection stream host path opts customHeaders = do + -- Create the request and send it + request <- createRequest protocol bHost bPath False customHeaders + Stream.write stream (Builder.toLazyByteString $ encodeRequestHead request) + checkServerResponse stream request + streamToClientConnection stream opts + where + protocol = defaultProtocol -- TODO + bHost = T.encodeUtf8 $ T.pack host + bPath = T.encodeUtf8 $ T.pack path + +-- | Check the response from the server. +-- Throws 'OtherHandshakeException' on failure +checkServerResponse :: Stream -> RequestHead -> IO () +checkServerResponse stream request = do + mbResponse <- Stream.parse stream decodeResponseHead + response <- case mbResponse of + Just response -> return response + Nothing -> throwIO $ OtherHandshakeException $ + "Network.WebSockets.Client.newClientConnection: no handshake " ++ + "response from server" + void $ either throwIO return $ finishResponse protocol request response + where + protocol = defaultProtocol -- TODO + + +-- | Build a 'Connection' from a pre-established stream with already finished +-- handshake. +-- +-- /NB/: this will not perform any handshaking. +streamToClientConnection :: Stream -> ConnectionOptions -> IO Connection +streamToClientConnection stream opts = do + parse <- decodeMessages protocol + (connectionFramePayloadSizeLimit opts) + (connectionMessageDataSizeLimit opts) stream + write <- encodeMessages protocol ClientConnection stream + sentRef <- newIORef False + heartbeat <- newEmptyMVar + return $ Connection + { connectionOptions = opts + , connectionType = ClientConnection + , connectionProtocol = protocol + , connectionParse = parse + , connectionWrite = write + , connectionHeartbeat = heartbeat + , connectionSentClose = sentRef + } + where + protocol = defaultProtocol + + +-------------------------------------------------------------------------------- +runClientWithSocket :: S.Socket -- ^ Socket + -> String -- ^ Host + -> String -- ^ Path + -> ConnectionOptions -- ^ Options + -> Headers -- ^ Custom headers to send + -> ClientApp a -- ^ Client application + -> IO a +runClientWithSocket sock host path opts customHeaders app = bracket + (Stream.makeSocketStream sock) + Stream.close + (\stream -> + runClientWithStream stream host path opts customHeaders app) diff --git a/src/Network/WebSockets/Connection.hs b/src/Network/WebSockets/Connection.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Connection.hs @@ -0,0 +1,457 @@ +-------------------------------------------------------------------------------- +-- | This module exposes connection internals +{-# LANGUAGE OverloadedStrings #-} +module Network.WebSockets.Connection + ( PendingConnection (..) + , acceptRequest + , AcceptRequest(..) + , defaultAcceptRequest + , acceptRequestWith + , rejectRequest + , RejectRequest(..) + , defaultRejectRequest + , rejectRequestWith + + , Connection (..) + + , ConnectionOptions (..) + , defaultConnectionOptions + + , receive + , receiveDataMessage + , receiveData + , send + , sendDataMessage + , sendDataMessages + , sendTextData + , sendTextDatas + , sendBinaryData + , sendBinaryDatas + , sendClose + , sendCloseCode + , sendPing + , sendPong + + , withPingThread + , forkPingThread + , pingThread + + , CompressionOptions (..) + , PermessageDeflate (..) + , defaultPermessageDeflate + + , SizeLimit (..) + ) where + + +-------------------------------------------------------------------------------- +import Control.Applicative ((<$>)) +import Control.Concurrent (forkIO, + threadDelay) +import qualified Control.Concurrent.Async as Async +import Control.Concurrent.MVar (MVar, newEmptyMVar, tryPutMVar) +import Control.Exception (AsyncException, + fromException, + handle, + throwIO) +import Control.Monad (foldM, unless, + when) +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Char8 as B8 +import Data.IORef (IORef, + newIORef, + readIORef, + writeIORef) +import Data.List (find) +import Data.Maybe (catMaybes) +import qualified Data.Text as T +import Data.Word (Word16) +import Prelude + + +-------------------------------------------------------------------------------- +import Network.WebSockets.Connection.Options +import Network.WebSockets.Extensions as Extensions +import Network.WebSockets.Extensions.PermessageDeflate +import Network.WebSockets.Extensions.StrictUnicode +import Network.WebSockets.Http +import Network.WebSockets.Protocol +import Network.WebSockets.Stream (Stream) +import qualified Network.WebSockets.Stream as Stream +import Network.WebSockets.Types + + +-------------------------------------------------------------------------------- +-- | A new client connected to the server. We haven't accepted the connection +-- yet, though. +data PendingConnection = PendingConnection + { pendingOptions :: !ConnectionOptions + -- ^ Options, passed as-is to the 'Connection' + , pendingRequest :: !RequestHead + -- ^ Useful for e.g. inspecting the request path. + , pendingOnAccept :: !(Connection -> IO ()) + -- ^ One-shot callback fired when a connection is accepted, i.e., *after* + -- the accepting response is sent to the client. + , pendingStream :: !Stream + -- ^ Input/output stream + } + + +-------------------------------------------------------------------------------- +-- | This datatype allows you to set options for 'acceptRequestWith'. It is +-- strongly recommended to use 'defaultAcceptRequest' and then modify the +-- various fields, that way new fields introduced in the library do not break +-- your code. +data AcceptRequest = AcceptRequest + { acceptSubprotocol :: !(Maybe B.ByteString) + -- ^ The subprotocol to speak with the client. If 'pendingSubprotcols' is + -- non-empty, 'acceptSubprotocol' must be one of the subprotocols from the + -- list. + , acceptHeaders :: !Headers + -- ^ Extra headers to send with the response. + } + + +-------------------------------------------------------------------------------- +defaultAcceptRequest :: AcceptRequest +defaultAcceptRequest = AcceptRequest Nothing [] + + +-------------------------------------------------------------------------------- +-- | Utility +sendResponse :: PendingConnection -> Response -> IO () +sendResponse pc rsp = Stream.write (pendingStream pc) + (Builder.toLazyByteString (encodeResponse rsp)) + + +-------------------------------------------------------------------------------- +-- | Accept a pending connection, turning it into a 'Connection'. +acceptRequest :: PendingConnection -> IO Connection +acceptRequest pc = acceptRequestWith pc defaultAcceptRequest + + +-------------------------------------------------------------------------------- +-- | This function is like 'acceptRequest' but allows you to set custom options +-- using the 'AcceptRequest' datatype. +acceptRequestWith :: PendingConnection -> AcceptRequest -> IO Connection +acceptRequestWith pc ar = case find (flip compatible request) protocols of + Nothing -> do + sendResponse pc $ response400 versionHeader "" + throwIO NotSupported + Just protocol -> do + + -- Get requested list of exceptions from client. + rqExts <- either throwIO return $ + getRequestSecWebSocketExtensions request + + -- Set up permessage-deflate extension if configured. + pmdExt <- case connectionCompressionOptions (pendingOptions pc) of + NoCompression -> return Nothing + PermessageDeflateCompression pmd0 -> + case negotiateDeflate (connectionMessageDataSizeLimit options) (Just pmd0) rqExts of + Left err -> do + rejectRequestWith pc defaultRejectRequest {rejectMessage = B8.pack err} + throwIO NotSupported + Right pmd1 -> return (Just pmd1) + + -- Set up strict utf8 extension if configured. + let unicodeExt = + if connectionStrictUnicode (pendingOptions pc) + then Just strictUnicode else Nothing + + -- Final extension list. + let exts = catMaybes [pmdExt, unicodeExt] + + let subproto = maybe [] (\p -> [("Sec-WebSocket-Protocol", p)]) $ acceptSubprotocol ar + headers = subproto ++ acceptHeaders ar ++ concatMap extHeaders exts + response = finishRequest protocol request headers + + either throwIO (sendResponse pc) response + + parseRaw <- decodeMessages + protocol + (connectionFramePayloadSizeLimit options) + (connectionMessageDataSizeLimit options) + (pendingStream pc) + writeRaw <- encodeMessages protocol ServerConnection (pendingStream pc) + + write <- foldM (\x ext -> extWrite ext x) writeRaw exts + parse <- foldM (\x ext -> extParse ext x) parseRaw exts + + sentRef <- newIORef False + heartbeat <- newEmptyMVar + let connection = Connection + { connectionOptions = options + , connectionType = ServerConnection + , connectionProtocol = protocol + , connectionParse = parse + , connectionWrite = write + , connectionHeartbeat = heartbeat + , connectionSentClose = sentRef + } + + pendingOnAccept pc connection + return connection + where + options = pendingOptions pc + request = pendingRequest pc + versionHeader = [("Sec-WebSocket-Version", + B.intercalate ", " $ concatMap headerVersions protocols)] + + +-------------------------------------------------------------------------------- +-- | Parameters that allow you to tweak how a request is rejected. Please use +-- 'defaultRejectRequest' and modify fields using record syntax so your code +-- will not break when new fields are added. +data RejectRequest = RejectRequest + { -- | The status code, 400 by default. + rejectCode :: !Int + , -- | The message, "Bad Request" by default + rejectMessage :: !B.ByteString + , -- | Extra headers to be sent with the response. + rejectHeaders :: Headers + , -- | Reponse body of the rejection. + rejectBody :: !B.ByteString + } + + +-------------------------------------------------------------------------------- +defaultRejectRequest :: RejectRequest +defaultRejectRequest = RejectRequest + { rejectCode = 400 + , rejectMessage = "Bad Request" + , rejectHeaders = [] + , rejectBody = "" + } + + +-------------------------------------------------------------------------------- +rejectRequestWith + :: PendingConnection -- ^ Connection to reject + -> RejectRequest -- ^ Params on how to reject the request + -> IO () +rejectRequestWith pc reject = sendResponse pc $ Response + ResponseHead + { responseCode = rejectCode reject + , responseMessage = rejectMessage reject + , responseHeaders = rejectHeaders reject + } + (rejectBody reject) + + +-------------------------------------------------------------------------------- +-- | Requires calling 'pendingStream' and 'Stream.close'. +rejectRequest + :: PendingConnection -- ^ Connection to reject + -> B.ByteString -- ^ Rejection response body + -> IO () +rejectRequest pc body = rejectRequestWith pc + defaultRejectRequest {rejectBody = body} + + +-------------------------------------------------------------------------------- +data Connection = Connection + { connectionOptions :: !ConnectionOptions + , connectionType :: !ConnectionType + , connectionProtocol :: !Protocol + , connectionHeartbeat :: !(MVar ()) + -- ^ This MVar is filled whenever a pong is received. This is used by + -- 'withPingPong' to timeout the connection if a pong is not received. + , connectionParse :: !(IO (Maybe Message)) + , connectionWrite :: !([Message] -> IO ()) + , connectionSentClose :: !(IORef Bool) + -- ^ According to the RFC, both the client and the server MUST send + -- a close control message to each other. Either party can initiate + -- the first close message but then the other party must respond. Finally, + -- the server is in charge of closing the TCP connection. This IORef tracks + -- if we have sent a close message and are waiting for the peer to respond. + } + + +-------------------------------------------------------------------------------- +receive :: Connection -> IO Message +receive conn = do + mbMsg <- connectionParse conn + case mbMsg of + Nothing -> throwIO ConnectionClosed + Just msg -> return msg + + +-------------------------------------------------------------------------------- +-- | Receive an application message. Automatically respond to control messages. +-- +-- When the peer sends a close control message, an exception of type 'CloseRequest' +-- is thrown. The peer can send a close control message either to initiate a +-- close or in response to a close message we have sent to the peer. In either +-- case the 'CloseRequest' exception will be thrown. The RFC specifies that +-- the server is responsible for closing the TCP connection, which should happen +-- after receiving the 'CloseRequest' exception from this function. +-- +-- This will throw 'ConnectionClosed' if the TCP connection dies unexpectedly. +receiveDataMessage :: Connection -> IO DataMessage +receiveDataMessage conn = do + msg <- receive conn + case msg of + DataMessage _ _ _ am -> return am + ControlMessage cm -> case cm of + Close i closeMsg -> do + hasSentClose <- readIORef $ connectionSentClose conn + unless hasSentClose $ send conn msg + throwIO $ CloseRequest i closeMsg + Pong _ -> do + _ <- tryPutMVar (connectionHeartbeat conn) () + connectionOnPong (connectionOptions conn) + receiveDataMessage conn + Ping pl -> do + send conn (ControlMessage (Pong pl)) + receiveDataMessage conn + + +-------------------------------------------------------------------------------- +-- | Receive a message, converting it to whatever format is needed. +receiveData :: WebSocketsData a => Connection -> IO a +receiveData conn = fromDataMessage <$> receiveDataMessage conn + + +-------------------------------------------------------------------------------- +send :: Connection -> Message -> IO () +send conn = sendAll conn . return + +-------------------------------------------------------------------------------- +sendAll :: Connection -> [Message] -> IO () +sendAll _ [] = return () +sendAll conn msgs = do + when (any isCloseMessage msgs) $ + writeIORef (connectionSentClose conn) True + connectionWrite conn msgs + where + isCloseMessage (ControlMessage (Close _ _)) = True + isCloseMessage _ = False + +-------------------------------------------------------------------------------- +-- | Send a 'DataMessage'. This allows you send both human-readable text and +-- binary data. This is a slightly more low-level interface than 'sendTextData' +-- or 'sendBinaryData'. +sendDataMessage :: Connection -> DataMessage -> IO () +sendDataMessage conn = sendDataMessages conn . return + +-------------------------------------------------------------------------------- +-- | Send a collection of 'DataMessage's. This is more efficient than calling +-- 'sendDataMessage' many times. +sendDataMessages :: Connection -> [DataMessage] -> IO () +sendDataMessages conn = sendAll conn . map (DataMessage False False False) + +-------------------------------------------------------------------------------- +-- | Send a textual message. The message will be encoded as UTF-8. This should +-- be the default choice for human-readable text-based protocols such as JSON. +sendTextData :: WebSocketsData a => Connection -> a -> IO () +sendTextData conn = sendTextDatas conn . return + +-------------------------------------------------------------------------------- +-- | Send a number of textual messages. This is more efficient than calling +-- 'sendTextData' many times. +sendTextDatas :: WebSocketsData a => Connection -> [a] -> IO () +sendTextDatas conn = + sendDataMessages conn . + map (\x -> Text (toLazyByteString x) Nothing) + +-------------------------------------------------------------------------------- +-- | Send a binary message. This is useful for sending binary blobs, e.g. +-- images, data encoded with MessagePack, images... +sendBinaryData :: WebSocketsData a => Connection -> a -> IO () +sendBinaryData conn = sendBinaryDatas conn . return + +-------------------------------------------------------------------------------- +-- | Send a number of binary messages. This is more efficient than calling +-- 'sendBinaryData' many times. +sendBinaryDatas :: WebSocketsData a => Connection -> [a] -> IO () +sendBinaryDatas conn = sendDataMessages conn . map (Binary . toLazyByteString) + +-------------------------------------------------------------------------------- +-- | Send a friendly close message. Note that after sending this message, +-- you should still continue calling 'receiveDataMessage' to process any +-- in-flight messages. The peer will eventually respond with a close control +-- message of its own which will cause 'receiveDataMessage' to throw the +-- 'CloseRequest' exception. This exception is when you can finally consider +-- the connection closed. +sendClose :: WebSocketsData a => Connection -> a -> IO () +sendClose conn = sendCloseCode conn 1000 + + +-------------------------------------------------------------------------------- +-- | Send a friendly close message and close code. Similar to 'sendClose', +-- you should continue calling 'receiveDataMessage' until you receive a +-- 'CloseRequest' exception. +-- +-- See for a list of close +-- codes. +sendCloseCode :: WebSocketsData a => Connection -> Word16 -> a -> IO () +sendCloseCode conn code = + send conn . ControlMessage . Close code . toLazyByteString + + +-------------------------------------------------------------------------------- +-- | Send a ping +sendPing :: WebSocketsData a => Connection -> a -> IO () +sendPing conn = send conn . ControlMessage . Ping . toLazyByteString + +-------------------------------------------------------------------------------- +-- | Send a pong +sendPong :: WebSocketsData a => Connection -> a -> IO () +sendPong conn = send conn . ControlMessage . Pong . toLazyByteString + +-------------------------------------------------------------------------------- +-- | Forks a ping thread, sending a ping message every @n@ seconds over the +-- connection. The thread is killed when the inner IO action is finished. +-- +-- This is useful to keep idle connections open through proxies and whatnot. +-- Many (but not all) proxies have a 60 second default timeout, so based on that +-- sending a ping every 30 seconds is a good idea. +-- +-- Note that usually you want to use 'Network.WebSockets.Connection.PingPong.withPingPong' +-- to timeout the connection if a pong is not received. +withPingThread + :: Connection + -> Int -- ^ Second interval in which pings should be sent. + -> IO () -- ^ Repeat this after sending a ping. + -> IO a -- ^ Application to wrap with a ping thread. + -> IO a -- ^ Executes application and kills ping thread when done. +withPingThread conn n action app = + Async.withAsync (pingThread conn n action) (\_ -> app) + +-------------------------------------------------------------------------------- +-- | DEPRECATED: Use 'withPingThread' instead. +-- +-- Forks a ping thread, sending a ping message every @n@ seconds over the +-- connection. The thread dies silently if the connection crashes or is closed. +-- +-- This is useful to keep idle connections open through proxies and whatnot. +-- Many (but not all) proxies have a 60 second default timeout, so based on that +-- sending a ping every 30 seconds is a good idea. +forkPingThread :: Connection -> Int -> IO () +forkPingThread conn n = do + _ <- forkIO $ pingThread conn n (return ()) + return () +{-# DEPRECATED forkPingThread "Use 'withPingThread' instead" #-} + + +-------------------------------------------------------------------------------- +-- | Use this if you want to run the ping thread yourself. +-- +-- See also 'withPingThread'. +pingThread :: Connection -> Int -> IO () -> IO () +pingThread conn n action + | n <= 0 = return () + | otherwise = ignore `handle` go 1 + where + go :: Int -> IO () + go i = do + threadDelay (n * 1000 * 1000) + sendPing conn (T.pack $ show i) + action + go (i + 1) + + ignore e = case fromException e of + Just async -> throwIO (async :: AsyncException) + Nothing -> return () 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/Handshake.hs b/src/Network/WebSockets/Handshake.hs deleted file mode 100644 --- a/src/Network/WebSockets/Handshake.hs +++ /dev/null @@ -1,37 +0,0 @@ --- | Implementation of the WebSocket handshake -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} -module Network.WebSockets.Handshake - ( HandshakeError (..) - , handshake - , responseError - ) where - -import Data.List (find) - -import qualified Data.ByteString as B -import qualified Data.Enumerator as E - -import Network.WebSockets.Handshake.Http -import Network.WebSockets.Protocol - --- | Receives and checks the client handshake. If no suitable protocol is found --- (or the client sends garbage), a 'HandshakeError' will be thrown. -handshake :: (Monad m, Protocol p) - => RequestHttpPart - -> E.Iteratee B.ByteString m (Request, p) -handshake rhp = case find (flip supported rhp) implementations of - Nothing -> E.throwError NotSupported - Just p -> do - rq <- finishRequest p rhp - return (rq, p) - --- | Respond to errors encountered during handshake. First argument may be --- bottom. -responseError :: forall p. Protocol p => p -> HandshakeError -> Response -responseError _ err = response400 $ case err of - -- TODO: fix - NotSupported -> versionHeader -- Version negotiation - _ -> [] - where - versionHeader = [("Sec-WebSocket-Version", - B.intercalate ", " $ concatMap headerVersions (implementations :: [p]))] diff --git a/src/Network/WebSockets/Handshake/Http.hs b/src/Network/WebSockets/Handshake/Http.hs deleted file mode 100644 --- a/src/Network/WebSockets/Handshake/Http.hs +++ /dev/null @@ -1,129 +0,0 @@ --- | Module dealing with HTTP: request data types, encoding and decoding... -{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} -module Network.WebSockets.Handshake.Http - ( Headers - , RequestHttpPart (..) - , Request (..) - , Response (..) - , HandshakeError (..) - , getSecWebSocketVersion - , decodeRequest - , encodeResponse - , response101 - , response400 - ) where - -import Data.Dynamic (Typeable) -import Data.Monoid (mappend, mconcat) -import Control.Applicative (pure, (<$>), (<*>), (*>), (<*)) -import Control.Exception (Exception) -import Control.Monad.Error (Error (..)) - -import Data.ByteString.Char8 () -import Data.ByteString.Internal (c2w) -import qualified Data.Attoparsec as A -import qualified Blaze.ByteString.Builder as Builder -import qualified Blaze.ByteString.Builder.Char.Utf8 as Builder -import qualified Data.ByteString as B -import qualified Data.CaseInsensitive as CI - --- | Request headers -type Headers = [(CI.CI B.ByteString, B.ByteString)] - --- | (Internally used) HTTP headers and requested path. -data RequestHttpPart = RequestHttpPart - { requestHttpPath :: !B.ByteString - , requestHttpHeaders :: Headers - , requestHttpSecure :: Bool - } deriving (Eq, Show) - --- | Full request type -data Request = Request - { requestPath :: !B.ByteString - , requestHeaders :: Headers - , requestResponse :: Response - } - deriving (Show) - --- | Response to a 'Request' -data Response = Response - { responseCode :: !Int - , responseMessage :: !B.ByteString - , responseHeaders :: Headers - , responseBody :: B.ByteString - } deriving (Show) - --- | Error in case of failed handshake. Will be thrown as an iteratee --- exception. ('Error' condition). --- --- TODO: This should probably be in the Handshake module, and is solely here to --- prevent a cyclic dependency. -data HandshakeError - -- | We don't have a match for the protocol requested by the client. - -- todo: version parameter - = NotSupported - -- | The request was somehow invalid (missing headers or wrong security - -- token) - | MalformedRequest RequestHttpPart String - -- | The request was well-formed, but the library user rejected it. - -- (e.g. "unknown path") - | RequestRejected Request String - -- | for example "EOF came too early" (which is actually a parse error) - -- or for your own errors. (like "unknown path"?) - | OtherHandshakeError String - deriving (Show, Typeable) - -instance Error HandshakeError where - strMsg = OtherHandshakeError - -instance Exception HandshakeError - --- | Get the @Sec-WebSocket-Version@ header -getSecWebSocketVersion :: RequestHttpPart -> Maybe B.ByteString -getSecWebSocketVersion p = lookup "Sec-WebSocket-Version" (requestHttpHeaders p) - --- | Parse an initial request -decodeRequest :: Bool -> A.Parser RequestHttpPart -decodeRequest isSecure = RequestHttpPart - <$> requestLine - <*> A.manyTill header newline - <*> pure isSecure - where - space = A.word8 (c2w ' ') - newline = A.string "\r\n" - - requestLine = A.string "GET" *> space *> A.takeWhile1 (/= c2w ' ') - <* space - <* A.string "HTTP/1.1" <* newline - - header = (,) - <$> (CI.mk <$> A.takeWhile1 (/= c2w ':')) - <* A.string ": " - <*> A.takeWhile1 (/= c2w '\r') - <* newline - --- | Encode an HTTP upgrade response -encodeResponse :: Response -> Builder.Builder -encodeResponse (Response code msg headers body) = - Builder.copyByteString "HTTP/1.1 " `mappend` - Builder.fromString (show code) `mappend` - Builder.fromChar ' ' `mappend` - Builder.fromByteString msg `mappend` - Builder.fromByteString "\r\n" `mappend` - mconcat (map header headers) `mappend` - Builder.copyByteString "\r\n" `mappend` - Builder.copyByteString body -- (body is empty except for version -00) - where - header (k, v) = mconcat $ map Builder.copyByteString - [CI.original k, ": ", v, "\r\n"] - --- | An upgrade response -response101 :: Headers -> B.ByteString -> Response -response101 headers body = Response 101 "WebSocket Protocol Handshake" - (("Upgrade", "websocket") : ("Connection", "Upgrade") : headers) - body - --- | Bad request --- -response400 :: Headers -> Response -response400 headers = Response 400 "Bad Request" headers "" diff --git a/src/Network/WebSockets/Http.hs b/src/Network/WebSockets/Http.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Http.hs @@ -0,0 +1,267 @@ +-------------------------------------------------------------------------------- +-- | Module dealing with HTTP: request data types, encoding and decoding... +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +module Network.WebSockets.Http + ( Headers + , RequestHead (..) + , Request (..) + , ResponseHead (..) + , Response (..) + , HandshakeException (..) + + , encodeRequestHead + , encodeRequest + , decodeRequestHead + + , encodeResponseHead + , encodeResponse + , decodeResponseHead + , decodeResponse + + , response101 + , response400 + + , getRequestHeader + , getResponseHeader + , getRequestSecWebSocketVersion + , getRequestSubprotocols + , getRequestSecWebSocketExtensions + ) where + + +-------------------------------------------------------------------------------- +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Builder.Extra as Builder +import Control.Applicative (pure, (*>), (<$>), + (<*), (<*>)) +import Control.Exception (Exception) +import qualified Data.Attoparsec.ByteString as A +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.ByteString.Char8 () +import qualified Data.ByteString.Char8 as BC +import Data.ByteString.Internal (c2w) +import qualified Data.CaseInsensitive as CI +import Data.Dynamic (Typeable) +import Data.Monoid (mappend, mconcat) +import qualified Network.WebSockets.Extensions.Description as Extensions + + +-------------------------------------------------------------------------------- +-- | Request headers +type Headers = [(CI.CI ByteString, ByteString)] + + +-------------------------------------------------------------------------------- +-- | An HTTP request. The request body is not yet read. +data RequestHead = RequestHead + { requestPath :: !B.ByteString + , requestHeaders :: Headers + , requestSecure :: Bool + } deriving (Show) + + +-------------------------------------------------------------------------------- +-- | A request with a body +data Request = Request RequestHead B.ByteString + deriving (Show) + + +-------------------------------------------------------------------------------- +-- | HTTP response, without body. +data ResponseHead = ResponseHead + { responseCode :: !Int + , responseMessage :: !B.ByteString + , responseHeaders :: Headers + } deriving (Show) + + +-------------------------------------------------------------------------------- +-- | A response including a body +data Response = Response ResponseHead B.ByteString + deriving (Show) + + +-------------------------------------------------------------------------------- +-- | Error in case of failed handshake. Will be thrown as an 'Exception'. +-- +-- TODO: This should probably be in the Handshake module, and is solely here to +-- prevent a cyclic dependency. +data HandshakeException + -- | We don't have a match for the protocol requested by the client. + -- todo: version parameter + = NotSupported + -- | The request was somehow invalid (missing headers or wrong security + -- token) + | MalformedRequest RequestHead String + -- | The servers response was somehow invalid (missing headers or wrong + -- security token) + | MalformedResponse ResponseHead String + -- | The request was well-formed, but the library user rejected it. + -- (e.g. "unknown path") + | RequestRejected RequestHead ResponseHead + -- | The connection timed out + | ConnectionTimeout + -- | for example "EOF came too early" (which is actually a parse error) + -- or for your own errors. (like "unknown path"?) + | OtherHandshakeException String + deriving (Show, Typeable) + + +-------------------------------------------------------------------------------- +instance Exception HandshakeException + + +-------------------------------------------------------------------------------- +encodeRequestHead :: RequestHead -> Builder.Builder +encodeRequestHead (RequestHead path headers _) = + Builder.byteStringCopy "GET " `mappend` + Builder.byteStringCopy path `mappend` + Builder.byteStringCopy " HTTP/1.1" `mappend` + Builder.byteString "\r\n" `mappend` + mconcat (map header headers) `mappend` + Builder.byteStringCopy "\r\n" + where + header (k, v) = mconcat $ map Builder.byteStringCopy + [CI.original k, ": ", v, "\r\n"] + + +-------------------------------------------------------------------------------- +encodeRequest :: Request -> Builder.Builder +encodeRequest (Request head' body) = + encodeRequestHead head' `mappend` Builder.byteStringCopy body + + +-------------------------------------------------------------------------------- +-- | Parse an initial request +decodeRequestHead :: Bool -> A.Parser RequestHead +decodeRequestHead isSecure = RequestHead + <$> requestLine + <*> A.manyTill decodeHeaderLine newline + <*> pure isSecure + where + space = A.word8 (c2w ' ') + newline = A.string "\r\n" + + requestLine = A.string "GET" *> space *> A.takeWhile1 (/= c2w ' ') + <* space + <* A.string "HTTP/1.1" <* newline + + +-------------------------------------------------------------------------------- +-- | Encode an HTTP upgrade response +encodeResponseHead :: ResponseHead -> Builder.Builder +encodeResponseHead (ResponseHead code msg headers) = + Builder.byteStringCopy "HTTP/1.1 " `mappend` + Builder.stringUtf8 (show code) `mappend` + Builder.charUtf8 ' ' `mappend` + Builder.byteString msg `mappend` + Builder.byteString "\r\n" `mappend` + mconcat (map header headers) `mappend` + Builder.byteStringCopy "\r\n" + where + header (k, v) = mconcat $ map Builder.byteStringCopy + [CI.original k, ": ", v, "\r\n"] + + +-------------------------------------------------------------------------------- +encodeResponse :: Response -> Builder.Builder +encodeResponse (Response head' body) = + encodeResponseHead head' `mappend` Builder.byteStringCopy body + + +-------------------------------------------------------------------------------- +-- | An upgrade response +response101 :: Headers -> B.ByteString -> Response +response101 headers = Response + (ResponseHead 101 "WebSocket Protocol Handshake" + (("Upgrade", "websocket") : ("Connection", "Upgrade") : headers)) + + +-------------------------------------------------------------------------------- +-- | Bad request +response400 :: Headers -> B.ByteString -> Response +response400 headers = Response (ResponseHead 400 "Bad Request" headers) + + +-------------------------------------------------------------------------------- +-- | HTTP response parser +decodeResponseHead :: A.Parser ResponseHead +decodeResponseHead = ResponseHead + <$> fmap (read . BC.unpack) code + <*> message + <*> A.manyTill decodeHeaderLine newline + where + space = A.word8 (c2w ' ') + newline = A.string "\r\n" + + code = A.string "HTTP/1.1" *> space *> A.takeWhile1 digit <* space + digit = \x -> x >= c2w '0' && x <= c2w '9' + message = A.takeWhile (/= c2w '\r') <* newline + + +-------------------------------------------------------------------------------- +decodeResponse :: A.Parser Response +decodeResponse = Response <$> decodeResponseHead <*> A.takeByteString + + +-------------------------------------------------------------------------------- +getRequestHeader :: RequestHead + -> CI.CI ByteString + -> Either HandshakeException ByteString +getRequestHeader rq key = case lookup key (requestHeaders rq) of + Just t -> Right t + Nothing -> Left $ MalformedRequest rq $ + "Header missing: " ++ BC.unpack (CI.original key) + + +-------------------------------------------------------------------------------- +getResponseHeader :: ResponseHead + -> CI.CI ByteString + -> Either HandshakeException ByteString +getResponseHeader rsp key = case lookup key (responseHeaders rsp) of + Just t -> Right t + Nothing -> Left $ MalformedResponse rsp $ + "Header missing: " ++ BC.unpack (CI.original key) + + +-------------------------------------------------------------------------------- +-- | Get the @Sec-WebSocket-Version@ header +getRequestSecWebSocketVersion :: RequestHead -> Maybe B.ByteString +getRequestSecWebSocketVersion p = + lookup "Sec-WebSocket-Version" (requestHeaders p) + + +-------------------------------------------------------------------------------- +-- | List of subprotocols specified by the client, in order of preference. +-- If the client did not specify a list of subprotocols, this will be the +-- empty list. +getRequestSubprotocols :: RequestHead -> [B.ByteString] +getRequestSubprotocols rh = maybe [] parse mproto + where + mproto = lookup "Sec-WebSocket-Protocol" $ requestHeaders rh + parse = filter (not . B.null) . BC.splitWith (\o -> o == ',' || o == ' ') + + +-------------------------------------------------------------------------------- +-- | Get the @Sec-WebSocket-Extensions@ header +getRequestSecWebSocketExtensions + :: RequestHead -> Either HandshakeException Extensions.ExtensionDescriptions +getRequestSecWebSocketExtensions rq = + case lookup "Sec-WebSocket-Extensions" (requestHeaders rq) of + Nothing -> Right [] + Just ext -> case Extensions.parseExtensionDescriptions ext of + Right x -> Right x + Left err -> Left $ MalformedRequest rq $ + "Malformed Sec-WebSockets-Extensions: " ++ err + + +-------------------------------------------------------------------------------- +decodeHeaderLine :: A.Parser (CI.CI ByteString, ByteString) +decodeHeaderLine = (,) + <$> (CI.mk <$> A.takeWhile1 (/= c2w ':')) + <* A.word8 (c2w ':') + <* A.option (c2w ' ') (A.word8 (c2w ' ')) + <*> A.takeWhile (/= c2w '\r') + <* A.string "\r\n" diff --git a/src/Network/WebSockets/Hybi13.hs b/src/Network/WebSockets/Hybi13.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Hybi13.hs @@ -0,0 +1,258 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +module Network.WebSockets.Hybi13 + ( headerVersions + , finishRequest + , finishResponse + , encodeMessage + , encodeMessages + , decodeMessages + , createRequest + + -- Internal (used for testing) + , encodeFrame + , parseFrame + ) where + + +-------------------------------------------------------------------------------- +import qualified Data.ByteString.Builder as B +import Control.Applicative (pure, (<$>)) +import Control.Arrow (first) +import Control.Exception (throwIO) +import Control.Monad (forM, liftM, unless, + when) +import Data.Binary.Get (Get, getInt64be, + getLazyByteString, + getWord16be, getWord8) +import Data.Binary.Put (putWord16be, runPut) +import Data.Bits ((.&.), (.|.)) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base64 as B64 +import Data.ByteString.Char8 () +import qualified Data.ByteString.Lazy as BL +import Data.Digest.Pure.SHA (bytestringDigest, sha1) +import Data.IORef +import Data.Monoid (mappend, mconcat, + mempty) +import Data.Tuple (swap) +import System.Entropy as R +import System.Random (RandomGen, newStdGen) + + +-------------------------------------------------------------------------------- +import Network.WebSockets.Connection.Options +import Network.WebSockets.Http +import Network.WebSockets.Hybi13.Demultiplex +import Network.WebSockets.Hybi13.Mask +import Network.WebSockets.Stream (Stream) +import qualified Network.WebSockets.Stream as Stream +import Network.WebSockets.Types + + +-------------------------------------------------------------------------------- +headerVersions :: [ByteString] +headerVersions = ["13"] + + +-------------------------------------------------------------------------------- +finishRequest :: RequestHead + -> Headers + -> Either HandshakeException Response +finishRequest reqHttp headers = do + !key <- getRequestHeader reqHttp "Sec-WebSocket-Key" + let !hash = hashKey key + !encoded = B64.encode hash + return $ response101 (("Sec-WebSocket-Accept", encoded):headers) "" + + +-------------------------------------------------------------------------------- +finishResponse :: RequestHead + -> ResponseHead + -> Either HandshakeException Response +finishResponse request response = do + -- Response message should be one of + -- + -- - WebSocket Protocol Handshake + -- - Switching Protocols + -- + -- But we don't check it for now + when (responseCode response == 400) $ Left $ + RequestRejected request response + when (responseCode response /= 101) $ Left $ + MalformedResponse response "Wrong response status or message." + + key <- getRequestHeader request "Sec-WebSocket-Key" + responseHash <- getResponseHeader response "Sec-WebSocket-Accept" + let challengeHash = B64.encode $ hashKey key + when (responseHash /= challengeHash) $ Left $ + MalformedResponse response "Challenge and response hashes do not match." + + return $ Response response "" + + +-------------------------------------------------------------------------------- +encodeMessage :: RandomGen g => ConnectionType -> g -> Message -> (g, B.Builder) +encodeMessage conType gen msg = (gen', builder) + where + mkFrame = Frame True False False False + (mask, gen') = case conType of + ServerConnection -> (Nothing, gen) + ClientConnection -> first Just (randomMask gen) + builder = encodeFrame mask $ case msg of + (ControlMessage (Close code pl)) -> mkFrame CloseFrame $ + runPut (putWord16be code) `mappend` pl + (ControlMessage (Ping pl)) -> mkFrame PingFrame pl + (ControlMessage (Pong pl)) -> mkFrame PongFrame pl + (DataMessage rsv1 rsv2 rsv3 (Text pl _)) -> Frame True rsv1 rsv2 rsv3 TextFrame pl + (DataMessage rsv1 rsv2 rsv3 (Binary pl)) -> Frame True rsv1 rsv2 rsv3 BinaryFrame pl + + +-------------------------------------------------------------------------------- +encodeMessages + :: ConnectionType + -> Stream + -> IO ([Message] -> IO ()) +encodeMessages conType stream = do + genRef <- newIORef =<< newStdGen + return $ \msgs -> do + builders <- forM msgs $ \msg -> + atomicModifyIORef' genRef $ \s -> encodeMessage conType s msg + Stream.write stream (B.toLazyByteString $ mconcat builders) + + +-------------------------------------------------------------------------------- +encodeFrame :: Maybe Mask -> Frame -> B.Builder +encodeFrame mask f = B.word8 byte0 `mappend` + B.word8 byte1 `mappend` len `mappend` maskbytes `mappend` + B.lazyByteString (maskPayload mask payload) + where + + byte0 = fin .|. rsv1 .|. rsv2 .|. rsv3 .|. opcode + fin = if frameFin f then 0x80 else 0x00 + rsv1 = if frameRsv1 f then 0x40 else 0x00 + rsv2 = if frameRsv2 f then 0x20 else 0x00 + rsv3 = if frameRsv3 f then 0x10 else 0x00 + payload = case frameType f of + ContinuationFrame -> framePayload f + TextFrame -> framePayload f + BinaryFrame -> framePayload f + CloseFrame -> BL.take 125 $ framePayload f + PingFrame -> BL.take 125 $ framePayload f + PongFrame -> BL.take 125 $ framePayload f + opcode = case frameType f of + ContinuationFrame -> 0x00 + TextFrame -> 0x01 + BinaryFrame -> 0x02 + CloseFrame -> 0x08 + PingFrame -> 0x09 + PongFrame -> 0x0a + (maskflag, maskbytes) = case mask of + Nothing -> (0x00, mempty) + Just m -> (0x80, encodeMask m) + + byte1 = maskflag .|. lenflag + len' = BL.length payload + (lenflag, len) + | len' < 126 = (fromIntegral len', mempty) + | len' < 0x10000 = (126, B.word16BE (fromIntegral len')) + | otherwise = (127, B.word64BE (fromIntegral len')) + + +-------------------------------------------------------------------------------- +decodeMessages + :: SizeLimit + -> SizeLimit + -> Stream + -> IO (IO (Maybe Message)) +decodeMessages frameLimit messageLimit stream = do + dmRef <- newIORef emptyDemultiplexState + return $ go dmRef + where + go dmRef = do + mbFrame <- Stream.parseBin stream (parseFrame frameLimit) + case mbFrame of + Nothing -> return Nothing + Just frame -> do + demultiplexResult <- atomicModifyIORef' dmRef $ + \s -> swap $ demultiplex messageLimit s frame + case demultiplexResult of + DemultiplexError err -> throwIO err + DemultiplexContinue -> go dmRef + DemultiplexSuccess msg -> return (Just msg) + + +-------------------------------------------------------------------------------- +-- | Parse a frame +parseFrame :: SizeLimit -> Get Frame +parseFrame frameSizeLimit = do + byte0 <- getWord8 + let fin = byte0 .&. 0x80 == 0x80 + rsv1 = byte0 .&. 0x40 == 0x40 + rsv2 = byte0 .&. 0x20 == 0x20 + rsv3 = byte0 .&. 0x10 == 0x10 + opcode = byte0 .&. 0x0f + + byte1 <- getWord8 + let mask = byte1 .&. 0x80 == 0x80 + lenflag = byte1 .&. 0x7f + + len <- case lenflag of + 126 -> fromIntegral <$> getWord16be + 127 -> getInt64be + _ -> return (fromIntegral lenflag) + + -- Check size against limit. + unless (atMostSizeLimit len frameSizeLimit) $ + fail $ "Frame of size " ++ show len ++ " exceeded limit" + + ft <- case opcode of + 0x00 -> return ContinuationFrame + 0x01 -> return TextFrame + 0x02 -> return BinaryFrame + 0x08 -> enforceControlFrameRestrictions len fin >> return CloseFrame + 0x09 -> enforceControlFrameRestrictions len fin >> return PingFrame + 0x0a -> enforceControlFrameRestrictions len fin >> return PongFrame + _ -> fail $ "Unknown opcode: " ++ show opcode + + masker <- maskPayload <$> if mask then Just <$> parseMask else pure Nothing + + chunks <- getLazyByteString len + + return $ Frame fin rsv1 rsv2 rsv3 ft (masker chunks) + + where + enforceControlFrameRestrictions len fin + | not fin = fail "Control Frames must not be fragmented!" + | len > 125 = fail "Control Frames must not carry payload > 125 bytes!" + | otherwise = pure () + +-------------------------------------------------------------------------------- +hashKey :: ByteString -> ByteString +hashKey key = unlazy $ bytestringDigest $ sha1 $ lazy $ key `mappend` guid + where + guid = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11" + lazy = BL.fromChunks . return + unlazy = mconcat . BL.toChunks + + +-------------------------------------------------------------------------------- +createRequest :: ByteString + -> ByteString + -> Bool + -> Headers + -> IO RequestHead +createRequest hostname path secure customHeaders = do + key <- B64.encode `liftM` getEntropy 16 + return $ RequestHead path (headers key ++ customHeaders) secure + where + headers key = + [ ("Host" , hostname ) + , ("Connection" , "Upgrade" ) + , ("Upgrade" , "websocket" ) + , ("Sec-WebSocket-Key" , key ) + , ("Sec-WebSocket-Version" , versionNumber) + ] + + versionNumber = head headerVersions diff --git a/src/Network/WebSockets/Hybi13/Demultiplex.hs b/src/Network/WebSockets/Hybi13/Demultiplex.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Hybi13/Demultiplex.hs @@ -0,0 +1,157 @@ +-------------------------------------------------------------------------------- +-- | Demultiplexing of frames into messages +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +module Network.WebSockets.Hybi13.Demultiplex + ( FrameType (..) + , Frame (..) + , DemultiplexState + , emptyDemultiplexState + , DemultiplexResult (..) + , demultiplex + ) where + + +-------------------------------------------------------------------------------- +import Data.ByteString.Builder (Builder) +import qualified Data.ByteString.Builder as B +import Control.Exception (Exception) +import Data.Binary.Get (getWord16be, runGet) +import qualified Data.ByteString.Lazy as BL +import Data.Int (Int64) +import Data.Monoid (mappend) +import Data.Typeable (Typeable) +import Network.WebSockets.Connection.Options +import Network.WebSockets.Types + + +-------------------------------------------------------------------------------- +-- | A low-level representation of a WebSocket packet +data Frame = Frame + { frameFin :: !Bool + , frameRsv1 :: !Bool + , frameRsv2 :: !Bool + , frameRsv3 :: !Bool + , frameType :: !FrameType + , framePayload :: !BL.ByteString + } deriving (Eq, Show) + + +-------------------------------------------------------------------------------- +-- | The type of a frame. Not all types are allowed for all protocols. +data FrameType + = ContinuationFrame + | TextFrame + | BinaryFrame + | CloseFrame + | PingFrame + | PongFrame + deriving (Eq, Show) + + +-------------------------------------------------------------------------------- +-- | Thrown if the client sends invalid multiplexed data +data DemultiplexException = DemultiplexException + deriving (Show, Typeable) + + +-------------------------------------------------------------------------------- +instance Exception DemultiplexException + + +-------------------------------------------------------------------------------- +-- | Internal state used by the demultiplexer +data DemultiplexState + = EmptyDemultiplexState + | DemultiplexState !Int64 !Builder !(Builder -> Message) + + +-------------------------------------------------------------------------------- +emptyDemultiplexState :: DemultiplexState +emptyDemultiplexState = EmptyDemultiplexState + + +-------------------------------------------------------------------------------- +-- | Result of demultiplexing +data DemultiplexResult + = DemultiplexSuccess Message + | DemultiplexError ConnectionException + | DemultiplexContinue + + +-------------------------------------------------------------------------------- +demultiplex :: SizeLimit + -> DemultiplexState + -> Frame + -> (DemultiplexResult, DemultiplexState) + +demultiplex _ state (Frame True False False False PingFrame pl) + | BL.length pl > 125 = + (DemultiplexError $ CloseRequest 1002 "Protocol Error", emptyDemultiplexState) + | otherwise = + (DemultiplexSuccess $ ControlMessage (Ping pl), state) + +demultiplex _ state (Frame True False False False PongFrame pl) = + (DemultiplexSuccess (ControlMessage (Pong pl)), state) + +demultiplex _ _ (Frame True False False False CloseFrame pl) = + (DemultiplexSuccess (ControlMessage (uncurry Close parsedClose)), emptyDemultiplexState) + where + -- The Close frame MAY contain a body (the "Application data" portion of the + -- frame) that indicates a reason for closing, such as an endpoint shutting + -- down, an endpoint having received a frame too large, or an endpoint + -- having received a frame that does not conform to the format expected by + -- the endpoint. If there is a body, the first two bytes of the body MUST + -- be a 2-byte unsigned integer (in network byte order) representing a + -- status code with value /code/ defined in Section 7.4. + parsedClose + | BL.length pl >= 2 = case runGet getWord16be pl of + a | a < 1000 || a `elem` [1004,1005,1006 + ,1014,1015,1016 + ,1100,2000,2999 + ,5000,65535] -> (1002, BL.empty) + a -> (a, BL.drop 2 pl) + | BL.length pl == 1 = (1002, BL.empty) + | otherwise = (1000, BL.empty) + +demultiplex sizeLimit EmptyDemultiplexState (Frame fin rsv1 rsv2 rsv3 tp pl) = case tp of + _ | not (atMostSizeLimit size sizeLimit) -> + ( DemultiplexError $ ParseException $ + "Message of size " ++ show size ++ " exceeded limit" + , emptyDemultiplexState + ) + + TextFrame + | fin -> + (DemultiplexSuccess (text pl), emptyDemultiplexState) + | otherwise -> + (DemultiplexContinue, DemultiplexState size plb (text . B.toLazyByteString)) + + + BinaryFrame + | fin -> (DemultiplexSuccess (binary pl), emptyDemultiplexState) + | otherwise -> (DemultiplexContinue, DemultiplexState size plb (binary . B.toLazyByteString)) + + _ -> (DemultiplexError $ CloseRequest 1002 "Protocol Error", emptyDemultiplexState) + + where + size = BL.length pl + plb = B.lazyByteString pl + text x = DataMessage rsv1 rsv2 rsv3 (Text x Nothing) + binary x = DataMessage rsv1 rsv2 rsv3 (Binary x) + +demultiplex sizeLimit (DemultiplexState size0 b f) (Frame fin False False False ContinuationFrame pl) + | not (atMostSizeLimit size1 sizeLimit) = + ( DemultiplexError $ ParseException $ + "Message of size " ++ show size1 ++ " exceeded limit" + , emptyDemultiplexState + ) + | fin = (DemultiplexSuccess (f b'), emptyDemultiplexState) + | otherwise = (DemultiplexContinue, DemultiplexState size1 b' f) + where + size1 = size0 + BL.length pl + b' = b `mappend` plb + plb = B.lazyByteString pl + +demultiplex _ _ _ = + (DemultiplexError (CloseRequest 1002 "Protocol Error"), emptyDemultiplexState) diff --git a/src/Network/WebSockets/Hybi13/Mask.hs b/src/Network/WebSockets/Hybi13/Mask.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Hybi13/Mask.hs @@ -0,0 +1,81 @@ +-------------------------------------------------------------------------------- +-- | Masking of fragmes using a simple XOR algorithm +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Network.WebSockets.Hybi13.Mask + ( Mask + , parseMask + , encodeMask + , randomMask + + , maskPayload + ) where + + +-------------------------------------------------------------------------------- +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Builder.Extra as Builder +import Data.Binary.Get (Get, getWord32host) +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Internal as BL +import Data.Word (Word32, Word8) +import Foreign.C.Types (CChar (..), CInt (..), + CSize (..)) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Ptr (Ptr, plusPtr) +import System.Random (RandomGen, random) + + +-------------------------------------------------------------------------------- +foreign import ccall unsafe "_hs_mask_chunk" c_mask_chunk + :: Word32 -> CInt -> Ptr CChar -> CSize -> Ptr Word8 -> IO () + + +-------------------------------------------------------------------------------- +-- | A mask is sequence of 4 bytes. We store this in a 'Word32' in the host's +-- native byte ordering. +newtype Mask = Mask {unMask :: Word32} + + +-------------------------------------------------------------------------------- +-- | Parse a mask. +parseMask :: Get Mask +parseMask = fmap Mask getWord32host + + +-------------------------------------------------------------------------------- +-- | Encode a mask +encodeMask :: Mask -> Builder.Builder +encodeMask = Builder.word32Host . unMask + + +-------------------------------------------------------------------------------- +-- | Create a random mask +randomMask :: forall g. RandomGen g => g -> (Mask, g) +randomMask gen = (Mask int, gen') + where + (!int, !gen') = random gen :: (Word32, g) + + +-------------------------------------------------------------------------------- +-- | Mask a lazy bytestring. Uses 'c_mask_chunk' under the hood. +maskPayload :: Maybe Mask -> BL.ByteString -> BL.ByteString +maskPayload Nothing = id +maskPayload (Just (Mask 0)) = id +maskPayload (Just (Mask mask)) = go 0 + where + go _ BL.Empty = BL.Empty + go !maskOffset (BL.Chunk (B.PS payload off len) rest) = + BL.Chunk maskedChunk (go ((maskOffset + len) `rem` 4) rest) + where + maskedChunk = + B.unsafeCreate len $ \dst -> + withForeignPtr payload $ \src -> + c_mask_chunk mask + (fromIntegral maskOffset) + (src `plusPtr` off) + (fromIntegral len) + dst diff --git a/src/Network/WebSockets/Internal.hs b/src/Network/WebSockets/Internal.hs deleted file mode 100644 --- a/src/Network/WebSockets/Internal.hs +++ /dev/null @@ -1,8 +0,0 @@ --- | This module exports some extra functions. However, note that these --- utilities are primarily meant for internal use, and can change between minor --- releases. -module Network.WebSockets.Internal - ( S.iterSocket - ) where - -import qualified Network.WebSockets.Socket as S diff --git a/src/Network/WebSockets/Monad.hs b/src/Network/WebSockets/Monad.hs deleted file mode 100644 --- a/src/Network/WebSockets/Monad.hs +++ /dev/null @@ -1,257 +0,0 @@ --- | Provides a simple, clean monad to write websocket servers in -{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, OverloadedStrings, - NoMonomorphismRestriction, Rank2Types, ScopedTypeVariables #-} -module Network.WebSockets.Monad - ( WebSocketsOptions (..) - , defaultWebSocketsOptions - , WebSockets (..) - , runWebSockets - , runWebSocketsWith - , runWebSocketsHandshake - , runWebSocketsWithHandshake - , runWebSocketsWith' - , receive - , sendBuilder - , send - , Sink - , sendSink - , getSink - , getOptions - , getProtocol - , getVersion - , throwWsError - , catchWsError - , spawnPingThread - ) where - -import Control.Applicative (Applicative, (<$>)) -import Control.Concurrent (forkIO, threadDelay) -import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar) -import Control.Exception (Exception (..), SomeException, throw) -import Control.Monad (forever) -import Control.Monad.Reader (ReaderT, ask, runReaderT) -import Control.Monad.Trans (MonadIO, lift, liftIO) -import Data.Foldable (forM_) - -import Blaze.ByteString.Builder (Builder) -import Data.ByteString (ByteString) -import Data.Enumerator (Enumerator, Iteratee, ($$), (>>==), (=$)) -import qualified Blaze.ByteString.Builder as BB -import qualified Data.Attoparsec as A -import qualified Data.ByteString.Lazy as BL -import qualified Data.Attoparsec.Enumerator as AE -import qualified Data.Enumerator as E -import qualified Data.Enumerator.List as EL - -import Network.WebSockets.Handshake -import Network.WebSockets.Handshake.Http -import Network.WebSockets.Protocol -import Network.WebSockets.Types - --- | Options for the WebSocket program -data WebSocketsOptions = WebSocketsOptions - { onPong :: IO () - } - --- | Default options -defaultWebSocketsOptions :: WebSocketsOptions -defaultWebSocketsOptions = WebSocketsOptions - { onPong = return () - } - --- | Environment in which the 'WebSockets' monad actually runs -data WebSocketsEnv p = WebSocketsEnv - { envOptions :: WebSocketsOptions - , envSendBuilder :: Builder -> IO () - , envSink :: Sink p - , envProtocol :: p - } - --- | Used for asynchronous sending. -newtype Sink p = Sink - { unSink :: MVar (E.Iteratee (Message p) IO ()) - } - --- | The monad in which you can write WebSocket-capable applications -newtype WebSockets p a = WebSockets - { unWebSockets :: ReaderT (WebSocketsEnv p) (Iteratee (Message p) IO) a - } deriving (Applicative, Functor, Monad, MonadIO) - --- | Receives the initial client handshake, then behaves like 'runWebSockets'. -runWebSocketsHandshake :: Protocol p - => Bool - -> (Request -> WebSockets p a) - -> Iteratee ByteString IO () - -> Iteratee ByteString IO a -runWebSocketsHandshake = runWebSocketsWithHandshake defaultWebSocketsOptions - --- | Receives the initial client handshake, then behaves like --- 'runWebSocketsWith'. -runWebSocketsWithHandshake :: Protocol p - => WebSocketsOptions - -> Bool - -> (Request -> WebSockets p a) - -> Iteratee ByteString IO () - -> Iteratee ByteString IO a -runWebSocketsWithHandshake opts isSecure goWs outIter = do - httpReq <- receiveIteratee $ decodeRequest isSecure - runWebSocketsWith opts httpReq goWs outIter - --- | Run a 'WebSockets' application on an 'Enumerator'/'Iteratee' pair, given --- that you (read: your web server) has already received the HTTP part of the --- initial request. If not, you might want to use 'runWebSocketsWithHandshake' --- instead. --- --- If the handshake failed, throws a 'HandshakeError'. Otherwise, executes the --- supplied continuation. You should still send a response to the client --- yourself. -runWebSockets :: Protocol p - => RequestHttpPart - -> (Request -> WebSockets p a) - -> Iteratee ByteString IO () - -> Iteratee ByteString IO a -runWebSockets = runWebSocketsWith defaultWebSocketsOptions - --- | Version of 'runWebSockets' which allows you to specify custom options -runWebSocketsWith :: forall p a. Protocol p - => WebSocketsOptions - -> RequestHttpPart - -> (Request -> WebSockets p a) - -> Iteratee ByteString IO () - -> Iteratee ByteString IO a -runWebSocketsWith opts httpReq goWs outIter = E.catchError ok $ \e -> do - -- If handshake went bad, send response - forM_ (fromException e) $ \he -> - let builder = encodeResponse $ responseError (undefined :: p) he - in liftIO $ makeBuilderSender outIter builder - -- Re-throw error - E.throwError e - where - -- Perform handshake, call runWebSocketsWith' - ok = do - (rq, p) <- handshake httpReq - runWebSocketsWith' opts p (goWs rq) outIter - -runWebSocketsWith' :: Protocol p - => WebSocketsOptions - -> p - -> WebSockets p a - -> Iteratee ByteString IO () - -> Iteratee ByteString IO a -runWebSocketsWith' opts proto ws outIter = do - -- Create sink with a random source - let sinkIter = encodeMessages proto =$ builderToByteString =$ outIter - sink <- Sink <$> liftIO (newMVar sinkIter) - - let sender = makeBuilderSender outIter - env = WebSocketsEnv opts sender sink proto - iter = runReaderT (unWebSockets ws) env - - decodeMessages proto =$ iter - -makeBuilderSender :: MonadIO m => Iteratee ByteString m b -> Builder -> m () -makeBuilderSender outIter x = do - ok <- E.run $ singleton x $$ builderToByteString $$ outIter - case ok of - Left err -> throw err - Right _ -> return () - --- | @spawnPingThread n@ spawns a thread which sends a ping every @n@ seconds --- (if the protocol supports it). To be called after having sent the response. -spawnPingThread :: BinaryProtocol p => Int -> WebSockets p () -spawnPingThread i = do - sink <- getSink - _ <- liftIO $ forkIO $ forever $ do - -- An ugly hack here. We first sleep before sending the first - -- ping, so the ping (hopefully) doesn't interfere with the - -- intitial request/response. - threadDelay (i * 1000 * 1000) -- seconds - sendSink sink $ ping ("Hi" :: ByteString) - return () - --- | Receive arbitrary data. -receiveIteratee :: A.Parser a -> Iteratee ByteString IO a -receiveIteratee parser = do - eof <- E.isEOF - if eof - then E.throwError ConnectionClosed - else wrappingParseError . AE.iterParser $ parser - --- | Execute an iteratee, wrapping attoparsec-enumeratee's ParseError into the --- ParseError constructor (which is a ConnectionError). -wrappingParseError :: (Monad m) => Iteratee a m b -> Iteratee a m b -wrappingParseError = flip E.catchError $ \e -> E.throwError $ - maybe e (toException . ParseError) $ fromException e - --- | Receive a message -receive :: Protocol p => WebSockets p (Message p) -receive = liftIteratee $ do - mmsg <- EL.head - case mmsg of - Nothing -> E.throwError ConnectionClosed - Just msg -> return msg - --- | Send an arbitrary 'Builder' -sendBuilder :: Builder -> WebSockets p () -sendBuilder builder = WebSockets $ do - sb <- envSendBuilder <$> ask - liftIO $ sb builder - --- | Low-level sending with an arbitrary 'T.Message' -send :: Protocol p => Message p -> WebSockets p () -send msg = getSink >>= \sink -> liftIO $ sendSink sink msg - --- | Send a message to a sink. Might generate an exception if the underlying --- connection is closed. -sendSink :: Sink p -> Message p -> IO () -sendSink sink msg = modifyMVar_ (unSink sink) $ \iter -> do - step <- E.runIteratee $ singleton msg $$ iter - case step of - E.Error err -> throw err - _ -> return $! E.returnI step - --- | In case the user of the library wants to do asynchronous sending to the --- socket, he can extract a 'Sink' and pass this value around, for example, --- to other threads. -getSink :: Protocol p => WebSockets p (Sink p) -getSink = WebSockets $ envSink <$> ask - -singleton :: Monad m => a -> Enumerator a m b -singleton c = E.checkContinue0 $ \_ f -> f (E.Chunks [c]) >>== E.returnI - --- TODO: Figure out why Blaze.ByteString.Enumerator.builderToByteString doesn't --- work, then inform Simon or send a patch. -builderToByteString :: Monad m => E.Enumeratee Builder ByteString m a -builderToByteString = EL.concatMap $ BL.toChunks . BB.toLazyByteString - --- | Get the current configuration -getOptions :: WebSockets p WebSocketsOptions -getOptions = WebSockets $ ask >>= return . envOptions - --- | Get the underlying protocol -getProtocol :: WebSockets p p -getProtocol = WebSockets $ envProtocol <$> ask - --- | Find out the 'WebSockets' version used at runtime -getVersion :: Protocol p => WebSockets p String -getVersion = version <$> getProtocol - --- | Throw an iteratee error in the WebSockets monad -throwWsError :: (Exception e) => e -> WebSockets p a -throwWsError = liftIteratee . E.throwError - --- | Catch an iteratee error in the WebSockets monad -catchWsError :: WebSockets p a - -> (SomeException -> WebSockets p a) - -> WebSockets p a -catchWsError act c = WebSockets $ do - env <- ask - let it = peelWebSockets env $ act - cit = peelWebSockets env . c - lift $ it `E.catchError` cit - where - peelWebSockets env = flip runReaderT env . unWebSockets - --- | Lift an Iteratee computation to WebSockets -liftIteratee :: Iteratee (Message p) IO a -> WebSockets p a -liftIteratee = WebSockets . lift 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 @@ -1,81 +1,91 @@ +-------------------------------------------------------------------------------- -- | Wrapper for supporting multiple protocol versions {-# LANGUAGE ExistentialQuantification #-} module Network.WebSockets.Protocol ( Protocol (..) - , TextProtocol - , BinaryProtocol - , close - , ping - , pong - , textData - , binaryData + , defaultProtocol + , protocols + , compatible + , headerVersions + , finishRequest + , finishResponse + , encodeMessages + , decodeMessages + , createRequest ) where -import Blaze.ByteString.Builder (Builder) -import qualified Data.ByteString as B -import qualified Data.Enumerator as E -import Network.WebSockets.Types -import Network.WebSockets.Handshake.Http -import qualified Network.WebSockets.Protocol.Unsafe as Unsafe +-------------------------------------------------------------------------------- +import Data.ByteString (ByteString) +import qualified Data.ByteString as B -class Protocol p where - -- | Unique identifier for us. - version :: p -> String - -- | Version accepted in the "Sec-WebSocket-Version " header. This is - -- usually not the same, or derivable from "version", e.g. for hybi10, it's - -- "7", "8" or "17". - headerVersions :: p -> [B.ByteString] +-------------------------------------------------------------------------------- +import Network.WebSockets.Connection.Options +import Network.WebSockets.Http +import qualified Network.WebSockets.Hybi13 as Hybi13 +import Network.WebSockets.Stream (Stream) +import Network.WebSockets.Types - -- | Determine if the protocol is compatible with a requested version. A - -- default implementation exists which uses the @headerVersions@ of the - -- protocol. - supported :: p -> RequestHttpPart -> Bool - supported p h = case getSecWebSocketVersion h of - Just v -> v `elem` headerVersions p - _ -> False - -- | Encodes messages to binary 'Builder's. Takes a random source so it is - -- able to do masking of frames (needed in some cases). - encodeMessages :: Monad m - => p - -> E.Enumeratee (Message p) Builder m a +-------------------------------------------------------------------------------- +data Protocol + = Hybi13 + deriving (Show) - -- | Decodes messages from binary 'B.ByteString's. - decodeMessages :: Monad m => p -> E.Enumeratee B.ByteString (Message p) m a - -- | Parse and validate the rest of the request. For hybi10, this is just - -- validation, but hybi00 also needs to fetch a "security token" - -- - -- In case of failure, this function may throw a 'HandshakeError'. - -- be amended with the RequestHttpPart for the user) - finishRequest :: Monad m - => p -> RequestHttpPart - -> E.Iteratee B.ByteString m Request +-------------------------------------------------------------------------------- +defaultProtocol :: Protocol +defaultProtocol = Hybi13 - -- | Implementations of the specification - implementations :: [p] -class Protocol p => TextProtocol p -class TextProtocol p => BinaryProtocol p +-------------------------------------------------------------------------------- +protocols :: [Protocol] +protocols = [Hybi13] --- | Construct a close message -close :: (TextProtocol p, WebSocketsData a) => a -> Message p -close = Unsafe.close --- | Construct a ping message -ping :: (BinaryProtocol p, WebSocketsData a) => a -> Message p -ping = Unsafe.ping +-------------------------------------------------------------------------------- +headerVersions :: Protocol -> [ByteString] +headerVersions Hybi13 = Hybi13.headerVersions --- | Construct a pong message -pong :: (BinaryProtocol p, WebSocketsData a) => a -> Message p -pong = Unsafe.pong --- | Construct a text message -textData :: (TextProtocol p, WebSocketsData a) => a -> Message p -textData = Unsafe.textData +-------------------------------------------------------------------------------- +compatible :: Protocol -> RequestHead -> Bool +compatible protocol req = case getRequestSecWebSocketVersion req of + Just v -> v `elem` headerVersions protocol + _ -> True -- Whatever? --- | Construct a binary message -binaryData :: (BinaryProtocol p, WebSocketsData a) => a -> Message p -binaryData = Unsafe.binaryData + +-------------------------------------------------------------------------------- +finishRequest + :: Protocol -> RequestHead -> Headers -> Either HandshakeException Response +finishRequest Hybi13 = Hybi13.finishRequest + + +-------------------------------------------------------------------------------- +finishResponse + :: Protocol -> RequestHead -> ResponseHead + -> Either HandshakeException Response +finishResponse Hybi13 = Hybi13.finishResponse + + +-------------------------------------------------------------------------------- +encodeMessages + :: Protocol -> ConnectionType -> Stream + -> IO ([Message] -> IO ()) +encodeMessages Hybi13 = Hybi13.encodeMessages + + +-------------------------------------------------------------------------------- +decodeMessages + :: Protocol -> SizeLimit -> SizeLimit -> Stream + -> IO (IO (Maybe Message)) +decodeMessages Hybi13 frameLimit messageLimit = + Hybi13.decodeMessages frameLimit messageLimit + + +-------------------------------------------------------------------------------- +createRequest + :: Protocol -> B.ByteString -> B.ByteString -> Bool -> Headers + -> IO RequestHead +createRequest Hybi13 = Hybi13.createRequest diff --git a/src/Network/WebSockets/Protocol/Hybi00.hs b/src/Network/WebSockets/Protocol/Hybi00.hs deleted file mode 100644 --- a/src/Network/WebSockets/Protocol/Hybi00.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE ExistentialQuantification, OverloadedStrings #-} -module Network.WebSockets.Protocol.Hybi00 - ( Hybi00_ (..) - , Hybi00 - ) where - -import Data.Enumerator ((=$)) -import Data.Enumerator.List as EL -import Network.WebSockets.Protocol -import Network.WebSockets.Protocol.Hybi00.Internal -import Network.WebSockets.Protocol.Hybi10.Internal -import Network.WebSockets.Protocol.Unsafe - -data Hybi00 = forall p. Protocol p => Hybi00 p - -instance Protocol Hybi00 where - version (Hybi00 p) = version p - headerVersions (Hybi00 p) = headerVersions p - supported (Hybi00 p) h = supported p h - encodeMessages (Hybi00 p) = (EL.map castMessage =$) . encodeMessages p - decodeMessages (Hybi00 p) = (decodeMessages p =$) . EL.map castMessage - finishRequest (Hybi00 p) = finishRequest p - implementations = [Hybi00 Hybi10_, Hybi00 Hybi00_] - -instance TextProtocol Hybi00 diff --git a/src/Network/WebSockets/Protocol/Hybi00/Internal.hs b/src/Network/WebSockets/Protocol/Hybi00/Internal.hs deleted file mode 100644 --- a/src/Network/WebSockets/Protocol/Hybi00/Internal.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -module Network.WebSockets.Protocol.Hybi00.Internal - ( Hybi00_ (..) - ) where - -import Control.Applicative ((<|>)) -import Data.Char (isDigit) - -import Data.Binary (encode) -import Data.ByteString.Lazy.Char8 () -import Data.Digest.Pure.MD5 (md5) -import Data.Int (Int32) -import qualified Blaze.ByteString.Builder as BB -import qualified Data.Attoparsec as A -import qualified Data.Attoparsec.Enumerator as A -import qualified Data.ByteString as B -import qualified Data.Enumerator as E -import qualified Data.Enumerator.List as EL -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as BL -import qualified Data.CaseInsensitive as CI - -import Network.WebSockets.Handshake.Http -import Network.WebSockets.Protocol -import Network.WebSockets.Types - -data Hybi00_ = Hybi00_ - -instance Protocol Hybi00_ where - version Hybi00_ = "hybi00" - headerVersions Hybi00_ = [] -- The client will elide it - supported Hybi00_ h = getSecWebSocketVersion h == Nothing - encodeMessages Hybi00_ = EL.map encodeMessage - decodeMessages Hybi00_ = E.sequence (A.iterParser parseMessage) - finishRequest Hybi00_ = handshakeHybi00 - implementations = [Hybi00_] - -instance TextProtocol Hybi00_ - -encodeMessage :: Message p -> BB.Builder -encodeMessage (DataMessage (Text pl)) = - BB.fromLazyByteString $ "\0" `BL.append` pl `BL.append` "\255" -encodeMessage (ControlMessage (Close _)) = - BB.fromLazyByteString "\255\0" -encodeMessage msg = error $ - "Network.WebSockets.Protocol.Hybi00.encodeFrame: unsupported message: " ++ - show msg - -parseMessage :: A.Parser (Message p) -parseMessage = parseText <|> parseClose - where - parseText = do - _ <- A.word8 0x00 - utf8string <- A.manyTill A.anyWord8 (A.try $ A.word8 0xff) - return $ DataMessage $ Text $ BL.pack utf8string - - parseClose = do - _ <- A.word8 0xff - _ <- A.word8 0x00 - return $ ControlMessage $ Close "" - -divBySpaces :: String -> Maybe Int32 -divBySpaces str - | spaces == 0 = Nothing - | otherwise = Just . fromIntegral $ number `div` spaces - where - number = read $ filter isDigit str :: Integer - spaces = fromIntegral . length $ filter (== ' ') str - -handshakeHybi00 :: Monad m - => RequestHttpPart - -> E.Iteratee B.ByteString m Request -handshakeHybi00 reqHttp@(RequestHttpPart path h isSecure) = do - keyPart3 <- A.iterParser $ A.take 8 - keyPart1 <- numberFromToken =<< getHeader "Sec-WebSocket-Key1" - keyPart2 <- numberFromToken =<< getHeader "Sec-WebSocket-Key2" - - let key = B.concat . BL.toChunks . encode . md5 $ BL.concat - [keyPart1, keyPart2, BL.fromChunks [keyPart3]] - - host <- getHeader "Host" - -- todo: origin right? (also applies to hybi10) - origin <- getHeader "Origin" - let schema = if isSecure then "wss://" else "ws://" - let response = response101 - [ ("Sec-WebSocket-Location", B.concat [schema, host, path]) - , ("Sec-WebSocket-Origin", origin) - ] - key - - return $ Request path h response - where - getHeader k = case lookup k h of - Just t -> return t - Nothing -> E.throwError $ MalformedRequest reqHttp $ - "Header missing: " ++ BC.unpack (CI.original k) - - numberFromToken token = case divBySpaces (BC.unpack token) of - Just n -> return $ encode n - Nothing -> E.throwError $ MalformedRequest reqHttp - "Security token does not contain enough spaces" diff --git a/src/Network/WebSockets/Protocol/Hybi10.hs b/src/Network/WebSockets/Protocol/Hybi10.hs deleted file mode 100644 --- a/src/Network/WebSockets/Protocol/Hybi10.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -module Network.WebSockets.Protocol.Hybi10 - ( Hybi10 - ) where - -import Data.Enumerator ((=$)) -import Data.Enumerator.List as EL -import Network.WebSockets.Protocol -import Network.WebSockets.Protocol.Hybi10.Internal -import Network.WebSockets.Protocol.Unsafe - -data Hybi10 = forall p. Protocol p => Hybi10 p - -instance Protocol Hybi10 where - version (Hybi10 p) = version p - headerVersions (Hybi10 p) = headerVersions p - supported (Hybi10 p) h = supported p h - encodeMessages (Hybi10 p) = (EL.map castMessage =$) . encodeMessages p - decodeMessages (Hybi10 p) = (decodeMessages p =$) . EL.map castMessage - finishRequest (Hybi10 p) = finishRequest p - implementations = [Hybi10 Hybi10_] - -instance TextProtocol Hybi10 -instance BinaryProtocol Hybi10 diff --git a/src/Network/WebSockets/Protocol/Hybi10/Demultiplex.hs b/src/Network/WebSockets/Protocol/Hybi10/Demultiplex.hs deleted file mode 100644 --- a/src/Network/WebSockets/Protocol/Hybi10/Demultiplex.hs +++ /dev/null @@ -1,77 +0,0 @@ --- | Demultiplexing of frames into messages -module Network.WebSockets.Protocol.Hybi10.Demultiplex - ( FrameType (..) - , Frame (..) - , DemultiplexState - , emptyDemultiplexState - , demultiplex - ) where - -import Blaze.ByteString.Builder (Builder) -import Data.Monoid (mappend) -import qualified Blaze.ByteString.Builder as B -import qualified Data.ByteString.Lazy as BL - -import Network.WebSockets.Types - --- | A low-level representation of a WebSocket packet -data Frame = Frame - { frameFin :: !Bool - , frameRsv1 :: !Bool - , frameRsv2 :: !Bool - , frameRsv3 :: !Bool - , frameType :: !FrameType - , framePayload :: !BL.ByteString - } deriving (Eq, Show) - --- | The type of a frame. Not all types are allowed for all protocols. -data FrameType - = ContinuationFrame - | TextFrame - | BinaryFrame - | CloseFrame - | PingFrame - | PongFrame - deriving (Eq, Show) - --- | Internal state used by the demultiplexer -newtype DemultiplexState = DemultiplexState - { unDemultiplexState :: Maybe (FrameType, Builder) - } - -emptyDemultiplexState :: DemultiplexState -emptyDemultiplexState = DemultiplexState Nothing - -demultiplex :: DemultiplexState - -> Frame - -> (Maybe (Message p), DemultiplexState) -demultiplex state (Frame fin _ _ _ tp pl) = case tp of - -- Return control messages immediately, they have no influence on the state - CloseFrame -> (Just (ControlMessage (Close pl)), state) - PingFrame -> (Just (ControlMessage (Ping pl)), state) - PongFrame -> (Just (ControlMessage (Pong pl)), state) - -- If we're dealing with a continuation... - ContinuationFrame -> case unDemultiplexState state of - -- We received a continuation but we don't have any state. Let's ignore - -- this fragment... - Nothing -> (Nothing, DemultiplexState Nothing) - -- Append the payload to the state - -- TODO: protect against overflows - Just (amt, b) - | not fin -> (Nothing, DemultiplexState (Just (amt, b'))) - | otherwise -> case amt of - TextFrame -> (Just (DataMessage (Text m)), e) - BinaryFrame -> (Just (DataMessage (Binary m)), e) - _ -> error "Demultiplex.demultiplex: Internal error" - where - b' = b `mappend` plb - m = B.toLazyByteString b' - TextFrame - | fin -> (Just (DataMessage (Text pl)), e) - | otherwise -> (Nothing, DemultiplexState (Just (TextFrame, plb))) - BinaryFrame - | fin -> (Just (DataMessage (Binary pl)), e) - | otherwise -> (Nothing, DemultiplexState (Just (BinaryFrame, plb))) - where - e = emptyDemultiplexState - plb = B.fromLazyByteString pl diff --git a/src/Network/WebSockets/Protocol/Hybi10/Internal.hs b/src/Network/WebSockets/Protocol/Hybi10/Internal.hs deleted file mode 100644 --- a/src/Network/WebSockets/Protocol/Hybi10/Internal.hs +++ /dev/null @@ -1,156 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Network.WebSockets.Protocol.Hybi10.Internal - ( Hybi10_ (..) - , encodeFrameHybi10 - ) where - -import Control.Applicative (pure, (<$>)) -import Data.Bits ((.&.), (.|.)) -import Data.Maybe (maybeToList) -import Data.Monoid (mempty, mappend, mconcat) - -import Data.Attoparsec (anyWord8) -import Data.Binary.Get (runGet, getWord16be, getWord64be) -import Data.ByteString (ByteString) -import Data.ByteString.Char8 () -import Data.Digest.Pure.SHA (bytestringDigest, sha1) -import Data.Int (Int64) -import Data.Enumerator ((=$)) -import qualified Blaze.ByteString.Builder as B -import qualified Data.Attoparsec as A -import qualified Data.Attoparsec.Enumerator as A -import qualified Data.ByteString.Base64 as B64 -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as BL -import qualified Data.CaseInsensitive as CI -import qualified Data.Enumerator as E -import qualified Data.Enumerator.List as EL - -import Network.WebSockets.Handshake.Http -import Network.WebSockets.Protocol -import Network.WebSockets.Protocol.Hybi10.Demultiplex -import Network.WebSockets.Protocol.Hybi10.Mask -import Network.WebSockets.Types - -data Hybi10_ = Hybi10_ - -instance Protocol Hybi10_ where - version Hybi10_ = "hybi10" - headerVersions Hybi10_ = ["13", "8", "7"] - encodeMessages Hybi10_ = EL.map encodeMessageHybi10 - decodeMessages Hybi10_ = decodeMessagesHybi10 - finishRequest Hybi10_ = handshakeHybi10 - implementations = [Hybi10_] - -instance TextProtocol Hybi10_ -instance BinaryProtocol Hybi10_ - -encodeMessageHybi10 :: Message p -> B.Builder -encodeMessageHybi10 msg = builder - where - mkFrame = Frame True False False False - builder = encodeFrameHybi10 $ case msg of - (ControlMessage (Close pl)) -> mkFrame CloseFrame pl - (ControlMessage (Ping pl)) -> mkFrame PingFrame pl - (ControlMessage (Pong pl)) -> mkFrame PongFrame pl - (DataMessage (Text pl)) -> mkFrame TextFrame pl - (DataMessage (Binary pl)) -> mkFrame BinaryFrame pl - --- | Encode a frame -encodeFrameHybi10 :: Frame -> B.Builder -encodeFrameHybi10 f = B.fromWord8 byte0 `mappend` - B.fromWord8 byte1 `mappend` len `mappend` - B.fromLazyByteString (framePayload f) - where - byte0 = fin .|. rsv1 .|. rsv2 .|. rsv3 .|. opcode - fin = if frameFin f then 0x80 else 0x00 - rsv1 = if frameRsv1 f then 0x40 else 0x00 - rsv2 = if frameRsv2 f then 0x20 else 0x00 - rsv3 = if frameRsv3 f then 0x10 else 0x00 - opcode = case frameType f of - ContinuationFrame -> 0x00 - TextFrame -> 0x01 - BinaryFrame -> 0x02 - CloseFrame -> 0x08 - PingFrame -> 0x09 - PongFrame -> 0x0a - - byte1 = lenflag - len' = BL.length (framePayload f) - (lenflag, len) - | len' < 126 = (fromIntegral len', mempty) - | len' < 0x10000 = (126, B.fromWord16be (fromIntegral len')) - | otherwise = (127, B.fromWord64be (fromIntegral len')) - -decodeMessagesHybi10 :: Monad m => E.Enumeratee ByteString (Message p) m a -decodeMessagesHybi10 = - (E.sequence (A.iterParser parseFrame) =$) . demultiplexEnum - -demultiplexEnum :: Monad m => E.Enumeratee Frame (Message p) m a -demultiplexEnum = EL.concatMapAccum step emptyDemultiplexState - where - step s f = let (m, s') = demultiplex s f in (s', maybeToList m) - --- | Parse a frame -parseFrame :: A.Parser Frame -parseFrame = do - byte0 <- anyWord8 - let fin = byte0 .&. 0x80 == 0x80 - rsv1 = byte0 .&. 0x40 == 0x40 - rsv2 = byte0 .&. 0x20 == 0x20 - rsv3 = byte0 .&. 0x10 == 0x10 - opcode = byte0 .&. 0x0f - - let ft = case opcode of - 0x00 -> ContinuationFrame - 0x01 -> TextFrame - 0x02 -> BinaryFrame - 0x08 -> CloseFrame - 0x09 -> PingFrame - 0x0a -> PongFrame - _ -> error "Unknown opcode" - - byte1 <- anyWord8 - let mask = byte1 .&. 0x80 == 0x80 - lenflag = fromIntegral (byte1 .&. 0x7f) - - len <- case lenflag of - 126 -> fromIntegral . runGet' getWord16be <$> A.take 2 - 127 -> fromIntegral . runGet' getWord64be <$> A.take 8 - _ -> return lenflag - - masker <- maskPayload <$> if mask then Just <$> A.take 4 else pure Nothing - - chunks <- take64 len - - return $ Frame fin rsv1 rsv2 rsv3 ft (masker $ BL.fromChunks chunks) - where - runGet' g = runGet g . BL.fromChunks . return - - take64 :: Int64 -> A.Parser [ByteString] - take64 n - | n <= 0 = return [] - | otherwise = do - let n' = min intMax n - chunk <- A.take (fromIntegral n') - (chunk :) <$> take64 (n - n') - where - intMax :: Int64 - intMax = fromIntegral (maxBound :: Int) - -handshakeHybi10 :: Monad m - => RequestHttpPart - -> E.Iteratee ByteString m Request -handshakeHybi10 reqHttp@(RequestHttpPart path h _) = do - key <- getHeader "Sec-WebSocket-Key" - let hash = unlazy $ bytestringDigest $ sha1 $ lazy $ key `mappend` guid - let encoded = B64.encode hash - return $ Request path h $ response101 [("Sec-WebSocket-Accept", encoded)] "" - where - guid = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11" - lazy = BL.fromChunks . return - unlazy = mconcat . BL.toChunks - getHeader k = case lookup k h of - Just t -> return t - Nothing -> E.throwError $ MalformedRequest reqHttp $ - "Header missing: " ++ BC.unpack (CI.original k) diff --git a/src/Network/WebSockets/Protocol/Hybi10/Mask.hs b/src/Network/WebSockets/Protocol/Hybi10/Mask.hs deleted file mode 100644 --- a/src/Network/WebSockets/Protocol/Hybi10/Mask.hs +++ /dev/null @@ -1,24 +0,0 @@ --- | Masking of fragmes using a simple XOR algorithm -{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} -module Network.WebSockets.Protocol.Hybi10.Mask - ( Mask - , maskPayload - ) where - -import Data.Bits (xor) - -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL - --- | ByteString should be exactly 4 bytes long -type Mask = Maybe B.ByteString - --- | Apply mask -maskPayload :: Mask -> BL.ByteString -> BL.ByteString -maskPayload Nothing = id -maskPayload (Just mask) = snd . BL.mapAccumL f 0 - where - len = B.length mask - f !i !c = let i' = (i + 1) `mod` len - m = mask `B.index` i - in (i', m `xor` c) diff --git a/src/Network/WebSockets/Protocol/Unsafe.hs b/src/Network/WebSockets/Protocol/Unsafe.hs deleted file mode 100644 --- a/src/Network/WebSockets/Protocol/Unsafe.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Network.WebSockets.Protocol.Unsafe - ( castMessage - , close - , ping - , pong - , textData - , binaryData - ) where - -import Network.WebSockets.Types - -castMessage :: Message p1 -> Message p2 -castMessage (ControlMessage m) = ControlMessage $ case m of - Close b -> Close b - Ping b -> Ping b - Pong b -> Pong b -castMessage (DataMessage m) = DataMessage $ case m of - Text b -> Text b - Binary b -> Binary b -{-# INLINE castMessage #-} - -close :: WebSocketsData a => a -> Message p -close = ControlMessage . Close . toLazyByteString - -ping :: WebSocketsData a => a -> Message p -ping = ControlMessage . Ping . toLazyByteString - -pong :: WebSocketsData a => a -> Message p -pong = ControlMessage . Pong . toLazyByteString - -textData :: WebSocketsData a => a -> Message p -textData = DataMessage . Text . toLazyByteString - -binaryData :: WebSocketsData a => a -> Message p -binaryData = DataMessage . Binary . toLazyByteString diff --git a/src/Network/WebSockets/Server.hs b/src/Network/WebSockets/Server.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Server.hs @@ -0,0 +1,174 @@ +-------------------------------------------------------------------------------- +-- | This provides a simple stand-alone server for 'WebSockets' applications. +-- Note that in production you want to use a real webserver such as snap or +-- warp. +{-# LANGUAGE OverloadedStrings #-} +module Network.WebSockets.Server + ( ServerApp + , runServer + , ServerOptions (..) + , defaultServerOptions + , runServerWithOptions + , runServerWith + , makeListenSocket + , makePendingConnection + , makePendingConnectionFromStream + + , PongTimeout + ) where + + +-------------------------------------------------------------------------------- +import qualified Control.Concurrent.Async as Async +import Control.Exception (bracket, + bracketOnError, finally, mask_, + throwIO) +import Network.Socket (Socket) +import qualified Network.Socket as S + + +-------------------------------------------------------------------------------- +import Network.WebSockets.Connection +import Network.WebSockets.Connection.PingPong (PongTimeout(..)) +import Network.WebSockets.Http +import qualified Network.WebSockets.Stream as Stream +import Network.WebSockets.Types + + +-------------------------------------------------------------------------------- +-- | WebSockets application that can be ran by a server. Once this 'IO' action +-- finishes, the underlying socket is closed automatically. +type ServerApp = PendingConnection -> IO () + + +-------------------------------------------------------------------------------- +-- | Provides a simple server. This function blocks forever. Note that this +-- is merely provided for quick-and-dirty or internal applications, but for real +-- applications, you should use a real server. +-- +-- For example: +-- +-- * Performance is reasonable under load, but: +-- * No protection against DoS attacks is provided. +-- * No logging is performed. +-- * ... +-- +-- Glue for using this package with real servers is provided by: +-- +-- * +-- +-- * +runServer :: String -- ^ Address to bind + -> Int -- ^ Port to listen on + -> ServerApp -- ^ Application + -> IO () -- ^ Never returns +runServer host port app = runServerWith host port defaultConnectionOptions app + + +-------------------------------------------------------------------------------- +-- | A version of 'runServer' which allows you to customize some options. +runServerWith :: String -> Int -> ConnectionOptions -> ServerApp -> IO () +runServerWith host port opts = runServerWithOptions defaultServerOptions + { serverHost = host + , serverPort = port + , serverConnectionOptions = opts + } +{-# DEPRECATED runServerWith "Use 'runServerWithOptions' instead" #-} + + +-------------------------------------------------------------------------------- +data ServerOptions = ServerOptions + { serverHost :: String + , serverPort :: Int + , serverConnectionOptions :: ConnectionOptions + } + + +-------------------------------------------------------------------------------- +defaultServerOptions :: ServerOptions +defaultServerOptions = ServerOptions + { serverHost = "127.0.0.1" + , serverPort = 8080 + , serverConnectionOptions = defaultConnectionOptions + } + + +-------------------------------------------------------------------------------- +-- | Customizable version of 'runServer'. Never returns until killed. +-- +-- Please use the 'defaultServerOptions' combined with record updates to set the +-- fields you want. This way your code is unlikely to break on future changes. +runServerWithOptions :: ServerOptions -> ServerApp -> IO a +runServerWithOptions opts app = S.withSocketsDo $ + bracket + (makeListenSocket (serverHost opts) (serverPort opts)) + S.close + (\sock -> + let + mainThread = do + (conn, _) <- S.accept sock + Async.withAsyncWithUnmask + (\unmask -> unmask (runApp conn (serverConnectionOptions opts) app) `finally` S.close conn) + (\_ -> mainThread) + in mask_ mainThread + ) + + +-------------------------------------------------------------------------------- +-- | Create a standardized socket on which you can listen for incomming +-- connections. Should only be used for a quick and dirty solution! Should be +-- preceded by the call 'Network.Socket.withSocketsDo'. +makeListenSocket :: String -> Int -> IO Socket +makeListenSocket host port = do + addr:_ <- S.getAddrInfo (Just hints) (Just host) (Just (show port)) + bracketOnError + (S.socket (S.addrFamily addr) S.Stream S.defaultProtocol) + S.close + (\sock -> do + _ <- S.setSocketOption sock S.ReuseAddr 1 + _ <- S.setSocketOption sock S.NoDelay 1 + S.bind sock (S.addrAddress addr) + S.listen sock 5 + return sock + ) + where + hints = S.defaultHints { S.addrSocketType = S.Stream } + + +-------------------------------------------------------------------------------- +runApp :: Socket + -> ConnectionOptions + -> ServerApp + -> IO () +runApp socket opts app = + bracket + (makePendingConnection socket opts) + (Stream.close . pendingStream) + app + + +-------------------------------------------------------------------------------- +-- | Turns a socket, connected to some client, into a 'PendingConnection'. The +-- 'PendingConnection' should be closed using 'pendingStream' and 'Stream.close' later. +makePendingConnection + :: Socket -> ConnectionOptions -> IO PendingConnection +makePendingConnection socket opts = do + stream <- Stream.makeSocketStream socket + makePendingConnectionFromStream stream opts + + +-- | More general version of 'makePendingConnection' for 'Stream.Stream' +-- instead of a 'Socket'. +makePendingConnectionFromStream + :: Stream.Stream -> ConnectionOptions -> IO PendingConnection +makePendingConnectionFromStream stream opts = do + -- TODO: we probably want to send a 40x if the request is bad? + mbRequest <- Stream.parse stream (decodeRequestHead False) + case mbRequest of + Nothing -> throwIO ConnectionClosed + Just request -> return PendingConnection + { pendingOptions = opts + , pendingRequest = request + , pendingOnAccept = \_ -> return () + , pendingStream = stream + } diff --git a/src/Network/WebSockets/Socket.hs b/src/Network/WebSockets/Socket.hs deleted file mode 100644 --- a/src/Network/WebSockets/Socket.hs +++ /dev/null @@ -1,78 +0,0 @@ --- | Simple module which provides the low-level socket handling in case you want --- to write a stand-alone 'WebSockets' application. -{-# LANGUAGE OverloadedStrings #-} -module Network.WebSockets.Socket - ( runServer - , runWithSocket - , iterSocket - ) where - -import Prelude hiding (catch) - -import Control.Concurrent (forkIO) -import Control.Exception (SomeException, catch) -import Control.Monad (forever) -import Control.Monad.Trans (liftIO) - -import Data.ByteString (ByteString) -import Data.Enumerator (Iteratee, ($$)) -import Network.Socket (Socket) -import qualified Data.Enumerator as E -import qualified Network.Socket as S -import qualified Network.Socket.ByteString as SB -import qualified Network.Socket.Enumerator as SE - -import Network.WebSockets.Handshake.Http -import Network.WebSockets.Monad -import Network.WebSockets.Protocol -import Network.WebSockets.Types - --- | Provides a simple server. This function blocks forever. Note that this --- is merely provided for quick-and-dirty standalone applications, for real --- applications, you should use a real server. -runServer :: Protocol p - => String -- ^ Address to bind to - -> Int -- ^ Port to listen on - -> (Request -> WebSockets p ()) -- ^ Application to serve - -> IO () -- ^ Never returns -runServer host port ws = S.withSocketsDo $ do - sock <- S.socket S.AF_INET S.Stream S.defaultProtocol - _ <- S.setSocketOption sock S.ReuseAddr 1 - host' <- S.inet_addr host - S.bindSocket sock (S.SockAddrInet (fromIntegral port) host') - S.listen sock 5 - flip catch (closeSock sock) $ forever $ do - (conn, _) <- S.accept sock - -- Voodoo fix: set this to True as soon as we notice the connection was - -- closed. Will prevent iterSocket' from even trying to send anything. - -- Without it, we got many "Couldn't decode text frame as UTF8" errors - -- in the browser (although the payload is definitely UTF8). - -- killRef <- newIORef False - _ <- forkIO $ runWithSocket conn ws >> return () - return () - where - closeSock :: Socket -> SomeException -> IO () - closeSock sock _ = S.sClose sock - --- | This function wraps 'runWebSockets' in order to provide a simple API for --- stand-alone servers. -runWithSocket :: Protocol p - => Socket -> (Request -> WebSockets p a) -> IO a -runWithSocket s ws = do - r <- E.run $ SE.enumSocket 4096 s $$ runWebSocketsWithHandshake - defaultWebSocketsOptions False ws (iterSocket s) - S.sClose s - either (error . show) return r - --- | Create an iterator which writes to a socket. Throws a 'ConnectionClosed' --- exception if the user attempts to write to a closed socket. -iterSocket :: Socket -> Iteratee ByteString IO () -iterSocket s = E.continue go - where - go (E.Chunks []) = E.continue go - go (E.Chunks cs) = do - b <- liftIO $ S.sIsWritable s - if b - then E.tryIO (SB.sendMany s cs) >> E.continue go - else E.throwError ConnectionClosed - go E.EOF = E.continue go diff --git a/src/Network/WebSockets/Stream.hs b/src/Network/WebSockets/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Network/WebSockets/Stream.hs @@ -0,0 +1,218 @@ +-------------------------------------------------------------------------------- +-- | Lightweight abstraction over an input/output stream. +{-# LANGUAGE CPP #-} +module Network.WebSockets.Stream + ( Stream + , makeStream + , makeSocketStream + , makeEchoStream + , parse + , parseBin + , write + , close + ) where + +import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, + putMVar, takeMVar, withMVar) +import Control.Exception (SomeException, SomeAsyncException, throwIO, catch, try, fromException) +import Control.Monad (forM_) +import qualified Data.Attoparsec.ByteString as Atto +import qualified Data.Binary.Get as BIN +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.IORef (IORef, atomicModifyIORef', + newIORef, readIORef, + writeIORef) +import qualified Network.Socket as S +import qualified Network.Socket.ByteString as SB (recv) + +#if !defined(mingw32_HOST_OS) +import qualified Network.Socket.ByteString.Lazy as SBL (sendAll) +#else +import qualified Network.Socket.ByteString as SB (sendAll) +#endif +import System.IO.Error (isResourceVanishedError) + +import Network.WebSockets.Types + + +-------------------------------------------------------------------------------- +-- | State of the stream +data StreamState + = Closed !B.ByteString -- Remainder + | Open !B.ByteString -- Buffer + + +-------------------------------------------------------------------------------- +-- | Lightweight abstraction over an input/output stream. +data Stream = Stream + { streamIn :: IO (Maybe B.ByteString) + , streamOut :: (Maybe BL.ByteString -> IO ()) + , streamState :: !(IORef StreamState) + } + + +-------------------------------------------------------------------------------- +-- | Create a stream from a "receive" and "send" action. The following +-- properties apply: +-- +-- - Regardless of the provided "receive" and "send" functions, reading and +-- writing from the stream will be thread-safe, i.e. this function will create +-- a receive and write lock to be used internally. +-- +-- - Reading from or writing to a closed 'Stream' will always throw an +-- exception, even if the underlying "receive" and "send" functions do not +-- (we do the bookkeeping). +-- +-- - Streams should always be closed. +makeStream + :: IO (Maybe B.ByteString) -- ^ Reading + -> (Maybe BL.ByteString -> IO ()) -- ^ Writing + -> IO Stream -- ^ Resulting stream +makeStream receive send = do + ref <- newIORef (Open B.empty) + receiveLock <- newMVar () + sendLock <- newMVar () + return $ Stream (receive' ref receiveLock) (send' ref sendLock) ref + where + closeRef :: IORef StreamState -> IO () + closeRef ref = atomicModifyIORef' ref $ \state -> case state of + Open buf -> (Closed buf, ()) + Closed buf -> (Closed buf, ()) + + -- Throw a 'ConnectionClosed' is the connection is not 'Open'. + assertOpen :: IORef StreamState -> IO () + assertOpen ref = do + state <- readIORef ref + case state of + Closed _ -> throwIO ConnectionClosed + Open _ -> return () + + receive' :: IORef StreamState -> MVar () -> IO (Maybe B.ByteString) + receive' ref lock = withMVar lock $ \() -> do + assertOpen ref + mbBs <- onSyncException receive (closeRef ref) + case mbBs of + Nothing -> closeRef ref >> return Nothing + Just bs -> return (Just bs) + + send' :: IORef StreamState -> MVar () -> (Maybe BL.ByteString -> IO ()) + send' ref lock mbBs = withMVar lock $ \() -> do + case mbBs of + Nothing -> closeRef ref + Just _ -> assertOpen ref + onSyncException (send mbBs) (closeRef ref) + + onSyncException :: IO a -> IO b -> IO a + onSyncException io what = + catch io $ \e -> do + case fromException (e :: SomeException) :: Maybe SomeAsyncException of + Just _ -> pure () + Nothing -> what *> pure () + throwIO e + + +-------------------------------------------------------------------------------- +makeSocketStream :: S.Socket -> IO Stream +makeSocketStream socket = makeStream receive send + where + receive = do + bs <- try $ SB.recv socket 8192 + case bs of + -- If the resource vanished, the socket was closed + Left e | isResourceVanishedError e -> return Nothing + | otherwise -> throwIO e + Right bs' | B.null bs' -> return Nothing + | otherwise -> return $ Just bs' + + send Nothing = return () + send (Just bs) = do +#if !defined(mingw32_HOST_OS) + SBL.sendAll socket bs +#else + forM_ (BL.toChunks bs) (SB.sendAll socket) +#endif + + +-------------------------------------------------------------------------------- +makeEchoStream :: IO Stream +makeEchoStream = do + mvar <- newEmptyMVar + makeStream (takeMVar mvar) $ \mbBs -> case mbBs of + Nothing -> putMVar mvar Nothing + Just bs -> forM_ (BL.toChunks bs) $ \c -> putMVar mvar (Just c) + + +-------------------------------------------------------------------------------- +parseBin :: Stream -> BIN.Get a -> IO (Maybe a) +parseBin stream parser = do + state <- readIORef (streamState stream) + case state of + Closed remainder + | B.null remainder -> return Nothing + | otherwise -> go (BIN.runGetIncremental parser `BIN.pushChunk` remainder) True + Open buffer + | B.null buffer -> do + mbBs <- streamIn stream + case mbBs of + Nothing -> do + writeIORef (streamState stream) (Closed B.empty) + return Nothing + Just bs -> go (BIN.runGetIncremental parser `BIN.pushChunk` bs) False + | otherwise -> go (BIN.runGetIncremental parser `BIN.pushChunk` buffer) False + where + -- Buffer is empty when entering this function. + go (BIN.Done remainder _ x) closed = do + writeIORef (streamState stream) $ + if closed then Closed remainder else Open remainder + return (Just x) + go (BIN.Partial f) closed + | closed = go (f Nothing) True + | otherwise = do + mbBs <- streamIn stream + case mbBs of + Nothing -> go (f Nothing) True + Just bs -> go (f (Just bs)) False + go (BIN.Fail _ _ err) _ = throwIO (ParseException err) + + +parse :: Stream -> Atto.Parser a -> IO (Maybe a) +parse stream parser = do + state <- readIORef (streamState stream) + case state of + Closed remainder + | B.null remainder -> return Nothing + | otherwise -> go (Atto.parse parser remainder) True + Open buffer + | B.null buffer -> do + mbBs <- streamIn stream + case mbBs of + Nothing -> do + writeIORef (streamState stream) (Closed B.empty) + return Nothing + Just bs -> go (Atto.parse parser bs) False + | otherwise -> go (Atto.parse parser buffer) False + where + -- Buffer is empty when entering this function. + go (Atto.Done remainder x) closed = do + writeIORef (streamState stream) $ + if closed then Closed remainder else Open remainder + return (Just x) + go (Atto.Partial f) closed + | closed = go (f B.empty) True + | otherwise = do + mbBs <- streamIn stream + case mbBs of + Nothing -> go (f B.empty) True + Just bs -> go (f bs) False + go (Atto.Fail _ _ err) _ = throwIO (ParseException err) + + +-------------------------------------------------------------------------------- +write :: Stream -> BL.ByteString -> IO () +write stream = streamOut stream . Just + + +-------------------------------------------------------------------------------- +close :: Stream -> IO () +close stream = streamOut stream Nothing 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 @@ -1,61 +1,82 @@ - -{-# LANGUAGE DeriveDataTypeable #-} - +-------------------------------------------------------------------------------- -- | Primary types +{-# LANGUAGE DeriveDataTypeable #-} module Network.WebSockets.Types ( Message (..) , ControlMessage (..) , DataMessage (..) , WebSocketsData (..) - , ConnectionError (..) + , HandshakeException (..) + , ConnectionException (..) + + , ConnectionType (..) + + , decodeUtf8Lenient + , decodeUtf8Strict ) where -import Control.Exception (Exception(..)) -import Data.Typeable (Typeable) -import qualified Data.Attoparsec.Enumerator as AE -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL +-------------------------------------------------------------------------------- +import Control.Exception (Exception (..)) +import Control.Exception (throw, try) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Data.Text.Encoding.Error as TL +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import Data.Typeable (Typeable) +import Data.Word (Word16) +import System.IO.Unsafe (unsafePerformIO) --- | The connection couldn't be established or broke down unexpectedly. thrown --- as an iteratee exception. -data ConnectionError - -- | The client sent malformed data. - = ParseError AE.ParseError - -- | the client closed the connection while - -- we were trying to receive some data. - -- - -- todo: Also want this for sending. - | ConnectionClosed - deriving (Show, Typeable) -instance Exception ConnectionError +-------------------------------------------------------------------------------- +import Network.WebSockets.Http + +-------------------------------------------------------------------------------- -- | The kind of message a server application typically deals with -data Message p - = ControlMessage (ControlMessage p) - | DataMessage (DataMessage p) +data Message + = ControlMessage ControlMessage + -- | Reserved bits, actual message + | DataMessage Bool Bool Bool DataMessage deriving (Eq, Show) + +-------------------------------------------------------------------------------- -- | Different control messages -data ControlMessage p - = Close BL.ByteString +data ControlMessage + = Close Word16 BL.ByteString | Ping BL.ByteString | Pong BL.ByteString deriving (Eq, Show) + +-------------------------------------------------------------------------------- -- | For an end-user of this library, dealing with 'Frame's would be a bit -- low-level. This is why define another type on top of it, which represents -- data for the application layer. -data DataMessage p - = Text BL.ByteString +-- +-- There are currently two kinds of data messages supported by the WebSockets +-- protocol: +-- +-- * Textual UTF-8 encoded data. This corresponds roughly to sending a String +-- in JavaScript. +-- +-- * Binary data. This corresponds roughly to send an ArrayBuffer in +-- JavaScript. +data DataMessage + -- | A textual message. The second field /might/ contain the decoded UTF-8 + -- text for caching reasons. This field is computed lazily so if it's not + -- accessed, it should have no performance impact. + = Text BL.ByteString (Maybe TL.Text) + -- | A binary message. | Binary BL.ByteString deriving (Eq, Show) + +-------------------------------------------------------------------------------- -- | In order to have an even more high-level API, we define a typeclass for -- values the user can receive from and send to the socket. A few warnings -- apply: @@ -70,21 +91,97 @@ -- * Messages can be very large. If this is the case, it might be inefficient to -- use the strict 'B.ByteString' and 'T.Text' instances. class WebSocketsData a where + fromDataMessage :: DataMessage -> a + fromLazyByteString :: BL.ByteString -> a toLazyByteString :: a -> BL.ByteString + +-------------------------------------------------------------------------------- instance WebSocketsData BL.ByteString where + fromDataMessage (Text bl _) = bl + fromDataMessage (Binary bl) = bl + fromLazyByteString = id toLazyByteString = id + +-------------------------------------------------------------------------------- instance WebSocketsData B.ByteString where + fromDataMessage (Text bl _) = fromLazyByteString bl + fromDataMessage (Binary bl) = fromLazyByteString bl + fromLazyByteString = B.concat . BL.toChunks toLazyByteString = BL.fromChunks . return + +-------------------------------------------------------------------------------- instance WebSocketsData TL.Text where + fromDataMessage (Text _ (Just tl)) = tl + fromDataMessage (Text bl Nothing) = fromLazyByteString bl + fromDataMessage (Binary bl) = fromLazyByteString bl + + fromLazyByteString = TL.decodeUtf8 toLazyByteString = TL.encodeUtf8 + +-------------------------------------------------------------------------------- instance WebSocketsData T.Text where + fromDataMessage (Text _ (Just tl)) = T.concat (TL.toChunks tl) + fromDataMessage (Text bl Nothing) = fromLazyByteString bl + fromDataMessage (Binary bl) = fromLazyByteString bl + fromLazyByteString = T.concat . TL.toChunks . fromLazyByteString toLazyByteString = toLazyByteString . TL.fromChunks . return + + +-------------------------------------------------------------------------------- +-- | Various exceptions that can occur while receiving or transmitting messages +data ConnectionException + -- | The peer has requested that the connection be closed, and included + -- a close code and a reason for closing. When receiving this exception, + -- no more messages can be sent. Also, the server is responsible for + -- closing the TCP connection once this exception is received. + -- + -- See for a list of close + -- codes. + = CloseRequest Word16 BL.ByteString + + -- | The peer unexpectedly closed the connection while we were trying to + -- receive some data. This is a violation of the websocket RFC since the + -- TCP connection should only be closed after sending and receiving close + -- control messages. + | ConnectionClosed + + -- | The client sent garbage, i.e. we could not parse the WebSockets stream. + | ParseException String + + -- | The client sent invalid UTF-8. Note that this exception will only be + -- thrown if strict decoding is set in the connection options. + | UnicodeException String + deriving (Eq, Show, Typeable) + + +-------------------------------------------------------------------------------- +instance Exception ConnectionException + + +-------------------------------------------------------------------------------- +data ConnectionType = ServerConnection | ClientConnection + deriving (Eq, Ord, Show) + + +-------------------------------------------------------------------------------- +-- | Replace an invalid input byte with the Unicode replacement character +-- U+FFFD. +decodeUtf8Lenient :: BL.ByteString -> TL.Text +decodeUtf8Lenient = TL.decodeUtf8With TL.lenientDecode + + +-------------------------------------------------------------------------------- +-- | Throw an error if there is an invalid input byte. +decodeUtf8Strict :: BL.ByteString -> Either ConnectionException TL.Text +decodeUtf8Strict bl = unsafePerformIO $ try $ + let txt = TL.decodeUtf8With (\err _ -> throw (UnicodeException err)) bl in + TL.length txt `seq` return txt diff --git a/src/Network/WebSockets/Util/PubSub.hs b/src/Network/WebSockets/Util/PubSub.hs deleted file mode 100644 --- a/src/Network/WebSockets/Util/PubSub.hs +++ /dev/null @@ -1,79 +0,0 @@ --- | This is a simple utility module to implement a publish-subscribe pattern. --- Note that this only allows communication in a single direction: pusing data --- from the server to connected clients (browsers). --- --- Usage: --- --- * Create a new 'PubSub' handle using 'newPubSub' --- --- * Subscribe your clients using the 'subscribe' call --- --- * Push new updates from the server using the 'publish' call --- -{-# LANGUAGE Rank2Types, ScopedTypeVariables #-} -module Network.WebSockets.Util.PubSub - ( PubSub - , newPubSub - , publish - , subscribe - ) where - -import Control.Applicative ((<$>)) -import Control.Exception (IOException, handle) -import Control.Monad (foldM, forever) -import Control.Monad.Trans (liftIO) -import Data.IntMap (IntMap) -import Data.List (foldl') -import qualified Control.Concurrent.MVar as MV - -import qualified Data.IntMap as IM - -import Network.WebSockets - -data PubSub_ p = PubSub_ - { pubSubNextId :: Int - , pubSubSinks :: IntMap (Sink p) - } - -addClient :: Sink p -> PubSub_ p -> (PubSub_ p, Int) -addClient sink (PubSub_ nid sinks) = - (PubSub_ (nid + 1) (IM.insert nid sink sinks), nid) - -removeClient :: Int -> PubSub_ p -> PubSub_ p -removeClient ref ps = ps {pubSubSinks = IM.delete ref (pubSubSinks ps)} - --- | A handle which keeps track of subscribed clients -newtype PubSub p = PubSub (MV.MVar (PubSub_ p)) - --- | Create a new 'PubSub' handle, with no clients initally connected -newPubSub :: IO (PubSub p) -newPubSub = PubSub <$> MV.newMVar PubSub_ - { pubSubNextId = 0 - , pubSubSinks = IM.empty - } - --- | Broadcast a message to all connected clients -publish :: PubSub p -> Message p -> IO () -publish (PubSub mvar) msg = MV.modifyMVar_ mvar $ \pubSub -> do - -- Take care to detect and remove broken clients - broken <- foldM publish' [] (IM.toList $ pubSubSinks pubSub) - return $ foldl' (\p b -> removeClient b p) pubSub broken - where - -- Publish the message to a single client, add it to the broken list if an - -- IOException occurs - publish' broken (i, s) = - handle (\(_ :: IOException) -> return (i : broken)) $ do - sendSink s msg - return broken - --- | Blocks forever -subscribe :: Protocol p => PubSub p -> WebSockets p () -subscribe (PubSub mvar) = do - sink <- getSink - ref <- liftIO $ MV.modifyMVar mvar $ return . addClient sink - catchWsError loop $ const $ liftIO $ - MV.modifyMVar_ mvar $ return . removeClient ref - where - loop = forever $ do - _ <- receiveDataMessage - return () 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 new file mode 100644 --- /dev/null +++ b/tests/haskell/Network/WebSockets/Handshake/Tests.hs @@ -0,0 +1,185 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +module Network.WebSockets.Handshake.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Control.Concurrent (forkIO) +import Control.Exception (handle) +import Data.ByteString.Char8 () +import Data.IORef (newIORef, readIORef, + writeIORef) +import Data.Maybe (fromJust) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, assert, (@?=)) + + +-------------------------------------------------------------------------------- +import Network.WebSockets +import Network.WebSockets.Connection +import Network.WebSockets.Http +import qualified Network.WebSockets.Stream as Stream + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Network.WebSockets.Handshake.Test" + [ testCase "handshake Hybi13" testHandshakeHybi13 + , testCase "handshake Hybi13 with subprotocols" testHandshakeHybi13WithProto + , testCase "handshake Hybi13 with headers" testHandshakeHybi13WithHeaders + , testCase "handshake Hybi13 with subprotocols and headers" testHandshakeHybi13WithProtoAndHeaders + , testCase "handshake reject" testHandshakeReject + , testCase "handshake reject with custom code" testHandshakeRejectWithCode + , testCase "handshake Hybi9000" testHandshakeHybi9000 + ] + + +-------------------------------------------------------------------------------- +testHandshake :: RequestHead -> (PendingConnection -> IO a) -> IO ResponseHead +testHandshake rq app = do + echo <- Stream.makeEchoStream + _ <- forkIO $ do + _ <- app (PendingConnection defaultConnectionOptions rq nullify echo) + return () + mbRh <- Stream.parse echo decodeResponseHead + Stream.close echo + case mbRh of + Nothing -> fail "testHandshake: No response" + Just rh -> return rh + where + nullify _ = return () + + +-------------------------------------------------------------------------------- +(!) :: Eq a => [(a, b)] -> a -> b +assoc ! key = fromJust (lookup key assoc) + + +-------------------------------------------------------------------------------- +rq13 :: RequestHead +rq13 = RequestHead "/mychat" + [ ("Host", "server.example.com") + , ("Upgrade", "websocket") + , ("Connection", "Upgrade") + , ("Sec-WebSocket-Key", "x3JJHMbDL1EzLkh9GBhXDw==") + , ("Sec-WebSocket-Protocol", "chat, superchat") + , ("Sec-WebSocket-Version", "13") + , ("Origin", "http://example.com") + ] + False + + +-------------------------------------------------------------------------------- +testHandshakeHybi13 :: Assertion +testHandshakeHybi13 = do + onAcceptFired <- newIORef False + ResponseHead code message headers <- testHandshake rq13 $ \pc -> + acceptRequest pc {pendingOnAccept = \_ -> writeIORef onAcceptFired True} + + readIORef onAcceptFired >>= assert + code @?= 101 + message @?= "WebSocket Protocol Handshake" + headers ! "Sec-WebSocket-Accept" @?= "HSmrc0sMlYUkAGmm5OPpG2HaGWk=" + headers ! "Connection" @?= "Upgrade" + lookup "Sec-WebSocket-Protocol" headers @?= Nothing + +-------------------------------------------------------------------------------- +testHandshakeHybi13WithProto :: Assertion +testHandshakeHybi13WithProto = do + onAcceptFired <- newIORef False + ResponseHead code message headers <- testHandshake rq13 $ \pc -> do + getRequestSubprotocols (pendingRequest pc) @?= ["chat", "superchat"] + acceptRequestWith pc {pendingOnAccept = \_ -> writeIORef onAcceptFired True} + (AcceptRequest (Just "superchat") []) + + readIORef onAcceptFired >>= assert + code @?= 101 + message @?= "WebSocket Protocol Handshake" + headers ! "Sec-WebSocket-Accept" @?= "HSmrc0sMlYUkAGmm5OPpG2HaGWk=" + headers ! "Connection" @?= "Upgrade" + headers ! "Sec-WebSocket-Protocol" @?= "superchat" + +-------------------------------------------------------------------------------- +testHandshakeHybi13WithHeaders :: Assertion +testHandshakeHybi13WithHeaders = do + onAcceptFired <- newIORef False + ResponseHead code message headers <- testHandshake rq13 $ \pc -> do + getRequestSubprotocols (pendingRequest pc) @?= ["chat", "superchat"] + acceptRequestWith pc {pendingOnAccept = \_ -> writeIORef onAcceptFired True} + (AcceptRequest Nothing [("Set-Cookie","sid=foo")]) + + readIORef onAcceptFired >>= assert + code @?= 101 + message @?= "WebSocket Protocol Handshake" + headers ! "Sec-WebSocket-Accept" @?= "HSmrc0sMlYUkAGmm5OPpG2HaGWk=" + headers ! "Connection" @?= "Upgrade" + headers ! "Set-Cookie" @?= "sid=foo" + lookup "Sec-WebSocket-Protocol" headers @?= Nothing + +-------------------------------------------------------------------------------- +testHandshakeHybi13WithProtoAndHeaders :: Assertion +testHandshakeHybi13WithProtoAndHeaders = do + onAcceptFired <- newIORef False + ResponseHead code message headers <- testHandshake rq13 $ \pc -> do + getRequestSubprotocols (pendingRequest pc) @?= ["chat", "superchat"] + acceptRequestWith pc {pendingOnAccept = \_ -> writeIORef onAcceptFired True} + (AcceptRequest (Just "superchat") [("Set-Cookie","sid=foo")]) + + readIORef onAcceptFired >>= assert + code @?= 101 + message @?= "WebSocket Protocol Handshake" + headers ! "Sec-WebSocket-Accept" @?= "HSmrc0sMlYUkAGmm5OPpG2HaGWk=" + headers ! "Connection" @?= "Upgrade" + headers ! "Sec-WebSocket-Protocol" @?= "superchat" + headers ! "Set-Cookie" @?= "sid=foo" + + +-------------------------------------------------------------------------------- +testHandshakeReject :: Assertion +testHandshakeReject = do + ResponseHead code _ _ <- testHandshake rq13 $ \pc -> + rejectRequest pc "YOU SHALL NOT PASS" + + code @?= 400 + + +-------------------------------------------------------------------------------- +testHandshakeRejectWithCode :: Assertion +testHandshakeRejectWithCode = do + ResponseHead code _ _ <- testHandshake rq13 $ \pc -> + rejectRequestWith pc defaultRejectRequest + { rejectBody = "YOU SHALL NOT PASS" + , rejectCode = 401 + } + + code @?= 401 + + +-------------------------------------------------------------------------------- +-- I don't believe this one is supported yet +rq9000 :: RequestHead +rq9000 = RequestHead "/chat" + [ ("Host", "server.example.com") + , ("Upgrade", "websocket") + , ("Connection", "Upgrade") + , ("Sec-WebSocket-Key", "dGhlIHNhbXBsZSBub25jZQ==") + , ("Sec-WebSocket-Origin", "http://example.com") + , ("Sec-WebSocket-Protocol", "chat, superchat") + , ("Sec-WebSocket-Version", "9000") + ] + False + + +-------------------------------------------------------------------------------- +testHandshakeHybi9000 :: Assertion +testHandshakeHybi9000 = do + ResponseHead code _ headers <- testHandshake rq9000 $ \pc -> + flip handle (acceptRequest pc) $ \e -> case e of + NotSupported -> return undefined + _ -> error $ "Unexpected Exception: " ++ show e + + code @?= 400 + headers ! "Sec-WebSocket-Version" @?= "13" diff --git a/tests/haskell/Network/WebSockets/Http/Tests.hs b/tests/haskell/Network/WebSockets/Http/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/haskell/Network/WebSockets/Http/Tests.hs @@ -0,0 +1,88 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +module Network.WebSockets.Http.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import qualified Data.Attoparsec.ByteString as A +import qualified Data.ByteString.Char8 as BC +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, assert) + + +-------------------------------------------------------------------------------- +import Network.WebSockets.Http + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Network.WebSockets.Http.Tests" + [ testCase "jwebsockets response" jWebSocketsResponse + , testCase "chromium response" chromiumResponse + , testCase "matchbook response" matchbookResponse + ] + + +-------------------------------------------------------------------------------- +-- | This is a specific response sent by jwebsockets which caused trouble +jWebSocketsResponse :: Assertion +jWebSocketsResponse = assert $ case A.parseOnly decodeResponseHead input of + Left err -> error err + Right _ -> True + where + input = BC.intercalate "\r\n" + [ "HTTP/1.1 101 Switching Protocols" + , "Upgrade: websocket" + , "Connection: Upgrade" + , "Sec-WebSocket-Accept: Ha0QR1T9CoYx/nqwHsVnW8KVTSo=" + , "Sec-WebSocket-Origin: " + , "Sec-WebSocket-Location: ws://127.0.0.1" + , "Set-Cookie: JWSSESSIONID=2e0690e2e328f327056a5676b6a890e3; HttpOnly" + , "" + , "" + ] + + +-------------------------------------------------------------------------------- +-- | This is a specific response sent by chromium which caused trouble +chromiumResponse :: Assertion +chromiumResponse = assert $ case A.parseOnly decodeResponseHead input of + Left err -> error err + Right _ -> True + where + input = BC.intercalate "\r\n" + [ "HTTP/1.1 500 Internal Error" + , "Content-Type:text/html" + , "Content-Length:23" + , "" + , "No such target id: 20_1" + ] + +-------------------------------------------------------------------------------- +-- | This is a specific response sent by Matchbook.com which caused trouble + +matchbookResponse :: Assertion +matchbookResponse = assert $ case A.parseOnly decodeResponseHead input of + Left err -> error err + Right _ -> True + where + input = BC.intercalate "\r\n" + [ "HTTP/1.1 101 " + , "Date: Mon, 22 May 2017 19:39:08 GMT" + , "Connection: upgrade" + , "Set-Cookie: __cfduid=deadbeefdeadbeefdeadbeefdeadbeefdeadbeefdea; expires=Tue, 22-May-18 19:39:08 GMT; path=/; domain=.matchbook.com; HttpOnly" + , "X-Content-Type-Options: nosniff" + , "X-XSS-Protection: 1; mode=block" + , "X-Frame-Options: DENY" + , "Upgrade: websocket" + , "Sec-WebSocket-Accept: dEadB33fDeadbEEfD3aDbE3Fdea=" + , "X-MB-HA: edge-socket" + , "X-MB-HAP: haproxy01aws" + , "Server: cloudflare-nginx" + , "CF-RAY: 3632deadbeef5b33-HEL" + , "" + , "" + ] 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 new file mode 100644 --- /dev/null +++ b/tests/haskell/Network/WebSockets/Server/Tests.hs @@ -0,0 +1,185 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Network.WebSockets.Server.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Control.Applicative ((<$>), (<|>)) +import Control.Concurrent (forkIO, killThread, + threadDelay) +import Control.Concurrent.Async (Async, async, cancel) +import Control.Exception (SomeException, catch, handle) +import Control.Monad (forever, replicateM, unless) +import Data.IORef (IORef, newIORef, readIORef, + writeIORef) + +-------------------------------------------------------------------------------- +import qualified Data.ByteString.Lazy as BL +import Data.Text (Text) +import System.Environment (getEnvironment) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, assert, (@=?)) +import Test.QuickCheck (Arbitrary, arbitrary) +import Test.QuickCheck.Gen (Gen (..)) +import Test.QuickCheck.Random (newQCGen) + + +-------------------------------------------------------------------------------- +import Network.WebSockets +import Network.WebSockets.Tests.Util + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Network.WebSockets.Server.Tests" + [ testCase "simple server/client" testSimpleServerClient + , testCase "bulk server/client" testBulkServerClient + , testCase "onPong" testOnPong + , testCase "ipv6 server" testIpv6Server + , testCase "reject request" testRejectRequest + ] + + +-------------------------------------------------------------------------------- +testSimpleServerClient :: Assertion +testSimpleServerClient = testServerClient "127.0.0.1" $ \conn -> mapM_ (sendTextData conn) + + +-------------------------------------------------------------------------------- +-- | This is a bit ugly but it seems CI services don't support ipv6 in 2018. +skipIpv6Incompatible :: Assertion -> Assertion +skipIpv6Incompatible assertion = do + env <- getEnvironment + case lookup "TRAVIS" env <|> lookup "CIRCLECI" env of + Just "true" -> return () + _ -> assertion + +-------------------------------------------------------------------------------- +testIpv6Server :: Assertion +testIpv6Server = skipIpv6Incompatible $ + testServerClient "::1" $ \conn -> mapM_ (sendTextData conn) + +-------------------------------------------------------------------------------- +testBulkServerClient :: Assertion +testBulkServerClient = testServerClient "127.0.0.1" sendTextDatas + +-------------------------------------------------------------------------------- +testServerClient :: String -> (Connection -> [BL.ByteString] -> IO ()) -> Assertion +testServerClient host sendMessages = withEchoServer host 42940 "Bye" $ do + texts <- map unArbitraryUtf8 <$> sample + texts' <- runClient host 42940 "/chat" $ client texts + texts @=? texts' + where + client :: [BL.ByteString] -> ClientApp [BL.ByteString] + client texts conn = do + sendMessages conn texts + texts' <- replicateM (length texts) (receiveData conn) + sendClose conn ("Bye" :: BL.ByteString) + expectCloseException conn "Bye" + return texts' + +-------------------------------------------------------------------------------- +testRejectRequest :: Assertion +testRejectRequest = withRejectingServer + where + client :: ClientApp () + client _ = error "Client should not be able to connect" + + server :: ServerApp + server pendingConnection = rejectRequest pendingConnection "Bye" + + withRejectingServer :: IO () + withRejectingServer = do + serverThread <- async $ runServer "127.0.0.1" 42940 server + waitSome + () <- runClient "127.0.0.1" 42940 "/chat" client `catch` handler + waitSome + cancel serverThread + return () + + handler :: HandshakeException -> IO () + handler (RequestRejected _ response) = do + responseCode response @=? 400 + handler exc = error $ "Unexpected exception " ++ show exc + +-------------------------------------------------------------------------------- +testOnPong :: Assertion +testOnPong = withEchoServer "127.0.0.1" 42941 "Bye" $ do + gotPong <- newIORef False + let opts = defaultConnectionOptions + { connectionOnPong = writeIORef gotPong True + } + + rcv <- runClientWith "127.0.0.1" 42941 "/" opts [] client + assert rcv + assert =<< readIORef gotPong + where + client :: ClientApp Bool + client conn = do + sendPing conn ("What's a fish without an eye?" :: Text) + sendTextData conn ("A fsh!" :: Text) + msg <- receiveData conn + sendCloseCode conn 1000 ("Bye" :: BL.ByteString) + expectCloseException conn "Bye" + return $ "A fsh!" == (msg :: Text) + + +-------------------------------------------------------------------------------- +sample :: Arbitrary a => IO [a] +sample = do + gen <- newQCGen + return $ (unGen arbitrary) gen 512 + + +-------------------------------------------------------------------------------- +waitSome :: IO () +waitSome = threadDelay $ 200 * 1000 + +-------------------------------------------------------------------------------- +withEchoServer :: String -> Int -> BL.ByteString -> IO a -> IO a +withEchoServer host port expectedClose action = do + cRef <- newIORef False + serverThread <- async $ runServer host port (\c -> server c `catch` handleClose cRef) + waitSome + result <- action + waitSome + cancel serverThread + closeCalled <- readIORef cRef + unless closeCalled $ error "Expecting the CloseRequest exception" + return result + where + server :: ServerApp + server pc = do + conn <- acceptRequest pc + forever $ do + msg <- receiveDataMessage conn + sendDataMessage conn msg + + handleClose :: IORef Bool -> ConnectionException -> IO () + handleClose cRef (CloseRequest i msg) = do + i @=? 1000 + msg @=? expectedClose + writeIORef cRef True + handleClose _ ConnectionClosed = + error "Unexpected connection closed exception" + handleClose _ (ParseException _) = + error "Unexpected parse exception" + handleClose _ (UnicodeException _) = + error "Unexpected unicode exception" + + +-------------------------------------------------------------------------------- +expectCloseException :: Connection -> BL.ByteString -> IO () +expectCloseException conn msg = act `catch` handler + where + act = receiveDataMessage conn >> error "Expecting CloseRequest exception" + handler (CloseRequest i msg') = do + i @=? 1000 + msg' @=? msg + handler ConnectionClosed = error "Unexpected connection closed" + handler (ParseException _) = error "Unexpected parse exception" + handler (UnicodeException _) = error "Unexpected unicode exception" diff --git a/tests/haskell/Network/WebSockets/Tests.hs b/tests/haskell/Network/WebSockets/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/haskell/Network/WebSockets/Tests.hs @@ -0,0 +1,223 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Network.WebSockets.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import qualified Data.ByteString.Builder as Builder +import Control.Applicative ((<$>)) +import Control.Concurrent (forkIO) +import Control.Exception (try) +import Control.Monad (replicateM) +import Data.Binary.Get (runGetOrFail) +import qualified Data.ByteString.Lazy as BL +import Data.List (intersperse) +import Data.Maybe (catMaybes) +import Data.Monoid (mempty, mconcat) +import Network.WebSockets +import qualified Network.WebSockets.Hybi13 as Hybi13 +import Network.WebSockets.Hybi13.Demultiplex +import Network.WebSockets.Protocol +import qualified Network.WebSockets.Stream as Stream +import Network.WebSockets.Tests.Util +import Network.WebSockets.Types +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit ((@=?)) +import Test.QuickCheck (Arbitrary (..), Gen, + Property) +import qualified Test.QuickCheck as QC +import qualified Test.QuickCheck.Monadic as QC +import Prelude + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Network.WebSockets.Test" + [ testProperty "simple encode/decode Hybi13" (testSimpleEncodeDecode Hybi13) + , testProperty "fragmented Hybi13" testFragmentedHybi13 + , testRfc_6455_5_5_1 + , testRfc_6455_5_5_2 + , testFramePayloadSizeLimit + ] + +-------------------------------------------------------------------------------- +testSimpleEncodeDecode :: Protocol -> Property +testSimpleEncodeDecode protocol = QC.monadicIO $ + QC.forAllM QC.arbitrary $ \msgs -> QC.run $ do + echo <- Stream.makeEchoStream + parse <- decodeMessages protocol mempty mempty echo + write <- encodeMessages protocol ClientConnection echo + _ <- forkIO $ write msgs + msgs' <- catMaybes <$> replicateM (length msgs) parse + Stream.close echo + msgs @=? msgs' + + +-------------------------------------------------------------------------------- +testFragmentedHybi13 :: Property +testFragmentedHybi13 = QC.monadicIO $ + QC.forAllM QC.arbitrary $ \fragmented -> QC.run $ do + echo <- Stream.makeEchoStream + parse <- Hybi13.decodeMessages mempty mempty echo + -- is' <- Streams.filter isDataMessage =<< Hybi13.decodeMessages is + + -- Simple hacky encoding of all frames + _ <- forkIO $ do + mapM_ (Stream.write echo) + [ Builder.toLazyByteString (Hybi13.encodeFrame Nothing f) + | FragmentedMessage _ frames <- fragmented + , f <- frames + ] + Stream.close echo + + -- Check if we got all data + msgs <- filter isDataMessage <$> parseAll parse + [msg | FragmentedMessage msg _ <- fragmented] @=? msgs + where + isDataMessage (ControlMessage _) = False + isDataMessage (DataMessage _ _ _ _) = True + + parseAll parse = do + mbMsg <- try parse + case mbMsg of + Left ConnectionClosed -> return [] + Left _ -> return [] + Right (Just msg) -> (msg :) <$> parseAll parse + Right Nothing -> return [] + +-------------------------------------------------------------------------------- +testRfc_6455_5_5_1 :: Test +testRfc_6455_5_5_1 = + testCase "RFC 6455, 5.5: Frame encoder shall truncate control frame payload to 125 bytes" $ do + 260 @=? BL.length (encodedFrame ContinuationFrame) + 260 @=? BL.length (encodedFrame TextFrame) + 260 @=? BL.length (encodedFrame BinaryFrame) + 127 @=? BL.length (encodedFrame CloseFrame) + 127 @=? BL.length (encodedFrame PingFrame) + 127 @=? BL.length (encodedFrame PongFrame) + where + payload256 = BL.replicate 256 0 + encodedFrame ft + = Builder.toLazyByteString + $ Hybi13.encodeFrame Nothing (Frame True False False False ft payload256) + +-------------------------------------------------------------------------------- +testRfc_6455_5_5_2 :: Test +testRfc_6455_5_5_2 = + testCase "RFC 6455, 5.5: Frame decoder shall fail if control frame payload length > 125 bytes" $ + Left (BL.drop 4 ping126, 4, errMsg) @=? runGetOrFail (Hybi13.parseFrame mempty) ping126 + where + errMsg = "Control Frames must not carry payload > 125 bytes!" + ping126 = mconcat + [ "\137\254\NUL~\219\SI\190\252\219\SI\190\252\219\SI\190\252\219" + , "\SI\190\252\219\SI\190\252\219\SI\190\252\219\SI\190\252\219" + , "\SI\190\252\219\SI\190\252\219\SI\190\252\219\SI\190\252\219" + , "\SI\190\252\219\SI\190\252\219\SI\190\252\219\SI\190\252\219" + , "\SI\190\252\219\SI\190\252\219\SI\190\252\219\SI\190\252\219" + , "\SI\190\252\219\SI\190\252\219\SI\190\252\219\SI\190\252\219" + , "\SI\190\252\219\SI\190\252\219\SI\190\252\219\SI\190\252\219" + , "\SI\190\252\219\SI\190\252\219\SI\190\252\219\SI\190\252\219" + , "\SI\190\252\219\SI" + ] + +testFramePayloadSizeLimit :: Test +testFramePayloadSizeLimit = testGroup "FramePayloadSizeLimit Hybi13" + [ testCase "OK 1" $ case parse (frame 99) of + Right _ -> return () + Left _ -> fail "Expecting successful parse." + , testCase "OK 2" $ case parse (frame 100) of + Right _ -> return () + Left _ -> fail "Expecting successful parse." + , testCase "Exceed" $ case parse (frame 101) of + Right _ -> fail "Expecting parse to fail." + Left _ -> return () + ] + where + parse = runGetOrFail (Hybi13.parseFrame (SizeLimit 100)) + frame n = Builder.toLazyByteString $ Hybi13.encodeFrame Nothing $ + Frame True False False False BinaryFrame (BL.replicate n 20) + + +-------------------------------------------------------------------------------- +instance Arbitrary Message where + arbitrary = QC.oneof + [ do + payload <- BL.take 125 . BL.pack <$> arbitrary + return $ ControlMessage (Ping payload) + , do + payload <- BL.take 125 . BL.pack <$> arbitrary + return $ ControlMessage (Pong payload) + , do + payload <- BL.pack <$> arbitrary + return $ DataMessage False False False (Text payload Nothing) + , do + payload <- BL.pack <$> arbitrary + return $ DataMessage False False False (Binary payload) + ] + + +-------------------------------------------------------------------------------- +data FragmentedMessage = FragmentedMessage Message [Frame] + deriving (Show) + + +-------------------------------------------------------------------------------- +instance Arbitrary FragmentedMessage where + arbitrary = do + -- Pick a frametype and a corresponding random payload + ft <- QC.elements [TextFrame, BinaryFrame] + payload <- case ft of + TextFrame -> arbitraryUtf8 + _ -> arbitraryByteString + + fragments <- arbitraryFragmentation payload + let fs = makeFrames $ zip (ft : repeat ContinuationFrame) fragments + msg = case ft of + TextFrame -> DataMessage False False False (Text payload Nothing) + BinaryFrame -> DataMessage False False False (Binary payload) + _ -> error "Arbitrary FragmentedMessage crashed" + + interleaved <- arbitraryInterleave genControlFrame fs + return $ FragmentedMessage msg interleaved + -- return $ FragmentedMessage msg fs + where + makeFrames [] = [] + makeFrames [(ft, pl)] = [Frame True False False False ft pl] + makeFrames ((ft, pl) : fr) = + Frame False False False False ft pl : makeFrames fr + + genControlFrame = QC.elements + [ Frame True False False False PingFrame "Herp" + , Frame True False False False PongFrame "Derp" + ] + + +-------------------------------------------------------------------------------- +arbitraryFragmentation :: BL.ByteString -> Gen [BL.ByteString] +arbitraryFragmentation bs = arbitraryFragmentation' bs + where + len :: Int + len = fromIntegral $ BL.length bs + arbitraryFragmentation' bs' = do + -- TODO: we currently can't send packets of length 0. We should + -- investigate why (regardless of the spec). + n <- QC.choose (1, len - 1) + let (l, r) = BL.splitAt (fromIntegral n) bs' + case r of + "" -> return [l] + _ -> (l :) <$> arbitraryFragmentation' r + + +-------------------------------------------------------------------------------- +arbitraryInterleave :: Gen a -> [a] -> Gen [a] +arbitraryInterleave sep xs = fmap concat $ sequence $ + [sep'] ++ intersperse sep' [return [x] | x <- xs] ++ [sep'] + where + sep' = QC.sized $ \size -> do + num <- QC.choose (1, size) + replicateM num sep diff --git a/tests/haskell/Network/WebSockets/Tests/Util.hs b/tests/haskell/Network/WebSockets/Tests/Util.hs new file mode 100644 --- /dev/null +++ b/tests/haskell/Network/WebSockets/Tests/Util.hs @@ -0,0 +1,38 @@ +-------------------------------------------------------------------------------- +module Network.WebSockets.Tests.Util + ( ArbitraryUtf8 (..) + , arbitraryUtf8 + , arbitraryByteString + ) where + + +-------------------------------------------------------------------------------- +import Control.Applicative ((<$>)) +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import Test.QuickCheck (Arbitrary (..), Gen) + + +-------------------------------------------------------------------------------- +import Network.WebSockets.Types + + +-------------------------------------------------------------------------------- +newtype ArbitraryUtf8 = ArbitraryUtf8 {unArbitraryUtf8 :: BL.ByteString} + deriving (Eq, Ord, Show) + + +-------------------------------------------------------------------------------- +instance Arbitrary ArbitraryUtf8 where + arbitrary = ArbitraryUtf8 <$> arbitraryUtf8 + + +-------------------------------------------------------------------------------- +arbitraryUtf8 :: Gen BL.ByteString +arbitraryUtf8 = toLazyByteString . TL.encodeUtf8 . TL.pack <$> arbitrary + + +-------------------------------------------------------------------------------- +arbitraryByteString :: Gen BL.ByteString +arbitraryByteString = BL.pack <$> arbitrary diff --git a/tests/haskell/TestSuite.hs b/tests/haskell/TestSuite.hs --- a/tests/haskell/TestSuite.hs +++ b/tests/haskell/TestSuite.hs @@ -1,12 +1,24 @@ -import Test.Framework (defaultMain) - -import qualified Network.WebSockets.Tests +-------------------------------------------------------------------------------- +import qualified Network.WebSockets.Extensions.Tests +import qualified Network.WebSockets.Extensions.PermessageDeflate.Tests import qualified Network.WebSockets.Handshake.Tests -import qualified Network.WebSockets.Socket.Tests +import qualified Network.WebSockets.Http.Tests +import qualified Network.WebSockets.Hybi13.Demultiplex.Tests +import qualified Network.WebSockets.Mask.Tests +import qualified Network.WebSockets.Server.Tests +import qualified Network.WebSockets.Tests +import Test.Framework (defaultMain) + +-------------------------------------------------------------------------------- main :: IO () main = defaultMain - [ Network.WebSockets.Tests.tests + [ Network.WebSockets.Extensions.Tests.tests + , Network.WebSockets.Extensions.PermessageDeflate.Tests.tests , Network.WebSockets.Handshake.Tests.tests - , Network.WebSockets.Socket.Tests.tests + , Network.WebSockets.Http.Tests.tests + , Network.WebSockets.Hybi13.Demultiplex.Tests.tests + , Network.WebSockets.Server.Tests.tests + , Network.WebSockets.Mask.Tests.tests + , Network.WebSockets.Tests.tests ] diff --git a/websockets.cabal b/websockets.cabal --- a/websockets.cabal +++ b/websockets.cabal @@ -1,5 +1,5 @@ Name: websockets -Version: 0.6.0.4 +Version: 0.13.0.0 Synopsis: A sensible and clean way to write WebSocket-capable servers in Haskell. @@ -7,10 +7,11 @@ Description: This library allows you to write WebSocket-capable servers. . - See an example: . + An example server: + . - The API of the 'Network.WebSockets' module should also contain enough - information to get you started. + An example client: + . See also: . @@ -23,98 +24,220 @@ License: BSD3 License-file: LICENCE Copyright: (c) 2010-2011 Siniša Biđin - (c) 2011 Jasper Van der Jeugt + (c) 2011-2018 Jasper Van der Jeugt (c) 2011 Steffen Schuldenzucker (c) 2011 Alex Lang Author: Siniša Biđin 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 +Extra-source-files: + CHANGELOG + +Source-repository head + Type: git + Location: https://github.com/jaspervdj/websockets + +Flag Example + Description: Build the example server + Default: False + Manual: True + Library Hs-source-dirs: src - Ghc-options: -Wall + Ghc-options: -Wall + C-sources: cbits/cbits.c + Default-language: Haskell2010 Exposed-modules: Network.WebSockets - Network.WebSockets.Internal - Network.WebSockets.Util.PubSub + Network.WebSockets.Client + Network.WebSockets.Connection + Network.WebSockets.Connection.PingPong + Network.WebSockets.Extensions + Network.WebSockets.Stream + -- Network.WebSockets.Util.PubSub TODO Other-modules: - Network.WebSockets.Handshake - Network.WebSockets.Handshake.Http - Network.WebSockets.Monad + Network.WebSockets.Connection.Options + Network.WebSockets.Extensions.Description + Network.WebSockets.Extensions.PermessageDeflate + Network.WebSockets.Extensions.StrictUnicode + Network.WebSockets.Http + Network.WebSockets.Hybi13 + Network.WebSockets.Hybi13.Demultiplex + Network.WebSockets.Hybi13.Mask Network.WebSockets.Protocol - Network.WebSockets.Protocol.Hybi00 - Network.WebSockets.Protocol.Hybi00.Internal - Network.WebSockets.Protocol.Hybi10 - Network.WebSockets.Protocol.Hybi10.Demultiplex - Network.WebSockets.Protocol.Hybi10.Internal - Network.WebSockets.Protocol.Hybi10.Mask - Network.WebSockets.Protocol.Unsafe - Network.WebSockets.Socket + Network.WebSockets.Server Network.WebSockets.Types Build-depends: - attoparsec >= 0.9 && < 0.11, - attoparsec-enumerator >= 0.2 && < 0.4, - base >= 4 && < 5, - base64-bytestring >= 0.1 && < 0.2, - binary >= 0.5 && < 0.6, - blaze-builder >= 0.3 && < 0.4, - blaze-builder-enumerator >= 0.2 && < 0.3, - bytestring >= 0.9 && < 0.10, - case-insensitive >= 0.3 && < 0.5, - containers >= 0.3 && < 0.6, - enumerator >= 0.4.13 && < 0.5, - mtl >= 2.0 && < 2.2, - network >= 2.3 && < 2.4, - network-enumerator >= 0.1 && < 0.2, - random >= 1.0 && < 1.1, - SHA >= 1.5 && < 1.6, - text >= 0.10 && < 0.12, - pureMD5 >= 0.2.2 && < 2.2 + async >= 2.2 && < 2.3, + attoparsec >= 0.10 && < 0.15, + base >= 4.14 && < 5, + base64-bytestring >= 0.1 && < 1.3, + binary >= 0.8.1 && < 0.11, + bytestring >= 0.9 && < 0.13, + case-insensitive >= 0.3 && < 1.3, + containers >= 0.3 && < 0.7, + network >= 2.3 && < 3.2, + random >= 1.0.1 && < 1.3, + SHA >= 1.5 && < 1.7, + streaming-commons >= 0.1 && < 0.3, + text >= 0.10 && < 2.2, + entropy >= 0.2.1 && < 0.5 Test-suite websockets-tests - Type: exitcode-stdio-1.0 - Hs-source-dirs: src tests/haskell - Main-is: TestSuite.hs - Ghc-options: -Wall + Type: exitcode-stdio-1.0 + Hs-source-dirs: src tests/haskell + Main-is: TestSuite.hs + Ghc-options: -Wall + C-sources: cbits/cbits.c + Default-language: Haskell2010 + Other-modules: + Network.WebSockets + Network.WebSockets.Client + Network.WebSockets.Connection + Network.WebSockets.Connection.Options + Network.WebSockets.Connection.PingPong + Network.WebSockets.Extensions + Network.WebSockets.Extensions.Description + Network.WebSockets.Extensions.PermessageDeflate + Network.WebSockets.Extensions.PermessageDeflate.Tests + Network.WebSockets.Extensions.StrictUnicode + Network.WebSockets.Extensions.Tests + Network.WebSockets.Handshake.Tests + Network.WebSockets.Http + Network.WebSockets.Http.Tests + Network.WebSockets.Hybi13 + Network.WebSockets.Hybi13.Demultiplex + Network.WebSockets.Hybi13.Demultiplex.Tests + Network.WebSockets.Hybi13.Mask + Network.WebSockets.Mask.Tests + Network.WebSockets.Protocol + Network.WebSockets.Server + Network.WebSockets.Server.Tests + Network.WebSockets.Stream + Network.WebSockets.Tests + Network.WebSockets.Tests.Util + Network.WebSockets.Types + Paths_websockets + Build-depends: - HUnit >= 1.2 && < 1.3, - QuickCheck >= 2.4 && < 2.5, - test-framework >= 0.4 && < 0.7, - test-framework-hunit >= 0.2 && < 0.3, - test-framework-quickcheck2 >= 0.2 && < 0.3, + HUnit >= 1.2 && < 1.7, + QuickCheck >= 2.7 && < 2.15, + test-framework >= 0.4 && < 0.9, + test-framework-hunit >= 0.2 && < 0.4, + test-framework-quickcheck2 >= 0.2 && < 0.4, -- Copied from regular dependencies... - attoparsec >= 0.9 && < 0.11, - attoparsec-enumerator >= 0.2 && < 0.4, - base >= 4 && < 5, - base64-bytestring >= 0.1 && < 0.2, - binary >= 0.5 && < 0.6, - blaze-builder >= 0.3 && < 0.4, - blaze-builder-enumerator >= 0.2 && < 0.3, - bytestring >= 0.9 && < 0.10, - case-insensitive >= 0.3 && < 0.5, - containers >= 0.3 && < 0.6, - enumerator >= 0.4.13 && < 0.5, - mtl >= 2.0 && < 2.2, - network >= 2.3 && < 2.4, - network-enumerator >= 0.1 && < 0.2, - random >= 1.0 && < 1.1, - SHA >= 1.5 && < 1.6, - text >= 0.10 && < 0.12, - pureMD5 >= 0.2.2 && < 2.2 + async >= 2.2 && < 2.3, + attoparsec >= 0.10 && < 0.15, + base >= 4.14 && < 5, + base64-bytestring >= 0.1 && < 1.3, + binary >= 0.8.1 && < 0.11, + bytestring >= 0.9 && < 0.13, + case-insensitive >= 0.3 && < 1.3, + containers >= 0.3 && < 0.7, + network >= 2.3 && < 3.2, + random >= 1.0 && < 1.3, + SHA >= 1.5 && < 1.7, + streaming-commons >= 0.1 && < 0.3, + text >= 0.10 && < 2.2, + entropy >= 0.2.1 && < 0.5 -Source-repository head - Type: git - Location: https://github.com/jaspervdj/websockets +Executable websockets-server-example + If !flag(Example) + Buildable: False + + Hs-source-dirs: example + Main-is: server.lhs + Ghc-options: -Wall + Default-language: Haskell2010 + + Build-depends: + base, + websockets, + text + +Executable websockets-client-example + If !flag(Example) + Buildable: False + + Hs-source-dirs: example + Main-is: client.hs + Ghc-options: -Wall + Default-language: Haskell2010 + + Build-depends: + base, + websockets, + text, + network, + mtl + +Executable websockets-autobahn + If !flag(Example) + Buildable: False + + Hs-source-dirs: tests/autobahn + Main-is: server.hs + Ghc-options: -Wall -threaded -O2 -rtsopts "-with-rtsopts=-N" + Default-language: Haskell2010 + + Other-modules: + Paths_websockets + + Build-depends: + websockets, + -- Copied from regular dependencies... + async >= 2.2 && < 2.3, + attoparsec >= 0.10 && < 0.15, + base >= 4.14 && < 5, + base64-bytestring >= 0.1 && < 1.3, + binary >= 0.8.1 && < 0.11, + bytestring >= 0.9 && < 0.13, + case-insensitive >= 0.3 && < 1.3, + containers >= 0.3 && < 0.7, + network >= 2.3 && < 3.2, + random >= 1.0 && < 1.3, + SHA >= 1.5 && < 1.7, + text >= 0.10 && < 2.2, + entropy >= 0.2.1 && < 0.5 + +Benchmark bench-mask + Type: exitcode-stdio-1.0 + Main-is: mask.hs + C-sources: cbits/cbits.c + Hs-source-dirs: benchmarks, src + Default-language: Haskell2010 + + Other-modules: + Network.WebSockets.Hybi13.Mask + + Build-depends: + criterion, + -- Copied from regular dependencies... + async >= 2.2 && < 2.3, + attoparsec >= 0.10 && < 0.15, + base >= 4.14 && < 5, + base64-bytestring >= 0.1 && < 1.3, + binary >= 0.8.1 && < 0.11, + bytestring >= 0.9 && < 0.13, + case-insensitive >= 0.3 && < 1.3, + containers >= 0.3 && < 0.7, + network >= 2.3 && < 3.2, + random >= 1.0 && < 1.3, + SHA >= 1.5 && < 1.7, + text >= 0.10 && < 2.2, + entropy >= 0.2.1 && < 0.5