diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 diff --git a/src/Network/WebSockets.hs b/src/Network/WebSockets.hs --- a/src/Network/WebSockets.hs +++ b/src/Network/WebSockets.hs @@ -23,7 +23,6 @@ , send , sendDataMessage , sendTextData - , sendTextDatas , sendBinaryData , sendClose , sendPing diff --git a/src/Network/WebSockets/Client.hs b/src/Network/WebSockets/Client.hs --- a/src/Network/WebSockets/Client.hs +++ b/src/Network/WebSockets/Client.hs @@ -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 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 @@ -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, 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 @@ -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 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 @@ -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 diff --git a/src/Network/WebSockets/Protocol.hs b/src/Network/WebSockets/Protocol.hs --- a/src/Network/WebSockets/Protocol.hs +++ b/src/Network/WebSockets/Protocol.hs @@ -68,7 +68,7 @@ -------------------------------------------------------------------------------- encodeMessages :: Protocol -> ConnectionType -> Stream - -> IO ([Message] -> IO ()) + -> IO (Message -> IO ()) encodeMessages Hybi13 = Hybi13.encodeMessages diff --git a/tests/haskell/Network/WebSockets/Handshake/Tests.hs b/tests/haskell/Network/WebSockets/Handshake/Tests.hs --- a/tests/haskell/Network/WebSockets/Handshake/Tests.hs +++ b/tests/haskell/Network/WebSockets/Handshake/Tests.hs @@ -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 diff --git a/tests/haskell/Network/WebSockets/Server/Tests.hs b/tests/haskell/Network/WebSockets/Server/Tests.hs --- a/tests/haskell/Network/WebSockets/Server/Tests.hs +++ b/tests/haskell/Network/WebSockets/Server/Tests.hs @@ -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" diff --git a/tests/haskell/Network/WebSockets/Tests.hs b/tests/haskell/Network/WebSockets/Tests.hs --- a/tests/haskell/Network/WebSockets/Tests.hs +++ b/tests/haskell/Network/WebSockets/Tests.hs @@ -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' diff --git a/websockets.cabal b/websockets.cabal --- a/websockets.cabal +++ b/websockets.cabal @@ -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,