e3d388c · distributed-process

git.iko.soy/distributed-process

Fix ordering problem with kill/exit. Fix tests.

See inline comment in definition of kill/exit for details.

commite3d388c3e9d7ba09526b7085e3e2ed1386477763 authorEdsko de Vries <edsko@well-typed.com> dateMon 3 Dec 2012, 19:32 (14 years ago) parent2074a01

3 files changed+85−47

compare with master

unifiedsplit

distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs+11−18 distributed-process/src/Control/Distributed/Process/Node.hs+8−4 distributed-process/tests/TestCH.hs+66−25

distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs+11−18

@@ -333,15 +333,13 @@ instance Exception ProcessTerminationException

333333terminate :: Process a

334334terminate = liftIO $ throwIO ProcessTerminationException

335335

336−

337336-- | Forceful request to kill a process

338337kill :: ProcessId -> String -> Process ()

339−kill them reason = do

340− mynid <- getSelfNode

341− let nid = processNodeId them

342− if mynid == nid

343− then sendCtrlMsg Nothing (Kill them reason)

344− else sendCtrlMsg (Just nid) (Kill them reason)

338+-- NOTE: We send the message to our local node controller, which will then

339+-- forward it to a remote node controller (if applicable). Sending it directly

340+-- to a remote node controller means that that the message may overtake a

341+-- 'monitor' or 'link' request.

342+kill them reason = sendCtrlMsg Nothing (Kill them reason)

345343

346344-- | Thrown by 'kill'

347345data ProcessKillException =

@@ -350,20 +348,15 @@ data ProcessKillException =

350348

351349instance Exception ProcessKillException

352350instance Show ProcessKillException where

353− show (ProcessKillException pid reason) = "Kill by " ++ show pid ++ " : " ++ reason

354−

351+ show (ProcessKillException pid reason) = "Kill by " ++ show pid ++ ": " ++ reason

355352

356353-- | Graceful request to exit a process

357354exit :: Serializable a => ProcessId -> a -> Process ()

358−exit them reason = do

359− mynid <- getSelfNode

360− if mynid == nid

361− then sendCtrlMsg Nothing msg

362− else sendCtrlMsg (Just nid) msg

363− where

364− nid = processNodeId them

365− msg = Exit them (createMessage reason)

366−

355+-- NOTE: We send the message to our local node controller, which will then

356+-- forward it to a remote node controller (if applicable). Sending it directly

357+-- to a remote node controller means that that the message may overtake a

358+-- 'monitor' or 'link' request.

359+exit them reason = sendCtrlMsg Nothing (Exit them (createMessage reason))

367360

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

369362data ProcessExitException =

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

@@ -725,13 +725,17 @@ ncEffectNamedSend from label msg = do

725725

