3b1335e · distributed-process

git.iko.soy/distributed-process

on master help sign in

More informative ProcessRegistrationException.

3b1335eMathieu Boespflug12 years ago

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

compare with master

unifiedsplit

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

1044registerImpl force label pid = do

1045 mynid <- getSelfNode

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

1047+ receiveWait

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

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

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

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

1049− ]

1050+ ]

1050

1051

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

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

1052--

1053--

@@ -1069,16 +1070,17 @@ unregister :: String -> Process ()

1069unregister label = do

1070unregister label = do

1070 mynid <- getSelfNode

1071 mynid <- getSelfNode

1071 sendCtrlMsg Nothing (Register label mynid Nothing False)

1072 sendCtrlMsg Nothing (Register label mynid Nothing False)

1073+ receiveWait

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

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

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

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

1074− ]

1076+ ]

1075

1077

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

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

1077-- by throwing an exception if necessary

1079-- by throwing an exception if necessary

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

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

1079−handleRegistrationReply label ok =

1081+handleRegistrationReply label ok owner =

1080 when (not ok) $

1082 when (not ok) $

1081− liftIO $ throwIO $ ProcessRegistrationException label

1083+ liftIO $ throwIO $ ProcessRegistrationException label owner

1082

1084

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

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

1084--

1086--

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

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

461

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

463-- a process under an already-registered name or to

464−-- unregister a name that hasn't been registered

464+-- unregister a name that hasn't been registered. Returns

465+-- the name and the identifier of the process that owns it,

466+-- if any.

465data ProcessRegistrationException =

467data ProcessRegistrationException =

466− ProcessRegistrationException !String

468+ ProcessRegistrationException !String !(Maybe ProcessId)

467 deriving (Typeable, Show)

469 deriving (Typeable, Show)

468

470

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

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

@@ -524,7 +526,7 @@ data WhereIsReply = WhereIsReply String (Maybe ProcessId)

524 deriving (Show, Typeable)

526 deriving (Show, Typeable)

525

527

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

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

527−data RegisterReply = RegisterReply String Bool

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

528 deriving (Show, Typeable)

530 deriving (Show, Typeable)

529

531

530data NodeStats = NodeStats {

532data NodeStats = NodeStats {

@@ -693,8 +695,8 @@ instance Binary WhereIsReply where

693 get = WhereIsReply <$> get <*> get

695 get = WhereIsReply <$> get <*> get

694

696

695instance Binary RegisterReply where

697instance Binary RegisterReply where

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

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

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

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

698

700

699instance Binary ProcessInfo where

701instance Binary ProcessInfo where

700 get = ProcessInfo <$> get <*> get <*> get <*> get <*> get

702 get = ProcessInfo <$> get <*> get <*> get <*> get <*> get

@@ -761,4 +763,3 @@ typedChannelWithId cid = typedChannels >>> DAC.mapMaybe cid

761{-# INLINE forever' #-}

763{-# INLINE forever' #-}

762forever' :: Monad m => m a -> m b

764forever' :: Monad m => m a -> m b

763forever' a = let a' = a >> a' in a'

765forever' a = let a' = a >> a' in a'

764−

src/Control/Distributed/Process/Node.hs+3−2

@@ -841,17 +841,18 @@ ncEffectRegister from label atnode mPid reregistration = do

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

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

843 if isLocal node (NodeIdentifier atnode)

844− then do when (isOk) $

844+ then do when isOk $

845 do modify' $ registeredHereFor label ^= mPid

846 updateRemote node currentVal mPid

847 case mPid of

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

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

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

850 liftIO $ sendMessage node

851 liftIO $ sendMessage node

851 (NodeIdentifier (localNodeId node))

852 (NodeIdentifier (localNodeId node))

852 (ProcessIdentifier from)

853 (ProcessIdentifier from)

853 WithImplicitReconnect

854 WithImplicitReconnect

854− (RegisterReply label isOk)

855+ (RegisterReply label isOk newVal)

855 else let operation =

856 else let operation =

856 case reregistration of

857 case reregistration of

857 True -> flip decList

858 True -> flip decList