59f0426 · distributed-process

git.iko.soy/distributed-process

Clean up documentation (move to test-framework)

commit59f0426c67d24876349fc3234efa967c93a8c406 authorEdsko de Vries <edsko@edsko.net> dateTue 6 Nov 2012, 10:43 (14 years ago) parent8b95ef1

4 files changed+209−240

compare with master

unifiedsplit

distributed-process/distributed-process.cabal+8−4 distributed-process/tests/TestAuxiliary.hs−75 distributed-process/tests/TestCH.hs+141−116 distributed-process/tests/TestClosure.hs+60−45

distributed-process/distributed-process.cabal+8−4

@@ -94,8 +94,10 @@ Test-Suite TestCH

9494 network-transport >= 0.3 && < 0.4,

9595 network-transport-tcp >= 0.3 && < 0.4,

9696 binary >= 0.5 && < 0.7,

97− network >= 2.3 && < 2.5

98− Other-modules: TestAuxiliary

97+ network >= 2.3 && < 2.5,

98+ HUnit >= 1.2 && < 1.3,

99+ test-framework >= 0.6 && < 0.7,

100+ test-framework-hunit >= 0.2 && < 0.3

99101 Extensions: CPP,

100102 ScopedTypeVariables,

101103 DeriveDataTypeable,

@@ -114,8 +116,10 @@ Test-Suite TestClosure

114116 network-transport >= 0.3 && < 0.4,

115117 network-transport-tcp >= 0.3 && < 0.4,

116118 bytestring >= 0.9 && < 0.11,

117− network >= 2.3 && < 2.5

118− Other-modules: TestAuxiliary

119+ network >= 2.3 && < 2.5,

120+ HUnit >= 1.2 && < 1.3,

121+ test-framework >= 0.6 && < 0.7,

122+ test-framework-hunit >= 0.2 && < 0.3

119123 Extensions: CPP,

120124 ScopedTypeVariables

121125 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

44import Prelude hiding (catch)

55#endif

78import Data.Binary (Binary(..))

89import Data.Typeable (Typeable)

910import Data.Foldable (forM_)

10−import Control.Concurrent (forkIO, threadDelay)

11+import Control.Concurrent (forkIO, threadDelay, myThreadId, throwTo, ThreadId)

1112import Control.Concurrent.MVar

1213 ( MVar

1314 , newEmptyMVar

@@ -16,7 +17,8 @@ import Control.Concurrent.MVar

1617 , readMVar

1718 )

1819import Control.Monad (replicateM_, replicateM, forever)

19−import Control.Exception (throwIO)

20+import Control.Exception (SomeException, throwIO)

21+import qualified Control.Exception as Ex (catch)

2022import Control.Applicative ((<$>), (<*>))

2123import qualified Network.Transport as NT (Transport, closeEndPoint)

2224import Network.Socket (sClose)

@@ -32,7 +34,10 @@ import Control.Distributed.Process.Internal.Types

3234 )

3335import Control.Distributed.Process.Node

3436import 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)

3641

3742newtype Ping = Ping ProcessId

3843 deriving (Typeable, Binary, Show)

@@ -40,6 +45,16 @@ newtype Ping = Ping ProcessId

4045newtype Pong = Pong ProcessId

4146 deriving (Typeable, Binary, Show)

4247

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+

4358-- | The ping server from the paper

4459ping :: Process ()

4560ping = do

@@ -55,35 +70,32 @@ whereisRemote nid string = do

5570 WhereIsReply _ mPid <- expect

5671 return mPid

5772

58−-- | Basic ping test

59−testPing :: NT.Transport -> IO ()

60−testPing transport = do

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

73+data Add = Add ProcessId Double Double deriving (Typeable)

74+data Divide = Divide ProcessId Double Double deriving (Typeable)

75+data DivByZero = DivByZero deriving (Typeable)

7476

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

7680

77− runProcess localNode $ do

78− pid <- getSelfPid

79− replicateM_ numPings $ do

80− send pingServer (Pong pid)

81− Ping _ <- expect

82− return ()

81+instance Binary Divide where

