Hello community, here is the log from the commit of package ghc-websockets for openSUSE:Factory checked in at 2017-03-03 17:52:19 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-websockets (Old) and /work/SRC/openSUSE:Factory/.ghc-websockets.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-websockets" Fri Mar 3 17:52:19 2017 rev:3 rq:461692 version:0.10.0.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-websockets/ghc-websockets.changes 2017-02-03 17:40:34.260328929 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-websockets.new/ghc-websockets.changes 2017-03-03 17:52:20.346983716 +0100 @@ -1,0 +2,5 @@ +Sun Feb 12 14:08:48 UTC 2017 - [email protected] + +- Update to version 0.10.0.0 with cabal2obs. + +------------------------------------------------------------------- Old: ---- websockets-0.9.8.2.tar.gz New: ---- websockets-0.10.0.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-websockets.spec ++++++ --- /var/tmp/diff_new_pack.reTc3Q/_old 2017-03-03 17:52:21.190864526 +0100 +++ /var/tmp/diff_new_pack.reTc3Q/_new 2017-03-03 17:52:21.190864526 +0100 @@ -1,7 +1,7 @@ # # spec file for package ghc-websockets # -# Copyright (c) 2016 SUSE LINUX GmbH, Nuernberg, Germany. +# Copyright (c) 2017 SUSE LINUX GmbH, Nuernberg, Germany. # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -19,7 +19,7 @@ %global pkg_name websockets %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.9.8.2 +Version: 0.10.0.0 Release: 0 Summary: A sensible and clean way to write WebSocket-capable servers in Haskell License: BSD-3-Clause ++++++ websockets-0.9.8.2.tar.gz -> websockets-0.10.0.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/websockets-0.9.8.2/CHANGELOG new/websockets-0.10.0.0/CHANGELOG --- old/websockets-0.9.8.2/CHANGELOG 2016-11-29 11:15:35.000000000 +0100 +++ new/websockets-0.10.0.0/CHANGELOG 2016-11-29 11:27:28.000000000 +0100 @@ -1,3 +1,8 @@ +- 0.10.0.0 + * Fix client specifying empty path + * Allow sending collections of messages (by David Turner) + * Allow sending extra headers when accepting request (by James Deery) + - 0.9.8.2 * Bump `HUnit` dependency to 1.5 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/websockets-0.9.8.2/src/Network/WebSockets/Client.hs new/websockets-0.10.0.0/src/Network/WebSockets/Client.hs --- old/websockets-0.9.8.2/src/Network/WebSockets/Client.hs 2016-11-29 11:15:35.000000000 +0100 +++ new/websockets-0.10.0.0/src/Network/WebSockets/Client.hs 2016-11-29 11:27:28.000000000 +0100 @@ -53,11 +53,14 @@ -> Headers -- ^ Custom headers to send -> ClientApp a -- ^ Client application -> IO a -runClientWith host port path opts customHeaders app = do +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} + + -- 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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/websockets-0.9.8.2/src/Network/WebSockets/Connection.hs new/websockets-0.10.0.0/src/Network/WebSockets/Connection.hs --- old/websockets-0.9.8.2/src/Network/WebSockets/Connection.hs 2016-11-29 11:15:35.000000000 +0100 +++ new/websockets-0.10.0.0/src/Network/WebSockets/Connection.hs 2016-11-29 11:27:28.000000000 +0100 @@ -4,8 +4,9 @@ {-# LANGUAGE OverloadedStrings #-} module Network.WebSockets.Connection ( PendingConnection (..) - , AcceptRequest(..) , acceptRequest + , AcceptRequest(..) + , defaultAcceptRequest , acceptRequestWith , rejectRequest @@ -19,8 +20,11 @@ , receiveData , send , sendDataMessage + , sendDataMessages , sendTextData + , sendTextDatas , sendBinaryData + , sendBinaryDatas , sendClose , sendCloseCode , sendPing @@ -34,7 +38,7 @@ import Control.Concurrent (forkIO, threadDelay) import Control.Exception (AsyncException, fromException, handle, throwIO) -import Control.Monad (unless) +import Control.Monad (unless, when) import qualified Data.ByteString as B import Data.IORef (IORef, newIORef, readIORef, writeIORef) @@ -68,15 +72,26 @@ -------------------------------------------------------------------------------- +-- | This datatype allows you to set options for 'acceptRequestWith'. It is +-- strongly recommended to use 'defaultAcceptRequest' and then modify the +-- various fields, that way new fields introduced in the library do not break +-- your code. data AcceptRequest = AcceptRequest { acceptSubprotocol :: !(Maybe B.ByteString) -- ^ 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. } -------------------------------------------------------------------------------- +defaultAcceptRequest :: AcceptRequest +defaultAcceptRequest = AcceptRequest Nothing [] + + +-------------------------------------------------------------------------------- -- | Utility sendResponse :: PendingConnection -> Response -> IO () sendResponse pc rsp = Stream.write (pendingStream pc) @@ -84,11 +99,14 @@ -------------------------------------------------------------------------------- +-- | Accept a pending connection, turning it into a 'Connection'. acceptRequest :: PendingConnection -> IO Connection -acceptRequest pc = acceptRequestWith pc $ AcceptRequest Nothing +acceptRequest pc = acceptRequestWith pc defaultAcceptRequest -------------------------------------------------------------------------------- +-- | This function is like 'acceptRequest' but allows you to set custom options +-- using the 'AcceptRequest' datatype. acceptRequestWith :: PendingConnection -> AcceptRequest -> IO Connection acceptRequestWith pc ar = case find (flip compatible request) protocols of Nothing -> do @@ -96,7 +114,8 @@ throwIO NotSupported Just protocol -> do let subproto = maybe [] (\p -> [("Sec-WebSocket-Protocol", p)]) $ acceptSubprotocol ar - response = finishRequest protocol request subproto + headers = subproto ++ acceptHeaders ar + response = finishRequest protocol request headers sendResponse pc response parse <- decodeMessages protocol (pendingStream pc) write <- encodeMessages protocol ServerConnection (pendingStream pc) @@ -130,7 +149,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 @@ -206,31 +225,47 @@ -------------------------------------------------------------------------------- send :: Connection -> Message -> IO () -send conn msg = do - case msg of - (ControlMessage (Close _ _)) -> - writeIORef (connectionSentClose conn) True - _ -> return () - connectionWrite conn msg +send conn = sendAll conn . return +-------------------------------------------------------------------------------- +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 = send conn . DataMessage +sendDataMessage conn = sendDataMessages conn . return +-------------------------------------------------------------------------------- +-- | 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 = sendDataMessage conn . Text . toLazyByteString +sendTextData conn = sendTextDatas conn . return +-------------------------------------------------------------------------------- +-- | 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 = sendDataMessage conn . Binary . toLazyByteString +sendBinaryData conn = sendBinaryDatas conn . return +-------------------------------------------------------------------------------- +-- | 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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/websockets-0.9.8.2/src/Network/WebSockets/Hybi13/Mask.hs new/websockets-0.10.0.0/src/Network/WebSockets/Hybi13/Mask.hs --- old/websockets-0.9.8.2/src/Network/WebSockets/Hybi13/Mask.hs 2016-11-29 11:15:35.000000000 +0100 +++ new/websockets-0.10.0.0/src/Network/WebSockets/Hybi13/Mask.hs 2016-11-29 11:27:28.000000000 +0100 @@ -25,14 +25,10 @@ -- | Apply mask maskPayload :: Mask -> BL.ByteString -> BL.ByteString maskPayload Nothing = id -maskPayload (Just mask) = snd . BL.mapAccumL f 0 +maskPayload (Just mask) = snd . BL.mapAccumL f (cycle $ B.unpack mask) where - len = B.length mask - f !i !c = - let i' = (i + 1) `mod` len - m = mask `B.index` i - in (i', m `xor` c) - + f [] !c = ([], c) + f (m:ms) !c = (ms, m `xor` c) -------------------------------------------------------------------------------- -- | Create a random mask diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/websockets-0.9.8.2/src/Network/WebSockets/Hybi13.hs new/websockets-0.10.0.0/src/Network/WebSockets/Hybi13.hs --- old/websockets-0.9.8.2/src/Network/WebSockets/Hybi13.hs 2016-11-29 11:15:35.000000000 +0100 +++ new/websockets-0.10.0.0/src/Network/WebSockets/Hybi13.hs 2016-11-29 11:27:28.000000000 +0100 @@ -18,7 +18,7 @@ import qualified Blaze.ByteString.Builder as B import Control.Applicative (pure, (<$>)) import Control.Exception (throw) -import Control.Monad (liftM) +import Control.Monad (liftM, forM) 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 `mappend` B.flush) +encodeMessage conType gen msg = (gen', builder) 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 $ \msg -> do - builder <- atomicModifyIORef genRef $ \s -> encodeMessage conType s msg - Stream.write stream (B.toLazyByteString builder) - + return $ \msgs -> do + builders <- forM msgs $ \msg -> + atomicModifyIORef genRef $ \s -> encodeMessage conType s msg + Stream.write stream (B.toLazyByteString $ mconcat builders) -------------------------------------------------------------------------------- encodeFrame :: Mask -> Frame -> B.Builder diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/websockets-0.9.8.2/src/Network/WebSockets/Protocol.hs new/websockets-0.10.0.0/src/Network/WebSockets/Protocol.hs --- old/websockets-0.9.8.2/src/Network/WebSockets/Protocol.hs 2016-11-29 11:15:35.000000000 +0100 +++ new/websockets-0.10.0.0/src/Network/WebSockets/Protocol.hs 2016-11-29 11:27:28.000000000 +0100 @@ -68,7 +68,7 @@ -------------------------------------------------------------------------------- encodeMessages :: Protocol -> ConnectionType -> Stream - -> IO (Message -> IO ()) + -> IO ([Message] -> IO ()) encodeMessages Hybi13 = Hybi13.encodeMessages diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/websockets-0.9.8.2/src/Network/WebSockets.hs new/websockets-0.10.0.0/src/Network/WebSockets.hs --- old/websockets-0.9.8.2/src/Network/WebSockets.hs 2016-11-29 11:15:35.000000000 +0100 +++ new/websockets-0.10.0.0/src/Network/WebSockets.hs 2016-11-29 11:27:28.000000000 +0100 @@ -4,8 +4,9 @@ ( -- * Incoming connections and handshaking PendingConnection , pendingRequest - , AcceptRequest(..) , acceptRequest + , AcceptRequest(..) + , defaultAcceptRequest , acceptRequestWith , rejectRequest @@ -23,6 +24,7 @@ , send , sendDataMessage , sendTextData + , sendTextDatas , sendBinaryData , sendClose , sendPing diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/websockets-0.9.8.2/tests/haskell/Network/WebSockets/Handshake/Tests.hs new/websockets-0.10.0.0/tests/haskell/Network/WebSockets/Handshake/Tests.hs --- old/websockets-0.9.8.2/tests/haskell/Network/WebSockets/Handshake/Tests.hs 2016-11-29 11:15:35.000000000 +0100 +++ new/websockets-0.10.0.0/tests/haskell/Network/WebSockets/Handshake/Tests.hs 2016-11-29 11:27:28.000000000 +0100 @@ -29,6 +29,8 @@ 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 ] @@ -90,7 +92,7 @@ ResponseHead code message headers <- testHandshake rq13 $ \pc -> do getRequestSubprotocols (pendingRequest pc) @?= ["chat", "superchat"] acceptRequestWith pc {pendingOnAccept = \_ -> writeIORef onAcceptFired True} - (AcceptRequest $ Just "superchat") + (AcceptRequest (Just "superchat") []) readIORef onAcceptFired >>= assert code @?= 101 @@ -100,6 +102,40 @@ 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")]) + + readIORef onAcceptFired >>= assert + code @?= 101 + message @?= "WebSocket Protocol Handshake" + headers ! "Sec-WebSocket-Accept" @?= "HSmrc0sMlYUkAGmm5OPpG2HaGWk=" + headers ! "Connection" @?= "Upgrade" + headers ! "Sec-WebSocket-Protocol" @?= "superchat" + headers ! "Set-Cookie" @?= "sid=foo" + +-------------------------------------------------------------------------------- testHandshakeReject :: Assertion testHandshakeReject = do ResponseHead code _ _ <- testHandshake rq13 $ \pc -> diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/websockets-0.9.8.2/tests/haskell/Network/WebSockets/Server/Tests.hs new/websockets-0.10.0.0/tests/haskell/Network/WebSockets/Server/Tests.hs --- old/websockets-0.9.8.2/tests/haskell/Network/WebSockets/Server/Tests.hs 2016-11-29 11:15:35.000000000 +0100 +++ new/websockets-0.10.0.0/tests/haskell/Network/WebSockets/Server/Tests.hs 2016-11-29 11:27:28.000000000 +0100 @@ -11,7 +11,7 @@ import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Exception (SomeException, handle, catch) -import Control.Monad (forM_, forever, replicateM, unless) +import Control.Monad (forever, replicateM, unless) import Data.IORef (newIORef, readIORef, IORef, writeIORef) @@ -36,20 +36,29 @@ tests :: Test tests = testGroup "Network.WebSockets.Server.Tests" [ testCase "simple server/client" testSimpleServerClient + , testCase "bulk server/client" testBulkServerClient , testCase "onPong" testOnPong ] -------------------------------------------------------------------------------- testSimpleServerClient :: Assertion -testSimpleServerClient = withEchoServer 42940 "Bye" $ do +testSimpleServerClient = testServerClient $ \conn -> mapM_ (sendTextData conn) + +-------------------------------------------------------------------------------- +testBulkServerClient :: Assertion +testBulkServerClient = testServerClient sendTextDatas + +-------------------------------------------------------------------------------- +testServerClient :: (Connection -> [BL.ByteString] -> IO ()) -> Assertion +testServerClient sendMessages = 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 - forM_ texts (sendTextData conn) + sendMessages conn texts texts' <- replicateM (length texts) (receiveData conn) sendClose conn ("Bye" :: BL.ByteString) expectCloseException conn "Bye" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/websockets-0.9.8.2/tests/haskell/Network/WebSockets/Tests.hs new/websockets-0.10.0.0/tests/haskell/Network/WebSockets/Tests.hs --- old/websockets-0.9.8.2/tests/haskell/Network/WebSockets/Tests.hs 2016-11-29 11:15:35.000000000 +0100 +++ new/websockets-0.10.0.0/tests/haskell/Network/WebSockets/Tests.hs 2016-11-29 11:27:28.000000000 +0100 @@ -49,7 +49,7 @@ echo <- Stream.makeEchoStream parse <- decodeMessages protocol echo write <- encodeMessages protocol ClientConnection echo - _ <- forkIO $ forM_ msgs write + _ <- forkIO $ write msgs msgs' <- catMaybes <$> replicateM (length msgs) parse Stream.close echo msgs @=? msgs' diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/websockets-0.9.8.2/websockets.cabal new/websockets-0.10.0.0/websockets.cabal --- old/websockets-0.9.8.2/websockets.cabal 2016-11-29 11:15:35.000000000 +0100 +++ new/websockets-0.10.0.0/websockets.cabal 2016-11-29 11:27:28.000000000 +0100 @@ -1,5 +1,5 @@ Name: websockets -Version: 0.9.8.2 +Version: 0.10.0.0 Synopsis: A sensible and clean way to write WebSocket-capable servers in Haskell. @@ -90,11 +90,22 @@ Ghc-options: -Wall Other-modules: + Network.WebSockets + Network.WebSockets.Client + Network.WebSockets.Connection Network.WebSockets.Handshake.Tests + Network.WebSockets.Http Network.WebSockets.Http.Tests + Network.WebSockets.Hybi13 + Network.WebSockets.Hybi13.Demultiplex + Network.WebSockets.Hybi13.Mask + Network.WebSockets.Protocol + Network.WebSockets.Server Network.WebSockets.Server.Tests + Network.WebSockets.Stream Network.WebSockets.Tests Network.WebSockets.Tests.Util + Network.WebSockets.Types Build-depends: HUnit >= 1.2 && < 1.6,
