module Async.Combinators
(
WorkerExited (WorkerExited, WorkerFailed)
, withWorker
) where
import Control.Concurrent (myThreadId)
import Control.Concurrent.Async (withAsync)
import Control.Exception (SomeException (..), asyncExceptionFromException,
asyncExceptionToException)
import Control.Exception.Safe (Exception (..), finally, throwTo, tryAsync)
import Control.Monad (unless)
import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)
import Data.IORef (atomicWriteIORef, newIORef, readIORef)
import Data.Text (Text)
import qualified Data.Text as Text
data WorkerExited = WorkerExited Text
| WorkerFailed Text SomeException
instance Show WorkerExited where
show (WorkerExited n) = "Worker '" ++ Text.unpack n ++ "' returned"
show (WorkerFailed n e) = "Worker '" ++ Text.unpack n ++ "' failed: " ++ show e
instance Exception WorkerExited where
toException = asyncExceptionToException
fromException = asyncExceptionFromException
withWorker :: MonadUnliftIO m
=> Text
-> m ()
-> m b
-> m b
withWorker name worker go = withRunInIO $ \run -> do
tid <- myThreadId
mainDone <- newIORef False
let worker' = do
res <- tryAsync $ run worker
isMainDone <- readIORef mainDone
unless isMainDone $ throwTo tid $
case res of
Right () -> WorkerExited name
Left e -> WorkerFailed name e
withAsync worker' $ \_ -> run go `finally` atomicWriteIORef mainDone True