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

module Network.Wai.Handler.Warp.Response (
    sendResponse,
    sanitizeHeaderValue, -- for testing
    warpVersion,
    hasBody,
    replaceHeader,
    addServer, -- testing
    addAltSvc,
) where

import Data.Array ((!))
import qualified Data.ByteString as S
import Data.ByteString.Builder (Builder, byteString)
import Data.ByteString.Builder.Extra (flush)
import Data.ByteString.Builder.HTTP.Chunked (
    chunkedTransferEncoding,
    chunkedTransferTerminator,
 )
import qualified Data.ByteString.Char8 as C8
import qualified Data.CaseInsensitive as CI
import Data.Function (on)
import Data.List (deleteBy)
import Data.Streaming.ByteString.Builder (
    newByteStringBuilderRecv,
    reuseBufferStrategy,
 )
import Data.Version (showVersion)
import Data.Word8 (_cr, _lf, _space, _tab)
import qualified Network.HTTP.Types as H
import qualified Network.HTTP.Types.Header as H
import Network.Wai
import Network.Wai.Internal
import qualified Paths_warp
import qualified System.TimeManager as T
import qualified UnliftIO

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)
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.
    -> IndexedHeader
    -- ^ 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
-> IndexedHeader
-> IO HeaderValue
-> Response
-> IO Bool
sendResponse Settings
settings Connection
conn InternalInfo
ii Handle
th Request
req IndexedHeader
reqidxhdr IO HeaderValue
src Response
response = do
    ResponseHeaders
hs <- Settings -> ResponseHeaders -> ResponseHeaders
addAltSvc Settings
settings (ResponseHeaders -> ResponseHeaders)
-> IO ResponseHeaders -> IO ResponseHeaders
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResponseHeaders -> IO ResponseHeaders
addServerAndDate ResponseHeaders
hs0
    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
-> ResponseHeaders
-> IndexedHeader
-> Int
-> HeaderValue
-> Rsp
-> IO (Maybe Status, Maybe Integer)
sendRsp Connection
conn InternalInfo
ii Handle
th HttpVersion
ver Status
s ResponseHeaders
hs IndexedHeader
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
            Handle -> IO ()
T.tickle Handle
th
            Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ret
        else do
            (Maybe Status, Maybe Integer)
_ <- Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> Status
-> ResponseHeaders
-> IndexedHeader
-> Int
-> HeaderValue
-> Rsp
-> IO (Maybe Status, Maybe Integer)
sendRsp Connection
conn InternalInfo
ii Handle
th HttpVersion
ver Status
s ResponseHeaders
hs IndexedHeader
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
isPersist
  where
    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
    ver :: HttpVersion
ver = Request -> HttpVersion
httpVersion Request
req
    s :: Status
s = Response -> Status
responseStatus Response
response
    hs0 :: ResponseHeaders
hs0 = ResponseHeaders -> ResponseHeaders
sanitizeHeaders (ResponseHeaders -> ResponseHeaders)
-> ResponseHeaders -> ResponseHeaders
forall a b. (a -> b) -> a -> b
$ Response -> ResponseHeaders
responseHeaders Response
response
    rspidxhdr :: IndexedHeader
rspidxhdr = ResponseHeaders -> IndexedHeader
indexResponseHeader ResponseHeaders
hs0
    getdate :: IO HeaderValue
getdate = InternalInfo -> IO HeaderValue
getDate InternalInfo
ii
    addServerAndDate :: ResponseHeaders -> IO ResponseHeaders
addServerAndDate = IO HeaderValue
-> IndexedHeader -> ResponseHeaders -> IO ResponseHeaders
addDate IO HeaderValue
getdate IndexedHeader
rspidxhdr (ResponseHeaders -> IO ResponseHeaders)
-> (ResponseHeaders -> ResponseHeaders)
-> ResponseHeaders
-> IO ResponseHeaders
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderValue -> IndexedHeader -> ResponseHeaders -> ResponseHeaders
addServer HeaderValue
defServer IndexedHeader
rspidxhdr
    (Bool
isPersist, Bool
isChunked0) = Request -> IndexedHeader -> (Bool, Bool)
infoFromRequest Request
req IndexedHeader
reqidxhdr
    isChunked :: Bool
