@@ -2,20 +2,23 @@
22module TestTransport where
33
44import Prelude hiding (catch, (>>=), (>>), return, fail)
5−import TestAuxiliary (forkTry, runTests, trySome)
5+import TestAuxiliary (forkTry, runTests, trySome, randomThreadDelay)
6+import Control.Concurrent (forkIO, killThread)
67import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar, readMVar)
78import Control.Exception (evaluate, throw)
8−import Control.Monad (replicateM, replicateM_, when, guard, forM_)
9+import Control.Monad (replicateM, replicateM_, when, guard, forM, forM_)
910import Control.Monad.Error ()
1011import Network.Transport hiding (connect)
1112import qualified Network.Transport as NT
1213import Network.Transport.Internal (tlog)
1314import Network.Transport.Util (spawn)
15+import System.Random (randomIO)
1416import Data.ByteString (ByteString)
1517import Data.ByteString.Char8 (pack)
1618import Data.Map (Map)
1719import qualified Data.Map as Map (empty, insert, delete, findWithDefault, adjust, null, toList, map)
1820import Data.String (fromString)
21+import Data.Maybe (catMaybes)
1922import Traced
2023
2124-- | We overload connect to always pass the default hints
@@ -648,9 +651,9 @@ testCloseTransport newTransport = do
648651
649652 -- Client now closes down its transport. We should receive connection closed messages
650653 -- TODO: this assumes a certain ordering on the messages we receive; that's not guaranteed
654+ ConnectionClosed cid1' <- receive endpoint ; True <- return $ cid1' == cid1
651655 ConnectionClosed cid2'' <- receive endpoint ; True <- return $ cid2'' == cid2
652656 ErrorEvent (TransportError (EventConnectionLost addr'' []) _) <- receive endpoint ; True <- return $ addr'' == theirAddr2
653− ConnectionClosed cid1' <- receive endpoint ; True <- return $ cid1' == cid1
654657
655658 -- An attempt to send to the endpoint should now fail
656659 Left (TransportError SendClosed _) <- send conn ["pong2"]
@@ -755,6 +758,7 @@ testExceptionOnReceive newTransport = do
755758
756759 return ()
757760
761+-- | Test what happens when the argument to 'send' is an exceptional value
758762testSendException :: IO (Either String Transport) -> IO ()
759763testSendException newTransport = do
760764 Right transport <- newTransport
@@ -785,6 +789,52 @@ testSendException newTransport = do
785789
786790 return ()
787791
792+-- | If threads get killed while executing a 'connect', 'send', or 'close', this
793+-- should not affect other threads.
794+--
795+-- The intention of this test is to see what happens when a asynchronous
796+-- exception happes _while executing a send, connect, or close_. This is
797+-- exceedingly difficult to guarantee, however. Hence we run a large number of
798+-- tests and insert random thread delays -- and even then it might not happen.
799+-- Moreover, it will only happen when we run on multiple cores.
800+testKill :: IO (Either String Transport) -> Int -> IO ()
801+testKill newTransport numThreads = do
802+ Right transport1 <- newTransport
803+ Right transport2 <- newTransport
804+ Right endpoint1 <- newEndPoint transport1
805+ Right endpoint2 <- newEndPoint transport2
806+
807+ threads <- forM [1 .. numThreads] $ \_ -> do
808+ done <- newEmptyMVar
809+ tid <- forkIO $ do
810+ randomThreadDelay 10
811+ Right conn <- connect endpoint1 (address endpoint2) ReliableOrdered
812+ randomThreadDelay 10
813+ Right () <- send conn ["ping"]
814+ randomThreadDelay 10
815+ close conn
816+ putMVar done ()
817+
818+ return (tid, done)
819+
820+ -- Kill half of those threads, and wait on the rest
821+ killerDone <- newEmptyMVar
822+ forkIO $ do
823+ wait <- forM threads $ \(tid, done) -> do
824+ shouldKill <- randomIO
825+ if shouldKill
826+ then do
827+ randomThreadDelay 30
828+ killThread tid
829+ return Nothing
830+ else
831+ return (Just done)
832+
833+ mapM_ takeMVar (catMaybes wait)
834+ putMVar killerDone ()
835+
836+ takeMVar killerDone
837+
788838-- Transport tests
789839testTransport :: IO (Either String Transport) -> IO ()
790840testTransport newTransport = do
@@ -806,6 +856,7 @@ testTransport newTransport = do
806856 , ("ConnectClosedEndPoint", testConnectClosedEndPoint transport)
807857 , ("ExceptionOnReceive", testExceptionOnReceive newTransport)
808858 , ("SendException", testSendException newTransport)
859+ , ("Kill", testKill newTransport 100000)
809860 ]
810861 where
811862 numPings = 10000 :: Int