Merge pull request #31 from NicolasT/issue-30

troupe: "allow" processes to catch signals
NicolasT · Mar 25, 2023 · abe08d9 · abe08d9
2 parents a9fb3ab + 0a5d8ad
commit abe08d9
Show file tree

Hide file tree

Showing 2 changed files with 59 additions and 7 deletions.
diff --git a/troupe/src/Troupe/Process.hs b/troupe/src/Troupe/Process.hs
@@ -51,9 +51,10 @@ module Troupe.Process
 where
 
 import Control.Applicative (Alternative, (<|>))
+import Control.Concurrent (throwTo)
 import Control.Concurrent.Async
   ( async,
-    cancelWith,
+    asyncThreadId,
     uninterruptibleCancel,
     waitCatchSTM,
     withAsyncOnWithUnmask,
@@ -814,7 +815,7 @@ spawnImpl affinity cb process = do
               wait >>= \case
                 Left _ -> pure ()
                 Right exc -> do
-                  uninterruptibleCancelWith a exc
+                  uninterruptibleThrowTo a exc
                   loop
 
         -- 3. At this point, either the `Async` already returned, or we canceled it.
@@ -836,13 +837,14 @@ spawnImpl affinity cb process = do
 
         ( (register >>= \() -> loop)
             `withException` \e ->
-              uninterruptibleCancelWith a (e :: SomeException)
+              uninterruptibleThrowTo a (e :: SomeException)
           )
           `finally` cleanup
 
     -- Like uninterruptibleCancel, but with a custom exception
-    uninterruptibleCancelWith a e =
-      uninterruptibleMask_ (cancelWith a e)
+    uninterruptibleThrowTo a e =
+      uninterruptibleMask_ $
+        throwTo (asyncThreadId a) e
 
     registerProcess nodeContext processContext =
       Map.insert processContext (processContextId processContext) (nodeContextProcesses nodeContext)

diff --git a/troupe/test/Troupe/Test.hs b/troupe/test/Troupe/Test.hs
@@ -4,6 +4,7 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Troupe.Test (tests) where
 
@@ -18,9 +19,20 @@ import Control.Concurrent
   )
 import Control.DeepSeq (NFData (..))
 import Control.Exception.Base (MaskingState (..), getMaskingState)
-import Control.Exception.Safe (Exception, Handler (..), bracket, catch, catchesAsync, fromException, mask, throwM)
+import Control.Exception.Safe
+  ( Exception,
+    Handler (..),
+    bracket,
+    catch,
+    catchJust,
+    catchesAsync,
+    fromException,
+    mask,
+    throwM,
+  )
 import Control.Monad (forever)
 import Control.Monad.IO.Class (liftIO)
+import Data.Typeable (Typeable)
 import GHC.Generics (Generic)
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit (Assertion, assertFailure, testCase, (@?=))
@@ -92,6 +104,11 @@ instance Exception TestException
 instance NFData TestException where
   rnf t = t `seq` ()
 
+newtype TestExceptionWithValue a = TestExceptionWithValue a
+  deriving (Show, Eq)
+
+instance (Typeable a, Show a) => Exception (TestExceptionWithValue a)
+
 tests :: TestTree
 tests =
   testGroup
@@ -505,7 +522,40 @@ tests =
 
             liftIO $ case exc of
               Just (IsExit _ _ True (Just exc')) -> fromException exc' @?= Just TestException
-              _ -> assertFailure "Expected an Exit exception"
+              _ -> assertFailure "Expected an Exit exception",
+          testCase "Monitor thread waits for thread exit after throwTo, which may not happen (#30)" $ troupeTest () $ do
+            mv <- liftIO newEmptyMVar
+            s <- self
+
+            (pid, _) <- spawnMonitor $ do
+              send s (0 :: Int)
+              catchJust
+                ( \case
+                    TestExceptionWithValue (0 :: Int) -> pure ()
+                    _ -> Nothing
+                )
+                (liftIO (takeMVar mv))
+                pure
+
+              send s (1 :: Int)
+
+              liftIO $ takeMVar mv
+
+            (0 :: Int) <- expect
+
+            -- This one gets caught
+            exit pid (Just $ TestExceptionWithValue (0 :: Int))
+
+            (1 :: Int) <- expect
+
+            -- Due to #30, this one is never delivered
+            exit pid (Just $ TestExceptionWithValue (1 :: Int))
+
+            -- Let child continue
+            liftIO $ putMVar mv ()
+
+            Down _ _ exc <- expect
+            liftIO $ fmap fromException exc @?= Just (Just $ TestExceptionWithValue (1 :: Int))
         ]
     ]
   where