module System.SimpleTimeout
( TimeoutHandle
, timeoutHandle
, timeout
) where
import Control.Exception (Exception, handle)
import Control.Concurrent (forkIO, threadDelay, throwTo, ThreadId, myThreadId)
import Control.Concurrent.MVar (MVar, newMVar, newEmptyMVar, takeMVar, putMVar, swapMVar, modifyMVar)
import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime)
import Data.Typeable (Typeable)
data TimeOutException
= TimeOutException Double
deriving (Eq, Typeable)
instance Show TimeOutException where
show (TimeOutException d) = "<<timeout at " ++ show (round $ 100*d :: Integer) ++ "%>>"
instance Exception TimeOutException
newtype TimeoutHandle
= TimeutHandle (MVar
(Maybe [(ThreadId, UTCTime)]))
timeoutHandle :: Double -> IO TimeoutHandle
timeoutHandle limit = do
th <- newMVar $ Just []
_ <- forkIO $ killLater th
return $ TimeutHandle th
where
killLater th = do
start <- getCurrentTime
threadDelay $ round $ 1000000 * limit
Just threads <- swapMVar th Nothing
end <- getCurrentTime
let whole = end `diffUTCTime` start
let kill (x, time)
= x `throwTo`
TimeOutException (realToFrac $ (time `diffUTCTime` start) / whole)
mapM_ kill threads
timeout
:: TimeoutHandle
-> (Double -> IO a)
-> IO a
-> IO a
timeout (TimeutHandle th) handleTimeout operation = do
result <- newEmptyMVar
let handleTimeoutException (TimeOutException d)
= handleTimeout d >>= putMVar result
_ <- forkIO $ handle handleTimeoutException $ do
b <- modifyMVar th $ \b -> case b of
Nothing -> return (Nothing, False)
Just xs -> do
pid <- myThreadId
time <- getCurrentTime
return (Just $ (pid,time):xs, True)
x <- if b
then operation
else handleTimeout 1
putMVar result x
takeMVar result