{-# LANGUAGE CPP #-}{-# LANGUAGE Safe #-}--------------------------------------------------------------------------------- |-- Module : System.Timeout-- Copyright : (c) The University of Glasgow 2007-- License : BSD-style (see the file libraries/base/LICENSE)---- Maintainer : libraries@haskell.org-- Stability : stable-- Portability : non-portable---- Attach a timeout event to arbitrary 'IO' computations.----------------------------------------------------------------------------------- TODO: Inspect is still suitable.moduleSystem.Timeout(Timeout ,timeout )where
#if !defined(mingw32_HOST_OS) && !defined(javascript_HOST_ARCH)
importControl.Monad importGHC.Event (getSystemTimerManager ,registerTimeout ,unregisterTimeout )
#endif
importControl.Concurrent importControl.Exception (Exception (..),handleJust ,bracket ,uninterruptibleMask_ ,asyncExceptionToException ,asyncExceptionFromException )importData.Unique (Unique ,newUnique )-- $setup-- >>> import Prelude-- >>> import Control.Concurrent (threadDelay)-- An internal type that is thrown as a dynamic exception to-- interrupt the running IO computation when the timeout has-- expired.-- | An exception thrown to a thread by 'timeout' to interrupt a timed-out-- computation.---- @since 4.0newtypeTimeout =Timeout Unique derivingTimeout -> Timeout -> Bool
(Timeout -> Timeout -> Bool)
-> (Timeout -> Timeout -> Bool) -> Eq Timeout
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Timeout -> Timeout -> Bool
== :: Timeout -> Timeout -> Bool
$c/= :: Timeout -> Timeout -> Bool
/= :: Timeout -> Timeout -> Bool
Eq -- | @since 4.0instanceShow Timeout whereshow :: Timeout -> String
show Timeout
_=String
"<<timeout>>"-- Timeout is a child of SomeAsyncException-- | @since 4.7.0.0instanceException Timeout wheretoException :: Timeout -> SomeException
toException =Timeout -> SomeException
forall e. Exception e => e -> SomeException
asyncExceptionToException fromException :: SomeException -> Maybe Timeout
fromException =SomeException -> Maybe Timeout
forall e. Exception e => SomeException -> Maybe e
asyncExceptionFromException -- |Wrap an 'IO' computation to time out and return @Nothing@ in case no result-- is available within @n@ microseconds (@1\/10^6@ seconds). In case a result-- is available before the timeout expires, @Just a@ is returned. A negative-- timeout interval means \"wait indefinitely\". When specifying long timeouts,-- be careful not to exceed @maxBound :: Int@, which on 32-bit machines is only-- 2147483647 μs, less than 36 minutes.-- Consider using @Control.Concurrent.Timeout.timeout@ from @unbounded-delays@ package.---- >>> timeout 1000000 (threadDelay 1000 *> pure "finished on time")-- Just "finished on time"---- >>> timeout 10000 (threadDelay 100000 *> pure "finished on time")-- Nothing---- The design of this combinator was guided by the objective that @timeout n f@-- should behave exactly the same as @f@ as long as @f@ doesn't time out. This-- means that @f@ has the same 'myThreadId' it would have without the timeout-- wrapper. Any exceptions @f@ might throw cancel the timeout and propagate-- further up. It also possible for @f@ to receive exceptions thrown to it by-- another thread.---- A tricky implementation detail is the question of how to abort an @IO@-- computation. This combinator relies on asynchronous exceptions internally-- (namely throwing the computation the 'Timeout' exception). The technique-- works very well for computations executing inside of the Haskell runtime-- system, but it doesn't work at all for non-Haskell code. Foreign function-- calls, for example, cannot be timed out with this combinator simply because-- an arbitrary C function cannot receive asynchronous exceptions. When-- @timeout@ is used to wrap an FFI call that blocks, no timeout event can be-- delivered until the FFI call returns, which pretty much negates the purpose-- of the combinator. In practice, however, this limitation is less severe than-- it may sound. Standard I\/O functions like 'System.IO.hGetBuf',-- 'System.IO.hPutBuf', Network.Socket.accept, or 'System.IO.hWaitForInput'-- appear to be blocking, but they really don't because the runtime system uses-- scheduling mechanisms like @select(2)@ to perform asynchronous I\/O, so it-- is possible to interrupt standard socket I\/O or file I\/O using this-- combinator.----- Note that 'timeout' cancels the computation by throwing it the 'Timeout'-- exception. Consequently blanket exception handlers (e.g. catching-- 'SomeException') within the computation will break the timeout behavior.timeout ::Int ->IO a ->IO (Maybe a )timeout :: forall a. Int -> IO a -> IO (Maybe a)
timeout Int
n IO a
f |Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0=(a -> Maybe a) -> IO a -> IO (Maybe a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just IO a
f |Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0=Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing 
#if !defined(mingw32_HOST_OS) && !defined(javascript_HOST_ARCH)
|Bool
rtsSupportsBoundThreads =do-- In the threaded RTS, we use the Timer Manager to delay the-- (fairly expensive) 'forkIO' call until the timeout has expired.---- An additional thread is required for the actual delivery of-- the Timeout exception because killThread (or another throwTo)-- is the only way to reliably interrupt a throwTo in flight.ThreadId
pid <-IO ThreadId
myThreadId Timeout
ex <-(Unique -> Timeout) -> IO Unique -> IO Timeout
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Unique -> Timeout
Timeout IO Unique
newUnique TimerManager
tm <-IO TimerManager
getSystemTimerManager -- 'lock' synchronizes the timeout handler and the main thread:-- * the main thread can disable the handler by writing to 'lock';-- * the handler communicates the spawned thread's id through 'lock'.-- These two cases are mutually exclusive.MVar ThreadId
lock <-IO (MVar ThreadId)
forall a. IO (MVar a)
newEmptyMVar lethandleTimeout :: IO ()
handleTimeout =doBool
v <-MVar ThreadId -> IO Bool
forall a. MVar a -> IO Bool
isEmptyMVar MVar ThreadId
lock Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
v (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId)
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask ->IO () -> IO ()
forall a. IO a -> IO a
unmask (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ doBool
v2 <-MVar ThreadId -> ThreadId -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ThreadId
lock (ThreadId -> IO Bool) -> IO ThreadId -> IO Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ThreadId
myThreadId Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
v2 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> Timeout -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
pid Timeout
ex cleanupTimeout :: TimeoutKey -> IO ()
cleanupTimeout TimeoutKey
key =IO () -> IO ()
forall a. IO a -> IO a
uninterruptibleMask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ doBool
v <-MVar ThreadId -> ThreadId -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ThreadId
lock ThreadId
forall a. HasCallStack => a
undefined ifBool
v thenTimerManager -> TimeoutKey -> IO ()
unregisterTimeout TimerManager
tm TimeoutKey
key elseMVar ThreadId -> IO ThreadId
forall a. MVar a -> IO a
takeMVar MVar ThreadId
lock IO ThreadId -> (ThreadId -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ThreadId -> IO ()
killThread (Timeout -> Maybe ())
-> (() -> IO (Maybe a)) -> IO (Maybe a) -> IO (Maybe a)
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
handleJust (\Timeout
e ->ifTimeout
e Timeout -> Timeout -> Bool
forall a. Eq a => a -> a -> Bool
== Timeout
ex then() -> Maybe ()
forall a. a -> Maybe a
Just ()elseMaybe ()
forall a. Maybe a
Nothing )(\()
_->Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing )(IO TimeoutKey
-> (TimeoutKey -> IO ())
-> (TimeoutKey -> IO (Maybe a))
-> IO (Maybe a)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (TimerManager -> Int -> IO () -> IO TimeoutKey
registerTimeout TimerManager
tm Int
n IO ()
handleTimeout )TimeoutKey -> IO ()
cleanupTimeout (\TimeoutKey
_->(a -> Maybe a) -> IO a -> IO (Maybe a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just IO a
f ))
#endif
|Bool
otherwise =doThreadId
pid <-IO ThreadId
myThreadId Timeout
ex <-(Unique -> Timeout) -> IO Unique -> IO Timeout
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Unique -> Timeout
Timeout IO Unique
newUnique (Timeout -> Maybe ())
-> (() -> IO (Maybe a)) -> IO (Maybe a) -> IO (Maybe a)
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
handleJust (\Timeout
e ->ifTimeout
e Timeout -> Timeout -> Bool
forall a. Eq a => a -> a -> Bool
== Timeout
ex then() -> Maybe ()
forall a. a -> Maybe a
Just ()elseMaybe ()
forall a. Maybe a
Nothing )(\()
_->Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing )(IO ThreadId
-> (ThreadId -> IO ())
-> (ThreadId -> IO (Maybe a))
-> IO (Maybe a)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId)
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask ->IO () -> IO ()
forall a. IO a -> IO a
unmask (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
n IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ThreadId -> Timeout -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
pid Timeout
ex )(IO () -> IO ()
forall a. IO a -> IO a
uninterruptibleMask_ (IO () -> IO ()) -> (ThreadId -> IO ()) -> ThreadId -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId -> IO ()
killThread )(\ThreadId
_->(a -> Maybe a) -> IO a -> IO (Maybe a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just IO a
f ))-- #7719 explains why we need uninterruptibleMask_ above.