e73c666 · distributed-process

git.iko.soy/distributed-process

on master help sign in

Implement process registry

e73c666Edsko de Vries14 years ago

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

compare with master

unifiedsplit

@@ -64,6 +64,15 @@ module Control.Distributed.Process

64 , Static

65 , unClosure

66 , RemoteTable

67+ -- * Registry

68+ , register

69+ , unregister

70+ , whereis

71+ , nsend

72+ , registerRemote

73+ , unregisterRemote

74+ , whereisRemote

75+ , nsendRemote

67 -- * Auxiliary API

76 -- * Auxiliary API

68 , catch

77 , catch

69 , expectTimeout

78 , expectTimeout

@@ -146,6 +155,15 @@ import Control.Distributed.Process.Internal.Primitives

146 , monitorNode

155 , monitorNode

147 , monitorPort

156 , monitorPort

148 , unmonitor

157 , unmonitor

158+ -- Registry

159+ , register

160+ , unregister

161+ , whereis

162+ , nsend

163+ , registerRemote

164+ , unregisterRemote

165+ , whereisRemote

166+ , nsendRemote

149 -- Auxiliary API

167 -- Auxiliary API

150 , catch

168 , catch

151 , expectTimeout

169 , expectTimeout

distributed-process/src/Control/Distributed/Process/Internal/MessageT.hs+6−30

@@ -14,8 +14,8 @@ module Control.Distributed.Process.Internal.MessageT

14 ) where

16import Data.Binary (Binary, encode)

17−import qualified Data.ByteString as BSS (ByteString, concat)

17+import qualified Data.ByteString as BSS (ByteString)

18−import qualified Data.ByteString.Lazy as BSL (toChunks, fromChunks, splitAt)

18+import qualified Data.ByteString.Lazy as BSL (toChunks)

19import Data.Map (Map)

20import qualified Data.Map as Map (empty)

21import Data.Accessor (Accessor, accessor, (^=), (^.))

@@ -33,17 +33,13 @@ import Control.Distributed.Process.Internal.Types

33 , NCMsg(NCMsg, ctrlMsgSender, ctrlMsgSignal)

34 , DiedReason(DiedDisconnect)

35 , ProcessSignal(Died)

36− , Message(..)

37 , MessageT(..)

36 , MessageT(..)

38 , MessageState(..)

37 , MessageState(..)

38+ , createMessage

39+ , messageToPayload

40+ , payloadToMessage

39 )

41 )

40−import Control.Distributed.Process.Serializable

42+import Control.Distributed.Process.Serializable (Serializable)

41− ( Serializable

42− , fingerprint

43− , encodeFingerprint

44− , decodeFingerprint

45− , sizeOfFingerprint

46− )

47import qualified Network.Transport as NT

43import qualified Network.Transport as NT

