Changed semantics of register/unregister to match Erlang

register will now throw an exception if the name is already registered
unregister will throw an exception if the name isn't registered
registerRemote and unregisterRemote have been replaced with Async versions, such that the user application is now responsible for checking the remote control process's response

Author: jepst

distributed-process/distributed-process.cabal

@@ -1,5 +1,5 @@
 Name:          distributed-process 
-Version:       0.4.0.2
+Version:       0.4.0.3
 Cabal-Version: >=1.8
 Build-Type:    Simple
 License:       BSD3 

distributed-process/src/Control/Distributed/Process.hs

@@ -80,8 +80,8 @@ module Control.Distributed.Process
   , unregister
   , whereis
   , nsend
-  , registerRemote
-  , unregisterRemote
+  , registerRemoteAsync
+  , unregisterRemoteAsync
   , whereisRemoteAsync
   , nsendRemote
   , WhereIsReply(..)
@@ -200,8 +200,8 @@ import Control.Distributed.Process.Internal.Primitives
   , unregister
   , whereis
   , nsend
-  , registerRemote
-  , unregisterRemote
+  , registerRemoteAsync
+  , unregisterRemoteAsync
   , whereisRemoteAsync
   , nsendRemote
     -- Closures

distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs

@@ -38,8 +38,8 @@ module Control.Distributed.Process.Internal.Primitives
   , unregister
   , whereis
   , nsend
-  , registerRemote
-  , unregisterRemote
+  , registerRemoteAsync
+  , unregisterRemoteAsync
   , whereisRemoteAsync
   , nsendRemote
     -- * Closures
@@ -76,6 +76,7 @@ import Data.Time.Clock (getCurrentTime)
 import Data.Time.Format (formatTime)
 import System.Locale (defaultTimeLocale)
 import System.Timeout (timeout)
+import Control.Monad (when)
 import Control.Monad.Reader (ask)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Control.Applicative ((<$>))
@@ -127,6 +128,8 @@ import Control.Distributed.Process.Internal.Types
   , DidUnlinkNode(..)
   , DidUnlinkPort(..)
   , WhereIsReply(..)
+  , RegisterReply(..)
+  , ProcessRegistrationException(..)
   , createMessage
   , runLocalProcess
   , ImplicitReconnect(WithImplicitReconnect, NoImplicitReconnect)
@@ -542,24 +545,44 @@ say string = do
 --
 -- The process to be registered does not have to be local itself.
 register :: String -> ProcessId -> Process ()
-register label pid = 
+register label pid = do
   sendCtrlMsg Nothing (Register label (Just pid))
