474909d · distributed-process

git.iko.soy/distributed-process

Merge pull request #76 from jepst/master

Align semantics of register/whereis with Erlang

commit474909d2438ee13f850c1a9a28c1a7c3324909b3 authorEdsko de Vries <edsko@well-typed.com> dateMon 19 Nov 2012, 06:20 (14 years ago) parentaf14826 c88fbef

7 files changed+225−49

compare with master

unifiedsplit

distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet.hs+2−2 distributed-process/distributed-process.cabal+1−1 distributed-process/src/Control/Distributed/Process.hs+10−4 distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs+57−12 distributed-process/src/Control/Distributed/Process/Internal/Types.hs+21−3 distributed-process/src/Control/Distributed/Process/Node.hs+111−21 distributed-process/tests/TestCH.hs+23−6

distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet.hs+2−2

@@ -115,7 +115,7 @@ import Control.Distributed.Process

115115 , WhereIsReply(..)

116116 , whereis

117117 , whereisRemoteAsync

118− , registerRemote

118+ , reregisterRemoteAsync

119119 , getSelfPid

120120 , register

121121 , expect

@@ -244,7 +244,7 @@ apiRedirectLogsHere backend = do

244244 mLogger <- whereis "logger"

245245 forM_ mLogger $ \logger -> do

246246 nids <- liftIO $ findPeers backend 1000000

247− forM_ nids $ \nid -> registerRemote nid "logger" logger

247+ forM_ nids $ \nid -> reregisterRemoteAsync nid "logger" logger -- ignore async response

248248

249249--------------------------------------------------------------------------------

250250-- Slaves --

distributed-process/distributed-process.cabal+1−1

@@ -1,5 +1,5 @@

11Name: distributed-process

2−Version: 0.4.0.2

2+Version: 0.4.0.3

33Cabal-Version: >=1.8

44Build-Type: Simple

55License: BSD3

distributed-process/src/Control/Distributed/Process.hs+10−4

@@ -44,6 +44,7 @@ module Control.Distributed.Process

4444 , call

4545 , terminate

4646 , ProcessTerminationException(..)

47+ , ProcessRegistrationException(..)

4748 , SpawnRef

4849 , getSelfPid

4950 , getSelfNode

@@ -77,11 +78,13 @@ module Control.Distributed.Process

7778 , say

7879 -- * Registry

7980 , register

81+ , reregister

8082 , unregister

8183 , whereis

8284 , nsend

83− , registerRemote

84− , unregisterRemote

85+ , registerRemoteAsync

86+ , reregisterRemoteAsync

87+ , unregisterRemoteAsync

8588 , whereisRemoteAsync

8689 , nsendRemote

8790 , WhereIsReply(..)

@@ -135,6 +138,7 @@ import Control.Distributed.Process.Internal.Types

135138 , ProcessLinkException(..)

136139 , NodeLinkException(..)

137140 , PortLinkException(..)

141+ , ProcessRegistrationException(..)

138142 , DiedReason(..)

139143 , SpawnRef(..)

140144 , DidSpawn(..)

@@ -197,11 +201,13 @@ import Control.Distributed.Process.Internal.Primitives

197201 , say

198202 -- Registry

199203 , register

204+ , reregister

200205 , unregister

201206 , whereis

202207 , nsend

203− , registerRemote

204− , unregisterRemote

208+ , registerRemoteAsync

209+ , reregisterRemoteAsync

210+ , unregisterRemoteAsync

205211 , whereisRemoteAsync

206212 , nsendRemote

207213 -- Closures

distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs+57−12

@@ -35,11 +35,13 @@ module Control.Distributed.Process.Internal.Primitives

3535 , say

3636 -- * Registry

3737 , register

38+ , reregister

3839 , unregister

3940 , whereis

4041 , nsend

41− , registerRemote

42− , unregisterRemote

42+ , registerRemoteAsync

43+ , reregisterRemoteAsync

44+ , unregisterRemoteAsync

4345 , whereisRemoteAsync

4446 , nsendRemote

4547 -- * Closures

@@ -76,6 +78,7 @@ import Data.Time.Clock (getCurrentTime)

7678import Data.Time.Format (formatTime)

7779import System.Locale (defaultTimeLocale)

7880import System.Timeout (timeout)