726726-- [Issue #69]

727727ncEffectKill :: ProcessId -> ProcessId -> String -> NC ()

728−ncEffectKill from to reason =

729− throwException to $ ProcessKillException from reason

728+ncEffectKill from to reason = do

729+ node <- ask

730+ when (isLocal node (ProcessIdentifier to)) $

731+ throwException to $ ProcessKillException from reason

730732

731733-- [Issue #69]

732734ncEffectExit :: ProcessId -> ProcessId -> Message -> NC ()

733−ncEffectExit from to reason =

734− throwException to $ ProcessExitException from reason

735+ncEffectExit from to reason = do

736+ node <- ask

737+ when (isLocal node (ProcessIdentifier to)) $

738+ throwException to $ ProcessExitException from reason

735739

736740--------------------------------------------------------------------------------

737741-- Auxiliary --

distributed-process/tests/TestCH.hs+66−25

@@ -365,9 +365,13 @@ testSendToTerminated transport = do

365365testTimeout :: NT.Transport -> Assertion

366366testTimeout transport = do

367367 localNode <- newLocalNode transport initRemoteTable

368+ done <- newEmptyMVar

369+

368370 runProcess localNode $ do

369371 Nothing <- receiveTimeout 1000000 [match (\(Add _ _ _) -> return ())]

370− return ()

372+ liftIO $ putMVar done ()

373+

374+ takeMVar done

371375

372376-- | Test zero timeout

373377testTimeout0 :: NT.Transport -> Assertion

@@ -526,6 +530,7 @@ testMergeChannels transport = do

526530testTerminate :: NT.Transport -> Assertion

527531testTerminate transport = do

528532 localNode <- newLocalNode transport initRemoteTable

533+ done <- newEmptyMVar

529534

530535 pid <- forkProcess localNode $ do

531536 liftIO $ threadDelay 100000

@@ -535,11 +540,14 @@ testTerminate transport = do

535540 ref <- monitor pid

536541 ProcessMonitorNotification ref' pid' (DiedException ex) <- expect

537542 True <- return $ ref == ref' && pid == pid' && ex == show ProcessTerminationException

538− return ()

543+ liftIO $ putMVar done ()

544+

545+ takeMVar done

539546

540547testMonitorNode :: NT.Transport -> Assertion

541548testMonitorNode transport = do

542549 [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable

550+ done <- newEmptyMVar

543551

544552 closeLocalNode node1

545553

@@ -547,7 +555,9 @@ testMonitorNode transport = do

547555 ref <- monitorNode (localNodeId node1)

548556 NodeMonitorNotification ref' nid DiedDisconnect <- expect

549557 True <- return $ ref == ref' && nid == localNodeId node1

550− return ()

558+ liftIO $ putMVar done ()

559+

560+ takeMVar done

551561

552562testMonitorChannel :: NT.Transport -> Assertion

553563testMonitorChannel transport = do

@@ -573,6 +583,7 @@ testMonitorChannel transport = do

573583testRegistry :: NT.Transport -> Assertion

574584testRegistry transport = do

575585 node <- newLocalNode transport initRemoteTable

586+ done <- newEmptyMVar

576587

577588 pingServer <- forkProcess node ping

578589

@@ -584,12 +595,15 @@ testRegistry transport = do

584595 nsend "ping" (Pong us)

585596 Ping pid' <- expect

586597 True <- return $ pingServer == pid'

587− return ()

598+ liftIO $ putMVar done ()

599+

600+ takeMVar done

588601

589602testRemoteRegistry :: NT.Transport -> Assertion

590603testRemoteRegistry transport = do

591604 node1 <- newLocalNode transport initRemoteTable

592605 node2 <- newLocalNode transport initRemoteTable

606+ done <- newEmptyMVar

593607

594608 pingServer <- forkProcess node1 ping

595609

@@ -606,11 +620,14 @@ testRemoteRegistry transport = do

606620 nsendRemote nid1 "ping" (Pong us)

607621 Ping pid' <- expect

608622 True <- return $ pingServer == pid'

609− return ()

623+ liftIO $ putMVar done ()

624+

625+ takeMVar done

610626

611627testSpawnLocal :: NT.Transport -> Assertion

612628testSpawnLocal transport = do

613629 node <- newLocalNode transport initRemoteTable

630+ done <- newEmptyMVar

614631

615632 runProcess node $ do

616633 us <- getSelfPid

@@ -624,7 +641,10 @@ testSpawnLocal transport = do

624641 send us ()

625642

626643 send pid sport

627− expect

644+ () <- expect

645+ liftIO $ putMVar done ()

646+

647+ takeMVar done

628648

629649testReconnect :: NT.Transport -> TransportInternals -> Assertion

630650testReconnect transport transportInternals = do

@@ -841,66 +861,87 @@ testReceiveChanFeatures transport = do

841861testKillLocal :: NT.Transport -> Assertion

842862testKillLocal transport = do

843863 localNode <- newLocalNode transport initRemoteTable

864+ done <- newEmptyMVar

844865

845866 pid <- forkProcess localNode $ do

846− liftIO $ threadDelay 100000

867+ liftIO $ threadDelay 1000000

847868

848869 runProcess localNode $ do

849870 ref <- monitor pid

871+ us <- getSelfPid

850872 kill pid "TestKill"

851873 ProcessMonitorNotification ref' pid' (DiedException ex) <- expect

852− True <- return $ ref == ref' && pid == pid' && ex == "TestKill"

853− return ()

874+ True <- return $ ref == ref' && pid == pid' && ex == "Kill by " ++ show us ++ ": TestKill"

875+ liftIO $ putMVar done ()

876+

877+ takeMVar done

854878

855879testKillRemote :: NT.Transport -> Assertion

856880testKillRemote transport = do

857881 node1 <- newLocalNode transport initRemoteTable

858882 node2 <- newLocalNode transport initRemoteTable

883+ done <- newEmptyMVar

859884

860885 pid <- forkProcess node1 $ do

861− liftIO $ threadDelay 100000

886+ liftIO $ threadDelay 1000000

862887

863888 runProcess node2 $ do

864889 ref <- monitor pid

890+ us <- getSelfPid

865891 kill pid "TestKill"

866− ProcessMonitorNotification ref' pid' (DiedException ex) <- expect

867− True <- return $ ref == ref' && pid == pid' && ex == "TestKill"

868− return ()

892+ ProcessMonitorNotification ref' pid' (DiedException reason) <- expect

893+ True <- return $ ref == ref' && pid == pid' && reason == "Kill by " ++ show us ++ ": TestKill"

894+ liftIO $ putMVar done ()

895+

896+ takeMVar done

869897

870898testExitLocal :: NT.Transport -> Assertion

871899testExitLocal transport = do

872900 localNode <- newLocalNode transport initRemoteTable

901+ supervisedDone <- newEmptyMVar

902+ supervisorDone <- newEmptyMVar

873903

874904 pid <- forkProcess localNode $ do

875905 (liftIO $ threadDelay 100000)

876− `catchExit` \from reason -> do

877− say $ "Got " ++ reason ++ " from " ++ show from

878− return ()

906+ `catchExit` \_from reason -> do

907+ -- TODO: should verify that 'from' has the right value

908+ True <- return $ reason == "TestExit"

909+ liftIO $ putMVar supervisedDone ()

879910

880911 runProcess localNode $ do

881912 ref <- monitor pid

882913 exit pid "TestExit"

883− ProcessMonitorNotification ref' pid' (DiedException ex) <- expect

884− True <- return $ ref == ref' && pid == pid' && ex == "TestExit"

885− return ()

914+ -- This time the client catches the exception, so it dies normally

915+ ProcessMonitorNotification ref' pid' DiedNormal <- expect

916+ True <- return $ ref == ref' && pid == pid'

917+ liftIO $ putMVar supervisorDone ()

918+

919+ takeMVar supervisedDone

920+ takeMVar supervisorDone

886921

887922testExitRemote :: NT.Transport -> Assertion

888923testExitRemote transport = do

889924 node1 <- newLocalNode transport initRemoteTable

890925 node2 <- newLocalNode transport initRemoteTable

926+ supervisedDone <- newEmptyMVar

927+ supervisorDone <- newEmptyMVar

891928

892929 pid <- forkProcess node1 $ do

893930 (liftIO $ threadDelay 100000)

894− `catchExit` \from reason -> do

895− say $ "Got " ++ reason ++ " from " ++ show from

896− return ()

931+ `catchExit` \_from reason -> do

932+ -- TODO: should verify that 'from' has the right value

933+ True <- return $ reason == "TestExit"

934+ liftIO $ putMVar supervisedDone ()

897935

898936 runProcess node2 $ do

899937 ref <- monitor pid

900938 exit pid "TestExit"

901− ProcessMonitorNotification ref' pid' (DiedException ex) <- expect

902− True <- return $ ref == ref' && pid == pid' && ex == "TestExit"

903− return ()

939+ ProcessMonitorNotification ref' pid' DiedNormal <- expect

940+ True <- return $ ref == ref' && pid == pid'

941+ liftIO $ putMVar supervisorDone ()

942+

943+ takeMVar supervisedDone

944+ takeMVar supervisorDone

904945

905946tests :: (NT.Transport, TransportInternals) -> [Test]

906947tests (transport, transportInternals) = [