System/Timeout.hs

   1 {-# LANGUAGE CPP #-}
   2 #ifdef __GLASGOW_HASKELL__
   3 {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
   4 #endif
   5
   6 -------------------------------------------------------------------------------
   7 -- |
   8 -- Module      :  System.Timeout
   9 -- Copyright   :  (c) The University of Glasgow 2007
  10 -- License     :  BSD-style (see the file libraries/base/LICENSE)
  11 --
  12 -- Maintainer  :  libraries@haskell.org
  13 -- Stability   :  experimental
  14 -- Portability :  non-portable
  15 --
  16 -- Attach a timeout event to arbitrary 'IO' computations.
  17 --
  18 -------------------------------------------------------------------------------
  19
  20 #ifdef __GLASGOW_HASKELL__
  21 #include "Typeable.h"
  22 #endif
  23
  24 module System.Timeout ( timeout ) where
  25
  26 #ifdef __GLASGOW_HASKELL__
  27 import Prelude             (Show(show), IO, Ord((<)), Eq((==)), Int,
  28                             otherwise, fmap)
  29 import Data.Maybe          (Maybe(..))
  30 import Control.Monad       (Monad(..))
  31 import Control.Concurrent  (forkIO, threadDelay, myThreadId, killThread)
  32 import Control.Exception   (Exception, handleJust, throwTo, bracket)
  33 import Data.Typeable
  34 import Data.Unique         (Unique, newUnique)
  35
  36 -- An internal type that is thrown as a dynamic exception to
  37 -- interrupt the running IO computation when the timeout has
  38 -- expired.
  39
  40 newtype Timeout = Timeout Unique deriving Eq
  41 INSTANCE_TYPEABLE0(Timeout,timeoutTc,"Timeout")
  42
  43 instance Show Timeout where
  44     show _ = "<<timeout>>"
  45
  46 instance Exception Timeout
  47 #endif /* !__GLASGOW_HASKELL__ */
  48
  49 -- |Wrap an 'IO' computation to time out and return @Nothing@ in case no result
  50 -- is available within @n@ microseconds (@1\/10^6@ seconds). In case a result
  51 -- is available before the timeout expires, @Just a@ is returned. A negative
  52 -- timeout interval means \"wait indefinitely\". When specifying long timeouts,
  53 -- be careful not to exceed @maxBound :: Int@.
  54 --
  55 -- The design of this combinator was guided by the objective that @timeout n f@
  56 -- should behave exactly the same as @f@ as long as @f@ doesn't time out. This
  57 -- means that @f@ has the same 'myThreadId' it would have without the timeout
  58 -- wrapper. Any exceptions @f@ might throw cancel the timeout and propagate
  59 -- further up. It also possible for @f@ to receive exceptions thrown to it by
  60 -- another thread.
  61 --
  62 -- A tricky implementation detail is the question of how to abort an @IO@
  63 -- computation. This combinator relies on asynchronous exceptions internally.
  64 -- The technique works very well for computations executing inside of the
  65 -- Haskell runtime system, but it doesn't work at all for non-Haskell code.
  66 -- Foreign function calls, for example, cannot be timed out with this
  67 -- combinator simply because an arbitrary C function cannot receive
  68 -- asynchronous exceptions. When @timeout@ is used to wrap an FFI call that
  69 -- blocks, no timeout event can be delivered until the FFI call returns, which
  70 -- pretty much negates the purpose of the combinator. In practice, however,
  71 -- this limitation is less severe than it may sound. Standard I\/O functions
  72 -- like 'System.IO.hGetBuf', 'System.IO.hPutBuf', Network.Socket.accept, or
  73 -- 'System.IO.hWaitForInput' appear to be blocking, but they really don't
  74 -- because the runtime system uses scheduling mechanisms like @select(2)@ to
  75 -- perform asynchronous I\/O, so it is possible to interrupt standard socket
  76 -- I\/O or file I\/O using this combinator.
  77
  78 timeout :: Int -> IO a -> IO (Maybe a)
  79 #ifdef __GLASGOW_HASKELL__
  80 timeout n f
  81     | n <  0    = fmap Just f
  82     | n == 0    = return Nothing
  83     | otherwise = do
  84         pid <- myThreadId
  85         ex  <- fmap Timeout newUnique
  86         handleJust (\e -> if e == ex then Just () else Nothing)
  87                    (\_ -> return Nothing)
  88                    (bracket (forkIO (threadDelay n >> throwTo pid ex))
  89                             (killThread)
  90                             (\_ -> fmap Just f))
  91 #else
  92 timeout n f = fmap Just f
  93 #endif /* !__GLASGOW_HASKELL__ */