@@ -0,0 +1,149 @@
1+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-}
2+{-# OPTIONS_GHC -Wall #-}
3+import Control.Distributed.Process
4+import Control.Distributed.Process.Closure
5+
6+import Control.Monad
7+import Text.Printf
8+import Data.DeriveTH
9+import Data.Binary
10+import Data.Typeable
11+
12+import DistribUtils
13+
14+import Test.Framework (defaultMain, testGroup)
15+import Test.Framework.Providers.HUnit
16+import Test.HUnit
17+
18+-- Tests:
19+
20+-- 1. 2 matchChans, receive on each one
21+-- 2. matchChan/matchIf, receive on each one
22+-- 3. matchIf/matchChan, receive on each one
23+-- 4. matchIf/matchChan/matchIf, receive on each one
24+
25+recTest1 :: ReceivePort ()
26+ -> SendPort String
27+ -> ReceivePort String -> ReceivePort String
28+ -> Process ()
29+recTest1 wait sync r1 r2 = do
30+ forever $ do
31+ receiveChan wait
32+ r <- receiveWait
33+ [ matchChan r1 $ \s -> return ("received1 " ++ s)
34+ , matchChan r2 $ \s -> return ("received2 " ++ s)
35+ ]
36+ sendChan sync r
37+
38+recTest2 :: ReceivePort ()
39+ -> SendPort String
40+ -> ReceivePort String -> ReceivePort String
41+ -> Process ()
42+recTest2 wait sync r1 r2 = do
43+ forever $ do
44+ receiveChan wait
45+ r <- receiveWait
46+ [ matchChan r1 $ \s -> return ("received1 " ++ s)
47+ , matchIf (== "foo") $ \s -> return ("received2 " ++ s)
48+ ]
49+ sendChan sync r
50+
51+recTest3 :: ReceivePort ()
52+ -> SendPort String
53+ -> ReceivePort String -> ReceivePort String
54+ -> Process ()
55+recTest3 wait sync r1 r2 = do
56+ forever $ do
57+ receiveChan wait
58+ r <- receiveWait
59+ [ matchIf (== "foo") $ \s -> return ("received1 " ++ s)
60+ , matchChan r1 $ \s -> return ("received2 " ++ s)
61+ ]
62+ sendChan sync r
63+
64+recTest4 :: ReceivePort ()
65+ -> SendPort String
66+ -> ReceivePort String -> ReceivePort String
67+ -> Process ()
68+recTest4 wait sync r1 r2 = do
69+ forever $ do
70+ receiveChan wait
71+ r <- receiveWait
72+ [ matchIf (== "foo") $ \s -> return ("received1 " ++ s)
73+ , matchChan r1 $ \s -> return ("received2 " ++ s)
74+ , matchIf (== "bar") $ \s -> return ("received3 " ++ s)
75+ ]
76+ sendChan sync r
77+
78+
79+master :: [NodeId] -> Process ()
80+master peers = do
81+
82+ (waits,waitr) <- newChan
83+ (syncs,syncr) <- newChan
84+ let go expect = do
85+ sendChan waits ()
86+ r <- receiveChan syncr
87+ liftIO $ print (r,expect, r == expect)
88+ liftIO $ r @?= expect
89+
90+ liftIO $ putStrLn "---- Test 1 ----"
91+ (s1,r1) <- newChan
92+ (s2,r2) <- newChan
93+ p <- spawnLocal (recTest1 waitr syncs r1 r2)
94+
95+ sendChan s1 "a" >> go "received1 a"
96+ sendChan s2 "b" >> go "received2 b"
97+ sendChan s1 "a" >> sendChan s2 "b" >> go "received1 a"
98+ go "received2 b"
99+
100+ kill p "BANG"
101+
102+ liftIO $ putStrLn "\n---- Test 2 ----"
103+ (s1,r1) <- newChan
104+ (s2,r2) <- newChan
105+ p <- spawnLocal (recTest2 waitr syncs r1 r2)
106+
107+ sendChan s1 "a" >> go "received1 a"
108+ send p "foo" >> go "received2 foo"
109+ sendChan s1 "a" >> send p "foo" >> go "received1 a"
110+ sendChan s1 "a" >> send p "bar" >> go "received1 a"
111+ go "received2 foo"
112+
113+ kill p "BANG"
114+
115+ liftIO $ putStrLn "\n---- Test 3 ----"
116+ (s1,r1) <- newChan
117+ (s2,r2) <- newChan
118+ p <- spawnLocal (recTest3 waitr syncs r1 r2)
119+
120+ sendChan s1 "a" >> go "received2 a"
121+ send p "foo" >> go "received1 foo"
122+ sendChan s1 "a" >> send p "foo" >> go "received1 foo"
123+ sendChan s1 "a" >> send p "bar" >> go "received2 a"
124+ go "received2 a"
125+
126+ kill p "BANG"
127+
128+ liftIO $ putStrLn "\n---- Test 4 ----"
129+ (s1,r1) <- newChan
130+ (s2,r2) <- newChan
131+ p <- spawnLocal (recTest4 waitr syncs r1 r2)
132+
133+ sendChan s1 "a" >> go "received2 a"
134+ send p "foo" >> go "received1 foo"
135+ send p "bar" >> go "received3 bar"
136+ sendChan s1 "a" >> send p "foo" >> go "received1 foo"
137+ send p "bar" >> go "received2 a"
138+ send p "foo" >> go "received1 foo" >> go "received3 bar"
139+
140+ kill p "BANG"
141+
142+ terminate
143+
144+
145+-- NB. test doesn't work, because failure exceptions don't get
146+-- propagated.
147+
148+main :: IO ()
149+main = defaultMain [ testCase "all" $ distribMain master id ]