48 ( EndPoint

44 ( EndPoint

49 , Connection

45 , Connection

@@ -87,26 +83,6 @@ sendBinary them = sendPayload them . BSL.toChunks . encode

87sendMessage :: (MonadIO m, Serializable a) => Identifier -> a -> MessageT m ()

83sendMessage :: (MonadIO m, Serializable a) => Identifier -> a -> MessageT m ()

88sendMessage them = sendPayload them . messageToPayload . createMessage

84sendMessage them = sendPayload them . messageToPayload . createMessage

90−--------------------------------------------------------------------------------

91−-- Serialization/deserialization --

92−--------------------------------------------------------------------------------

93−

94−-- | Turn any serialiable term into a message

95−createMessage :: Serializable a => a -> Message

96−createMessage a = Message (fingerprint a) (encode a)

97−

98−-- | Serialize a message

99−messageToPayload :: Message -> [BSS.ByteString]

100−messageToPayload (Message fp enc) = encodeFingerprint fp : BSL.toChunks enc

101−

102−-- | Deserialize a message

103−payloadToMessage :: [BSS.ByteString] -> Message

104−payloadToMessage payload = Message fp msg

105− where

106− (encFp, msg) = BSL.splitAt (fromIntegral sizeOfFingerprint)

107− $ BSL.fromChunks payload

108− fp = decodeFingerprint . BSS.concat . BSL.toChunks $ encFp

109−

110--------------------------------------------------------------------------------

86--------------------------------------------------------------------------------

111-- Internal --

87-- Internal --

112--------------------------------------------------------------------------------

88--------------------------------------------------------------------------------

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

@@ -29,6 +29,15 @@ module Control.Distributed.Process.Internal.Primitives

29 , unlink

30 , monitor

31 , unmonitor

32+ -- * Registry

33+ , register

34+ , unregister

35+ , whereis

36+ , nsend

37+ , registerRemote

38+ , unregisterRemote

39+ , whereisRemote

40+ , nsendRemote

32 -- * Auxiliary API

41 -- * Auxiliary API

33 , catch

42 , catch

34 , expectTimeout

43 , expectTimeout

@@ -91,6 +100,8 @@ import Control.Distributed.Process.Internal.Types

91 , DidUnlinkProcess(..)

100 , DidUnlinkProcess(..)

92 , DidUnlinkNode(..)

101 , DidUnlinkNode(..)

93 , DidUnlinkPort(..)

102 , DidUnlinkPort(..)

103+ , WhereIsReply(..)

104+ , createMessage

94 )

105 )

95import Control.Distributed.Process.Internal.MessageT

106import Control.Distributed.Process.Internal.MessageT

