git.iko.soy/distributed-process
on master help sign in
Monitor remote dead process
commit34b1d5aac174b33e887c4252a1461c20609b01d5 authorEdsko de Vries <edsko@edsko.net> dateWed 13 Jun 2012, 15:24 (14 years ago) parentcb444b2
2 files changed+40−9
compare with master
unifiedsplit
distributed-process/src/Control/Distributed/Process.hs+14−9 distributed-process/tests/TestCH.hs+26
distributed-process/src/Control/Distributed/Process.hs+14−9
@@ -339,10 +339,8 @@ nodeController = forever $ do
339339
340340 -- Forward the message if appropriate
341341 case destNid (ctrlMsgSignal msg) of
342− Just nid' | nid' /= localNodeId node ->
343− ctrlSendTo (Right nid') . BSL.toChunks . encode $ msg
344− _ ->
345− return ()
342+ Just nid' | nid' /= localNodeId node -> ncSendCtrlMsg nid' msg
343+ _ -> return ()
346344
347345 processCtrlMsg msg
348346
@@ -365,6 +363,9 @@ ctrlSendTo them payload = do
365363 , ctrlMsgSignal = Died them DiedDisconnect
366364 }
367365
366+ncSendCtrlMsg :: NodeId -> NodeCtrlMsg -> NodeCtrl ()
367+ncSendCtrlMsg dest = ctrlSendTo (Right dest) . BSL.toChunks . encode
368+
368369ctrlSendLocal :: LocalProcessId -> Message -> NodeCtrl ()
369370ctrlSendLocal lpid msg = do
370371 node <- ask
@@ -425,6 +426,11 @@ processCtrlMsg (NodeCtrlMsg (Left from) (Monitor them ref)) = do
425426 (False, True) -> -- [Unified: second rule]
426427 ctrlSendLocal (processLocalId from) . createMessage $
427428 ProcessDied ref them DiedNoProc
429+ (False, False) -> -- [Unified: third rule]
430+ ncSendCtrlMsg (processNodeId from) $ NodeCtrlMsg
431+ { ctrlMsgSender = Right (localNodeId node)
432+ , ctrlMsgSignal = Died (Left them) DiedNoProc
433+ }
428434
429435processCtrlMsg (NodeCtrlMsg (Right _) (Monitor _ _)) =
430436 error "Monitor message from a node?"
@@ -466,11 +472,10 @@ processCtrlMsg (NodeCtrlMsg _from (Died (Left pid) reason)) = do
466472 then
467473 ctrlSendLocal (processLocalId us) msg
468474 else
469− ctrlSendTo (Right . processNodeId $ us) . BSL.toChunks . encode $
470− NodeCtrlMsg
471− { ctrlMsgSender = Right (localNodeId node) -- TODO: why the change in sender? How does that affect 'reconnect' semantics?
472− , ctrlMsgSignal = Died (Left pid) reason
473− }
475+ ncSendCtrlMsg (processNodeId us) $ NodeCtrlMsg
476+ { ctrlMsgSender = Right (localNodeId node) -- TODO: why the change in sender? How does that affect 'reconnect' semantics?
477+ , ctrlMsgSignal = Died (Left pid) reason
478+ }
474479
475480 modify $ (nodeCtrlLinksForProcess pid ^= Set.empty)
476481 . (nodeCtrlMonsForProcess pid ^= Map.empty)
distributed-process/tests/TestCH.hs+26
@@ -175,6 +175,31 @@ testMonitorLocalDeadProcess transport = do
175175
176176 takeMVar done
177177
178+-- | Monitor a remote process that is already dead
179+testMonitorRemoteDeadProcess :: NT.Transport -> IO ()
180+testMonitorRemoteDeadProcess transport = do
181+ processDead <- newEmptyMVar
182+ processAddr <- newEmptyMVar
183+ done <- newEmptyMVar
184+
185+ forkIO $ do
186+ localNode <- newLocalNode transport
187+ addr <- forkProcess localNode . liftIO $ putMVar processDead ()
188+ putMVar processAddr addr
189+
190+ forkIO $ do
191+ localNode <- newLocalNode transport
192+ theirAddr <- readMVar processAddr
193+ readMVar processDead
194+ runProcess localNode $ do
195+ ref <- monitor theirAddr
196+ ProcessDied ref' pid DiedNoProc <- expect
197+ True <- return $ ref' == ref && pid == theirAddr
198+ return ()
199+ putMVar done ()
200+
201+ takeMVar done
202+
178203{-
179204-- Like 'testMonitor1', but throw an exception instead
180205testMonitor2 :: NT.Transport -> IO ()
@@ -286,6 +311,7 @@ main = do
286311 , ("MonitorNormalTermination", testMonitorNormalTermination transport)
287312 , ("MonitorAbnormalTermination", testMonitorAbnormalTermination transport)
288313 , ("MonitorLocalDeadProcess", testMonitorLocalDeadProcess transport)
314+ , ("MonitorRemoteDeadProcess", testMonitorRemoteDeadProcess transport)
289315 {-
290316 , ("Monitor2", testMonitor2 transport)
291317 , ("Monitor3", testMonitor3 transport)