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 12903833b3a130b1eba1ef1fd512e7bc3feb0df4 (commit)
from e59d013ffc19d300cee6270b834ce60225213663 (commit)
Summary of changes:
src/Snap/Internal/Http/Parser.hs | 94 +++++++++++++++----------
src/Snap/Internal/Http/Server.hs | 16 +---
test/suite/Snap/Internal/Http/Parser/Tests.hs | 30 ++-------
test/suite/Snap/Internal/Http/Server/Tests.hs | 16 +---
4 files changed, 69 insertions(+), 87 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 12903833b3a130b1eba1ef1fd512e7bc3feb0df4
Author: Gregory Collins <[email protected]>
Date: Tue Aug 31 16:36:24 2010 -0400
Rework buffering stuff again; chunked transfer encoding overhead should be
significantly lower now
diff --git a/src/Snap/Internal/Http/Parser.hs b/src/Snap/Internal/Http/Parser.hs
index 1db83f0..2b5f588 100644
--- a/src/Snap/Internal/Http/Parser.hs
+++ b/src/Snap/Internal/Http/Parser.hs
@@ -30,9 +30,10 @@ import Data.ByteString.Internal (c2w, w2c)
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Nums.Careless.Hex as Cvt
import Data.Char
+import Data.DList (DList)
+import qualified Data.DList as D
import Data.List (foldl')
import Data.Int
-import Data.IORef
import Data.Iteratee.WrappedByteString
import Data.Map (Map)
import qualified Data.Map as Map
@@ -40,8 +41,6 @@ import Data.Maybe (catMaybes)
import qualified Data.Vector.Unboxed as Vec
import Data.Vector.Unboxed (Vector)
import Data.Word (Word8, Word64)
-import Foreign.C.Types
-import Foreign.ForeignPtr
import Prelude hiding (take, takeWhile)
------------------------------------------------------------------------------
import Snap.Internal.Http.Types hiding (Enumerator)
@@ -98,9 +97,9 @@ toHex n' = s
| n .&. 0xf000000000000000 == 0 = trim (i-1) (n `shiftL` 4)
| otherwise = fst (S.unfoldrN i f n)
- f n = Just (char (n `shiftR` 60), n `shiftL` 4)
+ f n = Just (ch (n `shiftR` 60), n `shiftL` 4)
- char (fromIntegral -> i)
+ ch (fromIntegral -> i)
| i < 10 = (c2w '0' - 0) + i
| otherwise = (c2w 'a' - 10) + i
@@ -118,18 +117,14 @@ toHex n' = s
-- >
-- > Chunk "a\r\nfoobarquux\r\n0\r\n\r\n" Empty
--
-writeChunkedTransferEncoding :: ForeignPtr CChar
+writeChunkedTransferEncoding :: Enumerator IO a
-> Enumerator IO a
- -> Enumerator IO a
-writeChunkedTransferEncoding buf enum it = do
- killwrap <- newIORef False
- (out,_) <- unsafeBufferIterateeWithBuffer buf
- (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"))
+writeChunkedTransferEncoding enum it = do
+ let out = wrap it
+ i <- enum out
+ v <- runIter i (EOF Nothing)
+ j <- checkIfDone return v
+ w <- runIter j (Chunk (WrapBS "0\r\n\r\n"))
checkIfDone return w
where
@@ -140,28 +135,51 @@ writeChunkedTransferEncoding buf enum it = 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
- return $ Cont iter Nothing
-
- (EOF e) -> return $ Cont undefined e
- (Chunk (WrapBS x)) -> do
- 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
+ wrap iter = bufIt (0,D.empty) $ ignoreEOF iter
+
+ bufSiz = 16284
+
+ sendOut :: DList ByteString
+ -> Iteratee IO a
+ -> IO (Iteratee IO a)
+ sendOut dl iter = do
+ let chunks = D.toList dl
+ let bs = L.fromChunks chunks
+ let n = L.length bs
+
+ if n == 0
+ then return iter
+ else do
+ let o = L.concat [ L.fromChunks [ toHex (toEnum . fromEnum $ n)
+ , "\r\n" ]
+ , bs
+ , "\r\n" ]
+
+ enumLBS o iter
+
+
+ bufIt (n,dl) iter = IterateeG $ \s -> do
+ case s of
+ (EOF Nothing) -> do
+ i' <- sendOut dl iter
+ runIter i' (EOF Nothing)
+
+ (EOF e) -> return $ Cont undefined e
+
+ (Chunk (WrapBS x)) -> do
+ let m = S.length x
+
+ if m == 0
+ then return $ Cont (bufIt (n,dl) iter) Nothing
+ else do
+ let n' = m + n
+ let dl' = D.snoc dl x
+
+ if n' > bufSiz
+ then do
+ i' <- sendOut dl' iter
+ return $ Cont (bufIt (0,D.empty) i') Nothing
+ else return $ Cont (bufIt (n',dl') iter) Nothing
------------------------------------------------------------------------------
diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs
index efebca2..2360a4f 100644
--- a/src/Snap/Internal/Http/Server.hs
+++ b/src/Snap/Internal/Http/Server.hs
@@ -335,12 +335,7 @@ httpSession :: Iteratee IO () -- ^ write
end of socket
-> ServerMonad ()
httpSession writeEnd' ibuf onSendFile tickle handler = do
- (writeEnd, cancelBuffering) <-
- liftIO $ I.unsafeBufferIterateeWithBuffer ibuf writeEnd'
-
- -- (writeEnd, cancelBuffering) <- liftIO $ I.bufferIteratee writeEnd'
- let killBuffer = writeIORef cancelBuffering True
-
+ writeEnd <- liftIO $ I.unsafeBufferIterateeWithBuffer ibuf writeEnd'
liftIO $ debug "Server.httpSession: entered"
mreq <- receiveRequest
@@ -381,7 +376,7 @@ httpSession writeEnd' ibuf onSendFile tickle handler = do
date <- liftIO getDateString
let ins = Map.insert "Date" [date] . Map.insert "Server"
sERVER_HEADER
let rsp' = updateHeaders ins rsp
- (bytesSent,_) <- sendResponse rsp' writeEnd ibuf killBuffer
onSendFile
+ (bytesSent,_) <- sendResponse rsp' writeEnd onSendFile
liftIO . debug $ "Server.httpSession: sent " ++
(Prelude.show bytesSent) ++ " bytes"
@@ -603,11 +598,9 @@ receiveRequest = do
-- Response must be well-formed here
sendResponse :: Response
-> Iteratee IO a
- -> ForeignPtr CChar
- -> IO ()
-> (FilePath -> Int64 -> IO a)
-> ServerMonad (Int64, a)
-sendResponse rsp' writeEnd ibuf killBuffering onSendFile = do
+sendResponse rsp' writeEnd onSendFile = do
rsp <- fixupResponse rsp'
let !headerString = mkHeaderString rsp
@@ -663,9 +656,8 @@ sendResponse rsp' writeEnd ibuf killBuffering onSendFile =
do
let sendChunked = (rspHttpVersion r) == (1,1)
if sendChunked
then do
- liftIO $ killBuffering
let r' = setHeader "Transfer-Encoding" "chunked" r
- let e = writeChunkedTransferEncoding ibuf $
+ let e = writeChunkedTransferEncoding $
rspBodyToEnum $ rspBody r
return $ r' { rspBody = Enum e }
diff --git a/test/suite/Snap/Internal/Http/Parser/Tests.hs
b/test/suite/Snap/Internal/Http/Parser/Tests.hs
index 9a571cf..e700a8c 100644
--- a/test/suite/Snap/Internal/Http/Parser/Tests.hs
+++ b/test/suite/Snap/Internal/Http/Parser/Tests.hs
@@ -152,9 +152,8 @@ testBothChunked = testProperty "chunk . unchunk == id" $
monadicIO $ forAllM arbitrary prop
where
prop s = do
- buf <- QC.run mkIterateeBuffer
bs <- QC.run $
- writeChunkedTransferEncoding buf (enumBS s) stream2stream
+ writeChunkedTransferEncoding (enumBS s) stream2stream
>>= run >>= return . unWrap
let enum = enumBS bs
@@ -178,12 +177,7 @@ testBothChunkedBuffered1 = testProperty
"testBothChunkedBuffered1" $
let e = enumLBS s'
- buf <- QC.run mkIterateeBuffer
-
- enums <- QC.run $
- replicateM ntimes
- (mkIterateeBuffer >>=
- return . flip writeChunkedTransferEncoding e)
+ let enums = replicate ntimes (writeChunkedTransferEncoding e)
let mothra = foldl' (>.) (enumBS "") enums
@@ -217,12 +211,7 @@ testBothChunkedBuffered2 = testProperty
"testBothChunkedBuffered2" $
let e = enumLBS s'
- buf <- QC.run mkIterateeBuffer
-
- enums <- QC.run $
- replicateM ntimes
- (mkIterateeBuffer >>=
- return . flip writeChunkedTransferEncoding e)
+ let enums = replicate ntimes (writeChunkedTransferEncoding e)
let mothra = foldl' (>.) (enumBS "") enums
@@ -258,12 +247,7 @@ testBothChunkedPipelined = testProperty
"testBothChunkedPipelined" $
let e = enumLBS s'
- buf <- QC.run mkIterateeBuffer
-
- enums <- QC.run $
- replicateM ntimes
- (mkIterateeBuffer >>=
- return . flip writeChunkedTransferEncoding e)
+ let enums = replicate ntimes (writeChunkedTransferEncoding e)
let mothra = foldl' (>.) (enumBS "") enums
@@ -299,11 +283,7 @@ testBothChunkedEmpty = testCase "testBothChunkedEmpty" prop
let ntimes = 5
- buf <- mkIterateeBuffer
-
- enums <- replicateM ntimes
- (mkIterateeBuffer >>=
- return . flip writeChunkedTransferEncoding e)
+ let enums = replicate ntimes $ writeChunkedTransferEncoding e
let mothra = foldl' (>.) (enumBS "") enums
diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs
b/test/suite/Snap/Internal/Http/Server/Tests.hs
index e8d2d2a..9d7da9a 100644
--- a/test/suite/Snap/Internal/Http/Server/Tests.hs
+++ b/test/suite/Snap/Internal/Http/Server/Tests.hs
@@ -350,10 +350,8 @@ testHttpResponse1 :: Test
testHttpResponse1 = testCase "HttpResponse1" $ do
let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run
- buf <- mkIterateeBuffer
-
b <- run $ rsm $
- sendResponse rsp1 copyingStream2stream buf (return ()) onSendFile >>=
+ sendResponse rsp1 copyingStream2stream onSendFile >>=
return . fromWrap . snd
assertEqual "http response" (L.concat [
@@ -376,10 +374,8 @@ testHttpResponse2 :: Test
testHttpResponse2 = testCase "HttpResponse2" $ do
let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run
- buf <- mkIterateeBuffer
-
b2 <- run $ rsm $
- sendResponse rsp2 copyingStream2stream buf (return ()) onSendFile >>=
+ sendResponse rsp2 copyingStream2stream onSendFile >>=
return . fromWrap . snd
assertEqual "http response" (L.concat [
@@ -402,10 +398,8 @@ testHttpResponse3 :: Test
testHttpResponse3 = testCase "HttpResponse3" $ do
let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run
- buf <- mkIterateeBuffer
-
b3 <- run $ rsm $
- sendResponse rsp3 copyingStream2stream buf (return ()) onSendFile >>=
+ sendResponse rsp3 copyingStream2stream onSendFile >>=
return . fromWrap . snd
assertEqual "http response" b3 $ L.concat [
@@ -434,10 +428,8 @@ testHttpResponse4 :: Test
testHttpResponse4 = testCase "HttpResponse4" $ do
let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run
- buf <- mkIterateeBuffer
-
b <- run $ rsm $
- sendResponse rsp1 copyingStream2stream buf (return ()) onSendFile >>=
+ sendResponse rsp1 copyingStream2stream onSendFile >>=
return . fromWrap . snd
assertEqual "http response" (L.concat [
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
