git.iko.soy/distributed-process
on master help sign in
Test sending an exceptional value
c69a77fEdsko de Vries
network-transport/tests/TestAuxiliary.hs+9
compare with master
unifiedsplit
@@ -4,10 +4,12 @@ module TestAuxiliary ( -- Running tests
4 , runTests
4 , runTests
5 -- Writing tests
5 -- Writing tests
6 , forkTry
6 , forkTry
7+ , trySome
7 ) where
8 ) where
8
9
9import Prelude hiding (catch)
10import Prelude hiding (catch)
10import Control.Concurrent (myThreadId, forkIO, ThreadId, throwTo)
11import Control.Concurrent (myThreadId, forkIO, ThreadId, throwTo)
12+import Control.Concurrent.Chan (Chan)
11import Control.Monad (liftM2, unless)
13import Control.Monad (liftM2, unless)
12import Control.Exception (SomeException, try, catch)
14import Control.Exception (SomeException, try, catch)
13import System.Timeout (timeout)
15import System.Timeout (timeout)
@@ -27,6 +29,10 @@ forkTry p = do
27 tid <- myThreadId
29 tid <- myThreadId
28 forkIO $ catch p (\e -> throwTo tid (e :: SomeException))
30 forkIO $ catch p (\e -> throwTo tid (e :: SomeException))
29
31
32+-- | Like try, but specialized to SomeException
33+trySome :: IO a -> IO (Either SomeException a)
34+trySome = try
35+
30-- | Run the given test, catching timeouts and exceptions
36-- | Run the given test, catching timeouts and exceptions
31runTest :: String -> IO () -> IO Bool
37runTest :: String -> IO () -> IO Bool
32runTest description test = do
38runTest description test = do
@@ -86,3 +92,6 @@ instance Traceable SomeException where
86
92
87instance Traceable ThreadId where
93instance Traceable ThreadId where
88 trace = const Nothing
94 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 @@
2module TestTransport where
2module TestTransport where
3
3
4import Prelude hiding (catch, (>>=), (>>), return, fail)
4import Prelude hiding (catch, (>>=), (>>), return, fail)
5−import TestAuxiliary (forkTry, runTests)
5+import TestAuxiliary (forkTry, runTests, trySome)
6import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar, readMVar)
6import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar, readMVar)
7−import Control.Exception (evaluate, try, SomeException)
7+import Control.Exception (evaluate, throw)
8import Control.Monad (replicateM, replicateM_, when, guard, forM_)
8import Control.Monad (replicateM, replicateM_, when, guard, forM_)
9import Control.Monad.Error ()
9import Control.Monad.Error ()
10import Network.Transport hiding (connect)
10import Network.Transport hiding (connect)
@@ -745,13 +745,43 @@ testExceptionOnReceive newTransport = do
745 Right endpoint1 <- newEndPoint transport
745 Right endpoint1 <- newEndPoint transport
746 closeEndPoint endpoint1
746 closeEndPoint endpoint1
747 EndPointClosed <- receive endpoint1
747 EndPointClosed <- receive endpoint1
748− Left _ <- (try :: IO a -> IO (Either SomeException a)) (receive endpoint1 >>= evaluate)
748+ Left _ <- trySome (receive endpoint1 >>= evaluate)
749
749
750 -- Test two: when we close the entire transport
750 -- Test two: when we close the entire transport
751 Right endpoint2 <- newEndPoint transport
751 Right endpoint2 <- newEndPoint transport
752 closeTransport transport
752 closeTransport transport
753 EndPointClosed <- receive endpoint2
753 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
755
785
756 return ()
786 return ()
757
787
@@ -775,6 +805,7 @@ testTransport newTransport = do
775 , ("CloseTransport", testCloseTransport newTransport)
805 , ("CloseTransport", testCloseTransport newTransport)
776 , ("ConnectClosedEndPoint", testConnectClosedEndPoint transport)
806 , ("ConnectClosedEndPoint", testConnectClosedEndPoint transport)
777 , ("ExceptionOnReceive", testExceptionOnReceive newTransport)
807 , ("ExceptionOnReceive", testExceptionOnReceive newTransport)
808+ , ("SendException", testSendException newTransport)
778 ]
809 ]
779 where
810 where
780 numPings = 10000 :: Int
811 numPings = 10000 :: Int