Skip to content

Commit f403439

Browse files
qnikstqnikst
committed
Merge pull request #19 from haskell-distributed/inmemory-tests
Run tests using network-transport-inmemory
2 parents e942f0f + 14782a9 commit f403439

File tree

4 files changed

+97
-19
lines changed

4 files changed

+97
-19
lines changed

‎distributed-process-tests.cabal

Lines changed: 33 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,10 @@ category: Control, Cloud Haskell
1111
build-type: Simple
1212
cabal-version: >=1.8
1313

14+
flag tcp
15+
Description: build and run TCP tests
16+
Default: False
17+
1418
library
1519
exposed-modules: Network.Transport.Test
1620
Control.Distributed.Process.Tests.CH
@@ -49,43 +53,61 @@ library
4953
if impl(ghc <= 7.4.2)
5054
Build-Depends: ghc-prim == 0.2.0.0
5155

52-
Test-Suite TestCH
56+
Test-Suite TestCHInMemory
5357
Type: exitcode-stdio-1.0
54-
Main-Is: runTCP.hs
58+
Main-Is: runInMemory.hs
5559
CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.CH
5660
Build-Depends: base >= 4.4 && < 5,
5761
distributed-process-tests,
5862
network >= 2.3 && < 2.7,
5963
network-transport >= 0.4.1.0 && < 0.5,
60-
network-transport-tcp >= 0.3 && < 0.5,
64+
network-transport-inmemory >= 0.5,
6165
test-framework >= 0.6 && < 0.9
6266
Extensions: CPP
6367
ghc-options: -Wall -threaded -debug -eventlog -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
6468
HS-Source-Dirs: tests
6569

66-
Test-Suite TestClosure
70+
Test-Suite TestCHInTCP
6771
Type: exitcode-stdio-1.0
6872
Main-Is: runTCP.hs
73+
CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.CH
74+
if flag(tcp)
75+
Build-Depends: base >= 4.4 && < 5,
76+
distributed-process-tests,
77+
network >= 2.3 && < 2.7,
78+
network-transport >= 0.4.1.0 && < 0.5,
79+
network-transport-tcp >= 0.3 && < 0.5,
80+
test-framework >= 0.6 && < 0.9
81+
else
82+
Buildable: False
83+
Extensions: CPP
84+
ghc-options: -Wall -threaded -debug -eventlog -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
85+
HS-Source-Dirs: tests
86+
87+
88+
Test-Suite TestClosure
89+
Type: exitcode-stdio-1.0
90+
Main-Is: runInMemory.hs
6991
CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Closure
7092
Build-Depends: base >= 4.4 && < 5,
7193
distributed-process-tests,
7294
network >= 2.3 && < 2.7,
7395
network-transport >= 0.4.1.0 && < 0.5,
74-
network-transport-tcp >= 0.3 && < 0.5,
96+
network-transport-inmemory >= 0.5,
7597
test-framework >= 0.6 && < 0.9
7698
Extensions: CPP
7799
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
78100
HS-Source-Dirs: tests
79101

80102
Test-Suite TestStats
81103
Type: exitcode-stdio-1.0
82-
Main-Is: runTCP.hs
104+
Main-Is: runInMemory.hs
83105
CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Stats
84106
Build-Depends: base >= 4.4 && < 5,
85107
distributed-process-tests,
86108
network >= 2.3 && < 2.7,
87109
network-transport >= 0.4.1.0 && < 0.5,
88-
network-transport-tcp >= 0.3 && < 0.5,
110+
network-transport-inmemory >= 0.5,
89111
test-framework >= 0.6 && < 0.9
90112
Extensions: CPP
91113
ghc-options: -Wall -debug -eventlog -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
@@ -94,27 +116,27 @@ Test-Suite TestStats
94116

95117
Test-Suite TestMx
96118
Type: exitcode-stdio-1.0
97-
Main-Is: runTCP.hs
119+
Main-Is: runInMemory.hs
98120
CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Mx
99121
Build-Depends: base >= 4.4 && < 5,
100122
distributed-process-tests,
101123
network >= 2.3 && < 2.7,
102124
network-transport >= 0.4.1.0 && < 0.5,
103-
network-transport-tcp >= 0.3 && < 0.5,
125+
network-transport-inmemory >= 0.5,
104126
test-framework >= 0.6 && < 0.9
105127
Extensions: CPP
106128
ghc-options: -Wall -debug -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
107129
HS-Source-Dirs: tests
108130

