websockets 0.9.8.2 → 0.10.0.0

raw patch · 11 files changed

+134/−37 lines, 11 files

Files

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

@@ -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 

@@ -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

@@ -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

@@ -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,

@@ -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

@@ -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

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

@@ -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@@ -98,6 +100,40 @@     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")])++    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

@@ -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"

@@ -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'

@@ -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,