Improve exception handling in callLocal.

callLocal had few flaws,

1. it could leak worker process in parent process received an
   exception but handles it. Then process was not killed, so
   linking worker to parent didn't help

2. A parent process could exit `callLocal` while child process
   is still alive.

This this patch both things are solved alltogether.

Author: qnikst

src/Control/Distributed/Process.hs

@@ -162,7 +162,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
@@ -402,12 +407,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_ $ do
+  mv    <- liftIO newEmptyMVar :: Process (MVar (Either SomeException a))
+  child <- spawnLocal $ mask $ \release -> 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
+        liftIO $ either throwIO return rs