git.iko.soy/typeable/wai
on master help sign in
General cleanup, Matt's more efficient headers function
commit4030c17d9285cfb23cd30aff09cd559e7e60867f authorMichael Snoyman <michael@snoyman.com> dateFri 14 Jan 2011, 12:41 (16 years ago) parentab5b540
2 files changed+42−28
compare with master
unifiedsplit
Network/Wai/Handler/Warp.hs+37−23 runtests.hs+5−5
Network/Wai/Handler/Warp.hs+37−23
@@ -22,7 +22,7 @@ module Network.Wai.Handler.Warp
2222 , parseRequest
2323#if TEST
2424 , takeLineMax
25− , takeUntilBlank
25+ , takeHeaders
2626 , InvalidRequest (..)
2727#endif
2828 ) where
@@ -59,16 +59,17 @@ import Blaze.ByteString.Builder.HTTP
5959import Blaze.ByteString.Builder
6060 (copyByteString, Builder, toLazyByteString, toByteStringIO)
6161import Blaze.ByteString.Builder.Char8 (fromChar, fromShow)
62−import Data.Monoid (mconcat, mappend)
62+import Data.Monoid (mappend)
6363import Network.Socket.SendFile (sendFile)
6464import Network.Socket.Enumerator (iterSocket)
6565
6666import Control.Monad.IO.Class (liftIO)
6767import System.Timeout (timeout)
6868import Data.Word (Word8)
69+import Data.List (foldl')
6970
7071run :: Port -> Application -> IO ()
71−run port = withSocketsDo .
72+run port = withSocketsDo . -- FIXME should this be called by client user instead?
7273 bracket
7374 (listenOn $ PortNumber $ fromIntegral port)
7475 sClose .
@@ -100,7 +101,7 @@ serveConnection port app conn remoteHost' = do
100101
101102parseRequest :: Port -> SockAddr -> E.Iteratee S.ByteString IO (E.Enumeratee ByteString ByteString IO a, Request)
102103parseRequest port remoteHost' = do
103− headers' <- takeUntilBlank 0 id
104+ headers' <- takeHeaders
104105 parseRequest' port headers' remoteHost'
105106
106107-- FIXME come up with good values here
@@ -182,27 +183,37 @@ parseFirst s = do
182183 let (rpath, qstring) = B.break (== '?') query
183184 in return (method, rpath, qstring, hsecond)
184185 else E.throwError NonHttp
186+{-# INLINE parseFirst #-} -- FIXME is this inline necessary? the function is only called from one place and not exported
187+
188+httpBuilder, spaceBuilder, newlineBuilder, transferEncodingBuilder
189+ , colonSpaceBuilder :: Builder
190+httpBuilder = copyByteString "HTTP/"
191+spaceBuilder = fromChar ' '
192+newlineBuilder = copyByteString "\r\n"
193+transferEncodingBuilder = copyByteString "Transfer-Encoding: chunked\r\n\r\n"
194+colonSpaceBuilder = copyByteString ": "
185195
186196headers :: HttpVersion -> Status -> ResponseHeaders -> Bool -> Builder
187−headers httpversion status responseHeaders isChunked' =
188− copyByteString "HTTP/"
189− `mappend` copyByteString httpversion
190− `mappend` fromChar ' '
191− `mappend` fromShow (statusCode status)
192− `mappend` fromChar ' '
193− `mappend` copyByteString (statusMessage status)
194− `mappend` copyByteString "\r\n"
195− `mappend` mconcat (map go responseHeaders)
196− `mappend`
197− if isChunked'
198− then copyByteString "Transfer-Encoding: chunked\r\n\r\n"
199− else copyByteString "\r\n"
200− where
201− go (x, y) =
202− copyByteString (ciOriginal x)
203− `mappend` copyByteString ": "
204− `mappend` copyByteString y
205− `mappend` copyByteString "\r\n"
197+headers !httpversion !status !responseHeaders !isChunked' = {-# SCC "headers" #-}
198+ let !start = httpBuilder
199+ `mappend` copyByteString httpversion
200+ `mappend` spaceBuilder
201+ `mappend` fromShow (statusCode status)
202+ `mappend` spaceBuilder
203+ `mappend` copyByteString (statusMessage status)
204+ `mappend` newlineBuilder
205+ !start' = foldl' responseHeaderToBuilder start responseHeaders
206+ !end = if isChunked'
207+ then transferEncodingBuilder
208+ else newlineBuilder
209+ in start' `mappend` end
210+
211+responseHeaderToBuilder :: Builder -> (CIByteString, ByteString) -> Builder
212+responseHeaderToBuilder b (x, y) = b
213+ `mappend` (copyByteString $ ciOriginal x)
214+ `mappend` colonSpaceBuilder
215+ `mappend` copyByteString y
216+ `mappend` newlineBuilder
206217
207218isChunked :: HttpVersion -> Bool
208219isChunked = (==) http11
@@ -300,6 +311,9 @@ enumSocket _ _ step = E.returnI step
300311------ The functions below are not warp-specific and could be split out into a
301312--separate package.
302313
314+takeHeaders :: E.Iteratee ByteString IO [ByteString]
315+takeHeaders = takeUntilBlank 0 id
316+
303317takeUntilBlank :: Int
304318 -> ([ByteString] -> [ByteString])
305319 -> E.Iteratee S.ByteString IO [ByteString]
runtests.hs+5−5
@@ -5,7 +5,7 @@ import Test.Framework (defaultMain, testGroup, Test)
55import Test.Framework.Providers.HUnit
66import Test.HUnit hiding (Test)
77
8−import Network.Wai.Handler.Warp (takeLineMax, takeUntilBlank, InvalidRequest (..))
8+import Network.Wai.Handler.Warp (takeLineMax, takeHeaders, InvalidRequest (..))
99import Data.Enumerator (run_, ($$), enumList, run)
1010import Control.Exception (fromException)
1111
@@ -23,7 +23,7 @@ testSuite = testGroup "Text.Hamlet"
2323 ]
2424
2525caseTakeLineMaxSafe = do
26− x <- run_ $ (enumList 1 ["f", "oo\n\n", "bar\n\nbaz\n"]) $$ do
26+ x <- run_ $ (enumList 1 ["f", "oo\n\n", "bar\n\r\nbaz\n"]) $$ do
2727 a <- takeLineMax 0 id
2828 b <- takeLineMax 0 id
2929 c <- takeLineMax 0 id
@@ -33,7 +33,7 @@ caseTakeLineMaxSafe = do
3333 x @?= ("foo", "", "bar", "", "baz")
3434
3535caseTakeUntilBlankSafe = do
36− x <- run_ $ (enumList 1 ["f", "oo\n", "bar\nbaz\n\n"]) $$ takeUntilBlank 0 id
36+ x <- run_ $ (enumList 1 ["f", "oo\n", "bar\nbaz\n\r\n"]) $$ takeHeaders
3737 x @?= ["foo", "bar", "baz"]
3838
3939caseTakeLineMaxUnsafe = do
@@ -63,9 +63,9 @@ caseTakeLineMaxIncomplete = do
6363 assertException IncompleteHeaders x
6464
6565caseTakeUntilBlankTooMany = do
66− x <- run $ (enumList 1 $ repeat "f\n") $$ takeUntilBlank 0 id
66+ x <- run $ (enumList 1 $ repeat "f\n") $$ takeHeaders
6767 assertException TooManyHeaders x
6868
6969caseTakeUntilBlankTooLarge = do
70− x <- run $ (enumList 1 $ repeat "f") $$ takeUntilBlank 0 id
70+ x <- run $ (enumList 1 $ repeat "f") $$ takeHeaders
7171 assertException OverLargeHeader x