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