git.iko.soy/distributed-process
on master help sign in
Fixed bug for setting names at remote nodes

Fixed TestCH to deal accept fact that names are erased when nodes are disconnected

commit53d631258a74ca955233c1943d02eb966fb0341f authorJeff Epstein <jepst79@gmail.com> dateMon 19 Nov 2012, 05:08 (14 years ago) parent24163c2
4 files changed+42−23
compare with master
unifiedsplit
distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs+7−5 distributed-process/src/Control/Distributed/Process/Internal/Types.hs+3−3 distributed-process/src/Control/Distributed/Process/Node.hs+9−9 distributed-process/tests/TestCH.hs+23−6
distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs+7−5
@@ -560,7 +560,8 @@ reregister = registerImpl True
560560
561561registerImpl :: Bool -> String -> ProcessId -> Process ()
562562registerImpl force label pid = do
563− sendCtrlMsg Nothing (Register label (Just pid) force)
563+ mynid <- getSelfNode
564+ sendCtrlMsg Nothing (Register label mynid (Just pid) force)
564565 receiveWait [ matchIf (\(RegisterReply label' _) -> label == label')
565566 (\(RegisterReply _ ok) -> handleRegistrationReply label ok)
566567 ]
@@ -573,18 +574,19 @@ registerImpl force label pid = do
573574-- See comments in 'whereisRemoteAsync'
574575registerRemoteAsync :: NodeId -> String -> ProcessId -> Process ()
575576registerRemoteAsync nid label pid =
576− sendCtrlMsg (Just nid) (Register label (Just pid) False)
577+ sendCtrlMsg (Just nid) (Register label nid (Just pid) False)
577578
578579reregisterRemoteAsync :: NodeId -> String -> ProcessId -> Process ()
579580reregisterRemoteAsync nid label pid =
580− sendCtrlMsg (Just nid) (Register label (Just pid) True)
581+ sendCtrlMsg (Just nid) (Register label nid (Just pid) True)
581582
582583-- | Remove a process from the local registry (asynchronous).
583584-- This version will wait until a response is gotten from the
584585-- management process. The name must already be registered.
585586unregister :: String -> Process ()
586587unregister label = do
587− sendCtrlMsg Nothing (Register label Nothing False)
588+ mynid <- getSelfNode
589+ sendCtrlMsg Nothing (Register label mynid Nothing False)
588590 receiveWait [ matchIf (\(RegisterReply label' _) -> label == label')
589591 (\(RegisterReply _ ok) -> handleRegistrationReply label ok)
590592 ]
@@ -603,7 +605,7 @@ handleRegistrationReply label ok =
603605-- See comments in 'whereisRemoteAsync'
604606unregisterRemoteAsync :: NodeId -> String -> Process ()
605607unregisterRemoteAsync nid label =
606− sendCtrlMsg (Just nid) (Register label Nothing False)
608+ sendCtrlMsg (Just nid) (Register label nid Nothing False)
607609
608610-- | Query the local process registry
609611whereis :: String -> Process (Maybe ProcessId)
distributed-process/src/Control/Distributed/Process/Internal/Types.hs+3−3
@@ -440,7 +440,7 @@ data ProcessSignal =
440440 | Died Identifier !DiedReason
441441 | Spawn !(Closure (Process ())) !SpawnRef
442442 | WhereIs !String
443− | Register !String !(Maybe ProcessId) !Bool -- Use 'Nothing' to unregister, use True to force reregister
443+ | Register !String !NodeId !(Maybe ProcessId) !Bool -- Use 'Nothing' to unregister, use True to force reregister
444444 | NamedSend !String !Message
445445 deriving Show
446446
@@ -484,7 +484,7 @@ instance Binary ProcessSignal where
484484 put (Died who reason) = putWord8 4 >> put who >> put reason
485485 put (Spawn proc ref) = putWord8 5 >> put proc >> put ref
486486 put (WhereIs label) = putWord8 6 >> put label
487− put (Register label pid force)= putWord8 7 >> put label >> put pid >> put force
487+ put (Register label nid pid force) = putWord8 7 >> put label >> put nid >> put pid >> put force
488488 put (NamedSend label msg) = putWord8 8 >> put label >> put (messageToPayload msg)
489489 get = do
490490 header <- getWord8
@@ -496,7 +496,7 @@ instance Binary ProcessSignal where
496496 4 -> Died <$> get <*> get
497497 5 -> Spawn <$> get <*> get
498498 6 -> WhereIs <$> get
499− 7 -> Register <$> get <*> get <*> get
499+ 7 -> Register <$> get <*> get <*> get <*> get
500500 8 -> NamedSend <$> get <*> (payloadToMessage <$> get)
501501 _ -> fail "ProcessSignal.get: invalid"
502502
distributed-process/src/Control/Distributed/Process/Node.hs+9−9
@@ -487,8 +487,8 @@ nodeController = do
487487 ncEffectDied ident reason
488488 NCMsg (ProcessIdentifier from) (Spawn proc ref) ->
489489 ncEffectSpawn from proc ref
490− NCMsg (ProcessIdentifier from) (Register label pid force) ->
491− ncEffectRegister from label pid force
490+ NCMsg (ProcessIdentifier from) (Register label atnode pid force) ->
491+ ncEffectRegister from label atnode pid force
492492 NCMsg (ProcessIdentifier from) (WhereIs label) ->
493493 ncEffectWhereIs from label
494494 NCMsg from (NamedSend label msg') ->
@@ -609,8 +609,8 @@ ncEffectSpawn pid cProc ref = do
609609-- Unified semantics does not explicitly describe how to implement 'register',
610610-- but mentions it's "very similar to nsend" (Table 14)
611611-- We send a response indicated if the operation is invalid
612−ncEffectRegister :: ProcessId -> String -> Maybe ProcessId -> Bool -> NC ()
613−ncEffectRegister from label mPid reregistration = do
612+ncEffectRegister :: ProcessId -> String -> NodeId -> Maybe ProcessId -> Bool -> NC ()
613+ncEffectRegister from label atnode mPid reregistration = do
614614 node <- ask
615615 currentVal <- gets (^. registryFor (label, localNodeId node))
616616 isOk <-
@@ -621,9 +621,9 @@ ncEffectRegister from label mPid reregistration = do
621621 do isvalidlocal <- isValidLocalIdentifier (ProcessIdentifier thepid)
622622 return $ (isNothing currentVal /= reregistration) &&
623623 (not (isLocal node (ProcessIdentifier thepid) ) || isvalidlocal )
624− if isLocal node (ProcessIdentifier from)
624+ if isLocal node (NodeIdentifier atnode)
625625 then when (isOk) $
626− do modify' $ registryFor (label, localNodeId node) ^= mPid
626+ do modify' $ registryFor (label, atnode) ^= mPid
627627 let namedPid =
628628 head $ catMaybes [mPid, currentVal]
629629 when (not $ isLocal node (ProcessIdentifier namedPid)) $
@@ -633,9 +633,9 @@ ncEffectRegister from label mPid reregistration = do
633633 WithImplicitReconnect
634634 NCMsg
635635 { ctrlMsgSender = ProcessIdentifier from
636− , ctrlMsgSignal = Register label mPid reregistration
636+ , ctrlMsgSignal = Register label atnode mPid reregistration
637637 }
638− else modify' $ registryFor (label,processNodeId from) ^= mPid
638+ else modify' $ registryFor (label,atnode) ^= mPid
639639 liftIO $ sendMessage node
640640 (NodeIdentifier (localNodeId node))
641641 (ProcessIdentifier from)
@@ -708,7 +708,7 @@ destNid (Unlink ident) = Just $ nodeOf ident
708708destNid (Monitor ref) = Just $ nodeOf (monitorRefIdent ref)
709709destNid (Unmonitor ref) = Just $ nodeOf (monitorRefIdent ref)
710710destNid (Spawn _ _) = Nothing
711−destNid (Register _ _ _)= Nothing
711+destNid (Register _ _ _ _) = Nothing
712712destNid (WhereIs _) = Nothing
713713destNid (NamedSend _ _) = Nothing
714714-- We don't need to forward 'Died' signals; if monitoring/linking is setup,
distributed-process/tests/TestCH.hs+23−6
@@ -31,6 +31,7 @@ import Control.Distributed.Process
3131import Control.Distributed.Process.Internal.Types
3232 ( NodeId(nodeAddress)
3333 , LocalNode(localEndPoint)
34+ , RegisterReply(..)
3435 )
3536import Control.Distributed.Process.Node
3637import Control.Distributed.Process.Serializable (Serializable)
@@ -594,7 +595,11 @@ testRemoteRegistry transport = do
594595
595596 runProcess node2 $ do
596597 let nid1 = localNodeId node1
597− registerRemote nid1 "ping" pingServer
598+ registerRemoteAsync nid1 "ping" pingServer
599+ receiveWait [
600+ matchIf (\(RegisterReply label' _) -> "ping" == label')
601+ (\(RegisterReply _ _) -> return ()) ]
602+
598603 Just pid <- whereisRemote nid1 "ping"
599604 True <- return $ pingServer == pid
600605 us <- getSelfPid
@@ -665,7 +670,13 @@ testReconnect transport transportInternals = do
665670 -}
666671
667672 us <- getSelfPid
668− registerRemote nid1 "a" us >> liftIO (threadDelay 100000) -- registerRemote is asynchronous
673+ registerRemoteAsync nid1 "a" us -- registerRemote is asynchronous
674+ receiveWait [
675+ matchIf (\(RegisterReply label' _) -> "a" == label')
676+ (\(RegisterReply _ _) -> return ()) ]
677+
678+ Just _ <- whereisRemote nid1 "a"
679+
669680
670681 -- Simulate network failure
671682 liftIO $ do
@@ -674,14 +685,20 @@ testReconnect transport transportInternals = do
674685 threadDelay 10000
675686
676687 -- This will happen due to implicit reconnect
677− registerRemote nid1 "b" us
688+ registerRemoteAsync nid1 "b" us
689+ receiveWait [
690+ matchIf (\(RegisterReply label' _) -> "b" == label')
691+ (\(RegisterReply _ _) -> return ()) ]
678692
679693 -- Should happen
680− registerRemote nid1 "c" us
694+ registerRemoteAsync nid1 "c" us
695+ receiveWait [
696+ matchIf (\(RegisterReply label' _) -> "c" == label')
697+ (\(RegisterReply _ _) -> return ()) ]
681698
682699 -- Check
683− Just _ <- whereisRemote nid1 "a"
684− Just _ <- whereisRemote nid1 "b"
700+ Nothing <- whereisRemote nid1 "a" -- this will fail because the name is removed when the node is disconnected
701+ Just _ <- whereisRemote nid1 "b" -- this will suceed because the value is set after thereconnect
685702 Just _ <- whereisRemote nid1 "c"
686703
687704 liftIO $ putMVar registerTestOk ()