414c270 · distributed-process

git.iko.soy/distributed-process

Add support for terminate

commit414c270973c785472c9fb561d07939db1dd99256 authorEdsko de Vries <edsko@edsko.net> dateFri 22 Jun 2012, 15:23 (14 years ago) parent9bbd523

3 files changed+28−1

compare with master

unifiedsplit

distributed-process/src/Control/Distributed/Process.hs+12 distributed-process/src/Control/Distributed/Process/Internal/Types.hs+1−1 distributed-process/tests/TestCH.hs+15

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

@@ -33,6 +33,8 @@ module Control.Distributed.Process

3333 -- * Process management

3434 , spawn

3535 , call

36+ , terminate

37+ , ProcessTerminationException

3638 , SpawnRef

3739 , getSelfPid

3840 , getSelfNode

@@ -302,6 +304,7 @@ spawn nid proc = do

302304 (\(DidSpawn _ pid) -> return pid)

303305 ]

304306

307+-- | Run a process remotely and wait for it to reply

305308call :: Serializable a => NodeId -> Closure (Process a) -> Process a

306309call nid proc@(Closure (Static label) _) = do

307310 us <- getSelfPid

@@ -309,6 +312,15 @@ call nid proc@(Closure (Static label) _) = do

309312 CallReply a <- expect

310313 return a

311314

315+data ProcessTerminationException = ProcessTerminationException

316+ deriving (Show, Typeable)

317+

318+instance Exception ProcessTerminationException

319+

320+-- | Terminate (throws a ProcessTerminationException)

321+terminate :: Process a

322+terminate = liftIO $ throw ProcessTerminationException

323+

312324-- | Our own process ID

313325getSelfPid :: Process ProcessId

314326getSelfPid = processId <$> ask

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

@@ -256,7 +256,7 @@ data MonitorRef = MonitorRef

256256

257257-- | Messages sent by monitors

258258data MonitorNotification = MonitorNotification MonitorRef ProcessId DiedReason

259− deriving (Typeable)

259+ deriving (Typeable, Show)

260260

261261-- | Exceptions thrown when a linked process dies

262262data LinkException = LinkException ProcessId DiedReason

distributed-process/tests/TestCH.hs+15

@@ -483,6 +483,20 @@ testMergeChannels transport = do

483483 liftIO $ threadDelay 10000 -- Make sure messages have been sent

484484 return rport

485485

486+testTerminate :: NT.Transport -> IO ()

487+testTerminate transport = do

488+ localNode <- newLocalNode transport initRemoteTable

489+

490+ pid <- forkProcess localNode $ do

491+ liftIO $ threadDelay 100000

492+ terminate

493+

494+ runProcess localNode $ do

495+ ref <- monitor pid

496+ MonitorNotification ref' pid' (DiedException ex) <- expect

497+ True <- return $ ref == ref' && pid == pid' && ex == "ProcessTerminationException"

498+ return ()

499+

486500main :: IO ()

487501main = do

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

@@ -494,6 +508,7 @@ main = do

494508 , ("SendToTerminated", testSendToTerminated transport)

495509 , ("TypedChannnels", testTypedChannels transport)

496510 , ("MergeChannels", testMergeChannels transport)

511+ , ("TestTerminate", testTerminate transport)

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

498513 -- we cannot guarantee that the monitor reply or link exception will not

499514 -- happen before the unmonitor or unlink