@@ -297,6 +297,8 @@ data DiedReason =
297297 | DiedException String -- TODO: would prefer SomeException instead of String, but exceptions don't implement Binary
298298 | DiedDisconnect
299299 | DiedNodeDown
300+ | DiedNoProc
301+ deriving Show
300302
301303type Identifier = Either ProcessId NodeId
302304
@@ -363,6 +365,13 @@ ctrlSendTo them payload = do
363365 , ctrlMsgSignal = Died them DiedDisconnect
364366 }
365367
368+ctrlSendLocal :: LocalProcessId -> Message -> NodeCtrl ()
369+ctrlSendLocal lpid msg = do
370+ node <- ask
371+ liftIO $ do
372+ mProc <- withMVar (localState node) $ return . (^. localProcessWithId lpid)
373+ forM_ mProc $ \proc -> enqueue (processQueue proc) msg
374+
366375ctrlConnTo :: Identifier -> NodeCtrl (Maybe NT.Connection)
367376ctrlConnTo them = do
368377 mConn <- gets (^. nodeCtrlConnFor them)
@@ -402,18 +411,23 @@ createCtrlConnTo them = do
402411processCtrlMsg :: NodeCtrlMsg -> NodeCtrl ()
403412
404413-- [Unified: Table 10]
405−processCtrlMsg (NodeCtrlMsg from (Monitor them ref)) = do
414+processCtrlMsg (NodeCtrlMsg (Left from) (Monitor them ref)) = do
406415 node <- ask
407416 shouldLink <-
408417 if processNodeId them /= localNodeId node
409418 then return True
410419 else liftIO . withMVar (localState node) $
411420 return . isJust . (^. localProcessWithId (processLocalId them))
412− if shouldLink
413− then
414− modify $ nodeCtrlMonsFor them (fromLeft from) ^: Set.insert ref
415− else
416− fail "processCtrlMsg: TODO"
421+ let localFrom = processNodeId from == localNodeId node
422+ case (shouldLink, localFrom) of
423+ (True, _) -> -- [Unified: first rule]
424+ modify $ nodeCtrlMonsFor them from ^: Set.insert ref
425+ (False, True) -> -- [Unified: second rule]
426+ ctrlSendLocal (processLocalId from) . createMessage $
427+ ProcessDied ref them DiedNoProc
428+
429+processCtrlMsg (NodeCtrlMsg (Right _) (Monitor _ _)) =
430+ error "Monitor message from a node?"
417431
418432-- [Unified: Table 12, bottom rule]
419433processCtrlMsg (NodeCtrlMsg _from (Died (Right nid) reason)) = do
@@ -427,15 +441,11 @@ processCtrlMsg (NodeCtrlMsg _from (Died (Right nid) reason)) = do
427441 forM_ (Map.toList mons) $ \(them, uss) -> do
428442 forM_ (Map.toList uss) $ \(us, refs) -> do
429443 -- We only need to notify local processes
430− when (processNodeId us == localNodeId node) . liftIO $ do
444+ when (processNodeId us == localNodeId node) $ do
431445 let lpid = processLocalId us
432446 rpid = ProcessId nid them
433447 forM_ refs $ \ref -> do
434− mProc <- withMVar (localState node) $
435− return . (^. localProcessWithId lpid)
436− forM_ mProc $ \proc ->
437− enqueue (processQueue proc) . createMessage $
438− ProcessDied ref rpid reason
448+ ctrlSendLocal lpid . createMessage $ ProcessDied ref rpid reason
439449
440450 modify $ (nodeCtrlLinksForNode nid ^= Map.empty)
441451 . (nodeCtrlMonsForNode nid ^= Map.empty)
@@ -453,19 +463,15 @@ processCtrlMsg (NodeCtrlMsg _from (Died (Left pid) reason)) = do
453463 forM_ refs $ \ref -> do
454464 let msg = createMessage $ ProcessDied ref pid reason
455465 if processNodeId us == localNodeId node
456− then liftIO $ do
457− let lpid = processLocalId us
458− mProc <- withMVar (localState node) $
459− return . (^. localProcessWithId lpid)
460− forM_ mProc $ \proc ->
461− enqueue (processQueue proc) msg
462− else do
466+ then
467+ ctrlSendLocal (processLocalId us) msg
468+ else
463469 ctrlSendTo (Right . processNodeId $ us) . BSL.toChunks . encode $
464470 NodeCtrlMsg
465471 { ctrlMsgSender = Right (localNodeId node) -- TODO: why the change in sender? How does that affect 'reconnect' semantics?
466472 , ctrlMsgSignal = Died (Left pid) reason
467473 }
468−
474+
469475 modify $ (nodeCtrlLinksForProcess pid ^= Set.empty)
470476 . (nodeCtrlMonsForProcess pid ^= Map.empty)
471477
@@ -528,24 +534,17 @@ forkProcess node proc = do
528534 , lproc
529535 )
530536 void . forkIO $ do
531− catch (do
532− runLocalProcess lproc proc
533− -- [Unified: Table 4]
534− let pid = processId lproc
535− writeChan (localCtrlChan node) $ NodeCtrlMsg
536− { ctrlMsgSender = Left pid
537− , ctrlMsgSignal = Died (Left pid) DiedNormal
538− }
539− )
540− (\ex -> do
541− let pid = processId lproc
542− err = show (ex :: SomeException)
543− writeChan (localCtrlChan node) $ NodeCtrlMsg
544− { ctrlMsgSender = Left pid
545− , ctrlMsgSignal = Died (Left pid) (DiedException err)
546− }
547− )
548−
537+ let pid = processId lproc
538+ lpid = processLocalId pid
539+ reason <- catch (runLocalProcess lproc proc >> return DiedNormal)
540+ (return . DiedException . (show :: SomeException -> String))
541+ -- [Unified: Table 4, rules termination and exiting]
542+ modifyMVar_ (localState node) $
543+ return . (localProcessWithId lpid ^= Nothing)
544+ writeChan (localCtrlChan node) $ NodeCtrlMsg
545+ { ctrlMsgSender = Left pid
546+ , ctrlMsgSignal = Died (Left pid) reason
547+ }
549548 return (processId lproc)
550549
551550handleIncomingMessages :: LocalNode -> IO ()
@@ -768,6 +767,7 @@ instance Binary DiedReason where
768767 put (DiedException e) = putWord8 1 >> put e
769768 put DiedDisconnect = putWord8 2
770769 put DiedNodeDown = putWord8 3
770+ put DiedNoProc = putWord8 4
771771 get = do
772772 header <- getWord8
773773 case header of
@@ -775,6 +775,7 @@ instance Binary DiedReason where
775775 1 -> DiedException <$> get
776776 2 -> return DiedDisconnect
777777 3 -> return DiedNodeDown
778+ 4 -> return DiedNoProc
778779 _ -> fail "DiedReason.get: invalid"
779780
780781--------------------------------------------------------------------------------