Streamline's runAttoparsec pushed the data back unto the buffer in case of failure

src/System/IO/Uniform/Streamline.hs

@@ -106,19 +106,21 @@ takeBuff = do
        else if lim < 0 then return (b, cl{buff="", isEOF=BS.null b})
             else let (r, b') = BS.splitAt lim b
                  in return (r, cl{
-                                                        isEOF = BS.null b || sentEmpty cl,
-                                                        sentEmpty = BS.null r,
-                                                        buff = b',
-                                                        inLimit = lim - BS.length r
-                                                        })
+                               -- EOF is at the real end of file, not on limited input
+                               isEOF = lim /= 0 && (BS.null b || sentEmpty cl),
+                               sentEmpty = BS.null r,
+                               buff = b',
+                               inLimit = lim - BS.length r
+                               })
 
 -- | Pushes remaining data back into the buffer
 pushBuff :: Monad m => ByteString -> Streamline m ()
 pushBuff dt = Streamline $ \cl -> let
   lim = inLimit cl
   b = buff cl
-  in if lim <= 0 then return ((), cl{buff = BS.append dt b})
-     else return ((), cl{buff = BS.append dt b, inLimit = lim - BS.length dt})
+  newb = BS.append dt b
+  newl = if lim < 0 then lim else lim + BS.length dt
+  in return ((), cl{buff=newb, inLimit=newl})
 
 writeF :: MonadIO m => ByteString -> Streamline m ()
 writeF l = Streamline $ \cl -> case echo cl of
