@@ -26,93 +26,126 @@ import qualified Network.Wai.Handler.Warp.Timeout as T
2626import Network.Wai.Handler.Warp.Types
2727import qualified System.PosixCompat.Files as P
2828
29+----------------------------------------------------------------
2930----------------------------------------------------------------
3031
3132sendResponse :: T.Handle
3233 -> Request -> Connection -> Response -> ResourceT IO Bool
33−sendResponse th req conn r = sendResponse' r
34+
35+----------------------------------------------------------------
36+
37+sendResponse th req conn (ResponseFile s hs fp mpart) =
38+ headerAndLength >>= sendResponse'
3439 where
35− version = httpVersion req
36− isPersist = checkPersist req
37− isChunked' = isChunked version
38− needsChunked hs = isChunked' && not (hasLength hs)
39− isKeepAlive hs = isPersist && (isChunked' || hasLength hs)
40− hasLength hs = isJust $ lookup H.hContentLength hs
41− sendHeader = connSendMany conn . L.toChunks . toLazyByteString
42−
43− sendResponse' :: Response -> ResourceT IO Bool
44− sendResponse' (ResponseFile s hs fp mpart) = do
45− eres <-
46− case (readInt <$> lookup H.hContentLength hs, mpart) of
47− (Just cl, _) -> return $ Right (hs, cl)
48− (Nothing, Nothing) -> liftIO $ try $ do
49− cl <- P.fileSize <$> P.getFileStatus fp
50− return $ addClToHeaders cl
51− (Nothing, Just part) -> do
52− let cl = filePartByteCount part
53− return $ Right $ addClToHeaders cl
54− case eres of
55− Left (_ :: SomeException) -> sendResponse' $ responseLBS
56− H.status404
57− [(H.hContentType, "text/plain")]
58− "File not found"
59− Right (lengthyHeaders, cl) -> liftIO $ do
60− let headers' = L.toChunks . toLazyByteString $ headers version s lengthyHeaders False
61− T.tickle th
62− if hasBody s req then do
63− case mpart of
64− Nothing -> connSendFile conn fp 0 cl (T.tickle th) headers'
65− Just part -> connSendFile conn fp (filePartOffset part) (filePartByteCount part) (T.tickle th) headers'
66− T.tickle th
67− return isPersist
68− else
69− return isPersist
70− where
71− addClToHeaders cl = ((H.hContentLength, B.pack $ show cl):hs, fromIntegral cl)
72−
73− sendResponse' (ResponseBuilder s hs b)
74− | hasBody s req = liftIO $ do
75− toByteStringIO (\bs -> do
76− connSendAll conn bs
77− T.tickle th) body
78− return (isKeepAlive hs)
79− | otherwise = liftIO $ do
80− sendHeader $ headers' False
81− T.tickle th
82− return isPersist
40+ headerAndLength = case (readInt <$> checkLength hs, mpart) of
41+ (Just cl, _) -> return $ Right (hs, cl)
42+ (Nothing, Nothing) -> liftIO . try $ do
43+ cl <- fromIntegral . P.fileSize <$> P.getFileStatus fp
44+ return $ (addLength cl hs, cl)
45+ (Nothing, Just part) -> do
46+ let cl = fromIntegral $ filePartByteCount part
47+ return $ Right $ (addLength cl hs, cl)
48+
49+ sendResponse' (Right (lengthyHeaders, cl))
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'
55+ T.tickle th
56+ return isPersist
57+ | otherwise = liftIO $ do
58+ sendHeader conn $ headers version s hs False -- FIXME
59+ T.tickle th
60+ return isPersist -- FIXME isKeepAlive?
8361 where
84− headers' = headers version s hs
85− needsChunked' = needsChunked hs
86− body = if needsChunked' then
87− headers' needsChunked'
88− `mappend` chunkedTransferEncoding b
89− `mappend` chunkedTransferTerminator
90− else
91− headers' False `mappend` b
92−
93− sendResponse' (ResponseSource s hs bodyFlush)
94− | hasBody s req = do
95− let src = CL.sourceList [headers' needsChunked'] `mappend`
96− (if needsChunked' then body $= chunk else body)
97− src $$ builderToByteString =$ connSink conn th
98− return $ isKeepAlive hs
99− | otherwise = liftIO $ do
100− sendHeader $ headers' False
101− T.tickle th
102− return isPersist
62+ version = httpVersion req
63+ (isPersist,_) = infoFromRequest req
64+ headers' = L.toChunks . toLazyByteString $ headers version s lengthyHeaders False
65+
66+ sendResponse' (Left (_ :: SomeException)) =
67+ sendResponse th req conn notFound
10368 where
104− body = mapOutput (\x -> case x of
105− Flush -> flush
106− Chunk builder -> builder) bodyFlush
107− headers' = headers version s hs
108− -- FIXME perhaps alloca a buffer per thread and reuse that in all
109− -- functions below. Should lessen greatly the GC burden (I hope)
110− needsChunked' = needsChunked hs
111− chunk :: Conduit Builder (ResourceT IO) Builder
112− chunk = await >>= maybe (yield chunkedTransferTerminator) (\x -> yield (chunkedTransferEncoding x) >> chunk)
69+ notFound = responseLBS H.status404 [(H.hContentType, "text/plain")] "File not found"
70+
71+----------------------------------------------------------------
72+
73+sendResponse th req conn (ResponseBuilder s hs b)
74+ | hasBody s req = liftIO $ do
75+ flip toByteStringIO body $ \bs -> do
76+ connSendAll conn bs
77+ T.tickle th
78+ return isKeepAlive
79+ | otherwise = liftIO $ do
80+ sendHeader conn $ headers' False
81+ T.tickle th
82+ return isPersist
83+ 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
91+ version = httpVersion req
92+ reqinfo@(isPersist,_) = infoFromRequest req
93+ (isKeepAlive, needsChunked) = infoFromResponse hs reqinfo
94+
95+----------------------------------------------------------------
96+
97+sendResponse th req conn (ResponseSource s hs bodyFlush)
98+ | hasBody s req = do
99+ let src = CL.sourceList [headers' needsChunked] `mappend`
100+ (if needsChunked then body $= chunk else body)
101+ src $$ builderToByteString =$ connSink conn th
102+ return $ isKeepAlive
103+ | otherwise = liftIO $ do
104+ sendHeader conn $ headers' False
105+ T.tickle th
106+ return isPersist
107+ where
108+ body = mapOutput (\x -> case x of
109+ Flush -> flush
110+ Chunk builder -> builder) bodyFlush
111+ headers' = headers version s hs
112+ -- FIXME perhaps alloca a buffer per thread and reuse that in all
113+ -- functions below. Should lessen greatly the GC burden (I hope)
114+ chunk :: Conduit Builder (ResourceT IO) Builder
115+ chunk = await >>= maybe (yield chunkedTransferTerminator) (\x -> yield (chunkedTransferEncoding x) >> chunk)
116+
117+ version = httpVersion req
118+ reqinfo@(isPersist,_) = infoFromRequest req
119+ (isKeepAlive, needsChunked) = infoFromResponse hs reqinfo
120+
121+----------------------------------------------------------------
122+----------------------------------------------------------------
123+
124+-- | Use 'connSendAll' to send this data while respecting timeout rules.
125+connSink :: Connection -> T.Handle -> Sink B.ByteString (ResourceT IO) ()
126+connSink Connection { connSendAll = send } th =
127+ sink
128+ where
129+ sink = await >>= maybe close push
130+ close = liftIO (T.resume th)
131+ push x = do
132+ liftIO $ T.resume th
133+ liftIO $ send x
134+ liftIO $ T.pause th
135+ sink
136+ -- We pause timeouts before passing control back to user code. This ensures
137+ -- that a timeout will only ever be executed when Warp is in control. We
138+ -- also make sure to resume the timeout after the completion of user code
139+ -- so that we can kill idle connections.
140+
141+sendHeader :: Connection -> Builder -> IO ()
142+sendHeader conn = connSendMany conn . L.toChunks . toLazyByteString
113143
114144----------------------------------------------------------------
115145
146+infoFromRequest :: Request -> (Bool,Bool)
147+infoFromRequest req = (checkPersist req, checkChunk req)
148+
116149checkPersist :: Request -> Bool
117150checkPersist req
118151 | ver == H.http11 = checkPersist11 conn
@@ -127,12 +160,28 @@ checkPersist req
127160 | CI.foldCase x == "keep-alive" = True
128161 checkPersist10 _ = False
129162
130−isChunked :: H.HttpVersion -> Bool
131−isChunked = (==) H.http11
163+checkChunk :: Request -> Bool
164+checkChunk req = httpVersion req == H.http11
165+
166+----------------------------------------------------------------
167+
168+infoFromResponse :: H.ResponseHeaders -> (Bool,Bool) -> (Bool,Bool)
169+infoFromResponse hs (isPersist,isChunked) = (isKeepAlive, needsChunked)
170+ where
171+ needsChunked = isChunked && not hasLength
172+ isKeepAlive = isPersist && (isChunked || hasLength)
173+ hasLength = isJust $ checkLength hs
174+
175+checkLength :: H.ResponseHeaders -> Maybe B.ByteString
176+checkLength = lookup H.hContentLength
177+
178+----------------------------------------------------------------
132179
133180hasBody :: H.Status -> Request -> Bool
134−hasBody s req = s /= H.Status 204 "" && s /= H.status304 &&
135− H.statusCode s >= 200 && requestMethod req /= "HEAD"
181+hasBody s req = s /= H.Status 204 ""
182+ && s /= H.status304
183+ && H.statusCode s >= 200
184+ && requestMethod req /= H.methodHead
136185
137186----------------------------------------------------------------
138187
@@ -145,7 +194,7 @@ transferEncodingBuilder = copyByteString "Transfer-Encoding: chunked\r\n\r\n"
145194colonSpaceBuilder = copyByteString ": "
146195
147196headers :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> Builder
148−headers !httpversion !status !responseHeaders !isChunked' = {-# SCC "headers" #-}
197+headers !httpversion !status !responseHeaders !isChunked = {-# SCC "headers" #-}
149198 let !start = httpBuilder
150199 `mappend` copyByteString
151200 (case httpversion of
@@ -156,8 +205,8 @@ headers !httpversion !status !responseHeaders !isChunked' = {-# SCC "headers" #-
156205 `mappend` spaceBuilder
157206 `mappend` copyByteString (H.statusMessage status)
158207 `mappend` newlineBuilder
159− !start' = foldl' responseHeaderToBuilder start (serverHeader responseHeaders)
160− !end = if isChunked' then transferEncodingBuilder else newlineBuilder
208+ !start' = foldl' responseHeaderToBuilder start (addServerHeader responseHeaders)
209+ !end = if isChunked then transferEncodingBuilder else newlineBuilder
161210 in start' `mappend` end
162211
163212responseHeaderToBuilder :: Builder -> H.Header -> Builder
@@ -169,27 +218,14 @@ responseHeaderToBuilder b (x, y) = b
169218
170219----------------------------------------------------------------
171220
172−-- | Use 'connSendAll' to send this data while respecting timeout rules.
173−connSink :: Connection -> T.Handle -> Sink B.ByteString (ResourceT IO) ()
174−connSink Connection { connSendAll = send } th =
175− sink
176− where
177− sink = await >>= maybe close push
178− close = liftIO (T.resume th)
179− push x = do
180− liftIO $ T.resume th
181− liftIO $ send x
182− liftIO $ T.pause th
183− sink
184− -- We pause timeouts before passing control back to user code. This ensures
185− -- that a timeout will only ever be executed when Warp is in control. We
186− -- also make sure to resume the timeout after the completion of user code
187− -- so that we can kill idle connections.
221+addLength :: Integer -> H.ResponseHeaders -> H.ResponseHeaders
222+addLength cl hdrs = (H.hContentLength, B.pack $ show cl) : hdrs
188223
189−----------------------------------------------------------------
224+addEncodingHeader :: H.ResponseHeaders -> H.ResponseHeaders
225+addEncodingHeader hdrs = (hTransferEncoding, "chunked") : hdrs
190226
191−serverHeader :: H.RequestHeaders -> H.RequestHeaders
192−serverHeader hdrs = case lookup hServer hdrs of
227+addServerHeader :: H.ResponseHeaders -> H.ResponseHeaders
228+addServerHeader hdrs = case lookup hServer hdrs of
193229 Nothing -> warpVersionHeader : hdrs
194230 Just _ -> hdrs
195231