websockets 0.11.1.0 → 0.11.2.0
raw patch · 14 files changed
+367/−92 lines, 14 filesdep ~HUnitdep ~basedep ~binary
Dependency ranges changed: HUnit, base, binary, bytestring, random
Files
- CHANGELOG +7/−0
- benchmarks/mask.hs +19/−11
- cbits/cbits.c +72/−0
- src/Network/WebSockets/Connection.hs +22/−6
- src/Network/WebSockets/Http.hs +1/−1
- src/Network/WebSockets/Hybi13.hs +19/−32
- src/Network/WebSockets/Hybi13/Mask.hs +59/−29
- src/Network/WebSockets/Server.hs +10/−3
- src/Network/WebSockets/Stream.hs +35/−1
- src/Network/WebSockets/Types.hs +9/−0
- tests/haskell/Network/WebSockets/Http/Tests.hs +27/−0
- tests/haskell/Network/WebSockets/Mask/Tests.hs +57/−0
- tests/haskell/TestSuite.hs +2/−0
- websockets.cabal +28/−9
CHANGELOG view
@@ -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
benchmarks/mask.hs view
@@ -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
+ cbits/cbits.c view
@@ -0,0 +1,72 @@+#include <stdint.h>+#include <string.h>+#include <limits.h>+#include <assert.h>++/* Taken from:+ *+ * <http://stackoverflow.com/questions/776508/best-practices-for-circular-shift-rotate-operations-in-c>+ */+static inline uint32_t rotr32(uint32_t n, unsigned int c) {+ const unsigned int mask = (CHAR_BIT*sizeof(n)-1);+ c &= mask; /* avoid undef behaviour with NDEBUG. 0 overhead for most types / compilers */+ return (n>>c) | (n<<( (-c)&mask ));+}++/* - `mask` is the 4-byte mask to apply to the source. It is stored in the+ * hosts' native byte ordering.+ * - `mask_offset` is the initial offset in the mask. It is specified in bytes+ * and should be between 0 and 3 (inclusive). This is necessary for when we+ * are dealing with multiple chunks.+ * - `src` is the source pointer.+ * - `len` is the size of the source (and destination) in bytes.+ * - `dst` is the destination.+ */+void _hs_mask_chunk(+ uint32_t mask, int mask_offset,+ uint8_t *src, size_t len,+ uint8_t *dst) {+ const uint8_t *src_end = src + len;++ /* We have two fast paths: one for `x86_64` and one for `i386`+ * architectures. In these fast paths, we mask 8 (or 4) bytes at a time.+ *+ * Note that we use unaligned loads and stores (allowed on these+ * architectures). This makes the code much easier to write, since we don't+ * need to guarantee that `src` and `dst` have the same alignment.+ *+ * It only causes a minor slowdown, around 5% on my machine (TM).+ */+#if defined(__x86_64__)+ uint64_t mask64;+ /* Set up 64 byte mask. */+ mask64 = (uint64_t)(rotr32(mask, 8 * mask_offset));+ mask64 |= (mask64 << 32);+ /* Take the fast road. */+ while (src < src_end - 7) {+ *(uint64_t *)dst = *(uint64_t*)src ^ mask64;+ src += 8;+ dst += 8;+ }+#elif defined(__i386__)+ /* Set up 32 byte mask. */+ uint32_t mask32;+ mask32 = (uint32_t)(rotr32(mask, 8 * mask_offset));++ /* Take the fast road. */+ while (src < src_end - 3) {+ *(uint32_t *)dst = *(uint32_t*)src ^ mask32;+ src += 4;+ dst += 4;+ }+#endif++ /* This is the slow path which also handles the un-aligned suffix. */+ uint8_t *mask_ptr = (uint8_t *) &mask;+ while (src != src_end) {+ *dst = *src ^ *(mask_ptr + mask_offset);+ src++;+ dst++;+ mask_offset = (mask_offset + 1) & 0x3;+ }+}
src/Network/WebSockets/Connection.hs view
@@ -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 ()
src/Network/WebSockets/Http.hs view
@@ -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 --------------------------------------------------------------------------------
src/Network/WebSockets/Hybi13.hs view
@@ -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
src/Network/WebSockets/Hybi13/Mask.hs view
@@ -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
src/Network/WebSockets/Server.hs view
@@ -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: -- -- * <https://hackage.haskell.org/package/wai-websockets>@@ -88,7 +95,7 @@ return sock ) where- hints = S.defaultHints { S.addrSocketType = S.Stream } + hints = S.defaultHints { S.addrSocketType = S.Stream } --------------------------------------------------------------------------------
src/Network/WebSockets/Stream.hs view
@@ -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)
src/Network/WebSockets/Types.hs view
@@ -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
tests/haskell/Network/WebSockets/Http/Tests.hs view
@@ -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"+ , ""+ , "" ]
+ tests/haskell/Network/WebSockets/Mask/Tests.hs view
@@ -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
tests/haskell/TestSuite.hs view
@@ -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 ]
websockets.cabal view
@@ -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