e3d388c · distributed-process

git.iko.soy/distributed-process

on master help sign in

Fix ordering problem with kill/exit. Fix tests.

e3d388cEdsko de Vries14 years ago

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

compare with master

unifiedsplit

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

333terminate :: Process a

334terminate = liftIO $ throwIO ProcessTerminationException

335

336−

337-- | Forceful request to kill a process

336-- | Forceful request to kill a process

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

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

339−kill them reason = do

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

340− mynid <- getSelfNode

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

341− let nid = processNodeId them

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

342− if mynid == nid

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

343− then sendCtrlMsg Nothing (Kill them reason)

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

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

345

343

346-- | Thrown by 'kill'

344-- | Thrown by 'kill'

347data ProcessKillException =

345data ProcessKillException =

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

350

348

351instance Exception ProcessKillException

349instance Exception ProcessKillException

352instance Show ProcessKillException where

350instance Show ProcessKillException where

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

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

354−

355

352

356-- | Graceful request to exit a process

353-- | Graceful request to exit a process

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

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

358−exit them reason = do

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

359− mynid <- getSelfNode

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

360− if mynid == nid

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

361− then sendCtrlMsg Nothing msg

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

362− else sendCtrlMsg (Just nid) msg

363− where

364− nid = processNodeId them

365− msg = Exit them (createMessage reason)

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

366−

367

360

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

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

369data ProcessExitException =

362data ProcessExitException =

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

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

725

