diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,10 @@ +- 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 diff --git a/benchmarks/mask.hs b/benchmarks/mask.hs --- a/benchmarks/mask.hs +++ b/benchmarks/mask.hs @@ -3,6 +3,7 @@ import Criterion import Criterion.Main +import qualified Data.Binary.Get as Get import Network.WebSockets.Hybi13.Mask @@ -13,9 +14,11 @@ setupEnv = do let kilo = BL.replicate 1024 37 mega = BL.replicate (1024 * 1024) 37 - return (kilo, mega) + 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' :: Mask -> BL.ByteString -> BL.ByteString +maskPayload' :: Maybe B.ByteString -> BL.ByteString -> BL.ByteString maskPayload' Nothing = id maskPayload' (Just mask) = snd . BL.mapAccumL f (cycle $ B.unpack mask) where @@ -23,42 +26,47 @@ f (m:ms) !c = (ms, m `xor` c) main = defaultMain [ - env setupEnv $ \ ~(kilo, mega) -> bgroup "main" + env setupEnv $ \ ~(kilo, mega, megaU, megaS) -> bgroup "main" [ bgroup "kilobyte payload" [ bgroup "zero_mask" - [ bench "current" $ nf (maskPayload (Just "\x00\x00\x00\x00")) kilo + [ 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 (Just "\xFF\xFF\xFF\xFF")) kilo + [ 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 (Just "\xCC\xCC\xCC\xCC")) kilo + [ 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 (Just "\xB0\xA2\xB0\xA2")) kilo + [ 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 (Just "\x00\x00\x00\x00")) mega + [ 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 (Just "\xFF\xFF\xFF\xFF")) mega + [ 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 (Just "\xCC\xCC\xCC\xCC")) mega + [ 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 (Just "\xB0\xA2\xB0\xA2")) mega + [ 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/src/Network/WebSockets/Connection.hs b/src/Network/WebSockets/Connection.hs --- a/src/Network/WebSockets/Connection.hs +++ b/src/Network/WebSockets/Connection.hs @@ -267,6 +267,11 @@ -------------------------------------------------------------------------------- +-- | The default connection options: +-- +-- * Nothing happens when a pong is received. +-- * Compression is disabled. +-- * Lenient unicode decoding. defaultConnectionOptions :: ConnectionOptions defaultConnectionOptions = ConnectionOptions { connectionOnPong = return () @@ -341,34 +346,41 @@ isCloseMessage _ = False -------------------------------------------------------------------------------- --- | Send a 'DataMessage' +-- | Send a 'DataMessage'. This allows you send both human-readable text and +-- binary data. This is a slightly more low-level interface than 'sendTextData' +-- or 'sendBinaryData'. sendDataMessage :: Connection -> DataMessage -> IO () sendDataMessage conn = sendDataMessages conn . return -------------------------------------------------------------------------------- --- | Send a collection of 'DataMessage's +-- | Send a collection of 'DataMessage's. This is more efficient than calling +-- 'sendDataMessage' many times. sendDataMessages :: Connection -> [DataMessage] -> IO () sendDataMessages conn = sendAll conn . map (DataMessage False False False) -------------------------------------------------------------------------------- --- | Send a message as text +-- | Send a textual message. The message will be encoded as UTF-8. This should +-- be the default choice for human-readable text-based protocols such as JSON. sendTextData :: WebSocketsData a => Connection -> a -> IO () sendTextData conn = sendTextDatas conn . return -------------------------------------------------------------------------------- --- | Send a collection of messages as text +-- | Send a number of textual messages. This is more efficient than calling +-- 'sendTextData' many times. sendTextDatas :: WebSocketsData a => Connection -> [a] -> IO () sendTextDatas conn = sendDataMessages conn . map (\x -> Text (toLazyByteString x) Nothing) -------------------------------------------------------------------------------- --- | Send a message as binary data +-- | Send a binary message. This is useful for sending binary blobs, e.g. +-- images, data encoded with MessagePack, images... sendBinaryData :: WebSocketsData a => Connection -> a -> IO () sendBinaryData conn = sendBinaryDatas conn . return -------------------------------------------------------------------------------- --- | Send a collection of messages as binary data +-- | 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) @@ -404,6 +416,10 @@ -------------------------------------------------------------------------------- -- | 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 | n <= 0 = return () diff --git a/src/Network/WebSockets/Http.hs b/src/Network/WebSockets/Http.hs --- a/src/Network/WebSockets/Http.hs +++ b/src/Network/WebSockets/Http.hs @@ -195,7 +195,7 @@ newline = A.string "\r\n" code = A.string "HTTP/1.1" *> space *> A.takeWhile1 (/= c2w ' ') <* space - message = A.takeWhile1 (/= c2w '\r') <* newline + message = A.takeWhile (/= c2w '\r') <* newline -------------------------------------------------------------------------------- diff --git a/src/Network/WebSockets/Hybi13.hs b/src/Network/WebSockets/Hybi13.hs --- a/src/Network/WebSockets/Hybi13.hs +++ b/src/Network/WebSockets/Hybi13.hs @@ -17,11 +17,12 @@ -------------------------------------------------------------------------------- import qualified Blaze.ByteString.Builder as B import Control.Applicative (pure, (<$>)) +import Control.Arrow (first) import Control.Exception (throwIO) import Control.Monad (forM, liftM, when) -import qualified Data.Attoparsec.ByteString as A -import Data.Binary.Get (getWord16be, - getWord64be, runGet) +import Data.Binary.Get (Get, getInt64be, + getLazyByteString, + getWord16be, getWord8) import Data.Binary.Put (putWord16be, runPut) import Data.Bits ((.&.), (.|.)) import Data.ByteString (ByteString) @@ -29,7 +30,6 @@ import Data.ByteString.Char8 () import qualified Data.ByteString.Lazy as BL import Data.Digest.Pure.SHA (bytestringDigest, sha1) -import Data.Int (Int64) import Data.IORef import Data.Monoid (mappend, mconcat, mempty) @@ -93,7 +93,7 @@ mkFrame = Frame True False False False (mask, gen') = case conType of ServerConnection -> (Nothing, gen) - ClientConnection -> randomMask gen + ClientConnection -> first Just (randomMask gen) builder = encodeFrame mask $ case msg of (ControlMessage (Close code pl)) -> mkFrame CloseFrame $ runPut (putWord16be code) `mappend` pl @@ -115,8 +115,9 @@ atomicModifyIORef genRef $ \s -> encodeMessage conType s msg Stream.write stream (B.toLazyByteString $ mconcat builders) + -------------------------------------------------------------------------------- -encodeFrame :: Mask -> Frame -> B.Builder +encodeFrame :: Maybe Mask -> Frame -> B.Builder encodeFrame mask f = B.fromWord8 byte0 `mappend` B.fromWord8 byte1 `mappend` len `mappend` maskbytes `mappend` B.fromLazyByteString (maskPayload mask (framePayload f)) @@ -136,7 +137,7 @@ (maskflag, maskbytes) = case mask of Nothing -> (0x00, mempty) - Just m -> (0x80, B.fromByteString m) + Just m -> (0x80, encodeMask m) byte1 = maskflag .|. lenflag len' = BL.length (framePayload f) @@ -155,7 +156,7 @@ return $ go dmRef where go dmRef = do - mbFrame <- Stream.parse stream parseFrame + mbFrame <- Stream.parseBin stream parseFrame case mbFrame of Nothing -> return Nothing Just frame -> do @@ -169,9 +170,9 @@ -------------------------------------------------------------------------------- -- | Parse a frame -parseFrame :: A.Parser Frame +parseFrame :: Get Frame parseFrame = do - byte0 <- A.anyWord8 + byte0 <- getWord8 let fin = byte0 .&. 0x80 == 0x80 rsv1 = byte0 .&. 0x40 == 0x40 rsv2 = byte0 .&. 0x20 == 0x20 @@ -187,34 +188,20 @@ 0x0a -> return PongFrame _ -> fail $ "Unknown opcode: " ++ show opcode - byte1 <- A.anyWord8 + byte1 <- getWord8 let mask = byte1 .&. 0x80 == 0x80 - lenflag = fromIntegral (byte1 .&. 0x7f) + lenflag = byte1 .&. 0x7f len <- case lenflag of - 126 -> fromIntegral . runGet' getWord16be <$> A.take 2 - 127 -> fromIntegral . runGet' getWord64be <$> A.take 8 - _ -> return lenflag - - masker <- maskPayload <$> if mask then Just <$> A.take 4 else pure Nothing - - chunks <- take64 len + 126 -> fromIntegral <$> getWord16be + 127 -> getInt64be + _ -> return (fromIntegral lenflag) - return $ Frame fin rsv1 rsv2 rsv3 ft (masker $ BL.fromChunks chunks) - where - runGet' g = runGet g . BL.fromChunks . return + masker <- maskPayload <$> if mask then Just <$> parseMask else pure Nothing - take64 :: Int64 -> A.Parser [ByteString] - take64 n - | n <= 0 = return [] - | otherwise = do - let n' = min intMax n - chunk <- A.take (fromIntegral n') - (chunk :) <$> take64 (n - n') - where - intMax :: Int64 - intMax = fromIntegral (maxBound :: Int) + chunks <- getLazyByteString len + return $ Frame fin rsv1 rsv2 rsv3 ft (masker chunks) -------------------------------------------------------------------------------- hashKey :: ByteString -> ByteString diff --git a/src/Network/WebSockets/Hybi13/Mask.hs b/src/Network/WebSockets/Hybi13/Mask.hs --- a/src/Network/WebSockets/Hybi13/Mask.hs +++ b/src/Network/WebSockets/Hybi13/Mask.hs @@ -1,50 +1,80 @@ -------------------------------------------------------------------------------- -- | Masking of fragmes using a simple XOR algorithm -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# language OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Network.WebSockets.Hybi13.Mask ( Mask - , maskPayload + , parseMask + , encodeMask , randomMask + + , maskPayload ) where -------------------------------------------------------------------------------- -import Data.Bits (shiftR, xor) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import System.Random (RandomGen, random) +import qualified Blaze.ByteString.Builder as Builder +import Data.Binary.Get (Get, getWord32host) +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Internal as BL +import Data.Word (Word32, Word8) +import Foreign.C.Types (CChar (..), CInt (..), + CSize (..)) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Ptr (Ptr, plusPtr) +import System.Random (RandomGen, random) -------------------------------------------------------------------------------- --- | ByteString should be exactly 4 bytes long -type Mask = Maybe B.ByteString +foreign import ccall unsafe "_hs_mask_chunk" c_mask_chunk + :: Word32 -> CInt -> Ptr CChar -> CSize -> Ptr Word8 -> IO () -------------------------------------------------------------------------------- --- | Apply mask -maskPayload :: Mask -> BL.ByteString -> BL.ByteString -maskPayload Nothing = id -maskPayload (Just "\x00\x00\x00\x00") = id -maskPayload (Just mask) = - BL.fromChunks . go (cycle (B.unpack mask)) . BL.toChunks - where - 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" +-- | 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.fromStorable . unMask + + +-------------------------------------------------------------------------------- -- | Create a random mask randomMask :: forall g. RandomGen g => g -> (Mask, g) -randomMask gen = (Just (B.pack [b1, b2, b3, b4]), gen') +randomMask gen = (Mask int, gen') where - (!int, !gen') = random gen :: (Int, g) - !b1 = fromIntegral $ int `mod` 0x100 - !b2 = fromIntegral $ int `shiftR` 8 `mod` 0x100 - !b3 = fromIntegral $ int `shiftR` 16 `mod` 0x100 - !b4 = fromIntegral $ int `shiftR` 24 `mod` 0x100 + (!int, !gen') = random gen :: (Word32, g) + + +-------------------------------------------------------------------------------- +-- | Mask a lazy bytestring. Uses 'c_mask_chunk' under the hood. +maskPayload :: Maybe Mask -> BL.ByteString -> BL.ByteString +maskPayload Nothing = id +maskPayload (Just (Mask 0)) = id +maskPayload (Just (Mask mask)) = go 0 + where + go _ BL.Empty = BL.Empty + go !maskOffset (BL.Chunk (B.PS payload off len) rest) = + BL.Chunk maskedChunk (go ((maskOffset + len) `rem` 4) rest) + where + maskedChunk = + B.unsafeCreate len $ \dst -> + withForeignPtr payload $ \src -> + c_mask_chunk mask + (fromIntegral maskOffset) + (src `plusPtr` off) + (fromIntegral len) + dst diff --git a/src/Network/WebSockets/Server.hs b/src/Network/WebSockets/Server.hs --- a/src/Network/WebSockets/Server.hs +++ b/src/Network/WebSockets/Server.hs @@ -37,10 +37,17 @@ -------------------------------------------------------------------------------- --- | Provides a simple server. This function blocks forever. Note that this --- is merely provided for quick-and-dirty standalone applications, for real +-- | Provides a simple server. This function blocks forever. Note that this +-- is merely provided for quick-and-dirty or internal applications, but for real -- applications, you should use a real server. -- +-- For example: +-- +-- * Performance is reasonable under load, but: +-- * No protection against DoS attacks is provided. +-- * No logging is performed. +-- * ... +-- -- Glue for using this package with real servers is provided by: -- -- * @@ -88,7 +95,7 @@ return sock ) where - hints = S.defaultHints { S.addrSocketType = S.Stream } + hints = S.defaultHints { S.addrSocketType = S.Stream } -------------------------------------------------------------------------------- diff --git a/src/Network/WebSockets/Stream.hs b/src/Network/WebSockets/Stream.hs --- a/src/Network/WebSockets/Stream.hs +++ b/src/Network/WebSockets/Stream.hs @@ -7,10 +7,12 @@ , makeSocketStream , makeEchoStream , parse + , parseBin , write , close ) where +import qualified Data.Binary.Get as BIN import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar, withMVar) import Control.Exception (onException, throwIO) @@ -102,7 +104,7 @@ makeSocketStream socket = makeStream receive send where receive = do - bs <- SB.recv socket 1024 + bs <- SB.recv socket 8192 return $ if B.null bs then Nothing else Just bs send Nothing = return () @@ -124,6 +126,38 @@ -------------------------------------------------------------------------------- +parseBin :: Stream -> BIN.Get a -> IO (Maybe a) +parseBin stream parser = do + state <- readIORef (streamState stream) + case state of + Closed remainder + | B.null remainder -> return Nothing + | otherwise -> go (BIN.runGetIncremental parser `BIN.pushChunk` remainder) True + Open buffer + | B.null buffer -> do + mbBs <- streamIn stream + case mbBs of + Nothing -> do + writeIORef (streamState stream) (Closed B.empty) + return Nothing + Just bs -> go (BIN.runGetIncremental parser `BIN.pushChunk` bs) False + | otherwise -> go (BIN.runGetIncremental parser `BIN.pushChunk` buffer) False + where + -- Buffer is empty when entering this function. + go (BIN.Done remainder _ x) closed = do + writeIORef (streamState stream) $ + if closed then Closed remainder else Open remainder + return (Just x) + go (BIN.Partial f) closed + | closed = go (f Nothing) True + | otherwise = do + mbBs <- streamIn stream + case mbBs of + Nothing -> go (f Nothing) True + Just bs -> go (f (Just bs)) False + go (BIN.Fail _ _ err) _ = throwIO (ParseException err) + + parse :: Stream -> Atto.Parser a -> IO (Maybe a) parse stream parser = do state <- readIORef (streamState stream) diff --git a/src/Network/WebSockets/Types.hs b/src/Network/WebSockets/Types.hs --- a/src/Network/WebSockets/Types.hs +++ b/src/Network/WebSockets/Types.hs @@ -57,6 +57,15 @@ -- | For an end-user of this library, dealing with 'Frame's would be a bit -- low-level. This is why define another type on top of it, which represents -- data for the application layer. +-- +-- There are currently two kinds of data messages supported by the WebSockets +-- protocol: +-- +-- * Textual UTF-8 encoded data. This corresponds roughly to sending a String +-- in JavaScript. +-- +-- * Binary data. This corresponds roughly to send an ArrayBuffer in +-- JavaScript. data DataMessage -- | A textual message. The second field /might/ contain the decoded UTF-8 -- text for caching reasons. This field is computed lazily so if it's not diff --git a/tests/haskell/Network/WebSockets/Http/Tests.hs b/tests/haskell/Network/WebSockets/Http/Tests.hs --- a/tests/haskell/Network/WebSockets/Http/Tests.hs +++ b/tests/haskell/Network/WebSockets/Http/Tests.hs @@ -22,6 +22,7 @@ tests = testGroup "Network.WebSockets.Http.Tests" [ testCase "jwebsockets response" jWebSocketsResponse , testCase "chromium response" chromiumResponse + , testCase "matchbook response" matchbookResponse ] @@ -58,4 +59,30 @@ , "Content-Length:23" , "" , "No such target id: 20_1" + ] + +-------------------------------------------------------------------------------- +-- | This is a specific response sent by Matchbook.com which caused trouble + +matchbookResponse :: Assertion +matchbookResponse = assert $ case A.parseOnly decodeResponseHead input of + Left err -> error err + Right _ -> True + where + input = BC.intercalate "\r\n" + [ "HTTP/1.1 101 " + , "Date: Mon, 22 May 2017 19:39:08 GMT" + , "Connection: upgrade" + , "Set-Cookie: __cfduid=deadbeefdeadbeefdeadbeefdeadbeefdeadbeefdea; expires=Tue, 22-May-18 19:39:08 GMT; path=/; domain=.matchbook.com; HttpOnly" + , "X-Content-Type-Options: nosniff" + , "X-XSS-Protection: 1; mode=block" + , "X-Frame-Options: DENY" + , "Upgrade: websocket" + , "Sec-WebSocket-Accept: dEadB33fDeadbEEfD3aDbE3Fdea=" + , "X-MB-HA: edge-socket" + , "X-MB-HAP: haproxy01aws" + , "Server: cloudflare-nginx" + , "CF-RAY: 3632deadbeef5b33-HEL" + , "" + , "" ] diff --git a/tests/haskell/Network/WebSockets/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/TestSuite.hs b/tests/haskell/TestSuite.hs --- a/tests/haskell/TestSuite.hs +++ b/tests/haskell/TestSuite.hs @@ -2,6 +2,7 @@ import qualified Network.WebSockets.Extensions.Tests import qualified Network.WebSockets.Handshake.Tests import qualified Network.WebSockets.Http.Tests +import qualified Network.WebSockets.Mask.Tests import qualified Network.WebSockets.Server.Tests import qualified Network.WebSockets.Tests import Test.Framework (defaultMain) @@ -14,5 +15,6 @@ , Network.WebSockets.Handshake.Tests.tests , Network.WebSockets.Http.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.11.1.0 +Version: 0.11.2.0 Synopsis: A sensible and clean way to write WebSocket-capable servers in Haskell. @@ -51,6 +51,7 @@ Library Hs-source-dirs: src Ghc-options: -Wall + C-sources: cbits/cbits.c Exposed-modules: Network.WebSockets @@ -93,6 +94,7 @@ Hs-source-dirs: src tests/haskell Main-is: TestSuite.hs Ghc-options: -Wall + C-sources: cbits/cbits.c Other-modules: Network.WebSockets @@ -109,6 +111,7 @@ Network.WebSockets.Hybi13 Network.WebSockets.Hybi13.Demultiplex Network.WebSockets.Hybi13.Mask + Network.WebSockets.Mask.Tests Network.WebSockets.Protocol Network.WebSockets.Server Network.WebSockets.Server.Tests @@ -118,7 +121,7 @@ Network.WebSockets.Types Build-depends: - HUnit >= 1.2 && < 1.6, + HUnit >= 1.2 && < 1.7, QuickCheck >= 2.7 && < 2.10, test-framework >= 0.4 && < 0.9, test-framework-hunit >= 0.2 && < 0.4, @@ -195,11 +198,27 @@ 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, + Type: exitcode-stdio-1.0 + Main-is: mask.hs + C-sources: cbits/cbits.c + Hs-source-dirs: benchmarks, src + + Other-modules: + Network.WebSockets.Hybi13.Mask + + Build-depends: criterion, - random + -- 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