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, blaze-builder has been updated
via d28b2e450ecc4055cdf58830be7889c5d6d4f1f3 (commit)
via 8ae0130c06cd887ef3c19cf5199741001ba6cbdf (commit)
from bed4c438be6baa05fa5a78bf8d9b787324483f2e (commit)
Summary of changes:
src/Snap/Internal/Http/Server.hs | 41 +++++++++++++----------
src/Snap/Internal/Http/Server/Backend.hs | 3 ++
src/Snap/Internal/Http/Server/HttpPort.hs | 4 ++-
src/Snap/Internal/Http/Server/SimpleBackend.hs | 2 +-
test/suite/Snap/Internal/Http/Server/Tests.hs | 24 +++++++-------
test/suite/Test/Blackbox.hs | 8 ++--
6 files changed, 46 insertions(+), 36 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 d28b2e450ecc4055cdf58830be7889c5d6d4f1f3
Author: Gregory Collins <[email protected]>
Date: Mon Dec 27 12:53:06 2010 +0100
All tests pass.
diff --git a/src/Snap/Internal/Http/Server/Backend.hs
b/src/Snap/Internal/Http/Server/Backend.hs
index fe530d6..3791724 100644
--- a/src/Snap/Internal/Http/Server/Backend.hs
+++ b/src/Snap/Internal/Http/Server/Backend.hs
@@ -83,6 +83,9 @@ class ListenSocket a where
data ListenSocket = ListenHttp Socket
| ListenHttps Socket (Ptr Word) (Ptr Word)
+instance Show ListenSocket where
+ show (ListenHttp s) = "ListenHttp (" ++ show s ++ ")"
+ show (ListenHttps s _ _) = "ListenHttps (" ++ show s ++ ")"
------------------------------------------------------------------------------
data NetworkSession = NetworkSession
diff --git a/src/Snap/Internal/Http/Server/HttpPort.hs
b/src/Snap/Internal/Http/Server/HttpPort.hs
index af217f0..0afe39f 100644
--- a/src/Snap/Internal/Http/Server/HttpPort.hs
+++ b/src/Snap/Internal/Http/Server/HttpPort.hs
@@ -26,17 +26,19 @@ import Control.Monad (liftM)
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
#endif
+import Snap.Internal.Debug
import Snap.Internal.Http.Server.Backend
-
------------------------------------------------------------------------------
bindHttp :: ByteString -> Int -> IO ListenSocket
bindHttp bindAddr bindPort = do
sock <- socket AF_INET Stream 0
addr <- getHostAddr bindPort bindAddr
+ debug $ "bindHttp: binding port " ++ show addr
setSocketOption sock ReuseAddr 1
bindSocket sock addr
listen sock 150
+ debug $ "bindHttp: bound socket " ++ show sock
return $ ListenHttp sock
diff --git a/src/Snap/Internal/Http/Server/SimpleBackend.hs
b/src/Snap/Internal/Http/Server/SimpleBackend.hs
index d6747f9..32b1269 100644
--- a/src/Snap/Internal/Http/Server/SimpleBackend.hs
+++ b/src/Snap/Internal/Http/Server/SimpleBackend.hs
@@ -108,7 +108,7 @@ acceptThread :: SessionHandler
acceptThread handler tt elog cpu sock = loop
where
loop = do
- debug $ "acceptThread: calling accept()"
+ debug $ "acceptThread: calling accept() on socket " ++ show sock
(s,addr) <- accept $ Listen.listenSocket sock
debug $ "acceptThread: accepted connection from remote: " ++ show addr
forkOnIO cpu (go s addr `catches` cleanup)
diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs
b/test/suite/Snap/Internal/Http/Server/Tests.hs
index 0b2bf72..1d50557 100644
--- a/test/suite/Snap/Internal/Http/Server/Tests.hs
+++ b/test/suite/Snap/Internal/Http/Server/Tests.hs
@@ -791,7 +791,7 @@ testSendFile = testCase "server/sendFile" $ do
go tid = do
waitabit
- doc <- HTTP.simpleHttp "http://localhost:8123/";
+ doc <- HTTP.simpleHttp "http://127.0.0.1:8123/";
killThread tid
waitabit
@@ -826,7 +826,7 @@ testServerStartupShutdown = testCase
"server/startup/shutdown" $ do
debug $ "testServerStartupShutdown: waiting a bit"
waitabit
debug $ "testServerStartupShutdown: sending http request"
- doc <- HTTP.simpleHttp "http://localhost:8145/";
+ doc <- HTTP.simpleHttp "http://127.0.0.1:8145/";
assertEqual "server" "PONG" doc
debug $ "testServerStartupShutdown: killing thread"
@@ -834,7 +834,7 @@ testServerStartupShutdown = testCase
"server/startup/shutdown" $ do
debug $ "testServerStartupShutdown: kill signal sent to thread"
waitabit
- expectException $ HTTP.simpleHttp "http://localhost:8145/";
+ expectException $ HTTP.simpleHttp "http://127.0.0.1:8145/";
return ()
waitabit = threadDelay $ 2*((10::Int)^(6::Int))
diff --git a/test/suite/Test/Blackbox.hs b/test/suite/Test/Blackbox.hs
index 03b9302..8a58a1f 100644
--- a/test/suite/Test/Blackbox.hs
+++ b/test/suite/Test/Blackbox.hs
@@ -90,7 +90,7 @@ startTestServer port sslport backend = do
doPong :: Bool -> Int -> IO ByteString
doPong ssl port = do
let uri = (if ssl then "https" else "http")
- ++ "://localhost:" ++ show port ++ "/pong"
+ ++ "://127.0.0.1:" ++ show port ++ "/pong"
rsp <- HTTP.simpleHttp uri
return $ S.concat $ L.toChunks rsp
@@ -101,7 +101,7 @@ doPong ssl port = do
-- headPong :: Bool -> Int -> IO ByteString
-- headPong ssl port = do
-- let uri = (if ssl then "https" else "http")
--- ++ "://localhost:" ++ show port ++ "/echo"
+-- ++ "://127.0.0.1:" ++ show port ++ "/echo"
-- req0 <- HTTP.parseUrl uri
@@ -131,7 +131,7 @@ testEcho ssl port name = testProperty (name ++
"/blackbox/echo") $
where
prop txt = do
let uri = (if ssl then "https" else "http")
- ++ "://localhost:" ++ show port ++ "/echo"
+ ++ "://127.0.0.1:" ++ show port ++ "/echo"
req0 <- QC.run $ HTTP.parseUrl uri
let req = req0 { HTTP.requestBody = txt
@@ -150,7 +150,7 @@ testRot13 ssl port name = testProperty (name ++
"/blackbox/rot13") $
where
prop txt = do
let uri = (if ssl then "https" else "http")
- ++ "://localhost:" ++ show port ++ "/rot13"
+ ++ "://127.0.0.1:" ++ show port ++ "/rot13"
req0 <- QC.run $ HTTP.parseUrl uri
let req = req0 { HTTP.requestBody = L.fromChunks [txt]
commit 8ae0130c06cd887ef3c19cf5199741001ba6cbdf
Author: Gregory Collins <[email protected]>
Date: Mon Dec 27 12:11:30 2010 +0100
Get chunked transfer-encoding working
diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs
index 9d2f732..086733f 100644
--- a/src/Snap/Internal/Http/Server.hs
+++ b/src/Snap/Internal/Http/Server.hs
@@ -635,14 +635,15 @@ sendResponse req rsp' buffer writeEnd' onSendFile = do
let enum = if rspTransformingRqBody rsp
then eBuilder
else eBuilder >==>
- mapEnum fromByteString (joinI . I.take 0)
+ mapEnum toByteString fromByteString
+ (joinI . I.take 0)
debug $ "sendResponse: whenEnum: enumerating bytes"
outstep <- lift $ runIteratee $
iterateeDebugWrapper "countBytes writeEnd" $
countBytes writeEnd
- (x,bs) <- mapIter toByteString
+ (x,bs) <- mapIter fromByteString toByteString
(enum $$ joinI $
unsafeBuilderToByteString (return buffer) outstep)
debug $ "sendResponse: whenEnum: " ++ show bs ++
@@ -686,22 +687,19 @@ sendResponse req rsp' buffer writeEnd' onSendFile = do
let (!b',len') = h k ys
in (b `mappend` b', len+len')
- ical [] = (mempty,0)
- ical [y] = (fromByteString y, S.length y)
- ical (y:ys) = let (b,l) = ical ys
- in ( fromByteString y `mappend`
- fromByteString ", " `mappend` b
- , l + S.length y + 2 )
-
- h k ys = ( mconcat [ fromByteString $ unCI k
- , fromByteString ": "
- , b
- , fromByteString "\r\n" ]
- , klen + 4 + l )
+ crlf = fromByteString "\r\n"
+
+ doOne pre plen (b,len) y = ( mconcat [ b
+ , pre
+ , fromByteString y
+ , crlf ]
+ , len + plen + 2 + S.length y )
+
+ h k ys = foldl' (doOne kb klen) (mempty,0) ys
where
k' = unCI k
- klen = S.length k'
- (!b,!l) = ical ys
+ kb = fromByteString k' `mappend` fromByteString ": "
+ klen = S.length k' + 2
--------------------------------------------------------------------------
@@ -715,8 +713,7 @@ sendResponse req rsp' buffer writeEnd' onSendFile = do
let r' = setHeader "Transfer-Encoding" "chunked" r
let origE = rspBodyToEnum $ rspBody r
- let e = mapEnum chunkedTransferEncoding origE >==>
- enumBuilder chunkedTransferTerminator
+ let e = \i -> joinI $ origE $$ chunkIt i
return $! r' { rspBody = Enum e }
@@ -726,6 +723,14 @@ sendResponse req rsp' buffer writeEnd' onSendFile = do
modify $! \s -> s { _forceConnectionClose = True }
return $! setHeader "Connection" "close" r
+ --------------------------------------------------------------------------
+ chunkIt :: forall x . Enumeratee Builder Builder IO x
+ chunkIt = checkDone $ continue . step
+ where
+ step k EOF = k (Chunks [chunkedTransferTerminator]) >>== return
+ step k (Chunks []) = continue $ step k
+ step k (Chunks xs) = k (Chunks [chunkedTransferEncoding $ mconcat xs])
+ >>== chunkIt
--------------------------------------------------------------------------
fixCLIteratee :: Int -- ^ header length
diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs
b/test/suite/Snap/Internal/Http/Server/Tests.hs
index 0cd5f62..0b2bf72 100644
--- a/test/suite/Snap/Internal/Http/Server/Tests.hs
+++ b/test/suite/Snap/Internal/Http/Server/Tests.hs
@@ -432,15 +432,15 @@ testHttpResponse3 = testCase "server/HttpResponse3" $ do
sendResponse req rsp3 buf copyingStream2Stream testOnSendFile >>=
return . snd
- assertEqual "http response" b3 $ L.concat [
- "HTTP/1.1 600 Test\r\n"
- , "Content-Type: text/plain\r\n"
- , "Foo: Bar\r\n"
- , "Transfer-Encoding: chunked\r\n\r\n"
- , "a\r\n"
- , "0123456789\r\n"
- , "0\r\n\r\n"
- ]
+ assertEqual "http response" (L.concat [
+ "HTTP/1.1 600 Test\r\n"
+ , "Content-Type: text/plain\r\n"
+ , "Foo: Bar\r\n"
+ , "Transfer-Encoding: chunked\r\n\r\n"
+ , "000A\r\n"
+ , "0123456789\r\n"
+ , "0\r\n\r\n"
+ ]) b3
where
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
