git.iko.soy/distributed-process
on 30123fc help sign in
distributed-process/distributed-process-tests/src/Control/Distributed/Process/Tests/Receive.hs
158 lines 4.4 kB history raw
1{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-}
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
17import Text.Printf
18import Data.Binary
19import Data.Typeable
21import Test.HUnit (Assertion, (@?=))
22import Test.Framework (Test, defaultMain)
23import Test.Framework.Providers.HUnit (testCase)
25-- Tests:
27-- 1. 2 matchChans, receive on each one
28-- 2. matchChan/matchIf, receive on each one
29-- 3. matchIf/matchChan, receive on each one
30-- 4. matchIf/matchChan/matchIf, receive on each one
32recTest1 :: ReceivePort ()
33 -> SendPort String
34 -> ReceivePort String -> ReceivePort String
35 -> Process ()
36recTest1 wait sync r1 r2 = do
37 forever $ do
38 receiveChan wait
39 r <- receiveWait
40 [ matchChan r1 $ \s -> return ("received1 " ++ s)
41 , matchChan r2 $ \s -> return ("received2 " ++ s)
42 ]
43 sendChan sync r
45recTest2 :: ReceivePort ()
46 -> SendPort String
47 -> ReceivePort String -> ReceivePort String
48 -> Process ()
49recTest2 wait sync r1 r2 = do
50 forever $ do
51 receiveChan wait
52 r <- receiveWait
53 [ matchChan r1 $ \s -> return ("received1 " ++ s)
54 , matchIf (== "foo") $ \s -> return ("received2 " ++ s)
55 ]
56 sendChan sync r
58recTest3 :: ReceivePort ()
59 -> SendPort String
60 -> ReceivePort String -> ReceivePort String
61 -> Process ()
62recTest3 wait sync r1 r2 = do
63 forever $ do
64 receiveChan wait
65 r <- receiveWait
66 [ matchIf (== "foo") $ \s -> return ("received1 " ++ s)
67 , matchChan r1 $ \s -> return ("received2 " ++ s)
68 ]
69 sendChan sync r
71recTest4 :: ReceivePort ()
72 -> SendPort String
73 -> ReceivePort String -> ReceivePort String
74 -> Process ()
75recTest4 wait sync r1 r2 = do
76 forever $ do
77 receiveChan wait
78 r <- receiveWait
79 [ matchIf (== "foo") $ \s -> return ("received1 " ++ s)
80 , matchChan r1 $ \s -> return ("received2 " ++ s)
81 , matchIf (== "bar") $ \s -> return ("received3 " ++ s)
82 ]
83 sendChan sync r
85master :: Process ()
86master = do
87 (waits,waitr) <- newChan
88 (syncs,syncr) <- newChan
89 let go expect = do
90 sendChan waits ()
91 r <- receiveChan syncr
92 liftIO $ print (r,expect, r == expect)
93 liftIO $ r @?= expect
95 liftIO $ putStrLn "---- Test 1 ----"
96 (s1,r1) <- newChan
97 (s2,r2) <- newChan
98 p <- spawnLocal (recTest1 waitr syncs r1 r2)
100 sendChan s1 "a" >> go "received1 a"
101 sendChan s2 "b" >> go "received2 b"
102 sendChan s1 "a" >> sendChan s2 "b" >> go "received1 a"
103 go "received2 b"
105 kill p "BANG"
107 liftIO $ putStrLn "\n---- Test 2 ----"
108 (s1,r1) <- newChan
109 (s2,r2) <- newChan
110 p <- spawnLocal (recTest2 waitr syncs r1 r2)
112 sendChan s1 "a" >> go "received1 a"
113 send p "foo" >> go "received2 foo"
114 sendChan s1 "a" >> send p "foo" >> go "received1 a"
115 sendChan s1 "a" >> send p "bar" >> go "received1 a"
116 go "received2 foo"
118 kill p "BANG"
120 liftIO $ putStrLn "\n---- Test 3 ----"
121 (s1,r1) <- newChan
122 (s2,r2) <- newChan
123 p <- spawnLocal (recTest3 waitr syncs r1 r2)
125 sendChan s1 "a" >> go "received2 a"
126 send p "foo" >> go "received1 foo"
127 sendChan s1 "a" >> send p "foo" >> go "received1 foo"
128 sendChan s1 "a" >> send p "bar" >> go "received2 a"
129 go "received2 a"
131 kill p "BANG"
133 liftIO $ putStrLn "\n---- Test 4 ----"
134 (s1,r1) <- newChan
135 (s2,r2) <- newChan
136 p <- spawnLocal (recTest4 waitr syncs r1 r2)
138 sendChan s1 "a" >> go "received2 a"
139 send p "foo" >> go "received1 foo"
140 send p "bar" >> go "received3 bar"
141 sendChan s1 "a" >> send p "foo" >> go "received1 foo"
142 send p "bar" >> go "received2 a"
143 send p "foo" >> go "received1 foo" >> go "received3 bar"
145 kill p "BANG"
147 terminate
149testReceive :: Transport -> RemoteTable -> Assertion
150testReceive transport rtable = do
151 node <- newLocalNode transport rtable
152 runProcess node $ master
154tests :: TestTransport -> IO [Test]
155tests TestTransport{..} = do
156 let rtable = initRemoteTable
157 return
158 [ testCase "testReceive" (testReceive testTransport rtable) ]