websockets 0.10.0.0 → 0.11.0.0
raw patch · 24 files changed
+1095/−208 lines, 24 filesdep +criteriondep +streaming-commonsdep ~basedep ~bytestringdep ~randomnew-component:exe:websockets-autobahn
Dependencies added: criterion, streaming-commons
Dependency ranges changed: base, bytestring, random
Files
- CHANGELOG +6/−0
- benchmarks/mask.hs +64/−0
- example/server.lhs +4/−4
- src/Network/WebSockets.hs +8/−0
- src/Network/WebSockets/Client.hs +7/−7
- src/Network/WebSockets/Connection.hs +134/−31
- src/Network/WebSockets/Extensions.hs +24/−0
- src/Network/WebSockets/Extensions/Description.hs +63/−0
- src/Network/WebSockets/Extensions/PermessageDeflate.hs +285/−0
- src/Network/WebSockets/Extensions/StrictUnicode.hs +40/−0
- src/Network/WebSockets/Http.hs +35/−20
- src/Network/WebSockets/Hybi13.hs +28/−27
- src/Network/WebSockets/Hybi13/Demultiplex.hs +65/−37
- src/Network/WebSockets/Hybi13/Mask.hs +12/−4
- src/Network/WebSockets/Protocol.hs +5/−2
- src/Network/WebSockets/Server.hs +10/−7
- src/Network/WebSockets/Types.hs +57/−10
- tests/autobahn/server.hs +85/−0
- tests/haskell/Network/WebSockets/Extensions/Tests.hs +44/−0
- tests/haskell/Network/WebSockets/Handshake/Tests.hs +14/−0
- tests/haskell/Network/WebSockets/Server/Tests.hs +33/−11
- tests/haskell/Network/WebSockets/Tests.hs +20/−42
- tests/haskell/TestSuite.hs +4/−5
- websockets.cabal +48/−1
CHANGELOG view
@@ -1,3 +1,9 @@+- 0.11.0.0+ * Faster masking (by Dmitry Ivanov)+ * Support for IPv6 in the built-in server, client and tests (by agentm)+ * 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)
+ benchmarks/mask.hs view
@@ -0,0 +1,64 @@+{-# language BangPatterns #-}+{-# language OverloadedStrings #-}++import Criterion+import Criterion.Main++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+ return (kilo, mega)++maskPayload' :: Mask -> 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) -> bgroup "main"+ [ bgroup "kilobyte payload"+ [ bgroup "zero_mask"+ [ bench "current" $ nf (maskPayload (Just "\x00\x00\x00\x00")) kilo+ , bench "old" $ nf (maskPayload' (Just "\x00\x00\x00\x00")) kilo+ ]+ , bgroup "full_mask"+ [ bench "current" $ nf (maskPayload (Just "\xFF\xFF\xFF\xFF")) kilo+ , bench "old" $ nf (maskPayload' (Just "\xFF\xFF\xFF\xFF")) kilo+ ]+ , bgroup "one_byte_mask"+ [ bench "current" $ nf (maskPayload (Just "\xCC\xCC\xCC\xCC")) kilo+ , bench "old" $ nf (maskPayload' (Just "\xCC\xCC\xCC\xCC")) kilo+ ]+ , bgroup "other_mask"+ [ bench "current" $ nf (maskPayload (Just "\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 (Just "\x00\x00\x00\x00")) mega+ , bench "old" $ nf (maskPayload' (Just "\x00\x00\x00\x00")) mega+ ]+ , bgroup "full_mask"+ [ bench "current" $ nf (maskPayload (Just "\xFF\xFF\xFF\xFF")) mega+ , bench "old" $ nf (maskPayload' (Just "\xFF\xFF\xFF\xFF")) mega+ ]+ , bgroup "one_byte_mask"+ [ bench "current" $ nf (maskPayload (Just "\xCC\xCC\xCC\xCC")) mega+ , bench "old" $ nf (maskPayload' (Just "\xCC\xCC\xCC\xCC")) mega+ ]+ , bgroup "other_mask"+ [ bench "current" $ nf (maskPayload (Just "\xB0\xA2\xB0\xA2")) mega+ , bench "old" $ nf (maskPayload' (Just "\xB0\xA2\xB0\xA2")) mega+ ]+ ]+ ]+ ]
example/server.lhs view
@@ -3,11 +3,11 @@ This is the Haskell implementation of the example for the WebSockets library. We implement a simple multi-user chat program. A live demo of the example is-available [here](http://jaspervdj.be/websockets-example). In order to understand-this example, keep the [reference](http://jaspervdj.be/websockets/reference)-nearby to check out the functions we use.+available [here](/example/client.html). In order to understand this example,+keep the [reference](/reference/) nearby to check out the functions we use. > {-# LANGUAGE OverloadedStrings #-}+> module Main where > import Data.Char (isPunctuation, isSpace) > import Data.Monoid (mappend) > import Data.Text (Text)@@ -70,7 +70,7 @@ > main :: IO () > main = do > state <- newMVar newServerState-> WS.runServer "0.0.0.0" 9160 $ application state+> WS.runServer "127.0.0.1" 9160 $ application state Our main application has the type:
src/Network/WebSockets.hs view
@@ -9,6 +9,9 @@ , defaultAcceptRequest , acceptRequestWith , rejectRequest+ , RejectRequest(..)+ , defaultRejectRequest+ , rejectRequestWith -- * Main connection type , Connection@@ -16,6 +19,11 @@ -- * Options for connections , ConnectionOptions (..) , defaultConnectionOptions++ -- ** Compression options+ , CompressionOptions (..)+ , PermessageDeflate (..)+ , defaultPermessageDeflate -- * Sending and receiving messages , receive
src/Network/WebSockets/Client.hs view
@@ -13,6 +13,7 @@ -------------------------------------------------------------------------------- import qualified Blaze.ByteString.Builder as Builder import Control.Exception (bracket, finally, throwIO)+import Control.Monad (void) import Data.IORef (newIORef) import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -56,20 +57,20 @@ runClientWith host port path0 opts customHeaders app = do -- Create and connect socket let hints = S.defaultHints- {S.addrFamily = S.AF_INET, S.addrSocketType = S.Stream}+ {S.addrSocketType = S.Stream} -- Correct host and path. fullHost = if port == 80 then host else (host ++ ":" ++ show port) path = if null path0 then "/" else path0- addrInfos <- S.getAddrInfo (Just hints) (Just host) (Just $ show port)- sock <- S.socket S.AF_INET S.Stream S.defaultProtocol+ addr:_ <- S.getAddrInfo (Just hints) (Just host) (Just $ show port)+ sock <- S.socket (S.addrFamily addr) S.Stream S.defaultProtocol S.setSocketOption sock S.NoDelay 1 -- Connect WebSocket and run client res <- finally- (S.connect sock (S.addrAddress $ head addrInfos) >>+ (S.connect sock (S.addrAddress addr) >> runClientWithSocket sock fullHost path opts customHeaders app)- (S.sClose sock)+ (S.close sock) -- Clean up return res@@ -100,8 +101,7 @@ Nothing -> throwIO $ OtherHandshakeException $ "Network.WebSockets.Client.runClientWithStream: no handshake " ++ "response from server"- -- Note that we pattern match to evaluate the result here- Response _ _ <- return $ finishResponse protocol request response+ void $ either throwIO return $ finishResponse protocol request response parse <- decodeMessages protocol stream write <- encodeMessages protocol ClientConnection stream sentRef <- newIORef False
src/Network/WebSockets/Connection.hs view
@@ -9,6 +9,9 @@ , defaultAcceptRequest , acceptRequestWith , rejectRequest+ , RejectRequest(..)+ , defaultRejectRequest+ , rejectRequestWith , Connection (..) @@ -30,28 +33,43 @@ , sendPing , forkPingThread++ , CompressionOptions (..)+ , PermessageDeflate (..)+ , defaultPermessageDeflate ) where ---------------------------------------------------------------------------------import qualified Blaze.ByteString.Builder as Builder-import Control.Concurrent (forkIO, threadDelay)-import Control.Exception (AsyncException, fromException,- handle, throwIO)-import Control.Monad (unless, when)-import qualified Data.ByteString as B-import Data.IORef (IORef, newIORef, readIORef,- writeIORef)-import Data.List (find)-import qualified Data.Text as T-import Data.Word (Word16)+import qualified Blaze.ByteString.Builder as Builder+import Control.Concurrent (forkIO,+ threadDelay)+import Control.Exception (AsyncException,+ fromException,+ handle,+ throwIO)+import Control.Monad (foldM, unless,+ when)+import qualified Data.ByteString as B+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 Network.WebSockets.Extensions as Extensions+import Network.WebSockets.Extensions.PermessageDeflate+import Network.WebSockets.Extensions.StrictUnicode import Network.WebSockets.Http import Network.WebSockets.Protocol-import Network.WebSockets.Stream (Stream)-import qualified Network.WebSockets.Stream as Stream+import Network.WebSockets.Stream (Stream)+import qualified Network.WebSockets.Stream as Stream import Network.WebSockets.Types @@ -81,7 +99,7 @@ -- ^ The subprotocol to speak with the client. If 'pendingSubprotcols' is -- non-empty, 'acceptSubprotocol' must be one of the subprotocols from the -- list.- , acceptHeaders :: !Headers+ , acceptHeaders :: !Headers -- ^ Extra headers to send with the response. } @@ -113,13 +131,41 @@ 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 (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+ headers = subproto ++ acceptHeaders ar ++ concatMap extHeaders exts response = finishRequest protocol request headers- sendResponse pc response- parse <- decodeMessages protocol (pendingStream pc)- write <- encodeMessages protocol ServerConnection (pendingStream pc) + either throwIO (sendResponse pc) response++ parseRaw <- decodeMessages protocol (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 let connection = Connection { connectionOptions = pendingOptions pc@@ -139,11 +185,55 @@ ---------------------------------------------------------------------------------rejectRequest :: PendingConnection -> B.ByteString -> IO ()-rejectRequest pc message = sendResponse pc $ response400 [] message+-- | Parameters that allow you to tweak how a request is rejected. Please use+-- 'defaultRejectRequest' and modify fields using record syntax so your code+-- will not break when new fields are added.+data RejectRequest = RejectRequest+ { -- | The status code, 400 by default.+ rejectCode :: !Int+ , -- | The message, "Bad Request" by default+ rejectMessage :: !B.ByteString+ , -- | Extra headers to be sent with the response.+ rejectHeaders :: Headers+ , -- | Reponse body of the rejection.+ rejectBody :: !B.ByteString+ } --------------------------------------------------------------------------------+defaultRejectRequest :: RejectRequest+defaultRejectRequest = RejectRequest+ { rejectCode = 400+ , rejectMessage = "Bad Request"+ , rejectHeaders = []+ , rejectBody = ""+ }+++--------------------------------------------------------------------------------+rejectRequestWith+ :: PendingConnection -- ^ Connection to reject+ -> RejectRequest -- ^ Params on how to reject the request+ -> IO ()+rejectRequestWith pc reject = sendResponse pc $ Response+ ResponseHead+ { responseCode = rejectCode reject+ , responseMessage = rejectMessage reject+ , responseHeaders = rejectHeaders reject+ }+ (rejectBody reject)+++--------------------------------------------------------------------------------+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@@ -162,20 +252,35 @@ -------------------------------------------------------------------------------- -- | Set options for a 'Connection'. data ConnectionOptions = ConnectionOptions- { connectionOnPong :: !(IO ())+ { connectionOnPong :: !(IO ()) -- ^ Whenever a 'pong' is received, this IO action is executed. It can be -- used to tickle connections or fire missiles.+ , 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. } -------------------------------------------------------------------------------- defaultConnectionOptions :: ConnectionOptions defaultConnectionOptions = ConnectionOptions- { connectionOnPong = return ()+ { connectionOnPong = return ()+ , connectionCompressionOptions = NoCompression+ , connectionStrictUnicode = False } --------------------------------------------------------------------------------+data CompressionOptions+ = NoCompression+ | PermessageDeflateCompression PermessageDeflate+ deriving (Eq, Show)+++-------------------------------------------------------------------------------- receive :: Connection -> IO Message receive conn = do mbMsg <- connectionParse conn@@ -199,8 +304,8 @@ receiveDataMessage conn = do msg <- receive conn case msg of- DataMessage am -> return am- ControlMessage cm -> case cm of+ DataMessage _ _ _ am -> return am+ ControlMessage cm -> case cm of Close i closeMsg -> do hasSentClose <- readIORef $ connectionSentClose conn unless hasSentClose $ send conn msg@@ -216,11 +321,7 @@ -------------------------------------------------------------------------------- -- | Receive a message, converting it to whatever format is needed. receiveData :: WebSocketsData a => Connection -> IO a-receiveData conn = do- dm <- receiveDataMessage conn- case dm of- Text x -> return (fromLazyByteString x)- Binary x -> return (fromLazyByteString x)+receiveData conn = fromDataMessage <$> receiveDataMessage conn --------------------------------------------------------------------------------@@ -245,7 +346,7 @@ -------------------------------------------------------------------------------- -- | Send a collection of 'DataMessage's sendDataMessages :: Connection -> [DataMessage] -> IO ()-sendDataMessages conn = sendAll conn . map DataMessage+sendDataMessages conn = sendAll conn . map (DataMessage False False False) -------------------------------------------------------------------------------- -- | Send a message as text@@ -255,7 +356,9 @@ -------------------------------------------------------------------------------- -- | Send a collection of messages as text sendTextDatas :: WebSocketsData a => Connection -> [a] -> IO ()-sendTextDatas conn = sendDataMessages conn . map (Text . toLazyByteString)+sendTextDatas conn =+ sendDataMessages conn .+ map (\x -> Text (toLazyByteString x) Nothing) -------------------------------------------------------------------------------- -- | Send a message as binary data
+ src/Network/WebSockets/Extensions.hs view
@@ -0,0 +1,24 @@+module Network.WebSockets.Extensions+ ( ExtensionDescription (..)+ , ExtensionDescriptions+ , parseExtensionDescriptions++ , NegotiateExtension+ , Extension (..)+ ) where++import Network.WebSockets.Extensions.Description+import Network.WebSockets.Http+import Network.WebSockets.Types++type NegotiateExtension = ExtensionDescriptions -> Either String Extension++-- | An extension is currently allowed to set extra headers and transform the+-- parse/write functions of 'Connection'.+--+-- This type is very likely to change as other extensions are introduced.+data Extension = Extension+ { extHeaders :: Headers+ , extParse :: IO (Maybe Message) -> IO (IO (Maybe Message))+ , extWrite :: ([Message] -> IO ()) -> IO ([Message] -> IO ())+ }
+ src/Network/WebSockets/Extensions/Description.hs view
@@ -0,0 +1,63 @@+-- | Code for parsing extensions headers.+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Network.WebSockets.Extensions.Description+ ( ExtensionParam+ , ExtensionDescription (..)+ , ExtensionDescriptions++ , parseExtensionDescriptions+ , encodeExtensionDescriptions+ ) where++import qualified Data.Attoparsec.ByteString as A+import qualified Data.Attoparsec.ByteString.Char8 as AC8+import qualified Data.ByteString as B+import Data.Monoid ((<>))++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 {..} =+ extName <> mconcat (map encodeParam extParams)+ where+ encodeParam (key, Nothing) = ";" <> key+ encodeParam (key, Just val) = ";" <> key <> "=" <> val++type ExtensionDescriptions = [ExtensionDescription]++parseExtensionDescriptions :: B.ByteString -> Either String ExtensionDescriptions+parseExtensionDescriptions = A.parseOnly $+ AC8.skipSpace *>+ A.sepBy parseExtensionDescription (AC8.char8 ',' <* AC8.skipSpace) <*+ A.endOfInput++encodeExtensionDescriptions :: ExtensionDescriptions -> B.ByteString+encodeExtensionDescriptions = B.intercalate "," . map encodeExtensionDescription
+ src/Network/WebSockets/Extensions/PermessageDeflate.hs view
@@ -0,0 +1,285 @@+--------------------------------------------------------------------------------+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+module Network.WebSockets.Extensions.PermessageDeflate+ ( defaultPermessageDeflate+ , PermessageDeflate(..)+ , negotiateDeflate+ ) where+++--------------------------------------------------------------------------------+import Control.Exception (throwIO)+import Control.Monad (foldM)+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.Monoid+import qualified Data.Streaming.Zlib as Zlib+import Network.WebSockets.Extensions+import Network.WebSockets.Extensions.Description+import Network.WebSockets.Http+import Network.WebSockets.Types+import Text.Read (readMaybe)++--------------------------------------------------------------------------------+-- | 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+++--------------------------------------------------------------------------------+-- | 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 :: Maybe PermessageDeflate -> NegotiateExtension+negotiateDeflate pmd0 exts0 = do+ (headers, pmd1) <- negotiateDeflateOpts exts0 pmd0+ return Extension+ { extHeaders = headers+ , extParse = \parseRaw -> do+ inflate <- makeMessageInflater 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+ bl <- Zlib.feedDeflate ptr c >>= dePopper+ (bl <>) <$> go cs+++--------------------------------------------------------------------------------+dePopper :: Zlib.Popper -> IO BL.ByteString+dePopper p = p >>= \case+ Zlib.PRDone -> return BL.empty+ Zlib.PRNext c -> BL.chunk c <$> dePopper p+ Zlib.PRError x -> throwIO $ CloseRequest 1002 (BL8.pack (show x))+++--------------------------------------------------------------------------------+makeMessageInflater :: Maybe PermessageDeflate -> IO (Message -> IO Message)+makeMessageInflater Nothing = return rejectExtensions+makeMessageInflater (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 . BL.toChunks . (<> appTailL)+ where+ go [] = BL.fromStrict <$> Zlib.flushInflate ptr+ go (c : cs) = do+ bl <- Zlib.feedInflate ptr c >>= dePopper+ (bl <>) <$> go cs
+ src/Network/WebSockets/Extensions/StrictUnicode.hs view
@@ -0,0 +1,40 @@+--------------------------------------------------------------------------------+module Network.WebSockets.Extensions.StrictUnicode+ ( strictUnicode+ ) where+++--------------------------------------------------------------------------------+import Control.Exception (throwIO)+import qualified Data.ByteString.Lazy as BL+import Network.WebSockets.Extensions+import Network.WebSockets.Types+++--------------------------------------------------------------------------------+strictUnicode :: Extension+strictUnicode = Extension+ { extHeaders = []+ , extParse = \parseRaw -> return (parseRaw >>= strictParse)+ , extWrite = return+ }+++--------------------------------------------------------------------------------+strictParse :: Maybe Message -> IO (Maybe Message)+strictParse Nothing = return Nothing+strictParse (Just (DataMessage rsv1 rsv2 rsv3 (Text bl _))) =+ case decodeUtf8Strict bl of+ Left err -> throwIO err+ Right txt ->+ return (Just (DataMessage rsv1 rsv2 rsv3 (Text bl (Just txt))))+strictParse (Just msg@(ControlMessage (Close _ bl))) =+ -- If there is a body, the first two bytes of the body MUST be a 2-byte+ -- unsigned integer (in network byte order) representing a status code with+ -- value /code/ defined in Section 7.4. Following the 2-byte integer, the+ -- body MAY contain UTF-8-encoded data with value /reason/, the+ -- interpretation of which is not defined by this specification.+ case decodeUtf8Strict (BL.drop 2 bl) of+ Left err -> throwIO err+ Right _ -> return (Just msg)+strictParse (Just msg) = return (Just msg)
src/Network/WebSockets/Http.hs view
@@ -26,24 +26,26 @@ , getResponseHeader , getRequestSecWebSocketVersion , getRequestSubprotocols+ , getRequestSecWebSocketExtensions ) where ---------------------------------------------------------------------------------import qualified Blaze.ByteString.Builder as Builder-import qualified Blaze.ByteString.Builder.Char.Utf8 as Builder-import Control.Applicative (pure, (*>), (<$>), (<*),- (<*>))-import Control.Exception (Exception, throw)-import qualified Data.Attoparsec.ByteString as A-import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import Data.ByteString.Char8 ()-import qualified Data.ByteString.Char8 as BC-import Data.ByteString.Internal (c2w)-import qualified Data.CaseInsensitive as CI-import Data.Dynamic (Typeable)-import Data.Monoid (mappend, mconcat)+import qualified Blaze.ByteString.Builder as Builder+import qualified Blaze.ByteString.Builder.Char.Utf8 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 --------------------------------------------------------------------------------@@ -204,20 +206,20 @@ -------------------------------------------------------------------------------- getRequestHeader :: RequestHead -> CI.CI ByteString- -> ByteString+ -> Either HandshakeException ByteString getRequestHeader rq key = case lookup key (requestHeaders rq) of- Just t -> t- Nothing -> throw $ MalformedRequest rq $+ Just t -> Right t+ Nothing -> Left $ MalformedRequest rq $ "Header missing: " ++ BC.unpack (CI.original key) -------------------------------------------------------------------------------- getResponseHeader :: ResponseHead -> CI.CI ByteString- -> ByteString+ -> Either HandshakeException ByteString getResponseHeader rsp key = case lookup key (responseHeaders rsp) of- Just t -> t- Nothing -> throw $ MalformedResponse rsp $+ Just t -> Right t+ Nothing -> Left $ MalformedResponse rsp $ "Header missing: " ++ BC.unpack (CI.original key) @@ -237,6 +239,19 @@ where mproto = lookup "Sec-WebSocket-Protocol" $ requestHeaders rh parse = filter (not . B.null) . BC.splitWith (\o -> o == ',' || o == ' ')+++--------------------------------------------------------------------------------+-- | Get the @Sec-WebSocket-Extensions@ header+getRequestSecWebSocketExtensions+ :: RequestHead -> Either HandshakeException Extensions.ExtensionDescriptions+getRequestSecWebSocketExtensions rq =+ case lookup "Sec-WebSocket-Extensions" (requestHeaders rq) of+ Nothing -> Right []+ Just ext -> case Extensions.parseExtensionDescriptions ext of+ Right x -> Right x+ Left err -> Left $ MalformedRequest rq $+ "Malformed Sec-WebSockets-Extensions: " ++ err --------------------------------------------------------------------------------
src/Network/WebSockets/Hybi13.hs view
@@ -17,8 +17,8 @@ -------------------------------------------------------------------------------- import qualified Blaze.ByteString.Builder as B import Control.Applicative (pure, (<$>))-import Control.Exception (throw)-import Control.Monad (liftM, forM)+import Control.Exception (throwIO)+import Control.Monad (forM, liftM, when) import qualified Data.Attoparsec.ByteString as A import Data.Binary.Get (getWord16be, getWord64be, runGet)@@ -55,37 +55,37 @@ -------------------------------------------------------------------------------- finishRequest :: RequestHead -> Headers- -> Response-finishRequest reqHttp headers =- let !key = getRequestHeader reqHttp "Sec-WebSocket-Key"- !hash = hashKey key+ -> Either HandshakeException Response+finishRequest reqHttp headers = do+ !key <- getRequestHeader reqHttp "Sec-WebSocket-Key"+ let !hash = hashKey key !encoded = B64.encode hash- in response101 (("Sec-WebSocket-Accept", encoded):headers) ""+ return $ response101 (("Sec-WebSocket-Accept", encoded):headers) "" -------------------------------------------------------------------------------- finishResponse :: RequestHead -> ResponseHead- -> Response-finishResponse request response+ -> Either HandshakeException Response+finishResponse request response = do -- Response message should be one of -- -- - WebSocket Protocol Handshake -- - Switching Protocols -- -- But we don't check it for now- | responseCode response /= 101 = throw $ MalformedResponse response- "Wrong response status or message."- | responseHash /= challengeHash = throw $ MalformedResponse response- "Challenge and response hashes do not match."- | otherwise =- Response response ""- where- key = getRequestHeader request "Sec-WebSocket-Key"- responseHash = getResponseHeader response "Sec-WebSocket-Accept"- challengeHash = B64.encode $ hashKey key+ when (responseCode response /= 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)@@ -97,10 +97,10 @@ builder = encodeFrame mask $ case msg of (ControlMessage (Close code pl)) -> mkFrame CloseFrame $ runPut (putWord16be code) `mappend` pl- (ControlMessage (Ping pl)) -> mkFrame PingFrame pl- (ControlMessage (Pong pl)) -> mkFrame PongFrame pl- (DataMessage (Text pl)) -> mkFrame TextFrame pl- (DataMessage (Binary pl)) -> mkFrame BinaryFrame pl+ (ControlMessage (Ping pl)) -> mkFrame PingFrame pl+ (ControlMessage (Pong pl)) -> mkFrame PongFrame pl+ (DataMessage rsv1 rsv2 rsv3 (Text pl _)) -> Frame True rsv1 rsv2 rsv3 TextFrame pl+ (DataMessage rsv1 rsv2 rsv3 (Binary pl)) -> Frame True rsv1 rsv2 rsv3 BinaryFrame pl --------------------------------------------------------------------------------@@ -159,11 +159,12 @@ case mbFrame of Nothing -> return Nothing Just frame -> do- mbMsg <- atomicModifyIORef dmRef $+ demultiplexResult <- atomicModifyIORef' dmRef $ \s -> swap $ demultiplex s frame- case mbMsg of- Nothing -> go dmRef- Just msg -> return (Just msg)+ case demultiplexResult of+ DemultiplexError err -> throwIO err+ DemultiplexContinue -> go dmRef+ DemultiplexSuccess msg -> return (Just msg) --------------------------------------------------------------------------------
src/Network/WebSockets/Hybi13/Demultiplex.hs view
@@ -1,11 +1,13 @@ -------------------------------------------------------------------------------- -- | Demultiplexing of frames into messages-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-} module Network.WebSockets.Hybi13.Demultiplex ( FrameType (..) , Frame (..) , DemultiplexState , emptyDemultiplexState+ , DemultiplexResult (..) , demultiplex ) where @@ -13,8 +15,8 @@ -------------------------------------------------------------------------------- import Blaze.ByteString.Builder (Builder) import qualified Blaze.ByteString.Builder as B-import Control.Exception (Exception, throw)-import Data.Binary.Get (runGet, getWord16be)+import Control.Exception (Exception)+import Data.Binary.Get (getWord16be, runGet) import qualified Data.ByteString.Lazy as BL import Data.Monoid (mappend) import Data.Typeable (Typeable)@@ -62,7 +64,7 @@ -- | Internal state used by the demultiplexer data DemultiplexState = EmptyDemultiplexState- | DemultiplexState !FrameType !Builder+ | DemultiplexState !Builder !(Builder -> Message) --------------------------------------------------------------------------------@@ -71,40 +73,30 @@ --------------------------------------------------------------------------------+-- | Result of demultiplexing+data DemultiplexResult+ = DemultiplexSuccess Message+ | DemultiplexError ConnectionException+ | DemultiplexContinue+++-------------------------------------------------------------------------------- demultiplex :: DemultiplexState -> Frame- -> (Maybe Message, DemultiplexState)-demultiplex state (Frame fin _ _ _ tp pl) = case tp of- -- Return control messages immediately, they have no influence on the state- CloseFrame -> (Just (ControlMessage (uncurry Close parsedClose)), state)- PingFrame -> (Just (ControlMessage (Ping pl)), state)- PongFrame -> (Just (ControlMessage (Pong pl)), state)- -- If we're dealing with a continuation...- ContinuationFrame -> case state of- -- We received a continuation but we don't have any state. Let's ignore- -- this fragment...- EmptyDemultiplexState -> (Nothing, EmptyDemultiplexState)- -- Append the payload to the state- -- TODO: protect against overflows- DemultiplexState amt b- | not fin -> (Nothing, DemultiplexState amt b')- | otherwise -> case amt of- TextFrame -> (Just (DataMessage (Text m)), e)- BinaryFrame -> (Just (DataMessage (Binary m)), e)- _ -> throw DemultiplexException- where- b' = b `mappend` plb- m = B.toLazyByteString b'- TextFrame- | fin -> (Just (DataMessage (Text pl)), e)- | otherwise -> (Nothing, DemultiplexState TextFrame plb)- BinaryFrame- | fin -> (Just (DataMessage (Binary pl)), e)- | otherwise -> (Nothing, DemultiplexState BinaryFrame plb)- where- e = emptyDemultiplexState- plb = B.fromLazyByteString pl+ -> (DemultiplexResult, DemultiplexState) +demultiplex state (Frame True False False False PingFrame pl)+ | BL.length pl > 125 =+ (DemultiplexError $ CloseRequest 1002 "Protocol Error", emptyDemultiplexState)+ | otherwise =+ (DemultiplexSuccess $ ControlMessage (Ping pl), state)++demultiplex state (Frame True False False False PongFrame pl) =+ (DemultiplexSuccess (ControlMessage (Pong pl)), state)++demultiplex _ (Frame True False False False CloseFrame pl) =+ (DemultiplexSuccess (ControlMessage (uncurry Close parsedClose)), emptyDemultiplexState)+ where -- The Close frame MAY contain a body (the "Application data" portion of the -- frame) that indicates a reason for closing, such as an endpoint shutting -- down, an endpoint having received a frame too large, or an endpoint@@ -113,5 +105,41 @@ -- be a 2-byte unsigned integer (in network byte order) representing a -- status code with value /code/ defined in Section 7.4. parsedClose- | BL.length pl >= 2 = (runGet getWord16be pl, BL.drop 2 pl)- | otherwise = (1000, BL.empty)+ | BL.length pl >= 2 = case runGet getWord16be pl of+ a | a < 1000 || a `elem` [1004,1005,1006+ ,1014,1015,1016+ ,1100,2000,2999+ ,5000,65535] -> (1002, BL.empty)+ a -> (a, BL.drop 2 pl)+ | BL.length pl == 1 = (1002, BL.empty)+ | otherwise = (1000, BL.empty)++demultiplex EmptyDemultiplexState (Frame fin rsv1 rsv2 rsv3 tp pl) = case tp of++ TextFrame+ | fin ->+ (DemultiplexSuccess (text pl), emptyDemultiplexState)+ | otherwise ->+ (DemultiplexContinue, DemultiplexState plb (text . B.toLazyByteString))+++ BinaryFrame+ | fin -> (DemultiplexSuccess (binary pl), emptyDemultiplexState)+ | otherwise -> (DemultiplexContinue, DemultiplexState plb (binary . B.toLazyByteString))++ _ -> (DemultiplexError $ CloseRequest 1002 "Protocol Error", emptyDemultiplexState)++ where+ plb = B.fromLazyByteString pl+ text x = DataMessage rsv1 rsv2 rsv3 (Text x Nothing)+ binary x = DataMessage rsv1 rsv2 rsv3 (Binary x)++demultiplex (DemultiplexState b f) (Frame fin False False False ContinuationFrame pl)+ | fin = (DemultiplexSuccess (f b'), emptyDemultiplexState)+ | otherwise = (DemultiplexContinue, DemultiplexState b' f)+ where+ b' = b `mappend` plb+ plb = B.fromLazyByteString pl++demultiplex _ _ =+ (DemultiplexError (CloseRequest 1002 "Protocol Error"), emptyDemultiplexState)
src/Network/WebSockets/Hybi13/Mask.hs view
@@ -2,6 +2,7 @@ -- | Masking of fragmes using a simple XOR algorithm {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# language OverloadedStrings #-} module Network.WebSockets.Hybi13.Mask ( Mask , maskPayload@@ -24,11 +25,18 @@ -------------------------------------------------------------------------------- -- | Apply mask maskPayload :: Mask -> BL.ByteString -> BL.ByteString-maskPayload Nothing = id-maskPayload (Just mask) = snd . BL.mapAccumL f (cycle $ B.unpack mask)+maskPayload Nothing = id+maskPayload (Just "\x00\x00\x00\x00") = id+maskPayload (Just mask) =+ BL.fromChunks . go (cycle (B.unpack mask)) . BL.toChunks where- f [] !c = ([], c)- f (m:ms) !c = (ms, m `xor` c)+ go _ [] = []+ go ms (chunk : chunks) =+ let (ms', chunk') = B.mapAccumL f ms chunk+ in chunk' : go ms' chunks+ f (m : ms) c = (ms, m `xor` c)+ f [] _ = error "impossible, we have infinite stream of mask bytes"+ -------------------------------------------------------------------------------- -- | Create a random mask
src/Network/WebSockets/Protocol.hs view
@@ -56,12 +56,15 @@ ---------------------------------------------------------------------------------finishRequest :: Protocol -> RequestHead -> Headers -> Response+finishRequest+ :: Protocol -> RequestHead -> Headers -> Either HandshakeException Response finishRequest Hybi13 = Hybi13.finishRequest ---------------------------------------------------------------------------------finishResponse :: Protocol -> RequestHead -> ResponseHead -> Response+finishResponse+ :: Protocol -> RequestHead -> ResponseHead+ -> Either HandshakeException Response finishResponse Hybi13 = Hybi13.finishResponse
src/Network/WebSockets/Server.hs view
@@ -59,13 +59,13 @@ runServerWith host port opts app = S.withSocketsDo $ bracket (makeListenSocket host port)- S.sClose+ S.close (\sock -> mask_ $ forever $ do allowInterrupt (conn, _) <- S.accept sock void $ forkIOWithUnmask $ \unmask ->- finally (unmask $ runApp conn opts app) (S.sClose conn)+ finally (unmask $ runApp conn opts app) (S.close conn) ) @@ -75,17 +75,20 @@ -- connections. Should only be used for a quick and dirty solution! Should be -- preceded by the call 'Network.Socket.withSocketsDo'. makeListenSocket :: String -> Int -> IO Socket-makeListenSocket host port = bracketOnError- (S.socket S.AF_INET S.Stream S.defaultProtocol)- S.sClose+makeListenSocket host port = do+ addr:_ <- S.getAddrInfo (Just hints) (Just host) (Just (show port))+ bracketOnError+ (S.socket (S.addrFamily addr) S.Stream S.defaultProtocol)+ S.close (\sock -> do _ <- S.setSocketOption sock S.ReuseAddr 1 _ <- S.setSocketOption sock S.NoDelay 1- host' <- S.inet_addr host- S.bindSocket sock (S.SockAddrInet (fromIntegral port) host')+ S.bind sock (S.addrAddress addr) S.listen sock 5 return sock )+ where+ hints = S.defaultHints { S.addrSocketType = S.Stream } --------------------------------------------------------------------------------
src/Network/WebSockets/Types.hs view
@@ -11,18 +11,24 @@ , ConnectionException (..) , ConnectionType (..)++ , decodeUtf8Lenient+ , decodeUtf8Strict ) where ---------------------------------------------------------------------------------import Control.Exception (Exception (..))-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Encoding as TL-import Data.Typeable (Typeable)-import Data.Word (Word16)+import Control.Exception (Exception (..))+import Control.Exception (throw, try)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Data.Text.Encoding.Error as TL+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL+import Data.Typeable (Typeable)+import Data.Word (Word16)+import System.IO.Unsafe (unsafePerformIO) --------------------------------------------------------------------------------@@ -33,7 +39,8 @@ -- | The kind of message a server application typically deals with data Message = ControlMessage ControlMessage- | DataMessage DataMessage+ -- | Reserved bits, actual message+ | DataMessage Bool Bool Bool DataMessage deriving (Eq, Show) @@ -51,7 +58,11 @@ -- low-level. This is why define another type on top of it, which represents -- data for the application layer. data DataMessage- = Text BL.ByteString+ -- | A textual message. The second field /might/ contain the decoded UTF-8+ -- text for caching reasons. This field is computed lazily so if it's not+ -- accessed, it should have no performance impact.+ = Text BL.ByteString (Maybe TL.Text)+ -- | A binary message. | Binary BL.ByteString deriving (Eq, Show) @@ -71,30 +82,47 @@ -- * Messages can be very large. If this is the case, it might be inefficient to -- use the strict 'B.ByteString' and 'T.Text' instances. class WebSocketsData a where+ fromDataMessage :: DataMessage -> a+ fromLazyByteString :: BL.ByteString -> a toLazyByteString :: a -> BL.ByteString -------------------------------------------------------------------------------- instance WebSocketsData BL.ByteString where+ fromDataMessage (Text bl _) = bl+ fromDataMessage (Binary bl) = bl+ fromLazyByteString = id toLazyByteString = id -------------------------------------------------------------------------------- instance WebSocketsData B.ByteString where+ fromDataMessage (Text bl _) = fromLazyByteString bl+ fromDataMessage (Binary bl) = fromLazyByteString bl+ fromLazyByteString = B.concat . BL.toChunks toLazyByteString = BL.fromChunks . return -------------------------------------------------------------------------------- instance WebSocketsData TL.Text where+ fromDataMessage (Text _ (Just tl)) = tl+ fromDataMessage (Text bl Nothing) = fromLazyByteString bl+ fromDataMessage (Binary bl) = fromLazyByteString bl++ fromLazyByteString = TL.decodeUtf8 toLazyByteString = TL.encodeUtf8 -------------------------------------------------------------------------------- instance WebSocketsData T.Text where+ fromDataMessage (Text _ (Just tl)) = T.concat (TL.toChunks tl)+ fromDataMessage (Text bl Nothing) = fromLazyByteString bl+ fromDataMessage (Binary bl) = fromLazyByteString bl+ fromLazyByteString = T.concat . TL.toChunks . fromLazyByteString toLazyByteString = toLazyByteString . TL.fromChunks . return @@ -119,6 +147,10 @@ -- | 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 (Show, Typeable) @@ -129,3 +161,18 @@ -------------------------------------------------------------------------------- data ConnectionType = ServerConnection | ClientConnection deriving (Eq, Ord, Show)+++--------------------------------------------------------------------------------+-- | Replace an invalid input byte with the Unicode replacement character+-- U+FFFD.+decodeUtf8Lenient :: BL.ByteString -> TL.Text+decodeUtf8Lenient = TL.decodeUtf8With TL.lenientDecode+++--------------------------------------------------------------------------------+-- | Throw an error if there is an invalid input byte.+decodeUtf8Strict :: BL.ByteString -> Either ConnectionException TL.Text+decodeUtf8Strict bl = unsafePerformIO $ try $+ let txt = TL.decodeUtf8With (\err _ -> throw (UnicodeException err)) bl in+ TL.length txt `seq` return txt
+ tests/autobahn/server.hs view
@@ -0,0 +1,85 @@+--------------------------------------------------------------------------------+-- | 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 msg) =+ putStrLn $ "Recevied close request " ++ 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.runServerWith "0.0.0.0" 9001 options application+ where+ options = WS.defaultConnectionOptions+ { WS.connectionCompressionOptions =+ WS.PermessageDeflateCompression WS.defaultPermessageDeflate+ , WS.connectionStrictUnicode = True+ }
+ tests/haskell/Network/WebSockets/Extensions/Tests.hs view
@@ -0,0 +1,44 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+module Network.WebSockets.Extensions.Tests+ ( tests+ ) where+++--------------------------------------------------------------------------------+import Network.WebSockets.Extensions+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@?=))+++--------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Network.WebSockets.Extensions.Tests"+ [ testCase "parseExtensionDescriptions 01" $ do+ parseExtensionDescriptions "permessage-deflate" @?= Right+ [ ExtensionDescription "permessage-deflate" [] ]++ , testCase "parseExtensionDescriptions 02" $ do+ parseExtensionDescriptions "permessage-deflate; client_max_window_bits; server_max_window_bits=10" @?= Right+ [ ExtensionDescription "permessage-deflate"+ [ ("client_max_window_bits", Nothing)+ , ("server_max_window_bits", Just "10")+ ]+ ]++ , testCase "parseExtensionDescriptions 03" $ do+ parseExtensionDescriptions "permessage-deflate; client_max_window_bits=15; server_max_window_bits=10, permessage-deflate; client_max_window_bits,permessage-deflate; client_max_window_bits=15; client_max_window_bits=10" @?= Right+ [ ExtensionDescription "permessage-deflate"+ [ ("client_max_window_bits", Just "15")+ , ("server_max_window_bits", Just "10")+ ]+ , ExtensionDescription "permessage-deflate"+ [ ("client_max_window_bits", Nothing)+ ]+ , ExtensionDescription "permessage-deflate"+ [ ("client_max_window_bits", Just "15")+ , ("client_max_window_bits", Just "10")+ ]+ ]+ ]
tests/haskell/Network/WebSockets/Handshake/Tests.hs view
@@ -32,6 +32,7 @@ , 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 ] @@ -135,6 +136,7 @@ headers ! "Sec-WebSocket-Protocol" @?= "superchat" headers ! "Set-Cookie" @?= "sid=foo" + -------------------------------------------------------------------------------- testHandshakeReject :: Assertion testHandshakeReject = do@@ -142,6 +144,18 @@ 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 --------------------------------------------------------------------------------
tests/haskell/Network/WebSockets/Server/Tests.hs view
@@ -10,14 +10,15 @@ import Control.Applicative ((<$>)) import Control.Concurrent (forkIO, killThread, threadDelay)-import Control.Exception (SomeException, handle, catch)+import Control.Exception (SomeException, catch, handle) import Control.Monad (forever, replicateM, unless)-import Data.IORef (newIORef, readIORef, IORef,+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, (@=?))@@ -38,22 +39,39 @@ [ testCase "simple server/client" testSimpleServerClient , testCase "bulk server/client" testBulkServerClient , testCase "onPong" testOnPong+ , testCase "ipv6 server" testIPv6Server ] -------------------------------------------------------------------------------- testSimpleServerClient :: Assertion-testSimpleServerClient = testServerClient $ \conn -> mapM_ (sendTextData conn)+testSimpleServerClient = testServerClient "127.0.0.1" $ \conn -> mapM_ (sendTextData conn) + --------------------------------------------------------------------------------+-- | <travis-ci.org> sets the TRAVIS environment variable to "true".+skipTravis :: Assertion -> Assertion+skipTravis assertion = do+ env <- getEnvironment+ case lookup "TRAVIS" env of+ Just "true" -> return ()+ _ -> assertion++--------------------------------------------------------------------------------+-- | IPV6 is currently NOT supported on travis+testIPv6Server :: Assertion+testIPv6Server = skipTravis $+ testServerClient "::1" $ \conn -> mapM_ (sendTextData conn)++-------------------------------------------------------------------------------- testBulkServerClient :: Assertion-testBulkServerClient = testServerClient sendTextDatas+testBulkServerClient = testServerClient "127.0.0.1" sendTextDatas ---------------------------------------------------------------------------------testServerClient :: (Connection -> [BL.ByteString] -> IO ()) -> Assertion-testServerClient sendMessages = withEchoServer 42940 "Bye" $ do+testServerClient :: String -> (Connection -> [BL.ByteString] -> IO ()) -> Assertion+testServerClient host sendMessages = withEchoServer host 42940 "Bye" $ do texts <- map unArbitraryUtf8 <$> sample- texts' <- retry $ runClient "127.0.0.1" 42940 "/chat" $ client texts+ texts' <- retry $ runClient host 42940 "/chat" $ client texts texts @=? texts' where client :: [BL.ByteString] -> ClientApp [BL.ByteString]@@ -65,9 +83,10 @@ return texts' + -------------------------------------------------------------------------------- testOnPong :: Assertion-testOnPong = withEchoServer 42941 "Bye" $ do+testOnPong = withEchoServer "127.0.0.1" 42941 "Bye" $ do gotPong <- newIORef False let opts = defaultConnectionOptions { connectionOnPong = writeIORef gotPong True@@ -113,10 +132,10 @@ ---------------------------------------------------------------------------------withEchoServer :: Int -> BL.ByteString -> IO a -> IO a-withEchoServer port expectedClose action = do+withEchoServer :: String -> Int -> BL.ByteString -> IO a -> IO a+withEchoServer host port expectedClose action = do cRef <- newIORef False- serverThread <- forkIO $ retry $ runServer "0.0.0.0" port (\c -> server c `catch` handleClose cRef)+ serverThread <- forkIO $ retry $ runServer host port (\c -> server c `catch` handleClose cRef) waitSome result <- action waitSome@@ -141,6 +160,8 @@ error "Unexpected connection closed exception" handleClose _ (ParseException _) = error "Unexpected parse exception"+ handleClose _ (UnicodeException _) =+ error "Unexpected unicode exception" --------------------------------------------------------------------------------@@ -153,3 +174,4 @@ msg' @=? msg handler ConnectionClosed = error "Unexpected connection closed" handler (ParseException _) = error "Unexpected parse exception"+ handler (UnicodeException _) = error "Unexpected unicode exception"
tests/haskell/Network/WebSockets/Tests.hs view
@@ -11,7 +11,7 @@ import Control.Applicative ((<$>)) import Control.Concurrent (forkIO) import Control.Exception (try)-import Control.Monad (forM_, replicateM)+import Control.Monad (replicateM) import qualified Data.ByteString.Lazy as BL import Data.List (intersperse) import Data.Maybe (catMaybes)@@ -76,8 +76,8 @@ msgs <- filter isDataMessage <$> parseAll parse [msg | FragmentedMessage msg _ <- fragmented] @=? msgs where- isDataMessage (ControlMessage _) = False- isDataMessage (DataMessage _) = True+ isDataMessage (ControlMessage _) = False+ isDataMessage (DataMessage _ _ _ _) = True parseAll parse = do mbMsg <- try parse@@ -89,43 +89,21 @@ ---------------------------------------------------------------------------------instance Arbitrary FrameType where- arbitrary = QC.elements- [ ContinuationFrame- , TextFrame- , BinaryFrame- , CloseFrame- , PingFrame- , PongFrame- ]------------------------------------------------------------------------------------instance Arbitrary Frame where- arbitrary = do- fin <- arbitrary- rsv1 <- arbitrary- rsv2 <- arbitrary- rsv3 <- arbitrary- t <- arbitrary- payload <- case t of- TextFrame -> arbitraryUtf8- _ -> BL.pack <$> arbitrary- return $ Frame fin rsv1 rsv2 rsv3 t payload----------------------------------------------------------------------------------- instance Arbitrary Message where- arbitrary = do- payload <- BL.pack <$> arbitrary- closecode <- arbitrary- QC.elements- [ ControlMessage (Close closecode payload)- , ControlMessage (Ping payload)- , ControlMessage (Pong payload)- , DataMessage (Text payload)- , DataMessage (Binary payload)- ]+ arbitrary = QC.oneof+ [ do+ payload <- BL.take 125 . BL.pack <$> arbitrary+ return $ ControlMessage (Ping payload)+ , do+ payload <- BL.take 125 . BL.pack <$> arbitrary+ return $ ControlMessage (Pong payload)+ , do+ payload <- BL.pack <$> arbitrary+ return $ DataMessage False False False (Text payload Nothing)+ , do+ payload <- BL.pack <$> arbitrary+ return $ DataMessage False False False (Binary payload)+ ] --------------------------------------------------------------------------------@@ -145,8 +123,8 @@ fragments <- arbitraryFragmentation payload let fs = makeFrames $ zip (ft : repeat ContinuationFrame) fragments msg = case ft of- TextFrame -> DataMessage (Text payload)- BinaryFrame -> DataMessage (Binary payload)+ TextFrame -> DataMessage False False False (Text payload Nothing)+ BinaryFrame -> DataMessage False False False (Binary payload) _ -> error "Arbitrary FragmentedMessage crashed" interleaved <- arbitraryInterleave genControlFrame fs@@ -160,7 +138,7 @@ genControlFrame = QC.elements [ Frame True False False False PingFrame "Herp"- , Frame True True True True PongFrame "Derp"+ , Frame True False False False PongFrame "Derp" ]
tests/haskell/TestSuite.hs view
@@ -1,18 +1,17 @@ ---------------------------------------------------------------------------------import Test.Framework (defaultMain)-----------------------------------------------------------------------------------+import qualified Network.WebSockets.Extensions.Tests import qualified Network.WebSockets.Handshake.Tests import qualified Network.WebSockets.Http.Tests import qualified Network.WebSockets.Server.Tests import qualified Network.WebSockets.Tests+import Test.Framework (defaultMain) -------------------------------------------------------------------------------- main :: IO () main = defaultMain- [ Network.WebSockets.Handshake.Tests.tests+ [ Network.WebSockets.Extensions.Tests.tests+ , Network.WebSockets.Handshake.Tests.tests , Network.WebSockets.Http.Tests.tests , Network.WebSockets.Server.Tests.tests , Network.WebSockets.Tests.tests
websockets.cabal view
@@ -1,5 +1,5 @@ Name: websockets-Version: 0.10.0.0+Version: 0.11.0.0 Synopsis: A sensible and clean way to write WebSocket-capable servers in Haskell.@@ -55,11 +55,15 @@ Exposed-modules: Network.WebSockets Network.WebSockets.Connection+ Network.WebSockets.Extensions Network.WebSockets.Stream -- Network.WebSockets.Util.PubSub TODO Other-modules: Network.WebSockets.Client+ Network.WebSockets.Extensions.Description+ Network.WebSockets.Extensions.PermessageDeflate+ Network.WebSockets.Extensions.StrictUnicode Network.WebSockets.Http Network.WebSockets.Hybi13 Network.WebSockets.Hybi13.Demultiplex@@ -80,6 +84,7 @@ network >= 2.3 && < 2.7, random >= 1.0 && < 1.2, SHA >= 1.5 && < 1.7,+ streaming-commons >= 0.1 && < 0.2, text >= 0.10 && < 1.3, entropy >= 0.2.1 && < 0.4 @@ -93,6 +98,11 @@ Network.WebSockets Network.WebSockets.Client Network.WebSockets.Connection+ Network.WebSockets.Extensions+ Network.WebSockets.Extensions.Description+ Network.WebSockets.Extensions.PermessageDeflate+ Network.WebSockets.Extensions.StrictUnicode+ Network.WebSockets.Extensions.Tests Network.WebSockets.Handshake.Tests Network.WebSockets.Http Network.WebSockets.Http.Tests@@ -125,6 +135,7 @@ network >= 2.3 && < 2.7, random >= 1.0 && < 1.2, SHA >= 1.5 && < 1.7,+ streaming-commons >= 0.1 && < 0.2, text >= 0.10 && < 1.3, entropy >= 0.2.1 && < 0.4 @@ -156,3 +167,39 @@ Source-repository head Type: git Location: https://github.com/jaspervdj/websockets+++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"++ Build-depends:+ websockets,+ -- Copied from regular dependencies...+ attoparsec >= 0.10 && < 0.14,+ base >= 4 && < 5,+ base64-bytestring >= 0.1 && < 1.1,+ binary >= 0.5 && < 0.9,+ blaze-builder >= 0.3 && < 0.5,+ bytestring >= 0.9 && < 0.11,+ case-insensitive >= 0.3 && < 1.3,+ containers >= 0.3 && < 0.6,+ network >= 2.3 && < 2.7,+ random >= 1.0 && < 1.2,+ SHA >= 1.5 && < 1.7,+ text >= 0.10 && < 1.3,+ entropy >= 0.2.1 && < 0.4++Benchmark bench-mask+ type: exitcode-stdio-1.0+ main-is: mask.hs+ hs-source-dirs: benchmarks, src+ build-depends:+ base,+ bytestring,+ criterion,+ random