How to link parent async with multiple children asyncs - multithreading

Question

The documentation of the async package describes the withAsync function as:
Spawn an asynchronous action in a separate thread, and pass its Async
handle to the supplied function. When the function returns or throws
an exception, uninterruptibleCancel is called on the Async. This is a
useful variant of async that ensures an Async is never left running
unintentionally.
I've been staring at that for the past 2 hours and haven't been able to figure out how to start a monitor thread, that spawns multiple worker threads, such that:
If the monitor thread dies, all worker threads should be killed,
But, if any worker thread dies, none of the other worker threads should be affected. The monitor should be notified and it should be able to restart the worker thread.

Answer 1

It seems that we need two functions: one that starts all the async tasks and another that watches them and restarts them whenever they die.
The first one could be written like this:
withAsyncMany :: [IO t] -> ([Async t] -> IO b) -> IO b
withAsyncMany [] f = f []
withAsyncMany (t:ts) f = withAsync t $ \a -> withAsyncMany ts (f . (a:))
If we were using the managed package, we could also write it like this:
import Control.Monad.Managed (with,managed)
withAsyncMany' :: [IO t] -> ([Async t] -> IO b) -> IO b
withAsyncMany' = with . traverse (\t -> managed (withAsync t))
The restart function would loop the list of asyncs, polling for their status and renewing them when they fail:
{-# language NumDecimals #-}
import Control.Concurrent (threadDelay)
resurrect :: IO t -> [Async t] -> IO ()
resurrect restartAction = go []
where
go ts [] = do
threadDelay 1e6 -- wait a little before the next round of polling
go [] (reverse ts)
go past (a:pending) = do
status <- poll a -- has the task died, or finished?
case status of
Nothing -> go (a:past) pending
Just _ -> withAsync restartAction $ \a' -> go (a':past) pending
I'm worried however about the possibility of many nested withAsyncs causing some type of resource leak (because some kind of exception handler must be installed with each withAsync to notify the child in case the parent thread dies).
So perhaps in this case it would be better to spawn workers with plain asyncs, store the collection of Asyncs into some kind of mutable reference and install a single exception handler in the monitor thread, which would traverse the container terminating each task.

Answer 2

Here's another answer, that uses async instead of withAsync. The main function is
monitor :: Int -> IO () -> IO ()
monitor count task =
bracket (do asyncs <- replicateM count (async task)
newIORef asyncs)
(\ref -> forever (do
threadDelay 1e6
asyncs <- readIORef ref
vivify task (writeIORef ref) asyncs))
(\ref -> do
asyncs <- readIORef ref
mapM_ uninterruptibleCancel asyncs)
it uses an auxiliary vivify function that traverses a list of Asyncs, reviving dead ones and writing back the updated list to an IORef:
vivify :: IO () -> ([Async ()] -> IO ()) -> [Async ()] -> IO ()
vivify task write asyncs = go [] asyncs
where
go _ [] = do
return ()
go past (a:pending) = do
status <- poll a
case status of
Nothing -> do
go (a:past) pending
Just _ -> do
past' <- mask_ $ do
a' <- async task
write (reverse (a':past) ++ pending)
return (a':past)
go past' pending
We mask asynchronous exceptions in the interval between creating a new Async and "persisting" it in the IOref, because otherwise if an asynchronous exception arrived inbetween and killed the monitor thread, that Async would remain dangling.