/
Response.hs
214 lines (183 loc) · 7.91 KB
/
Response.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
module Network.Wai.Handler.Warp.Response (
sendResponse
) where
import Blaze.ByteString.Builder (fromByteString, Builder, toByteStringIO, flush)
import Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTerminator)
import Control.Applicative
import Control.Exception
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B (pack)
import qualified Data.CaseInsensitive as CI
import Data.Conduit
import Data.Conduit.Blaze (builderToByteString)
import qualified Data.Conduit.List as CL
import Data.Maybe (isJust)
import Data.Monoid (mappend)
import qualified Network.HTTP.Types as H
import Network.Wai
import Network.Wai.Handler.Warp.ReadInt
import qualified Network.Wai.Handler.Warp.ResponseHeader as RH
import qualified Network.Wai.Handler.Warp.Timeout as T
import Network.Wai.Handler.Warp.Types
import qualified System.PosixCompat.Files as P
----------------------------------------------------------------
----------------------------------------------------------------
sendResponse :: Cleaner -> Request -> Connection -> Response
-> ResourceT IO Bool
----------------------------------------------------------------
sendResponse cleaner req conn (ResponseFile s hs path mpart) =
headerAndLength >>= sendResponse'
where
th = threadHandle cleaner
headerAndLength = case (readInt <$> checkLength hs, mpart) of
(Just cl, _) -> return $ Right (hs, cl)
(Nothing, Nothing) -> liftIO . try $ do
cl <- fromIntegral . P.fileSize <$> P.getFileStatus path
return (addLength cl hs, cl)
(Nothing, Just part) -> do
let cl = fromIntegral $ filePartByteCount part
return $ Right (addLength cl hs, cl)
sendResponse' (Right (lengthyHeaders, cl))
| hasBody s req = liftIO $ do
lheader <- composeHeader version s lengthyHeaders
connSendFile conn path beg end (T.tickle th) [lheader] cleaner
T.tickle th
return isPersist
| otherwise = liftIO $ do
composeHeader version s hs >>= connSendAll conn
T.tickle th
return isPersist -- FIXME isKeepAlive?
where
(beg,end) = case mpart of
Nothing -> (0,cl)
Just prt -> (filePartOffset prt, filePartByteCount prt)
version = httpVersion req
(isPersist,_) = infoFromRequest req
sendResponse' (Left (_ :: SomeException)) =
sendResponse cleaner req conn notFound
where
notFound = responseLBS H.status404 [(H.hContentType, "text/plain")] "File not found"
----------------------------------------------------------------
sendResponse cleaner req conn (ResponseBuilder s hs b)
| hasBody s req = liftIO $ do
header <- composeHeaderBuilder version s hs needsChunked
let body
| needsChunked = header `mappend` chunkedTransferEncoding b
`mappend` chunkedTransferTerminator
| otherwise = header `mappend` b
flip toByteStringIO body $ \bs -> do
connSendAll conn bs
T.tickle th
return isKeepAlive
| otherwise = liftIO $ do
composeHeader version s hs >>= connSendAll conn
T.tickle th
return isPersist
where
th = threadHandle cleaner
version = httpVersion req
reqinfo@(isPersist,_) = infoFromRequest req
(isKeepAlive, needsChunked) = infoFromResponse hs reqinfo
----------------------------------------------------------------
sendResponse cleaner req conn (ResponseSource s hs bodyFlush)
| hasBody s req = do
header <- liftIO $ composeHeaderBuilder version s hs needsChunked
let src = CL.sourceList [header] `mappend` cbody
src $$ builderToByteString =$ connSink conn th
return isKeepAlive
| otherwise = liftIO $ do
composeHeader version s hs >>= connSendAll conn
T.tickle th
return isPersist
where
th = threadHandle cleaner
body = mapOutput (\x -> case x of
Flush -> flush
Chunk builder -> builder) bodyFlush
cbody = if needsChunked then body $= chunk else body
-- FIXME perhaps alloca a buffer per thread and reuse that in all
-- functions below. Should lessen greatly the GC burden (I hope)
chunk :: Conduit Builder (ResourceT IO) Builder
chunk = await >>= maybe (yield chunkedTransferTerminator) (\x -> yield (chunkedTransferEncoding x) >> chunk)
version = httpVersion req
reqinfo@(isPersist,_) = infoFromRequest req
(isKeepAlive, needsChunked) = infoFromResponse hs reqinfo
----------------------------------------------------------------
----------------------------------------------------------------
-- | Use 'connSendAll' to send this data while respecting timeout rules.
connSink :: Connection -> T.Handle -> Sink ByteString (ResourceT IO) ()
connSink Connection { connSendAll = send } th =
sink
where
sink = await >>= maybe close push
close = liftIO (T.resume th)
push x = do
liftIO $ T.resume th
liftIO $ send x
liftIO $ T.pause th
sink
-- We pause timeouts before passing control back to user code. This ensures
-- that a timeout will only ever be executed when Warp is in control. We
-- also make sure to resume the timeout after the completion of user code
-- so that we can kill idle connections.
----------------------------------------------------------------
infoFromRequest :: Request -> (Bool,Bool)
infoFromRequest req = (checkPersist req, checkChunk req)
checkPersist :: Request -> Bool
checkPersist req
| ver == H.http11 = checkPersist11 conn
| otherwise = checkPersist10 conn
where
ver = httpVersion req
conn = lookup H.hConnection $ requestHeaders req
checkPersist11 (Just x)
| CI.foldCase x == "close" = False
checkPersist11 _ = True
checkPersist10 (Just x)
| CI.foldCase x == "keep-alive" = True
checkPersist10 _ = False
checkChunk :: Request -> Bool
checkChunk req = httpVersion req == H.http11
----------------------------------------------------------------
infoFromResponse :: H.ResponseHeaders -> (Bool,Bool) -> (Bool,Bool)
infoFromResponse hs (isPersist,isChunked) = (isKeepAlive, needsChunked)
where
needsChunked = isChunked && not hasLength
isKeepAlive = isPersist && (isChunked || hasLength)
hasLength = isJust $ checkLength hs
checkLength :: H.ResponseHeaders -> Maybe ByteString
checkLength = lookup H.hContentLength
----------------------------------------------------------------
hasBody :: H.Status -> Request -> Bool
hasBody s req = sc /= 204
&& sc /= 304
&& sc >= 200
&& method /= H.methodHead
where
sc = H.statusCode s
method = requestMethod req
----------------------------------------------------------------
addLength :: Integer -> H.ResponseHeaders -> H.ResponseHeaders
addLength cl hdrs = (H.hContentLength, B.pack $ show cl) : hdrs
addEncodingHeader :: H.ResponseHeaders -> H.ResponseHeaders
addEncodingHeader hdrs = (hTransferEncoding, "chunked") : hdrs
addServerHeader :: H.ResponseHeaders -> H.ResponseHeaders
addServerHeader hdrs = case lookup hServer hdrs of
Nothing -> warpVersionHeader : hdrs
Just _ -> hdrs
warpVersionHeader :: H.Header
warpVersionHeader = (hServer, ver)
where
ver = B.pack $ "Warp/" ++ warpVersion
----------------------------------------------------------------
composeHeader :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> IO ByteString
composeHeader version s hs = RH.composeHeader version s (addServerHeader hs)
composeHeaderBuilder :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder
composeHeaderBuilder ver s hs True =
fromByteString <$> composeHeader ver s (addEncodingHeader hs)
composeHeaderBuilder ver s hs False =
fromByteString <$> composeHeader ver s hs