1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE RankNTypes #-}
4{-# LANGUAGE CPP #-}
5{-# LANGUAGE BangPatterns #-}
6
7module Network.Wai.Handler.Warp.Response (
8    sendResponse
9  , sanitizeHeaderValue -- for testing
10  , warpVersion
11  , hasBody
12  , replaceHeader
13  , addServer -- testing
14  , addAltSvc
15  ) where
16
17import Data.ByteString.Builder.HTTP.Chunked (chunkedTransferEncoding, chunkedTransferTerminator)
18import qualified UnliftIO
19import Data.Array ((!))
20import qualified Data.ByteString as S
21import Data.ByteString.Builder (byteString, Builder)
22import Data.ByteString.Builder.Extra (flush)
23import qualified Data.ByteString.Char8 as C8
24import qualified Data.CaseInsensitive as CI
25import Data.Function (on)
26import Data.Streaming.ByteString.Builder (newByteStringBuilderRecv, reuseBufferStrategy)
27import Data.Version (showVersion)
28import Data.Word8 (_cr, _lf)
29import qualified Network.HTTP.Types as H
30import qualified Network.HTTP.Types.Header as H
31import Network.Wai
32import Network.Wai.Internal
33import qualified Paths_warp
34import qualified System.TimeManager as T
35
36import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer)
37import qualified Network.Wai.Handler.Warp.Date as D
38import Network.Wai.Handler.Warp.File
39import Network.Wai.Handler.Warp.Header
40import Network.Wai.Handler.Warp.IO (toBufIOWith)
41import Network.Wai.Handler.Warp.Imports
42import Network.Wai.Handler.Warp.ResponseHeader
43import Network.Wai.Handler.Warp.Settings
44import Network.Wai.Handler.Warp.Types
45
46-- $setup
47-- >>> :set -XOverloadedStrings
48
49----------------------------------------------------------------
50
51-- | Sending a HTTP response to 'Connection' according to 'Response'.
52--
53--   Applications/middlewares MUST provide a proper 'H.ResponseHeaders'.
54--   so that inconsistency does not happen.
55--   No header is deleted by this function.
56--
57--   Especially, Applications/middlewares MUST provide a proper
58--   Content-Type. They MUST NOT provide
59--   Content-Length, Content-Range, and Transfer-Encoding
60--   because they are inserted, when necessary,
61--   regardless they already exist.
62--   This function does not insert Content-Encoding. It's middleware's
63--   responsibility.
64--
65--   The Date and Server header is added if not exist
66--   in HTTP response header.
67--
68--   There are three basic APIs to create 'Response':
69--
70--   ['responseBuilder' :: 'H.Status' -> 'H.ResponseHeaders' -> 'Builder' -> 'Response']
71--     HTTP response body is created from 'Builder'.
72--     Transfer-Encoding: chunked is used in HTTP/1.1.
73--
74--   ['responseStream' :: 'H.Status' -> 'H.ResponseHeaders' -> 'StreamingBody' -> 'Response']
75--     HTTP response body is created from 'Builder'.
76--     Transfer-Encoding: chunked is used in HTTP/1.1.
77--
78--   ['responseRaw' :: ('IO' 'ByteString' -> ('ByteString' -> 'IO' ()) -> 'IO' ()) -> 'Response' -> 'Response']
79--     No header is added and no Transfer-Encoding: is applied.
80--
81--   ['responseFile' :: 'H.Status' -> 'H.ResponseHeaders' -> 'FilePath' -> 'Maybe' 'FilePart' -> 'Response']
82--     HTTP response body is sent (by sendfile(), if possible) for GET method.
83--     HTTP response body is not sent by HEAD method.
84--     Content-Length and Content-Range are automatically
85--     added into the HTTP response header if necessary.
86--     If Content-Length and Content-Range exist in the HTTP response header,
87--     they would cause inconsistency.
88--     \"Accept-Ranges: bytes\" is also inserted.
89--
90--     Applications are categorized into simple and sophisticated.
91--     Sophisticated applications should specify 'Just' to
92--     'Maybe' 'FilePart'. They should treat the conditional request
93--     by themselves. A proper 'Status' (200 or 206) must be provided.
94--
95--     Simple applications should specify 'Nothing' to
96--     'Maybe' 'FilePart'. The size of the specified file is obtained
97--     by disk access or from the file infor cache.
98--     If-Modified-Since, If-Unmodified-Since, If-Range and Range
99--     are processed. Since a proper status is chosen, 'Status' is
100--     ignored. Last-Modified is inserted.
101
102sendResponse :: Settings
103             -> Connection
104             -> InternalInfo
105             -> T.Handle
106             -> Request -- ^ HTTP request.
107             -> IndexedHeader -- ^ Indexed header of HTTP request.
108             -> IO ByteString -- ^ source from client, for raw response
109             -> Response -- ^ HTTP response including status code and response header.
110             -> IO Bool -- ^ Returing True if the connection is persistent.
111sendResponse settings conn ii th req reqidxhdr src response = do
112    hs <- addAltSvc settings <$> addServerAndDate hs0
113    if hasBody s then do
114        -- The response to HEAD does not have body.
115        -- But to handle the conditional requests defined RFC 7232 and
116        -- to generate appropriate content-length, content-range,
117        -- and status, the response to HEAD is processed here.
118        --
119        -- See definition of rsp below for proper body stripping.
120        (ms, mlen) <- sendRsp conn ii th ver s hs rspidxhdr rsp
121        case ms of
122            Nothing         -> return ()
123            Just realStatus -> logger req realStatus mlen
124        T.tickle th
125        return ret
126      else do
127        _ <- sendRsp conn ii th ver s hs rspidxhdr RspNoBody
128        logger req s Nothing
129        T.tickle th
130        return isPersist
131  where
132    defServer = settingsServerName settings
133    logger = settingsLogger settings
134    ver = httpVersion req
135    s = responseStatus response
136    hs0 = sanitizeHeaders $ responseHeaders response
137    rspidxhdr = indexResponseHeader hs0
138    getdate = getDate ii
139    addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr
140    (isPersist,isChunked0) = infoFromRequest req reqidxhdr
141    isChunked = not isHead && isChunked0
142    (isKeepAlive, needsChunked) = infoFromResponse rspidxhdr (isPersist,isChunked)
143    isHead = requestMethod req == H.methodHead
144    rsp = case response of
145        ResponseFile _ _ path mPart -> RspFile path mPart reqidxhdr isHead (T.tickle th)
146        ResponseBuilder _ _ b
147          | isHead                  -> RspNoBody
148          | otherwise               -> RspBuilder b needsChunked
149        ResponseStream _ _ fb
150          | isHead                  -> RspNoBody
151          | otherwise               -> RspStream fb needsChunked
152        ResponseRaw raw _           -> RspRaw raw src
153    -- Make sure we don't hang on to 'response' (avoid space leak)
154    !ret = case response of
155        ResponseFile    {} -> isPersist
156        ResponseBuilder {} -> isKeepAlive
157        ResponseStream  {} -> isKeepAlive
158        ResponseRaw     {} -> False
159
160----------------------------------------------------------------
161
162sanitizeHeaders :: H.ResponseHeaders -> H.ResponseHeaders
163sanitizeHeaders = map (sanitize <$>)
164  where
165    sanitize v
166      | containsNewlines v = sanitizeHeaderValue v -- slow path
167      | otherwise          = v                     -- fast path
168
169{-# INLINE containsNewlines #-}
170containsNewlines :: ByteString -> Bool
171containsNewlines = S.any (\w -> w == _cr || w == _lf)
172
173{-# INLINE sanitizeHeaderValue #-}
174sanitizeHeaderValue :: ByteString -> ByteString
175sanitizeHeaderValue v = case C8.lines $ S.filter (/= _cr) v of
176    []     -> ""
177    x : xs -> C8.intercalate "\r\n" (x : mapMaybe addSpaceIfMissing xs)
178  where
179    addSpaceIfMissing line = case C8.uncons line of
180        Nothing                           -> Nothing
181        Just (first, _)
182          | first == ' ' || first == '\t' -> Just line
183          | otherwise                     -> Just $ " " <> line
184
185----------------------------------------------------------------
186
187data Rsp = RspNoBody
188         | RspFile FilePath (Maybe FilePart) IndexedHeader Bool (IO ())
189         | RspBuilder Builder Bool
190         | RspStream StreamingBody Bool
191         | RspRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) (IO ByteString)
192
193----------------------------------------------------------------
194
195sendRsp :: Connection
196        -> InternalInfo
197        -> T.Handle
198        -> H.HttpVersion
199        -> H.Status
200        -> H.ResponseHeaders
201        -> IndexedHeader -- Response
202        -> Rsp
203        -> IO (Maybe H.Status, Maybe Integer)
204
205----------------------------------------------------------------
206
207sendRsp conn _ _ ver s hs _ RspNoBody = do
208    -- Not adding Content-Length.
209    -- User agents treats it as Content-Length: 0.
210    composeHeader ver s hs >>= connSendAll conn
211    return (Just s, Nothing)
212
213----------------------------------------------------------------
214
215sendRsp conn _ th ver s hs _ (RspBuilder body needsChunked) = do
216    header <- composeHeaderBuilder ver s hs needsChunked
217    let hdrBdy
218         | needsChunked = header <> chunkedTransferEncoding body
219                                 <> chunkedTransferTerminator
220         | otherwise    = header <> body
221        buffer = connWriteBuffer conn
222        size = connBufferSize conn
223    toBufIOWith buffer size (\bs -> connSendAll conn bs >> T.tickle th) hdrBdy
224    return (Just s, Nothing) -- fixme: can we tell the actual sent bytes?
225
226----------------------------------------------------------------
227
228sendRsp conn _ th ver s hs _ (RspStream streamingBody needsChunked) = do
229    header <- composeHeaderBuilder ver s hs needsChunked
230    (recv, finish) <- newByteStringBuilderRecv $ reuseBufferStrategy
231                    $ toBuilderBuffer (connWriteBuffer conn) (connBufferSize conn)
232    let send builder = do
233            popper <- recv builder
234            let loop = do
235                    bs <- popper
236                    unless (S.null bs) $ do
237                        sendFragment conn th bs
238                        loop
239            loop
240        sendChunk
241            | needsChunked = send . chunkedTransferEncoding
242            | otherwise = send
243    send header
244    streamingBody sendChunk (sendChunk flush)
245    when needsChunked $ send chunkedTransferTerminator
246    mbs <- finish
247    maybe (return ()) (sendFragment conn th) mbs
248    return (Just s, Nothing) -- fixme: can we tell the actual sent bytes?
249
250----------------------------------------------------------------
251
252sendRsp conn _ th _ _ _ _ (RspRaw withApp src) = do
253    withApp recv send
254    return (Nothing, Nothing)
255  where
256    recv = do
257        bs <- src
258        unless (S.null bs) $ T.tickle th
259        return bs
260    send bs = connSendAll conn bs >> T.tickle th
261
262----------------------------------------------------------------
263
264-- Sophisticated WAI applications.
265-- We respect s0. s0 MUST be a proper value.
266sendRsp conn ii th ver s0 hs0 rspidxhdr (RspFile path (Just part) _ isHead hook) =
267    sendRspFile2XX conn ii th ver s0 hs rspidxhdr path beg len isHead hook
268  where
269    beg = filePartOffset part
270    len = filePartByteCount part
271    hs = addContentHeadersForFilePart hs0 part
272
273----------------------------------------------------------------
274
275-- Simple WAI applications.
276-- Status is ignored
277sendRsp conn ii th ver _ hs0 rspidxhdr (RspFile path Nothing reqidxhdr isHead hook) = do
278    efinfo <- UnliftIO.tryIO $ getFileInfo ii path
279    case efinfo of
280        Left (_ex :: UnliftIO.IOException) ->
281#ifdef WARP_DEBUG
282          print _ex >>
283#endif
284          sendRspFile404 conn ii th ver hs0 rspidxhdr
285        Right finfo -> case conditionalRequest finfo hs0 rspidxhdr reqidxhdr of
286          WithoutBody s         -> sendRsp conn ii th ver s hs0 rspidxhdr RspNoBody
287          WithBody s hs beg len -> sendRspFile2XX conn ii th ver s hs rspidxhdr path beg len isHead hook
288
289----------------------------------------------------------------
290
291sendRspFile2XX :: Connection
292               -> InternalInfo
293               -> T.Handle
294               -> H.HttpVersion
295               -> H.Status
296               -> H.ResponseHeaders
297               -> IndexedHeader
298               -> FilePath
299               -> Integer
300               -> Integer
301               -> Bool
302               -> IO ()
303               -> IO (Maybe H.Status, Maybe Integer)
304sendRspFile2XX conn ii th ver s hs rspidxhdr path beg len isHead hook
305  | isHead = sendRsp conn ii th ver s hs rspidxhdr RspNoBody
306  | otherwise = do
307      lheader <- composeHeader ver s hs
308      (mfd, fresher) <- getFd ii path
309      let fid = FileId path mfd
310          hook' = hook >> fresher
311      connSendFile conn fid beg len hook' [lheader]
312      return (Just s, Just len)
313
314sendRspFile404 :: Connection
315               -> InternalInfo
316               -> T.Handle
317               -> H.HttpVersion
318               -> H.ResponseHeaders
319               -> IndexedHeader
320               -> IO (Maybe H.Status, Maybe Integer)
321sendRspFile404 conn ii th ver hs0 rspidxhdr = sendRsp conn ii th ver s hs rspidxhdr (RspBuilder body True)
322  where
323    s = H.notFound404
324    hs =  replaceHeader H.hContentType "text/plain; charset=utf-8" hs0
325    body = byteString "File not found"
326
327----------------------------------------------------------------
328----------------------------------------------------------------
329
330-- | Use 'connSendAll' to send this data while respecting timeout rules.
331sendFragment :: Connection -> T.Handle -> ByteString -> IO ()
332sendFragment Connection { connSendAll = send } th bs = do
333    T.resume th
334    send bs
335    T.pause th
336    -- We pause timeouts before passing control back to user code. This ensures
337    -- that a timeout will only ever be executed when Warp is in control. We
338    -- also make sure to resume the timeout after the completion of user code
339    -- so that we can kill idle connections.
340
341----------------------------------------------------------------
342
343infoFromRequest :: Request -> IndexedHeader -> (Bool  -- isPersist
344                                               ,Bool) -- isChunked
345infoFromRequest req reqidxhdr = (checkPersist req reqidxhdr, checkChunk req)
346
347checkPersist :: Request -> IndexedHeader -> Bool
348checkPersist req reqidxhdr
349    | ver == H.http11 = checkPersist11 conn
350    | otherwise       = checkPersist10 conn
351  where
352    ver = httpVersion req
353    conn = reqidxhdr ! fromEnum ReqConnection
354    checkPersist11 (Just x)
355        | CI.foldCase x == "close"      = False
356    checkPersist11 _                    = True
357    checkPersist10 (Just x)
358        | CI.foldCase x == "keep-alive" = True
359    checkPersist10 _                    = False
360
361checkChunk :: Request -> Bool
362checkChunk req = httpVersion req == H.http11
363
364----------------------------------------------------------------
365
366-- Used for ResponseBuilder and ResponseSource.
367-- Don't use this for ResponseFile since this logic does not fit
368-- for ResponseFile. For instance, isKeepAlive should be True in some cases
369-- even if the response header does not have Content-Length.
370--
371-- Content-Length is specified by a reverse proxy.
372-- Note that CGI does not specify Content-Length.
373infoFromResponse :: IndexedHeader -> (Bool,Bool) -> (Bool,Bool)
374infoFromResponse rspidxhdr (isPersist,isChunked) = (isKeepAlive, needsChunked)
375  where
376    needsChunked = isChunked && not hasLength
377    isKeepAlive = isPersist && (isChunked || hasLength)
378    hasLength = isJust $ rspidxhdr ! fromEnum ResContentLength
379
380----------------------------------------------------------------
381
382hasBody :: H.Status -> Bool
383hasBody s = sc /= 204
384         && sc /= 304
385         && sc >= 200
386  where
387    sc = H.statusCode s
388
389----------------------------------------------------------------
390
391addTransferEncoding :: H.ResponseHeaders -> H.ResponseHeaders
392addTransferEncoding hdrs = (H.hTransferEncoding, "chunked") : hdrs
393
394addDate :: IO D.GMTDate -> IndexedHeader -> H.ResponseHeaders -> IO H.ResponseHeaders
395addDate getdate rspidxhdr hdrs = case rspidxhdr ! fromEnum ResDate of
396    Nothing -> do
397        gmtdate <- getdate
398        return $ (H.hDate, gmtdate) : hdrs
399    Just _ -> return hdrs
400
401----------------------------------------------------------------
402
403-- | The version of Warp.
404warpVersion :: String
405warpVersion = showVersion Paths_warp.version
406
407{-# INLINE addServer #-}
408addServer :: HeaderValue -> IndexedHeader -> H.ResponseHeaders -> H.ResponseHeaders
409addServer "" rspidxhdr hdrs = case rspidxhdr ! fromEnum ResServer of
410    Nothing -> hdrs
411    _       -> filter ((/= H.hServer) . fst) hdrs
412addServer serverName rspidxhdr hdrs = case rspidxhdr ! fromEnum ResServer of
413    Nothing -> (H.hServer, serverName) : hdrs
414    _       -> hdrs
415
416addAltSvc :: Settings -> H.ResponseHeaders -> H.ResponseHeaders
417addAltSvc settings hs = case settingsAltSvc settings of
418                Nothing -> hs
419                Just  v -> ("Alt-Svc", v) : hs
420
421----------------------------------------------------------------
422
423-- |
424--
425-- >>> replaceHeader "Content-Type" "new" [("content-type","old")]
426-- [("Content-Type","new")]
427replaceHeader :: H.HeaderName -> HeaderValue -> H.ResponseHeaders -> H.ResponseHeaders
428replaceHeader k v hdrs = (k,v) : deleteBy ((==) `on` fst) (k,v) hdrs
429
430----------------------------------------------------------------
431
432composeHeaderBuilder :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder
433composeHeaderBuilder ver s hs True =
434    byteString <$> composeHeader ver s (addTransferEncoding hs)
435composeHeaderBuilder ver s hs False =
436    byteString <$> composeHeader ver s hs
437