git.iko.soy/distributed-process
on master help sign in
Clean up documentation (move to test-framework)
59f0426Edsko de Vries
distributed-process/distributed-process.cabal+8−4
compare with master
unifiedsplit
@@ -94,8 +94,10 @@ Test-Suite TestCH
94 network-transport >= 0.3 && < 0.4,
94 network-transport >= 0.3 && < 0.4,
95 network-transport-tcp >= 0.3 && < 0.4,
95 network-transport-tcp >= 0.3 && < 0.4,
96 binary >= 0.5 && < 0.7,
96 binary >= 0.5 && < 0.7,
97− network >= 2.3 && < 2.5
97+ network >= 2.3 && < 2.5,
98− Other-modules: TestAuxiliary
98+ HUnit >= 1.2 && < 1.3,
99+ test-framework >= 0.6 && < 0.7,
100+ test-framework-hunit >= 0.2 && < 0.3
99 Extensions: CPP,
101 Extensions: CPP,
100 ScopedTypeVariables,
102 ScopedTypeVariables,
101 DeriveDataTypeable,
103 DeriveDataTypeable,
@@ -114,8 +116,10 @@ Test-Suite TestClosure
114 network-transport >= 0.3 && < 0.4,
116 network-transport >= 0.3 && < 0.4,
115 network-transport-tcp >= 0.3 && < 0.4,
117 network-transport-tcp >= 0.3 && < 0.4,
116 bytestring >= 0.9 && < 0.11,
118 bytestring >= 0.9 && < 0.11,
117− network >= 2.3 && < 2.5
119+ network >= 2.3 && < 2.5,
118− Other-modules: TestAuxiliary
120+ HUnit >= 1.2 && < 1.3,
121+ test-framework >= 0.6 && < 0.7,
122+ test-framework-hunit >= 0.2 && < 0.3
119 Extensions: CPP,
123 Extensions: CPP,
120 ScopedTypeVariables
124 ScopedTypeVariables
121 ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
125 ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
distributed-process/tests/TestAuxiliary.hsdeleted−75
@@ -1,75 +0,0 @@
1−{-# OPTIONS_GHC -fno-warn-orphans #-}
2−module TestAuxiliary ( -- Running tests
3− runTest
4− , runTests
5− -- Writing tests
6− , forkTry
7− , trySome
8− , randomThreadDelay
9− ) where
10−
11−
12−#if ! MIN_VERSION_base(4,6,0)
13−import Prelude hiding (catch)
14−#endif
15−
16−import Control.Concurrent (myThreadId, forkIO, ThreadId, throwTo, threadDelay)
17−import Control.Monad (liftM2, unless)
18−import Control.Exception (SomeException, try, catch)
19−import System.Timeout (timeout)
20−import System.IO (stdout, hFlush)
21−import System.Console.ANSI ( SGR(SetColor, Reset)
22− , Color(Red, Green)
23− , ConsoleLayer(Foreground)
24− , ColorIntensity(Vivid)
25− , setSGR
26− )
27−import System.Random (randomIO)
28−
29−-- | Like fork, but throw exceptions in the child thread to the parent
30−forkTry :: IO () -> IO ThreadId
31−forkTry p = do
32− tid <- myThreadId
33− forkIO $ catch p (\e -> throwTo tid (e :: SomeException))
34−
35−-- | Like try, but specialized to SomeException
36−trySome :: IO a -> IO (Either SomeException a)
37−trySome = try
38−
39−-- | Run the given test, catching timeouts and exceptions
40−runTest :: String -> IO () -> IO Bool
41−runTest description test = do
42− putStr $ "Running " ++ show description ++ ": "
43− hFlush stdout
44− done <- try . timeout 60000000 $ test -- 60 seconds
45− case done of
46− Left err -> failed $ "(exception: " ++ show (err :: SomeException) ++ ")"
47− Right Nothing -> failed "(timeout)"
48− Right (Just ()) -> ok
49− where
50− failed :: String -> IO Bool
51− failed err = do
52− setSGR [SetColor Foreground Vivid Red]
53− putStr "failed "
54− setSGR [Reset]
55− putStrLn err
56− return False
57−
58− ok :: IO Bool
59− ok = do
60− setSGR [SetColor Foreground Vivid Green]
61− putStrLn "ok"
62− setSGR [Reset]
63− return True
64−
65−-- | Run a bunch of tests and throw an exception if any fails
66−runTests :: [(String, IO ())] -> IO ()
67−runTests tests = do
68− success <- foldr (liftM2 (&&) . uncurry runTest) (return True) tests
69− unless success $ fail "Some tests failed"
70−
71−-- | Random thread delay between 0 and the specified max
72−randomThreadDelay :: Int -> IO ()
73−randomThreadDelay maxDelay = do
74− delay <- randomIO :: IO Int
75− threadDelay (delay `mod` maxDelay)
distributed-process/tests/TestCH.hs+141−116
@@ -4,10 +4,11 @@ module Main where
4import Prelude hiding (catch)
4import Prelude hiding (catch)
5#endif
5#endif
6
6
7+
7import Data.Binary (Binary(..))
8import Data.Binary (Binary(..))
8import Data.Typeable (Typeable)
9import Data.Typeable (Typeable)
9import Data.Foldable (forM_)
10import Data.Foldable (forM_)
10−import Control.Concurrent (forkIO, threadDelay)
11+import Control.Concurrent (forkIO, threadDelay, myThreadId, throwTo, ThreadId)
11import Control.Concurrent.MVar
12import Control.Concurrent.MVar
12 ( MVar
13 ( MVar
13 , newEmptyMVar
14 , newEmptyMVar
@@ -16,7 +17,8 @@ import Control.Concurrent.MVar
16 , readMVar
17 , readMVar
17 )
18 )
18import Control.Monad (replicateM_, replicateM, forever)
19import Control.Monad (replicateM_, replicateM, forever)
19−import Control.Exception (throwIO)
20+import Control.Exception (SomeException, throwIO)
21+import qualified Control.Exception as Ex (catch)
20import Control.Applicative ((<$>), (<*>))
22import Control.Applicative ((<$>), (<*>))
21import qualified Network.Transport as NT (Transport, closeEndPoint)
23import qualified Network.Transport as NT (Transport, closeEndPoint)
22import Network.Socket (sClose)
24import Network.Socket (sClose)
@@ -32,7 +34,10 @@ import Control.Distributed.Process.Internal.Types
32 )
34 )
33import Control.Distributed.Process.Node
35import Control.Distributed.Process.Node
34import Control.Distributed.Process.Serializable (Serializable)
36import Control.Distributed.Process.Serializable (Serializable)
35−import TestAuxiliary
37+
38+import Test.HUnit (Assertion)
39+import Test.Framework (Test, defaultMain, testGroup)
40+import Test.Framework.Providers.HUnit (testCase)
36
41
37newtype Ping = Ping ProcessId
42newtype Ping = Ping ProcessId
38 deriving (Typeable, Binary, Show)
43 deriving (Typeable, Binary, Show)
@@ -40,6 +45,16 @@ newtype Ping = Ping ProcessId
40newtype Pong = Pong ProcessId
45newtype Pong = Pong ProcessId
41 deriving (Typeable, Binary, Show)
46 deriving (Typeable, Binary, Show)
42
47
48+--------------------------------------------------------------------------------
49+-- Supporting definitions --
50+--------------------------------------------------------------------------------
51+
52+-- | Like fork, but throw exceptions in the child thread to the parent
53+forkTry :: IO () -> IO ThreadId
54+forkTry p = do
55+ tid <- myThreadId
56+ forkIO $ Ex.catch p (\e -> throwTo tid (e :: SomeException))
57+
43-- | The ping server from the paper
58-- | The ping server from the paper
44ping :: Process ()
59ping :: Process ()
45ping = do
60ping = do
@@ -55,35 +70,32 @@ whereisRemote nid string = do
55 WhereIsReply _ mPid <- expect
70 WhereIsReply _ mPid <- expect
56 return mPid
71 return mPid
57
72
58−-- | Basic ping test
73+data Add = Add ProcessId Double Double deriving (Typeable)
59−testPing :: NT.Transport -> IO ()
74+data Divide = Divide ProcessId Double Double deriving (Typeable)
60−testPing transport = do
75+data DivByZero = DivByZero deriving (Typeable)
61− serverAddr <- newEmptyMVar
62− clientDone <- newEmptyMVar
63−
64− -- Server
65− forkIO $ do
66− localNode <- newLocalNode transport initRemoteTable
67− addr <- forkProcess localNode ping
68− putMVar serverAddr addr
69−
70− -- Client
71− forkIO $ do
72− localNode <- newLocalNode transport initRemoteTable
73− pingServer <- readMVar serverAddr
74
76
75− let numPings = 10000
77+instance Binary Add where
78+ put (Add pid x y) = put pid >> put x >> put y
79+ get = Add <$> get <*> get <*> get
76
80
77− runProcess localNode $ do
81+instance Binary Divide where
78− pid <- getSelfPid
82+ put (Divide pid x y) = put pid >> put x >> put y
79− replicateM_ numPings $ do
83+ get = Divide <$> get <*> get <*> get
80− send pingServer (Pong pid)
81− Ping _ <- expect
82− return ()
83
84
84− putMVar clientDone ()
85+instance Binary DivByZero where
86+ put DivByZero = return ()
87+ get = return DivByZero
85
88
86− takeMVar clientDone
89+-- The math server from the paper
90+math :: Process ()
91+math = do
92+ receiveWait
93+ [ match (\(Add pid x y) -> send pid (x + y))
94+ , matchIf (\(Divide _ _ y) -> y /= 0)
95+ (\(Divide pid x y) -> send pid (x / y))
96+ , match (\(Divide pid _ _) -> send pid DivByZero)
97+ ]
98+ math
87
99
88-- | Monitor or link to a remote node
100-- | Monitor or link to a remote node
89monitorOrLink :: Bool -- ^ 'True' for monitor, 'False' for link
101monitorOrLink :: Bool -- ^ 'True' for monitor, 'False' for link
@@ -125,9 +137,42 @@ monitorTestProcess theirAddr mOrL un reason monitorSetup done =
125 liftIO $ putMVar done ()
137 liftIO $ putMVar done ()
126 )
138 )
127
139
140+--------------------------------------------------------------------------------
141+-- The tests proper --
142+--------------------------------------------------------------------------------
143+
144+-- | Basic ping test
145+testPing :: NT.Transport -> Assertion
146+testPing transport = do
147+ serverAddr <- newEmptyMVar
148+ clientDone <- newEmptyMVar
149+
150+ -- Server
151+ forkIO $ do
152+ localNode <- newLocalNode transport initRemoteTable
153+ addr <- forkProcess localNode ping
154+ putMVar serverAddr addr
155+
156+ -- Client
157+ forkIO $ do
158+ localNode <- newLocalNode transport initRemoteTable
159+ pingServer <- readMVar serverAddr
160+
161+ let numPings = 10000
162+
163+ runProcess localNode $ do
164+ pid <- getSelfPid
165+ replicateM_ numPings $ do
166+ send pingServer (Pong pid)
167+ Ping _ <- expect
168+ return ()
169+
170+ putMVar clientDone ()
171+
172+ takeMVar clientDone
128
173
129-- | Monitor a process on an unreachable node
174-- | Monitor a process on an unreachable node
130−testMonitorUnreachable :: NT.Transport -> Bool -> Bool -> IO ()
175+testMonitorUnreachable :: NT.Transport -> Bool -> Bool -> Assertion
131testMonitorUnreachable transport mOrL un = do
176testMonitorUnreachable transport mOrL un = do
132 deadProcess <- newEmptyMVar
177 deadProcess <- newEmptyMVar
133 done <- newEmptyMVar
178 done <- newEmptyMVar
@@ -147,7 +192,7 @@ testMonitorUnreachable transport mOrL un = do
147 takeMVar done
192 takeMVar done
148
193
149-- | Monitor a process which terminates normally
194-- | Monitor a process which terminates normally
150−testMonitorNormalTermination :: NT.Transport -> Bool -> Bool -> IO ()
195+testMonitorNormalTermination :: NT.Transport -> Bool -> Bool -> Assertion
151testMonitorNormalTermination transport mOrL un = do
196testMonitorNormalTermination transport mOrL un = do
152 monitorSetup <- newEmptyMVar
197 monitorSetup <- newEmptyMVar
153 monitoredProcess <- newEmptyMVar
198 monitoredProcess <- newEmptyMVar
@@ -168,7 +213,7 @@ testMonitorNormalTermination transport mOrL un = do
168 takeMVar done
213 takeMVar done
169
214
170-- | Monitor a process which terminates abnormally
215-- | Monitor a process which terminates abnormally
171−testMonitorAbnormalTermination :: NT.Transport -> Bool -> Bool -> IO ()
216+testMonitorAbnormalTermination :: NT.Transport -> Bool -> Bool -> Assertion
172testMonitorAbnormalTermination transport mOrL un = do
217testMonitorAbnormalTermination transport mOrL un = do
173 monitorSetup <- newEmptyMVar
218 monitorSetup <- newEmptyMVar
174 monitoredProcess <- newEmptyMVar
219 monitoredProcess <- newEmptyMVar
@@ -192,7 +237,7 @@ testMonitorAbnormalTermination transport mOrL un = do
192 takeMVar done
237 takeMVar done
193
238
194-- | Monitor a local process that is already dead
239-- | Monitor a local process that is already dead
195−testMonitorLocalDeadProcess :: NT.Transport -> Bool -> Bool -> IO ()
240+testMonitorLocalDeadProcess :: NT.Transport -> Bool -> Bool -> Assertion
196testMonitorLocalDeadProcess transport mOrL un = do
241testMonitorLocalDeadProcess transport mOrL un = do
197 processDead <- newEmptyMVar
242 processDead <- newEmptyMVar
198 processAddr <- newEmptyMVar
243 processAddr <- newEmptyMVar
@@ -212,7 +257,7 @@ testMonitorLocalDeadProcess transport mOrL un = do
212 takeMVar done
257 takeMVar done
213
258
214-- | Monitor a remote process that is already dead
259-- | Monitor a remote process that is already dead
215−testMonitorRemoteDeadProcess :: NT.Transport -> Bool -> Bool -> IO ()
260+testMonitorRemoteDeadProcess :: NT.Transport -> Bool -> Bool -> Assertion
216testMonitorRemoteDeadProcess transport mOrL un = do
261testMonitorRemoteDeadProcess transport mOrL un = do
217 processDead <- newEmptyMVar
262 processDead <- newEmptyMVar
218 processAddr <- newEmptyMVar
263 processAddr <- newEmptyMVar
@@ -233,7 +278,7 @@ testMonitorRemoteDeadProcess transport mOrL un = do
233 takeMVar done
278 takeMVar done
234
279
235-- | Monitor a process that becomes disconnected
280-- | Monitor a process that becomes disconnected
236−testMonitorDisconnect :: NT.Transport -> Bool -> Bool -> IO ()
281+testMonitorDisconnect :: NT.Transport -> Bool -> Bool -> Assertion
237testMonitorDisconnect transport mOrL un = do
282testMonitorDisconnect transport mOrL un = do
238 processAddr <- newEmptyMVar
283 processAddr <- newEmptyMVar
239 monitorSetup <- newEmptyMVar
284 monitorSetup <- newEmptyMVar
@@ -254,34 +299,8 @@ testMonitorDisconnect transport mOrL un = do
254
299
255 takeMVar done
300 takeMVar done
256
301
257−data Add = Add ProcessId Double Double deriving (Typeable)
258−data Divide = Divide ProcessId Double Double deriving (Typeable)
259−data DivByZero = DivByZero deriving (Typeable)
260−
261−instance Binary Add where
262− put (Add pid x y) = put pid >> put x >> put y
263− get = Add <$> get <*> get <*> get
264−
265−instance Binary Divide where
266− put (Divide pid x y) = put pid >> put x >> put y
267− get = Divide <$> get <*> get <*> get
268−
269−instance Binary DivByZero where
270− put DivByZero = return ()
271− get = return DivByZero
272−
273−math :: Process ()
274−math = do
275− receiveWait
276− [ match (\(Add pid x y) -> send pid (x + y))
277− , matchIf (\(Divide _ _ y) -> y /= 0)
278− (\(Divide pid x y) -> send pid (x / y))
279− , match (\(Divide pid _ _) -> send pid DivByZero)
280− ]
281− math
282−
283-- | Test the math server (i.e., receiveWait)
302-- | Test the math server (i.e., receiveWait)
284−testMath :: NT.Transport -> IO ()
303+testMath :: NT.Transport -> Assertion
285testMath transport = do
304testMath transport = do
286 serverAddr <- newEmptyMVar
305 serverAddr <- newEmptyMVar
287 clientDone <- newEmptyMVar
306 clientDone <- newEmptyMVar
@@ -312,7 +331,7 @@ testMath transport = do
312-- | Send first message (i.e. connect) to an already terminated process
331-- | Send first message (i.e. connect) to an already terminated process
313-- (without monitoring); then send another message to a second process on
332-- (without monitoring); then send another message to a second process on
314-- the same remote node (we're checking that the remote node did not die)
333-- the same remote node (we're checking that the remote node did not die)
315−testSendToTerminated :: NT.Transport -> IO ()
334+testSendToTerminated :: NT.Transport -> Assertion
316testSendToTerminated transport = do
335testSendToTerminated transport = do
317 serverAddr1 <- newEmptyMVar
336 serverAddr1 <- newEmptyMVar
318 serverAddr2 <- newEmptyMVar
337 serverAddr2 <- newEmptyMVar
@@ -342,7 +361,7 @@ testSendToTerminated transport = do
342 takeMVar clientDone
361 takeMVar clientDone
343
362
344-- | Test (non-zero) timeout
363-- | Test (non-zero) timeout
345−testTimeout :: NT.Transport -> IO ()
364+testTimeout :: NT.Transport -> Assertion
346testTimeout transport = do
365testTimeout transport = do
347 localNode <- newLocalNode transport initRemoteTable
366 localNode <- newLocalNode transport initRemoteTable
348 runProcess localNode $ do
367 runProcess localNode $ do
@@ -350,7 +369,7 @@ testTimeout transport = do
350 return ()
369 return ()
351
370
352-- | Test zero timeout
371-- | Test zero timeout
353−testTimeout0 :: NT.Transport -> IO ()
372+testTimeout0 :: NT.Transport -> Assertion
354testTimeout0 transport = do
373testTimeout0 transport = do
355 serverAddr <- newEmptyMVar
374 serverAddr <- newEmptyMVar
356 clientDone <- newEmptyMVar
375 clientDone <- newEmptyMVar
@@ -384,7 +403,7 @@ testTimeout0 transport = do
384 takeMVar clientDone
403 takeMVar clientDone
385
404
386-- | Test typed channels
405-- | Test typed channels
387−testTypedChannels :: NT.Transport -> IO ()
406+testTypedChannels :: NT.Transport -> Assertion
388testTypedChannels transport = do
407testTypedChannels transport = do
389 serverChannel <- newEmptyMVar :: IO (MVar (SendPort (SendPort Bool, Int)))
408 serverChannel <- newEmptyMVar :: IO (MVar (SendPort (SendPort Bool, Int)))
390 clientDone <- newEmptyMVar
409 clientDone <- newEmptyMVar
@@ -410,7 +429,7 @@ testTypedChannels transport = do
410 takeMVar clientDone
429 takeMVar clientDone
411
430
412-- | Test merging receive ports
431-- | Test merging receive ports
413−testMergeChannels :: NT.Transport -> IO ()
432+testMergeChannels :: NT.Transport -> Assertion
414testMergeChannels transport = do
433testMergeChannels transport = do
415 localNode <- newLocalNode transport initRemoteTable
434 localNode <- newLocalNode transport initRemoteTable
416 testFlat localNode True "aaabbbccc"
435 testFlat localNode True "aaabbbccc"
@@ -496,7 +515,7 @@ testMergeChannels transport = do
496 liftIO $ threadDelay 10000 -- Make sure messages have been sent
515 liftIO $ threadDelay 10000 -- Make sure messages have been sent
497 return rport
516 return rport
498
517
499−testTerminate :: NT.Transport -> IO ()
518+testTerminate :: NT.Transport -> Assertion
500testTerminate transport = do
519testTerminate transport = do
501 localNode <- newLocalNode transport initRemoteTable
520 localNode <- newLocalNode transport initRemoteTable
502
521
@@ -510,7 +529,7 @@ testTerminate transport = do
510 True <- return $ ref == ref' && pid == pid' && ex == show ProcessTerminationException
529 True <- return $ ref == ref' && pid == pid' && ex == show ProcessTerminationException
511 return ()
530 return ()
512
531
513−testMonitorNode :: NT.Transport -> IO ()
532+testMonitorNode :: NT.Transport -> Assertion
514testMonitorNode transport = do
533testMonitorNode transport = do
515 [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable
534 [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable
516
535
@@ -522,7 +541,7 @@ testMonitorNode transport = do
522 True <- return $ ref == ref' && nid == localNodeId node1
541 True <- return $ ref == ref' && nid == localNodeId node1
523 return ()
542 return ()
524
543
525−testMonitorChannel :: NT.Transport -> IO ()
544+testMonitorChannel :: NT.Transport -> Assertion
526testMonitorChannel transport = do
545testMonitorChannel transport = do
527 [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable
546 [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable
528 gotNotification <- newEmptyMVar
547 gotNotification <- newEmptyMVar
@@ -543,7 +562,7 @@ testMonitorChannel transport = do
543
562
544 takeMVar gotNotification
563 takeMVar gotNotification
545
564
546−testRegistry :: NT.Transport -> IO ()
565+testRegistry :: NT.Transport -> Assertion
547testRegistry transport = do
566testRegistry transport = do
548 node <- newLocalNode transport initRemoteTable
567 node <- newLocalNode transport initRemoteTable
549
568
@@ -559,7 +578,7 @@ testRegistry transport = do
559 True <- return $ pingServer == pid'
578 True <- return $ pingServer == pid'
560 return ()
579 return ()
561
580
562−testRemoteRegistry :: NT.Transport -> IO ()
581+testRemoteRegistry :: NT.Transport -> Assertion
563testRemoteRegistry transport = do
582testRemoteRegistry transport = do
564 node1 <- newLocalNode transport initRemoteTable
583 node1 <- newLocalNode transport initRemoteTable
565 node2 <- newLocalNode transport initRemoteTable
584 node2 <- newLocalNode transport initRemoteTable
@@ -577,7 +596,7 @@ testRemoteRegistry transport = do
577 True <- return $ pingServer == pid'
596 True <- return $ pingServer == pid'
578 return ()
597 return ()
579
598
580−testSpawnLocal :: NT.Transport -> IO ()
599+testSpawnLocal :: NT.Transport -> Assertion
581testSpawnLocal transport = do
600testSpawnLocal transport = do
582 node <- newLocalNode transport initRemoteTable
601 node <- newLocalNode transport initRemoteTable
583
602
@@ -595,7 +614,7 @@ testSpawnLocal transport = do
595 send pid sport
614 send pid sport
596 expect
615 expect
597
616
598−testReconnect :: NT.Transport -> TransportInternals -> IO ()
617+testReconnect :: NT.Transport -> TransportInternals -> Assertion
599testReconnect transport transportInternals = do
618testReconnect transport transportInternals = do
600 [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable
619 [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable
601 let nid1 = localNodeId node1
620 let nid1 = localNodeId node1
@@ -664,7 +683,7 @@ testReconnect transport transportInternals = do
664
683
665-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
684-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
666-- in between
685-- in between
667−testMatchAny :: NT.Transport -> IO ()
686+testMatchAny :: NT.Transport -> Assertion
668testMatchAny transport = do
687testMatchAny transport = do
669 proxyAddr <- newEmptyMVar
688 proxyAddr <- newEmptyMVar
670 clientDone <- newEmptyMVar
689 clientDone <- newEmptyMVar
@@ -696,12 +715,12 @@ testMatchAny transport = do
696 takeMVar clientDone
715 takeMVar clientDone
697
716
698-- Test 'receiveChanTimeout'
717-- Test 'receiveChanTimeout'
699−testReceiveChanTimeout :: NT.Transport -> IO ()
718+testReceiveChanTimeout :: NT.Transport -> Assertion
700testReceiveChanTimeout transport = do
719testReceiveChanTimeout transport = do
701 done <- newEmptyMVar
720 done <- newEmptyMVar
702 sendPort <- newEmptyMVar
721 sendPort <- newEmptyMVar
703
722
704− forkIO $ do
723+ forkTry $ do
705 localNode <- newLocalNode transport initRemoteTable
724 localNode <- newLocalNode transport initRemoteTable
706 runProcess localNode $ do
725 runProcess localNode $ do
707 -- Create a typed channel
726 -- Create a typed channel
@@ -723,7 +742,7 @@ testReceiveChanTimeout transport = do
723
742
724 liftIO $ putMVar done ()
743 liftIO $ putMVar done ()
725
744
726− forkIO $ do
745+ forkTry $ do
727 localNode <- newLocalNode transport initRemoteTable
746 localNode <- newLocalNode transport initRemoteTable
728 runProcess localNode $ do
747 runProcess localNode $ do
729 sp <- liftIO $ readMVar sendPort
748 sp <- liftIO $ readMVar sendPort
@@ -736,50 +755,56 @@ testReceiveChanTimeout transport = do
736
755
737 takeMVar done
756 takeMVar done
738
757
739−main :: IO ()
758+tests :: (NT.Transport, TransportInternals) -> [Test]
740−main = do
759+tests (transport, transportInternals) = [
741− Right (transport, transportInternals) <- createTransportExposeInternals "127.0.0.1" "8080" defaultTCPParameters
760+ testGroup "Basic features" [
742− runTests
743− [ ("Ping", testPing transport)
761+ testCase "Ping" (testPing transport)
744− , ("Math", testMath transport)
762+ , testCase "Math" (testMath transport)
745− , ("Timeout", testTimeout transport)
763+ , testCase "Timeout" (testTimeout transport)
746− , ("Timeout0", testTimeout0 transport)
764+ , testCase "Timeout0" (testTimeout0 transport)
747− , ("SendToTerminated", testSendToTerminated transport)
765+ , testCase "SendToTerminated" (testSendToTerminated transport)
748− , ("TypedChannnels", testTypedChannels transport)
766+ , testCase "TypedChannnels" (testTypedChannels transport)
749− , ("MergeChannels", testMergeChannels transport)
767+ , testCase "MergeChannels" (testMergeChannels transport)
750− , ("Terminate", testTerminate transport)
768+ , testCase "Terminate" (testTerminate transport)
751− , ("Registry", testRegistry transport)
769+ , testCase "Registry" (testRegistry transport)
752− , ("RemoteRegistry", testRemoteRegistry transport)
770+ , testCase "RemoteRegistry" (testRemoteRegistry transport)
753− , ("SpawnLocal", testSpawnLocal transport)
771+ , testCase "SpawnLocal" (testSpawnLocal transport)
754− , ("MatchAny", testMatchAny transport)
772+ , testCase "MatchAny" (testMatchAny transport)
773+ , testCase "ReceiveChanTimeout" (testReceiveChanTimeout transport)
774+ ]
775+ , testGroup "Monitoring and Linking" [
755 -- Monitoring processes
776 -- Monitoring processes
756 --
777 --
757 -- The "missing" combinations in the list below don't make much sense, as
778 -- The "missing" combinations in the list below don't make much sense, as
758 -- we cannot guarantee that the monitor reply or link exception will not
779 -- we cannot guarantee that the monitor reply or link exception will not
759 -- happen before the unmonitor or unlink
780 -- happen before the unmonitor or unlink
760− , ("MonitorUnreachable", testMonitorUnreachable transport True False)
781+ testCase "MonitorUnreachable" (testMonitorUnreachable transport True False)
761− , ("MonitorNormalTermination", testMonitorNormalTermination transport True False)
782+ , testCase "MonitorNormalTermination" (testMonitorNormalTermination transport True False)
762− , ("MonitorAbnormalTermination", testMonitorAbnormalTermination transport True False)
783+ , testCase "MonitorAbnormalTermination" (testMonitorAbnormalTermination transport True False)
763− , ("MonitorLocalDeadProcess", testMonitorLocalDeadProcess transport True False)
784+ , testCase "MonitorLocalDeadProcess" (testMonitorLocalDeadProcess transport True False)
764− , ("MonitorRemoteDeadProcess", testMonitorRemoteDeadProcess transport True False)
785+ , testCase "MonitorRemoteDeadProcess" (testMonitorRemoteDeadProcess transport True False)
765− , ("MonitorDisconnect", testMonitorDisconnect transport True False)
786+ , testCase "MonitorDisconnect" (testMonitorDisconnect transport True False)
766− , ("LinkUnreachable", testMonitorUnreachable transport False False)
787+ , testCase "LinkUnreachable" (testMonitorUnreachable transport False False)
767− , ("LinkNormalTermination", testMonitorNormalTermination transport False False)
788+ , testCase "LinkNormalTermination" (testMonitorNormalTermination transport False False)
768− , ("LinkAbnormalTermination", testMonitorAbnormalTermination transport False False)
789+ , testCase "LinkAbnormalTermination" (testMonitorAbnormalTermination transport False False)
769− , ("LinkLocalDeadProcess", testMonitorLocalDeadProcess transport False False)
790+ , testCase "LinkLocalDeadProcess" (testMonitorLocalDeadProcess transport False False)
770− , ("LinkRemoteDeadProcess", testMonitorRemoteDeadProcess transport False False)
791+ , testCase "LinkRemoteDeadProcess" (testMonitorRemoteDeadProcess transport False False)
771− , ("LinkDisconnect", testMonitorDisconnect transport False False)
792+ , testCase "LinkDisconnect" (testMonitorDisconnect transport False False)
772− , ("UnmonitorNormalTermination", testMonitorNormalTermination transport True True)
793+ , testCase "UnmonitorNormalTermination" (testMonitorNormalTermination transport True True)
773− , ("UnmonitorAbnormalTermination", testMonitorAbnormalTermination transport True True)
794+ , testCase "UnmonitorAbnormalTermination" (testMonitorAbnormalTermination transport True True)
774− , ("UnmonitorDisconnect", testMonitorDisconnect transport True True)
795+ , testCase "UnmonitorDisconnect" (testMonitorDisconnect transport True True)
775− , ("UnlinkNormalTermination", testMonitorNormalTermination transport False True)
796+ , testCase "UnlinkNormalTermination" (testMonitorNormalTermination transport False True)
776− , ("UnlinkAbnormalTermination", testMonitorAbnormalTermination transport False True)
797+ , testCase "UnlinkAbnormalTermination" (testMonitorAbnormalTermination transport False True)
777− , ("UnlinkDisconnect", testMonitorDisconnect transport False True)
798+ , testCase "UnlinkDisconnect" (testMonitorDisconnect transport False True)
778 -- Monitoring nodes and channels
799 -- Monitoring nodes and channels
779− , ("MonitorNode", testMonitorNode transport)
800+ , testCase "MonitorNode" (testMonitorNode transport)
780− , ("MonitorChannel", testMonitorChannel transport)
801+ , testCase "MonitorChannel" (testMonitorChannel transport)
781 -- Reconnect
802 -- Reconnect
782− , ("Reconnect", testReconnect transport transportInternals)
803+ , testCase "Reconnect" (testReconnect transport transportInternals)
783− -- ReceiveChanTimeout
784− , ("ReceiveChanTimeout", testReceiveChanTimeout transport)
785 ]
804 ]
805+ ]
806+
807+main :: IO ()
808+main = do
809+ Right transport <- createTransportExposeInternals "127.0.0.1" "8080" defaultTCPParameters
810+ defaultMain (tests transport)
distributed-process/tests/TestClosure.hs+60−45
@@ -29,7 +29,14 @@ import Control.Distributed.Process.Closure
29import Control.Distributed.Process.Node
29import Control.Distributed.Process.Node
30import Control.Distributed.Process.Internal.Types (NodeId(nodeAddress))
30import Control.Distributed.Process.Internal.Types (NodeId(nodeAddress))
31import Control.Distributed.Static (staticLabel, staticClosure)
31import Control.Distributed.Static (staticLabel, staticClosure)
32−import TestAuxiliary
32+
33+import Test.HUnit (Assertion)
34+import Test.Framework (Test, defaultMain, testGroup)
35+import Test.Framework.Providers.HUnit (testCase)
36+
37+--------------------------------------------------------------------------------
38+-- Supporting definitions --
39+--------------------------------------------------------------------------------
33
40
34quintuple :: a -> b -> c -> d -> e -> (a, b, c, d, e)
41quintuple :: a -> b -> c -> d -> e -> (a, b, c, d, e)
35quintuple a b c d e = (a, b, c, d, e)
42quintuple a b c d e = (a, b, c, d, e)
@@ -133,7 +140,18 @@ factorial' n = returnCP $(mkStatic 'sdictInt) n `bindCP` factorialOf
133waitClosure :: Int -> Closure (Process ())
140waitClosure :: Int -> Closure (Process ())
134waitClosure = $(mkClosure 'wait)
141waitClosure = $(mkClosure 'wait)
135
142
143+simulateNetworkFailure :: TransportInternals -> NodeId -> NodeId -> Process ()
144+simulateNetworkFailure transportInternals fr to = liftIO $ do
145+ threadDelay 10000
146+ sock <- socketBetween transportInternals (nodeAddress fr) (nodeAddress to)
147+ sClose sock
148+ threadDelay 10000
149+
150+--------------------------------------------------------------------------------
151+-- The tests proper --
152+--------------------------------------------------------------------------------
153+
136−testUnclosure :: Transport -> RemoteTable -> IO ()
154+testUnclosure :: Transport -> RemoteTable -> Assertion
137testUnclosure transport rtable = do
155testUnclosure transport rtable = do
138 node <- newLocalNode transport rtable
156 node <- newLocalNode transport rtable
139 done <- newEmptyMVar
157 done <- newEmptyMVar
@@ -142,7 +160,7 @@ testUnclosure transport rtable = do
142 liftIO $ putMVar done ()
160 liftIO $ putMVar done ()
143 takeMVar done
161 takeMVar done
144
162
145−testBind :: Transport -> RemoteTable -> IO ()
163+testBind :: Transport -> RemoteTable -> Assertion
146testBind transport rtable = do
164testBind transport rtable = do
147 node <- newLocalNode transport rtable
165 node <- newLocalNode transport rtable
148 done <- newEmptyMVar
166 done <- newEmptyMVar
@@ -153,7 +171,7 @@ testBind transport rtable = do
153 liftIO $ putMVar done ()
171 liftIO $ putMVar done ()
154 takeMVar done
172 takeMVar done
155
173
156−testSendPureClosure :: Transport -> RemoteTable -> IO ()
174+testSendPureClosure :: Transport -> RemoteTable -> Assertion
157testSendPureClosure transport rtable = do
175testSendPureClosure transport rtable = do
158 serverAddr <- newEmptyMVar
176 serverAddr <- newEmptyMVar
159 serverDone <- newEmptyMVar
177 serverDone <- newEmptyMVar
@@ -174,7 +192,7 @@ testSendPureClosure transport rtable = do
174
192
175 takeMVar serverDone
193 takeMVar serverDone
176
194
177−testSendIOClosure :: Transport -> RemoteTable -> IO ()
195+testSendIOClosure :: Transport -> RemoteTable -> Assertion
178testSendIOClosure transport rtable = do
196testSendIOClosure transport rtable = do
179 serverAddr <- newEmptyMVar
197 serverAddr <- newEmptyMVar
180 serverDone <- newEmptyMVar
198 serverDone <- newEmptyMVar
@@ -198,7 +216,7 @@ testSendIOClosure transport rtable = do
198
216
199 takeMVar serverDone
217 takeMVar serverDone
200
218
201−testSendProcClosure :: Transport -> RemoteTable -> IO ()
219+testSendProcClosure :: Transport -> RemoteTable -> Assertion
202testSendProcClosure transport rtable = do
220testSendProcClosure transport rtable = do
203 serverAddr <- newEmptyMVar
221 serverAddr <- newEmptyMVar
204 clientDone <- newEmptyMVar
222 clientDone <- newEmptyMVar
@@ -222,7 +240,7 @@ testSendProcClosure transport rtable = do
222
240
223 takeMVar clientDone
241 takeMVar clientDone
224
242
225−testSpawn :: Transport -> RemoteTable -> IO ()
243+testSpawn :: Transport -> RemoteTable -> Assertion
226testSpawn transport rtable = do
244testSpawn transport rtable = do
227 serverNodeAddr <- newEmptyMVar
245 serverNodeAddr <- newEmptyMVar
228 clientDone <- newEmptyMVar
246 clientDone <- newEmptyMVar
@@ -243,7 +261,7 @@ testSpawn transport rtable = do
243
261
244 takeMVar clientDone
262 takeMVar clientDone
245
263
246−testCall :: Transport -> RemoteTable -> IO ()
264+testCall :: Transport -> RemoteTable -> Assertion
247testCall transport rtable = do
265testCall transport rtable = do
248 serverNodeAddr <- newEmptyMVar
266 serverNodeAddr <- newEmptyMVar
249 clientDone <- newEmptyMVar
267 clientDone <- newEmptyMVar
@@ -261,7 +279,7 @@ testCall transport rtable = do
261
279
262 takeMVar clientDone
280 takeMVar clientDone
263
281
264−testCallBind :: Transport -> RemoteTable -> IO ()
282+testCallBind :: Transport -> RemoteTable -> Assertion
265testCallBind transport rtable = do
283testCallBind transport rtable = do
266 serverNodeAddr <- newEmptyMVar
284 serverNodeAddr <- newEmptyMVar
267 clientDone <- newEmptyMVar
285 clientDone <- newEmptyMVar
@@ -279,7 +297,7 @@ testCallBind transport rtable = do
279
297
280 takeMVar clientDone
298 takeMVar clientDone
281
299
282−testSeq :: Transport -> RemoteTable -> IO ()
300+testSeq :: Transport -> RemoteTable -> Assertion
283testSeq transport rtable = do
301testSeq transport rtable = do
284 node <- newLocalNode transport rtable
302 node <- newLocalNode transport rtable
285 done <- newEmptyMVar
303 done <- newEmptyMVar
@@ -297,7 +315,7 @@ testSeq transport rtable = do
297-- child. The supervisor then throws an exception, the child dies because it
315-- child. The supervisor then throws an exception, the child dies because it
298-- was linked to the supervisor, and the third process notices that the child
316-- was linked to the supervisor, and the third process notices that the child
299-- dies.
317-- dies.
300−testSpawnSupervised :: Transport -> RemoteTable -> IO ()
318+testSpawnSupervised :: Transport -> RemoteTable -> Assertion
301testSpawnSupervised transport rtable = do
319testSpawnSupervised transport rtable = do
302 [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
320 [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
303 [superPid, childPid] <- replicateM 2 $ newEmptyMVar
321 [superPid, childPid] <- replicateM 2 $ newEmptyMVar
@@ -326,7 +344,7 @@ testSpawnSupervised transport rtable = do
326 supervisorDeath :: IOException
344 supervisorDeath :: IOException
327 supervisorDeath = userError "Supervisor died"
345 supervisorDeath = userError "Supervisor died"
328
346
329−testSpawnInvalid :: Transport -> RemoteTable -> IO ()
347+testSpawnInvalid :: Transport -> RemoteTable -> Assertion
330testSpawnInvalid transport rtable = do
348testSpawnInvalid transport rtable = do
331 node <- newLocalNode transport rtable
349 node <- newLocalNode transport rtable
332 done <- newEmptyMVar
350 done <- newEmptyMVar
@@ -338,7 +356,7 @@ testSpawnInvalid transport rtable = do
338 liftIO $ putMVar done ()
356 liftIO $ putMVar done ()
339 takeMVar done
357 takeMVar done
340
358
341−testClosureExpect :: Transport -> RemoteTable -> IO ()
359+testClosureExpect :: Transport -> RemoteTable -> Assertion
342testClosureExpect transport rtable = do
360testClosureExpect transport rtable = do
343 node <- newLocalNode transport rtable
361 node <- newLocalNode transport rtable
344 done <- newEmptyMVar
362 done <- newEmptyMVar
@@ -351,7 +369,7 @@ testClosureExpect transport rtable = do
351 liftIO $ putMVar done ()
369 liftIO $ putMVar done ()
352 takeMVar done
370 takeMVar done
353
371
354−testSpawnChannel :: Transport -> RemoteTable -> IO ()
372+testSpawnChannel :: Transport -> RemoteTable -> Assertion
355testSpawnChannel transport rtable = do
373testSpawnChannel transport rtable = do
356 done <- newEmptyMVar
374 done <- newEmptyMVar
357 [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
375 [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
@@ -368,7 +386,7 @@ testSpawnChannel transport rtable = do
368
386
369 takeMVar done
387 takeMVar done
370
388
371−testTDict :: Transport -> RemoteTable -> IO ()
389+testTDict :: Transport -> RemoteTable -> Assertion
372testTDict transport rtable = do
390testTDict transport rtable = do
373 done <- newEmptyMVar
391 done <- newEmptyMVar
374 [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
392 [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
@@ -377,14 +395,7 @@ testTDict transport rtable = do
377 liftIO $ putMVar done ()
395 liftIO $ putMVar done ()
378 takeMVar done
396 takeMVar done
379
397
380−simulateNetworkFailure :: TransportInternals -> NodeId -> NodeId -> Process ()
381−simulateNetworkFailure transportInternals fr to = liftIO $ do
382− threadDelay 10000
383− sock <- socketBetween transportInternals (nodeAddress fr) (nodeAddress to)
384− sClose sock
385− threadDelay 10000
386−
387−testFib :: Transport -> RemoteTable -> IO ()
398+testFib :: Transport -> RemoteTable -> Assertion
388testFib transport rtable = do
399testFib transport rtable = do
389 nodes <- replicateM 4 $ newLocalNode transport rtable
400 nodes <- replicateM 4 $ newLocalNode transport rtable
390 done <- newEmptyMVar
401 done <- newEmptyMVar
@@ -397,7 +408,7 @@ testFib transport rtable = do
397
408
398 takeMVar done
409 takeMVar done
399
410
400−testSpawnReconnect :: Transport -> RemoteTable -> TransportInternals -> IO ()
411+testSpawnReconnect :: Transport -> RemoteTable -> TransportInternals -> Assertion
401testSpawnReconnect transport rtable transportInternals = do
412testSpawnReconnect transport rtable transportInternals = do
402 [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
413 [node1, node2] <- replicateM 2 $ newLocalNode transport rtable
403 let nid1 = localNodeId node1
414 let nid1 = localNodeId node1
@@ -426,7 +437,7 @@ testSpawnReconnect transport rtable transportInternals = do
426
437
427-- | 'spawn' used to ave a race condition which would be triggered if the
438-- | 'spawn' used to ave a race condition which would be triggered if the
428-- spawning process terminates immediately after spawning
439-- spawning process terminates immediately after spawning
429−testSpawnTerminate :: Transport -> RemoteTable -> IO ()
440+testSpawnTerminate :: Transport -> RemoteTable -> Assertion
430testSpawnTerminate transport rtable = do
441testSpawnTerminate transport rtable = do
431 slave <- newLocalNode transport rtable
442 slave <- newLocalNode transport rtable
432 master <- newLocalNode transport rtable
443 master <- newLocalNode transport rtable
@@ -440,26 +451,30 @@ testSpawnTerminate transport rtable = do
440
451
441 takeMVar masterDone
452 takeMVar masterDone
442
453
454+tests :: (Transport, TransportInternals) -> RemoteTable -> [Test]
455+tests (transport, transportInternals) rtable = [
456+ testCase "Unclosure" (testUnclosure transport rtable)
457+ , testCase "Bind" (testBind transport rtable)
458+ , testCase "SendPureClosure" (testSendPureClosure transport rtable)
459+ , testCase "SendIOClosure" (testSendIOClosure transport rtable)
460+ , testCase "SendProcClosure" (testSendProcClosure transport rtable)
461+ , testCase "Spawn" (testSpawn transport rtable)
462+ , testCase "Call" (testCall transport rtable)
463+ , testCase "CallBind" (testCallBind transport rtable)
464+ , testCase "Seq" (testSeq transport rtable)
465+ , testCase "SpawnSupervised" (testSpawnSupervised transport rtable)
466+ , testCase "SpawnInvalid" (testSpawnInvalid transport rtable)
467+ , testCase "ClosureExpect" (testClosureExpect transport rtable)
468+ , testCase "SpawnChannel" (testSpawnChannel transport rtable)
469+ , testCase "TDict" (testTDict transport rtable)
470+ , testCase "Fib" (testFib transport rtable)
471+ , testCase "SpawnTerminate" (testSpawnTerminate transport rtable)
472+ , testCase "SpawnReconnect" (testSpawnReconnect transport rtable transportInternals)
473+ ]
474+
475+
443main :: IO ()
476main :: IO ()
444main = do
477main = do
445− Right (transport, transportInternals) <- createTransportExposeInternals "127.0.0.1" "8080" defaultTCPParameters
478+ Right transport <- createTransportExposeInternals "127.0.0.1" "8080" defaultTCPParameters
446 let rtable = __remoteTable . __remoteTableDecl $ initRemoteTable
479 let rtable = __remoteTable . __remoteTableDecl $ initRemoteTable
447− runTests
480+ defaultMain (tests transport rtable)
448− [ ("Unclosure", testUnclosure transport rtable)
449− , ("Bind", testBind transport rtable)
450− , ("SendPureClosure", testSendPureClosure transport rtable)
451− , ("SendIOClosure", testSendIOClosure transport rtable)
452− , ("SendProcClosure", testSendProcClosure transport rtable)
453− , ("Spawn", testSpawn transport rtable)
454− , ("Call", testCall transport rtable)
455− , ("CallBind", testCallBind transport rtable)
456− , ("Seq", testSeq transport rtable)
457− , ("SpawnSupervised", testSpawnSupervised transport rtable)
458− , ("SpawnInvalid", testSpawnInvalid transport rtable)
459− , ("ClosureExpect", testClosureExpect transport rtable)
460− , ("SpawnChannel", testSpawnChannel transport rtable)
461− , ("TDict", testTDict transport rtable)
462− , ("Fib", testFib transport rtable)
463− , ("SpawnTerminate", testSpawnTerminate transport rtable)
464− , ("SpawnReconnect", testSpawnReconnect transport rtable transportInternals)
465− ]