This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "snap-core".
The branch, master has been updated
via c79652f5e5978eee3c3aad06c2fad5a97c60045d (commit)
via a737d427ab58dcb8ba26022e261dc113dfa5ae4f (commit)
from 112537b49c1258ff29adec0e3225fa8bcc961623 (commit)
Summary of changes:
snap-core.cabal | 2 +-
src/Snap/Iteratee.hs | 15 ++++++++++++-
test/suite/Snap/Iteratee/Tests.hs | 38 ++++++++++++++++++++++++------------
3 files changed, 39 insertions(+), 16 deletions(-)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit c79652f5e5978eee3c3aad06c2fad5a97c60045d
Author: Gregory Collins <[email protected]>
Date: Sun May 30 14:29:28 2010 -0400
Add an 'escape valve' to safe buffer iteratee
diff --git a/src/Snap/Iteratee.hs b/src/Snap/Iteratee.hs
index 78842c5..6b7ecf0 100644
--- a/src/Snap/Iteratee.hs
+++ b/src/Snap/Iteratee.hs
@@ -126,11 +126,22 @@ countBytes = go 0
-- Our enumerators produce a lot of little strings; rather than spending all
-- our time doing kernel context switches for 4-byte write() calls, we buffer
-- the iteratee to send 8KB at a time.
-bufferIteratee :: (Monad m) => Enumerator m a
-bufferIteratee = return . go (D.empty,0)
+bufferIteratee :: Iteratee IO a -> IO (Iteratee IO a, IORef Bool)
+bufferIteratee iteratee = do
+ esc <- newIORef False
+ return $ (start esc iteratee, esc)
+
where
blocksize = 8192
+ start esc iter = IterateeG $! checkRef esc iter
+
+ checkRef esc iter ch = do
+ quit <- readIORef esc
+ if quit
+ then runIter iter ch
+ else f (D.empty,0) iter ch
+
--go :: (DList ByteString, Int) -> Iteratee m a -> Iteratee m a
go (!dl,!n) iter = IterateeG $! f (dl,n) iter
diff --git a/test/suite/Snap/Iteratee/Tests.hs
b/test/suite/Snap/Iteratee/Tests.hs
index 4116252..f00eb84 100644
--- a/test/suite/Snap/Iteratee/Tests.hs
+++ b/test/suite/Snap/Iteratee/Tests.hs
@@ -78,46 +78,58 @@ testEnumLBS = testProperty "enumLBS" prop
testBuffer :: Test
-testBuffer = testProperty "testBuffer" prop
+testBuffer = testProperty "testBuffer" $
+ monadicIO $ forAllM arbitrary prop
where
- prop s = s /= L.empty ==> fromWrap (runIdentity (run iter)) == s'
+ prop s = do
+ pre (s /= L.empty)
+
+ (i,_) <- liftQ $ bufferIteratee stream2stream
+ iter <- liftQ $ enumLBS s' i
+ x <- liftQ $ run iter
+
+ QC.assert $ fromWrap x == s'
where
s' = L.take 20000 $ L.cycle s
- i = runIdentity $ bufferIteratee stream2stream
- iter = runIdentity $ enumLBS s' i
testBuffer2 :: Test
testBuffer2 = testCase "testBuffer2" prop
where
prop = do
- i <- bufferIteratee $ drop 4 >> stream2stream
+ (i,_) <- bufferIteratee $ drop 4 >> stream2stream
s <- enumLBS "abcdefgh" i >>= run >>= return . fromWrap
H.assertEqual "s == 'efgh'" "efgh" s
testBuffer3 :: Test
-testBuffer3 = testProperty "testBuffer3" prop
+testBuffer3 = testProperty "testBuffer3" $
+ monadicIO $ forAllM arbitrary prop
where
- prop s = s /= L.empty ==> fromWrap (runIdentity (run iter)) == (L.take
19999 s')
+ prop s = do
+ pre (s /= L.empty)
+ (i,_) <- liftQ $ bufferIteratee (ss >>= \x -> drop 1 >> return x)
+ iter <- liftQ $ enumLBS s' i
+ x <- liftQ $ run iter
+
+ QC.assert $ fromWrap x == (L.take 19999 s')
where
s' = L.take 20000 $ L.cycle s
ss = joinI $ take 19999 stream2stream
- i = runIdentity $ bufferIteratee (ss >>= \x -> drop 1 >> return x)
- iter = runIdentity $ enumLBS s' i
+
testBuffer4 :: Test
testBuffer4 = testProperty "testBuffer4" $
monadicIO $ forAllM arbitrary prop
where
prop s = do
- i <- liftQ $ bufferIteratee (stream2stream >> throwErr (Err "foo"))
- i' <- liftQ $ enumLBS s i
+ (i,_) <- liftQ $ bufferIteratee (stream2stream >> throwErr (Err "foo"))
+ i' <- liftQ $ enumLBS s i
expectException $ run i'
- j <- liftQ $ bufferIteratee (throwErr (Err "foo") >> stream2stream)
- j' <- liftQ $ enumLBS s j
+ (j,_) <- liftQ $ bufferIteratee (throwErr (Err "foo") >> stream2stream)
+ j' <- liftQ $ enumLBS s j
expectException $ run j'
k <- liftQ $ enumErr "foo" j
commit a737d427ab58dcb8ba26022e261dc113dfa5ae4f
Author: Gregory Collins <[email protected]>
Date: Sun May 30 13:39:01 2010 -0400
Bump version number
diff --git a/snap-core.cabal b/snap-core.cabal
index 98982df..66787cb 100644
--- a/snap-core.cabal
+++ b/snap-core.cabal
@@ -1,5 +1,5 @@
name: snap-core
-version: 0.2.5
+version: 0.2.6
synopsis: Snap: A Haskell Web Framework (Core)
description:
-----------------------------------------------------------------------
hooks/post-receive
--
snap-core
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
