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 ffc57c6a7f1d5dc82fee303d99a3dda3188e2402 (commit)
from 775935eb4a1065a7c4ed32a3d8ae6118dfd3219c (commit)
Summary of changes:
src/Snap/Internal/Http/Parser.hs | 18 ++---
src/Snap/Internal/Http/Server.hs | 49 ++++++++-----
test/suite/Snap/Internal/Http/Parser/Tests.hs | 94 +++++++++++++------------
test/testserver/Main.hs | 9 ++-
4 files changed, 95 insertions(+), 75 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 ffc57c6a7f1d5dc82fee303d99a3dda3188e2402
Author: Gregory Collins <[email protected]>
Date: Fri Sep 3 16:56:06 2010 -0400
Rework iteratee code inside the server to make unsafeDetachRequestBody work
properly
diff --git a/src/Snap/Internal/Http/Parser.hs b/src/Snap/Internal/Http/Parser.hs
index 2b5f588..4eb4810 100644
--- a/src/Snap/Internal/Http/Parser.hs
+++ b/src/Snap/Internal/Http/Parser.hs
@@ -45,7 +45,8 @@ import Prelude hiding (take, takeWhile)
------------------------------------------------------------------------------
import Snap.Internal.Http.Types hiding (Enumerator)
import Snap.Iteratee hiding (take, foldl', filter)
-
+import qualified Snap.Iteratee as I
+import Snap.Internal.Iteratee.Debug
------------------------------------------------------------------------------
@@ -118,14 +119,9 @@ toHex n' = s
-- > Chunk "a\r\nfoobarquux\r\n0\r\n\r\n" Empty
--
writeChunkedTransferEncoding :: Enumerator IO a
- -> Enumerator IO a
-writeChunkedTransferEncoding enum it = do
+writeChunkedTransferEncoding 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
+ return out
where
ignoreEOF iter = IterateeG $ \s ->
@@ -135,7 +131,8 @@ writeChunkedTransferEncoding enum it = do
i <- runIter iter s >>= checkIfDone return
return $ Cont (ignoreEOF i) Nothing
- wrap iter = bufIt (0,D.empty) $ ignoreEOF iter
+ --wrap iter = bufIt (0,D.empty) $ ignoreEOF iter
+ wrap iter = bufIt (0,D.empty) iter
bufSiz = 16284
@@ -162,7 +159,8 @@ writeChunkedTransferEncoding enum it = do
case s of
(EOF Nothing) -> do
i' <- sendOut dl iter
- runIter i' (EOF Nothing)
+ j <- liftM liftI $ runIter i' (Chunk (WrapBS "0\r\n\r\n"))
+ runIter j (EOF Nothing)
(EOF e) -> return $ Cont undefined e
diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs
index 2360a4f..40988ed 100644
--- a/src/Snap/Internal/Http/Server.hs
+++ b/src/Snap/Internal/Http/Server.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Snap.Internal.Http.Server where
@@ -299,9 +300,10 @@ runHTTP lh lip lp rip rp alog elog
go = do
buf <- mkIterateeBuffer
- let iter = runServerMonad lh lip lp rip rp (logA alog) (logE elog) $
- httpSession writeEnd buf onSendFile tickle
- handler
+ let iter1 = runServerMonad lh lip lp rip rp (logA alog) (logE elog) $
+ httpSession writeEnd buf onSendFile tickle
+ handler
+ let iter = iterateeDebugWrapper "httpSession iteratee" iter1
readEnd iter >>= run
@@ -335,11 +337,15 @@ httpSession :: Iteratee IO () -- ^ write
end of socket
-> ServerMonad ()
httpSession writeEnd' ibuf onSendFile tickle handler = do
- writeEnd <- liftIO $ I.unsafeBufferIterateeWithBuffer ibuf writeEnd'
+ writeEnd1 <- liftIO $ I.unsafeBufferIterateeWithBuffer ibuf writeEnd'
+
+ let writeEnd = iterateeDebugWrapper "writeEnd" writeEnd1
liftIO $ debug "Server.httpSession: entered"
mreq <- receiveRequest
+
+
-- successfully got a request, so restart timer
liftIO tickle
@@ -354,6 +360,7 @@ httpSession writeEnd' ibuf onSendFile tickle handler = do
checkExpect100Continue req writeEnd
logerr <- gets _logError
+
(req',rspOrig) <- lift $ handler logerr req
liftIO $ debug $ "Server.httpSession: finished running user handler"
@@ -367,9 +374,11 @@ httpSession writeEnd' ibuf onSendFile tickle handler = do
else rspTmp
liftIO $ debug "Server.httpSession: handled, skipping request body"
+
srqEnum <- liftIO $ readIORef $ rqBody req'
let (SomeEnumerator rqEnum) = srqEnum
- lift $ joinIM $ rqEnum skipToEof
+ lift $ joinIM
+ $ rqEnum (iterateeDebugWrapper "httpSession/skipToEof"
skipToEof)
liftIO $ debug $ "Server.httpSession: request body skipped, " ++
"sending response"
@@ -464,13 +473,13 @@ receiveRequest = do
hasContentLength :: Int -> ServerMonad ()
hasContentLength l = do
liftIO $ debug $ "receiveRequest/setEnumerator: " ++
- "request had content-length"
+ "request had content-length " ++ Prelude.show l
liftIO $ writeIORef (rqBody req) (SomeEnumerator e)
liftIO $ debug "receiveRequest/setEnumerator: body enumerator set"
where
e :: Enumerator IO a
- e = return . joinI . I.take l .
- iterateeDebugWrapper "rqBody iterator"
+ e it = return $ joinI $ I.take l $
+ iterateeDebugWrapper "rqBody iterator" it
noContentLength :: ServerMonad ()
noContentLength = do
@@ -596,7 +605,7 @@ receiveRequest = do
------------------------------------------------------------------------------
-- Response must be well-formed here
-sendResponse :: Response
+sendResponse :: forall a . Response
-> Iteratee IO a
-> (FilePath -> Int64 -> IO a)
-> ServerMonad (Int64, a)
@@ -605,18 +614,18 @@ sendResponse rsp' writeEnd onSendFile = do
let !headerString = mkHeaderString rsp
(!x,!bs) <- case (rspBody rsp) of
- (Enum e) -> liftIO $ whenEnum headerString e
- (SendFile f) -> liftIO $ whenSendFile headerString rsp f
+ (Enum e) -> lift $ whenEnum headerString e
+ (SendFile f) -> lift $ whenSendFile headerString rsp f
return $! (bs,x)
where
--------------------------------------------------------------------------
+ whenEnum :: ByteString -> (forall x . Enumerator IO x) -> Iteratee IO
(a,Int64)
whenEnum hs e = do
- let enum = enumBS hs >. e
+ let enum = enumBS hs >. e >. enumEof
let hl = fromIntegral $ S.length hs
-
- (x,bs) <- liftIO $ enum (countBytes writeEnd) >>= run
+ (x,bs) <- joinIM $ enum (countBytes writeEnd)
return (x, bs-hl)
@@ -624,10 +633,10 @@ sendResponse rsp' writeEnd onSendFile = do
--------------------------------------------------------------------------
whenSendFile hs r f = do
-- guaranteed to have a content length here.
- enumBS hs writeEnd >>= run
+ joinIM $ (enumBS hs >. enumEof) writeEnd
let !cl = fromJust $ rspContentLength r
- x <- onSendFile f cl
+ x <- liftIO $ onSendFile f cl
return (x, cl)
@@ -657,8 +666,10 @@ sendResponse rsp' writeEnd onSendFile = do
if sendChunked
then do
let r' = setHeader "Transfer-Encoding" "chunked" r
- let e = writeChunkedTransferEncoding $
- rspBodyToEnum $ rspBody r
+ let origE = rspBodyToEnum $ rspBody r
+
+ let e i = writeChunkedTransferEncoding i >>= origE
+
return $ r' { rspBody = Enum e }
else do
@@ -682,7 +693,7 @@ sendResponse rsp' writeEnd onSendFile = do
return $ r' { rspBody = b }
where
- i :: Enumerator IO a -> Enumerator IO a
+ i :: forall a . Enumerator IO a -> Enumerator IO a
i enum iter = enum (joinI $ takeExactly cl iter)
diff --git a/test/suite/Snap/Internal/Http/Parser/Tests.hs
b/test/suite/Snap/Internal/Http/Parser/Tests.hs
index e700a8c..f96a470 100644
--- a/test/suite/Snap/Internal/Http/Parser/Tests.hs
+++ b/test/suite/Snap/Internal/Http/Parser/Tests.hs
@@ -20,6 +20,7 @@ import Data.Iteratee.WrappedByteString
import Data.List
import qualified Data.Map as Map
import Data.Maybe (isNothing)
+import Data.Monoid
import Test.Framework
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2
@@ -32,6 +33,7 @@ import Text.Printf
import Snap.Internal.Http.Parser
import Snap.Internal.Http.Types hiding (Enumerator)
import Snap.Iteratee hiding (foldl')
+import qualified Snap.Iteratee as I
import Snap.Test.Common()
@@ -41,7 +43,6 @@ tests = [ testShow
, testChunked
, testBothChunked
, testBothChunkedBuffered1
- , testBothChunkedBuffered2
, testBothChunkedPipelined
, testBothChunkedEmpty
, testP2I
@@ -152,8 +153,10 @@ testBothChunked = testProperty "chunk . unchunk == id" $
monadicIO $ forAllM arbitrary prop
where
prop s = do
+ it <- QC.run $ writeChunkedTransferEncoding stream2stream
+
bs <- QC.run $
- writeChunkedTransferEncoding (enumBS s) stream2stream
+ enumBS s it
>>= run >>= return . unWrap
let enum = enumBS bs
@@ -167,7 +170,7 @@ testBothChunked = testProperty "chunk . unchunk == id" $
testBothChunkedBuffered1 :: Test
-testBothChunkedBuffered1 = testProperty "testBothChunkedBuffered1" $
+testBothChunkedBuffered1 = testProperty "testBothChunkedBuffered2" $
monadicIO prop
where
prop = do
@@ -176,52 +179,42 @@ testBothChunkedBuffered1 = testProperty
"testBothChunkedBuffered1" $
ntimes <- QC.pick (choose (4,7))
let e = enumLBS s'
+ let n = fromEnum $ L.length s'
- let enums = replicate ntimes (writeChunkedTransferEncoding e)
-
- let mothra = foldl' (>.) (enumBS "") enums
-
- ----------------------------------------------------------------------
- -- first go, buffer, no cancellation
- (inputIter1,_) <- QC.run $ bufferIteratee stream2stream
- bs1 <- QC.run $ mothra inputIter1
- >>= run >>= return . unWrap
- let e1 = enumBS bs1
- let pcrlf = \s -> parserToIteratee $ string "\r\n" >> return s
- iters <- QC.run $
- replicateM ntimes $
- readChunkedTransferEncoding stream2stream
- let godzilla = sequence $ map (>>= pcrlf) iters
- outiter1 <- QC.run $ e1 godzilla
- x1 <- QC.run $ liftM (map unWrap) $ run outiter1
-
- QC.assert $
- (map (L.fromChunks . (:[])) x1) == (replicate ntimes s')
-
-
+ let enum = foldl' (>.) (enumBS "") (replicate ntimes e)
-testBothChunkedBuffered2 :: Test
-testBothChunkedBuffered2 = testProperty "testBothChunkedBuffered2" $
- monadicIO prop
- where
- prop = do
- sz <- QC.pick (choose (1000,4000))
- s' <- QC.pick $ resize sz arbitrary
- ntimes <- QC.pick (choose (4,7))
+ (bufi,_) <- QC.run $ bufferIteratee stream2stream
+ iter' <- QC.run $ writeChunkedTransferEncoding bufi
+ let iter = I.joinI $ I.take n iter'
+ let iters = replicate ntimes iter
- let e = enumLBS s'
+ let mothra = foldM (\s it -> it >>= \t -> return $ s `mappend` t)
+ mempty
+ iters
- let enums = replicate ntimes (writeChunkedTransferEncoding e)
+ bs <- QC.run $ enum mothra
+ >>= run >>= return . unWrap
- let mothra = foldl' (>.) (enumBS "") enums
----------------------------------------------------------------------
-- 2nd pass, cancellation
let pcrlf = \s -> parserToIteratee $ string "\r\n" >> return s
(inputIter2,esc) <- QC.run $ bufferIteratee stream2stream
QC.run $ writeIORef esc True
- bs2 <- QC.run $ mothra inputIter2
+
+ iter2' <- QC.run $ writeChunkedTransferEncoding inputIter2
+ let iter2 = I.joinI $ I.take n iter2'
+ let iters2 = replicate ntimes iter2
+
+ let mothra2 = foldM (\s it -> it >>= \t -> return $ s `mappend` t)
+ mempty
+ iters2
+
+
+ bs2 <- QC.run $ enum mothra2
>>= run >>= return . unWrap
+
+
let e2 = enumBS bs2
iters' <- QC.run $
replicateM ntimes $
@@ -246,14 +239,21 @@ testBothChunkedPipelined = testProperty
"testBothChunkedPipelined" $
--let s' = L.take 2000 $ L.fromChunks $ repeat s
let e = enumLBS s'
+ let n = fromEnum $ L.length s'
- let enums = replicate ntimes (writeChunkedTransferEncoding e)
-
- let mothra = foldl' (>.) (enumBS "") enums
+ let enum = foldl' (>.) (enumBS "") (replicate ntimes e)
(bufi,_) <- QC.run $ bufferIteratee stream2stream
- bs <- QC.run $ mothra bufi
+ iter' <- QC.run $ writeChunkedTransferEncoding bufi
+ let iter = I.joinI $ I.take n iter'
+
+ let iters = replicate ntimes iter
+ let mothra = foldM (\s it -> it >>= \t -> return $ s `mappend` t)
+ mempty
+ iters
+
+ bs <- QC.run $ enum mothra
>>= run >>= return . unWrap
let e2 = enumBS bs
@@ -280,14 +280,20 @@ testBothChunkedEmpty = testCase "testBothChunkedEmpty"
prop
prop = do
let s' = ""
let e = enumLBS s'
+ let n = fromEnum $ L.length s'
let ntimes = 5
+ let enum = foldl' (>.) (enumBS "") (replicate ntimes e)
- let enums = replicate ntimes $ writeChunkedTransferEncoding e
+ iter' <- writeChunkedTransferEncoding stream2stream
+ let iter = I.joinI $ I.take n iter'
- let mothra = foldl' (>.) (enumBS "") enums
+ let iters = replicate ntimes iter
+ let mothra = foldM (\s it -> it >>= \t -> return $ s `mappend` t)
+ mempty
+ iters
- bs <- mothra stream2stream
+ bs <- enum mothra
>>= run >>= return . unWrap
let e2 = enumBS bs
diff --git a/test/testserver/Main.hs b/test/testserver/Main.hs
index 354a78e..6a2d40c 100644
--- a/test/testserver/Main.hs
+++ b/test/testserver/Main.hs
@@ -10,6 +10,9 @@ import Snap.Types
import Snap.Http.Server
import Snap.Util.FileServe
+
+import Snap.Internal.Iteratee.Debug
+
{-
/pong
@@ -35,7 +38,8 @@ echoHandler :: Snap ()
echoHandler = do
unsafeDetachRequestBody >>= \e -> do
let (SomeEnumerator x) = e
- modifyResponse $ setResponseBody x
+ let e' i = x (iterateeDebugWrapper "echoHandler" i)
+ modifyResponse $ setResponseBody e'
responseHandler = do
@@ -69,6 +73,7 @@ main = do
where
go m = do
- httpServe "*" 3000 "localhost" Nothing Nothing handlers
+ httpServe "*" 3000 "localhost" (Just "ts-access.log")
+ (Just "ts-error.log") handlers
putMVar m ()
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
