diff --git a/tests/haskell/Network/WebSockets/Handshake/Tests.hs b/tests/haskell/Network/WebSockets/Handshake/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/haskell/Network/WebSockets/Handshake/Tests.hs @@ -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" diff --git a/tests/haskell/Network/WebSockets/Http/Tests.hs b/tests/haskell/Network/WebSockets/Http/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/haskell/Network/WebSockets/Http/Tests.hs @@ -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" + ] diff --git a/tests/haskell/Network/WebSockets/Server/Tests.hs b/tests/haskell/Network/WebSockets/Server/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/haskell/Network/WebSockets/Server/Tests.hs @@ -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 diff --git a/tests/haskell/Network/WebSockets/Tests.hs b/tests/haskell/Network/WebSockets/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/haskell/Network/WebSockets/Tests.hs @@ -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 diff --git a/tests/haskell/Network/WebSockets/Tests/Util.hs b/tests/haskell/Network/WebSockets/Tests/Util.hs new file mode 100644 --- /dev/null +++ b/tests/haskell/Network/WebSockets/Tests/Util.hs @@ -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 diff --git a/websockets.cabal b/websockets.cabal --- a/websockets.cabal +++ b/websockets.cabal @@ -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,