82+ put (Divide pid x y) = put pid >> put x >> put y

83+ get = Divide <$> get <*> get <*> get

8384

84− putMVar clientDone ()

85+instance Binary DivByZero where

86+ put DivByZero = return ()

87+ get = return DivByZero

8588

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

8799

88100-- | Monitor or link to a remote node

89101monitorOrLink :: Bool -- ^ 'True' for monitor, 'False' for link

@@ -125,9 +137,42 @@ monitorTestProcess theirAddr mOrL un reason monitorSetup done =

125137 liftIO $ putMVar done ()

126138 )

127139

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

128173

129174-- | Monitor a process on an unreachable node

130−testMonitorUnreachable :: NT.Transport -> Bool -> Bool -> IO ()

175+testMonitorUnreachable :: NT.Transport -> Bool -> Bool -> Assertion

131176testMonitorUnreachable transport mOrL un = do

132177 deadProcess <- newEmptyMVar

133178 done <- newEmptyMVar

@@ -147,7 +192,7 @@ testMonitorUnreachable transport mOrL un = do

147192 takeMVar done

148193

149194-- | Monitor a process which terminates normally

150−testMonitorNormalTermination :: NT.Transport -> Bool -> Bool -> IO ()

195+testMonitorNormalTermination :: NT.Transport -> Bool -> Bool -> Assertion

151196testMonitorNormalTermination transport mOrL un = do

152197 monitorSetup <- newEmptyMVar

153198 monitoredProcess <- newEmptyMVar

@@ -168,7 +213,7 @@ testMonitorNormalTermination transport mOrL un = do

168213 takeMVar done

169214

170215-- | Monitor a process which terminates abnormally

171−testMonitorAbnormalTermination :: NT.Transport -> Bool -> Bool -> IO ()

216+testMonitorAbnormalTermination :: NT.Transport -> Bool -> Bool -> Assertion

172217testMonitorAbnormalTermination transport mOrL un = do

173218 monitorSetup <- newEmptyMVar

174219 monitoredProcess <- newEmptyMVar

@@ -192,7 +237,7 @@ testMonitorAbnormalTermination transport mOrL un = do

192237 takeMVar done

193238

194239-- | Monitor a local process that is already dead

195−testMonitorLocalDeadProcess :: NT.Transport -> Bool -> Bool -> IO ()

240+testMonitorLocalDeadProcess :: NT.Transport -> Bool -> Bool -> Assertion

196241testMonitorLocalDeadProcess transport mOrL un = do

197242 processDead <- newEmptyMVar

198243 processAddr <- newEmptyMVar

@@ -212,7 +257,7 @@ testMonitorLocalDeadProcess transport mOrL un = do

212257 takeMVar done

213258

214259-- | Monitor a remote process that is already dead

215−testMonitorRemoteDeadProcess :: NT.Transport -> Bool -> Bool -> IO ()

260+testMonitorRemoteDeadProcess :: NT.Transport -> Bool -> Bool -> Assertion

216261testMonitorRemoteDeadProcess transport mOrL un = do

217262 processDead <- newEmptyMVar

218263 processAddr <- newEmptyMVar

@@ -233,7 +278,7 @@ testMonitorRemoteDeadProcess transport mOrL un = do

233278 takeMVar done

234279

235280-- | Monitor a process that becomes disconnected

236−testMonitorDisconnect :: NT.Transport -> Bool -> Bool -> IO ()

281+testMonitorDisconnect :: NT.Transport -> Bool -> Bool -> Assertion

237282testMonitorDisconnect transport mOrL un = do

238283 processAddr <- newEmptyMVar

239284 monitorSetup <- newEmptyMVar

@@ -254,34 +299,8 @@ testMonitorDisconnect transport mOrL un = do

254299

255300 takeMVar done

256301

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−

283302-- | Test the math server (i.e., receiveWait)

284−testMath :: NT.Transport -> IO ()

303+testMath :: NT.Transport -> Assertion

285304testMath transport = do

286305 serverAddr <- newEmptyMVar

287306 clientDone <- newEmptyMVar

@@ -312,7 +331,7 @@ testMath transport = do

