12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576 |
- {-# 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
- {- |
- 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
- doTimeout :: IO a
- doTimeout = ioError $ userError "Timeout"
|