isChunked = Bool -> Bool
not Bool
isHead Bool -> Bool -> Bool
&& Bool
isChunked0
    (Bool
isKeepAlive, Bool
needsChunked) = IndexedHeader -> (Bool, Bool) -> (Bool, Bool)
infoFromResponse IndexedHeader
rspidxhdr (Bool
isPersist, Bool
isChunked)
    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
    rsp :: Rsp
rsp = case Response
response of
        ResponseFile Status
_ ResponseHeaders
_ FilePath
path Maybe FilePart
mPart -> FilePath -> Maybe FilePart -> IndexedHeader -> IO () -> Rsp
RspFile FilePath
path Maybe FilePart
mPart IndexedHeader
reqidxhdr (Handle -> IO ()
T.tickle Handle
th)
        ResponseBuilder Status
_ ResponseHeaders
_ Builder
b
            | Bool
isHead -> Rsp
RspNoBody
            | Bool
otherwise -> Builder -> Bool -> Rsp
RspBuilder Builder
b Bool
needsChunked
        ResponseStream Status
_ ResponseHeaders
_ 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
    -- Make sure we don't hang on to 'response' (avoid space leak)
    !ret :: Bool
ret = case Response
response of
        ResponseFile{} -> Bool
isPersist
        ResponseBuilder{} -> Bool
isKeepAlive
        ResponseStream{} -> Bool
isKeepAlive
        ResponseRaw{} -> Bool
False

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