96 ( sendMessage

107 ( sendMessage

@@ -351,6 +362,60 @@ unlinkPortAsync :: SendPort a -> Process ()

351unlinkPortAsync (SendPort cid) =

362unlinkPortAsync (SendPort cid) =

352 sendCtrlMsg Nothing . Unlink $ SendPortIdentifier cid

363 sendCtrlMsg Nothing . Unlink $ SendPortIdentifier cid

353

364

365+--------------------------------------------------------------------------------

366+-- Registry --

367+--------------------------------------------------------------------------------

368+

369+-- | Register a process with the local registry (asynchronous).

370+--

371+-- The process to be registered does not have to be local itself.

372+register :: String -> ProcessId -> Process ()

373+register label pid =

374+ sendCtrlMsg Nothing (Register label (Just pid))

375+

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

377+--

378+-- The process to be registered does not have to live on the same remote node.

379+registerRemote :: NodeId -> String -> ProcessId -> Process ()

380+registerRemote nid label pid =

381+ sendCtrlMsg (Just nid) (Register label (Just pid))

382+

383+-- | Remove a process from the local registry (asynchronous).

384+unregister :: String -> Process ()

385+unregister label =

386+ sendCtrlMsg Nothing (Register label Nothing)

387+

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

389+unregisterRemote :: NodeId -> String -> Process ()

390+unregisterRemote nid label =

391+ sendCtrlMsg (Just nid) (Register label Nothing)

392+

393+-- | Query the local process registry (synchronous).

394+whereis :: String -> Process (Maybe ProcessId)

395+whereis label = do

396+ sendCtrlMsg Nothing (WhereIs label)

397+ receiveWait [ matchIf (\(WhereIsReply label' _) -> label == label')

398+ (\(WhereIsReply _ mPid) -> return mPid)

399+ ]

400+

401+-- | Query a remote process registry (synchronous)

402+whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)

403+whereisRemote nid label = do

404+ sendCtrlMsg (Just nid) (WhereIs label)

405+ receiveWait [ matchIf (\(WhereIsReply label' _) -> label == label')

406+ (\(WhereIsReply _ mPid) -> return mPid)

407+ ]

408+

409+-- | Named send to a process in the local registry (asynchronous)

410+nsend :: Serializable a => String -> a -> Process ()

411+nsend label msg =

412+ sendCtrlMsg Nothing (NamedSend label (createMessage msg))

413+

414+-- | Named send to a process in a remote registry (asynchronous)

415+nsendRemote :: Serializable a => NodeId -> String -> a -> Process ()

416+nsendRemote nid label msg =

417+ sendCtrlMsg (Just nid) (NamedSend label (createMessage msg))

418+

354--------------------------------------------------------------------------------

419--------------------------------------------------------------------------------

355-- Auxiliary functions --

420-- Auxiliary functions --

356--------------------------------------------------------------------------------

421--------------------------------------------------------------------------------

@@ -399,3 +464,4 @@ sendCtrlMsg mNid signal = do

399 liftIO $ writeChan ctrlChan msg

464 liftIO $ writeChan ctrlChan msg

400 Just nid ->

465 Just nid ->

401 procMsg $ sendBinary (NodeIdentifier nid) msg

466 procMsg $ sendBinary (NodeIdentifier nid) msg

467+

distributed-process/src/Control/Distributed/Process/Internal/Types.hs+63−13

@@ -33,6 +33,9 @@ module Control.Distributed.Process.Internal.Types

33 , RuntimeSerializableSupport(..)

34 -- * Messages

35 , Message(..)

36+ , createMessage

37+ , messageToPayload

38+ , payloadToMessage

36 -- * Node controller user-visible data types

39 -- * Node controller user-visible data types

37 , MonitorRef(..)

40 , MonitorRef(..)

38 , ProcessMonitorNotification(..)

41 , ProcessMonitorNotification(..)

@@ -48,6 +51,7 @@ module Control.Distributed.Process.Internal.Types

48 , DidUnlinkPort(..)

51 , DidUnlinkPort(..)

49 , SpawnRef(..)

52 , SpawnRef(..)

50 , DidSpawn(..)

53 , DidSpawn(..)

54+ , WhereIsReply(..)

51 -- * Node controller internal data types

55 -- * Node controller internal data types

52 , NCMsg(..)

56 , NCMsg(..)

53 , ProcessSignal(..)

57 , ProcessSignal(..)

@@ -73,11 +77,16 @@ module Control.Distributed.Process.Internal.Types

73import Data.Map (Map)

77import Data.Map (Map)

74import Data.Int (Int32)

78import Data.Int (Int32)

75import Data.Typeable (Typeable, TypeRep)

79import Data.Typeable (Typeable, TypeRep)

76−import Data.Binary (Binary(put, get), putWord8, getWord8)

80+import Data.Binary (Binary(put, get), putWord8, getWord8, encode)

81+import qualified Data.ByteString as BSS (ByteString, concat)

77−import Data.ByteString.Lazy (ByteString)

82+import qualified Data.ByteString.Lazy as BSL

83+ ( ByteString

84+ , toChunks

85+ , splitAt

86+ , fromChunks

87+ )

78import Data.Accessor (Accessor, accessor)

88import Data.Accessor (Accessor, accessor)

79import qualified Data.Accessor.Container as DAC (mapMaybe)

89import qualified Data.Accessor.Container as DAC (mapMaybe)

80−import qualified Data.ByteString.Lazy as BSL (ByteString)

81import Control.Category ((>>>))

90import Control.Category ((>>>))

82import Control.Exception (Exception)

91import Control.Exception (Exception)

83import Control.Concurrent (ThreadId)

92import Control.Concurrent (ThreadId)

@@ -90,7 +99,14 @@ import Control.Monad.Reader (MonadReader(..), ReaderT)

90import Control.Monad.IO.Class (MonadIO)

99import Control.Monad.IO.Class (MonadIO)

91import Control.Monad.State (MonadState, StateT)

100import Control.Monad.State (MonadState, StateT)

92import qualified Control.Monad.Trans.Class as Trans (lift)

101import qualified Control.Monad.Trans.Class as Trans (lift)

93−import Control.Distributed.Process.Serializable (Fingerprint, Serializable)

102+import Control.Distributed.Process.Serializable

103+ ( Fingerprint

104+ , Serializable

105+ , fingerprint

106+ , encodeFingerprint

107+ , sizeOfFingerprint

108+ , decodeFingerprint

109+ )

94import Control.Distributed.Process.Internal.CQueue (CQueue)

110import Control.Distributed.Process.Internal.CQueue (CQueue)

95import Control.Distributed.Process.Internal.Dynamic (Dynamic)

111import Control.Distributed.Process.Internal.Dynamic (Dynamic)

112

@@ -255,7 +271,7 @@ newtype Static a = Static StaticLabel

255 deriving (Typeable, Show)

271 deriving (Typeable, Show)

256

272

257-- | A closure is a static value and an encoded environment

273-- | A closure is a static value and an encoded environment

258−data Closure a = Closure (Static (ByteString -> a)) ByteString

274+data Closure a = Closure (Static (BSL.ByteString -> a)) BSL.ByteString

259 deriving (Typeable, Show)

275 deriving (Typeable, Show)

260

276

261-- | Used to fake 'static' (see paper)

277-- | Used to fake 'static' (see paper)

@@ -294,6 +310,25 @@ data Message = Message

294 , messageEncoding :: BSL.ByteString

310 , messageEncoding :: BSL.ByteString

295 }

311 }

296

312

313+instance Show Message where

314+ show = show . messageEncoding

315+

316+-- | Turn any serialiable term into a message

317+createMessage :: Serializable a => a -> Message

318+createMessage a = Message (fingerprint a) (encode a)

319+

320+-- | Serialize a message

321+messageToPayload :: Message -> [BSS.ByteString]

322+messageToPayload (Message fp enc) = encodeFingerprint fp : BSL.toChunks enc

323+

324+-- | Deserialize a message

325+payloadToMessage :: [BSS.ByteString] -> Message

326+payloadToMessage payload = Message fp msg

327+ where

328+ (encFp, msg) = BSL.splitAt (fromIntegral sizeOfFingerprint)

329+ $ BSL.fromChunks payload

330+ fp = decodeFingerprint . BSS.concat . BSL.toChunks $ encFp

331+

297--------------------------------------------------------------------------------

332--------------------------------------------------------------------------------

298-- Node controller user-visible data types --

333-- Node controller user-visible data types --

299--------------------------------------------------------------------------------

334--------------------------------------------------------------------------------

@@ -376,10 +411,14 @@ newtype DidUnlinkPort = DidUnlinkPort SendPortId

376newtype SpawnRef = SpawnRef Int32

411newtype SpawnRef = SpawnRef Int32

377 deriving (Show, Binary, Typeable, Eq)

412 deriving (Show, Binary, Typeable, Eq)

378

413

379−-- | (Asynchronius) reply from spawn

414+-- | (Asynchronius) reply from 'spawn'

380data DidSpawn = DidSpawn SpawnRef ProcessId

415data DidSpawn = DidSpawn SpawnRef ProcessId

381 deriving (Show, Typeable)

416 deriving (Show, Typeable)

382

417

418+-- | (Asynchronous) reply from 'whereis'

419+data WhereIsReply = WhereIsReply String (Maybe ProcessId)

420+ deriving (Show, Typeable)

421+

383--------------------------------------------------------------------------------

422--------------------------------------------------------------------------------

384-- Node controller internal data types --

423-- Node controller internal data types --

385--------------------------------------------------------------------------------

424--------------------------------------------------------------------------------

@@ -399,6 +438,9 @@ data ProcessSignal =

399 | Unmonitor MonitorRef

438 | Unmonitor MonitorRef

400 | Died Identifier DiedReason

439 | Died Identifier DiedReason

401 | Spawn (Closure (Process ())) SpawnRef

440 | Spawn (Closure (Process ())) SpawnRef

441+ | WhereIs String

442+ | Register String (Maybe ProcessId) -- Nothing to unregister

443+ | NamedSend String Message

402 deriving Show

444 deriving Show

403

445

404--------------------------------------------------------------------------------

446--------------------------------------------------------------------------------

@@ -434,12 +476,15 @@ instance Binary MonitorRef where

434 get = MonitorRef <$> get <*> get

476 get = MonitorRef <$> get <*> get

435

477

436instance Binary ProcessSignal where

478instance Binary ProcessSignal where

437− put (Link pid) = putWord8 0 >> put pid

479+ put (Link pid) = putWord8 0 >> put pid

438− put (Unlink pid) = putWord8 1 >> put pid

480+ put (Unlink pid) = putWord8 1 >> put pid

439− put (Monitor ref) = putWord8 2 >> put ref

481+ put (Monitor ref) = putWord8 2 >> put ref

440− put (Unmonitor ref) = putWord8 3 >> put ref

482+ put (Unmonitor ref) = putWord8 3 >> put ref

441− put (Died who reason) = putWord8 4 >> put who >> put reason

483+ put (Died who reason) = putWord8 4 >> put who >> put reason

442− put (Spawn proc ref) = putWord8 5 >> put proc >> put ref

484+ put (Spawn proc ref) = putWord8 5 >> put proc >> put ref

485+ put (WhereIs label) = putWord8 6 >> put label

486+ put (Register label pid) = putWord8 7 >> put label >> put pid

487+ put (NamedSend label msg) = putWord8 8 >> put label >> put (messageToPayload msg)

443 get = do

488 get = do

444 header <- getWord8

489 header <- getWord8

445 case header of

490 case header of

@@ -449,6 +494,9 @@ instance Binary ProcessSignal where

449 3 -> Unmonitor <$> get

494 3 -> Unmonitor <$> get

450 4 -> Died <$> get <*> get

495 4 -> Died <$> get <*> get

451 5 -> Spawn <$> get <*> get

496 5 -> Spawn <$> get <*> get

497+ 6 -> WhereIs <$> get

498+ 7 -> Register <$> get <*> get

499+ 8 -> NamedSend <$> get <*> (payloadToMessage <$> get)

452 _ -> fail "ProcessSignal.get: invalid"

500 _ -> fail "ProcessSignal.get: invalid"

453

501

454instance Binary DiedReason where

502instance Binary DiedReason where

@@ -529,7 +577,9 @@ instance Binary StaticLabel where

529 15 -> return CpApply

577 15 -> return CpApply

530 _ -> fail "StaticLabel.get: invalid"

578 _ -> fail "StaticLabel.get: invalid"

531

579

532−

580+instance Binary WhereIsReply where

581+ put (WhereIsReply label mPid) = put label >> put mPid

582+ get = WhereIsReply <$> get <*> get

533

583

534--------------------------------------------------------------------------------

584--------------------------------------------------------------------------------

535-- Accessors --

585-- Accessors --

distributed-process/src/Control/Distributed/Process/Node.hs+47−1

@@ -61,7 +61,7 @@ import qualified Network.Transport as NT

61 , ConnectionId

62 )

