git.iko.soy/distributed-process
on master help sign in
Merge pull request #166 from tweag/informative-register-exc

More informative ProcessRegistrationException.

commit5336c01e0fea828d4aa19591d70e7d3ddd44834b authorFacundo Domínguez <facundominguez@gmail.com> dateSun 12 Jul 2015, 09:56 (11 years ago) parent14227fd3b1335e
3 files changed+21−16
compare with master
unifiedsplit
src/Control/Distributed/Process/Internal/Primitives.hs+11−9 src/Control/Distributed/Process/Internal/Types.hs+7−5 src/Control/Distributed/Process/Node.hs+3−2
src/Control/Distributed/Process/Internal/Primitives.hs+11−9
@@ -1070,9 +1070,10 @@ registerImpl :: Bool -> String -> ProcessId -> Process ()
10701070registerImpl force label pid = do
10711071 mynid <- getSelfNode
10721072 sendCtrlMsg Nothing (Register label mynid (Just pid) force)
1073− receiveWait [ matchIf (\(RegisterReply label' _) -> label == label')
1074− (\(RegisterReply _ ok) -> handleRegistrationReply label ok)
1075− ]
1073+ receiveWait
1074+ [ matchIf (\(RegisterReply label' _ _) -> label == label')
1075+ (\(RegisterReply _ ok owner) -> handleRegistrationReply label ok owner)
1076+ ]
10761077
10771078-- | Register a process with a remote registry (asynchronous).
10781079--
@@ -1095,16 +1096,17 @@ unregister :: String -> Process ()
10951096unregister label = do
10961097 mynid <- getSelfNode
10971098 sendCtrlMsg Nothing (Register label mynid Nothing False)
1098− receiveWait [ matchIf (\(RegisterReply label' _) -> label == label')
1099− (\(RegisterReply _ ok) -> handleRegistrationReply label ok)
1100− ]
1099+ receiveWait
1100+ [ matchIf (\(RegisterReply label' _ _) -> label == label')
1101+ (\(RegisterReply _ ok owner) -> handleRegistrationReply label ok owner)
1102+ ]
11011103
11021104-- | Deal with the result from an attempted registration or unregistration
11031105-- by throwing an exception if necessary
1104−handleRegistrationReply :: String -> Bool -> Process ()
1105−handleRegistrationReply label ok =
1106+handleRegistrationReply :: String -> Bool -> Maybe ProcessId -> Process ()
1107+handleRegistrationReply label ok owner =
11061108 when (not ok) $
1107− liftIO $ throwIO $ ProcessRegistrationException label
1109+ liftIO $ throwIO $ ProcessRegistrationException label owner
11081110
11091111-- | Remove a process from a remote registry (asynchronous).
11101112--
src/Control/Distributed/Process/Internal/Types.hs+7−5
@@ -512,9 +512,11 @@ data PortLinkException =
512512
513513-- | Exception thrown when a process attempts to register
514514-- a process under an already-registered name or to
515−-- unregister a name that hasn't been registered
515+-- unregister a name that hasn't been registered. Returns
516+-- the name and the identifier of the process that owns it,
517+-- if any.
516518data ProcessRegistrationException =
517− ProcessRegistrationException !String
519+ ProcessRegistrationException !String !(Maybe ProcessId)
518520 deriving (Typeable, Show)
519521
520522-- | Internal exception thrown indirectly by 'exit'
@@ -579,7 +581,7 @@ data WhereIsReply = WhereIsReply String (Maybe ProcessId)
579581 deriving (Show, Typeable)
580582
581583-- | (Asynchronous) reply from 'register' and 'unregister'
582−data RegisterReply = RegisterReply String Bool
584+data RegisterReply = RegisterReply String Bool (Maybe ProcessId)
583585 deriving (Show, Typeable)
584586
585587data NodeStats = NodeStats {
@@ -748,8 +750,8 @@ instance Binary WhereIsReply where
748750 get = WhereIsReply <$> get <*> get
749751
750752instance Binary RegisterReply where
751− put (RegisterReply label ok) = put label >> put ok
752− get = RegisterReply <$> get <*> get
753+ put (RegisterReply label ok owner) = put label >> put ok >> put owner
754+ get = RegisterReply <$> get <*> get <*> get
753755
754756instance Binary ProcessInfo where
755757 get = ProcessInfo <$> get <*> get <*> get <*> get <*> get
src/Control/Distributed/Process/Node.hs+3−2
@@ -866,17 +866,18 @@ ncEffectRegister from label atnode mPid reregistration = do
866866 return $ (isNothing currentVal /= reregistration) &&
867867 (not (isLocal node (ProcessIdentifier thepid) ) || isvalidlocal )
868868 if isLocal node (NodeIdentifier atnode)
869− then do when (isOk) $
869+ then do when isOk $
870870 do modify' $ registeredHereFor label ^= mPid
871871 updateRemote node currentVal mPid
872872 case mPid of
873873 (Just p) -> liftIO $ trace node (MxRegistered p label)
874874 Nothing -> liftIO $ trace node (MxUnRegistered (fromJust currentVal) label)
875+ newVal <- gets (^. registeredHereFor label)
875876 liftIO $ sendMessage node
876877 (NodeIdentifier (localNodeId node))
877878 (ProcessIdentifier from)
878879 WithImplicitReconnect
879− (RegisterReply label isOk)
880+ (RegisterReply label isOk newVal)
880881 else let operation =
881882 case reregistration of
882883 True -> flip decList