109131
Test-Suite TestTracing
110132
Type: exitcode-stdio-1.0
111-
Main-Is: runTCP.hs
133+
Main-Is: runInMemory.hs
112134
CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Tracing
113135
Build-Depends: base >= 4.4 && < 5,
114136
distributed-process-tests,
115137
network >= 2.3 && < 2.7,
116138
network-transport >= 0.4.1.0 && < 0.5,
117-
network-transport-tcp >= 0.3 && < 0.5,
139+
network-transport-inmemory >= 0.5,
118140
test-framework >= 0.6 && < 0.9
119141
Extensions: CPP
120142
ghc-options: -Wall -debug -eventlog -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind

‎src/Control/Distributed/Process/Tests/CH.hs

Lines changed: 32 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -21,7 +21,7 @@ import Control.Monad (replicateM_, replicateM, forever, void, unless)
2121
import Control.Exception (SomeException, throwIO)
2222
import qualified Control.Exception as Ex (catch)
2323
import Control.Applicative ((<$>), (<*>), pure, (<|>))
24-
import qualified Network.Transport as NT (closeEndPoint)
24+
import qualified Network.Transport as NT (closeEndPoint, EndPointAddress)
2525
import Control.Distributed.Process
2626
import Control.Distributed.Process.Internal.Types
2727
( NodeId(nodeAddress)
@@ -302,19 +302,25 @@ testMonitorRemoteDeadProcess TestTransport{..} mOrL un = do
302302
testMonitorDisconnect :: TestTransport -> Bool -> Bool -> Assertion
303303
testMonitorDisconnect TestTransport{..} mOrL un = do
304304
processAddr <- newEmptyMVar
305+
processAddr2 <- newEmptyMVar
305306
monitorSetup <- newEmptyMVar
306307
done <- newEmptyMVar
307308

308309
forkIO $ do
309310
localNode <- newLocalNode testTransport initRemoteTable
310-
addr <- forkProcess localNode . liftIO $ threadDelay 1000000
311+
addr <- forkProcess localNode $ expect
312+
addr2 <- forkProcess localNode $ return ()
311313
putMVar processAddr addr
312314
readMVar monitorSetup
313315
NT.closeEndPoint (localEndPoint localNode)
316+
putMVar processAddr2 addr2
314317

315318
forkIO $ do
316319
localNode <- newLocalNode testTransport initRemoteTable
317320
theirAddr <- readMVar processAddr
321+
forkProcess localNode $ do
322+
lc <- liftIO $ readMVar processAddr2
323+
send lc ()
318324
runProcess localNode $ do
319325
monitorTestProcess theirAddr mOrL un DiedDisconnect (Just monitorSetup) done
320326

@@ -583,17 +589,22 @@ testMonitorLiveNode :: TestTransport -> Assertion
583589
testMonitorLiveNode TestTransport{..} = do
584590
[node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable
585591
ready <- newEmptyMVar
592+
readyr <- newEmptyMVar
586593
done <- newEmptyMVar
587594

595+
p <- forkProcess node1 $ return ()
588596
forkProcess node2 $ do
589597
ref <- monitorNode (localNodeId node1)
590598
liftIO $ putMVar ready ()
599+
liftIO $ takeMVar readyr
600+
send p ()
591601
NodeMonitorNotification ref' nid _ <- expect
592602
True <- return $ ref == ref' && nid == localNodeId node1
593603
liftIO $ putMVar done ()
594604

595605
takeMVar ready
596606
closeLocalNode node1
607+
putMVar readyr ()
597608

598609
takeMVar done
599610

@@ -688,7 +699,6 @@ testReconnect :: TestTransport -> Assertion
688699
testReconnect TestTransport{..} = do
689700
[node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable
690701
let nid1 = localNodeId node1
691-
nid2 = localNodeId node2
692702
processA <- newEmptyMVar
693703
[sendTestOk, registerTestOk] <- replicateM 2 newEmptyMVar
694704

@@ -709,7 +719,8 @@ testReconnect TestTransport{..} = do
709719
send them "message 1" >> liftIO (threadDelay 100000)
710720

711721
-- Simulate network failure
712-
liftIO $ testBreakConnection (nodeAddress nid1) (nodeAddress nid2)
722+
liftIO $ syncBreakConnection testBreakConnection node1 node2
723+
713724

714725
-- Should not arrive
715726
send them "message 2"
@@ -734,7 +745,7 @@ testReconnect TestTransport{..} = do
734745

735746

736747
-- Simulate network failure
737-
liftIO $ testBreakConnection (nodeAddress nid1) (nodeAddress nid2)
748+
liftIO $ syncBreakConnection testBreakConnection node1 node2
738749

739750
-- This will happen due to implicit reconnect
740751
registerRemoteAsync nid1 "b" us
@@ -1320,7 +1331,7 @@ testUnsafeSendChan TestTransport{..} = do
13201331

13211332
tests :: TestTransport -> IO [Test]
13221333
tests testtrans = return [
1323-
testGroup "Basic features" [
1334+
testGroup "Basic features" [
13241335
testCase "Ping" (testPing testtrans)
13251336
, testCase "Math" (testMath testtrans)
13261337
, testCase "Timeout" (testTimeout testtrans)
@@ -1356,7 +1367,7 @@ tests testtrans = return [
13561367
-- usend
13571368
, testCase "USend" (testUSend testtrans 50)
13581369
]
1359-
, testGroup "Monitoring and Linking" [
1370+
, testGroup "Monitoring and Linking" [
13601371
-- Monitoring processes
13611372
--
13621373
-- The "missing" combinations in the list below don't make much sense, as
@@ -1388,3 +1399,17 @@ tests testtrans = return [
13881399
, testCase "Reconnect" (testReconnect testtrans)
13891400
]
13901401
]
1402+
1403+
syncBreakConnection :: (NT.EndPointAddress -> NT.EndPointAddress -> IO ()) -> LocalNode -> LocalNode -> IO ()
1404+
syncBreakConnection breakConnection nid0 nid1 = do
1405+
m <- newEmptyMVar
1406+
_ <- forkProcess nid1 $ getSelfPid >>= liftIO . putMVar m
1407+
runProcess nid0 $ do
1408+
them <- liftIO $ takeMVar m
1409+
pinger <- spawnLocal $ forever $ send them ()
1410+
_ <- monitorNode (localNodeId nid1)
1411+
liftIO $ breakConnection (nodeAddress $ localNodeId nid0)
1412+
(nodeAddress $ localNodeId nid1)
1413+
NodeMonitorNotification _ _ _ <- expect
1414+
kill pinger "finished"
1415+
return ()

‎tests/runInMemory.hs

Lines changed: 31 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,31 @@
1+
-- Run tests using the TCP transport.
2+
3+
module Main where
4+
5+
import TEST_SUITE_MODULE (tests)
6+
7+
import Network.Transport.Test (TestTransport(..))
8+
import Network.Transport.InMemory
9+
import Test.Framework (defaultMainWithArgs)
10+
11+
import Control.Concurrent (threadDelay)
12+
import System.Environment (getArgs)
13+
14+
main :: IO ()
15+
main = do
16+
(transport, internals) <- createTransportExposeInternals
17+
ts <- tests TestTransport
18+
{ testTransport = transport
19+
, testBreakConnection = \addr1 addr2 -> breakConnection internals addr1 addr2 "user error"
20+
}
21+
args <- getArgs
22+
-- Tests are time sensitive. Running the tests concurrently can slow them
23+
-- down enough that threads using threadDelay would wake up later than
24+
-- expected, thus changing the order in which messages were expected.
25+
-- Therefore we run the tests sequentially by passing "-j 1" to
26+
-- test-framework. This does not solve the issue but makes it less likely.
27+
--
28+
-- The problem was first detected with
29+
-- 'Control.Distributed.Process.Tests.CH.testMergeChannels'
30+
-- in particular.
31+
defaultMainWithArgs ts ("-j" : "1" : args)

‎tests/runTCP.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
-- Run tests using the TCP transport.
2-
2+
--
33
module Main where
44

55
import TEST_SUITE_MODULE (tests)

0 commit comments

Comments
 (0)