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 be952fbd863ea8f463d9fdc3fb2536c4c45261b4 (commit)
from 3bc11b99856a762de3de19200f3a9d56e2d79e18 (commit)
Summary of changes:
src/Snap/Internal/Http/Parser.hs | 10 +++++++---
src/Snap/Internal/Http/Server.hs | 22 +++++++++++++++-------
test/suite/Snap/Internal/Http/Parser/Tests.hs | 3 ++-
test/suite/Snap/Internal/Http/Server/Tests.hs | 8 +++++---
4 files changed, 29 insertions(+), 14 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 be952fbd863ea8f463d9fdc3fb2536c4c45261b4
Author: Gregory Collins <[email protected]>
Date: Sat May 29 16:25:00 2010 -0400
Alloc fewer buffers by creating a persistent per-connection buffer rather
than a per-request buffer.
diff --git a/src/Snap/Internal/Http/Parser.hs b/src/Snap/Internal/Http/Parser.hs
index c165fb2..7fcca6e 100644
--- a/src/Snap/Internal/Http/Parser.hs
+++ b/src/Snap/Internal/Http/Parser.hs
@@ -37,6 +37,8 @@ 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)
@@ -108,10 +110,12 @@ 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 :: Enumerator IO a -> Enumerator IO a
-writeChunkedTransferEncoding enum it = do
+writeChunkedTransferEncoding :: ForeignPtr CChar
+ -> Enumerator IO a
+ -> Enumerator IO a
+writeChunkedTransferEncoding buf enum it = do
i' <- wrap it
- (i,_) <- unsafeBufferIteratee i'
+ (i,_) <- unsafeBufferIterateeWithBuffer buf i'
enum i
where
diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs
index beeb2fc..e734e58 100644
--- a/src/Snap/Internal/Http/Server.hs
+++ b/src/Snap/Internal/Http/Server.hs
@@ -24,6 +24,8 @@ import qualified Data.Map as Map
import Data.Maybe (fromJust, catMaybes, fromMaybe)
import Data.Monoid
import Data.Version
+import Foreign.C.Types
+import Foreign.ForeignPtr
import GHC.Conc
import Prelude hiding (catch, show, Show)
import qualified Prelude
@@ -268,8 +270,9 @@ runHTTP lh lip lp rip rp alog elog
logPrefix = S.concat [ "[", rip, "]: error: " ]
go = do
+ buf <- mkIterateeBuffer
let iter = runServerMonad lh lip lp rip rp (logA alog) (logE elog) $
- httpSession writeEnd onSendFile tickle
+ httpSession writeEnd buf onSendFile tickle
handler
readEnd iter >>= run
@@ -292,13 +295,16 @@ logError s = gets _logError >>= (\l -> liftIO $ l s)
------------------------------------------------------------------------------
-- | Runs an HTTP session.
httpSession :: Iteratee IO () -- ^ write end of socket
+ -> ForeignPtr CChar -- ^ iteratee buffer
-> (FilePath -> IO ()) -- ^ sendfile continuation
-> IO () -- ^ timeout tickler
-> ServerHandler -- ^ handler procedure
-> ServerMonad ()
-httpSession writeEnd' onSendFile tickle handler = do
+httpSession writeEnd' ibuf onSendFile tickle handler = do
+
+ (writeEnd, cancelBuffering) <-
+ liftIO $ I.unsafeBufferIterateeWithBuffer ibuf writeEnd'
- (writeEnd, cancelBuffering) <- liftIO $ I.unsafeBufferIteratee writeEnd'
let killBuffer = writeIORef cancelBuffering True
liftIO $ debug "Server.httpSession: entered"
@@ -328,7 +334,7 @@ httpSession writeEnd' 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 killBuffer onSendFile
+ (bytesSent,_) <- sendResponse rsp' writeEnd ibuf killBuffer
onSendFile
liftIO . debug $ "Server.httpSession: sent " ++
(Prelude.show bytesSent) ++ " bytes"
@@ -339,7 +345,7 @@ httpSession writeEnd' onSendFile tickle handler = do
if cc
then return ()
- else httpSession writeEnd onSendFile tickle handler
+ else httpSession writeEnd ibuf onSendFile tickle handler
Nothing -> return ()
@@ -496,10 +502,11 @@ receiveRequest = do
-- Response must be well-formed here
sendResponse :: Response
-> Iteratee IO a
+ -> ForeignPtr CChar
-> IO ()
-> (FilePath -> IO a)
-> ServerMonad (Int,a)
-sendResponse rsp' writeEnd killBuffering onSendFile = do
+sendResponse rsp' writeEnd ibuf killBuffering onSendFile = do
rsp <- fixupResponse rsp'
let !headerString = mkHeaderString rsp
@@ -549,7 +556,8 @@ sendResponse rsp' writeEnd killBuffering onSendFile = do
then do
liftIO $ killBuffering
let r' = setHeader "Transfer-Encoding" "chunked" r
- let e = writeChunkedTransferEncoding $ rspBodyToEnum $
rspBody r
+ let e = writeChunkedTransferEncoding ibuf $
+ rspBodyToEnum $ rspBody r
return $ r' { rspBody = Enum e }
else do
diff --git a/test/suite/Snap/Internal/Http/Parser/Tests.hs
b/test/suite/Snap/Internal/Http/Parser/Tests.hs
index fb352e1..fea04a2 100644
--- a/test/suite/Snap/Internal/Http/Parser/Tests.hs
+++ b/test/suite/Snap/Internal/Http/Parser/Tests.hs
@@ -145,8 +145,9 @@ testBothChunked = testProperty "chunk . unchunk == id" $
monadicIO $ forAllM arbitrary prop
where
prop s = do
+ buf <- QC.run mkIterateeBuffer
bs <- QC.run $
- writeChunkedTransferEncoding (enumLBS s) stream2stream
+ writeChunkedTransferEncoding buf (enumLBS s) stream2stream
>>= run >>= return . fromWrap
let enum = enumLBS bs
diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs
b/test/suite/Snap/Internal/Http/Server/Tests.hs
index 0296334..568b3c2 100644
--- a/test/suite/Snap/Internal/Http/Server/Tests.hs
+++ b/test/suite/Snap/Internal/Http/Server/Tests.hs
@@ -291,8 +291,10 @@ testHttpResponse1 :: Test
testHttpResponse1 = testCase "HttpResponse1" $ do
let onSendFile = \f -> enumFile f copyingStream2stream >>= run
+ buf <- mkIterateeBuffer
+
b <- run $ rsm $
- sendResponse rsp1 copyingStream2stream (return ()) onSendFile >>=
+ sendResponse rsp1 copyingStream2stream buf (return ()) onSendFile >>=
return . fromWrap . snd
assertEqual "http response" (L.concat [
@@ -303,7 +305,7 @@ testHttpResponse1 = testCase "HttpResponse1" $ do
]) b
b2 <- run $ rsm $
- sendResponse rsp2 copyingStream2stream (return ()) onSendFile >>=
+ sendResponse rsp2 copyingStream2stream buf (return ()) onSendFile >>=
return . fromWrap . snd
assertEqual "http response" (L.concat [
@@ -314,7 +316,7 @@ testHttpResponse1 = testCase "HttpResponse1" $ do
]) b2
b3 <- run $ rsm $
- sendResponse rsp3 copyingStream2stream (return ()) onSendFile >>=
+ sendResponse rsp3 copyingStream2stream buf (return ()) onSendFile >>=
return . fromWrap . snd
assertEqual "http response" b3 $ L.concat [
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
