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