sanitizeHeaders :: H.ResponseHeaders -> H.ResponseHeaders
sanitizeHeaders :: ResponseHeaders -> ResponseHeaders
sanitizeHeaders = (Header -> Header) -> ResponseHeaders -> ResponseHeaders
forall a b. (a -> b) -> [a] -> [b]
map (HeaderValue -> HeaderValue
sanitize (HeaderValue -> HeaderValue) -> Header -> Header
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
  where
    sanitize :: HeaderValue -> HeaderValue
sanitize HeaderValue
v
        | HeaderValue -> Bool
containsNewlines HeaderValue
v = HeaderValue -> HeaderValue
sanitizeHeaderValue HeaderValue
v -- slow path
        | Bool
otherwise = HeaderValue
v -- fast path

{-# INLINE containsNewlines #-}
containsNewlines :: ByteString -> Bool
containsNewlines :: HeaderValue -> Bool
containsNewlines = (Word8 -> Bool) -> HeaderValue -> Bool
S.any (\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)

{-# INLINE sanitizeHeaderValue #-}
sanitizeHeaderValue :: ByteString -> ByteString
sanitizeHeaderValue :: HeaderValue -> HeaderValue
sanitizeHeaderValue HeaderValue
v = case HeaderValue -> [HeaderValue]
C8.lines (HeaderValue -> [HeaderValue]) -> HeaderValue -> [HeaderValue]
forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> HeaderValue -> HeaderValue
S.filter (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
_cr) HeaderValue
v of
    [] -> HeaderValue
""
    HeaderValue
x : [HeaderValue]
xs -> HeaderValue -> [HeaderValue] -> HeaderValue
C8.intercalate HeaderValue
"\r\n" (HeaderValue
x HeaderValue -> [HeaderValue] -> [HeaderValue]
forall a. a -> [a] -> [a]
: (HeaderValue -> Maybe HeaderValue)
-> [HeaderValue] -> [HeaderValue]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe HeaderValue -> Maybe HeaderValue
addSpaceIfMissing [HeaderValue]
xs)
  where
    addSpaceIfMissing :: HeaderValue -> Maybe HeaderValue
addSpaceIfMissing HeaderValue
line = case HeaderValue -> Maybe (Word8, HeaderValue)
S.uncons HeaderValue
line of
        Maybe (Word8, HeaderValue)
Nothing -> Maybe HeaderValue
forall a. Maybe a
Nothing
        Just (Word8
first, HeaderValue
_)
            | Word8
first Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_space Bool -> Bool -> Bool
|| Word8
first Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_tab -> HeaderValue -> Maybe HeaderValue
forall a. a -> Maybe a
Just HeaderValue
line
            | Bool
otherwise -> HeaderValue -> Maybe HeaderValue
forall a. a -> Maybe a
Just (HeaderValue -> Maybe HeaderValue)
-> HeaderValue -> Maybe HeaderValue
forall a b. (a -> b) -> a -> b
$ Word8
_space Word8 -> HeaderValue -> HeaderValue
`S.cons` HeaderValue
line

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

data Rsp
    = RspNoBody
    | RspFile FilePath (Maybe FilePart) IndexedHeader (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
    -> IndexedHeader -- Response
    -> Int -- maxBuilderResponseBufferSize
    -> H.Method
    -> Rsp
    -> IO (Maybe H.Status, Maybe Integer)
----------------------------------------------------------------

sendRsp :: Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> Status
-> ResponseHeaders
-> IndexedHeader
-> Int
-> HeaderValue
-> Rsp
-> IO (Maybe Status, Maybe Integer)
sendRsp Connection
conn InternalInfo
_ Handle
_ HttpVersion
ver Status
s ResponseHeaders
hs IndexedHeader
_ Int
_ HeaderValue
_ Rsp
RspNoBody = do
    -- Not adding Content-Length.
    -- User agents treats it as Content-Length: 0.
    HttpVersion -> Status -> ResponseHeaders -> IO HeaderValue
composeHeader HttpVersion
ver Status
s ResponseHeaders
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, Maybe Integer
forall a. Maybe a
Nothing)

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

sendRsp Connection
conn InternalInfo
_ Handle
th HttpVersion
ver Status
s ResponseHeaders
hs IndexedHeader
_ Int
maxRspBufSize HeaderValue
_ (RspBuilder Builder
body Bool
needsChunked) = do
    Builder
header <- HttpVersion -> Status -> ResponseHeaders -> Bool -> IO Builder
composeHeaderBuilder HttpVersion
ver Status
s ResponseHeaders
hs Bool
needsChunked
    let hdrBdy :: Builder
hdrBdy
            | Bool
needsChunked =
                Builder
header
                    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
chunkedTransferEncoding Builder
body
                    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
chunkedTransferTerminator
            | Bool
otherwise = Builder
header Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
body
        writeBufferRef :: IORef WriteBuffer
writeBufferRef = Connection -> IORef WriteBuffer
connWriteBuffer Connection
conn
    Integer
len <-
        Int
-> IORef WriteBuffer
-> (HeaderValue -> IO ())
-> Builder
-> IO Integer
toBufIOWith
            Int
maxRspBufSize
            IORef WriteBuffer
writeBufferRef
            (\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)
            Builder
hdrBdy
    (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)

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

sendRsp Connection
conn InternalInfo
_ Handle
th HttpVersion
ver Status
s ResponseHeaders
hs IndexedHeader
_ Int
_ HeaderValue
_ (RspStream StreamingBody
streamingBody Bool
needsChunked) = do
    Builder
header <- HttpVersion -> Status -> ResponseHeaders -> Bool -> IO Builder
composeHeaderBuilder HttpVersion
ver Status
s ResponseHeaders
hs 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
    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
                        Connection -> Handle -> HeaderValue -> IO ()
sendFragment Connection
conn Handle
th 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
    Maybe HeaderValue
mbs <- BuilderFinish
finish
    IO () -> (HeaderValue -> IO ()) -> Maybe HeaderValue -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Connection -> Handle -> HeaderValue -> IO ()
sendFragment Connection
conn Handle
th) Maybe HeaderValue
mbs
    (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, Maybe Integer
forall a. Maybe a
Nothing) -- fixme: can we tell the actual sent bytes?

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

sendRsp Connection
conn InternalInfo
_ Handle
th HttpVersion
_ Status
_ ResponseHeaders
_ IndexedHeader
_ 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 ResponseHeaders
hs0 IndexedHeader
rspidxhdr Int
maxRspBufSize HeaderValue
method (RspFile FilePath
path (Just FilePart
part) IndexedHeader
_ IO ()
hook) =
    Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> Status
-> ResponseHeaders
-> IndexedHeader
-> Int
-> HeaderValue
-> FilePath
-> Integer
-> Integer
-> IO ()
-> IO (Maybe Status, Maybe Integer)
sendRspFile2XX
        Connection
conn
        InternalInfo
ii
        Handle
th
        HttpVersion
ver
        Status
s0
        ResponseHeaders
hs
        IndexedHeader
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 :: ResponseHeaders
hs = ResponseHeaders -> FilePart -> ResponseHeaders
addContentHeadersForFilePart ResponseHeaders
hs0 FilePart
part

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

-- Simple WAI applications.
-- Status is ignored
sendRsp Connection
conn InternalInfo
ii Handle
th HttpVersion
ver Status
_ ResponseHeaders
hs0 IndexedHeader
rspidxhdr Int
maxRspBufSize HeaderValue
method (RspFile FilePath
path Maybe FilePart
Nothing IndexedHeader
reqidxhdr IO ()
hook) = do
    Either IOException FileInfo
efinfo <- IO FileInfo -> IO (Either IOException FileInfo)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOException a)
UnliftIO.tryIO (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 :: UnliftIO.IOException) ->
#ifdef WARP_DEBUG
            print _ex >>
#endif
            Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> ResponseHeaders
-> IndexedHeader
-> Int
-> HeaderValue
-> IO (Maybe Status, Maybe Integer)
sendRspFile404 Connection
conn InternalInfo
ii Handle
th HttpVersion
ver ResponseHeaders
hs0 IndexedHeader
rspidxhdr Int
maxRspBufSize HeaderValue
method
        Right FileInfo
finfo -> case FileInfo
-> ResponseHeaders
-> HeaderValue
-> IndexedHeader
-> IndexedHeader
-> RspFileInfo
conditionalRequest FileInfo
finfo ResponseHeaders
hs0 HeaderValue
method IndexedHeader
rspidxhdr IndexedHeader
reqidxhdr of
            WithoutBody Status
s ->
                Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> Status
-> ResponseHeaders
-> IndexedHeader
-> Int
-> HeaderValue
-> Rsp
-> IO (Maybe Status, Maybe Integer)
sendRsp Connection
conn InternalInfo
ii Handle
th HttpVersion
ver Status
s ResponseHeaders
hs0 IndexedHeader
rspidxhdr Int
maxRspBufSize HeaderValue
method Rsp
RspNoBody
            WithBody Status
s ResponseHeaders
hs Integer
beg Integer
len ->
                Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> Status
-> ResponseHeaders
-> IndexedHeader
-> Int
-> HeaderValue
-> FilePath
-> Integer
-> Integer
-> IO ()
-> IO (Maybe Status, Maybe Integer)
sendRspFile2XX
                    Connection
conn
                    InternalInfo
ii
                    Handle
th
                    HttpVersion
ver
                    Status
s
                    ResponseHeaders
hs
                    IndexedHeader
rspidxhdr
                    Int
maxRspBufSize
                    HeaderValue
method
                    FilePath
path
                    Integer
beg
                    Integer
len
                    IO ()
hook

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

sendRspFile2XX
    :: Connection
    -> InternalInfo
    -> T.Handle
    -> H.HttpVersion
    -> H.Status
    -> H.ResponseHeaders
    -> IndexedHeader
    -> Int
    -> H.Method
    -> FilePath
    -> Integer
    -> Integer
    -> IO ()
    -> IO (Maybe H.Status, Maybe Integer)
sendRspFile2XX :: Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> Status
-> ResponseHeaders
-> IndexedHeader
-> Int
-> HeaderValue
-> FilePath
-> Integer
-> Integer
-> IO ()
-> IO (Maybe Status, Maybe Integer)
sendRspFile2XX Connection
conn InternalInfo
ii Handle
th HttpVersion
ver Status
s ResponseHeaders
hs IndexedHeader
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 =
        Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> Status
-> ResponseHeaders
-> IndexedHeader
-> Int
-> HeaderValue
-> Rsp
-> IO (Maybe Status, Maybe Integer)
sendRsp Connection
conn InternalInfo
ii Handle
th HttpVersion
ver Status
s ResponseHeaders
hs IndexedHeader
rspidxhdr Int
maxRspBufSize HeaderValue
method Rsp
RspNoBody
    | Bool
otherwise = do
        HeaderValue
lheader <- HttpVersion -> Status -> ResponseHeaders -> IO HeaderValue
composeHeader HttpVersion
ver Status
s ResponseHeaders
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
    -> IndexedHeader
    -> Int
    -> H.Method
    -> IO (Maybe H.Status, Maybe Integer)
sendRspFile404 :: Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> ResponseHeaders
-> IndexedHeader
-> Int
-> HeaderValue
-> IO (Maybe Status, Maybe Integer)
sendRspFile404 Connection
conn InternalInfo
ii Handle
th HttpVersion
ver ResponseHeaders
hs0 IndexedHeader
rspidxhdr Int
maxRspBufSize HeaderValue
method =
    Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> Status
-> ResponseHeaders
-> IndexedHeader
-> Int
-> HeaderValue
-> Rsp
-> IO (Maybe Status, Maybe Integer)
sendRsp
        Connection
conn
        InternalInfo
ii
        Handle
th
        HttpVersion
ver
        Status
s
        ResponseHeaders
hs
        IndexedHeader
rspidxhdr
        Int
maxRspBufSize
        HeaderValue
method
        (Builder -> Bool -> Rsp
RspBuilder Builder
body Bool
True)
  where
    s :: Status
s = Status
H.notFound404
    hs :: ResponseHeaders
hs = HeaderName -> HeaderValue -> ResponseHeaders -> ResponseHeaders
replaceHeader HeaderName
H.hContentType HeaderValue
"text/plain; charset=utf-8" ResponseHeaders
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.

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

infoFromRequest
    :: Request
    -> IndexedHeader
    -> ( Bool -- isPersist
       , Bool -- isChunked
       )
infoFromRequest :: Request -> IndexedHeader -> (Bool, Bool)
infoFromRequest Request
req IndexedHeader
reqidxhdr = (Request -> IndexedHeader -> Bool
checkPersist Request
req IndexedHeader
reqidxhdr, Request -> Bool
checkChunk Request
req)

checkPersist :: Request -> IndexedHeader -> Bool
checkPersist :: Request -> IndexedHeader -> Bool
checkPersist Request
req IndexedHeader
reqidxhdr
    | HttpVersion
ver HttpVersion -> HttpVersion -> Bool
forall a. Eq a => a -> a -> Bool
== HttpVersion
H.http11 = Maybe HeaderValue -> Bool
forall {a}. (Eq a, FoldCase a, IsString a) => Maybe a -> Bool
checkPersist11 Maybe HeaderValue
conn
    | Bool
otherwise = Maybe HeaderValue -> Bool
forall {a}. (Eq a, FoldCase a, IsString a) => Maybe a -> Bool
checkPersist10 Maybe HeaderValue
conn
  where
    ver :: HttpVersion
ver = Request -> HttpVersion
httpVersion Request
req
    conn :: Maybe HeaderValue
conn = IndexedHeader
reqidxhdr IndexedHeader -> Int -> Maybe HeaderValue
forall i e. Ix i => Array i e -> i -> e
! RequestHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqConnection
    checkPersist11 :: Maybe a -> Bool
checkPersist11 (Just a
x)
        | a -> a
forall s. FoldCase s => s -> s
CI.foldCase a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
"close" = Bool
False
    checkPersist11 Maybe a
_ = Bool
True
    checkPersist10 :: Maybe a -> Bool
checkPersist10 (Just a
x)
        | a -> a
forall s. FoldCase s => s -> s
CI.foldCase a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
"keep-alive" = Bool
True
    checkPersist10 Maybe a
_ = Bool
False

checkChunk :: Request -> Bool
checkChunk :: Request -> Bool
checkChunk Request
req = Request -> HttpVersion
httpVersion Request
req HttpVersion -> HttpVersion -> Bool
forall a. Eq a => a -> a -> Bool
== HttpVersion
H.http11

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

-- Used for ResponseBuilder and ResponseSource.
-- Don't use this for ResponseFile since this logic does not fit
-- for ResponseFile. For instance, isKeepAlive should be True in some cases
-- even if the response header does not have Content-Length.
--
-- Content-Length is specified by a reverse proxy.
-- Note that CGI does not specify Content-Length.
infoFromResponse :: IndexedHeader -> (Bool, Bool) -> (Bool, Bool)
infoFromResponse :: IndexedHeader -> (Bool, Bool) -> (Bool, Bool)
infoFromResponse IndexedHeader
rspidxhdr (Bool
isPersist, Bool
isChunked) = (Bool
isKeepAlive, Bool
needsChunked)
  where
    needsChunked :: Bool
needsChunked = Bool
isChunked Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
hasLength
    isKeepAlive :: Bool
isKeepAlive = Bool
isPersist Bool -> Bool -> Bool
&& (Bool
isChunked Bool -> Bool -> Bool
|| Bool
hasLength)
    hasLength :: Bool
hasLength = Maybe HeaderValue -> Bool
forall a. Maybe a -> Bool
isJust (Maybe HeaderValue -> Bool) -> Maybe HeaderValue -> Bool
forall a b. (a -> b) -> a -> b
$ IndexedHeader
rspidxhdr IndexedHeader -> Int -> Maybe HeaderValue
forall i e. Ix i => Array i e -> i -> e
! ResponseHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum ResponseHeaderIndex
ResContentLength

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

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

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

addTransferEncoding :: H.ResponseHeaders -> H.ResponseHeaders
addTransferEncoding :: ResponseHeaders -> ResponseHeaders
addTransferEncoding ResponseHeaders
hdrs = (HeaderName
H.hTransferEncoding, HeaderValue
"chunked") Header -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: ResponseHeaders
hdrs

addDate
    :: IO D.GMTDate -> IndexedHeader -> H.ResponseHeaders -> IO H.ResponseHeaders
addDate :: IO HeaderValue
-> IndexedHeader -> ResponseHeaders -> IO ResponseHeaders
addDate IO HeaderValue
getdate IndexedHeader
rspidxhdr ResponseHeaders
hdrs = case IndexedHeader
rspidxhdr IndexedHeader -> Int -> Maybe HeaderValue
forall i e. Ix i => Array i e -> i -> e
! ResponseHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum ResponseHeaderIndex
ResDate of
    Maybe HeaderValue
Nothing -> do
        HeaderValue
gmtdate <- IO HeaderValue
getdate
        ResponseHeaders -> IO ResponseHeaders
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ResponseHeaders -> IO ResponseHeaders)
-> ResponseHeaders -> IO ResponseHeaders
forall a b. (a -> b) -> a -> b
$ (HeaderName
H.hDate, HeaderValue
gmtdate) Header -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: ResponseHeaders
hdrs
    Just HeaderValue
