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 2722cbf1584150dbc99ba692ccfa933be4a1d909 (commit)
from 69705ae80e80fff2100e9645aa7013bbe4f50b3e (commit)
Summary of changes:
snap-server.cabal | 2 +-
src/Snap/Internal/Http/Server.hs | 70 ++++++++++++++++++------
test/suite/Snap/Internal/Http/Server/Tests.hs | 57 ++++++++++++++++++--
3 files changed, 105 insertions(+), 24 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 2722cbf1584150dbc99ba692ccfa933be4a1d909
Author: Gregory Collins <[email protected]>
Date: Sun Mar 20 16:44:11 2011 +0100
Send 411 when PUT/POST requests come in with no content-length
diff --git a/snap-server.cabal b/snap-server.cabal
index 21dae36..f04e383 100644
--- a/snap-server.cabal
+++ b/snap-server.cabal
@@ -118,7 +118,7 @@ Library
murmur-hash >= 0.1 && < 0.2,
network >= 2.3 && <2.4,
old-locale,
- snap-core >= 0.4.1 && <0.5,
+ snap-core >= 0.4.2 && <0.5,
template-haskell,
time,
transformers,
diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs
index 49f0d76..66ec994 100644
--- a/src/Snap/Internal/Http/Server.hs
+++ b/src/Snap/Internal/Http/Server.hs
@@ -1,7 +1,8 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Snap.Internal.Http.Server where
@@ -27,10 +28,11 @@ import Data.IORef
import Data.List (foldl')
import Data.Map (Map)
import qualified Data.Map as Map
-import Data.Maybe (fromJust, catMaybes, fromMaybe)
+import Data.Maybe (catMaybes, fromJust, fromMaybe)
import Data.Monoid
-import Data.Version
import Data.Time
+import Data.Typeable
+import Data.Version
import GHC.Conc
import System.PosixCompat.Files hiding (setFileSize)
import System.Posix.Types (FileOffset)
@@ -88,6 +90,14 @@ data EventLoopType = EventLoopSimple
------------------------------------------------------------------------------
+-- This exception will be thrown if we decided to terminate the request before
+-- running the user handler.
+data TerminatedBeforeHandlerException = TerminatedBeforeHandlerException
+ deriving (Show, Typeable)
+instance Exception TerminatedBeforeHandlerException
+
+
+------------------------------------------------------------------------------
defaultEvType :: EventLoopType
#ifdef LIBEV
defaultEvType = EventLoopLibEv
@@ -250,9 +260,10 @@ runHTTP :: Int -- ^ default
timeout
-> IO ()
runHTTP defaultTimeout alog elog handler lh sinfo readEnd writeEnd onSendFile
tickle =
- go `catches` [ Handler $ \(e :: AsyncException) -> do
+ go `catches` [ Handler $ \(_ :: TerminatedBeforeHandlerException) -> do
+ return ()
+ , Handler $ \(e :: AsyncException) -> do
throwIO e
-
, Handler $ \(e :: SomeException) ->
logE elog $ S.concat [ logPrefix , bshow e ] ]
@@ -310,7 +321,7 @@ httpSession defaultTimeout writeEnd' buffer onSendFile
tickle handler = do
let writeEnd = iterateeDebugWrapper "writeEnd" writeEnd'
liftIO $ debug "Server.httpSession: entered"
- mreq <- receiveRequest
+ mreq <- receiveRequest writeEnd
liftIO $ debug "Server.httpSession: receiveRequest finished"
-- successfully got a request, so restart timer
@@ -408,8 +419,30 @@ checkExpect100Continue req writeEnd = do
------------------------------------------------------------------------------
-receiveRequest :: ServerMonad (Maybe Request)
-receiveRequest = do
+return411 :: Request
+ -> Iteratee ByteString IO ()
+ -> ServerMonad a
+return411 req writeEnd = do
+ go
+ liftIO $ throwIO $ TerminatedBeforeHandlerException
+
+ where
+ go = do
+ let (major,minor) = rqVersion req
+ let hl = mconcat [ fromByteString "HTTP/"
+ , fromShow major
+ , fromWord8 $ c2w '.'
+ , fromShow minor
+ , fromByteString " 411 Length Required\r\n\r\n"
+ , fromByteString "411 Length Required\r\n" ]
+ liftIO $ runIteratee
+ ((enumBS (toByteString hl) >==> enumEOF) $$ writeEnd)
+ return ()
+
+
+------------------------------------------------------------------------------
+receiveRequest :: Iteratee ByteString IO () -> ServerMonad (Maybe Request)
+receiveRequest writeEnd = do
debug "receiveRequest: entered"
mreq <- {-# SCC "receiveRequest/parseRequest" #-} lift $
iterateeDebugWrapper "parseRequest" parseRequest
@@ -469,15 +502,17 @@ receiveRequest = do
joinI $ takeExactly len st'
noContentLength :: Request -> ServerMonad ()
- noContentLength rq = liftIO $ do
+ noContentLength rq = do
debug ("receiveRequest/setEnumerator: " ++
"request did NOT have content-length")
+
+ when (rqMethod rq == POST || rqMethod rq == PUT) $
+ return411 req writeEnd
+
let enum = SomeEnumerator $
- if rqMethod rq == POST || rqMethod rq == PUT
- then returnI
- else iterateeDebugWrapper "noContentLength" .
- joinI . I.take 0
- writeIORef (rqBody rq) enum
+ iterateeDebugWrapper "noContentLength" .
+ joinI . I.take 0
+ liftIO $ writeIORef (rqBody rq) enum
debug "receiveRequest/setEnumerator: body enumerator set"
@@ -543,7 +578,6 @@ receiveRequest = do
-- will override in "setEnumerator"
enum <- liftIO $ newIORef $ SomeEnumerator (enumBS "")
-
return $ Request serverName
serverPort
remoteAddr
diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs
b/test/suite/Snap/Internal/Http/Server/Tests.hs
index a855b5a..43ab0db 100644
--- a/test/suite/Snap/Internal/Http/Server/Tests.hs
+++ b/test/suite/Snap/Internal/Http/Server/Tests.hs
@@ -71,6 +71,7 @@ tests = [ testHttpRequest1
, testHttp1
, testHttp2
, testHttp100
+ , test411
, testExpectGarbage
, testPartialParse
, testMethodParsing
@@ -112,6 +113,14 @@ sampleRequestExpectContinue =
, "\r\n"
, "0123456789" ]
+sampleRequest411 :: ByteString
+sampleRequest411 =
+ S.concat [ "\r\nPOST /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc
HTTP/1.1\r\n"
+ , "Host: www.zabble.com:7777\r\n"
+ , "X-Random-Other-Header: foo\r\n bar\r\n"
+ , "Cookie: foo=\"bar\\\"\"\r\n"
+ , "\r\n" ]
+
sampleRequestExpectGarbage :: ByteString
sampleRequestExpectGarbage =
S.concat [ "\r\nGET /foo/bar.html?param1=abc¶m2=def%20+¶m1=abc
HTTP/1.1\r\n"
@@ -140,17 +149,20 @@ testMethodParsing =
ms = [ GET, HEAD, POST, PUT, DELETE, TRACE, OPTIONS, CONNECT ]
+dummyIter :: Iteratee ByteString IO ()
+dummyIter = consume >> return ()
+
mkRequest :: ByteString -> IO Request
mkRequest s = do
- step <- runIteratee $ liftM fromJust $ rsm receiveRequest
+ step <- runIteratee $ liftM fromJust $ rsm $ receiveRequest dummyIter
let iter = enumBS s step
run_ iter
testReceiveRequest :: Iteratee ByteString IO (Request,L.ByteString)
testReceiveRequest = do
- r <- liftM fromJust $ rsm receiveRequest
+ r <- liftM fromJust $ rsm $ receiveRequest dummyIter
se <- liftIO $ readIORef (rqBody r)
let (SomeEnumerator e) = se
it <- liftM e $ lift $ runIteratee copyingStream2Stream
@@ -230,7 +242,7 @@ testMultiRequest =
testOneMethod :: Method -> IO ()
testOneMethod m = do
- step <- runIteratee $ liftM fromJust $ rsm receiveRequest
+ step <- runIteratee $ liftM fromJust $ rsm $ receiveRequest dummyIter
let iter = enumLBS txt step
req <- run_ iter
@@ -253,7 +265,7 @@ expectException m = do
testPartialParse :: Test
testPartialParse = testCase "server/short" $ do
- step <- runIteratee $ liftM fromJust $ rsm receiveRequest
+ step <- runIteratee $ liftM fromJust $ rsm $ receiveRequest dummyIter
let iter = enumBS sampleShortRequest step
expectException $ run_ iter
@@ -261,7 +273,7 @@ testPartialParse = testCase "server/short" $ do
methodTestText :: Method -> L.ByteString
methodTestText m = L.concat [ (L.pack $ map c2w $ show m)
- , " / HTTP/1.1\r\n\r\n" ]
+ , " / HTTP/1.1\r\nContent-Length: 0\r\n\r\n" ]
sampleRequest2 :: ByteString
@@ -727,6 +739,41 @@ testHttp100 = testCase "server/expect100" $ do
assertBool "100 Continue" ok
+test411 :: Test
+test411 = testCase "server/expect411" $ do
+ let enumBody = enumBS sampleRequest411
+
+ ref <- newIORef ""
+
+ let (iter,onSendFile) = mkIter ref
+
+ runHTTP 60
+ Nothing
+ Nothing
+ echoServer2
+ "localhost"
+ (SessionInfo "127.0.0.1" 80 "127.0.0.1" 58384 False)
+ enumBody
+ iter
+ onSendFile
+ (const $ return ())
+
+ s <- readIORef ref
+
+ let lns = LC.lines s
+
+ let ok = case lns of
+ ("HTTP/1.1 411 Length Required\r":_) -> True
+ _ -> False
+
+ when (not ok) $ do
+ putStrLn "expect411 fail! got:"
+ LC.putStrLn s
+
+ assertBool "411 Length Required" ok
+
+
+
testExpectGarbage :: Test
testExpectGarbage = testCase "server/Expect: garbage" $ do
let enumBody = enumBS sampleRequestExpectGarbage
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
