@@ -3,8 +3,10 @@ module Main where
33import Prelude hiding (catch)
44import Data.Binary (Binary)
55import Data.Typeable (Typeable)
6+import Data.Foldable (forM_)
67import Control.Concurrent (forkIO, threadDelay)
7−import Control.Concurrent.MVar ( newEmptyMVar
8+import Control.Concurrent.MVar ( MVar
9+ , newEmptyMVar
810 , putMVar
911 , takeMVar
1012 , readMVar
@@ -64,13 +66,53 @@ testPing transport = do
6466 takeMVar clientDone
6567
6668-- | Monitor or link to a remote node
67−monitorOrLink :: Bool -> ProcessId -> Process (Maybe MonitorRef)
68−monitorOrLink True pid = Just <$> monitor pid
69−monitorOrLink False pid = link pid >> return Nothing
69+monitorOrLink :: Bool -- ^ 'True' for monitor, 'False' for link
70+ -> ProcessId -- Process to monitor/link to
71+ -> Maybe (MVar ()) -- MVar to signal on once the monitor has been set up
72+ -> Process (Maybe MonitorRef)
73+monitorOrLink mOrL pid mSignal = do
74+ result <- if mOrL then Just <$> monitor pid
75+ else link pid >> return Nothing
76+ -- Monitor is asynchronous, which usually does not matter but if we want a
77+ -- *specific* signal then it does. Therefore we wait an arbitrary delay and
78+ -- hope that this means the monitor has been set up
79+ forM_ mSignal $ \signal -> liftIO . forkIO $ threadDelay 100000 >> putMVar signal ()
80+ return result
81+
82+monitorTestProcess :: ProcessId -- Process to monitor/link to
83+ -> Bool -- 'True' for monitor, 'False' for link
84+ -> Bool -- Should we unmonitor?
85+ -> DiedReason -- Expected cause of death
86+ -> Maybe (MVar ()) -- Signal for 'monitor set up'
87+ -> MVar () -- Signal for successful termination
88+ -> Process ()
89+monitorTestProcess theirAddr mOrL un reason monitorSetup done =
90+ catch (do mRef <- monitorOrLink mOrL theirAddr monitorSetup
91+ case (un, mRef) of
92+ (True, Nothing) -> do
93+ unlink theirAddr
94+ DidUnlink pid <- expect
95+ True <- return $ pid == theirAddr
96+ liftIO $ putMVar done ()
97+ (True, Just ref) -> do
98+ unmonitor ref
99+ DidUnmonitor ref' <- expect
100+ True <- return $ ref == ref'
101+ liftIO $ putMVar done ()
102+ (False, ref) -> do
103+ MonitorNotification ref' pid reason' <- expect
104+ True <- return $ Just ref' == ref && pid == theirAddr && mOrL && reason == reason'
105+ liftIO $ putMVar done ()
106+ )
107+ (\(LinkException pid reason') -> do
108+ True <- return $ pid == theirAddr && not mOrL && not un && reason == reason'
109+ liftIO $ putMVar done ()
110+ )
111+
70112
71113-- | Monitor an unreachable node
72−testMonitorUnreachable :: NT.Transport -> Bool -> IO ()
73−testMonitorUnreachable transport mOrL = do
114+testMonitorUnreachable :: NT.Transport -> Bool -> Bool -> IO ()
115+testMonitorUnreachable transport mOrL un = do
74116 deadProcess <- newEmptyMVar
75117 done <- newEmptyMVar
76118
@@ -84,19 +126,13 @@ testMonitorUnreachable transport mOrL = do
84126 localNode <- newLocalNode transport
85127 theirAddr <- readMVar deadProcess
86128 runProcess localNode $
87− catch (do ref <- monitorOrLink mOrL theirAddr
88− MonitorNotification ref' pid DiedDisconnect <- expect
89− True <- return $ Just ref' == ref && pid == theirAddr && mOrL
90− liftIO $ putMVar done ())
91− (\(LinkException pid DiedDisconnect) -> do
92− True <- return $ pid == theirAddr && not mOrL
93− liftIO $ putMVar done ())
129+ monitorTestProcess theirAddr mOrL un DiedDisconnect Nothing done
94130
95131 takeMVar done
96132
97133-- | Monitor a process which terminates normally
98−testMonitorNormalTermination :: NT.Transport -> Bool -> IO ()
99−testMonitorNormalTermination transport mOrL = do
134+testMonitorNormalTermination :: NT.Transport -> Bool -> Bool -> IO ()
135+testMonitorNormalTermination transport mOrL un = do
100136 monitorSetup <- newEmptyMVar
101137 monitoredProcess <- newEmptyMVar
102138 done <- newEmptyMVar
@@ -111,25 +147,13 @@ testMonitorNormalTermination transport mOrL = do
111147 localNode <- newLocalNode transport
112148 theirAddr <- readMVar monitoredProcess
113149 runProcess localNode $
114− catch (do ref <- monitorOrLink mOrL theirAddr
115− liftIO $ do
116− -- Monitor is asynchronous, but we want to make sure the monitor has
117− -- been fully created before allowing the remote process to terminate,
118− -- otherwise we might get a different signal here
119− threadDelay 100000
120− putMVar monitorSetup ()
121− MonitorNotification ref' pid DiedNormal <- expect
122− True <- return $ Just ref' == ref && pid == theirAddr && mOrL
123− liftIO $ putMVar done ())
124− (\(LinkException pid DiedNormal) -> do
125− True <- return $ pid == theirAddr && not mOrL
126− liftIO $ putMVar done ())
150+ monitorTestProcess theirAddr mOrL un DiedNormal (Just monitorSetup) done
127151
128152 takeMVar done
129153
130154-- | Monitor a process which terminates abnormally
131−testMonitorAbnormalTermination :: NT.Transport -> Bool -> IO ()
132−testMonitorAbnormalTermination transport mOrL = do
155+testMonitorAbnormalTermination :: NT.Transport -> Bool -> Bool -> IO ()
156+testMonitorAbnormalTermination transport mOrL un = do
133157 monitorSetup <- newEmptyMVar
134158 monitoredProcess <- newEmptyMVar
135159 done <- newEmptyMVar
@@ -147,25 +171,13 @@ testMonitorAbnormalTermination transport mOrL = do
147171 localNode <- newLocalNode transport
148172 theirAddr <- readMVar monitoredProcess
149173 runProcess localNode $
150− catch (do ref <- monitorOrLink mOrL theirAddr
151− liftIO $ do
152− -- Monitor is asynchronous, but we want to make sure the monitor has
153− -- been fully created before allowing the remote process to terminate,
154− -- otherwise we might get a different signal here
155− threadDelay 100000
156− putMVar monitorSetup ()
157− MonitorNotification ref' pid (DiedException err') <- expect
158− True <- return $ Just ref' == ref && pid == theirAddr && err' == show err && mOrL
159− liftIO $ putMVar done ())
160− (\(LinkException pid (DiedException err')) -> do
161− True <- return $ pid == theirAddr && err' == show err && not mOrL
162− liftIO $ putMVar done ())
174+ monitorTestProcess theirAddr mOrL un (DiedException (show err)) (Just monitorSetup) done
163175
164176 takeMVar done
165177
166178-- | Monitor a local process that is already dead
167−testMonitorLocalDeadProcess :: NT.Transport -> Bool -> IO ()
168−testMonitorLocalDeadProcess transport mOrL = do
179+testMonitorLocalDeadProcess :: NT.Transport -> Bool -> Bool -> IO ()
180+testMonitorLocalDeadProcess transport mOrL un = do
169181 processDead <- newEmptyMVar
170182 processAddr <- newEmptyMVar
171183 localNode <- newLocalNode transport
@@ -179,19 +191,13 @@ testMonitorLocalDeadProcess transport mOrL = do
179191 theirAddr <- readMVar processAddr
180192 readMVar processDead
181193 runProcess localNode $ do
182− catch (do ref <- monitorOrLink mOrL theirAddr
183− MonitorNotification ref' pid DiedNoProc <- expect
184− True <- return $ Just ref' == ref && pid == theirAddr && mOrL
185− liftIO $ putMVar done ())
186− (\(LinkException pid DiedNoProc) -> do
187− True <- return $ pid == theirAddr && not mOrL
188− liftIO $ putMVar done ())
194+ monitorTestProcess theirAddr mOrL un DiedNoProc Nothing done
189195
190196 takeMVar done
191197
192198-- | Monitor a remote process that is already dead
193−testMonitorRemoteDeadProcess :: NT.Transport -> Bool -> IO ()
194−testMonitorRemoteDeadProcess transport mOrL = do
199+testMonitorRemoteDeadProcess :: NT.Transport -> Bool -> Bool -> IO ()
200+testMonitorRemoteDeadProcess transport mOrL un = do
195201 processDead <- newEmptyMVar
196202 processAddr <- newEmptyMVar
197203 done <- newEmptyMVar
@@ -206,19 +212,13 @@ testMonitorRemoteDeadProcess transport mOrL = do
206212 theirAddr <- readMVar processAddr
207213 readMVar processDead
208214 runProcess localNode $ do
209− catch (do ref <- monitorOrLink mOrL theirAddr
210− MonitorNotification ref' pid DiedNoProc <- expect
211− True <- return $ Just ref' == ref && pid == theirAddr && mOrL
212− liftIO $ putMVar done ())
213− (\(LinkException pid DiedNoProc) -> do
214− True <- return $ pid == theirAddr && not mOrL
215− liftIO $ putMVar done ())
215+ monitorTestProcess theirAddr mOrL un DiedNoProc Nothing done
216216
217217 takeMVar done
218218
219219-- | Monitor a process that becomes disconnected
220−testMonitorDisconnect :: NT.Transport -> Bool -> IO ()
221−testMonitorDisconnect transport mOrL = do
220+testMonitorDisconnect :: NT.Transport -> Bool -> Bool -> IO ()
221+testMonitorDisconnect transport mOrL un = do
222222 processAddr <- newEmptyMVar
223223 monitorSetup <- newEmptyMVar
224224 done <- newEmptyMVar
@@ -234,14 +234,7 @@ testMonitorDisconnect transport mOrL = do
234234 localNode <- newLocalNode transport
235235 theirAddr <- readMVar processAddr
236236 runProcess localNode $ do
237− catch (do ref <- monitorOrLink mOrL theirAddr
238− liftIO $ threadDelay 100000 >> putMVar monitorSetup ()
239− MonitorNotification ref' pid DiedDisconnect <- expect
240− True <- return $ Just ref' == ref && pid == theirAddr && mOrL
241− liftIO $ putMVar done ())
242− (\(LinkException pid DiedDisconnect) -> do
243− True <- return $ pid == theirAddr && not mOrL
244− liftIO $ putMVar done ())
237+ monitorTestProcess theirAddr mOrL un DiedDisconnect (Just monitorSetup) done
245238
246239 takeMVar done
247240
@@ -352,19 +345,28 @@ main :: IO ()
352345main = do
353346 Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
354347 runTests
355− [ --("Ping", testPing transport)
356− ("MonitorUnreachable", testMonitorUnreachable transport True)
357− , ("MonitorNormalTermination", testMonitorNormalTermination transport True)
358− , ("MonitorAbnormalTermination", testMonitorAbnormalTermination transport True)
359− , ("MonitorLocalDeadProcess", testMonitorLocalDeadProcess transport True)
360− , ("MonitorRemoteDeadProcess", testMonitorRemoteDeadProcess transport True)
361− , ("MonitorDisconnect", testMonitorDisconnect transport True)
362− , ("LinkUnreachable", testMonitorUnreachable transport False)
363− , ("LinkNormalTermination", testMonitorNormalTermination transport False)
364− , ("LinkAbnormalTermination", testMonitorAbnormalTermination transport False)
365− , ("LinkLocalDeadProcess", testMonitorLocalDeadProcess transport False)
366− , ("LinkRemoteDeadProcess", testMonitorRemoteDeadProcess transport False)
367− , ("LinkDisconnect", testMonitorDisconnect transport False)
348+ [ ("Ping", testPing transport)
349+ -- The "missing" combinations in the list below don't make much sense, as
350+ -- we cannot guarantee that the monitor reply or link exception will not
351+ -- happen before the unmonitor or unlink
352+ , ("MonitorUnreachable", testMonitorUnreachable transport True False)
353+ , ("MonitorNormalTermination", testMonitorNormalTermination transport True False)
354+ , ("MonitorAbnormalTermination", testMonitorAbnormalTermination transport True False)
355+ , ("MonitorLocalDeadProcess", testMonitorLocalDeadProcess transport True False)
356+ , ("MonitorRemoteDeadProcess", testMonitorRemoteDeadProcess transport True False)
357+ , ("MonitorDisconnect", testMonitorDisconnect transport True False)
358+ , ("LinkUnreachable", testMonitorUnreachable transport False False)
359+ , ("LinkNormalTermination", testMonitorNormalTermination transport False False)
360+ , ("LinkAbnormalTermination", testMonitorAbnormalTermination transport False False)
361+ , ("LinkLocalDeadProcess", testMonitorLocalDeadProcess transport False False)
362+ , ("LinkRemoteDeadProcess", testMonitorRemoteDeadProcess transport False False)
363+ , ("LinkDisconnect", testMonitorDisconnect transport False False)
364+ , ("UnmonitorNormalTermination", testMonitorNormalTermination transport True True)
365+ , ("UnmonitorAbnormalTermination", testMonitorAbnormalTermination transport True True)
366+ , ("UnmonitorDisconnect", testMonitorDisconnect transport True True)
367+ , ("UnlinkNormalTermination", testMonitorNormalTermination transport False True)
368+ , ("UnlinkAbnormalTermination", testMonitorAbnormalTermination transport False True)
369+ , ("UnlinkDisconnect", testMonitorDisconnect transport False True)
368370 {-
369371 , ("Monitor2", testMonitor2 transport)
370372 , ("Monitor3", testMonitor3 transport)