@@ -2,26 +2,26 @@
22{-# LANGUAGE ScopedTypeVariables #-}
33{-# LANGUAGE BangPatterns #-}
44
5−module Network.Wai.Handler.Warp.Response where
5+module Network.Wai.Handler.Warp.Response (
6+ sendResponse
7+ ) where
68
7−import Blaze.ByteString.Builder (copyByteString, Builder, toLazyByteString, toByteStringIO, flush)
8−import Blaze.ByteString.Builder.Char8 (fromChar, fromShow)
9+import Blaze.ByteString.Builder (fromByteString, Builder, toByteStringIO, flush)
910import Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTerminator)
1011import Control.Applicative
1112import Control.Exception
1213import Control.Monad.IO.Class (MonadIO, liftIO)
1314import qualified Data.ByteString.Char8 as B
14−import qualified Data.ByteString.Lazy as L
1515import qualified Data.CaseInsensitive as CI
1616import Data.Conduit
1717import Data.Conduit.Blaze (builderToByteString)
1818import qualified Data.Conduit.List as CL
19−import Data.List (foldl')
2019import Data.Maybe (isJust)
2120import Data.Monoid (mappend)
2221import qualified Network.HTTP.Types as H
2322import Network.Wai
2423import Network.Wai.Handler.Warp.ReadInt
24+import qualified Network.Wai.Handler.Warp.ResponseHeader as RH
2525import qualified Network.Wai.Handler.Warp.Timeout as T
2626import Network.Wai.Handler.Warp.Types
2727import qualified System.PosixCompat.Files as P
@@ -41,27 +41,27 @@ sendResponse th req conn (ResponseFile s hs fp mpart) =
4141 (Just cl, _) -> return $ Right (hs, cl)
4242 (Nothing, Nothing) -> liftIO . try $ do
4343 cl <- fromIntegral . P.fileSize <$> P.getFileStatus fp
44− return $ (addLength cl hs, cl)
44+ return (addLength cl hs, cl)
4545 (Nothing, Just part) -> do
4646 let cl = fromIntegral $ filePartByteCount part
47− return $ Right $ (addLength cl hs, cl)
47+ return $ Right (addLength cl hs, cl)
4848
4949 sendResponse' (Right (lengthyHeaders, cl))
5050 | 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]
5552 T.tickle th
5653 return isPersist
5754 | otherwise = liftIO $ do
58− sendHeader conn $ headers version s hs False -- FIXME
55+ connSendAll conn $ composeHeader version s hs
5956 T.tickle th
6057 return isPersist -- FIXME isKeepAlive?
6158 where
59+ (beg,end) = case mpart of
60+ Nothing -> (0,cl)
61+ Just prt -> (filePartOffset prt, filePartByteCount prt)
62+ lheader = composeHeader version s lengthyHeaders
6263 version = httpVersion req
6364 (isPersist,_) = infoFromRequest req
64− headers' = L.toChunks . toLazyByteString $ headers version s lengthyHeaders False
6565
6666 sendResponse' (Left (_ :: SomeException)) =
6767 sendResponse th req conn notFound
@@ -77,17 +77,15 @@ sendResponse th req conn (ResponseBuilder s hs b)
7777 T.tickle th
7878 return isKeepAlive
7979 | otherwise = liftIO $ do
80− sendHeader conn $ headers' False
80+ connSendAll conn $ composeHeader version s hs
8181 T.tickle th
8282 return isPersist
8383 where
84− headers' = headers version s hs
85− body = if needsChunked then
86− headers' needsChunked
87− `mappend` chunkedTransferEncoding b
88− `mappend` chunkedTransferTerminator
89− else
90− headers' False `mappend` b
84+ header = composeHeaderBuilder version s hs needsChunked
85+ body
86+ | needsChunked = header `mappend` chunkedTransferEncoding b
87+ `mappend` chunkedTransferTerminator
88+ | otherwise = header `mappend` b
9189 version = httpVersion req
9290 reqinfo@(isPersist,_) = infoFromRequest req
9391 (isKeepAlive, needsChunked) = infoFromResponse hs reqinfo
@@ -96,24 +94,23 @@ sendResponse th req conn (ResponseBuilder s hs b)
9694
9795sendResponse th req conn (ResponseSource s hs bodyFlush)
9896 | hasBody s req = do
99− let src = CL.sourceList [headers' needsChunked] `mappend`
100− (if needsChunked then body $= chunk else body)
97+ let src = CL.sourceList [header] `mappend` cbody
10198 src $$ builderToByteString =$ connSink conn th
102− return $ isKeepAlive
99+ return isKeepAlive
103100 | otherwise = liftIO $ do
104− sendHeader conn $ headers' False
101+ connSendAll conn $ composeHeader version s hs
105102 T.tickle th
106103 return isPersist
107104 where
105+ header = composeHeaderBuilder version s hs needsChunked
108106 body = mapOutput (\x -> case x of
109107 Flush -> flush
110108 Chunk builder -> builder) bodyFlush
111− headers' = headers version s hs
109+ cbody = if needsChunked then body $= chunk else body
112110 -- FIXME perhaps alloca a buffer per thread and reuse that in all
113111 -- functions below. Should lessen greatly the GC burden (I hope)
114112 chunk :: Conduit Builder (ResourceT IO) Builder
115113 chunk = await >>= maybe (yield chunkedTransferTerminator) (\x -> yield (chunkedTransferEncoding x) >> chunk)
116−
117114 version = httpVersion req
118115 reqinfo@(isPersist,_) = infoFromRequest req
119116 (isKeepAlive, needsChunked) = infoFromResponse hs reqinfo
@@ -138,9 +135,6 @@ connSink Connection { connSendAll = send } th =
138135 -- also make sure to resume the timeout after the completion of user code
139136 -- so that we can kill idle connections.
140137
141−sendHeader :: Connection -> Builder -> IO ()
142−sendHeader conn = connSendMany conn . L.toChunks . toLazyByteString
143−
144138----------------------------------------------------------------
145139
146140infoFromRequest :: Request -> (Bool,Bool)
@@ -185,39 +179,6 @@ hasBody s req = s /= H.Status 204 ""
185179
186180----------------------------------------------------------------
187181
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−
221182addLength :: Integer -> H.ResponseHeaders -> H.ResponseHeaders
222183addLength cl hdrs = (H.hContentLength, B.pack $ show cl) : hdrs
223184
@@ -233,3 +194,14 @@ warpVersionHeader :: H.Header
233194warpVersionHeader = (hServer, ver)
234195 where
235196 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