Improve exception handling in callLocal.

callLocal had the following flaws:

1. It could leak the worker process if the parent process was
   interrupted but not killed.
   Linking the worker to the parent wouldn't help.

2. If the parent was interrupted, `callLocal` would return the
   control before the worker is terminated. This would make
   slightly harder to synchronize with whatever task the
   worker is doing.

This patch fixes both issues.

Author: qnikst

src/Control/Distributed/Process.hs

@@ -163,7 +163,12 @@ import Prelude hiding (catch)
 import Control.Monad.IO.Class (liftIO)
 import Control.Applicative ((<$>))
 import Control.Monad.Reader (ask)
-import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
+import Control.Concurrent.MVar
+  ( MVar
+  , newEmptyMVar
+  , takeMVar
+  , putMVar
+  )
 import Control.Distributed.Static
   ( Closure
   , closure
@@ -404,12 +409,22 @@ spawnChannelLocal proc = do
 callLocal ::
      Process a  -- ^ Process to run
   -> Process a  -- ^ Value returned
-callLocal proc = do
-  mv <- liftIO newEmptyMVar
-  self <- getSelfPid
-  _ <- spawnLocal $ do
-     link self
-     try proc >>= liftIO . putMVar mv
-  liftIO $ takeMVar mv >>=
-     either (throwIO :: SomeException -> IO a) return
-
+callLocal proc = mask $ \release -> do
+  mv    <- liftIO newEmptyMVar :: Process (MVar (Either SomeException a))
+  child <- spawnLocal $ do
+             ep <- try $ release $ proc
+             liftIO $ putMVar mv ep
+  liftIO (fetchResult mv) `onException`
+    (do exit child "exception in parent process"
+        waitForExit child)
+  where
+    waitForExit child = do
+      bracket (monitor child)
+              (unmonitor)
+              (\mRef -> receiveWait
+                   [ matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef)
+                             (\_ -> return ())
+                   ])
+    fetchResult mv = do
+        rs <- takeMVar mv
+        either throwIO return rs