{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Network.Wai.Handler.Warp.Response (
    sendResponse,
    sanitizeHeaderValue, -- for testing
    containsRecoverableWhitespace, -- for benchmarking
    --  Provided here for backwards compatibility.
    warpVersion,
    hasBody,
    replaceHeader,
    addServer, -- testing
    addAltSvc,
) where

import qualified Control.Exception as E
import qualified Data.ByteString as S
import Data.ByteString.Internal (toForeignPtr, unsafeCreate)
import Data.ByteString.Builder (Builder, byteString)
import Data.ByteString.Builder.Extra (flush)
import Data.ByteString.Builder.HTTP.Chunked (
    chunkedTransferEncoding,
    chunkedTransferTerminator,
 )
import qualified Data.CaseInsensitive as CI
import Data.Foldable (for_)
import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)
import Data.Streaming.ByteString.Builder (
    newByteStringBuilderRecv,
    reuseBufferStrategy,
 )
import Data.Word8 (_cr, _lf, _nul, _space)
import Foreign (copyBytes, plusForeignPtr, pokeByteOff, withForeignPtr)
import qualified Network.HTTP.Types as H
import qualified Network.HTTP.Types.Header as Header
import Network.Wai
import Network.Wai.Internal
import qualified System.TimeManager as T

import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer)
import qualified Network.Wai.Handler.Warp.Date as D
import Network.Wai.Handler.Warp.File
import Network.Wai.Handler.Warp.Header
import Network.Wai.Handler.Warp.IO (toBufIOWith, unsafeToBufIOWithOffset)
import Network.Wai.Handler.Warp.Imports
import Network.Wai.Handler.Warp.ResponseHeader
import Network.Wai.Handler.Warp.Settings
import Network.Wai.Handler.Warp.Types

-- $setup
-- >>> :set -XOverloadedStrings

----------------------------------------------------------------

-- | Sending a HTTP response to 'Connection' according to 'Response'.
--
--   Applications/middlewares MUST provide a proper 'H.ResponseHeaders'.
--   so that inconsistency does not happen.
--   No header is deleted by this function.
--
--   Especially, Applications/middlewares MUST provide a proper
--   Content-Type. They MUST NOT provide
--   Content-Length, Content-Range, and Transfer-Encoding
--   because they are inserted, when necessary,
--   regardless they already exist.
--   This function does not insert Content-Encoding. It's middleware's
--   responsibility.
--
--   The Date and Server header is added if not exist
--   in HTTP response header.
--
--   There are three basic APIs to create 'Response':
--
--   ['responseBuilder' :: 'H.Status' -> 'H.ResponseHeaders' -> 'Builder' -> 'Response']
--     HTTP response body is created from 'Builder'.
--     Transfer-Encoding: chunked is used in HTTP/1.1.
--
--   ['responseStream' :: 'H.Status' -> 'H.ResponseHeaders' -> 'StreamingBody' -> 'Response']
--     HTTP response body is created from 'Builder'.
--     Transfer-Encoding: chunked is used in HTTP/1.1.
--
--   ['responseRaw' :: ('IO' 'ByteString' -> ('ByteString' -> 'IO' ()) -> 'IO' ()) -> 'Response' -> 'Response']
--     No header is added and no Transfer-Encoding: is applied.
--
--   ['responseFile' :: 'H.Status' -> 'H.ResponseHeaders' -> 'FilePath' -> 'Maybe' 'FilePart' -> 'Response']
--     HTTP response body is sent (by sendfile(), if possible) for GET method.
--     HTTP response body is not sent by HEAD method.
--     Content-Length and Content-Range are automatically
--     added into the HTTP response header if necessary.
--     If Content-Length and Content-Range exist in the HTTP response header,
--     they would cause inconsistency.
--     \"Accept-Ranges: bytes\" is also inserted.
--
--     Applications are categorized into simple and sophisticated.
--     Sophisticated applications should specify 'Just' to
--     'Maybe' 'FilePart'. They should treat the conditional request
--     by themselves. A proper 'Status' (200 or 206) must be provided.
--
--     Simple applications should specify 'Nothing' to
--     'Maybe' 'FilePart'. The size of the specified file is obtained
--     by disk access or from the file info cache.
--     If-Modified-Since, If-Unmodified-Since, If-Range and Range
--     are processed. Since a proper status is chosen, 'Status' is
--     ignored. Last-Modified is inserted.
sendResponse
    :: Settings
    -> Connection
    -> InternalInfo
    -> T.Handle
    -> Request
    -- ^ HTTP request.
    -> IndexedRequestHeader
    -- ^ Indexed header of HTTP request.
    -> IO ByteString
    -- ^ source from client, for raw response
    -> Response
    -- ^ HTTP response including status code and response header.
    -> IO Bool
    -- ^ Returing True if the connection is persistent.
sendResponse :: Settings
-> Connection
-> InternalInfo
-> Handle
-> Request
-> IndexedRequestHeader
-> IO HeaderValue
-> Response
-> IO Bool
sendResponse Settings
settings Connection
conn InternalInfo
ii Handle
th Request
req IndexedRequestHeader
reqidxhdr IO HeaderValue
src Response
response = do
    -- Decide connection persistence
    Bool
isShuttingDown <-
        case Settings -> Maybe ServerState
settingsServerState Settings
settings of
            Just ServerState
serverState -> ServerState -> IO Bool
currentShuttingDownState ServerState
serverState
            -- Should never be reached!
            -- (cf. 'makeServerState' in 'runSettingsConnectionMakerSecure')
            Maybe ServerState
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    let shouldPersist :: Bool
shouldPersist = Bool -> Bool
not Bool
isShuttingDown Bool -> Bool -> Bool
&& Bool
ret
        addConnection :: [(HeaderName, b)] -> [(HeaderName, b)]
addConnection [(HeaderName, b)]
hs =
            if Bool
shouldPersist Bool -> Bool -> Bool
|| Bool
responseWantsToClose
                then [(HeaderName, b)]
hs
                else (HeaderName
Header.hConnection, b
"close") (HeaderName, b) -> [(HeaderName, b)] -> [(HeaderName, b)]
forall a. a -> [a] -> [a]
: [(HeaderName, b)]
hs

    -- Adjust headers
    [(HeaderName, HeaderValue)]
