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 4189776a348d36a0401dc2921562f66517c59f5c (commit)
from 077dd3e34a176b3154e9087bd795486390345cdd (commit)
Summary of changes:
src/Snap/Internal/Http/Parser.hs | 7 ++--
src/Snap/Internal/Http/Server.hs | 17 +++++++---
test/suite/Snap/Internal/Http/Server/Tests.hs | 43 ++++++++++++++++++------
3 files changed, 47 insertions(+), 20 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 4189776a348d36a0401dc2921562f66517c59f5c
Author: Gregory Collins <[email protected]>
Date: Wed May 26 23:43:24 2010 -0400
Return an 'escape value' from unsafeBufferIteratee
diff --git a/src/Snap/Internal/Http/Parser.hs b/src/Snap/Internal/Http/Parser.hs
index 4c2575a..c165fb2 100644
--- a/src/Snap/Internal/Http/Parser.hs
+++ b/src/Snap/Internal/Http/Parser.hs
@@ -110,8 +110,8 @@ toHex !i' = S.reverse s
--
writeChunkedTransferEncoding :: Enumerator IO a -> Enumerator IO a
writeChunkedTransferEncoding enum it = do
- i' <- wrap it
- i <- unsafeBufferIteratee i'
+ i' <- wrap it
+ (i,_) <- unsafeBufferIteratee i'
enum i
where
@@ -122,8 +122,7 @@ writeChunkedTransferEncoding enum it = do
i <- checkIfDone return v
runIter i (EOF Nothing)
(EOF e) -> return $ Cont undefined e
- (Chunk x') -> do
- let x = S.concat $ L.toChunks $ fromWrap x'
+ (Chunk (WrapBS x)) -> do
let n = S.length x
if n == 0
then do
diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs
index 5b253ac..47c7eca 100644
--- a/src/Snap/Internal/Http/Server.hs
+++ b/src/Snap/Internal/Http/Server.hs
@@ -165,7 +165,7 @@ httpServe bindAddress bindPort localHostname alogPath
elogPath handler =
{-# SCC "httpServe/runOne" #-} do
debug "Server.httpServe.runOne: entered"
let readEnd = Backend.getReadEnd conn
- writeEnd <- I.unsafeBufferIteratee $ Backend.getWriteEnd conn
+ let writeEnd = Backend.getWriteEnd conn
let raddr = Backend.getRemoteAddr conn
let rport = Backend.getRemotePort conn
@@ -173,7 +173,8 @@ httpServe bindAddress bindPort localHostname alogPath
elogPath handler =
let lport = Backend.getLocalPort conn
runHTTP localHostname laddr lport raddr rport
- alog elog readEnd writeEnd (Backend.sendFile conn)
+ alog elog readEnd writeEnd
+ (Backend.sendFile conn)
(Backend.tickleTimeout conn) handler
debug "Server.httpServe.runHTTP: finished"
@@ -294,7 +295,11 @@ httpSession :: Iteratee IO () -- ^ write end of
socket
-> IO () -- ^ timeout tickler
-> ServerHandler -- ^ handler procedure
-> ServerMonad ()
-httpSession writeEnd onSendFile tickle handler = do
+httpSession writeEnd' onSendFile tickle handler = do
+
+ (writeEnd, cancelBuffering) <- liftIO $ I.unsafeBufferIteratee writeEnd'
+ let killBuffer = writeIORef cancelBuffering True
+
liftIO $ debug "Server.httpSession: entered"
mreq <- receiveRequest
-- successfully got a request, so restart timer
@@ -322,7 +327,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 onSendFile
+ (bytesSent,_) <- sendResponse rsp' writeEnd killBuffer onSendFile
liftIO . debug $ "Server.httpSession: sent " ++
(Prelude.show bytesSent) ++ " bytes"
@@ -490,9 +495,10 @@ receiveRequest = do
-- Response must be well-formed here
sendResponse :: Response
-> Iteratee IO a
+ -> IO ()
-> (FilePath -> IO a)
-> ServerMonad (Int,a)
-sendResponse rsp' writeEnd onSendFile = do
+sendResponse rsp' writeEnd killBuffering onSendFile = do
rsp <- fixupResponse rsp'
let !headerString = mkHeaderString rsp
@@ -540,6 +546,7 @@ sendResponse rsp' writeEnd onSendFile = do
let sendChunked = (rspHttpVersion r) == (1,1)
if sendChunked
then do
+ liftIO $ killBuffering
let r' = setHeader "Transfer-Encoding" "chunked" r
let e = writeChunkedTransferEncoding $ rspBodyToEnum $
rspBody r
return $ r' { rspBody = Enum e }
diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs
b/test/suite/Snap/Internal/Http/Server/Tests.hs
index d7d7351..0296334 100644
--- a/test/suite/Snap/Internal/Http/Server/Tests.hs
+++ b/test/suite/Snap/Internal/Http/Server/Tests.hs
@@ -15,10 +15,13 @@ import Data.ByteString (ByteString)
import Data.ByteString.Internal (c2w, w2c)
import Data.Char
import Data.IORef
+import Data.Iteratee.WrappedByteString
import qualified Data.Map as Map
import Data.Maybe (fromJust)
+import Data.Monoid
import Data.Time.Calendar
import Data.Time.Clock
+import Data.Word
import qualified Network.HTTP as HTTP
import Prelude hiding (take)
import qualified Prelude
@@ -81,6 +84,21 @@ testMethodParsing =
where
ms = [ GET, HEAD, POST, PUT, DELETE, TRACE, OPTIONS, CONNECT ]
+
+copyingStream2stream :: Iteratee IO (WrappedByteString Word8)
+copyingStream2stream = IterateeG (step mempty)
+ where
+ step acc (Chunk (WrapBS ls))
+ | S.null ls = return $ Cont (IterateeG (step acc)) Nothing
+ | otherwise = do
+ let !ls' = S.copy ls
+ let !bs' = WrapBS $! ls'
+ return $ Cont (IterateeG (step (acc `mappend` bs')))
+ Nothing
+
+ step acc str = return $ Done acc str
+
+
testHttpRequest1 :: Test
testHttpRequest1 =
testCase "HttpRequest1" $ do
@@ -89,7 +107,7 @@ testHttpRequest1 =
r <- liftM fromJust $ rsm receiveRequest
se <- liftIO $ readIORef (rqBody r)
let (SomeEnumerator e) = se
- b <- liftM fromWrap $ joinIM $ e stream2stream
+ b <- liftM fromWrap $ joinIM $ e copyingStream2stream
return (r,b)
(req,body) <- run iter
@@ -132,11 +150,11 @@ testMultiRequest =
r1 <- liftM fromJust $ rsm receiveRequest
se1 <- liftIO $ readIORef (rqBody r1)
let (SomeEnumerator e1) = se1
- b1 <- liftM fromWrap $ joinIM $ e1 stream2stream
+ b1 <- liftM fromWrap $ joinIM $ e1 copyingStream2stream
r2 <- liftM fromJust $ rsm receiveRequest
se2 <- liftIO $ readIORef (rqBody r2)
let (SomeEnumerator e2) = se2
- b2 <- liftM fromWrap $ joinIM $ e2 stream2stream
+ b2 <- liftM fromWrap $ joinIM $ e2 copyingStream2stream
return (r1,b1,r2,b2)
(req1,body1,req2,body2) <- run iter
@@ -209,7 +227,7 @@ testHttpRequest2 =
r <- liftM fromJust $ rsm receiveRequest
se <- liftIO $ readIORef (rqBody r)
let (SomeEnumerator e) = se
- b <- liftM fromWrap $ joinIM $ e stream2stream
+ b <- liftM fromWrap $ joinIM $ e copyingStream2stream
return (r,b)
(_,body) <- run iter
@@ -225,7 +243,7 @@ testHttpRequest3 =
r <- liftM fromJust $ rsm receiveRequest
se <- liftIO $ readIORef (rqBody r)
let (SomeEnumerator e) = se
- b <- liftM fromWrap $ joinIM $ e stream2stream
+ b <- liftM fromWrap $ joinIM $ e copyingStream2stream
return (r,b)
(req,body) <- run iter
@@ -271,10 +289,11 @@ rsm = runServerMonad "localhost" "127.0.0.1" 80
"127.0.0.1" 58382 alog elog
testHttpResponse1 :: Test
testHttpResponse1 = testCase "HttpResponse1" $ do
- let onSendFile = \f -> enumFile f stream2stream >>= run
+ let onSendFile = \f -> enumFile f copyingStream2stream >>= run
b <- run $ rsm $
- sendResponse rsp1 stream2stream onSendFile >>= return . fromWrap . snd
+ sendResponse rsp1 copyingStream2stream (return ()) onSendFile >>=
+ return . fromWrap . snd
assertEqual "http response" (L.concat [
"HTTP/1.0 600 Test\r\n"
@@ -284,7 +303,8 @@ testHttpResponse1 = testCase "HttpResponse1" $ do
]) b
b2 <- run $ rsm $
- sendResponse rsp2 stream2stream onSendFile >>= return . fromWrap .
snd
+ sendResponse rsp2 copyingStream2stream (return ()) onSendFile >>=
+ return . fromWrap . snd
assertEqual "http response" (L.concat [
"HTTP/1.0 600 Test\r\n"
@@ -294,7 +314,8 @@ testHttpResponse1 = testCase "HttpResponse1" $ do
]) b2
b3 <- run $ rsm $
- sendResponse rsp3 stream2stream onSendFile >>= return . fromWrap .
snd
+ sendResponse rsp3 copyingStream2stream (return ()) onSendFile >>=
+ return . fromWrap . snd
assertEqual "http response" b3 $ L.concat [
"HTTP/1.1 600 Test\r\n"
@@ -329,7 +350,7 @@ echoServer :: (ByteString -> IO ())
echoServer _ req = do
se <- liftIO $ readIORef (rqBody req)
let (SomeEnumerator enum) = se
- let i = joinIM $ enum stream2stream
+ let i = joinIM $ enum copyingStream2stream
b <- liftM fromWrap i
let cl = L.length b
liftIO $ writeIORef (rqBody req) (SomeEnumerator $ return . joinI . take 0)
@@ -388,7 +409,7 @@ mkIter :: IORef L.ByteString -> (Iteratee IO (), FilePath
-> IO ())
mkIter ref = (iter, \f -> onF f iter)
where
iter = do
- x <- stream2stream
+ x <- copyingStream2stream
liftIO $ modifyIORef ref $ \s -> L.append s (fromWrap x)
onF f i = enumFile f i >>= run
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
