git.iko.soy/distributed-process
on 391cb93 help sign in
distributed-process/distributed-process-tests/src/Control/Distributed/Process/Tests/Receive.hs
155 lines 4.4 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.Closure
14import Control.Distributed.Process.Node
16import Control.Monad
18import Test.HUnit (Assertion, (@?=))
19import Test.Framework (Test, defaultMain)
20import Test.Framework.Providers.HUnit (testCase)
22-- Tests:
24-- 1. 2 matchChans, receive on each one
25-- 2. matchChan/matchIf, receive on each one
26-- 3. matchIf/matchChan, receive on each one
27-- 4. matchIf/matchChan/matchIf, receive on each one
29recTest1 :: ReceivePort ()
30 -> SendPort String
31 -> ReceivePort String -> ReceivePort String
32 -> Process ()
33recTest1 wait sync r1 r2 = do
34 forever $ do
35 receiveChan wait
36 r <- receiveWait
37 [ matchChan r1 $ \s -> return ("received1 " ++ s)
38 , matchChan r2 $ \s -> return ("received2 " ++ s)
39 ]
40 sendChan sync r
42recTest2 :: ReceivePort ()
43 -> SendPort String
44 -> ReceivePort String -> ReceivePort String
45 -> Process ()
46recTest2 wait sync r1 r2 = do
47 forever $ do
48 receiveChan wait
49 r <- receiveWait
50 [ matchChan r1 $ \s -> return ("received1 " ++ s)
51 , matchIf (== "foo") $ \s -> return ("received2 " ++ s)
52 ]
53 sendChan sync r
55recTest3 :: ReceivePort ()
56 -> SendPort String
57 -> ReceivePort String -> ReceivePort String
58 -> Process ()
59recTest3 wait sync r1 r2 = do
60 forever $ do
61 receiveChan wait
62 r <- receiveWait
63 [ matchIf (== "foo") $ \s -> return ("received1 " ++ s)
64 , matchChan r1 $ \s -> return ("received2 " ++ s)
65 ]
66 sendChan sync r
68recTest4 :: ReceivePort ()
69 -> SendPort String
70 -> ReceivePort String -> ReceivePort String
71 -> Process ()
72recTest4 wait sync r1 r2 = do
73 forever $ do
74 receiveChan wait
75 r <- receiveWait
76 [ matchIf (== "foo") $ \s -> return ("received1 " ++ s)
77 , matchChan r1 $ \s -> return ("received2 " ++ s)
78 , matchIf (== "bar") $ \s -> return ("received3 " ++ s)
79 ]
80 sendChan sync r
82master :: Process ()
83master = do
84 (waits,waitr) <- newChan
85 (syncs,syncr) <- newChan
86 let go expect = do
87 sendChan waits ()
88 r <- receiveChan syncr
89 liftIO $ print (r,expect, r == expect)
90 liftIO $ r @?= expect
92 liftIO $ putStrLn "---- Test 1 ----"
93 (s1,r1) <- newChan
94 (s2,r2) <- newChan
95 p <- spawnLocal (recTest1 waitr syncs r1 r2)
97 sendChan s1 "a" >> go "received1 a"
98 sendChan s2 "b" >> go "received2 b"
99 sendChan s1 "a" >> sendChan s2 "b" >> go "received1 a"
100 go "received2 b"
102 kill p "BANG"
104 liftIO $ putStrLn "\n---- Test 2 ----"
105 (s1,r1) <- newChan
106 (s2,r2) <- newChan
107 p <- spawnLocal (recTest2 waitr syncs r1 r2)
109 sendChan s1 "a" >> go "received1 a"
110 send p "foo" >> go "received2 foo"
111 sendChan s1 "a" >> send p "foo" >> go "received1 a"
112 sendChan s1 "a" >> send p "bar" >> go "received1 a"
113 go "received2 foo"
115 kill p "BANG"
117 liftIO $ putStrLn "\n---- Test 3 ----"
118 (s1,r1) <- newChan
119 (s2,r2) <- newChan
120 p <- spawnLocal (recTest3 waitr syncs r1 r2)
122 sendChan s1 "a" >> go "received2 a"
123 send p "foo" >> go "received1 foo"
124 sendChan s1 "a" >> send p "foo" >> go "received1 foo"
125 sendChan s1 "a" >> send p "bar" >> go "received2 a"
126 go "received2 a"
128 kill p "BANG"
130 liftIO $ putStrLn "\n---- Test 4 ----"
131 (s1,r1) <- newChan
132 (s2,r2) <- newChan
133 p <- spawnLocal (recTest4 waitr syncs r1 r2)
135 sendChan s1 "a" >> go "received2 a"
136 send p "foo" >> go "received1 foo"
137 send p "bar" >> go "received3 bar"
138 sendChan s1 "a" >> send p "foo" >> go "received1 foo"
139 send p "bar" >> go "received2 a"
140 send p "foo" >> go "received1 foo" >> go "received3 bar"
142 kill p "BANG"
144 terminate
146testReceive :: Transport -> RemoteTable -> Assertion
147testReceive transport rtable = do
148 node <- newLocalNode transport rtable
149 runProcess node $ master
151tests :: TestTransport -> IO [Test]
152tests TestTransport{..} = do
153 let rtable = initRemoteTable
154 return
155 [ testCase "testReceive" (testReceive testTransport rtable) ]