@@ -306,18 +308,20 @@ runAttoparsecAndReturn :: MonadIO m => A.Parser a -> Streamline m (ByteString, E
 runAttoparsecAndReturn p = do
   d <- takeBuff
   let c = A.parse p d
-  continueResult c d
+  continueResult c d [d]
   where
-    continueResult c d = case c of
+    continueResult c d dd = case c of
       A.Fail i _ msg -> do
-        pushBuff i
+        pushBuff $ BS.concat (reverse dd) `BS.append` i
         return (BS.take (BS.length d - BS.length i) d, Left msg)
       A.Done i r -> do
         pushBuff i
-        return (BS.take (BS.length d - BS.length i) d, Right r)
+        return (BS.concat (reverse dd) `BS.append`
+                BS.take (BS.length d - BS.length i) d,
+                Right r)
       A.Partial c' -> do
         dt <- takeBuff
-        continueResult (c' dt) dt
+        continueResult (c' dt) dt $ dt:dd
 
 -- | Runs an Attoparsec parser over the data read from the
 --  streamlined IO target. Returning the parser result.

test/Base.hs

@@ -1,22 +1,35 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module Base (simpleTest) where
+module Base (simpleTest, noTimeoutTest) where
 
 import Distribution.TestSuite
 import System.IO.Error
+import Data.Maybe
+import System.Timeout
 
-simpleTest :: String -> IO Progress -> Test
-simpleTest n t = 
-  let test = TestInstance
-        {run = t',
-         name = n,
-         tags = [],
-         options = [],
-         setOption = \_ _ -> Right test
-        }
+mktest :: String -> IO Progress -> Test
+mktest n t = let
+  test = TestInstance {
+    run = t,
+    name = n,
+    tags = [],
+    options = [],
+    setOption = \_ _ -> Right test
+    }
   in Test test
-  where
-    t' :: IO Progress
-    t' = catchIOError t (
-      \e -> return . Finished . Fail $ "Raised exception: " ++ show e
-      )
+
+simpleTest :: String -> IO Progress -> Test
+simpleTest n t = mktest n . catchTest . timeoutTest $ t
+
+noTimeoutTest :: String -> IO Progress -> Test
+noTimeoutTest n t = mktest n . catchTest $ t
+
+catchTest :: IO Progress -> IO Progress
+catchTest t = catchIOError t (
+  \e -> return . Finished . Fail $ "Raised exception: " ++ show e
+  )
+
+timeoutTest :: IO Progress -> IO Progress
+timeoutTest t = fromMaybe (Finished . Fail $ "Timeout!") <$> (
+  timeout 1000000 t
+  )

test/LimitedInput.hs

@@ -4,13 +4,10 @@ module LimitedInput where
 
 import Distribution.TestSuite
 import Base (simpleTest)
-import System.IO.Error
 import System.IO.Uniform.ByteString
 import qualified System.IO.Uniform.Streamline as S
-import System.Timeout (timeout)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
-import qualified Data.ByteString.Char8 as C8
 import qualified Data.Attoparsec.ByteString as A
 import Control.Monad
 
@@ -21,33 +18,40 @@ tests = return [
   simpleTest "runAttoparsec" $ recvTest False "abcedefghijklmnopqrstuvwxyz" 3 $ runParser parseAlphabet,
   simpleTest "recieveLine" $ recvTest True "A test\n" 3 S.recieveLine,
   simpleTest "recieveN" $ recvTest True "A test\n" 3 $ S.recieveN 30,
-  simpleTest "runAttoparsec" $ recvTest True "abcedefghijklmnopqrstuvwxyz" 3 $ runParser parseAlphabet
+  simpleTest "runAttoparsec" $ recvTest True "abcedefghijklmnopqrstuvwxyz" 3 $ runParser parseAlphabet,
+  simpleTest "Attoparsec failure gets pushed back" attoparsecPushBack
   ]
 
 recvTest :: Bool -> ByteString -> Int -> S.Streamline IO ByteString -> IO Progress
-recvTest readFirst input limit f = do
-  r <- tryIOError $ test readFirst
-  case r of
-    Left e -> return . Finished . Fail $ "IO error: " ++ show e
-    Right v -> return v
-  where
-    test recv = do
-      to <- timeout 1000000 $ do
-        (r, _) <- withByteStringIO input $ \t -> do
-          S.withTarget t $ do
-            when recv $ S.recieveN 1 >> return ()
-            S.limitInput limit
-            f
-        let extra = if readFirst then 1 else 0
-        if BS.length r <= limit + extra
-          then return . Finished $ Pass
-          else return . Finished . Fail $ "Got too much text: " ++ show r
-      case to of
-        Nothing -> return . Finished . Fail $ "Execution blocked"
-        Just v -> return v
+recvTest readFirst input limit f = fstIO $ withByteStringIO input $ \t -> S.withTarget t $ do
+    when readFirst $ S.recieveN 1 >> return ()
+    S.limitInput limit
+    r <- f
+    let extra = if readFirst then 1 else 0
+    if BS.length r <= limit + extra
+      then return . Finished $ Pass
+      else return . Finished . Fail $ "Got too much text: " ++ show r
+
+fstIO :: IO (a, b) -> IO a
+fstIO f = fst <$> f
+
+alphabet :: ByteString
+alphabet = "abcedefghijklmnopqrstuvwxyz"
 
 parseAlphabet :: A.Parser ByteString
-parseAlphabet = A.string "abcedefghijklmnopqrstuvwxyz"
+parseAlphabet = A.string alphabet
+
+parseNotAlphabet :: A.Parser ByteString
+parseNotAlphabet = A.string . BS.reverse $ alphabet
 
 runParser :: A.Parser ByteString -> S.Streamline IO ByteString
 runParser p = fst <$> S.runAttoparsecAndReturn p
+
+attoparsecPushBack :: IO Progress
+attoparsecPushBack = fstIO $ withByteStringIO alphabet $ \t -> S.withTarget t $ do
+  S.runAttoparsec parseNotAlphabet
+  abc <- S.recieveN 3
+  if abc == "abc"
+    then return . Finished $ Pass
+    else return . Finished . Fail $ "Read wrong data: " ++ show abc
+    

test/Targets.hs

@@ -3,7 +3,7 @@
 module Targets (tests) where
 
 import Distribution.TestSuite
-import Base (simpleTest)
+import Base
 import qualified System.IO as I
 import System.IO.Uniform
 import System.IO.Uniform.Network
@@ -27,10 +27,10 @@ tests = do
     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
+    noTimeoutTest "timeout success" $ tfixTimeouts (FixedTimeout 1000000) 1 False,
+    noTimeoutTest "timeout fails" $ tfixTimeouts (FixedTimeout 10000) 10000 True,
+    noTimeoutTest "mvar timeout success" $ tfixTimeouts (MVarTimeout t) 1 False,
+    noTimeoutTest "mvar timeout fails" $ tfixTimeouts (MVarTimeout t) 10000 True
     ]
 
 testNetwork :: IO Progress