websockets 0.9.8.0 → 0.9.8.1

raw patch · 11 files changed

+42/−107 lines, 11 filesdep ~HUnitdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: HUnit, base

API changes (from Hackage documentation)

Files

• CHANGELOG +6/−4
• src/Network/WebSockets.hs +0/−1
• src/Network/WebSockets/Client.hs +1/−4
• src/Network/WebSockets/Connection.hs +13/−35
• src/Network/WebSockets/Hybi13.hs +7/−7
• src/Network/WebSockets/Hybi13/Mask.hs +7/−3
• src/Network/WebSockets/Protocol.hs +1/−1
• tests/haskell/Network/WebSockets/Handshake/Tests.hs +1/−37
• tests/haskell/Network/WebSockets/Server/Tests.hs +3/−12
• tests/haskell/Network/WebSockets/Tests.hs +1/−1
• websockets.cabal +2/−2

@@ -1,8 +1,10 @@+- 0.9.8.1+    * Restore state of the package to version `0.9.7.0`+ - 0.9.8.0-    * Fix client specifying empty path-    * Allow sending collections of messages (by David Turner)-    * Allow sending extra headers when accepting request (by James Deery)-    * Bump `HUnit` dependency to 1.5+    * This release contained a feature which broke backwards-compatibility.+      Hence, it was marked as broken a new release containing the changes will+      be uploaded as `0.10.0.0`.  - 0.9.7.0     * Fix issue trying to kill builtin server

@@ -23,7 +23,6 @@     , send     , sendDataMessage     , sendTextData-    , sendTextDatas     , sendBinaryData     , sendClose     , sendPing

@@ -53,14 +53,11 @@               -> Headers            -- ^ Custom headers to send               -> ClientApp a        -- ^ Client application               -> IO a-runClientWith host port path0 opts customHeaders app = do+runClientWith host port path opts customHeaders app = do     -- Create and connect socket     let hints = S.defaultHints                     {S.addrFamily = S.AF_INET, 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     S.setSocketOption sock S.NoDelay 1

@@ -19,11 +19,8 @@     , receiveData     , send     , sendDataMessage-    , sendDataMessages     , sendTextData-    , sendTextDatas     , sendBinaryData-    , sendBinaryDatas     , sendClose     , sendCloseCode     , sendPing@@ -37,7 +34,7 @@ import           Control.Concurrent          (forkIO, threadDelay) import           Control.Exception           (AsyncException, fromException,                                               handle, throwIO)-import           Control.Monad               (unless, when)+import           Control.Monad               (unless) import qualified Data.ByteString             as B import           Data.IORef                  (IORef, newIORef, readIORef,                                               writeIORef)@@ -76,8 +73,6 @@     -- ^ The subprotocol to speak with the client.  If 'pendingSubprotcols' is     -- non-empty, 'acceptSubprotocol' must be one of the subprotocols from the     -- list.-    , acceptHeaders :: !Headers-    -- ^ Extra headers to send with the response.     }  @@ -90,7 +85,7 @@  -------------------------------------------------------------------------------- acceptRequest :: PendingConnection -> IO Connection-acceptRequest pc = acceptRequestWith pc $ AcceptRequest Nothing []+acceptRequest pc = acceptRequestWith pc $ AcceptRequest Nothing   --------------------------------------------------------------------------------@@ -101,8 +96,7 @@         throwIO NotSupported     Just protocol -> do         let subproto = maybe [] (\p -> [("Sec-WebSocket-Protocol", p)]) $ acceptSubprotocol ar-            headers = subproto ++ acceptHeaders ar-            response = finishRequest protocol request headers+            response = finishRequest protocol request subproto         sendResponse pc response         parse <- decodeMessages protocol (pendingStream pc)         write <- encodeMessages protocol ServerConnection (pendingStream pc)@@ -136,7 +130,7 @@     , connectionType      :: !ConnectionType     , connectionProtocol  :: !Protocol     , connectionParse     :: !(IO (Maybe Message))-    , connectionWrite     :: !([Message] -> IO ())+    , connectionWrite     :: !(Message -> IO ())     , connectionSentClose :: !(IORef Bool)     -- ^ According to the RFC, both the client and the server MUST send     -- a close control message to each other.  Either party can initiate@@ -212,47 +206,31 @@  -------------------------------------------------------------------------------- send :: Connection -> Message -> IO ()-send conn = sendAll conn . return+send conn msg = do+    case msg of+        (ControlMessage (Close _ _)) ->+            writeIORef (connectionSentClose conn) True+        _ -> return ()+    connectionWrite conn msg ----------------------------------------------------------------------------------sendAll :: Connection -> [Message] -> IO ()-sendAll conn msgs = do-    when (any isCloseMessage msgs) $-      writeIORef (connectionSentClose conn) True-    connectionWrite conn msgs-  where-    isCloseMessage (ControlMessage (Close _ _)) = True-    isCloseMessage _                            = False  -------------------------------------------------------------------------------- -- | Send a 'DataMessage' sendDataMessage :: Connection -> DataMessage -> IO ()-sendDataMessage conn = sendDataMessages conn . return+sendDataMessage conn = send conn . DataMessage ------------------------------------------------------------------------------------ | Send a collection of 'DataMessage's-sendDataMessages :: Connection -> [DataMessage] -> IO ()-sendDataMessages conn = sendAll conn . map DataMessage  -------------------------------------------------------------------------------- -- | Send a message as text sendTextData :: WebSocketsData a => Connection -> a -> IO ()-sendTextData conn = sendTextDatas conn . return+sendTextData conn = sendDataMessage conn . Text . toLazyByteString ------------------------------------------------------------------------------------ | Send a collection of messages as text-sendTextDatas :: WebSocketsData a => Connection -> [a] -> IO ()-sendTextDatas conn = sendDataMessages conn . map (Text . toLazyByteString)  -------------------------------------------------------------------------------- -- | Send a message as binary data sendBinaryData :: WebSocketsData a => Connection -> a -> IO ()-sendBinaryData conn = sendBinaryDatas conn . return+sendBinaryData conn = sendDataMessage conn . Binary . toLazyByteString ------------------------------------------------------------------------------------ | Send a collection of messages as binary data-sendBinaryDatas :: WebSocketsData a => Connection -> [a] -> IO ()-sendBinaryDatas conn = sendDataMessages conn . map (Binary . toLazyByteString)  -------------------------------------------------------------------------------- -- | Send a friendly close message.  Note that after sending this message,