81+import Control.Monad (when)

7982import Control.Monad.Reader (ask)

8083import Control.Monad.IO.Class (MonadIO, liftIO)

8184import Control.Applicative ((<$>))

@@ -127,6 +130,8 @@ import Control.Distributed.Process.Internal.Types

127130 , DidUnlinkNode(..)

128131 , DidUnlinkPort(..)

129132 , WhereIsReply(..)

133+ , RegisterReply(..)

134+ , ProcessRegistrationException(..)

130135 , createMessage

131136 , runLocalProcess

132137 , ImplicitReconnect(WithImplicitReconnect, NoImplicitReconnect)

@@ -539,28 +544,68 @@ say string = do

539544--------------------------------------------------------------------------------

540545

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

547+-- This version will wait until a response is gotten from the

548+-- management process. The name must not already be registered.

549+-- The process need not be on this node.

550+-- A bad registration will result in a 'ProcessRegistrationException'

542551--

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

544553register :: String -> ProcessId -> Process ()

545−register label pid =

546− sendCtrlMsg Nothing (Register label (Just pid))

554+register = registerImpl False

555+

556+-- | Like 'register', but will replace an existing registration.

557+-- The name must already be registered.

558+reregister :: String -> ProcessId -> Process ()

559+reregister = registerImpl True

560+

561+registerImpl :: Bool -> String -> ProcessId -> Process ()

562+registerImpl force label pid = do

563+ mynid <- getSelfNode

564+ sendCtrlMsg Nothing (Register label mynid (Just pid) force)

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

566+ (\(RegisterReply _ ok) -> handleRegistrationReply label ok)

567+ ]

547568

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

549570--

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

551−registerRemote :: NodeId -> String -> ProcessId -> Process ()

552−registerRemote nid label pid =

553− sendCtrlMsg (Just nid) (Register label (Just pid))

572+-- Reply wil come in the form of a 'RegisterReply' message

573+--

574+-- See comments in 'whereisRemoteAsync'

575+registerRemoteAsync :: NodeId -> String -> ProcessId -> Process ()

576+registerRemoteAsync nid label pid =

577+ sendCtrlMsg (Just nid) (Register label nid (Just pid) False)

578+

579+reregisterRemoteAsync :: NodeId -> String -> ProcessId -> Process ()

580+reregisterRemoteAsync nid label pid =

581+ sendCtrlMsg (Just nid) (Register label nid (Just pid) True)

554582

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

584+-- This version will wait until a response is gotten from the

585+-- management process. The name must already be registered.

556586unregister :: String -> Process ()

557−unregister label =

558− sendCtrlMsg Nothing (Register label Nothing)

587+unregister label = do

588+ mynid <- getSelfNode

589+ sendCtrlMsg Nothing (Register label mynid Nothing False)

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

591+ (\(RegisterReply _ ok) -> handleRegistrationReply label ok)

592+ ]

593+

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

595+-- by throwing an exception if necessary

596+handleRegistrationReply :: String -> Bool -> Process ()

597+handleRegistrationReply label ok =

598+ when (not ok) $

599+ liftIO $ throwIO $ ProcessRegistrationException label

559600

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

561−unregisterRemote :: NodeId -> String -> Process ()

562−unregisterRemote nid label =

563− sendCtrlMsg (Just nid) (Register label Nothing)

602+--

603+-- Reply wil come in the form of a 'RegisterReply' message

604+--

605+-- See comments in 'whereisRemoteAsync'

606+unregisterRemoteAsync :: NodeId -> String -> Process ()

607+unregisterRemoteAsync nid label =

608+ sendCtrlMsg (Just nid) (Register label nid Nothing False)

564609

565610-- | Query the local process registry

566611whereis :: String -> Process (Maybe ProcessId)

distributed-process/src/Control/Distributed/Process/Internal/Types.hs+21−3

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

3939 , ProcessLinkException(..)

4040 , NodeLinkException(..)

4141 , PortLinkException(..)

42+ , ProcessRegistrationException(..)

4243 , DiedReason(..)

4344 , DidUnmonitor(..)

4445 , DidUnlinkProcess(..)

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

4748 , SpawnRef(..)

4849 , DidSpawn(..)

4950 , WhereIsReply(..)

51+ , RegisterReply(..)

