1{-# LANGUAGE CPP, DeriveDataTypeable, NoImplicitPrelude #-} 2 3#if __GLASGOW_HASKELL__ >= 704 4{-# LANGUAGE Safe #-} 5#endif 6 7------------------------------------------------------------------------------- 8-- | 9-- Module : Control.Concurrent.Timeout 10-- Copyright : 2011 Bas van Dijk & Roel van Dijk 11-- License : BSD3 (see the file LICENSE) 12-- Maintainer : Bas van Dijk <v.dijk.bas@gmail.com> 13-- , Roel van Dijk <vandijk.roel@gmail.com> 14-- 15-- Wait arbitrarily long for an IO computation to finish. 16------------------------------------------------------------------------------- 17 18module Control.Concurrent.Timeout ( timeout, Timeout, timeoutWithPred ) where 19 20 21------------------------------------------------------------------------------- 22-- Imports 23------------------------------------------------------------------------------- 24 25-- from base: 26import Control.Concurrent ( forkIOWithUnmask, myThreadId, throwTo, killThread ) 27import Control.Exception ( Exception, bracket, handleJust ) 28import Control.Monad ( return, (>>), fmap ) 29import Data.Bool ( Bool(False), otherwise ) 30import Data.Eq ( Eq, (==) ) 31import Data.Function ( (.), const) 32import Data.Maybe ( Maybe(Nothing, Just) ) 33import Data.Ord ( (<) ) 34import Data.Typeable ( Typeable ) 35import Data.Unique ( Unique, newUnique ) 36import Prelude ( Integer ) 37import System.IO ( IO ) 38import Text.Show ( Show, show ) 39 40#if __GLASGOW_HASKELL__ < 700 41import Prelude ( fromInteger ) 42import Control.Monad ( (>>=), fail ) 43#endif 44 45#ifdef __HADDOCK_VERSION__ 46import Data.Int ( Int ) 47import System.IO ( hGetBuf, hPutBuf, hWaitForInput ) 48import qualified System.Timeout ( timeout ) 49#endif 50 51-- from unbounded-delays (this package): 52import Control.Concurrent.Thread.Delay ( delay ) 53 54 55------------------------------------------------------------------------------- 56-- Long delays and timeouts 57------------------------------------------------------------------------------- 58 59{- 60The following code was mostly copied from the module System.Timeout in the 61package base-4.2.0.0. 62 63(c) The University of Glasgow 2007 64-} 65 66newtype Timeout = Timeout Unique deriving (Eq, Typeable) 67 68instance Show Timeout where 69 show _ = "<<timeout>>" 70 71instance Exception Timeout 72 73{-| 74Like @System.Timeout.'System.Timeout.timeout'@, but not bounded by an 'Int'. 75(..) 76Wrap an 'IO' computation to time out and return 'Nothing' in case no result is 77available within @n@ microseconds (@1\/10^6@ seconds). In case a result is 78available before the timeout expires, 'Just' @a@ is returned. A negative timeout 79interval means \"wait indefinitely\". 80 81If the computation has not terminated after @n@ microseconds, it is interrupted 82by an asynchronous exception. The function passed to @f@ can be used to detect 83whether it was interrupted by this timeout or some other exception. 84 85The design of this combinator was guided by the objective that @timeout n (const f)@ 86should behave exactly the same as @f@ as long as @f@ doesn't time out. This 87means that @f@ has the same 'myThreadId' it would have without the timeout 88wrapper. Any exceptions @f@ might throw cancel the timeout and propagate further 89up. It also possible for @f@ to receive exceptions thrown to it by another 90thread. 91 92A tricky implementation detail is the question of how to abort an 'IO' 93computation. This combinator relies on asynchronous exceptions internally. The 94technique works very well for computations executing inside of the Haskell 95runtime system, but it doesn't work at all for non-Haskell code. Foreign 96function calls, for example, cannot be timed out with this combinator simply 97because an arbitrary C function cannot receive asynchronous exceptions. When 98@timeout@ is used to wrap an FFI call that blocks, no timeout event can be 99delivered until the FFI call returns, which pretty much negates the purpose of 100the combinator. In practice, however, this limitation is less severe than it may 101sound. Standard I\/O functions like 'System.IO.hGetBuf', 'System.IO.hPutBuf', 102Network.Socket.accept, or 'System.IO.hWaitForInput' appear to be blocking, but 103they really don't because the runtime system uses scheduling mechanisms like 104@select(2)@ to perform asynchronous I\/O, so it is possible to interrupt 105standard socket I\/O or file I\/O using this combinator. 106-} 107timeoutWithPred :: Integer -> ((Timeout -> Bool) -> IO α) -> IO (Maybe α) 108timeoutWithPred n f 109 | n < 0 = fmap Just (f (const False)) 110 | n == 0 = return Nothing 111 | otherwise = do 112 pid <- myThreadId 113 ex <- fmap Timeout newUnique 114 handleJust (\e -> if e == ex then Just () else Nothing) 115 (\_ -> return Nothing) 116 (bracket (forkIOWithUnmask (\unmask -> unmask (delay n >> throwTo pid ex))) 117 (killThread) 118 (\_ -> fmap Just (f (==ex))) 119 ) 120 121{-| 122Like 'timeoutWithPred', but does not expose the 'Timeout' exception to the called action. 123-} 124timeout :: Integer -> IO α -> IO (Maybe α) 125timeout n = timeoutWithPred n . const 126