hs <- [(HeaderName, HeaderValue)] -> [(HeaderName, HeaderValue)]
forall {b}. IsString b => [(HeaderName, b)] -> [(HeaderName, b)]
addConnection ([(HeaderName, HeaderValue)] -> [(HeaderName, HeaderValue)])
-> ([(HeaderName, HeaderValue)] -> [(HeaderName, HeaderValue)])
-> [(HeaderName, HeaderValue)]
-> [(HeaderName, HeaderValue)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Settings
-> [(HeaderName, HeaderValue)] -> [(HeaderName, HeaderValue)]
addAltSvc Settings
settings ([(HeaderName, HeaderValue)] -> [(HeaderName, HeaderValue)])
-> IO [(HeaderName, HeaderValue)] -> IO [(HeaderName, HeaderValue)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(HeaderName, HeaderValue)] -> IO [(HeaderName, HeaderValue)]
addServerAndDate [(HeaderName, HeaderValue)]
hs0

    -- Start response logic
    if Status -> Bool
hasBody Status
s
        then do
            -- The response to HEAD does not have body.
            -- But to handle the conditional requests defined RFC 7232 and
            -- to generate appropriate content-length, content-range,
            -- and status, the response to HEAD is processed here.
            --
            -- See definition of rsp below for proper body stripping.
            (Maybe Status
ms, Maybe Integer
mlen) <- Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> Status
-> [(HeaderName, HeaderValue)]
-> ResponseHeaderPresence
-> Int
-> HeaderValue
-> Rsp
-> IO (Maybe Status, Maybe Integer)
sendRsp Connection
conn InternalInfo
ii Handle
th HttpVersion
ver Status
s [(HeaderName, HeaderValue)]
hs ResponseHeaderPresence
rspidxhdr Int
maxRspBufSize HeaderValue
method Rsp
rsp
            case Maybe Status
ms of
                Maybe Status
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Just Status
realStatus -> Request -> Status -> Maybe Integer -> IO ()
logger Request
req Status
realStatus Maybe Integer
mlen
        else do
            (Maybe Status, Maybe Integer)
_ <- Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> Status
-> [(HeaderName, HeaderValue)]
-> ResponseHeaderPresence
-> Int
-> HeaderValue
-> Rsp
-> IO (Maybe Status, Maybe Integer)
sendRsp Connection
conn InternalInfo
ii Handle
th HttpVersion
ver Status
s [(HeaderName, HeaderValue)]
hs ResponseHeaderPresence
rspidxhdr Int
maxRspBufSize HeaderValue
method Rsp
RspNoBody
            Request -> Status -> Maybe Integer -> IO ()
logger Request
req Status
s Maybe Integer
forall a. Maybe a
Nothing
    Handle -> IO ()
T.tickle Handle
th
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
shouldPersist
  where
    -- From Settings --
    defServer :: HeaderValue
defServer = Settings -> HeaderValue
settingsServerName Settings
settings
    logger :: Request -> Status -> Maybe Integer -> IO ()
logger = Settings -> Request -> Status -> Maybe Integer -> IO ()
settingsLogger Settings
settings
    maxRspBufSize :: Int
maxRspBufSize = Settings -> Int
settingsMaxBuilderResponseBufferSize Settings
settings

    -- From Request --
    method :: HeaderValue
method = Request -> HeaderValue
requestMethod Request
req
    isHead :: Bool
isHead = HeaderValue
method HeaderValue -> HeaderValue -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderValue
H.methodHead
    ver :: HttpVersion
ver = Request -> HttpVersion
httpVersion Request
req
    isHttp11 :: Bool
isHttp11 = HttpVersion
ver HttpVersion -> HttpVersion -> Bool
forall a. Eq a => a -> a -> Bool
== HttpVersion
H.http11
    reqSaysPersist :: Bool
reqSaysPersist = Bool -> IndexedRequestHeader -> Bool
checkReqConnectionHeader Bool
isHttp11 IndexedRequestHeader
reqidxhdr

    -- From Response --
    s :: Status
s = Response -> Status
responseStatus Response
response
    hs0 :: [(HeaderName, HeaderValue)]
hs0 = [(HeaderName, HeaderValue)] -> [(HeaderName, HeaderValue)]
sanitizeHeaders ([(HeaderName, HeaderValue)] -> [(HeaderName, HeaderValue)])
-> [(HeaderName, HeaderValue)] -> [(HeaderName, HeaderValue)]
forall a b. (a -> b) -> a -> b
$ Response -> [(HeaderName, HeaderValue)]
responseHeaders Response
response
    rspidxhdr :: ResponseHeaderPresence
rspidxhdr = [(HeaderName, HeaderValue)] -> ResponseHeaderPresence
indexResponseHeader [(HeaderName, HeaderValue)]
hs0
    hasLength :: Bool
hasLength = ResponseHeaderPresence -> Bool
hasContentLength ResponseHeaderPresence
rspidxhdr
    responseWantsToClose :: Bool
responseWantsToClose =
        case ResponseHeaderPresence -> Maybe HeaderValue
hasConnection ResponseHeaderPresence
rspidxhdr of
            Maybe HeaderValue
Nothing -> Bool
False
            Just HeaderValue
v -> HeaderValue -> HeaderValue
forall s. FoldCase s => s -> s
CI.foldCase HeaderValue
v HeaderValue -> HeaderValue -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderValue
"close"
    isPersist :: Bool
isPersist = Bool
reqSaysPersist Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
responseWantsToClose

    -- Other --
    getdate :: IO HeaderValue
getdate = InternalInfo -> IO HeaderValue
getDate InternalInfo
ii
    addServerAndDate :: [(HeaderName, HeaderValue)] -> IO [(HeaderName, HeaderValue)]
addServerAndDate = IO HeaderValue
-> ResponseHeaderPresence
-> [(HeaderName, HeaderValue)]
-> IO [(HeaderName, HeaderValue)]
addDate IO HeaderValue
getdate ResponseHeaderPresence
rspidxhdr ([(HeaderName, HeaderValue)] -> IO [(HeaderName, HeaderValue)])
-> ([(HeaderName, HeaderValue)] -> [(HeaderName, HeaderValue)])
-> [(HeaderName, HeaderValue)]
-> IO [(HeaderName, HeaderValue)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderValue
-> ResponseHeaderPresence
-> [(HeaderName, HeaderValue)]
-> [(HeaderName, HeaderValue)]
addServer HeaderValue
defServer ResponseHeaderPresence
rspidxhdr
    needsChunked :: Bool
needsChunked = Bool
isHttp11 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
hasLength
    rsp :: Rsp
rsp = case Response
response of
        ResponseFile Status
_ [(HeaderName, HeaderValue)]
_ FilePath
path Maybe FilePart
mPart -> FilePath -> Maybe FilePart -> IndexedRequestHeader -> IO () -> Rsp
RspFile FilePath
path Maybe FilePart
mPart IndexedRequestHeader
reqidxhdr (Handle -> IO ()
T.tickle Handle
th)
        ResponseBuilder Status
_ [(HeaderName, HeaderValue)]
_ Builder
b
            | Bool
isHead -> Rsp
RspNoBody
            | Bool
otherwise -> Builder -> Bool -> Rsp
RspBuilder Builder
b Bool
needsChunked
        ResponseStream Status
_ [(HeaderName, HeaderValue)]
_ StreamingBody
fb
            | Bool
isHead -> Rsp
RspNoBody
            | Bool
otherwise -> StreamingBody -> Bool -> Rsp
RspStream StreamingBody
fb Bool
needsChunked
        ResponseRaw IO HeaderValue -> (HeaderValue -> IO ()) -> IO ()
raw Response
_ -> (IO HeaderValue -> (HeaderValue -> IO ()) -> IO ())
-> IO HeaderValue -> Rsp
RspRaw IO HeaderValue -> (HeaderValue -> IO ()) -> IO ()
raw IO HeaderValue
src
    -- Should be False if (http10 && not hasLength), regardless of what
    -- the 'Connection' header says. (as long as the response should have a body)
    isKeepAlive :: Bool
isKeepAlive =
        Bool
isPersist Bool -> Bool -> Bool
&& (Bool
isHttp11 Bool -> Bool -> Bool
|| Bool
hasLength Bool -> Bool -> Bool
|| Bool
isHead Bool -> Bool -> Bool
|| Bool -> Bool
not (Status -> Bool
hasBody Status
s))
    -- Make sure we don't hang on to 'response' (avoid space leak)
    !ret :: Bool
ret = case Response
response of
        -- Will get 'Content-Length' header later on using the
        -- 'addContentHeaders(ForFilePart)' functions, so if the
        -- 'Connection' header says we persist, we persist.
        ResponseFile{} -> Bool
isPersist
        ResponseBuilder{} -> Bool
isKeepAlive
        ResponseStream{} -> Bool
isKeepAlive
        -- Is already an ongoing open connection, so if it is done,
        -- the connection should be closed.
        ResponseRaw{} -> Bool
False

----------------------------------------------------------------

-- | As per RFC 9110 we replace any newlines (\r\n) or \NUL with spaces
-- Values without CR/LF/NUL (the overwhelmingly common case) leave the
-- header list untouched; only a dirty value triggers a rebuild.
sanitizeHeaders :: H.ResponseHeaders -> H.ResponseHeaders
sanitizeHeaders :: [(HeaderName, HeaderValue)] -> [(HeaderName, HeaderValue)]
sanitizeHeaders [(HeaderName, HeaderValue)]
hdrs
      -- slow path
    | ((HeaderName, HeaderValue) -> Bool)
-> [(HeaderName, HeaderValue)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (HeaderValue -> Bool
containsRecoverableWhitespace (HeaderValue -> Bool)
-> ((HeaderName, HeaderValue) -> HeaderValue)
-> (HeaderName, HeaderValue)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, HeaderValue) -> HeaderValue
forall a b. (a, b) -> b
snd) [(HeaderName, HeaderValue)]
hdrs = ((HeaderName, HeaderValue) -> (HeaderName, HeaderValue))
-> [(HeaderName, HeaderValue)] -> [(HeaderName, HeaderValue)]
forall a b. (a -> b) -> [a] -> [b]
map (HeaderValue -> HeaderValue
sanitize (HeaderValue -> HeaderValue)
-> (HeaderName, HeaderValue) -> (HeaderName, HeaderValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) [(HeaderName, HeaderValue)]
hdrs
      -- fast path
    | Bool
otherwise = [(HeaderName, HeaderValue)]
hdrs
  where
    sanitize :: HeaderValue -> HeaderValue
sanitize HeaderValue
bs
        | HeaderValue -> Bool
containsRecoverableWhitespace HeaderValue
bs = HeaderValue -> HeaderValue
sanitizeHeaderValue HeaderValue
bs
        | Bool
otherwise = HeaderValue
bs

-- Yes, this is quicker than @S.any (\w -> w == _lf || w == _cr || w == _nul)@
-- because of `bytestring`'s rewrite rules.
containsRecoverableWhitespace :: ByteString -> Bool
containsRecoverableWhitespace :: HeaderValue -> Bool
containsRecoverableWhitespace HeaderValue
bs =
    (Word8 -> Bool) -> HeaderValue -> Bool
S.any (Word8
_lf Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
==) HeaderValue
bs Bool -> Bool -> Bool
|| (Word8 -> Bool) -> HeaderValue -> Bool
S.any (Word8
_cr Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
==) HeaderValue
bs Bool -> Bool -> Bool
|| (Word8 -> Bool) -> HeaderValue -> Bool
S.any (Word8
_nul Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
==) HeaderValue
bs

{-# INLINE isRecoverableWhitespace #-}
-- | CR, LF and NUL can safely be replaced with a SP according to RFC 9110
-- <https://www.rfc-editor.org/rfc/rfc9110.html#section-5.5-5>
isRecoverableWhitespace :: Word8 -> Bool
isRecoverableWhitespace :: Word8 -> Bool
isRecoverableWhitespace Word8
w = Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_cr Bool -> Bool -> Bool
|| Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_lf Bool -> Bool -> Bool
|| Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_nul

sanitizeHeaderValue :: ByteString -> ByteString
sanitizeHeaderValue :: HeaderValue -> HeaderValue
sanitizeHeaderValue HeaderValue
v =
    case (Word8 -> Bool) -> HeaderValue -> [Int]
S.findIndices Word8 -> Bool
isRecoverableWhitespace HeaderValue
v of
        -- Nothing to replace
        [] -> HeaderValue
v
        -- Found CR, LF or NUL.
        [Int]
ixs ->
            Int -> (Ptr Word8 -> IO ()) -> HeaderValue
unsafeCreate Int
len ((Ptr Word8 -> IO ()) -> HeaderValue)
-> (Ptr Word8 -> IO ()) -> HeaderValue
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
dst -> do
                ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
forall {b}. ForeignPtr b
fptr ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
src -> do
                    -- copy the bytestring
                    Ptr Word8 -> Ptr Word8 -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr Word8
dst Ptr Word8
src Int
len
                    -- and then replace the offending bytes
                    [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Int]
ixs ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
ix -> Ptr Word8 -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
dst Int
ix Word8
_space
  where
    (ForeignPtr Word8
fptr', Int
offset, Int
len) = HeaderValue -> (ForeignPtr Word8, Int, Int)
toForeignPtr HeaderValue
v
    -- We need to use the offset for backwards compatibility with
    -- "bytestring < 0.11"
    fptr :: ForeignPtr b
fptr = ForeignPtr Word8
fptr' ForeignPtr Word8 -> Int -> ForeignPtr b
forall a b. ForeignPtr a -> Int -> ForeignPtr b
`plusForeignPtr` Int
offset

----------------------------------------------------------------

data Rsp
    = RspNoBody
    | RspFile FilePath (Maybe FilePart) IndexedRequestHeader (IO ())
    | RspBuilder Builder Bool
    | RspStream StreamingBody Bool
    | RspRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) (IO ByteString)

----------------------------------------------------------------

sendRsp
    :: Connection
    -> InternalInfo
    -> T.Handle
    -> H.HttpVersion
    -> H.Status
    -> H.ResponseHeaders
    -> ResponseHeaderPresence
    -> Int -- maxBuilderResponseBufferSize
    -> H.Method
    -> Rsp
    -> IO (Maybe H.Status, Maybe Integer)
----------------------------------------------------------------

sendRsp :: Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> Status
-> [(HeaderName, HeaderValue)]
-> ResponseHeaderPresence
-> Int
-> HeaderValue
-> Rsp
-> IO (Maybe Status, Maybe Integer)
sendRsp Connection
conn InternalInfo
_ Handle
_ HttpVersion
ver Status
s [(HeaderName, HeaderValue)]
hs ResponseHeaderPresence
_ Int
_ HeaderValue
_ Rsp
RspNoBody = do
    -- Not adding Content-Length.
    -- User agents treats it as Content-Length: 0.
    HttpVersion
-> Status -> [(HeaderName, HeaderValue)] -> IO HeaderValue
composeHeader HttpVersion
ver Status
s [(HeaderName, HeaderValue)]
hs IO HeaderValue -> (HeaderValue -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Connection -> HeaderValue -> IO ()
connSendAll Connection
conn
    (Maybe Status, Maybe Integer) -> IO (Maybe Status, Maybe Integer)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Status -> Maybe Status
forall a. a -> Maybe a
Just Status
s, Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
0)

----------------------------------------------------------------

sendRsp Connection
conn InternalInfo
_ Handle
th HttpVersion
ver Status
s [(HeaderName, HeaderValue)]
hs ResponseHeaderPresence
rspidxhdr Int
maxRspBufSize HeaderValue
_ (RspBuilder Builder
body Bool
needsChunked) = do
    WriteBuffer
writeBuffer <- IORef WriteBuffer -> IO WriteBuffer
forall a. IORef a -> IO a
readIORef IORef WriteBuffer
writeBufferRef
    Integer
len <-
        -- SAFETY: this check is what makes the unchecked writes below
        -- memory-safe, do not weaken it. composeHeaderPtr writes hdrLen
        -- bytes into the write buffer with no bounds checking of its own,
        -- and unsafeToBufIOWithOffset requires an offset within the
        -- buffer (it hands the builder buffer + offset with
        -- bufSize - offset bytes of claimed free space). If hdrLen could
        -- reach the buffer size, either write would run past the end of
        -- the allocation and corrupt memory, so oversized headers must
        -- take the composeHeaderBuilder fallback.
        if Int
hdrLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< WriteBuffer -> Int
bufSize WriteBuffer
writeBuffer
            then do
                -- Compose the header directly into the connection write
                -- buffer and run the body builder right after it, saving
                -- a copy of the header bytes through an intermediate
                -- ByteString.
                Int
_ <- Ptr Word8
-> HttpVersion -> Status -> [(HeaderName, HeaderValue)] -> IO Int
composeHeaderPtr (WriteBuffer -> Ptr Word8
bufBuffer WriteBuffer
writeBuffer) HttpVersion
ver Status
s [(HeaderName, HeaderValue)]
hs'
                Int
-> Int
-> IORef WriteBuffer
-> (HeaderValue -> IO ())
-> Builder
-> IO Integer
unsafeToBufIOWithOffset Int
hdrLen Int
maxRspBufSize IORef WriteBuffer
writeBufferRef HeaderValue -> IO ()
send Builder
bdy
            else do
                -- Huge headers: fall back to composing a separate header
                -- ByteString and letting the builder machinery copy it.
                (Builder
header, Int
_) <- HttpVersion
-> Status
-> [(HeaderName, HeaderValue)]
-> ResponseHeaderPresence
-> Bool
-> IO (Builder, Int)
composeHeaderBuilder HttpVersion
ver Status
s [(HeaderName, HeaderValue)]
hs ResponseHeaderPresence
rspidxhdr Bool
needsChunked
                Int
-> IORef WriteBuffer
-> (HeaderValue -> IO ())
-> Builder
-> IO Integer
toBufIOWith Int
maxRspBufSize IORef WriteBuffer
writeBufferRef HeaderValue -> IO ()
send (Builder
header Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
bdy)
    --              small adjustment to only count the body
    (Maybe Status, Maybe Integer) -> IO (Maybe Status, Maybe Integer)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Status -> Maybe Status
forall a. a -> Maybe a
Just Status
s, Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Integer
len Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
hdrLen)
  where
    hs' :: [(HeaderName, HeaderValue)]
hs'
        | Bool
needsChunked = ResponseHeaderPresence
-> [(HeaderName, HeaderValue)] -> [(HeaderName, HeaderValue)]
addTransferEncoding ResponseHeaderPresence
rspidxhdr [(HeaderName, HeaderValue)]
hs
        | Bool
otherwise = [(HeaderName, HeaderValue)]
hs
    hdrLen :: Int
hdrLen = Status -> [(HeaderName, HeaderValue)] -> Int
composeHeaderLength Status
s [(HeaderName, HeaderValue)]
hs'
    bdy :: Builder
bdy
        | Bool
needsChunked = Builder -> Builder
chunkedTransferEncoding Builder
body Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
chunkedTransferTerminator
        | Bool
otherwise = Builder
body
    writeBufferRef :: IORef WriteBuffer
writeBufferRef = Connection -> IORef WriteBuffer
connWriteBuffer Connection
conn
    send :: HeaderValue -> IO ()
send HeaderValue
bs = Connection -> HeaderValue -> IO ()
connSendAll Connection
conn HeaderValue
bs IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
T.tickle Handle
th

----------------------------------------------------------------

sendRsp Connection
conn InternalInfo
_ Handle
th HttpVersion
ver Status
s [(HeaderName, HeaderValue)]
hs ResponseHeaderPresence
rspidxhdr Int
_ HeaderValue
_ (RspStream StreamingBody
streamingBody Bool
needsChunked) = do
    (Builder
header, Int
hdrLen) <- HttpVersion
-> Status
-> [(HeaderName, HeaderValue)]
-> ResponseHeaderPresence
-> Bool
-> IO (Builder, Int)
composeHeaderBuilder HttpVersion
ver Status
s [(HeaderName, HeaderValue)]
hs ResponseHeaderPresence
rspidxhdr Bool
needsChunked
    (BuilderRecv
recv, BuilderFinish
finish) <-
        BufferAllocStrategy -> IO (BuilderRecv, BuilderFinish)
newByteStringBuilderRecv (BufferAllocStrategy -> IO (BuilderRecv, BuilderFinish))
-> BufferAllocStrategy -> IO (BuilderRecv, BuilderFinish)
forall a b. (a -> b) -> a -> b
$
            IO Buffer -> BufferAllocStrategy
reuseBufferStrategy (IO Buffer -> BufferAllocStrategy)
-> IO Buffer -> BufferAllocStrategy
forall a b. (a -> b) -> a -> b
$
                IORef WriteBuffer -> IO Buffer
toBuilderBuffer (IORef WriteBuffer -> IO Buffer) -> IORef WriteBuffer -> IO Buffer
forall a b. (a -> b) -> a -> b
$
                    Connection -> IORef WriteBuffer
connWriteBuffer Connection
conn
    -- We'll be counting how many bytes we send with this 'IORef'
    IORef Integer
sizeCounter <- Integer -> IO (IORef Integer)
forall a. a -> IO (IORef a)
newIORef (Integer
0 :: Integer)
    let sendFragmentAndCount :: HeaderValue -> IO ()
sendFragmentAndCount HeaderValue
bs = do
            Connection -> Handle -> HeaderValue -> IO ()
sendFragment Connection
conn Handle
th HeaderValue
bs
            -- add amount of bytes to count
            HeaderValue -> Int
S.length HeaderValue
bs Int -> IORef Integer -> IO ()
`addToCounter` IORef Integer
sizeCounter
    let send :: Builder -> IO ()
send Builder
builder = do
            IO HeaderValue
popper <- BuilderRecv
recv Builder
builder
            let loop :: IO ()
loop = do
                    HeaderValue
bs <- IO HeaderValue
popper
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (HeaderValue -> Bool
S.null HeaderValue
bs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                        HeaderValue -> IO ()
sendFragmentAndCount HeaderValue
bs
                        IO ()
loop
            IO ()
loop
        sendChunk :: Builder -> IO ()
sendChunk
            | Bool
needsChunked = Builder -> IO ()
send (Builder -> IO ()) -> (Builder -> Builder) -> Builder -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Builder
chunkedTransferEncoding
            | Bool
otherwise = Builder -> IO ()
send
    Builder -> IO ()
send Builder
header
    StreamingBody
streamingBody Builder -> IO ()
sendChunk (Builder -> IO ()
sendChunk Builder
flush)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needsChunked (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Builder -> IO ()
send Builder
chunkedTransferTerminator
    -- final flush
    BuilderFinish
finish BuilderFinish -> (Maybe HeaderValue -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (HeaderValue -> IO ()) -> Maybe HeaderValue -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ HeaderValue -> IO ()
sendFragmentAndCount
    Integer
finalSize <- IORef Integer -> IO Integer
forall a. IORef a -> IO a
readIORef IORef Integer
sizeCounter
    --              small adjustment to only count the body
    (Maybe Status, Maybe Integer) -> IO (Maybe Status, Maybe Integer)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Status -> Maybe Status
forall a. a -> Maybe a
Just Status
s, Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Integer
finalSize Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
hdrLen)
  where
    addToCounter :: Int -> IORef Integer -> IO ()
    addToCounter :: Int -> IORef Integer -> IO ()
addToCounter Int
bytes IORef Integer
ref =
        IORef Integer -> (Integer -> (Integer, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Integer
ref ((Integer -> (Integer, ())) -> IO ())
-> (Integer -> (Integer, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Integer
old ->
            (Integer
old Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bytes, ())

----------------------------------------------------------------

sendRsp Connection
conn InternalInfo
_ Handle
th HttpVersion
_ Status
_ [(HeaderName, HeaderValue)]
_ ResponseHeaderPresence
_ Int
_ HeaderValue
_ (RspRaw IO HeaderValue -> (HeaderValue -> IO ()) -> IO ()
withApp IO HeaderValue
src) = do
    IO HeaderValue -> (HeaderValue -> IO ()) -> IO ()
withApp IO HeaderValue
recv HeaderValue -> IO ()
send
    (Maybe Status, Maybe Integer) -> IO (Maybe Status, Maybe Integer)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Status
forall a. Maybe a
Nothing, Maybe Integer
forall a. Maybe a
Nothing)
  where
    recv :: IO HeaderValue
recv = do
        HeaderValue
bs <- IO HeaderValue
src
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (HeaderValue -> Bool
S.null HeaderValue
bs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
T.tickle Handle
th
        HeaderValue -> IO HeaderValue
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HeaderValue
bs
    send :: HeaderValue -> IO ()
send HeaderValue
bs = Connection -> HeaderValue -> IO ()
connSendAll Connection
conn HeaderValue
bs IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
T.tickle Handle
th

----------------------------------------------------------------

-- Sophisticated WAI applications.
-- We respect s0. s0 MUST be a proper value.
sendRsp Connection
conn InternalInfo
ii Handle
th HttpVersion
ver Status
s0 [(HeaderName, HeaderValue)]
hs0 ResponseHeaderPresence
rspidxhdr Int
maxRspBufSize HeaderValue
method (RspFile FilePath
path (Just FilePart
part) IndexedRequestHeader
_ IO ()
hook) =
    Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> Status
-> [(HeaderName, HeaderValue)]
-> ResponseHeaderPresence
-> Int
-> HeaderValue
-> FilePath
-> Integer
-> Integer
-> IO ()
-> IO (Maybe Status, Maybe Integer)
sendRspFile2XX
        Connection
conn
        InternalInfo
ii
        Handle
th
        HttpVersion
ver
        Status
s0
        [(HeaderName, HeaderValue)]
hs
        ResponseHeaderPresence
rspidxhdr
        Int
maxRspBufSize
        HeaderValue
method
        FilePath
path
        Integer
beg
        Integer
len
        IO ()
hook
  where
    beg :: Integer
beg = FilePart -> Integer
filePartOffset FilePart
part
    len :: Integer
len = FilePart -> Integer
filePartByteCount FilePart
part
    hs :: [(HeaderName, HeaderValue)]
hs = [(HeaderName, HeaderValue)]
-> FilePart -> [(HeaderName, HeaderValue)]
addContentHeadersForFilePart [(HeaderName, HeaderValue)]
hs0 FilePart
part

----------------------------------------------------------------

-- Simple WAI applications.
-- Status is ignored
sendRsp Connection
conn InternalInfo
ii Handle
th HttpVersion
ver Status
_ [(HeaderName, HeaderValue)]
hs0 ResponseHeaderPresence
rspidxhdr Int
maxRspBufSize HeaderValue
method (RspFile FilePath
path Maybe FilePart
Nothing IndexedRequestHeader
reqidxhdr IO ()
hook) = do
    Either IOException FileInfo
efinfo <- IO FileInfo -> IO (Either IOException FileInfo)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO FileInfo -> IO (Either IOException FileInfo))
-> IO FileInfo -> IO (Either IOException FileInfo)
forall a b. (a -> b) -> a -> b
$ InternalInfo -> FilePath -> IO FileInfo
getFileInfo InternalInfo
ii FilePath
path
    case Either IOException FileInfo
efinfo of
        Left (IOException
_ex :: E.IOException) ->
#ifdef WARP_DEBUG
            print _ex >>
#endif
            Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> [(HeaderName, HeaderValue)]
-> ResponseHeaderPresence
-> Int
-> HeaderValue
-> IO (Maybe Status, Maybe Integer)
sendRspFile404 Connection
conn InternalInfo
ii Handle
th HttpVersion
ver [(HeaderName, HeaderValue)]
hs0 ResponseHeaderPresence
rspidxhdr Int
maxRspBufSize HeaderValue
method
        Right FileInfo
finfo -> case FileInfo
-> [(HeaderName, HeaderValue)]
-> HeaderValue
-> ResponseHeaderPresence
-> IndexedRequestHeader
-> RspFileInfo
conditionalRequest FileInfo
finfo [(HeaderName, HeaderValue)]
hs0 HeaderValue
method ResponseHeaderPresence
rspidxhdr IndexedRequestHeader
reqidxhdr of
            WithoutBody Status
s ->
                Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> Status
-> [(HeaderName, HeaderValue)]
-> ResponseHeaderPresence
-> Int
-> HeaderValue
-> Rsp
-> IO (Maybe Status, Maybe Integer)
sendRsp Connection
conn InternalInfo
ii Handle
th HttpVersion
ver Status
s [(HeaderName, HeaderValue)]
hs0 ResponseHeaderPresence
rspidxhdr Int
maxRspBufSize HeaderValue
method Rsp
RspNoBody
            WithBody Status
s [(HeaderName, HeaderValue)]
hs Integer
beg Integer
len ->
                Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> Status
-> [(HeaderName, HeaderValue)]
-> ResponseHeaderPresence
-> Int
-> HeaderValue
-> FilePath
-> Integer
-> Integer
-> IO ()
-> IO (Maybe Status, Maybe Integer)
sendRspFile2XX
                    Connection
conn
                    InternalInfo
ii
                    Handle
th
                    HttpVersion
ver
                    Status
s
                    [(HeaderName, HeaderValue)]
hs
                    ResponseHeaderPresence
rspidxhdr
                    Int
maxRspBufSize
                    HeaderValue
method
                    FilePath
path
                    Integer
beg
                    Integer
len
                    IO ()
hook

----------------------------------------------------------------

sendRspFile2XX
    :: Connection
    -> InternalInfo
    -> T.Handle
    -> H.HttpVersion
    -> H.Status
    -> H.ResponseHeaders
    -> ResponseHeaderPresence
    -> Int
    -> H.Method
    -> FilePath
    -> Integer
    -> Integer
    -> IO ()
    -> IO (Maybe H.Status, Maybe Integer)
sendRspFile2XX :: Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> Status
-> [(HeaderName, HeaderValue)]
-> ResponseHeaderPresence
-> Int
-> HeaderValue
-> FilePath
-> Integer
-> Integer
-> IO ()
-> IO (Maybe Status, Maybe Integer)
sendRspFile2XX Connection
conn InternalInfo
ii Handle
th HttpVersion
ver Status
s [(HeaderName, HeaderValue)]
hs ResponseHeaderPresence
rspidxhdr Int
maxRspBufSize HeaderValue
method FilePath
path Integer
beg Integer
len IO ()
hook
    | HeaderValue
method HeaderValue -> HeaderValue -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderValue
H.methodHead =
        -- FIXME: We could check the size of the file and add a
        -- 'Content-Length' header to give the requester more information?
        Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> Status
-> [(HeaderName, HeaderValue)]
-> ResponseHeaderPresence
-> Int
-> HeaderValue
-> Rsp
-> IO (Maybe Status, Maybe Integer)
sendRsp Connection
conn InternalInfo
ii Handle
th HttpVersion
ver Status
s [(HeaderName, HeaderValue)]
hs ResponseHeaderPresence
rspidxhdr Int
maxRspBufSize HeaderValue
method Rsp
RspNoBody
    | Bool
otherwise = do
        HeaderValue
lheader <- HttpVersion
-> Status -> [(HeaderName, HeaderValue)] -> IO HeaderValue
composeHeader HttpVersion
ver Status
s [(HeaderName, HeaderValue)]
hs
        (Maybe Fd
mfd, IO ()
fresher) <- InternalInfo -> FilePath -> IO (Maybe Fd, IO ())
getFd InternalInfo
ii FilePath
path
        let fid :: FileId
fid = FilePath -> Maybe Fd -> FileId
FileId FilePath
path Maybe Fd
mfd
            hook' :: IO ()
hook' = IO ()
hook IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
fresher
        Connection -> SendFile
connSendFile Connection
conn FileId
fid Integer
beg Integer
len IO ()
hook' [HeaderValue
lheader]
        (Maybe Status, Maybe Integer) -> IO (Maybe Status, Maybe Integer)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Status -> Maybe Status
forall a. a -> Maybe a
Just Status
s, Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
len)

sendRspFile404
    :: Connection
    -> InternalInfo
    -> T.Handle
    -> H.HttpVersion
    -> H.ResponseHeaders
    -> ResponseHeaderPresence
    -> Int
    -> H.Method
    -> IO (Maybe H.Status, Maybe Integer)
sendRspFile404 :: Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> [(HeaderName, HeaderValue)]
-> ResponseHeaderPresence
-> Int
-> HeaderValue
-> IO (Maybe Status, Maybe Integer)
sendRspFile404 Connection
conn InternalInfo
ii Handle
th HttpVersion
ver [(HeaderName, HeaderValue)]
hs0 ResponseHeaderPresence
rspidxhdr Int
maxRspBufSize HeaderValue
method =
    Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> Status
-> [(HeaderName, HeaderValue)]
-> ResponseHeaderPresence
-> Int
-> HeaderValue
-> Rsp
-> IO (Maybe Status, Maybe Integer)
sendRsp
        Connection
conn
        InternalInfo
ii
        Handle
th
        HttpVersion
ver
        Status
s
        [(HeaderName, HeaderValue)]
hs
        ResponseHeaderPresence
rspidxhdr
        Int
maxRspBufSize
        HeaderValue
method
        (Builder -> Bool -> Rsp
RspBuilder Builder
body Bool
True)
  where
    s :: Status
s = Status
H.notFound404
    hs :: [(HeaderName, HeaderValue)]
hs = HeaderName
-> HeaderValue
-> [(HeaderName, HeaderValue)]
-> [(HeaderName, HeaderValue)]
replaceHeader HeaderName
Header.hContentType HeaderValue
"text/plain; charset=utf-8" [(HeaderName, HeaderValue)]
hs0
    body :: Builder
body = HeaderValue -> Builder
byteString HeaderValue
"File not found"

----------------------------------------------------------------
----------------------------------------------------------------

-- | Use 'connSendAll' to send this data while respecting timeout rules.
sendFragment :: Connection -> T.Handle -> ByteString -> IO ()
sendFragment :: Connection -> Handle -> HeaderValue -> IO ()
sendFragment Connection{connSendAll :: Connection -> HeaderValue -> IO ()
connSendAll = HeaderValue -> IO ()
send} Handle
th HeaderValue
bs = do
    Handle -> IO ()
T.resume Handle
th
    HeaderValue -> IO ()
send HeaderValue
bs
    Handle -> IO ()
T.pause Handle
th

-- 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.

----------------------------------------------------------------

-- | We infer from the request whether the connection should be persisted.
checkReqConnectionHeader :: Bool -> IndexedRequestHeader -> Bool
checkReqConnectionHeader :: Bool -> IndexedRequestHeader -> Bool
checkReqConnectionHeader Bool
isHttp11 IndexedRequestHeader
reqidxhdr =
    case IndexedRequestHeader -> Maybe HeaderValue
reqidxConnection IndexedRequestHeader
reqidxhdr of
        -- If no "Connection" header, then default: HTTP/1.1 == persist
        Maybe HeaderValue
Nothing -> Bool
isHttp11
        Just HeaderValue
val ->
            let connValue :: HeaderValue
connValue = HeaderValue -> HeaderValue
forall s. FoldCase s => s -> s
CI.foldCase HeaderValue
val
             in if Bool
isHttp11
                    then HeaderValue
connValue HeaderValue -> HeaderValue -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderValue
"close"
                    else HeaderValue
connValue HeaderValue -> HeaderValue -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderValue
"keep-alive"

----------------------------------------------------------------

-- | Only checks for status codes, NOT for methods.
--
-- This is by design and some handling relies on HEAD being a separate check.
hasBody :: H.Status -> Bool
hasBody :: Status -> Bool
hasBody Status
s =
    Int
sc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
204
        Bool -> Bool -> Bool
&& Int
sc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
304
        Bool -> Bool -> Bool
&& Int
sc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
200
  where
    sc :: Int
sc = Status -> Int
H.statusCode Status
s

----------------------------------------------------------------

-- | We ASSUME there's no middleware that will chunk the transfer, so
-- we'll add it to the headers if there's no other encoding, or add it
-- to the end in case it is.
-- (e.g. if a 'Middleware' were to add "Transfer-Encoding: gzip")
addTransferEncoding :: ResponseHeaderPresence -> H.ResponseHeaders -> H.ResponseHeaders
addTransferEncoding :: ResponseHeaderPresence
-> [(HeaderName, HeaderValue)] -> [(HeaderName, HeaderValue)]
addTransferEncoding ResponseHeaderPresence
rspidxhdr =
    case ResponseHeaderPresence -> Maybe HeaderValue
hasTransferEncoding ResponseHeaderPresence
rspidxhdr of
        Just HeaderValue
value -> HeaderName
-> HeaderValue
-> [(HeaderName, HeaderValue)]
-> [(HeaderName, HeaderValue)]
replaceHeader HeaderName
Header.hTransferEncoding (HeaderValue
value HeaderValue -> HeaderValue -> HeaderValue
forall a. Semigroup a => a -> a -> a
<> HeaderValue
", chunked")
        Maybe HeaderValue
Nothing -> ((HeaderName
Header.hTransferEncoding, HeaderValue
"chunked") (HeaderName, HeaderValue)
-> [(HeaderName, HeaderValue)] -> [(HeaderName, HeaderValue)]
forall a. a -> [a] -> [a]
:)

addDate
    :: IO D.GMTDate -> ResponseHeaderPresence -> H.ResponseHeaders -> IO H.ResponseHeaders
addDate :: IO HeaderValue
-> ResponseHeaderPresence
-> [(HeaderName, HeaderValue)]
-> IO [(HeaderName, HeaderValue)]
addDate IO HeaderValue
getdate ResponseHeaderPresence
rspidxhdr [(HeaderName, HeaderValue)]
hdrs
    | ResponseHeaderPresence -> Bool
hasDate ResponseHeaderPresence
rspidxhdr = [(HeaderName, HeaderValue)] -> IO [(HeaderName, HeaderValue)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(HeaderName, HeaderValue)]
hdrs
    | Bool
otherwise = do
        HeaderValue
gmtdate <- IO HeaderValue
getdate
        [(HeaderName, HeaderValue)] -> IO [(HeaderName, HeaderValue)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(HeaderName, HeaderValue)] -> IO [(HeaderName, HeaderValue)])
-> [(HeaderName, HeaderValue)] -> IO [(HeaderName, HeaderValue)]
forall a b. (a -> b) -> a -> b
$ (HeaderName
Header.hDate, HeaderValue
gmtdate) (HeaderName, HeaderValue)
-> [(HeaderName, HeaderValue)] -> [(HeaderName, HeaderValue)]
forall a. a -> [a] -> [a]
: [(HeaderName, HeaderValue)]
hdrs

----------------------------------------------------------------

{-# INLINE addServer #-}
addServer
    :: HeaderValue -> ResponseHeaderPresence -> H.ResponseHeaders -> H.ResponseHeaders
addServer :: HeaderValue
-> ResponseHeaderPresence
-> [(HeaderName, HeaderValue)]
-> [(HeaderName, HeaderValue)]
addServer HeaderValue
serverName ResponseHeaderPresence
rspidxhdr [(HeaderName, HeaderValue)]
hdrs =
    case HeaderValue
serverName of
        -- empty string means there shouldn't be a "Server" header
        HeaderValue
""
            | Bool
serverPresent -> ((HeaderName, HeaderValue) -> Bool)
-> [(HeaderName, HeaderValue)] -> [(HeaderName, HeaderValue)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
Header.hServer) (HeaderName -> Bool)
-> ((HeaderName, HeaderValue) -> HeaderName)
-> (HeaderName, HeaderValue)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, HeaderValue) -> HeaderName
forall a b. (a, b) -> a
fst) [(HeaderName, HeaderValue)]
hdrs
            | Bool
otherwise -> [(HeaderName, HeaderValue)]
hdrs
        -- Anything else should set the "Server" header if it isn't already set
        HeaderValue
_
            | Bool -> Bool
not Bool
serverPresent -> (HeaderName
Header.hServer, HeaderValue
serverName) (HeaderName, HeaderValue)
-> [(HeaderName, HeaderValue)] -> [(HeaderName, HeaderValue)]
forall a. a -> [a] -> [a]
: [(HeaderName, HeaderValue)]
hdrs
            | Bool
otherwise -> [(HeaderName, HeaderValue)]
hdrs
  where
    serverPresent :: Bool
serverPresent = ResponseHeaderPresence -> Bool
hasServer ResponseHeaderPresence
rspidxhdr

addAltSvc :: Settings -> H.ResponseHeaders -> H.ResponseHeaders
addAltSvc :: Settings
-> [(HeaderName, HeaderValue)] -> [(HeaderName, HeaderValue)]
addAltSvc Settings
settings [(HeaderName, HeaderValue)]
hs = case Settings -> Maybe HeaderValue
settingsAltSvc Settings
settings of
    Maybe HeaderValue
Nothing -> [(HeaderName, HeaderValue)]
hs
    Just HeaderValue
v -> (HeaderName
"Alt-Svc", HeaderValue
v) (HeaderName, HeaderValue)
-> [(HeaderName, HeaderValue)] -> [(HeaderName, HeaderValue)]
forall a. a -> [a] -> [a]
: [(HeaderName, HeaderValue)]
hs

----------------------------------------------------------------

-- | Replaces a header, instead of just adding it which might lead to
-- duplicate entries of the same header name.
--
-- >>> replaceHeader "Content-Type" "new" [("content-type","old")]
-- [("Content-Type","new")]
replaceHeader
    :: H.HeaderName -> HeaderValue -> H.ResponseHeaders -> H.ResponseHeaders
replaceHeader :: HeaderName
-> HeaderValue
-> [(HeaderName, HeaderValue)]
-> [(HeaderName, HeaderValue)]
replaceHeader HeaderName
k HeaderValue
v [(HeaderName, HeaderValue)]
hdrs = (HeaderName
k, HeaderValue
v) (HeaderName, HeaderValue)
-> [(HeaderName, HeaderValue)] -> [(HeaderName, HeaderValue)]
forall a. a -> [a] -> [a]
: ((HeaderName, HeaderValue) -> Bool)
-> [(HeaderName, HeaderValue)] -> [(HeaderName, HeaderValue)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
k) (HeaderName -> Bool)
-> ((HeaderName, HeaderValue) -> HeaderName)
-> (HeaderName, HeaderValue)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, HeaderValue) -> HeaderName
forall a b. (a, b) -> a
fst) [(HeaderName, HeaderValue)]
hdrs

----------------------------------------------------------------

composeHeaderBuilder
    :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> ResponseHeaderPresence -> Bool -> IO (Builder, Int)
composeHeaderBuilder :: HttpVersion
-> Status
-> [(HeaderName, HeaderValue)]
-> ResponseHeaderPresence
-> Bool
-> IO (Builder, Int)
composeHeaderBuilder HttpVersion
ver Status
s [(HeaderName, HeaderValue)]
hs ResponseHeaderPresence
rspidxhdr Bool
shouldChunk = do
    HeaderValue
bs <- HttpVersion
-> Status -> [(HeaderName, HeaderValue)] -> IO HeaderValue
composeHeader HttpVersion
ver Status
s [(HeaderName, HeaderValue)]
finalHdrs
    (Builder, Int) -> IO (Builder, Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HeaderValue -> Builder
byteString HeaderValue
bs, HeaderValue -> Int
S.length HeaderValue
bs)
  where
    finalHdrs :: [(HeaderName, HeaderValue)]
finalHdrs
        | Bool
shouldChunk = ResponseHeaderPresence
-> [(HeaderName, HeaderValue)] -> [(HeaderName, HeaderValue)]
addTransferEncoding ResponseHeaderPresence
rspidxhdr [(HeaderName, HeaderValue)]
hs
        | Bool
otherwise = [(HeaderName, HeaderValue)]
hs