1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
|
{-# LANGUAGE DeriveDataTypeable #-}
-- |Intended for internal use: Simple timeout mechanism
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)
------------------------
-- |timeout exception
--
-- The @Double@ parameter documented at 'timeout'.
data TimeOutException
= TimeOutException Double
deriving (Eq, Typeable)
instance Show TimeOutException where
show (TimeOutException d) = "<<timeout at " ++ show (round $ 100*d :: Integer) ++ "%>>"
instance Exception TimeOutException
---------------
-- |Abstract data structure used by 'TimeoutHandle' and 'timeout'.
newtype TimeoutHandle
= TimeutHandle (MVar
(Maybe [(ThreadId, UTCTime)]))
-- ^
-- @Nothing@: the timeout happened already
-- @Just xs@: there is time left
-- @xs@ contains the list of threads for which a 'TimeoutException'
-- will be thrown when the time is over.
-- 'UTCTime' is needed to compute the @Double@ parameter of the exception.
-- |Creates a 'TimeoutHandle'.
--
-- The @Double@ parameter is the time limit in seconds.
-- All operations behind 'timeout' will be stopped
-- at the current time plus the time limit.
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
-- | Stop an operation at a time given by 'timeoutHandle'.
--
-- The @Double@ parameter is a percent between 0 and 1.
--
-- * 0: 'timeout' was called right after the 'TimeoutHandle' was created.
--
-- * 1: 'timeout' was called after the time of the timeout.
--
-- * near to 1: 'timeout' was called right before the time of the timeout.
--
-- * Other values: proportional to the time spend by the operation.
timeout
:: TimeoutHandle -- ^ knows the time of the timeout and the creation time of itself
-> (Double -> IO a) -- ^ timeout handling action for which will the percent will be supplied
-> IO a -- ^ the operation to timeout
-> 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
|
