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 Control.Exception as E 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 <- E.try $ getFileInfo ii path 279 case efinfo of 280 Left (_ex :: E.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