5052 -- * Node controller internal data types

5153 , NCMsg(..)

5254 , ProcessSignal(..)

@@ -359,9 +361,17 @@ data PortLinkException =

359361 PortLinkException !SendPortId !DiedReason

360362 deriving (Typeable, Show)

361363

364+-- | Exception thrown when a process attempts to register

365+-- a process under an already-registered name or to

366+-- unregister a name that hasn't been registered

367+data ProcessRegistrationException =

368+ ProcessRegistrationException !String

369+ deriving (Typeable, Show)

370+

362371instance Exception ProcessLinkException

363372instance Exception NodeLinkException

364373instance Exception PortLinkException

374+instance Exception ProcessRegistrationException

365375

366376-- | Why did a process die?

367377data DiedReason =

@@ -406,6 +416,10 @@ data DidSpawn = DidSpawn SpawnRef ProcessId

406416data WhereIsReply = WhereIsReply String (Maybe ProcessId)

407417 deriving (Show, Typeable)

408418

419+-- | (Asynchronous) reply from 'register' and 'unregister'

420+data RegisterReply = RegisterReply String Bool

421+ deriving (Show, Typeable)

422+

409423--------------------------------------------------------------------------------

410424-- Node controller internal data types --

411425--------------------------------------------------------------------------------

@@ -426,7 +440,7 @@ data ProcessSignal =

426440 | Died Identifier !DiedReason

427441 | Spawn !(Closure (Process ())) !SpawnRef

428442 | WhereIs !String

429− | Register !String !(Maybe ProcessId) -- Use 'Nothing' to unregister

443+ | Register !String !NodeId !(Maybe ProcessId) !Bool -- Use 'Nothing' to unregister, use True to force reregister

430444 | NamedSend !String !Message

431445 deriving Show

432446

@@ -470,7 +484,7 @@ instance Binary ProcessSignal where

470484 put (Died who reason) = putWord8 4 >> put who >> put reason

471485 put (Spawn proc ref) = putWord8 5 >> put proc >> put ref

472486 put (WhereIs label) = putWord8 6 >> put label

473− put (Register label pid) = putWord8 7 >> put label >> put pid

487+ put (Register label nid pid force) = putWord8 7 >> put label >> put nid >> put pid >> put force

474488 put (NamedSend label msg) = putWord8 8 >> put label >> put (messageToPayload msg)

475489 get = do

476490 header <- getWord8

@@ -482,7 +496,7 @@ instance Binary ProcessSignal where

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

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

484498 6 -> WhereIs <$> get

485− 7 -> Register <$> get <*> get

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

486500 8 -> NamedSend <$> get <*> (payloadToMessage <$> get)

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

488502

@@ -526,6 +540,10 @@ instance Binary WhereIsReply where

526540 put (WhereIsReply label mPid) = put label >> put mPid

527541 get = WhereIsReply <$> get <*> get

528542

543+instance Binary RegisterReply where

544+ put (RegisterReply label ok) = put label >> put ok

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

546+

529547--------------------------------------------------------------------------------

530548-- Accessors --

531549--------------------------------------------------------------------------------

distributed-process/src/Control/Distributed/Process/Node.hs+111−21

@@ -24,6 +24,8 @@ import Data.Map (Map)

2424import qualified Data.Map as Map

2525 ( empty

2626 , toList

27+ , fromList

28+ , filter

2729 , partitionWithKey

2830 , elems

2931 , filterWithKey

@@ -31,7 +33,7 @@ import qualified Data.Map as Map

3133import Data.Set (Set)

3234import qualified Data.Set as Set (empty, insert, delete, member)

3335import Data.Foldable (forM_)

34−import Data.Maybe (isJust)

36+import Data.Maybe (isJust, isNothing, catMaybes)

3537import Data.Typeable (Typeable)

3638import Control.Category ((>>>))

3739import Control.Applicative ((<$>))

@@ -118,6 +120,7 @@ import Control.Distributed.Process.Internal.Types

118120 , nodeOf

119121 , SendPortId(..)

120122 , typedChannelWithId

123+ , RegisterReply(..)

121124 , WhereIsReply(..)

122125 , messageToPayload

123126 , payloadToMessage

@@ -437,8 +440,9 @@ data NCState = NCState

437440 _links :: !(Map Identifier (Set ProcessId))

438441 -- Mapping from remote processes to monitoring local processes

439442 , _monitors :: !(Map Identifier (Set (ProcessId, MonitorRef)))

440− -- Process registry

441− , _registry :: !(Map String ProcessId)

443+ -- Process registry: names and where they live, mapped to the PIDs

444+ , _registeredHere :: !(Map String ProcessId)

445+ , _registeredOnNodes :: !(Map ProcessId [(NodeId,Int)])

442446 }

