414c270 · distributed-process

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

compare with master

unifiedsplit

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

33 -- * Process management

34 , spawn

35 , call

36+ , terminate

37+ , ProcessTerminationException

36 , SpawnRef

38 , SpawnRef

37 , getSelfPid

39 , getSelfPid

38 , getSelfNode

40 , getSelfNode

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

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

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

303 ]

305 ]

304

306

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

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

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

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

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

307 us <- getSelfPid

310 us <- getSelfPid

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

309 CallReply a <- expect

312 CallReply a <- expect

310 return a

313 return a

311

314

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+

312-- | Our own process ID

324-- | Our own process ID

313getSelfPid :: Process ProcessId

325getSelfPid :: Process ProcessId

314getSelfPid = processId <$> ask

326getSelfPid = processId <$> ask

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

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

256

257-- | Messages sent by monitors

258data MonitorNotification = MonitorNotification MonitorRef ProcessId DiedReason

259− deriving (Typeable)

259+ deriving (Typeable, Show)

260

261-- | Exceptions thrown when a linked process dies

262data LinkException = LinkException ProcessId DiedReason

distributed-process/tests/TestCH.hs+15

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

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

484 return rport

485

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+

486main :: IO ()

500main :: IO ()

487main = do

501main = do

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

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

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

494 , ("SendToTerminated", testSendToTerminated transport)

508 , ("SendToTerminated", testSendToTerminated transport)

495 , ("TypedChannnels", testTypedChannels transport)

509 , ("TypedChannnels", testTypedChannels transport)

496 , ("MergeChannels", testMergeChannels transport)

510 , ("MergeChannels", testMergeChannels transport)

511+ , ("TestTerminate", testTerminate transport)

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

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

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

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

499 -- happen before the unmonitor or unlink

514 -- happen before the unmonitor or unlink