Timeout wrappers

src/System/IO/Uniform/Streamline.hs

@@ -36,7 +36,7 @@ module System.IO.Uniform.Streamline (
   -- * Behavior settings
   startTls,
   isSecure,
-  setTimeout,
+  transformTarget,
   echoTo,
   setEcho
   ) where
@@ -65,24 +65,22 @@ import Data.IP (IP)
 import qualified Data.Attoparsec.ByteString as A
 
 -- | Internal state for a Streamline monad
-data StreamlineState = StreamlineState {str :: SomeIO, timeout :: Int, buff :: ByteString, isEOF :: Bool, echo :: Maybe Handle}
+data StreamlineState = StreamlineState {str :: SomeIO, buff :: ByteString, isEOF :: Bool, echo :: Maybe Handle}
 instance Default StreamlineState where
   -- | Will open StdIO
-  def = StreamlineState (SomeIO Std.StdIO) defaultTimeout BS.empty False Nothing
+  def = StreamlineState (SomeIO Std.StdIO) BS.empty False Nothing
 
 -- | Monad that emulates character stream IO over block IO.
 newtype Streamline m a = Streamline {withTarget' :: StreamlineState -> m (a, StreamlineState)}
 
 blockSize :: Int
 blockSize = 4096
-defaultTimeout :: Int
-defaultTimeout = 1000000 * 600
 
 readF :: MonadIO m => StreamlineState -> m ByteString
 readF cl = case echo cl of
   Just h -> do
     l <- liftIO $ S.uRead (str cl) blockSize
-    liftIO $ BS.hPutStr h "<"
+    liftIO $ BS.hPutStr h "< "
     liftIO $ BS.hPutStr h l
     return l
   Nothing -> liftIO $ S.uRead (str cl) blockSize
@@ -90,7 +88,7 @@ readF cl = case echo cl of
 writeF :: MonadIO m => StreamlineState -> ByteString -> m ()
 writeF cl l = case echo cl of
   Just h -> do
-    liftIO $ BS.hPutStr h ">"
+    liftIO $ BS.hPutStr h "> "
     liftIO $ BS.hPutStr h l
     liftIO $ S.uPut (str cl) l
   Nothing -> liftIO $ S.uPut (str cl) l
@@ -321,10 +319,6 @@ runAttoparsec p = Streamline $ \cl ->
 isSecure :: Monad m => Streamline m Bool
 isSecure = Streamline $ \cl -> return (S.isSecure $ str cl, cl)
 
--- | Sets the timeout for the streamlined IO target.
-setTimeout :: Monad m => Int -> Streamline m ()
-setTimeout t = Streamline $ \cl -> return ((), cl{timeout=t})
-
 -- | Sets echo of the streamlines IO target.
 --   If echo is set, all the data read an written to the target
 --   will be echoed in stdout, with ">" and "<" markers indicating
@@ -333,6 +327,14 @@ setEcho :: Monad m => Bool -> Streamline m ()
 setEcho e = Streamline $ \cl ->
   if e then return ((), cl{echo=Just stdout}) else return ((), cl{echo=Nothing})
 
+{- |
+Replaces the enclosed target with the result of the given transformation.
+
+Discards all buffered data in the process.
+-}
+transformTarget :: (UniformIO a, Monad m) => (SomeIO -> a) -> Streamline m ()
+transformTarget w = Streamline $ \cl -> return ((), cl{str = SomeIO . w . str $ cl})
+
 {- |
 Sets echo of the streamlined IO target.
 

src/System/IO/Uniform/Timeout.hs

@@ -0,0 +1,76 @@
+{-# 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"

test/Targets.hs

@@ -4,27 +4,34 @@ module Targets (tests) where
 
 import Distribution.TestSuite
 import Base (simpleTest)
-import Control.Concurrent(forkIO)
 import qualified System.IO as I
 import System.IO.Uniform
 import System.IO.Uniform.Network
 import System.IO.Uniform.File
---import System.IO.Uniform.Std
 import System.IO.Uniform.ByteString
 import System.IO.Uniform.HandlePair
+import System.IO.Uniform.Timeout
 import System.Timeout (timeout)
+import Control.Concurrent
 import qualified Data.ByteString.Char8 as C8
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
+import System.IO.Error
 
 tests :: IO [Test]
-tests = return [
-  simpleTest "network" testNetwork,
-  simpleTest "file" testFile,
-  simpleTest "network TLS" testTls,
-  simpleTest "byte string" testBS,
-  simpleTest "handle pair" testHandlePair
-  ]
+tests = do
+  t <- newMVar 1000000
+  return [
+    simpleTest "network" testNetwork,
+    simpleTest "file" testFile,
+    simpleTest "network TLS" testTls,
+    simpleTest "byte string" testBS,
+    simpleTest "handle pair" testHandlePair,
+    simpleTest "timeout success" $ tfixTimeouts (FixedTimeout 1000000) 1 False,
+    simpleTest "timeout fails" $ tfixTimeouts (FixedTimeout 1000000) 10000 True,
+    simpleTest "mvar timeout success" $ tfixTimeouts (MVarTimeout t) 1 False,
+    simpleTest "mvar timeout fails" $ tfixTimeouts (MVarTimeout t) 10000 True
+    ]
 
 testNetwork :: IO Progress
 testNetwork = do
@@ -120,3 +127,34 @@ testHandlePair = do
   if l == l'
     then return . Finished $ Pass
     else return . Finished . Fail . C8.unpack $ l'
+
+tfixTimeouts :: UniformIO a => (SocketIO -> a) -> Int -> Bool -> IO Progress
+tfixTimeouts mktimeout tm fails = do
+  recv <- bindPort 8888
+  r' <- tryIOError $ do
+    forkIO $ do
+      s <- accept recv
+      threadDelay $ tm * 10000
+      l <- uRead s 100
+      threadDelay $ tm * 10000
+      uPut s l
+      uClose s
+      return ()
+    s <- mktimeout <$> connectToHost "127.0.0.1" 8888
+    let l = "abcdef\n"
+    uPut s l
+    l' <- uRead s 100
+    uClose s
+    if l == l'
+      then return . Finished $ Pass
+      else return . Finished . Fail . C8.unpack $ l'
+  closePort recv
+  case r' of
+    Left e -> if fails
+              then return . Finished $ Pass
+              else return . Finished . Fail . show $ e
+    Right r -> if fails
+               then return . Finished . Fail $ "Timeout didn't trigger!"
+               else return r
+
+

uniform-io.cabal

@@ -10,7 +10,7 @@ name:                uniform-io
 -- PVP summary:      +-+------- breaking API changes
 --                   | | +----- non-breaking API additions
 --                   | | | +--- code changes with no API change
-version:    1.2.0.0
+version:    1.3.0.0
 
 -- A short (one-line) description of the package.
 synopsis:   Uniform IO over files, network, anything.
@@ -81,6 +81,7 @@ library
       System.IO.Uniform.Std,
       System.IO.Uniform.ByteString,
       System.IO.Uniform.HandlePair,
+      System.IO.Uniform.Timeout,
       System.IO.Uniform.Streamline,
       System.IO.Uniform.Streamline.Scanner