network-transport-tests 0.1.0.1 → 0.2.1.0
raw patch · 5 files changed
+209/−184 lines, 5 filesdep ~ansi-terminaldep ~basedep ~mtlnew-uploaderPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: ansi-terminal, base, mtl, network-transport
API changes (from Hackage documentation)
+ Network.Transport.Tests: testStreams :: Eq a => [a] -> [[a]] -> Bool
Files
- network-transport-tests.cabal +13/−9
- src/Network/Transport/Tests.hs +136/−115
- src/Network/Transport/Tests/Auxiliary.hs +14/−14
- src/Network/Transport/Tests/Multicast.hs +15/−15
- src/Network/Transport/Tests/Traced.hs +31/−31
network-transport-tests.cabal view
@@ -1,30 +1,34 @@ name: network-transport-tests-version: 0.1.0.1+version: 0.2.1.0 synopsis: Unit tests for Network.Transport implementations--- description: -homepage: http://github.com/haskell-distributed/distributed-process+-- description:+homepage: http://haskell-distributed.github.com license: BSD3 license-file: LICENSE author: Edsko de Vries-maintainer: edsko@well-typed.com+maintainer: edsko@well-typed.com, watson.timothy@gmail.com copyright: Well-Typed LLP category: Network build-type: Simple cabal-version: >=1.8 +Source-Repository head+ Type: git+ Location: https://github.com/haskell-distributed/network-transport-tests+ library exposed-modules: Network.Transport.Tests, Network.Transport.Tests.Multicast, Network.Transport.Tests.Auxiliary, Network.Transport.Tests.Traced- -- other-modules: - build-depends: base >= 4.5 && < 4.7,- network-transport >= 0.3 && < 0.4,+ -- other-modules:+ build-depends: base >= 4.5 && < 5,+ network-transport >= 0.4.1.0 && < 0.5, containers >= 0.4 && < 0.6, bytestring >= 0.9 && < 0.11, random >= 1.0 && < 1.1,- mtl >= 2.1 && < 2.2,- ansi-terminal >= 0.5 && < 0.6+ mtl >= 2.1 && < 2.3,+ ansi-terminal >= 0.5 && < 0.7 hs-source-dirs: src ghc-options: -Wall -fno-warn-unused-do-bind extensions: CPP,
src/Network/Transport/Tests.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE RebindableSyntax #-} module Network.Transport.Tests where -import Prelude hiding +import Prelude hiding ( (>>=) , return , fail@@ -16,7 +16,7 @@ import Control.Monad (replicateM, replicateM_, when, guard, forM_, unless) import Control.Monad.Error () import Control.Applicative ((<$>))-import Network.Transport +import Network.Transport import Network.Transport.Internal (tlog, tryIO, timeoutMaybe) import Network.Transport.Util (spawn) import System.Random (randomIO)@@ -34,22 +34,22 @@ echoServer endpoint = do go Map.empty where- go :: Map ConnectionId Connection -> IO () + go :: Map ConnectionId Connection -> IO () go cs = do event <- receive endpoint case event of ConnectionOpened cid rel addr -> do tlog $ "Opened new connection " ++ show cid Right conn <- connect endpoint addr rel defaultConnectHints- go (Map.insert cid conn cs) + go (Map.insert cid conn cs) Received cid payload -> do- send (Map.findWithDefault (error $ "Received: Invalid cid " ++ show cid) cid cs) payload + send (Map.findWithDefault (error $ "Received: Invalid cid " ++ show cid) cid cs) payload go cs- ConnectionClosed cid -> do + ConnectionClosed cid -> do tlog $ "Close connection " ++ show cid close (Map.findWithDefault (error $ "ConnectionClosed: Invalid cid " ++ show cid) cid cs)- go (Map.delete cid cs) - ReceivedMulticast _ _ -> + go (Map.delete cid cs)+ ReceivedMulticast _ _ -> -- Ignore go cs ErrorEvent _ ->@@ -81,49 +81,49 @@ -- Wait for the server to close its connection to us tlog "Wait for ConnectionClosed message"- ConnectionClosed cid' <- receive endpoint ; True <- return $ cid == cid' + ConnectionClosed cid' <- receive endpoint ; True <- return $ cid == cid' -- Done tlog "Ping client done"- + -- | Basic ping test-testPingPong :: Transport -> Int -> IO () +testPingPong :: Transport -> Int -> IO () testPingPong transport numPings = do tlog "Starting ping pong test" server <- spawn transport echoServer result <- newEmptyMVar - -- Client + -- Client forkTry $ do tlog "Ping client" Right endpoint <- newEndPoint transport ping endpoint server numPings "ping"- putMVar result () - + putMVar result ()+ takeMVar result -- | Test that endpoints don't get confused-testEndPoints :: Transport -> Int -> IO () +testEndPoints :: Transport -> Int -> IO () testEndPoints transport numPings = do server <- spawn transport echoServer dones <- replicateM 2 newEmptyMVar - forM_ (zip dones ['A'..]) $ \(done, name) -> forkTry $ do + forM_ (zip dones ['A'..]) $ \(done, name) -> forkTry $ do let name' :: ByteString name' = pack [name] Right endpoint <- newEndPoint transport tlog $ "Ping client " ++ show name' ++ ": " ++ show (address endpoint)- ping endpoint server numPings name' - putMVar done () + ping endpoint server numPings name'+ putMVar done () forM_ dones takeMVar -- Test that connections don't get confused-testConnections :: Transport -> Int -> IO () +testConnections :: Transport -> Int -> IO () testConnections transport numPings = do server <- spawn transport echoServer result <- newEmptyMVar- + -- Client forkTry $ do Right endpoint <- newEndPoint transport@@ -131,7 +131,7 @@ -- Open two connections to the server Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints ConnectionOpened serv1 _ _ <- receive endpoint- + Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints ConnectionOpened serv2 _ _ <- receive endpoint @@ -141,17 +141,17 @@ -- One thread to send "pingB" on the second connection forkTry $ replicateM_ numPings $ send conn2 ["pingB"] - -- Verify server responses - let verifyResponse 0 = putMVar result () - verifyResponse n = do + -- Verify server responses+ let verifyResponse 0 = putMVar result ()+ verifyResponse n = do event <- receive endpoint case event of Received cid [payload] -> do when (cid == serv1 && payload /= "pingA") $ error "Wrong message" when (cid == serv2 && payload /= "pingB") $ error "Wrong message"- verifyResponse (n - 1) - _ -> - verifyResponse n + verifyResponse (n - 1)+ _ ->+ verifyResponse n verifyResponse (2 * numPings) takeMVar result@@ -161,7 +161,7 @@ testCloseOneConnection transport numPings = do server <- spawn transport echoServer result <- newEmptyMVar- + -- Client forkTry $ do Right endpoint <- newEndPoint transport@@ -169,7 +169,7 @@ -- Open two connections to the server Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints ConnectionOpened serv1 _ _ <- receive endpoint- + Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints ConnectionOpened serv2 _ _ <- receive endpoint @@ -177,21 +177,21 @@ forkTry $ do replicateM_ numPings $ send conn1 ["pingA"] close conn1- + -- One thread to send "pingB" on the second connection forkTry $ replicateM_ (numPings * 2) $ send conn2 ["pingB"] - -- Verify server responses - let verifyResponse 0 = putMVar result () - verifyResponse n = do + -- Verify server responses+ let verifyResponse 0 = putMVar result ()+ verifyResponse n = do event <- receive endpoint case event of Received cid [payload] -> do when (cid == serv1 && payload /= "pingA") $ error "Wrong message" when (cid == serv2 && payload /= "pingB") $ error "Wrong message"- verifyResponse (n - 1) - _ -> - verifyResponse n + verifyResponse (n - 1)+ _ ->+ verifyResponse n verifyResponse (3 * numPings) takeMVar result@@ -208,7 +208,7 @@ -- A forkTry $ do- tlog "A" + tlog "A" Right endpoint <- newEndPoint transport tlog (show (address endpoint)) putMVar addrA (address endpoint)@@ -218,25 +218,25 @@ Right conn <- readMVar addrB >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints -- Wait for B to connect to us- tlog "Wait for B" + tlog "Wait for B" ConnectionOpened cid _ _ <- receive endpoint -- Send pings to B tlog "Send pings to B"- replicateM_ numPings $ send conn ["ping"] + replicateM_ numPings $ send conn ["ping"] -- Close our connection to B tlog "Close connection" close conn- + -- Wait for B's pongs- tlog "Wait for pongs from B" + tlog "Wait for pongs from B" replicateM_ numPings $ do Received _ _ <- receive endpoint ; return () -- Wait for B to close it's connection to us tlog "Wait for B to close connection" ConnectionClosed cid' <- receive endpoint- guard (cid == cid') + guard (cid == cid') -- Done tlog "Done"@@ -264,12 +264,12 @@ -- Wait for A to close it's connection to us tlog "Wait for A to close connection" ConnectionClosed cid' <- receive endpoint- guard (cid == cid') + guard (cid == cid') -- Send pongs to A tlog "Send pongs to A" replicateM_ numPings $ send conn ["pong"]- + -- Close our connection to A tlog "Close connection to A" close conn@@ -285,10 +285,10 @@ collect endPoint maxEvents timeout = go maxEvents Map.empty Map.empty where -- TODO: for more serious use of this function we'd need to make these arguments strict- go (Just 0) open closed = finish open closed + go (Just 0) open closed = finish open closed go n open closed = do- mEvent <- tryIO . timeoutMaybe timeout (userError "timeout") $ receive endPoint - case mEvent of + mEvent <- tryIO . timeoutMaybe timeout (userError "timeout") $ receive endPoint+ case mEvent of Left _ -> finish open closed Right event -> do let n' = (\x -> x - 1) <$> n@@ -307,8 +307,8 @@ EndPointClosed -> fail "Unexpected endpoint closure" - finish open closed = - if Map.null open + finish open closed =+ if Map.null open then return . Map.toList . Map.map reverse $ closed else fail $ "Open connections: " ++ show (map fst . Map.toList $ open) @@ -319,12 +319,12 @@ -- before receiving the messages on the second connection. What might (and sometimes -- does) happen is that finishes sending all of its messages on the first connection -- (in the TCP transport, the first socket pair) while B is behind on reading _from_--- this connection (socket pair) -- the messages are "in transit" on the network +-- this connection (socket pair) -- the messages are "in transit" on the network -- (these tests are done on localhost, so there are in some OS buffer). Then when -- A opens the second connection (socket pair) B will spawn a new thread for this -- connection, and hence might start interleaving messages from the first and second--- connection. --- +-- connection.+-- -- This is correct behaviour, however: the transport API guarantees reliability and -- ordering _per connection_, but not _across_ connections. testCloseReopen :: Transport -> Int -> IO ()@@ -332,7 +332,7 @@ addrB <- newEmptyMVar doneB <- newEmptyMVar - let numRepeats = 2 :: Int + let numRepeats = 2 :: Int -- A forkTry $ do@@ -342,7 +342,7 @@ tlog "A connecting" -- Connect to B Right conn <- readMVar addrB >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints- + tlog "A pinging" -- Say hi forM_ [1 .. numPings] $ \j -> send conn [pack $ "ping" ++ show i ++ "/" ++ show j]@@ -372,12 +372,12 @@ testParallelConnects :: Transport -> Int -> IO () testParallelConnects transport numPings = do server <- spawn transport echoServer- done <- newEmptyMVar + done <- newEmptyMVar Right endpoint <- newEndPoint transport -- Spawn lots of clients- forM_ [1 .. numPings] $ \i -> forkTry $ do + forM_ [1 .. numPings] $ \i -> forkTry $ do Right conn <- connect endpoint server ReliableOrdered defaultConnectHints send conn [pack $ "ping" ++ show i] send conn [pack $ "ping" ++ show i]@@ -386,7 +386,7 @@ forkTry $ do eventss <- collect endpoint (Just (numPings * 4)) Nothing -- Check that no pings got sent to the wrong connection- forM_ eventss $ \(_, [[ping1], [ping2]]) -> + forM_ eventss $ \(_, [[ping1], [ping2]]) -> guard (ping1 == ping2) putMVar done () @@ -405,13 +405,13 @@ replicateM numRepeats $ do Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints- + -- Close the second, but leave the first open; then output on the second -- connection (i.e., on a closed connection while there is still another -- connection open) close conn2 Left (TransportError SendClosed _) <- send conn2 ["ping2"]- + -- Now close the first connection, and output on it (i.e., output while -- there are no lightweight connection at all anymore) close conn1@@ -425,7 +425,7 @@ -- | Test that closing the same connection twice has no effect testCloseTwice :: Transport -> Int -> IO ()-testCloseTwice transport numRepeats = do +testCloseTwice transport numRepeats = do server <- spawn transport echoServer clientDone <- newEmptyMVar @@ -436,11 +436,11 @@ -- We request two lightweight connections Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints- + -- Close the second one twice close conn2 close conn2- + -- Then send a message on the first and close that twice too send conn1 ["ping"] close conn1@@ -448,12 +448,15 @@ -- Verify expected response from the echo server ConnectionOpened cid1 _ _ <- receive endpoint ConnectionOpened cid2 _ _ <- receive endpoint- ConnectionClosed cid2' <- receive endpoint ; True <- return $ cid2' == cid2- Received cid1' ["ping"] <- receive endpoint ; True <- return $ cid1' == cid1 - ConnectionClosed cid1'' <- receive endpoint ; True <- return $ cid1'' == cid1- + -- ordering of the following messages may differ depending of+ -- implementation+ ms <- replicateM 3 $ receive endpoint+ True <- return $ testStreams ms [ [ ConnectionClosed cid2 ]+ , [ Received cid1 ["ping"]+ , ConnectionClosed cid1 ]+ ] return ()- + putMVar clientDone () takeMVar clientDone@@ -471,7 +474,7 @@ -- One thread to write to the endpoint forkTry $ do- tlog $ "writing" + tlog $ "writing" tlog $ "Sending ping" replicateM_ numPings $ send conn ["ping"]@@ -513,17 +516,17 @@ -- One thread to write to the endpoint using the first connection forkTry $ do- tlog $ "writing" + tlog $ "writing" tlog $ "Sending ping" replicateM_ numPings $ send conn1 ["pingA"] tlog $ "Closing connection" close conn1- + -- One thread to write to the endpoint using the second connection forkTry $ do- tlog $ "writing" + tlog $ "writing" tlog $ "Sending ping" replicateM_ numPings $ send conn2 ["pingB"]@@ -554,11 +557,11 @@ Right conn1 <- connect endpoint1 (address endpoint1) ReliableOrdered defaultConnectHints Right conn2 <- connect endpoint1 (address endpoint1) ReliableOrdered defaultConnectHints Right conn3 <- connect endpoint2 (address endpoint2) ReliableOrdered defaultConnectHints- + -- Close the conneciton and try to send close conn1 Left (TransportError SendClosed _) <- send conn1 ["ping"]- + -- Close the first endpoint. We should not be able to use the first -- connection anymore, or open more self connections, but the self connection -- to the second endpoint should still be fine@@ -574,7 +577,7 @@ return () --- | Test various aspects of 'closeEndPoint' +-- | Test various aspects of 'closeEndPoint' testCloseEndPoint :: Transport -> Int -> IO () testCloseEndPoint transport _ = do serverDone <- newEmptyMVar@@ -598,7 +601,7 @@ -- Second test do theirAddr <- readMVar clientAddr2- + ConnectionOpened cid ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr Received cid' ["ping"] <- receive endpoint ; True <- return $ cid == cid' @@ -609,7 +612,7 @@ ErrorEvent (TransportError (EventConnectionLost addr') _) <- receive endpoint ; True <- return $ addr' == theirAddr Left (TransportError SendFailed _) <- send conn ["pong2"]- + return () putMVar serverDone ()@@ -621,7 +624,7 @@ -- First test: close endpoint with one outgoing but no incoming connections do Right endpoint <- newEndPoint transport- putMVar clientAddr1 (address endpoint) + putMVar clientAddr1 (address endpoint) -- Connect to the server, then close the endpoint without disconnecting explicitly Right _ <- connect endpoint theirAddr ReliableOrdered defaultConnectHints@@ -632,7 +635,7 @@ -- Second test: close endpoint with one outgoing and one incoming connection do Right endpoint <- newEndPoint transport- putMVar clientAddr2 (address endpoint) + putMVar clientAddr2 (address endpoint) Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints send conn ["ping"]@@ -641,7 +644,7 @@ ConnectionOpened cid ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr Received cid' ["pong"] <- receive endpoint ; True <- return $ cid == cid' - -- Close the endpoint + -- Close the endpoint closeEndPoint endpoint EndPointClosed <- receive endpoint @@ -677,13 +680,13 @@ Right endpoint <- newEndPoint transport putMVar serverAddr (address endpoint) - -- Client sets up first endpoint + -- Client sets up first endpoint theirAddr1 <- readMVar clientAddr1 ConnectionOpened cid1 ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr1 - -- Client sets up second endpoint + -- Client sets up second endpoint theirAddr2 <- readMVar clientAddr2- + ConnectionOpened cid2 ReliableOrdered addr' <- receive endpoint ; True <- return $ addr' == theirAddr2 Received cid2' ["ping"] <- receive endpoint ; True <- return $ cid2' == cid2 @@ -702,7 +705,7 @@ -- An attempt to send to the endpoint should now fail Left (TransportError SendFailed _) <- send conn ["pong2"]- + putMVar serverDone () -- Client@@ -712,14 +715,14 @@ -- Set up endpoint with one outgoing but no incoming connections Right endpoint1 <- newEndPoint transport- putMVar clientAddr1 (address endpoint1) + putMVar clientAddr1 (address endpoint1) -- Connect to the server, then close the endpoint without disconnecting explicitly Right _ <- connect endpoint1 theirAddr ReliableOrdered defaultConnectHints -- Set up an endpoint with one outgoing and out incoming connection Right endpoint2 <- newEndPoint transport- putMVar clientAddr2 (address endpoint2) + putMVar clientAddr2 (address endpoint2) Right conn <- connect endpoint2 theirAddr ReliableOrdered defaultConnectHints send conn ["ping"]@@ -746,7 +749,7 @@ Left (TransportError ConnectFailed _) <- connect endpoint2 theirAddr ReliableOrdered defaultConnectHints -- And finally, so should an attempt to create a new endpoint- Left (TransportError NewEndPointFailed _) <- newEndPoint transport + Left (TransportError NewEndPointFailed _) <- newEndPoint transport putMVar clientDone () @@ -758,7 +761,7 @@ serverAddr <- newEmptyMVar serverClosed <- newEmptyMVar clientDone <- newEmptyMVar- + -- Server forkTry $ do Right endpoint <- newEndPoint transport@@ -770,12 +773,12 @@ -- Client forkTry $ do Right endpoint <- newEndPoint transport- readMVar serverClosed + readMVar serverClosed Left (TransportError ConnectNotFound _) <- readMVar serverAddr >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints putMVar clientDone ()- + takeMVar clientDone -- | We should receive an exception when doing a 'receive' after we have been@@ -783,7 +786,7 @@ testExceptionOnReceive :: IO (Either String Transport) -> IO () testExceptionOnReceive newTransport = do Right transport <- newTransport- + -- Test one: when we close an endpoint specifically Right endpoint1 <- newEndPoint transport closeEndPoint endpoint1@@ -804,7 +807,7 @@ Right transport <- newTransport Right endpoint1 <- newEndPoint transport Right endpoint2 <- newEndPoint transport- + -- Connect endpoint1 to endpoint2 Right conn <- connect endpoint1 (address endpoint2) ReliableOrdered defaultConnectHints ConnectionOpened _ _ _ <- receive endpoint2@@ -814,7 +817,7 @@ -- This will have been as a failure to send by endpoint1, which will -- therefore have closed the socket. In turn this will have caused endpoint2- -- to report that the connection was lost + -- to report that the connection was lost ErrorEvent (TransportError (EventConnectionLost _) _) <- receive endpoint1 ErrorEvent (TransportError (EventConnectionLost _) _) <- receive endpoint2 @@ -831,27 +834,27 @@ -- | If threads get killed while executing a 'connect', 'send', or 'close', this -- should not affect other threads.--- +-- -- The intention of this test is to see what happens when a asynchronous -- exception happes _while executing a send_. This is exceedingly difficult to -- guarantee, however. Hence we run a large number of tests and insert random -- thread delays -- and even then it might not happen. Moreover, it will only--- happen when we run on multiple cores. +-- happen when we run on multiple cores. testKill :: IO (Either String Transport) -> Int -> IO () testKill newTransport numThreads = do Right transport1 <- newTransport Right transport2 <- newTransport Right endpoint1 <- newEndPoint transport1 Right endpoint2 <- newEndPoint transport2- - threads <- replicateM numThreads . forkIO $ do - randomThreadDelay 100 ++ threads <- replicateM numThreads . forkIO $ do+ randomThreadDelay 100 bracket (connect endpoint1 (address endpoint2) ReliableOrdered defaultConnectHints)- -- Note that we should not insert a randomThreadDelay into the + -- Note that we should not insert a randomThreadDelay into the -- exception handler itself as this means that the exception handler -- could be interrupted and we might not close (\(Right conn) -> close conn)- (\(Right conn) -> do randomThreadDelay 100 + (\(Right conn) -> do randomThreadDelay 100 Right () <- send conn ["ping"] randomThreadDelay 100) @@ -861,26 +864,26 @@ forkIO . forM_ threads $ \tid -> do shouldKill <- randomIO if shouldKill- then randomThreadDelay 600 >> killThread tid + then randomThreadDelay 600 >> killThread tid else modifyMVar_ numAlive (return . (+ 1)) -- Since it is impossible to predict when the kill exactly happens, we don't -- know how many connects were opened and how many pings were sent. But we -- should not have any open connections (if we do, collect will throw an -- error) and we should have at least the number of pings equal to the number- -- of threads we did *not* kill - eventss <- collect endpoint2 Nothing (Just 1000000) + -- of threads we did *not* kill+ eventss <- collect endpoint2 Nothing (Just 1000000) let actualPings = sum . map (length . snd) $ eventss expectedPings <- takeMVar numAlive- unless (actualPings >= expectedPings) $ + unless (actualPings >= expectedPings) $ throwIO (userError "Missing pings")- + -- print (actualPings, expectedPings) -- | Set up conditions with a high likelyhood of "crossing" (for transports -- that multiplex lightweight connections across heavyweight connections)-testCrossing :: Transport -> Int -> IO () +testCrossing :: Transport -> Int -> IO () testCrossing transport numRepeats = do [aAddr, bAddr] <- replicateM 2 newEmptyMVar [aDone, bDone] <- replicateM 2 newEmptyMVar@@ -902,10 +905,10 @@ -- Because we are creating lots of connections, it's possible that -- connect times out (for instance, in the TCP transport, -- Network.Socket.connect may time out). We shouldn't regard this as an- -- error in the Transport, though. + -- error in the Transport, though. connectResult <- connect endpoint theirAddress ReliableOrdered hints case connectResult of- Right conn -> close conn + Right conn -> close conn Left (TransportError ConnectTimeout _) -> putMVar aTimeout () Left (TransportError ConnectFailed _) -> readMVar bTimeout Left err -> throwIO . userError $ "testCrossed: " ++ show err@@ -916,23 +919,23 @@ Right endpoint <- newEndPoint transport putMVar bAddr (address endpoint) theirAddress <- readMVar aAddr- + replicateM_ numRepeats $ do takeMVar bGo >> yield connectResult <- connect endpoint theirAddress ReliableOrdered hints case connectResult of- Right conn -> close conn - Left (TransportError ConnectTimeout _) -> putMVar bTimeout () + Right conn -> close conn+ Left (TransportError ConnectTimeout _) -> putMVar bTimeout () Left (TransportError ConnectFailed _) -> readMVar aTimeout Left err -> throwIO . userError $ "testCrossed: " ++ show err putMVar bDone ()- + -- Driver forM_ [1 .. numRepeats] $ \_i -> do -- putStrLn $ "Round " ++ show _i tryTakeMVar aTimeout tryTakeMVar bTimeout- b <- randomIO + b <- randomIO if b then do putMVar aGo () ; putMVar bGo () else do putMVar bGo () ; putMVar aGo () yield@@ -954,15 +957,33 @@ , ("SendAfterClose", testSendAfterClose transport 100) , ("Crossing", testCrossing transport 10) , ("CloseTwice", testCloseTwice transport 100)- , ("ConnectToSelf", testConnectToSelf transport numPings) + , ("ConnectToSelf", testConnectToSelf transport numPings) , ("ConnectToSelfTwice", testConnectToSelfTwice transport numPings) , ("CloseSelf", testCloseSelf newTransport)- , ("CloseEndPoint", testCloseEndPoint transport numPings) + , ("CloseEndPoint", testCloseEndPoint transport numPings) , ("CloseTransport", testCloseTransport newTransport) , ("ConnectClosedEndPoint", testConnectClosedEndPoint transport) , ("ExceptionOnReceive", testExceptionOnReceive newTransport)- , ("SendException", testSendException newTransport) + , ("SendException", testSendException newTransport) , ("Kill", testKill newTransport 1000) ] where numPings = 10000 :: Int+++-- Test that list is a union of stream message, with preserved ordering+-- within each stream.+-- Note: this function may not work if different streams contains equal+-- messages.+testStreams :: Eq a => [a] -> [[a]] -> Bool+testStreams [] ys = all null ys+testStreams (x:xs) ys =+ case go [] ys of+ [] -> False+ ys' -> testStreams xs ys'+ where+ go _ [] = []+ go c ([]:zss) = go c zss+ go c (z'@(z:zs):zss)+ | x == z = (zs:c)++zss+ | otherwise = go (z':c) zss
src/Network/Transport/Tests/Auxiliary.hs view
@@ -30,7 +30,7 @@ import Network.Transport.Tests.Traced (Traceable(..), traceShow) -- | Like fork, but throw exceptions in the child thread to the parent-forkTry :: IO () -> IO ThreadId +forkTry :: IO () -> IO ThreadId forkTry p = do tid <- myThreadId forkIO $ catch p (\e -> throwTo tid (e :: SomeException))@@ -40,17 +40,17 @@ trySome = try -- | Run the given test, catching timeouts and exceptions-runTest :: String -> IO () -> IO Bool +runTest :: String -> IO () -> IO Bool runTest description test = do putStr $ "Running " ++ show description ++ ": " hFlush stdout done <- try . timeout 60000000 $ test -- 60 seconds case done of- Left err -> failed $ "(exception: " ++ show (err :: SomeException) ++ ")" + Left err -> failed $ "(exception: " ++ show (err :: SomeException) ++ ")" Right Nothing -> failed $ "(timeout)"- Right (Just ()) -> ok + Right (Just ()) -> ok where- failed :: String -> IO Bool + failed :: String -> IO Bool failed err = do setSGR [SetColor Foreground Vivid Red] putStr "failed "@@ -58,43 +58,43 @@ putStrLn err return False - ok :: IO Bool + ok :: IO Bool ok = do setSGR [SetColor Foreground Vivid Green] putStrLn "ok" setSGR [Reset] return True --- | Run a bunch of tests and throw an exception if any fails +-- | Run a bunch of tests and throw an exception if any fails runTests :: [(String, IO ())] -> IO () runTests tests = do success <- foldr (liftM2 (&&) . uncurry runTest) (return True) $ tests unless success $ fail "Some tests failed" --- | Random thread delay between 0 and the specified max +-- | Random thread delay between 0 and the specified max randomThreadDelay :: Int -> IO () randomThreadDelay maxDelay = do delay <- randomIO :: IO Int- threadDelay (delay `mod` maxDelay) + threadDelay (delay `mod` maxDelay) ----------------------------------------------------------------------------------- traceShow instances -- +-- traceShow instances -- -------------------------------------------------------------------------------- instance Traceable EndPoint where trace = const Nothing instance Traceable Transport where- trace = const Nothing + trace = const Nothing instance Traceable Connection where- trace = const Nothing + trace = const Nothing instance Traceable Event where- trace = traceShow + trace = traceShow instance Show err => Traceable (TransportError err) where- trace = traceShow + trace = traceShow instance Traceable EndPointAddress where trace = traceShow . endPointAddressToByteString
src/Network/Transport/Tests/Multicast.hs view
@@ -10,10 +10,10 @@ -- | Node for the "No confusion" test noConfusionNode :: Transport -- ^ Transport- -> [MVar MulticastAddress] -- ^ my group : groups to subscribe to + -> [MVar MulticastAddress] -- ^ my group : groups to subscribe to -> [MVar ()] -- ^ I'm ready : others ready -> Int -- ^ number of pings- -> [ByteString] -- ^ my message : messages from subscribed groups (same order as 'groups to subscribe to') + -> [ByteString] -- ^ my message : messages from subscribed groups (same order as 'groups to subscribe to') -> MVar () -- ^ I'm done -> IO () noConfusionNode transport groups ready numPings msgs done = do@@ -25,8 +25,8 @@ putMVar (head groups) (multicastAddress myGroup) -- Subscribe to the given multicast groups- addrs <- mapM readMVar (tail groups) - forM_ addrs $ \addr -> do Right group <- resolveMulticastGroup endpoint addr + addrs <- mapM readMVar (tail groups)+ forM_ addrs $ \addr -> do Right group <- resolveMulticastGroup endpoint addr multicastSubscribe group -- Indicate that we're ready and wait for everybody else to be ready@@ -42,31 +42,31 @@ case event of ReceivedMulticast addr [msg] -> let mix = addr `elemIndex` addrs in- case mix of + case mix of Nothing -> error "Message from unexpected source" Just ix -> when (msgs !! (ix + 1) /= msg) $ error "Unexpected message" _ -> error "Unexpected event" -- Success- putMVar done () + putMVar done () -- | Test that distinct multicast groups are not confused-testNoConfusion :: Transport -> Int -> IO () +testNoConfusion :: Transport -> Int -> IO () testNoConfusion transport numPings = do [group1, group2, group3] <- replicateM 3 newEmptyMVar [readyA, readyB, readyC] <- replicateM 3 newEmptyMVar [doneA, doneB, doneC] <- replicateM 3 newEmptyMVar let [msgA, msgB, msgC] = ["A says hi", "B says hi", "C says hi"] - forkIO $ noConfusionNode transport [group1, group1, group2] [readyA, readyB, readyC] numPings [msgA, msgA, msgB] doneA - forkIO $ noConfusionNode transport [group2, group1, group3] [readyB, readyC, readyA] numPings [msgB, msgA, msgC] doneB - forkIO $ noConfusionNode transport [group3, group2, group3] [readyC, readyA, readyB] numPings [msgC, msgB, msgC] doneC - - mapM_ takeMVar [doneA, doneB, doneC] + forkIO $ noConfusionNode transport [group1, group1, group2] [readyA, readyB, readyC] numPings [msgA, msgA, msgB] doneA+ forkIO $ noConfusionNode transport [group2, group1, group3] [readyB, readyC, readyA] numPings [msgB, msgA, msgC] doneB+ forkIO $ noConfusionNode transport [group3, group2, group3] [readyC, readyA, readyB] numPings [msgC, msgB, msgC] doneC + mapM_ takeMVar [doneA, doneB, doneC]+ -- | Test multicast-testMulticast :: Transport -> IO () -testMulticast transport = - runTests +testMulticast :: Transport -> IO ()+testMulticast transport =+ runTests [ ("NoConfusion", testNoConfusion transport 10000) ]
src/Network/Transport/Tests/Traced.hs view
@@ -1,7 +1,7 @@--- | Add tracing to the IO monad (see examples). --- +-- | Add tracing to the IO monad (see examples).+-- -- [Usage]--- +-- -- > {-# LANGUAGE RebindableSyntax #-} -- > import Prelude hiding (catch, (>>=), (>>), return, fail) -- > import Traced@@ -15,7 +15,7 @@ -- > Right y <- return (Left 2 :: Either Int Int) -- > return (x + y) ----- outputs +-- outputs -- -- > Hello world -- > *** Exception: user error (Pattern match failure in do expression at Traced.hs:187:3-9)@@ -31,7 +31,7 @@ -- > test2 = do -- > Left x <- return (Left 1 :: Either Int Int) -- > True <- return (x == 3)--- > return x +-- > return x -- -- The advantage of this idiom is that it gives you line number information when the guard fails: --@@ -39,7 +39,7 @@ -- > *** Exception: user error (Pattern match failure in do expression at Traced.hs:193:3-6) -- > Trace: -- > 0 Left 1-module Network.Transport.Tests.Traced +module Network.Transport.Tests.Traced ( MonadS(..) , return , (>>=)@@ -51,7 +51,7 @@ , traceShow ) where -import Prelude hiding +import Prelude hiding ( (>>=) , return , fail@@ -76,12 +76,12 @@ -- | Like 'Monad' but bind is only defined for 'Trace'able instances class MonadS m where- returnS :: a -> m a + returnS :: a -> m a bindS :: Traceable a => m a -> (a -> m b) -> m b failS :: String -> m a seqS :: m a -> m b -> m b --- | Redefinition of 'Prelude.>>=' +-- | Redefinition of 'Prelude.>>=' (>>=) :: (MonadS m, Traceable a) => m a -> (a -> m b) -> m b (>>=) = bindS @@ -95,7 +95,7 @@ -- | Redefinition of 'Prelude.fail' fail :: MonadS m => String -> m a-fail = failS +fail = failS -------------------------------------------------------------------------------- -- Trace typeclass (for adding elements to a trace --@@ -106,17 +106,17 @@ instance Show Showable where show (Showable x) = show x -mapShowable :: (forall a. Show a => a -> Showable) -> Showable -> Showable -mapShowable f (Showable x) = f x +mapShowable :: (forall a. Show a => a -> Showable) -> Showable -> Showable+mapShowable f (Showable x) = f x traceShow :: Show a => a -> Maybe Showable-traceShow = Just . Showable +traceShow = Just . Showable class Traceable a where- trace :: a -> Maybe Showable + trace :: a -> Maybe Showable instance (Traceable a, Traceable b) => Traceable (Either a b) where- trace (Left x) = (mapShowable $ Showable . (Left :: forall c. c -> Either c ())) <$> trace x + trace (Left x) = (mapShowable $ Showable . (Left :: forall c. c -> Either c ())) <$> trace x trace (Right y) = (mapShowable $ Showable . (Right :: forall c. c -> Either () c)) <$> trace y instance (Traceable a, Traceable b) => Traceable (a, b) where@@ -128,7 +128,7 @@ instance (Traceable a, Traceable b, Traceable c) => Traceable (a, b, c) where trace (x, y, z) = case (trace x, trace y, trace z) of- (Nothing, Nothing, Nothing) -> Nothing + (Nothing, Nothing, Nothing) -> Nothing (Just t1, Nothing, Nothing) -> traceShow t1 (Nothing, Just t2, Nothing) -> traceShow t2 (Just t1, Just t2, Nothing) -> traceShow (t1, t2)@@ -139,40 +139,40 @@ instance Traceable a => Traceable (Maybe a) where trace Nothing = traceShow (Nothing :: Maybe ())- trace (Just x) = mapShowable (Showable . Just) <$> trace x + trace (Just x) = mapShowable (Showable . Just) <$> trace x instance Traceable a => Traceable [a] where- trace = traceShow . catMaybes . map trace + trace = traceShow . catMaybes . map trace instance Traceable () where- trace = const Nothing + trace = const Nothing instance Traceable Int where- trace = traceShow + trace = traceShow instance Traceable Int32 where- trace = traceShow + trace = traceShow instance Traceable Int64 where- trace = traceShow + trace = traceShow instance Traceable Word32 where- trace = traceShow + trace = traceShow instance Traceable Word64 where- trace = traceShow + trace = traceShow instance Traceable Bool where- trace = const Nothing + trace = const Nothing instance Traceable ByteString where- trace = traceShow + trace = traceShow instance Traceable (MVar a) where- trace = const Nothing + trace = const Nothing instance Traceable [Char] where- trace = traceShow + trace = traceShow instance Traceable IOException where trace = traceShow@@ -186,7 +186,7 @@ instance Exception TracedException --- | Add tracing to 'IO' (see examples) +-- | Add tracing to 'IO' (see examples) instance MonadS IO where returnS = Prelude.return bindS = \x f -> x Prelude.>>= \a -> catches (f a) (traceHandlers a)@@ -194,7 +194,7 @@ seqS = (Prelude.>>) instance Show TracedException where- show (TracedException ts ex) = + show (TracedException ts ex) = show ex ++ "\nTrace:\n" ++ unlines (map (\(i, t) -> show i ++ "\t" ++ t) (zip ([0..] :: [Int]) (take 10 . reverse $ ts))) traceHandlers :: Traceable a => a -> [Handler b]@@ -204,7 +204,7 @@ , Handler $ \ex -> throwIO $ TracedException [show t] (ex :: SomeException) ] --- | Definition of 'ifThenElse' for use with RebindableSyntax +-- | Definition of 'ifThenElse' for use with RebindableSyntax ifThenElse :: Bool -> a -> a -> a ifThenElse True x _ = x ifThenElse False _ y = y