_ -> ResponseHeaders -> IO ResponseHeaders
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ResponseHeaders
hdrs

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

-- | The version of Warp.
warpVersion :: String
warpVersion :: FilePath
warpVersion = Version -> FilePath
showVersion Version
Paths_warp.version

{-# INLINE addServer #-}
addServer
    :: HeaderValue -> IndexedHeader -> H.ResponseHeaders -> H.ResponseHeaders
addServer :: HeaderValue -> IndexedHeader -> ResponseHeaders -> ResponseHeaders
addServer HeaderValue
"" IndexedHeader
rspidxhdr ResponseHeaders
hdrs = case IndexedHeader
rspidxhdr IndexedHeader -> Int -> Maybe HeaderValue
forall i e. Ix i => Array i e -> i -> e
! ResponseHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum ResponseHeaderIndex
ResServer of
    Maybe HeaderValue
Nothing -> ResponseHeaders
hdrs
    Maybe HeaderValue
_ -> (Header -> Bool) -> ResponseHeaders -> ResponseHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter ((HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
H.hServer) (HeaderName -> Bool) -> (Header -> HeaderName) -> Header -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header -> HeaderName
forall a b. (a, b) -> a
fst) ResponseHeaders
hdrs
addServer HeaderValue
serverName IndexedHeader
rspidxhdr ResponseHeaders
hdrs = case IndexedHeader
rspidxhdr IndexedHeader -> Int -> Maybe HeaderValue
forall i e. Ix i => Array i e -> i -> e
! ResponseHeaderIndex -> Int
forall a. Enum a => a -> Int
fromEnum ResponseHeaderIndex
ResServer of
    Maybe HeaderValue
Nothing -> (HeaderName
H.hServer, HeaderValue
serverName) Header -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: ResponseHeaders
hdrs
    Maybe HeaderValue
_ -> ResponseHeaders
hdrs

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

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

-- |
--
-- >>> replaceHeader "Content-Type" "new" [("content-type","old")]
-- [("Content-Type","new")]
replaceHeader
    :: H.HeaderName -> HeaderValue -> H.ResponseHeaders -> H.ResponseHeaders
replaceHeader :: HeaderName -> HeaderValue -> ResponseHeaders -> ResponseHeaders
replaceHeader HeaderName
k HeaderValue
v ResponseHeaders
hdrs = (HeaderName
k, HeaderValue
v) Header -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: (Header -> Header -> Bool)
-> Header -> ResponseHeaders -> ResponseHeaders
forall a. (a -> a -> Bool) -> a -> [a] -> [a]
deleteBy (HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
(==) (HeaderName -> HeaderName -> Bool)
-> (Header -> HeaderName) -> Header -> Header -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Header -> HeaderName
forall a b. (a, b) -> a
fst) (HeaderName
k, HeaderValue
v) ResponseHeaders
hdrs

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

composeHeaderBuilder
    :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder
composeHeaderBuilder :: HttpVersion -> Status -> ResponseHeaders -> Bool -> IO Builder
composeHeaderBuilder HttpVersion
ver Status
s ResponseHeaders
hs Bool
True =
    HeaderValue -> Builder
byteString (HeaderValue -> Builder) -> IO HeaderValue -> IO Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HttpVersion -> Status -> ResponseHeaders -> IO HeaderValue
composeHeader HttpVersion
ver Status
s (ResponseHeaders -> ResponseHeaders
addTransferEncoding ResponseHeaders
hs)
composeHeaderBuilder HttpVersion
ver Status
s ResponseHeaders
hs Bool
False =
    HeaderValue -> Builder
byteString (HeaderValue -> Builder) -> IO HeaderValue -> IO Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HttpVersion -> Status -> ResponseHeaders -> IO HeaderValue
composeHeader HttpVersion
ver Status
s ResponseHeaders
hs