git.iko.soy/typeable/wai
on master help sign in
Header composer tuning.
06f9b0eKazu Yamamoto
warp/Network/Wai/Handler/Warp/Response.hs+35−63
compare with master
unifiedsplit
@@ -2,26 +2,26 @@
2{-# LANGUAGE ScopedTypeVariables #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE BangPatterns #-}
3{-# LANGUAGE BangPatterns #-}
4
4
5−module Network.Wai.Handler.Warp.Response where
5+module Network.Wai.Handler.Warp.Response (
6+ sendResponse
7+ ) where
6
8
7−import Blaze.ByteString.Builder (copyByteString, Builder, toLazyByteString, toByteStringIO, flush)
9+import Blaze.ByteString.Builder (fromByteString, Builder, toByteStringIO, flush)
8−import Blaze.ByteString.Builder.Char8 (fromChar, fromShow)
9import Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTerminator)
10import Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTerminator)
10import Control.Applicative
11import Control.Applicative
11import Control.Exception
12import Control.Exception
12import Control.Monad.IO.Class (MonadIO, liftIO)
13import Control.Monad.IO.Class (MonadIO, liftIO)
13import qualified Data.ByteString.Char8 as B
14import qualified Data.ByteString.Char8 as B
14−import qualified Data.ByteString.Lazy as L
15import qualified Data.CaseInsensitive as CI
15import qualified Data.CaseInsensitive as CI
16import Data.Conduit
16import Data.Conduit
17import Data.Conduit.Blaze (builderToByteString)
17import Data.Conduit.Blaze (builderToByteString)
18import qualified Data.Conduit.List as CL
18import qualified Data.Conduit.List as CL
19−import Data.List (foldl')
20import Data.Maybe (isJust)
19import Data.Maybe (isJust)
21import Data.Monoid (mappend)
20import Data.Monoid (mappend)
22import qualified Network.HTTP.Types as H
21import qualified Network.HTTP.Types as H
23import Network.Wai
22import Network.Wai
24import Network.Wai.Handler.Warp.ReadInt
23import Network.Wai.Handler.Warp.ReadInt
24+import qualified Network.Wai.Handler.Warp.ResponseHeader as RH
25import qualified Network.Wai.Handler.Warp.Timeout as T
25import qualified Network.Wai.Handler.Warp.Timeout as T
26import Network.Wai.Handler.Warp.Types
26import Network.Wai.Handler.Warp.Types
27import qualified System.PosixCompat.Files as P
27import qualified System.PosixCompat.Files as P
@@ -41,27 +41,27 @@ sendResponse th req conn (ResponseFile s hs fp mpart) =
41 (Just cl, _) -> return $ Right (hs, cl)
41 (Just cl, _) -> return $ Right (hs, cl)
42 (Nothing, Nothing) -> liftIO . try $ do
42 (Nothing, Nothing) -> liftIO . try $ do
43 cl <- fromIntegral . P.fileSize <$> P.getFileStatus fp
43 cl <- fromIntegral . P.fileSize <$> P.getFileStatus fp
44− return $ (addLength cl hs, cl)
44+ return (addLength cl hs, cl)
45 (Nothing, Just part) -> do
45 (Nothing, Just part) -> do
46 let cl = fromIntegral $ filePartByteCount part
46 let cl = fromIntegral $ filePartByteCount part
47− return $ Right $ (addLength cl hs, cl)
47+ return $ Right (addLength cl hs, cl)
48
48
49 sendResponse' (Right (lengthyHeaders, cl))
49 sendResponse' (Right (lengthyHeaders, cl))
50 | hasBody s req = liftIO $ do
50 | hasBody s req = liftIO $ do
51− let (beg,end) = case mpart of
52− Nothing -> (0,cl)
53− Just prt -> (filePartOffset prt, filePartByteCount prt)
54− connSendFile conn fp beg end (T.tickle th) headers'
51+ connSendFile conn fp beg end (T.tickle th) [lheader]
55 T.tickle th
52 T.tickle th
56 return isPersist
53 return isPersist
57 | otherwise = liftIO $ do
54 | otherwise = liftIO $ do
58− sendHeader conn $ headers version s hs False -- FIXME
55+ connSendAll conn $ composeHeader version s hs
59 T.tickle th
56 T.tickle th
60 return isPersist -- FIXME isKeepAlive?
57 return isPersist -- FIXME isKeepAlive?
61 where
58 where
59+ (beg,end) = case mpart of
60+ Nothing -> (0,cl)
61+ Just prt -> (filePartOffset prt, filePartByteCount prt)
62+ lheader = composeHeader version s lengthyHeaders
62 version = httpVersion req
63 version = httpVersion req
63 (isPersist,_) = infoFromRequest req
64 (isPersist,_) = infoFromRequest req
64− headers' = L.toChunks . toLazyByteString $ headers version s lengthyHeaders False
65
65
66 sendResponse' (Left (_ :: SomeException)) =
66 sendResponse' (Left (_ :: SomeException)) =
67 sendResponse th req conn notFound
67 sendResponse th req conn notFound
@@ -77,17 +77,15 @@ sendResponse th req conn (ResponseBuilder s hs b)
77 T.tickle th
77 T.tickle th
78 return isKeepAlive
78 return isKeepAlive
79 | otherwise = liftIO $ do
79 | otherwise = liftIO $ do
80− sendHeader conn $ headers' False
80+ connSendAll conn $ composeHeader version s hs
81 T.tickle th
81 T.tickle th
82 return isPersist
82 return isPersist
83 where
83 where
84− headers' = headers version s hs
84+ header = composeHeaderBuilder version s hs needsChunked
85− body = if needsChunked then
85+ body
86− headers' needsChunked
87− `mappend` chunkedTransferEncoding b
86+ | needsChunked = header `mappend` chunkedTransferEncoding b
88− `mappend` chunkedTransferTerminator
87+ `mappend` chunkedTransferTerminator
89− else
88+ | otherwise = header `mappend` b
90− headers' False `mappend` b
91 version = httpVersion req
89 version = httpVersion req
92 reqinfo@(isPersist,_) = infoFromRequest req
90 reqinfo@(isPersist,_) = infoFromRequest req
93 (isKeepAlive, needsChunked) = infoFromResponse hs reqinfo
91 (isKeepAlive, needsChunked) = infoFromResponse hs reqinfo
@@ -96,24 +94,23 @@ sendResponse th req conn (ResponseBuilder s hs b)
96
94
97sendResponse th req conn (ResponseSource s hs bodyFlush)
95sendResponse th req conn (ResponseSource s hs bodyFlush)
98 | hasBody s req = do
96 | hasBody s req = do
99− let src = CL.sourceList [headers' needsChunked] `mappend`
97+ let src = CL.sourceList [header] `mappend` cbody
100− (if needsChunked then body $= chunk else body)
101 src $$ builderToByteString =$ connSink conn th
98 src $$ builderToByteString =$ connSink conn th
102− return $ isKeepAlive
99+ return isKeepAlive
103 | otherwise = liftIO $ do
100 | otherwise = liftIO $ do
104− sendHeader conn $ headers' False
101+ connSendAll conn $ composeHeader version s hs
105 T.tickle th
102 T.tickle th
106 return isPersist
103 return isPersist
107 where
104 where
105+ header = composeHeaderBuilder version s hs needsChunked
108 body = mapOutput (\x -> case x of
106 body = mapOutput (\x -> case x of
109 Flush -> flush
107 Flush -> flush
110 Chunk builder -> builder) bodyFlush
108 Chunk builder -> builder) bodyFlush
111− headers' = headers version s hs
109+ cbody = if needsChunked then body $= chunk else body
112 -- FIXME perhaps alloca a buffer per thread and reuse that in all
110 -- FIXME perhaps alloca a buffer per thread and reuse that in all
113 -- functions below. Should lessen greatly the GC burden (I hope)
111 -- functions below. Should lessen greatly the GC burden (I hope)
114 chunk :: Conduit Builder (ResourceT IO) Builder
112 chunk :: Conduit Builder (ResourceT IO) Builder
115 chunk = await >>= maybe (yield chunkedTransferTerminator) (\x -> yield (chunkedTransferEncoding x) >> chunk)
113 chunk = await >>= maybe (yield chunkedTransferTerminator) (\x -> yield (chunkedTransferEncoding x) >> chunk)
116−
117 version = httpVersion req
114 version = httpVersion req
118 reqinfo@(isPersist,_) = infoFromRequest req
115 reqinfo@(isPersist,_) = infoFromRequest req
119 (isKeepAlive, needsChunked) = infoFromResponse hs reqinfo
116 (isKeepAlive, needsChunked) = infoFromResponse hs reqinfo
@@ -138,9 +135,6 @@ connSink Connection { connSendAll = send } th =
138 -- also make sure to resume the timeout after the completion of user code
135 -- also make sure to resume the timeout after the completion of user code
139 -- so that we can kill idle connections.
136 -- so that we can kill idle connections.
140
137
141−sendHeader :: Connection -> Builder -> IO ()
142−sendHeader conn = connSendMany conn . L.toChunks . toLazyByteString
143−
144----------------------------------------------------------------
138----------------------------------------------------------------
145
139
146infoFromRequest :: Request -> (Bool,Bool)
140infoFromRequest :: Request -> (Bool,Bool)
@@ -185,39 +179,6 @@ hasBody s req = s /= H.Status 204 ""
185
179
186----------------------------------------------------------------
180----------------------------------------------------------------
187
181
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 ": "
195−
196−headers :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> Builder
197−headers !httpversion !status !responseHeaders !isChunked = {-# SCC "headers" #-}
198− let !start = httpBuilder
199− `mappend` copyByteString
200− (case httpversion of
201− H.HttpVersion 1 1 -> "1.1"
202− _ -> "1.0")
203− `mappend` spaceBuilder
204− `mappend` fromShow (H.statusCode status)
205− `mappend` spaceBuilder
206− `mappend` copyByteString (H.statusMessage status)
207− `mappend` newlineBuilder
208− !start' = foldl' responseHeaderToBuilder start (addServerHeader responseHeaders)
209− !end = if isChunked then transferEncodingBuilder else newlineBuilder
210− in start' `mappend` end
211−
212−responseHeaderToBuilder :: Builder -> H.Header -> Builder
213−responseHeaderToBuilder b (x, y) = b
214− `mappend` copyByteString (CI.original x)
215− `mappend` colonSpaceBuilder
216− `mappend` copyByteString y
217− `mappend` newlineBuilder
218−
219−----------------------------------------------------------------
220−
221addLength :: Integer -> H.ResponseHeaders -> H.ResponseHeaders
182addLength :: Integer -> H.ResponseHeaders -> H.ResponseHeaders
222addLength cl hdrs = (H.hContentLength, B.pack $ show cl) : hdrs
183addLength cl hdrs = (H.hContentLength, B.pack $ show cl) : hdrs
223
184
@@ -233,3 +194,14 @@ warpVersionHeader :: H.Header
233warpVersionHeader = (hServer, ver)
194warpVersionHeader = (hServer, ver)
234 where
195 where
235 ver = B.pack $ "Warp/" ++ warpVersion
196 ver = B.pack $ "Warp/" ++ warpVersion
197+
198+----------------------------------------------------------------
199+
200+composeHeader :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> B.ByteString
201+composeHeader version s hs = RH.composeHeader version s (addServerHeader hs)
202+
203+composeHeaderBuilder :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> Builder
204+composeHeaderBuilder ver s hs True =
205+ fromByteString $ composeHeader ver s (addEncodingHeader hs)
206+composeHeaderBuilder ver s hs False =
207+ fromByteString $ composeHeader ver s hs
warp/Network/Wai/Handler/Warp/ResponseHeader.hsnew file+94
@@ -0,0 +1,94 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns #-}
3+
4+module Network.Wai.Handler.Warp.ResponseHeader (composeHeader) where
5+
6+import Control.Monad
7+import Data.ByteString (ByteString)
8+import qualified Data.ByteString as S
9+import Data.ByteString.Internal (ByteString(..), unsafeCreate, memcpy)
10+import qualified Data.CaseInsensitive as CI
11+import Data.List (foldl')
12+import Data.Word (Word8)
13+import Foreign.ForeignPtr
14+import Foreign.Ptr
15+import GHC.Storable
16+import qualified Network.HTTP.Types as H
17+
18+----------------------------------------------------------------
19+
20+composeHeader :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> ByteString
21+composeHeader !httpversion !status !responseHeaders = unsafeCreate len $ \ptr -> do
22+ ptr1 <- copyStatus ptr httpversion status
23+ ptr2 <- copyHeaders ptr1 responseHeaders
24+ void $ copyCRLF ptr2
25+ where
26+ !len = 17 + slen + foldl' fieldLength 0 responseHeaders
27+ fieldLength !l !(k,v) = l + S.length (CI.original k) + S.length v + 4
28+ !slen = S.length $ H.statusMessage status
29+
30+{-# INLINE copy #-}
31+copy :: Ptr Word8 -> ByteString -> IO (Ptr Word8)
32+copy !ptr !(PS fp o l) = withForeignPtr fp $ \p -> do
33+ memcpy ptr (p `plusPtr` o) (fromIntegral l)
34+ return $! ptr `plusPtr` l
35+
36+httpVer11 :: ByteString
37+httpVer11 = "HTTP/1.1 "
38+
39+httpVer10 :: ByteString
40+httpVer10 = "HTTP/1.0 "
41+
42+{-# INLINE copyStatus #-}
43+copyStatus :: Ptr Word8 -> H.HttpVersion -> H.Status -> IO (Ptr Word8)
44+copyStatus !ptr !httpversion !status = do
45+ ptr1 <- copy ptr httpVer
46+ writeWord8OffPtr ptr1 0 (zero + fromIntegral r2)
47+ writeWord8OffPtr ptr1 1 (zero + fromIntegral r1)
48+ writeWord8OffPtr ptr1 2 (zero + fromIntegral r0)
49+ writeWord8OffPtr ptr1 3 spc
50+ ptr2 <- copy (ptr1 `plusPtr` 4) (H.statusMessage status)
51+ copyCRLF ptr2
52+ where
53+ httpVer
54+ | httpversion == H.HttpVersion 1 1 = httpVer11
55+ | otherwise = httpVer10
56+ (q0,r0) = H.statusCode status `divMod` 10
57+ (q1,r1) = q0 `divMod` 10
58+ r2 = q1 `mod` 10
59+
60+{-# INLINE copyHeaders #-}
61+copyHeaders :: Ptr Word8 -> [H.Header] -> IO (Ptr Word8)
62+copyHeaders !ptr [] = return ptr
63+copyHeaders !ptr (h:hs) = do
64+ ptr1 <- copyHeader ptr h
65+ copyHeaders ptr1 hs
66+
67+{-# INLINE copyHeader #-}
68+copyHeader :: Ptr Word8 -> H.Header -> IO (Ptr Word8)
69+copyHeader !ptr (k,v) = do
70+ ptr1 <- copy ptr (CI.original k)
71+ writeWord8OffPtr ptr1 0 colon
72+ writeWord8OffPtr ptr1 1 spc
73+ ptr2 <- copy (ptr1 `plusPtr` 2) v
74+ copyCRLF ptr2
75+
76+{-# INLINE copyCRLF #-}
77+copyCRLF :: Ptr Word8 -> IO (Ptr Word8)
78+copyCRLF !ptr = do
79+ writeWord8OffPtr ptr 0 cr
80+ writeWord8OffPtr ptr 1 lf
81+ return $! ptr `plusPtr` 2
82+
83+zero :: Word8
84+zero = 48
85+spc :: Word8
86+spc = 32
87+colon :: Word8
88+colon = 58
89+cr :: Word8
90+cr = 13
91+lf :: Word8
92+lf = 10
93+
94+
warp/warp.cabal+2
@@ -46,6 +46,7 @@ Library
46 Network.Wai.Handler.Warp.ReadInt
46 Network.Wai.Handler.Warp.ReadInt
47 Network.Wai.Handler.Warp.Request
47 Network.Wai.Handler.Warp.Request
48 Network.Wai.Handler.Warp.Response
48 Network.Wai.Handler.Warp.Response
49+ Network.Wai.Handler.Warp.ResponseHeader
49 Network.Wai.Handler.Warp.Run
50 Network.Wai.Handler.Warp.Run
50 Network.Wai.Handler.Warp.Settings
51 Network.Wai.Handler.Warp.Settings
51 Network.Wai.Handler.Warp.Timeout
52 Network.Wai.Handler.Warp.Timeout
@@ -57,6 +58,7 @@ Library
57 Network.Wai.Handler.Warp.ReadInt
58 Network.Wai.Handler.Warp.ReadInt
58 Network.Wai.Handler.Warp.Request
59 Network.Wai.Handler.Warp.Request
59 Network.Wai.Handler.Warp.Response
60 Network.Wai.Handler.Warp.Response
61+ Network.Wai.Handler.Warp.ResponseHeader
60 Network.Wai.Handler.Warp.Run
62 Network.Wai.Handler.Warp.Run
61 Network.Wai.Handler.Warp.Settings
63 Network.Wai.Handler.Warp.Settings
62 Network.Wai.Handler.Warp.Timeout
64 Network.Wai.Handler.Warp.Timeout