@@ -598,21 +598,125 @@ testCloseEndPoint transport _ = do
598598
599599 mapM_ takeMVar [serverDone, clientDone]
600600
601+-- Test closeTransport
602+--
603+-- This tests many of the same things that testEndPoint does, and some more
604+testCloseTransport :: IO (Either String Transport) -> IO ()
605+testCloseTransport newTransport = do
606+ serverDone <- newEmptyMVar
607+ clientDone <- newEmptyMVar
608+ clientAddr1 <- newEmptyMVar
609+ clientAddr2 <- newEmptyMVar
610+ serverAddr <- newEmptyMVar
611+
612+ -- Server
613+ forkTry $ do
614+ Right transport <- newTransport
615+ Right endpoint <- newEndPoint transport
616+ putMVar serverAddr (address endpoint)
617+
618+ -- Client sets up first endpoint
619+ theirAddr1 <- readMVar clientAddr1
620+ ConnectionOpened cid1 ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr1
621+
622+ -- Client sets up second endpoint
623+ theirAddr2 <- readMVar clientAddr2
624+
625+ ConnectionOpened cid2 ReliableOrdered addr' <- receive endpoint ; True <- return $ addr' == theirAddr2
626+ Received cid2' ["ping"] <- receive endpoint ; True <- return $ cid2' == cid2
627+
628+ Right conn <- connect endpoint theirAddr2 ReliableOrdered
629+ send conn ["pong"]
630+
631+ -- Client now closes down its transport. We should receive connection closed messages
632+ -- TODO: this assumes a certain ordering on the messages we receive; that's not guaranteed
633+ ConnectionClosed cid2'' <- receive endpoint ; True <- return $ cid2'' == cid2
634+ ErrorEvent (ErrorEventConnectionLost addr'' []) <- receive endpoint ; True <- return $ addr'' == theirAddr2
635+ ConnectionClosed cid1' <- receive endpoint ; True <- return $ cid1' == cid1
636+
637+ -- An attempt to send to the endpoint should now fail
638+ Left (FailedWith SendConnectionClosed _) <- send conn ["pong2"]
639+
640+ putMVar serverDone ()
641+
642+ -- Client
643+ forkTry $ do
644+ Right transport <- newTransport
645+ theirAddr <- readMVar serverAddr
646+
647+ -- Set up endpoint with one outgoing but no incoming connections
648+ Right endpoint1 <- newEndPoint transport
649+ putMVar clientAddr1 (address endpoint1)
650+
651+ -- Connect to the server, then close the endpoint without disconnecting explicitly
652+ Right _ <- connect endpoint1 theirAddr ReliableOrdered
653+
654+ -- Set up an endpoint with one outgoing and out incoming connection
655+ Right endpoint2 <- newEndPoint transport
656+ putMVar clientAddr2 (address endpoint2)
657+
658+ Right conn <- connect endpoint2 theirAddr ReliableOrdered
659+ send conn ["ping"]
660+
661+ -- Reply from the server
662+ ConnectionOpened cid ReliableOrdered addr <- receive endpoint2 ; True <- return $ addr == theirAddr
663+ Received cid' ["pong"] <- receive endpoint2 ; True <- return $ cid == cid'
664+
665+ -- Now shut down the entire transport
666+ closeTransport transport
667+
668+ -- Both endpoints should report an error
669+ ErrorEvent (ErrorEventEndPointClosed []) <- receive endpoint1
670+ ErrorEvent (ErrorEventEndPointClosed [cid'']) <- receive endpoint2; True <- return $ cid == cid''
671+
672+ -- Attempt to send should fail with connection closed
673+ Left (FailedWith SendConnectionClosed _) <- send conn ["ping2"]
674+
675+ -- An attempt to close the already closed connection should just return
676+ () <- close conn
677+
678+ -- And so should an attempt to connect on either endpoint
679+ Left (FailedWith ConnectFailed _) <- connect endpoint1 theirAddr ReliableOrdered
680+ Left (FailedWith ConnectFailed _) <- connect endpoint2 theirAddr ReliableOrdered
681+
682+ -- And finally, so should an attempt to create a new endpoint
683+ Left (FailedWith NewEndPointTransportFailure _) <- newEndPoint transport
684+
685+ putMVar clientDone ()
686+
687+ mapM_ takeMVar [serverDone, clientDone]
688+
689+testMany :: IO (Either String Transport) -> IO ()
690+testMany newTransport = do
691+ Right masterTransport <- newTransport
692+ Right masterEndPoint <- newEndPoint masterTransport
693+
694+ replicateM_ 20 $ do
695+ Right transport <- newTransport
696+ replicateM_ 2 $ do
697+ Right endpoint <- newEndPoint transport
698+ Right _ <- connect endpoint (address masterEndPoint) ReliableOrdered
699+ return ()
700+
601701-- Transport tests
602−testTransport :: Transport -> IO ()
603−testTransport transport = runTests
604− [ ("PingPong", testPingPong transport numPings)
605− , ("EndPoints", testEndPoints transport numPings)
606− , ("Connections", testConnections transport numPings)
607− , ("CloseOneConnection", testCloseOneConnection transport numPings)
608− , ("CloseOneDirection", testCloseOneDirection transport numPings)
609− , ("CloseReopen", testCloseReopen transport numPings)
610− , ("ParallelConnects", testParallelConnects transport numPings)
611− , ("SendAfterClose", testSendAfterClose transport numPings)
612− , ("CloseTwice", testCloseTwice transport numPings)
613− , ("ConnectToSelf", testConnectToSelf transport numPings)
614− , ("ConnectToSelfTwice", testConnectToSelfTwice transport numPings)
615− , ("CloseEndPoint", testCloseEndPoint transport numPings)
616− ]
702+testTransport :: IO (Either String Transport) -> IO ()
703+testTransport newTransport = do
704+ Right transport <- newTransport
705+ runTests
706+ [ ("Many", testMany newTransport)
707+ , ("PingPong", testPingPong transport numPings)
708+ , ("EndPoints", testEndPoints transport numPings)
709+ , ("Connections", testConnections transport numPings)
710+ , ("CloseOneConnection", testCloseOneConnection transport numPings)
711+ , ("CloseOneDirection", testCloseOneDirection transport numPings)
712+ , ("CloseReopen", testCloseReopen transport numPings)
713+ , ("ParallelConnects", testParallelConnects transport numPings)
714+ , ("SendAfterClose", testSendAfterClose transport numPings)
715+ , ("CloseTwice", testCloseTwice transport numPings)
716+ , ("ConnectToSelf", testConnectToSelf transport numPings)
717+ , ("ConnectToSelfTwice", testConnectToSelfTwice transport numPings)
718+ , ("CloseEndPoint", testCloseEndPoint transport numPings)
719+ , ("CloseTransport", testCloseTransport newTransport)
720+ ]
617721 where
618722 numPings = 10000 :: Int