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-server".
The branch, master has been updated
via 32b12ba641bdaa71a7a3c215ed9ba03e09f6de98 (commit)
from 7c1cf61568f51eebb762599753708415e46ee8e4 (commit)
Summary of changes:
snap-server.cabal | 2 +-
src/Snap/Internal/Http/Parser.hs | 76 +++++++++++++--------
src/Snap/Internal/Http/Server.hs | 1 +
test/snap-server-testsuite.cabal | 4 +-
test/suite/Snap/Internal/Http/Parser/Tests.hs | 91 +++++++++++++++++++++++--
test/suite/Snap/Internal/Http/Server/Tests.hs | 34 +++++++++-
6 files changed, 170 insertions(+), 38 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 32b12ba641bdaa71a7a3c215ed9ba03e09f6de98
Author: Gregory Collins <[email protected]>
Date: Wed Jun 2 03:34:26 2010 -0400
Some fixes and additional tests for chunked transfer encoding
diff --git a/snap-server.cabal b/snap-server.cabal
index cd61070..d102e1d 100644
--- a/snap-server.cabal
+++ b/snap-server.cabal
@@ -112,7 +112,7 @@ Library
network == 2.2.1.*,
old-locale,
sendfile >= 0.6.1 && < 0.7,
- snap-core >= 0.2.5 && <0.3,
+ snap-core >= 0.2.7 && <0.3,
time,
transformers,
unix-compat,
diff --git a/src/Snap/Internal/Http/Parser.hs b/src/Snap/Internal/Http/Parser.hs
index b0d9215..9037161 100644
--- a/src/Snap/Internal/Http/Parser.hs
+++ b/src/Snap/Internal/Http/Parser.hs
@@ -31,6 +31,7 @@ import qualified Data.ByteString.Nums.Careless.Hex as Cvt
import Data.Char
import Data.List (foldl')
import Data.Int
+import Data.IORef
import Data.Iteratee.WrappedByteString
import Data.Map (Map)
import qualified Data.Map as Map
@@ -71,12 +72,13 @@ parseRequest :: (Monad m) => Iteratee m (Maybe IRequest)
parseRequest = parserToIteratee pRequest
-readChunkedTransferEncoding :: (Monad m) => Enumerator m a
+readChunkedTransferEncoding :: (Monad m) =>
+ Iteratee m a
+ -> m (Iteratee m a)
readChunkedTransferEncoding iter = do
- i <- chunkParserToEnumerator (parserToIteratee pGetTransferChunk)
- iter
-
- return i
+ i <- chunkParserToEnumerator (parserToIteratee pGetTransferChunk)
+ iter
+ return i
toHex :: Int64 -> ByteString
@@ -111,37 +113,53 @@ toHex !i' = S.reverse s
-- >
-- > Chunk "3\r\nfoo\r\n3\r\nbar\r\n4\r\nquux\r\n0\r\n\r\n" Empty
--
+
writeChunkedTransferEncoding :: ForeignPtr CChar
-> Enumerator IO a
-> Enumerator IO a
writeChunkedTransferEncoding _buf enum it = do
- i' <- wrap it
- --(i,_) <- unsafeBufferIterateeWithBuffer buf i'
- (i,_) <- bufferIteratee i'
- enum i
+ killwrap <- newIORef False
+ (out,_) <- bufferIteratee (ignoreEOF $ wrap killwrap it)
+ i <- enum out
+ v <- runIter i (EOF Nothing)
+ j <- checkIfDone return v
+ writeIORef killwrap True
+ -- w <- runIter j (Chunk (WrapBS "0\r\n\r\n"))
+ w <- runIter j (Chunk (WrapBS "0\r\n\r\n"))
+ checkIfDone return w
where
- wrap iter = return $ IterateeG $ \s ->
+ ignoreEOF iter = IterateeG $ \s ->
case s of
- (EOF Nothing) -> do
- v <- runIter iter (Chunk $ toWrap "0\r\n\r\n")
- i <- checkIfDone return v
- runIter i (EOF Nothing)
- (EOF e) -> return $ Cont undefined e
- (Chunk (WrapBS x)) -> do
- let n = S.length x
- if n == 0
- then do
- i' <- wrap iter
- return $ Cont i' Nothing
- else do
- let o = S.concat [ toHex (toEnum n)
- , "\r\n"
- , x
- , "\r\n" ]
- v <- runIter iter (Chunk $ WrapBS o)
- i <- checkIfDone wrap v
- return $ Cont i Nothing
+ (EOF Nothing) -> return $ Cont iter Nothing
+ _ -> do
+ i <- runIter iter s >>= checkIfDone return
+ return $ Cont (ignoreEOF i) Nothing
+
+ wrap killwrap iter = IterateeG $ \s -> do
+ quit <- readIORef killwrap
+
+ if quit
+ then runIter iter s
+ else case s of
+ (EOF Nothing) -> do
+ --S.putStrLn "wrap: eof"
+ return $ Cont iter Nothing
+
+ (EOF e) -> return $ Cont undefined e
+ (Chunk (WrapBS x)) -> do
+ --S.putStrLn $ S.concat ["wrap: got ", x]
+ let n = S.length x
+ if n == 0
+ then do
+ return $ Cont iter Nothing
+ else do
+ let o = S.concat [ toHex (toEnum n)
+ , "\r\n"
+ , x
+ , "\r\n" ]
+ i <- liftM liftI $ runIter iter (Chunk $ WrapBS o)
+ return $ Cont (wrap killwrap i) Nothing
chunkParserToEnumerator :: (Monad m) =>
diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs
index 3cd9e4d..2c9b716 100644
--- a/src/Snap/Internal/Http/Server.hs
+++ b/src/Snap/Internal/Http/Server.hs
@@ -528,6 +528,7 @@ sendResponse rsp' writeEnd ibuf killBuffering onSendFile =
do
whenEnum hs e = do
let enum = enumBS hs >. e
let hl = S.length hs
+
(x,bs) <- liftIO $ enum (countBytes writeEnd) >>= run
return (x, bs-hl)
diff --git a/test/snap-server-testsuite.cabal b/test/snap-server-testsuite.cabal
index bc6650a..fe3d4f4 100644
--- a/test/snap-server-testsuite.cabal
+++ b/test/snap-server-testsuite.cabal
@@ -39,7 +39,7 @@ Executable testsuite
old-locale,
parallel > 2,
iteratee >= 0.3.1 && < 0.4,
- snap-core >= 0.2.1 && <0.3,
+ snap-core >= 0.2.7 && <0.3,
test-framework >= 0.3.1 && <0.4,
test-framework-hunit >= 0.2.5 && < 0.3,
test-framework-quickcheck2 >= 0.2.6 && < 0.3,
@@ -94,7 +94,7 @@ Executable pongserver
network == 2.2.1.7,
network-bytestring >= 0.1.2 && < 0.2,
sendfile >= 0.6.1 && < 0.7,
- snap-core >= 0.2.1 && <0.3,
+ snap-core >= 0.2.7 && <0.3,
time,
transformers,
unix-compat,
diff --git a/test/suite/Snap/Internal/Http/Parser/Tests.hs
b/test/suite/Snap/Internal/Http/Parser/Tests.hs
index fea04a2..275cfb4 100644
--- a/test/suite/Snap/Internal/Http/Parser/Tests.hs
+++ b/test/suite/Snap/Internal/Http/Parser/Tests.hs
@@ -15,6 +15,8 @@ import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Internal (c2w)
+import Data.Iteratee.WrappedByteString
+import Data.List
import qualified Data.Map as Map
import Data.Maybe (isNothing)
import Test.Framework
@@ -28,7 +30,7 @@ import Text.Printf
import Snap.Internal.Http.Parser
import Snap.Internal.Http.Types hiding (Enumerator)
-import Snap.Iteratee
+import Snap.Iteratee hiding (foldl')
import Snap.Test.Common()
@@ -37,6 +39,8 @@ tests = [ testShow
, testCookie
, testChunked
, testBothChunked
+ , testBothChunkedPipelined
+ , testBothChunkedEmpty
, testP2I
, testNull
, testPartial
@@ -147,19 +151,96 @@ testBothChunked = testProperty "chunk . unchunk == id" $
prop s = do
buf <- QC.run mkIterateeBuffer
bs <- QC.run $
- writeChunkedTransferEncoding buf (enumLBS s) stream2stream
- >>= run >>= return . fromWrap
+ writeChunkedTransferEncoding buf (enumBS s) stream2stream
+ >>= run >>= return . unWrap
- let enum = enumLBS bs
+ let enum = enumBS bs
iter <- do
i <- (readChunkedTransferEncoding stream2stream) >>= enum
- return $ liftM fromWrap i
+ return $ liftM unWrap i
x <- run iter
QC.assert $ s == x
+testBothChunkedPipelined :: Test
+testBothChunkedPipelined = testProperty "pipelined chunk . unchunk == id" $
+ monadicIO prop
+ where
+ prop = do
+ sz <- QC.pick (choose (20,4000))
+ s' <- QC.pick $ resize sz arbitrary
+ ntimes <- QC.pick (choose (1,7))
+ --let s' = L.take 2000 $ L.fromChunks $ repeat s
+
+ let e = enumLBS s'
+
+ buf <- QC.run mkIterateeBuffer
+
+ enums <- QC.run $
+ replicateM ntimes
+ (mkIterateeBuffer >>=
+ return . flip writeChunkedTransferEncoding e)
+
+ let mothra = foldl' (>.) (enumBS "") enums
+
+ bs <- QC.run $ mothra stream2stream
+ >>= run >>= return . unWrap
+
+ let e2 = enumBS bs
+
+ let pcrlf = \s -> parserToIteratee $ string "\r\n" >> return s
+
+ iters <- QC.run $
+ replicateM ntimes $
+ readChunkedTransferEncoding stream2stream
+ let godzilla = sequence $ map (>>= pcrlf) iters
+
+ iter <- QC.run $ e2 godzilla
+
+ x <- QC.run $ liftM (map unWrap) $ run iter
+
+ QC.assert $
+ (map (L.fromChunks . (:[])) x) == (replicate ntimes s')
+
+
+
+testBothChunkedEmpty :: Test
+testBothChunkedEmpty = testCase "testBothChunkedEmpty" prop
+ where
+ prop = do
+ let s' = ""
+ let e = enumLBS s'
+
+ let ntimes = 5
+
+ buf <- mkIterateeBuffer
+
+ enums <- replicateM ntimes
+ (mkIterateeBuffer >>=
+ return . flip writeChunkedTransferEncoding e)
+
+ let mothra = foldl' (>.) (enumBS "") enums
+
+ bs <- mothra stream2stream
+ >>= run >>= return . unWrap
+
+ let e2 = enumBS bs
+
+ let pcrlf = \s -> parserToIteratee $ string "\r\n" >> return s
+
+ iters <- replicateM ntimes $
+ readChunkedTransferEncoding stream2stream
+ let godzilla = sequence $ map (>>= pcrlf) iters
+
+ iter <- e2 godzilla
+
+ x <- liftM (map unWrap) $ run iter
+
+ assertBool "empty chunked transfer" $
+ (map (L.fromChunks . (:[])) x) == (replicate ntimes s')
+
testCookie :: Test
testCookie =
diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs
b/test/suite/Snap/Internal/Http/Server/Tests.hs
index 5e66ce3..7b98945 100644
--- a/test/suite/Snap/Internal/Http/Server/Tests.hs
+++ b/test/suite/Snap/Internal/Http/Server/Tests.hs
@@ -36,6 +36,7 @@ import Snap.Internal.Http.Server
import Snap.Iteratee
import Snap.Types
+import Snap.Internal.Iteratee.Debug
import System.IO
@@ -45,6 +46,8 @@ tests = [ testHttpRequest1
, testHttpRequest2
, testHttpRequest3
, testHttpResponse1
+ , testHttpResponse2
+ , testHttpResponse3
, testHttp1
, testHttp2
, testPartialParse
@@ -305,6 +308,21 @@ testHttpResponse1 = testCase "HttpResponse1" $ do
, "0123456789"
]) b
+ where
+ rsp1 = updateHeaders (Map.insert "Foo" ["Bar"]) $
+ setContentLength 10 $
+ setResponseStatus 600 "Test" $
+ modifyResponseBody (>. (enumBS "0123456789")) $
+ setResponseBody return $
+ emptyResponse { rspHttpVersion = (1,0) }
+
+
+testHttpResponse2 :: Test
+testHttpResponse2 = testCase "HttpResponse2" $ do
+ let onSendFile = \f -> enumFile f copyingStream2stream >>= run
+
+ buf <- mkIterateeBuffer
+
b2 <- run $ rsm $
sendResponse rsp2 copyingStream2stream buf (return ()) onSendFile >>=
return . fromWrap . snd
@@ -315,6 +333,21 @@ testHttpResponse1 = testCase "HttpResponse1" $ do
, "Foo: Bar\r\n\r\n"
, "0123456789"
]) b2
+ where
+ rsp1 = updateHeaders (Map.insert "Foo" ["Bar"]) $
+ setContentLength 10 $
+ setResponseStatus 600 "Test" $
+ modifyResponseBody (>. (enumBS "0123456789")) $
+ setResponseBody return $
+ emptyResponse { rspHttpVersion = (1,0) }
+ rsp2 = rsp1 { rspContentLength = Nothing }
+
+
+testHttpResponse3 :: Test
+testHttpResponse3 = testCase "HttpResponse3" $ do
+ let onSendFile = \f -> enumFile f copyingStream2stream >>= run
+
+ buf <- mkIterateeBuffer
b3 <- run $ rsm $
sendResponse rsp3 copyingStream2stream buf (return ()) onSendFile >>=
@@ -338,7 +371,6 @@ testHttpResponse1 = testCase "HttpResponse1" $ do
modifyResponseBody (>. (enumBS "0123456789")) $
setResponseBody return $
emptyResponse { rspHttpVersion = (1,0) }
-
rsp2 = rsp1 { rspContentLength = Nothing }
rsp3 = setContentType "text/plain" $ (rsp2 { rspHttpVersion = (1,1) })
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