726-- [Issue #69]

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

728−ncEffectKill from to reason =

728+ncEffectKill from to reason = do

729+ node <- ask

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

729− throwException to $ ProcessKillException from reason

731+ throwException to $ ProcessKillException from reason

730

732

731-- [Issue #69]

733-- [Issue #69]

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

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

733−ncEffectExit from to reason =

735+ncEffectExit from to reason = do

736+ node <- ask

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

734− throwException to $ ProcessExitException from reason

738+ throwException to $ ProcessExitException from reason

735

739

736--------------------------------------------------------------------------------

740--------------------------------------------------------------------------------

737-- Auxiliary --

741-- Auxiliary --

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

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

365testTimeout :: NT.Transport -> Assertion

366testTimeout transport = do

367 localNode <- newLocalNode transport initRemoteTable

368+ done <- newEmptyMVar

369+

368 runProcess localNode $ do

370 runProcess localNode $ do

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

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

370− return ()

372+ liftIO $ putMVar done ()

373+

374+ takeMVar done

371

375

372-- | Test zero timeout

376-- | Test zero timeout

373testTimeout0 :: NT.Transport -> Assertion

377testTimeout0 :: NT.Transport -> Assertion

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

526testTerminate :: NT.Transport -> Assertion

530testTerminate :: NT.Transport -> Assertion

527testTerminate transport = do

531testTerminate transport = do

528 localNode <- newLocalNode transport initRemoteTable

532 localNode <- newLocalNode transport initRemoteTable

533+ done <- newEmptyMVar

529

534

530 pid <- forkProcess localNode $ do

535 pid <- forkProcess localNode $ do

531 liftIO $ threadDelay 100000

536 liftIO $ threadDelay 100000

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

535 ref <- monitor pid

540 ref <- monitor pid

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

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

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

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

538− return ()

543+ liftIO $ putMVar done ()

544+

545+ takeMVar done

539

546

540testMonitorNode :: NT.Transport -> Assertion

547testMonitorNode :: NT.Transport -> Assertion

541testMonitorNode transport = do

548testMonitorNode transport = do

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

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

550+ done <- newEmptyMVar

543

551

544 closeLocalNode node1

552 closeLocalNode node1

545

553

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

547 ref <- monitorNode (localNodeId node1)

555 ref <- monitorNode (localNodeId node1)

548 NodeMonitorNotification ref' nid DiedDisconnect <- expect

556 NodeMonitorNotification ref' nid DiedDisconnect <- expect

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

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

550− return ()

558+ liftIO $ putMVar done ()

559+

560+ takeMVar done

551

561

552testMonitorChannel :: NT.Transport -> Assertion

562testMonitorChannel :: NT.Transport -> Assertion

553testMonitorChannel transport = do

563testMonitorChannel transport = do

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

573testRegistry :: NT.Transport -> Assertion

583testRegistry :: NT.Transport -> Assertion

574testRegistry transport = do

584testRegistry transport = do

575 node <- newLocalNode transport initRemoteTable

585 node <- newLocalNode transport initRemoteTable

586+ done <- newEmptyMVar

576

587

577 pingServer <- forkProcess node ping

588 pingServer <- forkProcess node ping

578

589

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

584 nsend "ping" (Pong us)

595 nsend "ping" (Pong us)

585 Ping pid' <- expect

596 Ping pid' <- expect

586 True <- return $ pingServer == pid'

597 True <- return $ pingServer == pid'

587− return ()

598+ liftIO $ putMVar done ()

599+

600+ takeMVar done

588

601

589testRemoteRegistry :: NT.Transport -> Assertion

602testRemoteRegistry :: NT.Transport -> Assertion

590testRemoteRegistry transport = do

603testRemoteRegistry transport = do

591 node1 <- newLocalNode transport initRemoteTable

604 node1 <- newLocalNode transport initRemoteTable

592 node2 <- newLocalNode transport initRemoteTable

605 node2 <- newLocalNode transport initRemoteTable

606+ done <- newEmptyMVar

593

607

594 pingServer <- forkProcess node1 ping

608 pingServer <- forkProcess node1 ping

595

609

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

606 nsendRemote nid1 "ping" (Pong us)

620 nsendRemote nid1 "ping" (Pong us)

607 Ping pid' <- expect

621 Ping pid' <- expect

608 True <- return $ pingServer == pid'

622 True <- return $ pingServer == pid'

609− return ()

623+ liftIO $ putMVar done ()

624+

625+ takeMVar done

610

626

611testSpawnLocal :: NT.Transport -> Assertion

627testSpawnLocal :: NT.Transport -> Assertion

612testSpawnLocal transport = do

628testSpawnLocal transport = do

613 node <- newLocalNode transport initRemoteTable

629 node <- newLocalNode transport initRemoteTable

630+ done <- newEmptyMVar

614

631

615 runProcess node $ do

632 runProcess node $ do

616 us <- getSelfPid

633 us <- getSelfPid

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

624 send us ()

641 send us ()

625

642

626 send pid sport

643 send pid sport

627− expect

644+ () <- expect

645+ liftIO $ putMVar done ()

646+

647+ takeMVar done

628

648

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

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

630testReconnect transport transportInternals = do

650testReconnect transport transportInternals = do

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

841testKillLocal :: NT.Transport -> Assertion

861testKillLocal :: NT.Transport -> Assertion

842testKillLocal transport = do

862testKillLocal transport = do

843 localNode <- newLocalNode transport initRemoteTable

863 localNode <- newLocalNode transport initRemoteTable

864+ done <- newEmptyMVar

844

865

845 pid <- forkProcess localNode $ do

866 pid <- forkProcess localNode $ do

846− liftIO $ threadDelay 100000

867+ liftIO $ threadDelay 1000000

847

868

848 runProcess localNode $ do

869 runProcess localNode $ do

849 ref <- monitor pid

870 ref <- monitor pid

871+ us <- getSelfPid

850 kill pid "TestKill"

872 kill pid "TestKill"

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

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

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

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

853− return ()

875+ liftIO $ putMVar done ()

876+

877+ takeMVar done

854

878

855testKillRemote :: NT.Transport -> Assertion

879testKillRemote :: NT.Transport -> Assertion

856testKillRemote transport = do

880testKillRemote transport = do

857 node1 <- newLocalNode transport initRemoteTable

881 node1 <- newLocalNode transport initRemoteTable

858 node2 <- newLocalNode transport initRemoteTable

882 node2 <- newLocalNode transport initRemoteTable

883+ done <- newEmptyMVar

859

884

860 pid <- forkProcess node1 $ do

885 pid <- forkProcess node1 $ do

861− liftIO $ threadDelay 100000

886+ liftIO $ threadDelay 1000000

862

887

863 runProcess node2 $ do

888 runProcess node2 $ do

864 ref <- monitor pid

889 ref <- monitor pid

890+ us <- getSelfPid

865 kill pid "TestKill"

891 kill pid "TestKill"

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

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

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

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

868− return ()

894+ liftIO $ putMVar done ()

895+

896+ takeMVar done

869

897

870testExitLocal :: NT.Transport -> Assertion

898testExitLocal :: NT.Transport -> Assertion

871testExitLocal transport = do

899testExitLocal transport = do

872 localNode <- newLocalNode transport initRemoteTable

900 localNode <- newLocalNode transport initRemoteTable

901+ supervisedDone <- newEmptyMVar

902+ supervisorDone <- newEmptyMVar

873

903

874 pid <- forkProcess localNode $ do

904 pid <- forkProcess localNode $ do

875 (liftIO $ threadDelay 100000)

905 (liftIO $ threadDelay 100000)

876− `catchExit` \from reason -> do

906+ `catchExit` \_from reason -> do

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

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

878− return ()

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

909+ liftIO $ putMVar supervisedDone ()

879

910

880 runProcess localNode $ do

911 runProcess localNode $ do

881 ref <- monitor pid

912 ref <- monitor pid

882 exit pid "TestExit"

913 exit pid "TestExit"

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

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

915+ ProcessMonitorNotification ref' pid' DiedNormal <- expect

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

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

885− return ()

917+ liftIO $ putMVar supervisorDone ()

918+

919+ takeMVar supervisedDone

920+ takeMVar supervisorDone

886

921

887testExitRemote :: NT.Transport -> Assertion

922testExitRemote :: NT.Transport -> Assertion

888testExitRemote transport = do

923testExitRemote transport = do

889 node1 <- newLocalNode transport initRemoteTable

924 node1 <- newLocalNode transport initRemoteTable

890 node2 <- newLocalNode transport initRemoteTable

925 node2 <- newLocalNode transport initRemoteTable

926+ supervisedDone <- newEmptyMVar

927+ supervisorDone <- newEmptyMVar

891

928

892 pid <- forkProcess node1 $ do

929 pid <- forkProcess node1 $ do

893 (liftIO $ threadDelay 100000)

930 (liftIO $ threadDelay 100000)

894− `catchExit` \from reason -> do

931+ `catchExit` \_from reason -> do

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

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

896− return ()

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

934+ liftIO $ putMVar supervisedDone ()

897

935

898 runProcess node2 $ do

936 runProcess node2 $ do

899 ref <- monitor pid

937 ref <- monitor pid

900 exit pid "TestExit"

938 exit pid "TestExit"

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

939+ ProcessMonitorNotification ref' pid' DiedNormal <- expect

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

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

903− return ()

941+ liftIO $ putMVar supervisorDone ()

942+

943+ takeMVar supervisedDone

944+ takeMVar supervisorDone

904

945

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

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

906tests (transport, transportInternals) = [

947tests (transport, transportInternals) = [