module Shelly.Background (
jobs, background, getBgResult, BgResult
) where
import Shelly
import Control.Concurrent
import Control.Exception (finally, catch, throw, SomeException)
import Prelude hiding (catch)
import qualified Control.Concurrent.MSem as Sem
jobs :: Int -> (BgJobManager -> ShIO a) -> ShIO a
jobs limit action = do
unless (limit > 0) $ terror "expected limit to be > 0"
availableJobsSem <- liftIO $ Sem.new limit
res <- action $ BgJobManager availableJobsSem
liftIO $ waitForJobs availableJobsSem
return res
where
waitForJobs sem = do
avail <- Sem.peekAvail sem
if avail == limit then return () else waitForJobs sem
newtype BgJobManager = BgJobManager (Sem.MSem Int)
newtype BgResult a = BgResult (MVar a)
getBgResult :: BgResult a -> ShIO a
getBgResult (BgResult mvar) = liftIO $ takeMVar mvar
background :: BgJobManager -> ShIO a -> ShIO (BgResult a)
background (BgJobManager manager) proc = do
state <- get
liftIO $ do
Sem.wait manager
mvar <- newEmptyMVar
mainTid <- myThreadId
_<- forkIO $ do
result <-
finally (
(shelly $ (put state >> proc)) `catch`
(\(e::SomeException) -> throwTo mainTid e >> throw e)
)
(Sem.signal manager >> return ())
putMVar mvar result
return $ BgResult mvar