5336c01 · distributed-process

git.iko.soy/distributed-process

on master help sign in

Merge pull request #166 from tweag/informative-register-exc

5336c01Facundo Domínguez11 years ago

src/Control/Distributed/Process/Internal/Primitives.hs+11−9

compare with master

unifiedsplit

@@ -1070,9 +1070,10 @@ registerImpl :: Bool -> String -> ProcessId -> Process ()

1070registerImpl force label pid = do

1071 mynid <- getSelfNode

1072 sendCtrlMsg Nothing (Register label mynid (Just pid) force)

1073+ receiveWait

1073− receiveWait [ matchIf (\(RegisterReply label' _) -> label == label')

1074+ [ matchIf (\(RegisterReply label' _ _) -> label == label')

1074− (\(RegisterReply _ ok) -> handleRegistrationReply label ok)

1075+ (\(RegisterReply _ ok owner) -> handleRegistrationReply label ok owner)

1075− ]

1076+ ]

1076

1077

1077-- | Register a process with a remote registry (asynchronous).

1078-- | Register a process with a remote registry (asynchronous).

1078--

1079--

@@ -1095,16 +1096,17 @@ unregister :: String -> Process ()

1095unregister label = do

1096unregister label = do

1096 mynid <- getSelfNode

1097 mynid <- getSelfNode

1097 sendCtrlMsg Nothing (Register label mynid Nothing False)

1098 sendCtrlMsg Nothing (Register label mynid Nothing False)

1099+ receiveWait

1098− receiveWait [ matchIf (\(RegisterReply label' _) -> label == label')

1100+ [ matchIf (\(RegisterReply label' _ _) -> label == label')

1099− (\(RegisterReply _ ok) -> handleRegistrationReply label ok)

1101+ (\(RegisterReply _ ok owner) -> handleRegistrationReply label ok owner)

1100− ]

1102+ ]

1101

1103

1102-- | Deal with the result from an attempted registration or unregistration

1104-- | Deal with the result from an attempted registration or unregistration

1103-- by throwing an exception if necessary

1105-- by throwing an exception if necessary

1104−handleRegistrationReply :: String -> Bool -> Process ()

1106+handleRegistrationReply :: String -> Bool -> Maybe ProcessId -> Process ()

1105−handleRegistrationReply label ok =

1107+handleRegistrationReply label ok owner =

1106 when (not ok) $

1108 when (not ok) $

1107− liftIO $ throwIO $ ProcessRegistrationException label

1109+ liftIO $ throwIO $ ProcessRegistrationException label owner

1108

1110

1109-- | Remove a process from a remote registry (asynchronous).

1111-- | Remove a process from a remote registry (asynchronous).

1110--

1112--

src/Control/Distributed/Process/Internal/Types.hs+7−5

@@ -512,9 +512,11 @@ data PortLinkException =

512

513-- | Exception thrown when a process attempts to register

514-- 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.

516data ProcessRegistrationException =

518data ProcessRegistrationException =

517− ProcessRegistrationException !String

519+ ProcessRegistrationException !String !(Maybe ProcessId)

518 deriving (Typeable, Show)

520 deriving (Typeable, Show)

519

521

520-- | Internal exception thrown indirectly by 'exit'

522-- | Internal exception thrown indirectly by 'exit'

@@ -579,7 +581,7 @@ data WhereIsReply = WhereIsReply String (Maybe ProcessId)

579 deriving (Show, Typeable)

581 deriving (Show, Typeable)

580

582

581-- | (Asynchronous) reply from 'register' and 'unregister'

583-- | (Asynchronous) reply from 'register' and 'unregister'

582−data RegisterReply = RegisterReply String Bool

584+data RegisterReply = RegisterReply String Bool (Maybe ProcessId)

583 deriving (Show, Typeable)

585 deriving (Show, Typeable)

584

586

585data NodeStats = NodeStats {

587data NodeStats = NodeStats {

@@ -748,8 +750,8 @@ instance Binary WhereIsReply where

748 get = WhereIsReply <$> get <*> get

750 get = WhereIsReply <$> get <*> get

749

751

750instance Binary RegisterReply where

752instance Binary RegisterReply where

751− put (RegisterReply label ok) = put label >> put ok

753+ put (RegisterReply label ok owner) = put label >> put ok >> put owner

752− get = RegisterReply <$> get <*> get

754+ get = RegisterReply <$> get <*> get <*> get

753

755

754instance Binary ProcessInfo where

756instance Binary ProcessInfo where

755 get = ProcessInfo <$> get <*> get <*> get <*> get <*> get

757 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

866 return $ (isNothing currentVal /= reregistration) &&

867 (not (isLocal node (ProcessIdentifier thepid) ) || isvalidlocal )

868 if isLocal node (NodeIdentifier atnode)

869− then do when (isOk) $

869+ then do when isOk $

870 do modify' $ registeredHereFor label ^= mPid

871 updateRemote node currentVal mPid

872 case mPid of

873 (Just p) -> liftIO $ trace node (MxRegistered p label)

874 Nothing -> liftIO $ trace node (MxUnRegistered (fromJust currentVal) label)

875+ newVal <- gets (^. registeredHereFor label)

875 liftIO $ sendMessage node

876 liftIO $ sendMessage node

876 (NodeIdentifier (localNodeId node))

877 (NodeIdentifier (localNodeId node))

877 (ProcessIdentifier from)

878 (ProcessIdentifier from)

878 WithImplicitReconnect

879 WithImplicitReconnect

879− (RegisterReply label isOk)

880+ (RegisterReply label isOk newVal)

880 else let operation =

881 else let operation =

881 case reregistration of

882 case reregistration of

882 True -> flip decList

883 True -> flip decList