312331-- | Send first message (i.e. connect) to an already terminated process

313332-- (without monitoring); then send another message to a second process on

314333-- the same remote node (we're checking that the remote node did not die)

315−testSendToTerminated :: NT.Transport -> IO ()

334+testSendToTerminated :: NT.Transport -> Assertion

316335testSendToTerminated transport = do

317336 serverAddr1 <- newEmptyMVar

318337 serverAddr2 <- newEmptyMVar

@@ -342,7 +361,7 @@ testSendToTerminated transport = do

342361 takeMVar clientDone

343362

344363-- | Test (non-zero) timeout

345−testTimeout :: NT.Transport -> IO ()

364+testTimeout :: NT.Transport -> Assertion

346365testTimeout transport = do

347366 localNode <- newLocalNode transport initRemoteTable

348367 runProcess localNode $ do

@@ -350,7 +369,7 @@ testTimeout transport = do

350369 return ()

351370

352371-- | Test zero timeout

353−testTimeout0 :: NT.Transport -> IO ()

372+testTimeout0 :: NT.Transport -> Assertion

354373testTimeout0 transport = do

355374 serverAddr <- newEmptyMVar

356375 clientDone <- newEmptyMVar

@@ -384,7 +403,7 @@ testTimeout0 transport = do

384403 takeMVar clientDone

385404

386405-- | Test typed channels

387−testTypedChannels :: NT.Transport -> IO ()

406+testTypedChannels :: NT.Transport -> Assertion

388407testTypedChannels transport = do

389408 serverChannel <- newEmptyMVar :: IO (MVar (SendPort (SendPort Bool, Int)))

390409 clientDone <- newEmptyMVar

@@ -410,7 +429,7 @@ testTypedChannels transport = do

410429 takeMVar clientDone

411430

412431-- | Test merging receive ports

413−testMergeChannels :: NT.Transport -> IO ()

432+testMergeChannels :: NT.Transport -> Assertion

414433testMergeChannels transport = do

415434 localNode <- newLocalNode transport initRemoteTable

416435 testFlat localNode True "aaabbbccc"

@@ -496,7 +515,7 @@ testMergeChannels transport = do

496515 liftIO $ threadDelay 10000 -- Make sure messages have been sent

497516 return rport

498517

499−testTerminate :: NT.Transport -> IO ()

518+testTerminate :: NT.Transport -> Assertion

500519testTerminate transport = do

501520 localNode <- newLocalNode transport initRemoteTable

502521

@@ -510,7 +529,7 @@ testTerminate transport = do

510529 True <- return $ ref == ref' && pid == pid' && ex == show ProcessTerminationException

511530 return ()

512531

513−testMonitorNode :: NT.Transport -> IO ()

532+testMonitorNode :: NT.Transport -> Assertion

514533testMonitorNode transport = do

515534 [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable

516535

@@ -522,7 +541,7 @@ testMonitorNode transport = do

522541 True <- return $ ref == ref' && nid == localNodeId node1

523542 return ()

524543

525−testMonitorChannel :: NT.Transport -> IO ()

544+testMonitorChannel :: NT.Transport -> Assertion

526545testMonitorChannel transport = do

527546 [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable

528547 gotNotification <- newEmptyMVar

@@ -543,7 +562,7 @@ testMonitorChannel transport = do

543562

544563 takeMVar gotNotification

545564

546−testRegistry :: NT.Transport -> IO ()

565+testRegistry :: NT.Transport -> Assertion

547566testRegistry transport = do

548567 node <- newLocalNode transport initRemoteTable

549568

@@ -559,7 +578,7 @@ testRegistry transport = do

559578 True <- return $ pingServer == pid'

560579 return ()

561580

562−testRemoteRegistry :: NT.Transport -> IO ()

581+testRemoteRegistry :: NT.Transport -> Assertion

563582testRemoteRegistry transport = do

564583 node1 <- newLocalNode transport initRemoteTable

565584 node2 <- newLocalNode transport initRemoteTable

@@ -577,7 +596,7 @@ testRemoteRegistry transport = do

577596 True <- return $ pingServer == pid'

578597 return ()

579598

580−testSpawnLocal :: NT.Transport -> IO ()

599+testSpawnLocal :: NT.Transport -> Assertion

581600testSpawnLocal transport = do

582601 node <- newLocalNode transport initRemoteTable

583602

@@ -595,7 +614,7 @@ testSpawnLocal transport = do

595614 send pid sport

596615 expect

597616

598−testReconnect :: NT.Transport -> TransportInternals -> IO ()

617+testReconnect :: NT.Transport -> TransportInternals -> Assertion

599618testReconnect transport transportInternals = do

600619 [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable

601620 let nid1 = localNodeId node1

@@ -664,7 +683,7 @@ testReconnect transport transportInternals = do

664683

665684-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server

666685-- in between

667−testMatchAny :: NT.Transport -> IO ()

686+testMatchAny :: NT.Transport -> Assertion

668687testMatchAny transport = do

669688 proxyAddr <- newEmptyMVar

670689 clientDone <- newEmptyMVar

@@ -696,12 +715,12 @@ testMatchAny transport = do

696715 takeMVar clientDone

697716

698717-- Test 'receiveChanTimeout'

699−testReceiveChanTimeout :: NT.Transport -> IO ()

718+testReceiveChanTimeout :: NT.Transport -> Assertion

700719testReceiveChanTimeout transport = do

701720 done <- newEmptyMVar

702721 sendPort <- newEmptyMVar

703722

704− forkIO $ do

723+ forkTry $ do

705724 localNode <- newLocalNode transport initRemoteTable

706725 runProcess localNode $ do

707726 -- Create a typed channel

@@ -723,7 +742,7 @@ testReceiveChanTimeout transport = do

723742

724743 liftIO $ putMVar done ()

725744

726− forkIO $ do

745+ forkTry $ do

727746 localNode <- newLocalNode transport initRemoteTable

728747 runProcess localNode $ do

729748 sp <- liftIO $ readMVar sendPort

@@ -736,50 +755,56 @@ testReceiveChanTimeout transport = do

736755

737756 takeMVar done

738757

739−main :: IO ()

740−main = do

741− Right (transport, transportInternals) <- createTransportExposeInternals "127.0.0.1" "8080" defaultTCPParameters

742− runTests

743− [ ("Ping", testPing transport)

744− , ("Math", testMath transport)

745− , ("Timeout", testTimeout transport)

746− , ("Timeout0", testTimeout0 transport)

747− , ("SendToTerminated", testSendToTerminated transport)

748− , ("TypedChannnels", testTypedChannels transport)

749− , ("MergeChannels", testMergeChannels transport)

750− , ("Terminate", testTerminate transport)

751− , ("Registry", testRegistry transport)

752− , ("RemoteRegistry", testRemoteRegistry transport)

753− , ("SpawnLocal", testSpawnLocal transport)

754− , ("MatchAny", testMatchAny transport)

758+tests :: (NT.Transport, TransportInternals) -> [Test]

759+tests (transport, transportInternals) = [

760+ testGroup "Basic features" [

761+ testCase "Ping" (testPing transport)

762+ , testCase "Math" (testMath transport)

763+ , testCase "Timeout" (testTimeout transport)

764+ , testCase "Timeout0" (testTimeout0 transport)

765+ , testCase "SendToTerminated" (testSendToTerminated transport)

766+ , testCase "TypedChannnels" (testTypedChannels transport)

767+ , testCase "MergeChannels" (testMergeChannels transport)

768+ , testCase "Terminate" (testTerminate transport)

769+ , testCase "Registry" (testRegistry transport)

770+ , testCase "RemoteRegistry" (testRemoteRegistry transport)

771+ , testCase "SpawnLocal" (testSpawnLocal transport)

772+ , testCase "MatchAny" (testMatchAny transport)

773+ , testCase "ReceiveChanTimeout" (testReceiveChanTimeout transport)

774+ ]

775+ , testGroup "Monitoring and Linking" [

755776 -- Monitoring processes

756777 --

757778 -- The "missing" combinations in the list below don't make much sense, as

758779 -- we cannot guarantee that the monitor reply or link exception will not

759780 -- happen before the unmonitor or unlink

760− , ("MonitorUnreachable", testMonitorUnreachable transport True False)

761− , ("MonitorNormalTermination", testMonitorNormalTermination transport True False)

762− , ("MonitorAbnormalTermination", testMonitorAbnormalTermination transport True False)

763− , ("MonitorLocalDeadProcess", testMonitorLocalDeadProcess transport True False)

764− , ("MonitorRemoteDeadProcess", testMonitorRemoteDeadProcess transport True False)

765− , ("MonitorDisconnect", testMonitorDisconnect transport True False)

766− , ("LinkUnreachable", testMonitorUnreachable transport False False)

767− , ("LinkNormalTermination", testMonitorNormalTermination transport False False)

768− , ("LinkAbnormalTermination", testMonitorAbnormalTermination transport False False)

769− , ("LinkLocalDeadProcess", testMonitorLocalDeadProcess transport False False)

770− , ("LinkRemoteDeadProcess", testMonitorRemoteDeadProcess transport False False)

771− , ("LinkDisconnect", testMonitorDisconnect transport False False)

772− , ("UnmonitorNormalTermination", testMonitorNormalTermination transport True True)

773− , ("UnmonitorAbnormalTermination", testMonitorAbnormalTermination transport True True)

774− , ("UnmonitorDisconnect", testMonitorDisconnect transport True True)

775− , ("UnlinkNormalTermination", testMonitorNormalTermination transport False True)

776− , ("UnlinkAbnormalTermination", testMonitorAbnormalTermination transport False True)

777− , ("UnlinkDisconnect", testMonitorDisconnect transport False True)

781+ testCase "MonitorUnreachable" (testMonitorUnreachable transport True False)

782+ , testCase "MonitorNormalTermination" (testMonitorNormalTermination transport True False)

783+ , testCase "MonitorAbnormalTermination" (testMonitorAbnormalTermination transport True False)

784+ , testCase "MonitorLocalDeadProcess" (testMonitorLocalDeadProcess transport True False)

785+ , testCase "MonitorRemoteDeadProcess" (testMonitorRemoteDeadProcess transport True False)

786+ , testCase "MonitorDisconnect" (testMonitorDisconnect transport True False)

787+ , testCase "LinkUnreachable" (testMonitorUnreachable transport False False)

788+ , testCase "LinkNormalTermination" (testMonitorNormalTermination transport False False)

789+ , testCase "LinkAbnormalTermination" (testMonitorAbnormalTermination transport False False)

790+ , testCase "LinkLocalDeadProcess" (testMonitorLocalDeadProcess transport False False)

791+ , testCase "LinkRemoteDeadProcess" (testMonitorRemoteDeadProcess transport False False)

792+ , testCase "LinkDisconnect" (testMonitorDisconnect transport False False)

793+ , testCase "UnmonitorNormalTermination" (testMonitorNormalTermination transport True True)

794+ , testCase "UnmonitorAbnormalTermination" (testMonitorAbnormalTermination transport True True)

795+ , testCase "UnmonitorDisconnect" (testMonitorDisconnect transport True True)

796+ , testCase "UnlinkNormalTermination" (testMonitorNormalTermination transport False True)

797+ , testCase "UnlinkAbnormalTermination" (testMonitorAbnormalTermination transport False True)

798+ , testCase "UnlinkDisconnect" (testMonitorDisconnect transport False True)

778799 -- Monitoring nodes and channels

779− , ("MonitorNode", testMonitorNode transport)

780− , ("MonitorChannel", testMonitorChannel transport)

800+ , testCase "MonitorNode" (testMonitorNode transport)

801+ , testCase "MonitorChannel" (testMonitorChannel transport)

781802 -- Reconnect

782− , ("Reconnect", testReconnect transport transportInternals)

783− -- ReceiveChanTimeout

784− , ("ReceiveChanTimeout", testReceiveChanTimeout transport)

803+ , testCase "Reconnect" (testReconnect transport transportInternals)

785804 ]

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

2929import Control.Distributed.Process.Node

3030import Control.Distributed.Process.Internal.Types (NodeId(nodeAddress))

3131import 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+--------------------------------------------------------------------------------

3340

3441quintuple :: a -> b -> c -> d -> e -> (a, b, c, d, e)

3542quintuple a b c d e = (a, b, c, d, e)

@@ -133,7 +140,18 @@ factorial' n = returnCP $(mkStatic 'sdictInt) n `bindCP` factorialOf

133140waitClosure :: Int -> Closure (Process ())

134141waitClosure = $(mkClosure 'wait)

135142

136−testUnclosure :: Transport -> RemoteTable -> IO ()

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+

154+testUnclosure :: Transport -> RemoteTable -> Assertion

137155testUnclosure transport rtable = do

138156 node <- newLocalNode transport rtable

139157 done <- newEmptyMVar

@@ -142,7 +160,7 @@ testUnclosure transport rtable = do

142160 liftIO $ putMVar done ()

143161 takeMVar done

144162

145−testBind :: Transport -> RemoteTable -> IO ()

163+testBind :: Transport -> RemoteTable -> Assertion

146164testBind transport rtable = do

147165 node <- newLocalNode transport rtable

148166 done <- newEmptyMVar

@@ -153,7 +171,7 @@ testBind transport rtable = do

153171 liftIO $ putMVar done ()

154172 takeMVar done

155173

156−testSendPureClosure :: Transport -> RemoteTable -> IO ()

174+testSendPureClosure :: Transport -> RemoteTable -> Assertion

157175testSendPureClosure transport rtable = do

158176 serverAddr <- newEmptyMVar

159177 serverDone <- newEmptyMVar

@@ -174,7 +192,7 @@ testSendPureClosure transport rtable = do

174192

175193 takeMVar serverDone

176194

177−testSendIOClosure :: Transport -> RemoteTable -> IO ()

195+testSendIOClosure :: Transport -> RemoteTable -> Assertion

178196testSendIOClosure transport rtable = do

179197 serverAddr <- newEmptyMVar

180198 serverDone <- newEmptyMVar

@@ -198,7 +216,7 @@ testSendIOClosure transport rtable = do

198216

199217 takeMVar serverDone

200218

201−testSendProcClosure :: Transport -> RemoteTable -> IO ()

219+testSendProcClosure :: Transport -> RemoteTable -> Assertion

202220testSendProcClosure transport rtable = do

203221 serverAddr <- newEmptyMVar

204222 clientDone <- newEmptyMVar

@@ -222,7 +240,7 @@ testSendProcClosure transport rtable = do

222240

223241 takeMVar clientDone

224242

225−testSpawn :: Transport -> RemoteTable -> IO ()

243+testSpawn :: Transport -> RemoteTable -> Assertion

226244testSpawn transport rtable = do

227245 serverNodeAddr <- newEmptyMVar

228246 clientDone <- newEmptyMVar

@@ -243,7 +261,7 @@ testSpawn transport rtable = do

243261

244262 takeMVar clientDone

245263

246−testCall :: Transport -> RemoteTable -> IO ()

264+testCall :: Transport -> RemoteTable -> Assertion

247265testCall transport rtable = do

248266 serverNodeAddr <- newEmptyMVar

249267 clientDone <- newEmptyMVar

@@ -261,7 +279,7 @@ testCall transport rtable = do

261279

262280 takeMVar clientDone

263281

264−testCallBind :: Transport -> RemoteTable -> IO ()

282+testCallBind :: Transport -> RemoteTable -> Assertion

265283testCallBind transport rtable = do

266284 serverNodeAddr <- newEmptyMVar

267285 clientDone <- newEmptyMVar

@@ -279,7 +297,7 @@ testCallBind transport rtable = do

279297

280298 takeMVar clientDone

281299

282−testSeq :: Transport -> RemoteTable -> IO ()

300+testSeq :: Transport -> RemoteTable -> Assertion

283301testSeq transport rtable = do

284302 node <- newLocalNode transport rtable

285303 done <- newEmptyMVar

@@ -297,7 +315,7 @@ testSeq transport rtable = do

297315-- child. The supervisor then throws an exception, the child dies because it

298316-- was linked to the supervisor, and the third process notices that the child

299317-- dies.

300−testSpawnSupervised :: Transport -> RemoteTable -> IO ()

318+testSpawnSupervised :: Transport -> RemoteTable -> Assertion

301319testSpawnSupervised transport rtable = do

302320 [node1, node2] <- replicateM 2 $ newLocalNode transport rtable

303321 [superPid, childPid] <- replicateM 2 $ newEmptyMVar

@@ -326,7 +344,7 @@ testSpawnSupervised transport rtable = do

326344 supervisorDeath :: IOException

327345 supervisorDeath = userError "Supervisor died"

328346

329−testSpawnInvalid :: Transport -> RemoteTable -> IO ()

347+testSpawnInvalid :: Transport -> RemoteTable -> Assertion

330348testSpawnInvalid transport rtable = do

331349 node <- newLocalNode transport rtable

332350 done <- newEmptyMVar

@@ -338,7 +356,7 @@ testSpawnInvalid transport rtable = do

338356 liftIO $ putMVar done ()

339357 takeMVar done

340358

341−testClosureExpect :: Transport -> RemoteTable -> IO ()

359+testClosureExpect :: Transport -> RemoteTable -> Assertion

342360testClosureExpect transport rtable = do

343361 node <- newLocalNode transport rtable

344362 done <- newEmptyMVar

@@ -351,7 +369,7 @@ testClosureExpect transport rtable = do

351369 liftIO $ putMVar done ()

352370 takeMVar done

353371

354−testSpawnChannel :: Transport -> RemoteTable -> IO ()

372+testSpawnChannel :: Transport -> RemoteTable -> Assertion

355373testSpawnChannel transport rtable = do

356374 done <- newEmptyMVar

357375 [node1, node2] <- replicateM 2 $ newLocalNode transport rtable

@@ -368,7 +386,7 @@ testSpawnChannel transport rtable = do

368386

369387 takeMVar done

370388

371−testTDict :: Transport -> RemoteTable -> IO ()

389+testTDict :: Transport -> RemoteTable -> Assertion

372390testTDict transport rtable = do

373391 done <- newEmptyMVar

374392 [node1, node2] <- replicateM 2 $ newLocalNode transport rtable

@@ -377,14 +395,7 @@ testTDict transport rtable = do

377395 liftIO $ putMVar done ()

378396 takeMVar done

379397

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

388399testFib transport rtable = do

389400 nodes <- replicateM 4 $ newLocalNode transport rtable

390401 done <- newEmptyMVar

@@ -397,7 +408,7 @@ testFib transport rtable = do

397408

398409 takeMVar done

399410

400−testSpawnReconnect :: Transport -> RemoteTable -> TransportInternals -> IO ()

411+testSpawnReconnect :: Transport -> RemoteTable -> TransportInternals -> Assertion

401412testSpawnReconnect transport rtable transportInternals = do

402413 [node1, node2] <- replicateM 2 $ newLocalNode transport rtable

403414 let nid1 = localNodeId node1

@@ -426,7 +437,7 @@ testSpawnReconnect transport rtable transportInternals = do

426437

427438-- | 'spawn' used to ave a race condition which would be triggered if the

428439-- spawning process terminates immediately after spawning

429−testSpawnTerminate :: Transport -> RemoteTable -> IO ()

440+testSpawnTerminate :: Transport -> RemoteTable -> Assertion

430441testSpawnTerminate transport rtable = do

431442 slave <- newLocalNode transport rtable

432443 master <- newLocalNode transport rtable

@@ -440,26 +451,30 @@ testSpawnTerminate transport rtable = do

440451

441452 takeMVar masterDone

442453

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+

443476main :: IO ()

444477main = do

445− Right (transport, transportInternals) <- createTransportExposeInternals "127.0.0.1" "8080" defaultTCPParameters

478+ Right transport <- createTransportExposeInternals "127.0.0.1" "8080" defaultTCPParameters

446479 let rtable = __remoteTable . __remoteTableDecl $ initRemoteTable

447− runTests

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− ]

480+ defaultMain (tests transport rtable)