@@ -18,7 +18,7 @@ import qualified Blaze.ByteString.Builder              as B import           Control.Applicative                   (pure, (<$>)) import           Control.Exception                     (throw)-import           Control.Monad                         (liftM, forM)+import           Control.Monad                         (liftM) import qualified Data.Attoparsec.ByteString            as A import           Data.Binary.Get                       (getWord16be,                                                         getWord64be, runGet)@@ -88,7 +88,7 @@  -------------------------------------------------------------------------------- encodeMessage :: RandomGen g => ConnectionType -> g -> Message -> (g, B.Builder)-encodeMessage conType gen msg = (gen', builder)+encodeMessage conType gen msg = (gen', builder `mappend` B.flush)   where     mkFrame      = Frame True False False False     (mask, gen') = case conType of@@ -107,13 +107,13 @@ encodeMessages     :: ConnectionType     -> Stream-    -> IO ([Message] -> IO ())+    -> IO (Message -> IO ()) encodeMessages conType stream = do     genRef <- newIORef =<< newStdGen-    return $ \msgs -> do-        builders <- forM msgs $ \msg ->-          atomicModifyIORef genRef $ \s -> encodeMessage conType s msg-        Stream.write stream (B.toLazyByteString $ mconcat builders)+    return $ \msg -> do+        builder <- atomicModifyIORef genRef $ \s -> encodeMessage conType s msg+        Stream.write stream (B.toLazyByteString builder)+  -------------------------------------------------------------------------------- encodeFrame :: Mask -> Frame -> B.Builder

@@ -25,10 +25,14 @@ -- | Apply mask maskPayload :: Mask -> BL.ByteString -> BL.ByteString maskPayload Nothing     = id-maskPayload (Just mask) = snd . BL.mapAccumL f (cycle $ B.unpack mask)+maskPayload (Just mask) = snd . BL.mapAccumL f 0   where-    f []     !c = ([], c)-    f (m:ms) !c = (ms, m `xor` c)+    len     = B.length mask+    f !i !c =+        let i' = (i + 1) `mod` len+            m  = mask `B.index` i+        in (i', m `xor` c)+  -------------------------------------------------------------------------------- -- | Create a random mask

@@ -68,7 +68,7 @@ -------------------------------------------------------------------------------- encodeMessages     :: Protocol -> ConnectionType -> Stream-    -> IO ([Message] -> IO ())+    -> IO (Message -> IO ()) encodeMessages Hybi13 = Hybi13.encodeMessages  

