6f77480 · distributed-process

git.iko.soy/distributed-process

on master help sign in

Fix exception handling in callLocal.

6f77480Facundo Domínguez11 years ago

src/Control/Distributed/Process.hs+27−4

compare with master

unifiedsplit

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

163import Control.Monad.IO.Class (liftIO)

164import Control.Applicative

165import Control.Monad.Reader (ask)

166+import Control.Concurrent (killThread)

166import Control.Concurrent.MVar

167import Control.Concurrent.MVar

167 ( MVar

168 ( MVar

168 , newEmptyMVar

169 , newEmptyMVar

@@ -197,6 +198,7 @@ import Control.Distributed.Process.Internal.Types

197 , RegisterReply(..)

198 , RegisterReply(..)

198 , LocalProcess(processNode)

199 , LocalProcess(processNode)

199 , Message

200 , Message

201+ , localProcessWithId

200 )

202 )

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

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

202import Control.Distributed.Process.Internal.Primitives

204import Control.Distributed.Process.Internal.Primitives

@@ -305,6 +307,10 @@ import Control.Distributed.Process.Internal.Primitives

305 , reconnectPort

307 , reconnectPort

306 )

308 )

307import Control.Distributed.Process.Node (forkProcess)

309import Control.Distributed.Process.Node (forkProcess)

310+import Control.Distributed.Process.Internal.Types

311+ ( processThread

312+ , withValidLocalState

313+ )

308import Control.Distributed.Process.Internal.Spawn

314import Control.Distributed.Process.Internal.Spawn

309 ( -- Spawning Processes/Channels

315 ( -- Spawning Processes/Channels

310 spawn

316 spawn

@@ -321,6 +327,11 @@ import Prelude

321#else

327#else

322import Prelude hiding (catch)

328import Prelude hiding (catch)

323#endif

329#endif

330+import Control.Distributed.Process.Internal.StrictMVar (readMVar)

331+import qualified Control.Exception as Exception (onException)

332+import Data.Accessor ((^.))

333+import Data.Foldable (forM_)

334+

324

335

325-- INTERNAL NOTES

336-- INTERNAL NOTES

326--

337--

@@ -418,8 +429,20 @@ spawnChannelLocal proc = do

418-- Silently dropping messages may not always be the best approach.

429-- Silently dropping messages may not always be the best approach.

419callLocal :: Process a -> Process a

430callLocal :: Process a -> Process a

420callLocal proc = Catch.mask $ \release -> do

431callLocal proc = Catch.mask $ \release -> do

421− mv <- liftIO newEmptyMVar :: Process (MVar (Either Catch.SomeException a))

432+ mv <- liftIO newEmptyMVar :: Process (MVar (Either Catch.SomeException a))

422 child <- spawnLocal $ Catch.try (release proc) >>= liftIO . putMVar mv

433 child <- spawnLocal $ Catch.try (release proc) >>= liftIO . putMVar mv

423− rs <- liftIO (takeMVar mv) `Catch.onException`

434+ lproc <- ask

424− (kill child "exception in parent process" >> liftIO (takeMVar mv))

435+ liftIO $ do

436+ rs <- Exception.onException (takeMVar mv) $ Catch.uninterruptibleMask_ $

437+ -- Exceptions need to be prevented from interrupting the clean up or

438+ -- the original exception which caused entering the handler could be

439+ -- forgotten. For instance, this could have a problematic effect

440+ -- when the original exception was meant to kill the thread and the

441+ -- second exception doesn't (like the exception thrown by

442+ -- 'System.Timeout.timeout').

443+ do mchildThreadId <- withValidLocalState (processNode lproc) $

444+ \vst -> return $ fmap processThread $

445+ vst ^. localProcessWithId (processLocalId child)

446+ forM_ mchildThreadId killThread

447+ takeMVar mv

425− either Catch.throwM return rs

448+ either Catch.throwM return rs