git.iko.soy/typeable/wai
on master help sign in
General cleanup, Matt's more efficient headers function
4030c17Michael Snoyman
Network/Wai/Handler/Warp.hs+37−23
compare with master
unifiedsplit
@@ -22,7 +22,7 @@ module Network.Wai.Handler.Warp
22 , parseRequest
22 , parseRequest
23#if TEST
23#if TEST
24 , takeLineMax
24 , takeLineMax
25− , takeUntilBlank
25+ , takeHeaders
26 , InvalidRequest (..)
26 , InvalidRequest (..)
27#endif
27#endif
28 ) where
28 ) where
@@ -59,16 +59,17 @@ import Blaze.ByteString.Builder.HTTP
59import Blaze.ByteString.Builder
59import Blaze.ByteString.Builder
60 (copyByteString, Builder, toLazyByteString, toByteStringIO)
60 (copyByteString, Builder, toLazyByteString, toByteStringIO)
61import Blaze.ByteString.Builder.Char8 (fromChar, fromShow)
61import Blaze.ByteString.Builder.Char8 (fromChar, fromShow)
62−import Data.Monoid (mconcat, mappend)
62+import Data.Monoid (mappend)
63import Network.Socket.SendFile (sendFile)
63import Network.Socket.SendFile (sendFile)
64import Network.Socket.Enumerator (iterSocket)
64import Network.Socket.Enumerator (iterSocket)
65
65
66import Control.Monad.IO.Class (liftIO)
66import Control.Monad.IO.Class (liftIO)
67import System.Timeout (timeout)
67import System.Timeout (timeout)
68import Data.Word (Word8)
68import Data.Word (Word8)
69+import Data.List (foldl')
69
70
70run :: Port -> Application -> IO ()
71run :: Port -> Application -> IO ()
71−run port = withSocketsDo .
72+run port = withSocketsDo . -- FIXME should this be called by client user instead?
72 bracket
73 bracket
73 (listenOn $ PortNumber $ fromIntegral port)
74 (listenOn $ PortNumber $ fromIntegral port)
74 sClose .
75 sClose .
@@ -100,7 +101,7 @@ serveConnection port app conn remoteHost' = do
100
101
101parseRequest :: Port -> SockAddr -> E.Iteratee S.ByteString IO (E.Enumeratee ByteString ByteString IO a, Request)
102parseRequest :: Port -> SockAddr -> E.Iteratee S.ByteString IO (E.Enumeratee ByteString ByteString IO a, Request)
102parseRequest port remoteHost' = do
103parseRequest port remoteHost' = do
103− headers' <- takeUntilBlank 0 id
104+ headers' <- takeHeaders
104 parseRequest' port headers' remoteHost'
105 parseRequest' port headers' remoteHost'
105
106
106-- FIXME come up with good values here
107-- FIXME come up with good values here
@@ -182,27 +183,37 @@ parseFirst s = do
182 let (rpath, qstring) = B.break (== '?') query
183 let (rpath, qstring) = B.break (== '?') query
183 in return (method, rpath, qstring, hsecond)
184 in return (method, rpath, qstring, hsecond)
184 else E.throwError NonHttp
185 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 ": "
185
195
186headers :: HttpVersion -> Status -> ResponseHeaders -> Bool -> Builder
196headers :: HttpVersion -> Status -> ResponseHeaders -> Bool -> Builder
187−headers httpversion status responseHeaders isChunked' =
197+headers !httpversion !status !responseHeaders !isChunked' = {-# SCC "headers" #-}
188− copyByteString "HTTP/"
198+ let !start = httpBuilder
189− `mappend` copyByteString httpversion
199+ `mappend` copyByteString httpversion
190− `mappend` fromChar ' '
200+ `mappend` spaceBuilder
191− `mappend` fromShow (statusCode status)
201+ `mappend` fromShow (statusCode status)
192− `mappend` fromChar ' '
202+ `mappend` spaceBuilder
193− `mappend` copyByteString (statusMessage status)
203+ `mappend` copyByteString (statusMessage status)
194− `mappend` copyByteString "\r\n"
204+ `mappend` newlineBuilder
195− `mappend` mconcat (map go responseHeaders)
205+ !start' = foldl' responseHeaderToBuilder start responseHeaders
196− `mappend`
197− if isChunked'
206+ !end = if isChunked'
198− then copyByteString "Transfer-Encoding: chunked\r\n\r\n"
207+ then transferEncodingBuilder
199− else copyByteString "\r\n"
208+ else newlineBuilder
200− where
209+ in start' `mappend` end
201− go (x, y) =
210+
202− copyByteString (ciOriginal x)
211+responseHeaderToBuilder :: Builder -> (CIByteString, ByteString) -> Builder
203− `mappend` copyByteString ": "
212+responseHeaderToBuilder b (x, y) = b
213+ `mappend` (copyByteString $ ciOriginal x)
214+ `mappend` colonSpaceBuilder
204− `mappend` copyByteString y
215+ `mappend` copyByteString y
205− `mappend` copyByteString "\r\n"
216+ `mappend` newlineBuilder
206
217
207isChunked :: HttpVersion -> Bool
218isChunked :: HttpVersion -> Bool
208isChunked = (==) http11
219isChunked = (==) http11
@@ -300,6 +311,9 @@ enumSocket _ _ step = E.returnI step
300------ The functions below are not warp-specific and could be split out into a
311------ The functions below are not warp-specific and could be split out into a
301--separate package.
312--separate package.
302
313
314+takeHeaders :: E.Iteratee ByteString IO [ByteString]
315+takeHeaders = takeUntilBlank 0 id
316+
303takeUntilBlank :: Int
317takeUntilBlank :: Int
304 -> ([ByteString] -> [ByteString])
318 -> ([ByteString] -> [ByteString])
305 -> E.Iteratee S.ByteString IO [ByteString]
319 -> E.Iteratee S.ByteString IO [ByteString]
runtests.hs+5−5
@@ -5,7 +5,7 @@ import Test.Framework (defaultMain, testGroup, Test)
5import Test.Framework.Providers.HUnit
5import Test.Framework.Providers.HUnit
6import Test.HUnit hiding (Test)
6import Test.HUnit hiding (Test)
7
7
8−import Network.Wai.Handler.Warp (takeLineMax, takeUntilBlank, InvalidRequest (..))
8+import Network.Wai.Handler.Warp (takeLineMax, takeHeaders, InvalidRequest (..))
9import Data.Enumerator (run_, ($$), enumList, run)
9import Data.Enumerator (run_, ($$), enumList, run)
10import Control.Exception (fromException)
10import Control.Exception (fromException)
11
11
@@ -23,7 +23,7 @@ testSuite = testGroup "Text.Hamlet"
23 ]
23 ]
24
24
25caseTakeLineMaxSafe = do
25caseTakeLineMaxSafe = 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
27 a <- takeLineMax 0 id
27 a <- takeLineMax 0 id
28 b <- takeLineMax 0 id
28 b <- takeLineMax 0 id
29 c <- takeLineMax 0 id
29 c <- takeLineMax 0 id
@@ -33,7 +33,7 @@ caseTakeLineMaxSafe = do
33 x @?= ("foo", "", "bar", "", "baz")
33 x @?= ("foo", "", "bar", "", "baz")
34
34
35caseTakeUntilBlankSafe = do
35caseTakeUntilBlankSafe = 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
37 x @?= ["foo", "bar", "baz"]
37 x @?= ["foo", "bar", "baz"]
38
38
39caseTakeLineMaxUnsafe = do
39caseTakeLineMaxUnsafe = do
@@ -63,9 +63,9 @@ caseTakeLineMaxIncomplete = do
63 assertException IncompleteHeaders x
63 assertException IncompleteHeaders x
64
64
65caseTakeUntilBlankTooMany = do
65caseTakeUntilBlankTooMany = do
66− x <- run $ (enumList 1 $ repeat "f\n") $$ takeUntilBlank 0 id
66+ x <- run $ (enumList 1 $ repeat "f\n") $$ takeHeaders
67 assertException TooManyHeaders x
67 assertException TooManyHeaders x
68
68
69caseTakeUntilBlankTooLarge = do
69caseTakeUntilBlankTooLarge = do
70− x <- run $ (enumList 1 $ repeat "f") $$ takeUntilBlank 0 id
70+ x <- run $ (enumList 1 $ repeat "f") $$ takeHeaders
71 assertException OverLargeHeader x
71 assertException OverLargeHeader x