@@ -29,8 +29,6 @@ tests = testGroup "Network.WebSockets.Handshake.Test"     [ testCase "handshake Hybi13"                   testHandshakeHybi13     , testCase "handshake Hybi13 with subprotocols" testHandshakeHybi13WithProto-    , testCase "handshake Hybi13 with headers"      testHandshakeHybi13WithHeaders-    , testCase "handshake Hybi13 with subprotocols and headers" testHandshakeHybi13WithProtoAndHeaders     , testCase "handshake reject"                   testHandshakeReject     , testCase "handshake Hybi9000"                 testHandshakeHybi9000     ]@@ -92,40 +90,7 @@     ResponseHead code message headers <- testHandshake rq13 $ \pc -> do         getRequestSubprotocols (pendingRequest pc) @?= ["chat", "superchat"]         acceptRequestWith pc {pendingOnAccept = \_ -> writeIORef onAcceptFired True}-                          (AcceptRequest (Just "superchat") [])--    readIORef onAcceptFired >>= assert-    code @?= 101-    message @?= "WebSocket Protocol Handshake"-    headers ! "Sec-WebSocket-Accept" @?= "HSmrc0sMlYUkAGmm5OPpG2HaGWk="-    headers ! "Connection"           @?= "Upgrade"-    headers ! "Sec-WebSocket-Protocol" @?= "superchat"-----------------------------------------------------------------------------------testHandshakeHybi13WithHeaders :: Assertion-testHandshakeHybi13WithHeaders = do-    onAcceptFired                     <- newIORef False-    ResponseHead code message headers <- testHandshake rq13 $ \pc -> do-        getRequestSubprotocols (pendingRequest pc) @?= ["chat", "superchat"]-        acceptRequestWith pc {pendingOnAccept = \_ -> writeIORef onAcceptFired True}-                          (AcceptRequest Nothing [("Set-Cookie","sid=foo")])--    readIORef onAcceptFired >>= assert-    code @?= 101-    message @?= "WebSocket Protocol Handshake"-    headers ! "Sec-WebSocket-Accept" @?= "HSmrc0sMlYUkAGmm5OPpG2HaGWk="-    headers ! "Connection"           @?= "Upgrade"-    headers ! "Set-Cookie"           @?= "sid=foo"-    lookup "Sec-WebSocket-Protocol" headers @?= Nothing-----------------------------------------------------------------------------------testHandshakeHybi13WithProtoAndHeaders :: Assertion-testHandshakeHybi13WithProtoAndHeaders = do-    onAcceptFired                     <- newIORef False-    ResponseHead code message headers <- testHandshake rq13 $ \pc -> do-        getRequestSubprotocols (pendingRequest pc) @?= ["chat", "superchat"]-        acceptRequestWith pc {pendingOnAccept = \_ -> writeIORef onAcceptFired True}-                          (AcceptRequest (Just "superchat") [("Set-Cookie","sid=foo")])+                          (AcceptRequest $ Just "superchat")      readIORef onAcceptFired >>= assert     code @?= 101@@ -133,7 +98,6 @@     headers ! "Sec-WebSocket-Accept" @?= "HSmrc0sMlYUkAGmm5OPpG2HaGWk="     headers ! "Connection"           @?= "Upgrade"     headers ! "Sec-WebSocket-Protocol" @?= "superchat"-    headers ! "Set-Cookie"           @?= "sid=foo"  -------------------------------------------------------------------------------- testHandshakeReject :: Assertion

@@ -11,7 +11,7 @@ import           Control.Concurrent             (forkIO, killThread,                                                  threadDelay) import           Control.Exception              (SomeException, handle, catch)-import           Control.Monad                  (forever, replicateM, unless)+import           Control.Monad                  (forM_, forever, replicateM, unless) import           Data.IORef                     (newIORef, readIORef, IORef,                                                  writeIORef) @@ -36,29 +36,20 @@ tests :: Test tests = testGroup "Network.WebSockets.Server.Tests"     [ testCase "simple server/client" testSimpleServerClient-    , testCase "bulk server/client"   testBulkServerClient     , testCase "onPong"               testOnPong     ]   -------------------------------------------------------------------------------- testSimpleServerClient :: Assertion-testSimpleServerClient = testServerClient $ \conn -> mapM_ (sendTextData conn)-----------------------------------------------------------------------------------testBulkServerClient :: Assertion-testBulkServerClient = testServerClient sendTextDatas-----------------------------------------------------------------------------------testServerClient :: (Connection -> [BL.ByteString] -> IO ()) -> Assertion-testServerClient sendMessages = withEchoServer 42940 "Bye" $ do+testSimpleServerClient = withEchoServer 42940 "Bye" $ do     texts  <- map unArbitraryUtf8 <$> sample     texts' <- retry $ runClient "127.0.0.1" 42940 "/chat" $ client texts     texts @=? texts'   where     client :: [BL.ByteString] -> ClientApp [BL.ByteString]     client texts conn = do-        sendMessages conn texts+        forM_ texts (sendTextData conn)         texts' <- replicateM (length texts) (receiveData conn)         sendClose conn ("Bye" :: BL.ByteString)         expectCloseException conn "Bye"

@@ -49,7 +49,7 @@         echo  <- Stream.makeEchoStream         parse <- decodeMessages protocol echo         write <- encodeMessages protocol ClientConnection echo-        _     <- forkIO $ write msgs+        _     <- forkIO $ forM_ msgs write         msgs' <- catMaybes <$> replicateM (length msgs) parse         Stream.close echo         msgs @=? msgs'

@@ -1,5 +1,5 @@ Name:    websockets-Version: 0.9.8.0+Version: 0.9.8.1  Synopsis:   A sensible and clean way to write WebSocket-capable servers in Haskell.@@ -97,7 +97,7 @@     Network.WebSockets.Tests.Util    Build-depends:-    HUnit                      >= 1.2 && < 1.6,+    HUnit                      >= 1.2 && < 1.4,     QuickCheck                 >= 2.7 && < 2.10,     test-framework             >= 0.4 && < 0.9,     test-framework-hunit       >= 0.2 && < 0.4,