63import Data.Accessor (Accessor, accessor, (^.), (^=), (^:))

64−import qualified Data.Accessor.Container as DAC (mapDefault)

64+import qualified Data.Accessor.Container as DAC (mapDefault, mapMaybe)

65import System.Random (randomIO)

66import Control.Distributed.Process.Internal.Types

67 ( RemoteTable

@@ -101,11 +101,14 @@ import Control.Distributed.Process.Internal.Types

101 , nodeOf

102 , SendPortId(..)

103 , typedChannelWithId

104+ , WhereIsReply(..)

105+ , messageToPayload

104 )

106 )

105import Control.Distributed.Process.Serializable (Serializable)

107import Control.Distributed.Process.Serializable (Serializable)

106import Control.Distributed.Process.Internal.MessageT

108import Control.Distributed.Process.Internal.MessageT

107 ( sendBinary

109 ( sendBinary

108 , sendMessage

110 , sendMessage

111+ , sendPayload

109 , getLocalNode

112 , getLocalNode

110 , runMessageT

113 , runMessageT

111 , payloadToMessage

114 , payloadToMessage

@@ -343,6 +346,8 @@ data NCState = NCState

343 _links :: Map Identifier (Set ProcessId)

346 _links :: Map Identifier (Set ProcessId)

344 -- Mapping from remote processes to monitoring local processes

347 -- Mapping from remote processes to monitoring local processes

345 , _monitors :: Map Identifier (Set (ProcessId, MonitorRef))

348 , _monitors :: Map Identifier (Set (ProcessId, MonitorRef))

349+ -- Process registry

350+ , _registry :: Map String ProcessId

346 }

351 }

