uniform-io/src/System/IO/Uniform/Timeout.hs

{-# LANGUAGE ExistentialQuantification #-} 

{- |
Wraps a target placing reading and writting operations
unders a timeout. Raises IOError if a timeout occurs.
-}
module System.IO.Uniform.Timeout (
  FixedTimeout(..),
  MVarTimeout(..)
  ) where

import System.IO.Uniform
import System.Timeout
--import System.IO.Error
import Control.Concurrent.MVar

{- |
Fixed timeout, set at define time.

> FixTimeout tm u

Will wrap u, applying a timeout of
tm nanoseconds on its IO operations.
-}
data FixedTimeout = forall u. UniformIO u => FixedTimeout Int u

instance UniformIO FixedTimeout where
  uRead (FixedTimeout t u) i = do
    r' <- timeout t $ uRead u i
    case r' of
      Just r -> return r
      Nothing -> doTimeout
  uPut (FixedTimeout t u) tx = do
    r' <- timeout t $ uPut u tx
    case r' of
      Just _ -> return ()
      Nothing -> doTimeout
  uClose (FixedTimeout _ u) = uClose u
  startTls s (FixedTimeout t u) = do
    r' <- timeout t $ startTls s u
    case r' of
      Just r -> return $ FixedTimeout t r
      Nothing -> doTimeout
  isSecure (FixedTimeout _ u) = isSecure u
  isEOF (FixedTimeout _ u) = isEOF u

{- |
Variable timeout, set at runtime.

> MVarTimeout tm u

Will wrap u, reading the timeout from (and locking) tm
during every read and write operation.
-}
data MVarTimeout = forall u. UniformIO u => MVarTimeout (MVar Int) u

instance UniformIO MVarTimeout where
  uRead (MVarTimeout t' u) i = withMVar t' $ \t -> do
    r' <- timeout t $ uRead u i
    case r' of
      Just r -> return r
      Nothing -> doTimeout
  uPut (MVarTimeout t' u) tx = withMVar t' $ \t -> do
    r' <- timeout t $ uPut u tx
    case r' of
      Just _ -> return ()
      Nothing -> doTimeout
  uClose (MVarTimeout _ u) = uClose u
  startTls s (MVarTimeout t' u) = withMVar t' $ \t -> do
    r' <- timeout t $ startTls s u
    case r' of
      Just r -> return $ MVarTimeout t' r
      Nothing -> doTimeout
  isSecure (MVarTimeout _ u) = isSecure u
  isEOF (MVarTimeout _ u) = isEOF u

doTimeout :: IO a
doTimeout = ioError $ userError "Timeout"