Fix race in runProcess when it fails.

facundominguez · facundominguez · commit deadc44f6dff · 2015-10-26T00:56:13.000-03:00
runProcess would yield control back to the caller and then it would
try to kill it. This could cause some strange behavior in tests when
they fail.

Moreover, the former solution assumed exceptions were not masked
uninterruptibly. This patch has runProcess work even in such cases.
diff --git a/src/Control/Distributed/Process/Node.hs b/src/Control/Distributed/Process/Node.hs
@@ -205,11 +205,10 @@ import Control.Distributed.Process.Internal.Messaging
   )
 import Control.Distributed.Process.Internal.Primitives
   ( register
-  , finally
   , receiveWait
   , match
   , sendChan
-  , catch
+  , try
   , unwrapMessage
   )
 import Control.Distributed.Process.Internal.Types (SendPort, Tracer(..))
@@ -355,11 +354,10 @@ closeLocalNode node = do
 runProcess :: LocalNode -> Process () -> IO ()
 runProcess node proc = do
   done <- newEmptyMVar
-  tid <- myThreadId
-  void $ forkProcess node $ do
-    catch (proc `finally` liftIO (putMVar done ()))
-          (\(ex :: SomeException) -> liftIO $ throwTo tid ex)
-  takeMVar done
+  -- TODO; When forkProcess inherits the masking state, protect the forked
+  -- thread against async exceptions that could occur before 'try' is evaluated.
+  void $ forkProcess node $ try proc >>= liftIO . putMVar done
+  takeMVar done >>= either (throwIO :: SomeException -> IO a) return
 
 -- | Spawn a new process on a local node
 forkProcess :: LocalNode -> Process () -> IO ProcessId
