websockets 0.8.1.0 → 0.8.1.1
raw patch · 6 files changed
+534/−1 lines, 6 files
Files
- tests/haskell/Network/WebSockets/Handshake/Tests.hs +117/−0
- tests/haskell/Network/WebSockets/Http/Tests.hs +61/−0
- tests/haskell/Network/WebSockets/Server/Tests.hs +118/−0
- tests/haskell/Network/WebSockets/Tests.hs +179/−0
- tests/haskell/Network/WebSockets/Tests/Util.hs +51/−0
- websockets.cabal +8/−1
+ tests/haskell/Network/WebSockets/Handshake/Tests.hs view
@@ -0,0 +1,117 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+module Network.WebSockets.Handshake.Tests+ ( tests+ ) where+++--------------------------------------------------------------------------------+import Control.Concurrent (forkIO)+import Control.Exception (handle)+import Data.ByteString.Char8 ()+import Data.IORef (newIORef, readIORef,+ writeIORef)+import Data.Maybe (fromJust)+import qualified System.IO.Streams.Attoparsec as Streams+import qualified System.IO.Streams.Builder as Streams+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (Assertion, (@?=), assert)+++--------------------------------------------------------------------------------+import Network.WebSockets+import Network.WebSockets.Connection+import Network.WebSockets.Http+import Network.WebSockets.Tests.Util+++--------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Network.WebSockets.Handshake.Test"+ [ testCase "handshake Hybi13" testHandshakeHybi13+ , testCase "handshake reject" testHandshakeReject+ , testCase "handshake Hybi9000" testHandshakeHybi9000+ ]+++--------------------------------------------------------------------------------+testHandshake :: RequestHead -> (PendingConnection -> IO a) -> IO ResponseHead+testHandshake rq app = do+ (is, os) <- makeChanPipe+ os' <- Streams.builderStream os+ _ <- forkIO $ do+ _ <- app (PendingConnection defaultConnectionOptions rq nullify is os')+ return ()+ Streams.parseFromStream decodeResponseHead is+ where+ nullify _ = return ()+++--------------------------------------------------------------------------------+(!) :: Eq a => [(a, b)] -> a -> b+assoc ! key = fromJust (lookup key assoc)+++--------------------------------------------------------------------------------+rq13 :: RequestHead+rq13 = RequestHead "/mychat"+ [ ("Host", "server.example.com")+ , ("Upgrade", "websocket")+ , ("Connection", "Upgrade")+ , ("Sec-WebSocket-Key", "x3JJHMbDL1EzLkh9GBhXDw==")+ , ("Sec-WebSocket-Protocol", "chat")+ , ("Sec-WebSocket-Version", "13")+ , ("Origin", "http://example.com")+ ]+ False+++--------------------------------------------------------------------------------+testHandshakeHybi13 :: Assertion+testHandshakeHybi13 = do+ onAcceptFired <- newIORef False+ ResponseHead code message headers <- testHandshake rq13 $ \pc ->+ acceptRequest pc {pendingOnAccept = \_ -> writeIORef onAcceptFired True}++ readIORef onAcceptFired >>= assert+ code @?= 101+ message @?= "WebSocket Protocol Handshake"+ headers ! "Sec-WebSocket-Accept" @?= "HSmrc0sMlYUkAGmm5OPpG2HaGWk="+ headers ! "Connection" @?= "Upgrade"+++--------------------------------------------------------------------------------+testHandshakeReject :: Assertion+testHandshakeReject = do+ ResponseHead code _ _ <- testHandshake rq13 $ \pc ->+ rejectRequest pc "YOU SHALL NOT PASS"++ code @?= 400+++--------------------------------------------------------------------------------+-- I don't believe this one is supported yet+rq9000 :: RequestHead+rq9000 = RequestHead "/chat"+ [ ("Host", "server.example.com")+ , ("Upgrade", "websocket")+ , ("Connection", "Upgrade")+ , ("Sec-WebSocket-Key", "dGhlIHNhbXBsZSBub25jZQ==")+ , ("Sec-WebSocket-Origin", "http://example.com")+ , ("Sec-WebSocket-Protocol", "chat, superchat")+ , ("Sec-WebSocket-Version", "9000")+ ]+ False+++--------------------------------------------------------------------------------+testHandshakeHybi9000 :: Assertion+testHandshakeHybi9000 = do+ ResponseHead code _ headers <- testHandshake rq9000 $ \pc ->+ flip handle (acceptRequest pc) $ \e -> case e of+ NotSupported -> return undefined+ _ -> error $ "Unexpected Exception: " ++ show e++ code @?= 400+ headers ! "Sec-WebSocket-Version" @?= "13"
+ tests/haskell/Network/WebSockets/Http/Tests.hs view
@@ -0,0 +1,61 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+module Network.WebSockets.Http.Tests+ ( tests+ ) where+++--------------------------------------------------------------------------------+import qualified Data.Attoparsec as A+import qualified Data.ByteString.Char8 as BC+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (Assertion, assert)+++--------------------------------------------------------------------------------+import Network.WebSockets.Http+++--------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Network.WebSockets.Http.Tests"+ [ testCase "jwebsockets response" jWebSocketsResponse+ , testCase "chromium response" chromiumResponse+ ]+++--------------------------------------------------------------------------------+-- | This is a specific response sent by jwebsockets which caused trouble+jWebSocketsResponse :: Assertion+jWebSocketsResponse = assert $ case A.parseOnly decodeResponseHead input of+ Left err -> error err+ Right _ -> True+ where+ input = BC.intercalate "\r\n"+ [ "HTTP/1.1 101 Switching Protocols"+ , "Upgrade: websocket"+ , "Connection: Upgrade"+ , "Sec-WebSocket-Accept: Ha0QR1T9CoYx/nqwHsVnW8KVTSo="+ , "Sec-WebSocket-Origin: "+ , "Sec-WebSocket-Location: ws://127.0.0.1"+ , "Set-Cookie: JWSSESSIONID=2e0690e2e328f327056a5676b6a890e3; HttpOnly"+ , ""+ , ""+ ]+++--------------------------------------------------------------------------------+-- | This is a specific response sent by chromium which caused trouble+chromiumResponse :: Assertion+chromiumResponse = assert $ case A.parseOnly decodeResponseHead input of+ Left err -> error err+ Right _ -> True+ where+ input = BC.intercalate "\r\n"+ [ "HTTP/1.1 500 Internal Error"+ , "Content-Type:text/html"+ , "Content-Length:23"+ , ""+ , "No such target id: 20_1"+ ]
+ tests/haskell/Network/WebSockets/Server/Tests.hs view
@@ -0,0 +1,118 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Network.WebSockets.Server.Tests+ ( tests+ ) where+++--------------------------------------------------------------------------------+import Control.Applicative ((<$>))+import Control.Concurrent (forkIO, killThread,+ threadDelay)+import Control.Exception (SomeException, handle)+import Control.Monad (forM_, forever, replicateM)+import Data.IORef (newIORef, readIORef,+ writeIORef)+++--------------------------------------------------------------------------------+import qualified Data.ByteString.Lazy as BL+import Data.Text (Text)+import System.Random (newStdGen)+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (Assertion, assert, (@=?))+import Test.QuickCheck (Arbitrary, arbitrary)+import Test.QuickCheck.Gen (Gen (..))+++--------------------------------------------------------------------------------+import Network.WebSockets+import Network.WebSockets.Tests.Util+++--------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Network.WebSockets.Server.Tests"+ [ testCase "simple server/client" testSimpleServerClient+ , testCase "onPong" testOnPong+ ]+++--------------------------------------------------------------------------------+testSimpleServerClient :: Assertion+testSimpleServerClient = withEchoServer 42940 $ 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)+ texts' <- replicateM (length texts) (receiveData conn)+ sendClose conn ("Bye" :: BL.ByteString)+ return texts'+++--------------------------------------------------------------------------------+testOnPong :: Assertion+testOnPong = withEchoServer 42941 $ do+ gotPong <- newIORef False+ let opts = defaultConnectionOptions+ { connectionOnPong = writeIORef gotPong True+ }++ rcv <- runClientWith "127.0.0.1" 42941 "/" opts [] client+ assert rcv+ assert =<< readIORef gotPong+ where+ client :: ClientApp Bool+ client conn = do+ sendPing conn ("What's a fish without an eye?" :: Text)+ sendTextData conn ("A fsh!" :: Text)+ msg <- receiveData conn+ return $ "A fsh!" == (msg :: Text)+++--------------------------------------------------------------------------------+sample :: Arbitrary a => IO [a]+sample = do+ gen <- newStdGen+ return $ (unGen arbitrary) gen 512+++--------------------------------------------------------------------------------+waitSome :: IO ()+waitSome = threadDelay $ 200 * 1000+++--------------------------------------------------------------------------------+-- HOLY SHIT WHAT SORT OF ATROCITY IS THIS?!?!?!+--+-- The problem is that sometimes, the server hasn't been brought down yet+-- before the next test, which will cause it not to be able to bind to the+-- same port again. In this case, we just retry.+--+-- The same is true for our client: possibly, the server is not up yet+-- before we run the client. We also want to retry in that case.+retry :: IO a -> IO a+retry action = (\(_ :: SomeException) -> waitSome >> action) `handle` action+++--------------------------------------------------------------------------------+withEchoServer :: Int -> IO a -> IO a+withEchoServer port action = do+ serverThread <- forkIO $ retry $ runServer "0.0.0.0" port server+ waitSome+ result <- action+ waitSome+ killThread serverThread+ return result+ where+ server :: ServerApp+ server pc = do+ conn <- acceptRequest pc+ forever $ do+ msg <- receiveDataMessage conn+ sendDataMessage conn msg
+ tests/haskell/Network/WebSockets/Tests.hs view
@@ -0,0 +1,179 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Network.WebSockets.Tests+ ( tests+ ) where+++--------------------------------------------------------------------------------+import qualified Blaze.ByteString.Builder as Builder+import Control.Applicative ((<$>))+import Control.Monad (replicateM)+import qualified Data.ByteString.Lazy as BL+import Data.List (intersperse)+import Data.Maybe (catMaybes)+import qualified System.IO.Streams as Streams+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.HUnit ((@=?))+import Test.QuickCheck (Arbitrary (..), Gen,+ Property)+import qualified Test.QuickCheck as QC+import qualified Test.QuickCheck.Monadic as QC+++--------------------------------------------------------------------------------+import Network.WebSockets+import qualified Network.WebSockets.Hybi13 as Hybi13+import Network.WebSockets.Hybi13.Demultiplex+import Network.WebSockets.Protocol+import Network.WebSockets.Tests.Util+import Network.WebSockets.Types+++--------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Network.WebSockets.Test"+ [ testProperty "simple encode/decode Hybi13" (testSimpleEncodeDecode Hybi13)+ , testProperty "framgmented Hybi13" testFragmentedHybi13+ ]+++--------------------------------------------------------------------------------+testSimpleEncodeDecode :: Protocol -> Property+testSimpleEncodeDecode protocol = QC.monadicIO $+ QC.forAllM QC.arbitrary $ \msgs -> QC.run $ do+ (is, os) <- makeChanPipe+ is' <- decodeMessages protocol is+ os' <- encodeMessages protocol ClientConnection =<<+ Streams.builderStream os+ Streams.writeList msgs os'+ msgs' <- catMaybes <$> replicateM (length msgs) (Streams.read is')+ msgs @=? msgs'+++--------------------------------------------------------------------------------+testFragmentedHybi13 :: Property+testFragmentedHybi13 = QC.monadicIO $+ QC.forAllM QC.arbitrary $ \fragmented -> QC.run $ do+ (is, os) <- makeChanPipe+ is' <- Streams.filter isDataMessage =<< Hybi13.decodeMessages is+ os' <- Streams.builderStream os++ -- Simple hacky encoding of all frames+ Streams.writeList+ [ Hybi13.encodeFrame Nothing f+ | FragmentedMessage _ frames <- fragmented+ , f <- frames+ ] os'+ Streams.write (Just Builder.flush) os'+ Streams.write Nothing os'++ -- Check if we got all data+ msgs <- catMaybes <$> replicateM (length fragmented) (Streams.read is')+ [msg | FragmentedMessage msg _ <- fragmented] @=? msgs+ where+ isDataMessage (ControlMessage _) = False+ isDataMessage (DataMessage _) = True+++--------------------------------------------------------------------------------+instance Arbitrary FrameType where+ arbitrary = QC.elements+ [ ContinuationFrame+ , TextFrame+ , BinaryFrame+ , CloseFrame+ , PingFrame+ , PongFrame+ ]+++--------------------------------------------------------------------------------+instance Arbitrary Frame where+ arbitrary = do+ fin <- arbitrary+ rsv1 <- arbitrary+ rsv2 <- arbitrary+ rsv3 <- arbitrary+ t <- arbitrary+ payload <- case t of+ TextFrame -> arbitraryUtf8+ _ -> BL.pack <$> arbitrary+ return $ Frame fin rsv1 rsv2 rsv3 t payload+++--------------------------------------------------------------------------------+instance Arbitrary Message where+ arbitrary = do+ payload <- BL.pack <$> arbitrary+ QC.elements+ [ ControlMessage (Close payload)+ , ControlMessage (Ping payload)+ , ControlMessage (Pong payload)+ , DataMessage (Text payload)+ , DataMessage (Binary payload)+ ]+++--------------------------------------------------------------------------------+data FragmentedMessage = FragmentedMessage Message [Frame]+ deriving (Show)+++--------------------------------------------------------------------------------+instance Arbitrary FragmentedMessage where+ arbitrary = do+ -- Pick a frametype and a corresponding random payload+ ft <- QC.elements [TextFrame, BinaryFrame]+ payload <- case ft of+ TextFrame -> arbitraryUtf8+ _ -> arbitraryByteString++ fragments <- arbitraryFragmentation payload+ let fs = makeFrames $ zip (ft : repeat ContinuationFrame) fragments+ msg = case ft of+ TextFrame -> DataMessage (Text payload)+ BinaryFrame -> DataMessage (Binary payload)+ _ -> error "Arbitrary FragmentedMessage crashed"++ interleaved <- arbitraryInterleave genControlFrame fs+ return $ FragmentedMessage msg interleaved+ -- return $ FragmentedMessage msg fs+ where+ makeFrames [] = []+ makeFrames [(ft, pl)] = [Frame True False False False ft pl]+ makeFrames ((ft, pl) : fr) =+ Frame False False False False ft pl : makeFrames fr++ genControlFrame = QC.elements+ [ Frame True False False False PingFrame "Herp"+ , Frame True True True True PongFrame "Derp"+ ]+++--------------------------------------------------------------------------------+arbitraryFragmentation :: BL.ByteString -> Gen [BL.ByteString]+arbitraryFragmentation bs = arbitraryFragmentation' bs+ where+ len :: Int+ len = fromIntegral $ BL.length bs+ arbitraryFragmentation' bs' = do+ -- TODO: we currently can't send packets of length 0. We should+ -- investigate why (regardless of the spec).+ n <- QC.choose (1, len - 1)+ let (l, r) = BL.splitAt (fromIntegral n) bs'+ case r of+ "" -> return [l]+ _ -> (l :) <$> arbitraryFragmentation' r+++--------------------------------------------------------------------------------+arbitraryInterleave :: Gen a -> [a] -> Gen [a]+arbitraryInterleave sep xs = fmap concat $ sequence $+ [sep'] ++ intersperse sep' [return [x] | x <- xs] ++ [sep']+ where+ sep' = QC.sized $ \size -> do+ num <- QC.choose (1, size)+ replicateM num sep
+ tests/haskell/Network/WebSockets/Tests/Util.hs view
@@ -0,0 +1,51 @@+--------------------------------------------------------------------------------+module Network.WebSockets.Tests.Util+ ( ArbitraryUtf8 (..)+ , arbitraryUtf8+ , arbitraryByteString+ , makeChanPipe+ ) where+++--------------------------------------------------------------------------------+import Control.Applicative ((<$>), (<*>))+import Control.Concurrent.Chan (newChan)+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL+import System.IO.Streams (InputStream, OutputStream)+import qualified System.IO.Streams.Concurrent as Streams+import Test.QuickCheck (Arbitrary (..), Gen)+++--------------------------------------------------------------------------------+import Network.WebSockets.Types+++--------------------------------------------------------------------------------+newtype ArbitraryUtf8 = ArbitraryUtf8 {unArbitraryUtf8 :: BL.ByteString}+ deriving (Eq, Ord, Show)+++--------------------------------------------------------------------------------+instance Arbitrary ArbitraryUtf8 where+ arbitrary = ArbitraryUtf8 <$> arbitraryUtf8+++--------------------------------------------------------------------------------+arbitraryUtf8 :: Gen BL.ByteString+arbitraryUtf8 = toLazyByteString . TL.encodeUtf8 . TL.pack <$> arbitrary+++--------------------------------------------------------------------------------+arbitraryByteString :: Gen BL.ByteString+arbitraryByteString = BL.pack <$> arbitrary+++--------------------------------------------------------------------------------+-- | TODO: I added this function to the io-streams library but it isn't released+-- yet, at some point we should be able to remove it here.+makeChanPipe :: IO (InputStream a, OutputStream a)+makeChanPipe = do+ chan <- newChan+ (,) <$> Streams.chanToInput chan <*> Streams.chanToOutput chan
websockets.cabal view
@@ -1,5 +1,5 @@ Name: websockets-Version: 0.8.1.0+Version: 0.8.1.1 Synopsis: A sensible and clean way to write WebSocket-capable servers in Haskell.@@ -81,6 +81,13 @@ Hs-source-dirs: src tests/haskell Main-is: TestSuite.hs Ghc-options: -Wall++ Other-modules:+ Network.WebSockets.Handshake.Tests+ Network.WebSockets.Http.Tests+ Network.WebSockets.Server.Tests+ Network.WebSockets.Tests+ Network.WebSockets.Tests.Util Build-depends: HUnit >= 1.2 && < 1.3,