+  receiveWait [ matchIf (\(RegisterReply label' _) -> label == label')
+                        (\(RegisterReply _ ok) -> handleRegistrationReply label ok)
+              ]
 
 -- | Register a process with a remote registry (asynchronous).
 --
 -- The process to be registered does not have to live on the same remote node.
-registerRemote :: NodeId -> String -> ProcessId -> Process ()
-registerRemote nid label pid = 
+-- Reply wil come in the form of a 'RegisterReply' message
+--
+-- See comments in 'whereisRemoteAsync'
+registerRemoteAsync :: NodeId -> String -> ProcessId -> Process ()
+registerRemoteAsync nid label pid = 
   sendCtrlMsg (Just nid) (Register label (Just pid)) 
 
 -- | Remove a process from the local registry (asynchronous).
 unregister :: String -> Process ()
-unregister label = 
+unregister label = do
   sendCtrlMsg Nothing (Register label Nothing)
+  receiveWait [ matchIf (\(RegisterReply label' _) -> label == label')
+                        (\(RegisterReply _ ok) -> handleRegistrationReply label ok)
+              ]
+
+-- | Deal with the result from an attempted registration or unregistration
+-- by throwing an exception if necessary
+handleRegistrationReply :: String -> Bool -> Process ()
+handleRegistrationReply label ok = 
+  when (not ok) $
+     liftIO $ throwIO $ ProcessRegistrationException label
 
 -- | Remove a process from a remote registry (asynchronous).
-unregisterRemote :: NodeId -> String -> Process ()
-unregisterRemote nid label =
+-- 
+-- Reply wil come in the form of a 'RegisterReply' message
+--
+-- See comments in 'whereisRemoteAsync'
+unregisterRemoteAsync :: NodeId -> String -> Process ()
+unregisterRemoteAsync nid label =
   sendCtrlMsg (Just nid) (Register label Nothing)
 
 -- | Query the local process registry

distributed-process/src/Control/Distributed/Process/Internal/Types.hs

@@ -39,6 +39,7 @@ module Control.Distributed.Process.Internal.Types
   , ProcessLinkException(..)
   , NodeLinkException(..)
   , PortLinkException(..)
+  , ProcessRegistrationException(..)
   , DiedReason(..)
   , DidUnmonitor(..)
   , DidUnlinkProcess(..)
@@ -47,6 +48,7 @@ module Control.Distributed.Process.Internal.Types
   , SpawnRef(..)
   , DidSpawn(..)
   , WhereIsReply(..)
+  , RegisterReply(..)
     -- * Node controller internal data types 
   , NCMsg(..)
   , ProcessSignal(..)
@@ -359,9 +361,17 @@ data PortLinkException =
     PortLinkException !SendPortId !DiedReason
   deriving (Typeable, Show)
 
+-- | Exception thrown when a process attempts to register
+-- a process under an already-registered name or to
+-- unregister a name that hasn't been registered
+data ProcessRegistrationException = 
+    ProcessRegistrationException !String
+  deriving (Typeable, Show)
+
 instance Exception ProcessLinkException
 instance Exception NodeLinkException
 instance Exception PortLinkException
+instance Exception ProcessRegistrationException
 
 -- | Why did a process die?
 data DiedReason = 
@@ -406,6 +416,10 @@ data DidSpawn = DidSpawn SpawnRef ProcessId
 data WhereIsReply = WhereIsReply String (Maybe ProcessId)
   deriving (Show, Typeable)
 
+-- | (Asynchronous) reply from 'register' and 'unregister'
+data RegisterReply = RegisterReply String Bool
+  deriving (Show, Typeable)
+
 --------------------------------------------------------------------------------
 -- Node controller internal data types                                        --
 --------------------------------------------------------------------------------
@@ -526,6 +540,10 @@ instance Binary WhereIsReply where
   put (WhereIsReply label mPid) = put label >> put mPid
   get = WhereIsReply <$> get <*> get
 
+instance Binary RegisterReply where
+  put (RegisterReply label ok) = put label >> put ok 
+  get = RegisterReply <$> get <*> get
+
 --------------------------------------------------------------------------------
 -- Accessors                                                                  --
 --------------------------------------------------------------------------------

distributed-process/src/Control/Distributed/Process/Node.hs

@@ -31,7 +31,7 @@ import qualified Data.Map as Map
 import Data.Set (Set)
 import qualified Data.Set as Set (empty, insert, delete, member)
 import Data.Foldable (forM_)
-import Data.Maybe (isJust)
+import Data.Maybe (isJust, isNothing)
 import Data.Typeable (Typeable)
 import Control.Category ((>>>))
 import Control.Applicative ((<$>))
@@ -118,6 +118,7 @@ import Control.Distributed.Process.Internal.Types
   , nodeOf
   , SendPortId(..)
   , typedChannelWithId
+  , RegisterReply(..)
   , WhereIsReply(..)
   , messageToPayload
   , payloadToMessage
@@ -485,8 +486,8 @@ nodeController = do
         ncEffectDied ident reason
       NCMsg (ProcessIdentifier from) (Spawn proc ref) ->
         ncEffectSpawn from proc ref
-      NCMsg _from (Register label pid) ->
-        ncEffectRegister label pid
+      NCMsg (ProcessIdentifier from) (Register label pid) ->
+        ncEffectRegister from label pid
       NCMsg (ProcessIdentifier from) (WhereIs label) ->
         ncEffectWhereIs from label
       NCMsg from (NamedSend label msg') ->
@@ -587,12 +588,24 @@ ncEffectSpawn pid cProc ref = do
 
 -- Unified semantics does not explicitly describe how to implement 'register',
 -- but mentions it's "very similar to nsend" (Table 14)
-ncEffectRegister :: String -> Maybe ProcessId -> NC ()
-ncEffectRegister label mPid = 
-  modify' $ registryFor label ^= mPid
-  -- An acknowledgement is not necessary. If we want a synchronous register,
-  -- it suffices to send a whereis requiry immediately after the register
-  -- (that may not suffice if we do decide for unreliable messaging instead)
+-- We send a response indicated if the operation is invalid
+ncEffectRegister :: ProcessId -> String -> Maybe ProcessId -> NC ()
+ncEffectRegister from label mPid = do
+  node <- ask
+  currentVal <- gets (^. registryFor label)
+  let isOk = 
+       case mPid of
+         Nothing -> -- unregister request
+           isJust currentVal
+         Just _ -> -- register request
+           isNothing currentVal
+  when (isOk) $
+     modify' $ registryFor label ^= mPid
+  liftIO $ sendMessage node
+                       (NodeIdentifier (localNodeId node))
+                       (ProcessIdentifier from) 
+                       WithImplicitReconnect
+                       (RegisterReply label isOk)
 
 -- Unified semantics does not explicitly describe 'whereis'
 ncEffectWhereIs :: ProcessId -> String -> NC ()