git.iko.soy/distributed-process
on master help sign in
Test sending an exceptional value
commitc69a77fb3002dcda2a10e93ec44a523d020e7331 authorEdsko de Vries <edsko@edsko.net> dateThu 24 May 2012, 13:16 (14 years ago) parentd714295
2 files changed+44−4
compare with master
unifiedsplit
network-transport/tests/TestAuxiliary.hs+9 network-transport/tests/TestTransport.hs+35−4
network-transport/tests/TestAuxiliary.hs+9
@@ -4,10 +4,12 @@ module TestAuxiliary ( -- Running tests
44 , runTests
55 -- Writing tests
66 , forkTry
7+ , trySome
78 ) where
89
910import Prelude hiding (catch)
1011import Control.Concurrent (myThreadId, forkIO, ThreadId, throwTo)
12+import Control.Concurrent.Chan (Chan)
1113import Control.Monad (liftM2, unless)
1214import Control.Exception (SomeException, try, catch)
1315import System.Timeout (timeout)
@@ -27,6 +29,10 @@ forkTry p = do
2729 tid <- myThreadId
2830 forkIO $ catch p (\e -> throwTo tid (e :: SomeException))
2931
32+-- | Like try, but specialized to SomeException
33+trySome :: IO a -> IO (Either SomeException a)
34+trySome = try
35+
3036-- | Run the given test, catching timeouts and exceptions
3137runTest :: String -> IO () -> IO Bool
3238runTest description test = do
@@ -86,3 +92,6 @@ instance Traceable SomeException where
8692
8793instance Traceable ThreadId where
8894 trace = const Nothing
95+
96+instance Traceable (Chan a) where
97+ trace = const Nothing
network-transport/tests/TestTransport.hs+35−4
@@ -2,9 +2,9 @@
22module TestTransport where
33
44import Prelude hiding (catch, (>>=), (>>), return, fail)
5−import TestAuxiliary (forkTry, runTests)
5+import TestAuxiliary (forkTry, runTests, trySome)
66import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar, readMVar)
7−import Control.Exception (evaluate, try, SomeException)
7+import Control.Exception (evaluate, throw)
88import Control.Monad (replicateM, replicateM_, when, guard, forM_)
99import Control.Monad.Error ()
1010import Network.Transport hiding (connect)
@@ -745,13 +745,43 @@ testExceptionOnReceive newTransport = do
745745 Right endpoint1 <- newEndPoint transport
746746 closeEndPoint endpoint1
747747 EndPointClosed <- receive endpoint1
748− Left _ <- (try :: IO a -> IO (Either SomeException a)) (receive endpoint1 >>= evaluate)
748+ Left _ <- trySome (receive endpoint1 >>= evaluate)
749749
750750 -- Test two: when we close the entire transport
751751 Right endpoint2 <- newEndPoint transport
752752 closeTransport transport
753753 EndPointClosed <- receive endpoint2
754− Left _ <- (try :: IO a -> IO (Either SomeException a)) (receive endpoint2 >>= evaluate)
754+ Left _ <- trySome (receive endpoint2 >>= evaluate)
755+
756+ return ()
757+
758+testSendException :: IO (Either String Transport) -> IO ()
759+testSendException newTransport = do
760+ Right transport <- newTransport
761+ Right endpoint1 <- newEndPoint transport
762+ Right endpoint2 <- newEndPoint transport
763+
764+ -- Connect endpoint1 to endpoint2
765+ Right conn <- connect endpoint1 (address endpoint2) ReliableOrdered
766+ ConnectionOpened _ _ _ <- receive endpoint2
767+
768+ -- Send an exceptional value
769+ Left (TransportError SendFailed _) <- send conn (throw $ userError "uhoh")
770+
771+ -- This will have been as a failure to send by endpoint1, which will
772+ -- therefore have closed the socket. In turn this will have caused endpoint2
773+ -- to report that the connection was lost
774+ ErrorEvent (TransportError (EventConnectionLost _ []) _) <- receive endpoint1
775+ ErrorEvent (TransportError (EventConnectionLost _ [_]) _) <- receive endpoint2
776+
777+ -- A new connection will re-establish the connection
778+ Right conn2 <- connect endpoint1 (address endpoint2) ReliableOrdered
779+ send conn2 ["ping"]
780+ close conn2
781+
782+ ConnectionOpened _ _ _ <- receive endpoint2
783+ Received _ ["ping"] <- receive endpoint2
784+ ConnectionClosed _ <- receive endpoint2
755785
756786 return ()
757787
@@ -775,6 +805,7 @@ testTransport newTransport = do
775805 , ("CloseTransport", testCloseTransport newTransport)
776806 , ("ConnectClosedEndPoint", testConnectClosedEndPoint transport)
777807 , ("ExceptionOnReceive", testExceptionOnReceive newTransport)
808+ , ("SendException", testSendException newTransport)
778809 ]
779810 where
780811 numPings = 10000 :: Int