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 6b954db032885d63df10048076ecc47f9deb6e40 (commit)
from e742e100006a8d3cfb534e88e7eaeb1b368aebd8 (commit)
Summary of changes:
src/Snap/Internal/Http/Server.hs | 41 ++++++++++++++----------
test/suite/Snap/Internal/Http/Server/Tests.hs | 26 ++++++++++++----
test/suite/Test/Blackbox.hs | 18 +++++++++++
3 files changed, 62 insertions(+), 23 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 6b954db032885d63df10048076ecc47f9deb6e40
Author: Gregory Collins <[email protected]>
Date: Fri Sep 24 18:23:57 2010 -0400
RFC 2616 Sec 9.4: responses to HEAD requests cannot have response bodies
diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs
index 6ab3b13..1198ce2 100644
--- a/src/Snap/Internal/Http/Server.hs
+++ b/src/Snap/Internal/Http/Server.hs
@@ -384,7 +384,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 onSendFile
+ (bytesSent,_) <- sendResponse req rsp' writeEnd onSendFile
liftIO . debug $ "Server.httpSession: sent " ++
(Prelude.show bytesSent) ++ " bytes"
@@ -604,11 +604,12 @@ receiveRequest = do
------------------------------------------------------------------------------
-- Response must be well-formed here
-sendResponse :: forall a . Response
+sendResponse :: forall a . Request
+ -> Response
-> Iteratee IO a
-> (FilePath -> Int64 -> IO a)
-> ServerMonad (Int64, a)
-sendResponse rsp' writeEnd onSendFile = do
+sendResponse req rsp' writeEnd onSendFile = do
rsp <- fixupResponse rsp'
let !headerString = mkHeaderString rsp
@@ -720,23 +721,29 @@ sendResponse rsp' writeEnd onSendFile = do
--------------------------------------------------------------------------
fixupResponse :: Response -> ServerMonad Response
- fixupResponse r =
- {-# SCC "fixupResponse" #-}
- do
- let r' = updateHeaders (Map.delete "Content-Length") r
+ fixupResponse r = {-# SCC "fixupResponse" #-} do
+ let r' = deleteHeader "Content-Length" r
+
+ let code = rspStatus r'
+
+ let r'' = if code == 204 || code == 304
+ then handle304 r'
+ else r'
- let code = rspStatus r'
+ r''' <- do
+ z <- case (rspBody r'') of
+ (Enum _) -> return r''
+ (SendFile f) -> setFileSize f r''
- let r'' = if code == 204 || code == 304
- then handle304 r'
- else r'
+ case (rspContentLength z) of
+ Nothing -> noCL z
+ (Just sz) -> hasCL sz z
- r''' <- case (rspBody r'') of
- (Enum _) -> return r''
- (SendFile f) -> setFileSize f r''
- case (rspContentLength r''') of
- Nothing -> noCL r'''
- (Just sz) -> hasCL sz r'''
+ -- HEAD requests cannot have bodies
+ if rqMethod req == HEAD
+ then return $ deleteHeader "Transfer-Encoding"
+ $ r''' { rspBody = Enum $ enumBS "" }
+ else return r'''
--------------------------------------------------------------------------
diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs
b/test/suite/Snap/Internal/Http/Server/Tests.hs
index 7181ff7..1ee69aa 100644
--- a/test/suite/Snap/Internal/Http/Server/Tests.hs
+++ b/test/suite/Snap/Internal/Http/Server/Tests.hs
@@ -14,7 +14,7 @@ import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as LC
import Data.ByteString (ByteString)
-import Data.ByteString.Internal (c2w, w2c)
+import Data.ByteString.Internal (c2w)
import Data.Char
import Data.Int
import Data.IORef
@@ -149,6 +149,12 @@ copyingStream2stream = IterateeG (step mempty)
step acc str = return $ Done acc str
+mkRequest :: ByteString -> IO Request
+mkRequest s = do
+ iter <- enumBS s $ liftM fromJust $ rsm receiveRequest
+ run iter
+
+
testHttpRequest1 :: Test
testHttpRequest1 =
testCase "server/HttpRequest1" $ do
@@ -240,7 +246,7 @@ expectException :: IO a -> IO ()
expectException m = do
e <- try m
case e of
- Left (z::SomeException) -> return ()
+ Left (_::SomeException) -> return ()
Right _ -> assertFailure "expected exception, didn't get it"
@@ -384,8 +390,10 @@ testHttpResponse1 :: Test
testHttpResponse1 = testCase "server/HttpResponse1" $ do
let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run
+ req <- mkRequest sampleRequest
+
b <- run $ rsm $
- sendResponse rsp1 copyingStream2stream onSendFile >>=
+ sendResponse req rsp1 copyingStream2stream onSendFile >>=
return . fromWrap . snd
assertEqual "http response" (L.concat [
@@ -408,8 +416,10 @@ testHttpResponse2 :: Test
testHttpResponse2 = testCase "server/HttpResponse2" $ do
let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run
+ req <- mkRequest sampleRequest
+
b2 <- run $ rsm $
- sendResponse rsp2 copyingStream2stream onSendFile >>=
+ sendResponse req rsp2 copyingStream2stream onSendFile >>=
return . fromWrap . snd
assertEqual "http response" (L.concat [
@@ -432,8 +442,10 @@ testHttpResponse3 :: Test
testHttpResponse3 = testCase "server/HttpResponse3" $ do
let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run
+ req <- mkRequest sampleRequest
+
b3 <- run $ rsm $
- sendResponse rsp3 copyingStream2stream onSendFile >>=
+ sendResponse req rsp3 copyingStream2stream onSendFile >>=
return . fromWrap . snd
assertEqual "http response" b3 $ L.concat [
@@ -462,8 +474,10 @@ testHttpResponse4 :: Test
testHttpResponse4 = testCase "server/HttpResponse4" $ do
let onSendFile = \f _ -> enumFile f copyingStream2stream >>= run
+ req <- mkRequest sampleRequest
+
b <- run $ rsm $
- sendResponse rsp1 copyingStream2stream onSendFile >>=
+ sendResponse req rsp1 copyingStream2stream onSendFile >>=
return . fromWrap . snd
assertEqual "http response" (L.concat [
diff --git a/test/suite/Test/Blackbox.hs b/test/suite/Test/Blackbox.hs
index 550c3a2..a74cef9 100644
--- a/test/suite/Test/Blackbox.hs
+++ b/test/suite/Test/Blackbox.hs
@@ -38,6 +38,7 @@ import Test.Common.TestHandler
tests :: Int -> [Test]
tests port = map ($ port) [ testPong
+ , testHeadPong
, testEcho
, testRot13
, testSlowLoris
@@ -72,12 +73,29 @@ doPong port = do
HTTP.getResponseBody rsp
+headPong :: Int -> IO String
+headPong port = do
+ let req = (HTTP.getRequest $
+ "http://localhost:"; ++ show port ++ "/pong")
+ { HTTP.rqMethod = HTTP.HEAD }
+
+ rsp <- HTTP.simpleHTTP req
+
+ HTTP.getResponseBody rsp
+
+
testPong :: Int -> Test
testPong port = testCase "blackbox/pong" $ do
doc <- doPong port
assertEqual "pong response" "PONG" doc
+testHeadPong :: Int -> Test
+testHeadPong port = testCase "blackbox/pong/HEAD" $ do
+ doc <- headPong port
+ assertEqual "pong HEAD response" "" doc
+
+
testEcho :: Int -> Test
testEcho port = testProperty "blackbox/echo" $
monadicIO $ forAllM arbitrary prop
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
