30123fc · distributed-process

git.iko.soy/distributed-process

on master help sign in

Fix exception handling in callLocal.

30123fcFacundo Domínguez11 years ago

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

compare with master

unifiedsplit

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

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

163import Control.Applicative

164import Control.Monad.Reader (ask)

165+import Control.Concurrent (killThread)

165import Control.Concurrent.MVar

166import Control.Concurrent.MVar

166 ( MVar

167 ( MVar

167 , newEmptyMVar

168 , newEmptyMVar

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

196 , RegisterReply(..)

197 , RegisterReply(..)

197 , LocalProcess(processNode)

198 , LocalProcess(processNode)

198 , Message

199 , Message

200+ , localProcessWithId

199 )

201 )

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

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

201import Control.Distributed.Process.Internal.Primitives

203import Control.Distributed.Process.Internal.Primitives

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

303 , reconnectPort

305 , reconnectPort

304 )

306 )

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

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

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

309+ ( processThread

310+ , withValidLocalState

311+ )

306import Control.Distributed.Process.Internal.Spawn

312import Control.Distributed.Process.Internal.Spawn

307 ( -- Spawning Processes/Channels

313 ( -- Spawning Processes/Channels

308 spawn

314 spawn

@@ -319,6 +325,11 @@ import Prelude

319#else

325#else

320import Prelude hiding (catch)

326import Prelude hiding (catch)

321#endif

327#endif

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

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

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

331+import Data.Foldable (forM_)

332+

322

333

323-- INTERNAL NOTES

334-- INTERNAL NOTES

324--

335--

@@ -416,8 +427,20 @@ spawnChannelLocal proc = do

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

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

417callLocal :: Process a -> Process a

428callLocal :: Process a -> Process a

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

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

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

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

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

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

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

432+ lproc <- ask

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

433+ liftIO $ do

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

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

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

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

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

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

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

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

442+ \vst -> return $ fmap processThread $

443+ vst ^. localProcessWithId (processLocalId child)

444+ forM_ mchildThreadId killThread

445+ takeMVar mv

423− either Catch.throwM return rs

446+ either Catch.throwM return rs