TimeOut.hs

{-# OPTIONS -fglasgow-exts #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  HAppS.Util.TimeOut
-- Copyright   :  (c) HAppS.org, 2005
-- License     :  BSD3
-- 
-- Portability :  uses mdo
--
-- Timeout implementation for performing operations in the IO monad
-- with a timeout added. Both using Maybe and exceptions to handle
-- timeouts are supported.
--
-- Timeouts can be implemented in GHC with either a global handler
-- or a per-timeout thread which sleeps until the timeout. The latter
-- is used in this module. Blocking on foreign calls can cause
-- problems as GHC has no way of interrupting such threads.
-- The module provides a slightly slower alternative implementation
-- which returns even if the computation has blocked on a foreign
-- call. This should not be an issue unless -threaded is used.
--
-- The timeouts are currently limited to a maximum of about
-- 2000 seconds. This is a feature of threadDelay, but
-- supporting longer timeouts is certainly possible if
-- that is desirable.
-----------------------------------------------------------------------------
module HAppS.Util.TimeOut 
    (withTimeOut, withTimeOutMaybe,
     withSafeTimeOut, withSafeTimeOutMaybe,
     TimeOutException(..), second
    ) where

import Control.Concurrent
import Control.Exception as E
import Data.Dynamic(toDyn)
import Data.Typeable(Typeable)

import HAppS.Util.Concurrent

data TimeOutException = TimeOutException
  deriving(Typeable)

-- | This is the normal timeout handler. It throws a dynamic exception (TimeOutException),
-- if the timeout occurs.

withTimeOut :: Int -> IO a -> IO a
withTimeOut tout op = do 
  wtid <- myThreadId
  ktid <- fork (threadDelay tout >> throwDynTo wtid TimeOutException)
  op `finally` killThread ktid


-- | This is the normal timeout handler. If the computation fails or the timeout
-- is reached it returns Nothing.
withTimeOutMaybe :: Int -> IO a -> IO (Maybe a)
withTimeOutMaybe tout op = worker `E.catch` (\_ -> return Nothing)
    where worker = do wtid <- myThreadId
                      ktid <- fork (threadDelay tout >> killThread wtid)
                      res  <- op `finally` killThread ktid
                      return $ Just res


-- | Like timeOut, but additionally it works even if the computation is blocking
-- async exceptions (explicitely or by a blocking FFI call). This consumes
-- more resources than timeOut, but is still quite fast.
withSafeTimeOut :: Int -> IO a -> IO a
withSafeTimeOut tout op = mdo
  mv <- newEmptyMVar
  wt <- fork $ do try op >>= tryPutMVar mv >> killThread kt
  kt <- fork $ do threadDelay tout
                  e <- tryPutMVar mv $ Left $ DynException $ toDyn TimeOutException
                  if e then killThread wt else return ()
  either throw return =<< takeMVar mv

-- | Like withTimeOutMaybe, but handles the operation blocking exceptions like withSafeTimeOut
-- does.
withSafeTimeOutMaybe :: Int -> IO a -> IO (Maybe a)
withSafeTimeOutMaybe tout op = mdo
  mv <- newEmptyMVar
  wt <- fork $ do (op >>= putMVar mv . Just) `E.catch` (\_ -> tryPutMVar mv Nothing >> return ())
                  killThread kt
  kt <- fork $ do threadDelay tout
                  e <- tryPutMVar mv Nothing
                  if e then killThread wt else return ()
  takeMVar mv

-- | Constant representing one second.
second :: Int
second = 1000000