git.iko.soy/distributed-process
on 7930062 help sign in
distributed-process/distributed-process-tests/src/Control/Distributed/Process/Tests/Receive.hs
154 lines 4.3 kB history raw
1{-# LANGUAGE TemplateHaskell #-}
2{-# OPTIONS_GHC -Wall #-}
4-- | XXX test doesn't work, because failure exceptions don't get propagated. The
5-- test always claims to succeed, even if it failed.
7module Control.Distributed.Process.Tests.Receive (tests) where
9import Network.Transport.Test (TestTransport(..))
11import Network.Transport (Transport)
12import Control.Distributed.Process
13import Control.Distributed.Process.Node
15import Control.Monad
17import Test.HUnit (Assertion, (@?=))
18import Test.Framework (Test)
19import Test.Framework.Providers.HUnit (testCase)
21-- Tests:
23-- 1. 2 matchChans, receive on each one
24-- 2. matchChan/matchIf, receive on each one
25-- 3. matchIf/matchChan, receive on each one
26-- 4. matchIf/matchChan/matchIf, receive on each one
28recTest1 :: ReceivePort ()
29 -> SendPort String
30 -> ReceivePort String -> ReceivePort String
31 -> Process ()
32recTest1 wait sync r1 r2 = do
33 forever $ do
34 receiveChan wait
35 r <- receiveWait
36 [ matchChan r1 $ \s -> return ("received1 " ++ s)
37 , matchChan r2 $ \s -> return ("received2 " ++ s)
38 ]
39 sendChan sync r
41recTest2 :: ReceivePort ()
42 -> SendPort String
43 -> ReceivePort String -> ReceivePort String
44 -> Process ()
45recTest2 wait sync r1 _ = do
46 forever $ do
47 receiveChan wait
48 r <- receiveWait
49 [ matchChan r1 $ \s -> return ("received1 " ++ s)
50 , matchIf (== "foo") $ \s -> return ("received2 " ++ s)
51 ]
52 sendChan sync r
54recTest3 :: ReceivePort ()
55 -> SendPort String
56 -> ReceivePort String -> ReceivePort String
57 -> Process ()
58recTest3 wait sync r1 _ = do
59 forever $ do
60 receiveChan wait
61 r <- receiveWait
62 [ matchIf (== "foo") $ \s -> return ("received1 " ++ s)
63 , matchChan r1 $ \s -> return ("received2 " ++ s)
64 ]
65 sendChan sync r
67recTest4 :: ReceivePort ()
68 -> SendPort String
69 -> ReceivePort String -> ReceivePort String
70 -> Process ()
71recTest4 wait sync r1 _ = do
72 forever $ do
73 receiveChan wait
74 r <- receiveWait
75 [ matchIf (== "foo") $ \s -> return ("received1 " ++ s)
76 , matchChan r1 $ \s -> return ("received2 " ++ s)
77 , matchIf (== "bar") $ \s -> return ("received3 " ++ s)
78 ]
79 sendChan sync r
81master :: Process ()
82master = do
83 (waits,waitr) <- newChan
84 (syncs,syncr) <- newChan
85 let go expected = do
86 sendChan waits ()
87 r <- receiveChan syncr
88 liftIO $ print (r, expected, r == expected)
89 liftIO $ r @?= expected
91 liftIO $ putStrLn "---- Test 1 ----"
92 (s1,r1) <- newChan
93 (s2,r2) <- newChan
94 p <- spawnLocal (recTest1 waitr syncs r1 r2)
96 sendChan s1 "a" >> go "received1 a"
97 sendChan s2 "b" >> go "received2 b"
98 sendChan s1 "a" >> sendChan s2 "b" >> go "received1 a"
99 go "received2 b"
101 kill p "BANG"
103 liftIO $ putStrLn "\n---- Test 2 ----"
104 (s1,r1) <- newChan
105 (s2,r2) <- newChan
106 p <- spawnLocal (recTest2 waitr syncs r1 r2)
108 sendChan s1 "a" >> go "received1 a"
109 send p "foo" >> go "received2 foo"
110 sendChan s1 "a" >> send p "foo" >> go "received1 a"
111 sendChan s1 "a" >> send p "bar" >> go "received1 a"
112 go "received2 foo"
114 kill p "BANG"
116 liftIO $ putStrLn "\n---- Test 3 ----"
117 (s1,r1) <- newChan
118 (s2,r2) <- newChan
119 p <- spawnLocal (recTest3 waitr syncs r1 r2)
121 sendChan s1 "a" >> go "received2 a"
122 send p "foo" >> go "received1 foo"
123 sendChan s1 "a" >> send p "foo" >> go "received1 foo"
124 sendChan s1 "a" >> send p "bar" >> go "received2 a"
125 go "received2 a"
127 kill p "BANG"
129 liftIO $ putStrLn "\n---- Test 4 ----"
130 (s1,r1) <- newChan
131 (s2,r2) <- newChan
132 p <- spawnLocal (recTest4 waitr syncs r1 r2)
134 sendChan s1 "a" >> go "received2 a"
135 send p "foo" >> go "received1 foo"
136 send p "bar" >> go "received3 bar"
137 sendChan s1 "a" >> send p "foo" >> go "received1 foo"
138 send p "bar" >> go "received2 a"
139 send p "foo" >> go "received1 foo" >> go "received3 bar"
141 kill p "BANG"
143 terminate
145testReceive :: Transport -> RemoteTable -> Assertion
146testReceive transport rtable = do
147 node <- newLocalNode transport rtable
148 runProcess node $ master
150tests :: TestTransport -> IO [Test]
151tests TestTransport{..} = do
152 let rtable = initRemoteTable
153 return
154 [ testCase "testReceive" (testReceive testTransport rtable) ]