443447

444448newtype NC a = NC { unNC :: StateT NCState (ReaderT LocalNode IO) a }

@@ -447,7 +451,8 @@ newtype NC a = NC { unNC :: StateT NCState (ReaderT LocalNode IO) a }

447451initNCState :: NCState

448452initNCState = NCState { _links = Map.empty

449453 , _monitors = Map.empty

450− , _registry = Map.empty

454+ , _registeredHere = Map.empty

455+ , _registeredOnNodes = Map.empty

451456 }

452457

453458--------------------------------------------------------------------------------

@@ -485,8 +490,8 @@ nodeController = do

485490 ncEffectDied ident reason

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

487492 ncEffectSpawn from proc ref

488− NCMsg _from (Register label pid) ->

489− ncEffectRegister label pid

493+ NCMsg (ProcessIdentifier from) (Register label atnode pid force) ->

494+ ncEffectRegister from label atnode pid force

490495 NCMsg (ProcessIdentifier from) (WhereIs label) ->

491496 ncEffectWhereIs from label

492497 NCMsg from (NamedSend label msg') ->

@@ -554,6 +559,8 @@ ncEffectDied ident reason = do

554559 (affectedLinks, unaffectedLinks) <- gets (splitNotif ident . (^. links))

555560 (affectedMons, unaffectedMons) <- gets (splitNotif ident . (^. monitors))

556561

562+-- _registry :: !(Map (String,NodeId) ProcessId)

563+

557564 let localOnly = case ident of NodeIdentifier _ -> True ; _ -> False

558565

559566 forM_ (Map.toList affectedLinks) $ \(them, uss) ->

@@ -564,10 +571,34 @@ ncEffectDied ident reason = do

564571 forM_ (Map.toList affectedMons) $ \(them, refs) ->

565572 forM_ refs $ \(us, ref) ->

566573 when (localOnly <= isLocal node (ProcessIdentifier us)) $

567− notifyDied us them reason (Just ref)

574+ notifyDied us them reason (Just ref)

568575

569576 modify' $ (links ^= unaffectedLinks) . (monitors ^= unaffectedMons)

570577

578+ modify' $ registeredHere ^: Map.filter (\pid -> not $ ident `impliesDeathOf` ProcessIdentifier pid)

579+

580+ remaining <- fmap Map.toList (gets (^. registeredOnNodes)) >>=

581+ mapM (\(pid,nidlist) ->

582+ case ident `impliesDeathOf` ProcessIdentifier pid of

583+ True ->

584+ do forM_ nidlist $ \(nid,_) ->

585+ when (not $ isLocal node (NodeIdentifier nid))

586+ (forwardNameDeath node nid)

587+ return Nothing

588+ False -> return $ Just (pid,nidlist) )

589+ modify' $ registeredOnNodes ^= (Map.fromList (catMaybes remaining))

590+ where

591+ forwardNameDeath node nid =

592+ liftIO $ sendBinary node

593+ (NodeIdentifier $ localNodeId node)

594+ (NodeIdentifier $ nid)

595+ WithImplicitReconnect

596+ NCMsg

597+ { ctrlMsgSender = NodeIdentifier (localNodeId node)

598+ , ctrlMsgSignal = Died ident reason

599+ }

600+

601+

571602-- [Unified: Table 13]

572603ncEffectSpawn :: ProcessId -> Closure (Process ()) -> SpawnRef -> NC ()

573604ncEffectSpawn pid cProc ref = do

@@ -587,18 +618,71 @@ ncEffectSpawn pid cProc ref = do

587618

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

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

590−ncEffectRegister :: String -> Maybe ProcessId -> NC ()

591−ncEffectRegister label mPid =

592− modify' $ registryFor label ^= mPid

593− -- An acknowledgement is not necessary. If we want a synchronous register,

594− -- it suffices to send a whereis requiry immediately after the register

595− -- (that may not suffice if we do decide for unreliable messaging instead)

621+-- We send a response indicated if the operation is invalid

622+ncEffectRegister :: ProcessId -> String -> NodeId -> Maybe ProcessId -> Bool -> NC ()

623+ncEffectRegister from label atnode mPid reregistration = do

624+ node <- ask

625+ currentVal <- gets (^. registeredHereFor label)

626+ isOk <-

627+ case mPid of

628+ Nothing -> -- unregister request

629+ return $ isJust currentVal

630+ Just thepid -> -- register request

631+ do isvalidlocal <- isValidLocalIdentifier (ProcessIdentifier thepid)

632+ return $ (isNothing currentVal /= reregistration) &&

633+ (not (isLocal node (ProcessIdentifier thepid) ) || isvalidlocal )

634+ if isLocal node (NodeIdentifier atnode)

635+ then do when (isOk) $

636+ do modify' $ registeredHereFor label ^= mPid

637+ updateRemote node currentVal mPid

638+ liftIO $ sendMessage node

639+ (NodeIdentifier (localNodeId node))

640+ (ProcessIdentifier from)

641+ WithImplicitReconnect

642+ (RegisterReply label isOk)

643+ else let operation =

644+ case reregistration of

645+ True -> flip decList

646+ False -> flip incList

647+ in case mPid of

648+ Nothing -> return ()

649+ Just pid -> modify' $ registeredOnNodesFor pid ^: (maybeify $ operation atnode)

650+ where updateRemote node (Just oldval) (Just newval) | processNodeId oldval /= processNodeId newval =

651+ do forward node (processNodeId oldval) (Register label atnode (Just oldval) True)

652+ forward node (processNodeId newval) (Register label atnode (Just newval) False)

653+ updateRemote node Nothing (Just newval) =

654+ forward node (processNodeId newval) (Register label atnode (Just newval) False)

655+ updateRemote node (Just oldval) Nothing =

656+ forward node (processNodeId oldval) (Register label atnode (Just oldval) True)

657+ updateRemote _ _ _ = return ()

658+ maybeify f Nothing = unmaybeify $ f []

659+ maybeify f (Just x) = unmaybeify $ f x

660+ unmaybeify [] = Nothing

661+ unmaybeify x = Just x

662+ incList [] tag = [(tag,1)]

663+ incList ((atag,acount):xs) tag | tag==atag = (atag,acount+1) : xs

664+ incList (x:xs) tag = x : incList xs tag

665+ decList [] _ = []

666+ decList ((atag,1):xs) tag | atag == tag = xs

667+ decList ((atag,n):xs) tag | atag == tag = (atag,n-1):xs

668+ decList (x:xs) tag = x:decList xs tag

669+ forward node to reg =

670+ when (not $ isLocal node (NodeIdentifier to)) $

671+ liftIO $ sendBinary node

672+ (ProcessIdentifier from)

673+ (NodeIdentifier to)

674+ WithImplicitReconnect

675+ NCMsg

676+ { ctrlMsgSender = ProcessIdentifier from

677+ , ctrlMsgSignal = reg

678+ }

679+

596680

597681-- Unified semantics does not explicitly describe 'whereis'

598682ncEffectWhereIs :: ProcessId -> String -> NC ()

599683ncEffectWhereIs from label = do

600684 node <- ask

601− mPid <- gets (^. registryFor label)

685+ mPid <- gets (^. registeredHereFor label)

602686 liftIO $ sendMessage node

603687 (NodeIdentifier (localNodeId node))

604688 (ProcessIdentifier from)

@@ -608,9 +692,9 @@ ncEffectWhereIs from label = do

608692-- [Unified: Table 14]

609693ncEffectNamedSend :: Identifier -> String -> Message -> NC ()

610694ncEffectNamedSend from label msg = do

611− mPid <- gets (^. registryFor label)

695+ node <- ask

696+ mPid <- gets (^. registeredHereFor label)

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

613− node <- ask

614698 forM_ mPid $ \pid ->

615699 liftIO $ sendPayload node

616700 from

@@ -660,7 +744,7 @@ destNid (Unlink ident) = Just $ nodeOf ident

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

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

662746destNid (Spawn _ _) = Nothing

663−destNid (Register _ _) = Nothing

747+destNid (Register _ _ _ _) = Nothing

664748destNid (WhereIs _) = Nothing

665749destNid (NamedSend _ _) = Nothing

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

@@ -732,8 +816,11 @@ links = accessor _links (\ls st -> st { _links = ls })

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

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

734818

735−registry :: Accessor NCState (Map String ProcessId)

736−registry = accessor _registry (\ry st -> st { _registry = ry })

819+registeredHere :: Accessor NCState (Map String ProcessId)

820+registeredHere = accessor _registeredHere (\ry st -> st { _registeredHere = ry })

821+

822+registeredOnNodes :: Accessor NCState (Map ProcessId [(NodeId, Int)])

823+registeredOnNodes = accessor _registeredOnNodes (\ry st -> st { _registeredOnNodes = ry })

737824

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

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

@@ -741,8 +828,11 @@ linksFor ident = links >>> DAC.mapDefault Set.empty ident

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

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

743830

744−registryFor :: String -> Accessor NCState (Maybe ProcessId)

745−registryFor ident = registry >>> DAC.mapMaybe ident

831+registeredHereFor :: String -> Accessor NCState (Maybe ProcessId)

832+registeredHereFor ident = registeredHere >>> DAC.mapMaybe ident

833+

834+registeredOnNodesFor :: ProcessId -> Accessor NCState (Maybe [(NodeId,Int)])

835+registeredOnNodesFor ident = registeredOnNodes >>> DAC.mapMaybe ident

746836

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

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

distributed-process/tests/TestCH.hs+23−6

@@ -31,6 +31,7 @@ import Control.Distributed.Process

3131import Control.Distributed.Process.Internal.Types

3232 ( NodeId(nodeAddress)

3333 , LocalNode(localEndPoint)

34+ , RegisterReply(..)

3435 )

3536import Control.Distributed.Process.Node

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

@@ -594,7 +595,11 @@ testRemoteRegistry transport = do

594595

595596 runProcess node2 $ do

596597 let nid1 = localNodeId node1

597− registerRemote nid1 "ping" pingServer

598+ registerRemoteAsync nid1 "ping" pingServer

599+ receiveWait [

600+ matchIf (\(RegisterReply label' _) -> "ping" == label')

601+ (\(RegisterReply _ _) -> return ()) ]

602+

598603 Just pid <- whereisRemote nid1 "ping"

599604 True <- return $ pingServer == pid

600605 us <- getSelfPid

@@ -665,7 +670,13 @@ testReconnect transport transportInternals = do

665670 -}

666671

667672 us <- getSelfPid

668− registerRemote nid1 "a" us >> liftIO (threadDelay 100000) -- registerRemote is asynchronous

673+ registerRemoteAsync nid1 "a" us -- registerRemote is asynchronous

674+ receiveWait [

675+ matchIf (\(RegisterReply label' _) -> "a" == label')

676+ (\(RegisterReply _ _) -> return ()) ]

677+

678+ Just _ <- whereisRemote nid1 "a"

679+

669680

670681 -- Simulate network failure

671682 liftIO $ do

@@ -674,14 +685,20 @@ testReconnect transport transportInternals = do

674685 threadDelay 10000

675686

676687 -- This will happen due to implicit reconnect

677− registerRemote nid1 "b" us

688+ registerRemoteAsync nid1 "b" us

689+ receiveWait [

690+ matchIf (\(RegisterReply label' _) -> "b" == label')

691+ (\(RegisterReply _ _) -> return ()) ]

678692

679693 -- Should happen

680− registerRemote nid1 "c" us

694+ registerRemoteAsync nid1 "c" us

695+ receiveWait [

696+ matchIf (\(RegisterReply label' _) -> "c" == label')

697+ (\(RegisterReply _ _) -> return ()) ]

681698

682699 -- Check

683− Just _ <- whereisRemote nid1 "a"

684− Just _ <- whereisRemote nid1 "b"

700+ Nothing <- whereisRemote nid1 "a" -- this will fail because the name is removed when the node is disconnected

701+ Just _ <- whereisRemote nid1 "b" -- this will suceed because the value is set after thereconnect

685702 Just _ <- whereisRemote nid1 "c"

686703

687704 liftIO $ putMVar registerTestOk ()