347

352

348newtype NC a = NC { unNC :: StateT NCState (MessageT IO) a }

353newtype NC a = NC { unNC :: StateT NCState (MessageT IO) a }

@@ -354,6 +359,7 @@ ncMsg = NC . Trans.lift

354initNCState :: NCState

359initNCState :: NCState

355initNCState = NCState { _links = Map.empty

360initNCState = NCState { _links = Map.empty

356 , _monitors = Map.empty

361 , _monitors = Map.empty

362+ , _registry = Map.empty

357 }

363 }

358

364

359--------------------------------------------------------------------------------

365--------------------------------------------------------------------------------

@@ -387,6 +393,12 @@ nodeController = do

387 ncEffectDied ident reason

393 ncEffectDied ident reason

388 NCMsg (ProcessIdentifier from) (Spawn proc ref) ->

394 NCMsg (ProcessIdentifier from) (Spawn proc ref) ->

389 ncEffectSpawn from proc ref

395 ncEffectSpawn from proc ref

396+ NCMsg _from (Register label pid) ->

397+ ncEffectRegister label pid

398+ NCMsg (ProcessIdentifier from) (WhereIs label) ->

399+ ncEffectWhereIs from label

400+ NCMsg from (NamedSend label msg') ->

401+ ncEffectNamedSend from label msg'

390 unexpected ->

402 unexpected ->

391 error $ "nodeController: unexpected message " ++ show unexpected

403 error $ "nodeController: unexpected message " ++ show unexpected

392

404

@@ -468,6 +480,31 @@ ncEffectSpawn pid cProc ref = do

468 pid' <- liftIO $ forkProcess node proc

480 pid' <- liftIO $ forkProcess node proc

469 ncMsg $ sendMessage (ProcessIdentifier pid) (DidSpawn ref pid')

481 ncMsg $ sendMessage (ProcessIdentifier pid) (DidSpawn ref pid')

470

482

483+-- Unified semantics does not explicitly describe how to implement 'register',

484+-- but mentions it's "very similar to nsend" (Table 14)

485+ncEffectRegister :: String -> Maybe ProcessId -> NC ()

486+ncEffectRegister label mPid =

487+ modify $ registryFor label ^= mPid

488+ -- An acknowledgement is not necessary. If we want a synchronous register,

489+ -- it suffices to send a whereis requiry immediately after the register

490+ -- (that may not suffice if we do decide for unreliable messaging instead)

491+

492+-- Unified semantics does not explicitly describe 'whereis'

493+ncEffectWhereIs :: ProcessId -> String -> NC ()

494+ncEffectWhereIs from label = do

495+ mPid <- gets (^. registryFor label)

496+ ncMsg $ sendMessage (ProcessIdentifier from) (WhereIsReply label mPid)

497+

498+-- [Unified: Table 14]

499+ncEffectNamedSend :: Identifier -> String -> Message -> NC ()

500+ncEffectNamedSend _from label msg = do

501+ mPid <- gets (^. registryFor label)

502+ -- If mPid is Nothing, we just ignore the named send (as per Table 14)

503+ -- TODO: messages don't carry a "from", but if they do, we should set it

504+ -- to be the 'from' of the original named send, not this node controller

505+ forM_ mPid $ \pid ->

506+ ncMsg $ sendPayload (ProcessIdentifier pid) (messageToPayload msg)

507+

471--------------------------------------------------------------------------------

508--------------------------------------------------------------------------------

472-- Auxiliary --

509-- Auxiliary --

473--------------------------------------------------------------------------------

510--------------------------------------------------------------------------------

@@ -507,6 +544,9 @@ destNid (Unlink ident) = Just $ nodeOf ident

507destNid (Monitor ref) = Just $ nodeOf (monitorRefIdent ref)

544destNid (Monitor ref) = Just $ nodeOf (monitorRefIdent ref)

508destNid (Unmonitor ref) = Just $ nodeOf (monitorRefIdent ref)

545destNid (Unmonitor ref) = Just $ nodeOf (monitorRefIdent ref)

509destNid (Spawn _ _) = Nothing

546destNid (Spawn _ _) = Nothing

547+destNid (Register _ _) = Nothing

548+destNid (WhereIs _) = Nothing

549+destNid (NamedSend _ _) = Nothing

510-- We don't need to forward 'Died' signals; if monitoring/linking is setup,

550-- We don't need to forward 'Died' signals; if monitoring/linking is setup,

511-- then when a local process dies the monitoring/linking machinery will take

551-- then when a local process dies the monitoring/linking machinery will take

512-- care of notifying remote nodes

552-- care of notifying remote nodes

@@ -576,12 +616,18 @@ links = accessor _links (\ls st -> st { _links = ls })

576monitors :: Accessor NCState (Map Identifier (Set (ProcessId, MonitorRef)))

616monitors :: Accessor NCState (Map Identifier (Set (ProcessId, MonitorRef)))

577monitors = accessor _monitors (\ms st -> st { _monitors = ms })

617monitors = accessor _monitors (\ms st -> st { _monitors = ms })

578

618

619+registry :: Accessor NCState (Map String ProcessId)

620+registry = accessor _registry (\ry st -> st { _registry = ry })

621+

579linksFor :: Identifier -> Accessor NCState (Set ProcessId)

622linksFor :: Identifier -> Accessor NCState (Set ProcessId)

580linksFor ident = links >>> DAC.mapDefault Set.empty ident

623linksFor ident = links >>> DAC.mapDefault Set.empty ident

581

624

582monitorsFor :: Identifier -> Accessor NCState (Set (ProcessId, MonitorRef))

625monitorsFor :: Identifier -> Accessor NCState (Set (ProcessId, MonitorRef))

583monitorsFor ident = monitors >>> DAC.mapDefault Set.empty ident

626monitorsFor ident = monitors >>> DAC.mapDefault Set.empty ident

584

627

628+registryFor :: String -> Accessor NCState (Maybe ProcessId)

629+registryFor ident = registry >>> DAC.mapMaybe ident

630+

585-- | @splitNotif ident@ splits a notifications map into those

631-- | @splitNotif ident@ splits a notifications map into those

586-- notifications that should trigger when 'ident' fails and those links that

632-- notifications that should trigger when 'ident' fails and those links that

587-- should not.

633-- should not.

distributed-process/tests/TestCH.hs+19−1

@@ -524,6 +524,23 @@ testMonitorChannel transport = do

524

525 takeMVar gotNotification

526

527+testRegistry :: NT.Transport -> IO ()

528+testRegistry transport = do

529+ node <- newLocalNode transport initRemoteTable

530+

531+ pingServer <- forkProcess node ping

532+

533+ runProcess node $ do

534+ register "ping" pingServer

535+ Just pid <- whereis "ping"

536+ True <- return $ pingServer == pid

537+ us <- getSelfPid

538+ nsend "ping" (Pong us)

539+ Ping pid' <- expect

540+ True <- return $ pingServer == pid'

541+ return ()

542+

543+

527main :: IO ()

544main :: IO ()

528main = do

545main = do

529 Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters

546 Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters

@@ -535,7 +552,8 @@ main = do

535 , ("SendToTerminated", testSendToTerminated transport)

552 , ("SendToTerminated", testSendToTerminated transport)

536 , ("TypedChannnels", testTypedChannels transport)

553 , ("TypedChannnels", testTypedChannels transport)

537 , ("MergeChannels", testMergeChannels transport)

554 , ("MergeChannels", testMergeChannels transport)

538− , ("TestTerminate", testTerminate transport)

555+ , ("Terminate", testTerminate transport)

556+ , ("Registry", testRegistry transport)

539 -- Monitoring processes

557 -- Monitoring processes

540 --

558 --

541 -- The "missing" combinations in the list below don't make much sense, as

559 -- The "missing" combinations in the list below don't make much sense, as