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

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

import Data.ByteString.Builder.HTTP.Chunked (chunkedTransferEncoding, chunkedTransferTerminator)
import qualified UnliftIO
import Data.Array ((!))
import qualified Data.ByteString as S
import Data.ByteString.Builder (byteString, Builder)
import Data.ByteString.Builder.Extra (flush)
import qualified Data.ByteString.Char8 as C8
import qualified Data.CaseInsensitive as CI
import Data.Function (on)
import Data.Streaming.ByteString.Builder (newByteStringBuilderRecv, reuseBufferStrategy)
import Data.Version (showVersion)
import Data.Word8 (_cr, _lf)
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 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 infor 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 ByteString
-> Response
-> IO Bool
sendResponse Settings
settings Connection
conn InternalInfo
ii Handle
th Request
req IndexedHeader
reqidxhdr IO ByteString
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
-> Rsp
-> IO (Maybe Status, Maybe Integer)
sendRsp Connection
conn InternalInfo
ii Handle
th HttpVersion
ver Status
s ResponseHeaders
hs IndexedHeader
rspidxhdr Rsp
rsp
        case Maybe Status
ms of
            Maybe Status
Nothing         -> () -> IO ()
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 (m :: * -> *) a. Monad m => a -> m a
return Bool
ret
      else do
        (Maybe Status, Maybe Integer)
_ <- Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> Status
-> ResponseHeaders
-> IndexedHeader
-> Rsp
-> IO (Maybe Status, Maybe Integer)
sendRsp Connection
conn InternalInfo
ii Handle
th HttpVersion
ver Status
s ResponseHeaders
hs IndexedHeader
rspidxhdr 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 (m :: * -> *) a. Monad m => a -> m a
return Bool
isPersist
  where
    defServer :: ByteString
defServer = Settings -> ByteString
settingsServerName Settings
settings
    logger :: Request -> Status -> Maybe Integer -> IO ()
logger = Settings -> Request -> Status -> Maybe Integer -> IO ()
settingsLogger 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 ByteString
getdate = InternalInfo -> IO ByteString
getDate InternalInfo
ii
    addServerAndDate :: ResponseHeaders -> IO ResponseHeaders
addServerAndDate = IO ByteString
-> IndexedHeader -> ResponseHeaders -> IO ResponseHeaders
addDate IO ByteString
getdate IndexedHeader
rspidxhdr (ResponseHeaders -> IO ResponseHeaders)
-> (ResponseHeaders -> ResponseHeaders)
-> ResponseHeaders
-> IO ResponseHeaders
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IndexedHeader -> ResponseHeaders -> ResponseHeaders
addServer ByteString
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)
    isHead :: Bool
isHead = Request -> ByteString
requestMethod Request
req ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
H.methodHead
    rsp :: Rsp
rsp = case Response
response of
        ResponseFile Status
_ ResponseHeaders
_ FilePath
path Maybe FilePart
mPart -> FilePath -> Maybe FilePart -> IndexedHeader -> Bool -> IO () -> Rsp
RspFile FilePath
path Maybe FilePart
mPart IndexedHeader
reqidxhdr Bool
isHead (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 ByteString -> (ByteString -> IO ()) -> IO ()
raw Response
_           -> (IO ByteString -> (ByteString -> IO ()) -> IO ())
-> IO ByteString -> Rsp
RspRaw IO ByteString -> (ByteString -> IO ()) -> IO ()
raw IO ByteString
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 = ((HeaderName, ByteString) -> (HeaderName, ByteString))
-> ResponseHeaders -> ResponseHeaders
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> ByteString
sanitize (ByteString -> ByteString)
-> (HeaderName, ByteString) -> (HeaderName, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
  where
    sanitize :: ByteString -> ByteString
sanitize ByteString
v
      | ByteString -> Bool
containsNewlines ByteString
v = ByteString -> ByteString
sanitizeHeaderValue ByteString
v -- slow path
      | Bool
otherwise          = ByteString
v                     -- fast path

{-# INLINE containsNewlines #-}
containsNewlines :: ByteString -> Bool
containsNewlines :: ByteString -> Bool
containsNewlines = (Word8 -> Bool) -> ByteString -> 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 :: ByteString -> ByteString
sanitizeHeaderValue ByteString
v = case ByteString -> [ByteString]
C8.lines (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> ByteString -> ByteString
S.filter (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
_cr) ByteString
v of
    []     -> ByteString
""
    ByteString
x : [ByteString]
xs -> ByteString -> [ByteString] -> ByteString
C8.intercalate ByteString
"\r\n" (ByteString
x ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: (ByteString -> Maybe ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ByteString -> Maybe ByteString
addSpaceIfMissing [ByteString]
xs)
  where
    addSpaceIfMissing :: ByteString -> Maybe ByteString
addSpaceIfMissing ByteString
line = case ByteString -> Maybe (Char, ByteString)
C8.uncons ByteString
line of
        Maybe (Char, ByteString)
Nothing                           -> Maybe ByteString
forall a. Maybe a
Nothing
        Just (Char
first, ByteString
_)
          | Char
first Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
first Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t' -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
line
          | Bool
otherwise                     -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
" " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
line

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

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

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

sendRsp :: Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> Status
-> ResponseHeaders
-> IndexedHeader
-> Rsp
-> IO (Maybe Status, Maybe Integer)
sendRsp Connection
conn InternalInfo
_ Handle
_ HttpVersion
ver Status
s ResponseHeaders
hs IndexedHeader
_ Rsp
RspNoBody = do
    -- Not adding Content-Length.
    -- User agents treats it as Content-Length: 0.
    HttpVersion -> Status -> ResponseHeaders -> IO ByteString
composeHeader HttpVersion
ver Status
s ResponseHeaders
hs IO ByteString -> (ByteString -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Connection -> ByteString -> IO ()
connSendAll Connection
conn
    (Maybe Status, Maybe Integer) -> IO (Maybe Status, Maybe Integer)
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
_ (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
        buffer :: Buffer
buffer = Connection -> Buffer
connWriteBuffer Connection
conn
        size :: BufSize
size = Connection -> BufSize
connBufferSize Connection
conn
    Buffer -> BufSize -> (ByteString -> IO ()) -> Builder -> IO ()
toBufIOWith Buffer
buffer BufSize
size (\ByteString
bs -> Connection -> ByteString -> IO ()
connSendAll Connection
conn ByteString
bs IO () -> IO () -> IO ()
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 (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
ver Status
s ResponseHeaders
hs IndexedHeader
_ (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
$ Buffer -> BufSize -> IO Buffer
toBuilderBuffer (Connection -> Buffer
connWriteBuffer Connection
conn) (Connection -> BufSize
connBufferSize Connection
conn)
    let send :: Builder -> IO ()
send Builder
builder = do
            IO ByteString
popper <- BuilderRecv
recv Builder
builder
            let loop :: IO ()
loop = do
                    ByteString
bs <- IO ByteString
popper
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                        Connection -> Handle -> ByteString -> IO ()
sendFragment Connection
conn Handle
th ByteString
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 ByteString
mbs <- BuilderFinish
finish
    IO () -> (ByteString -> IO ()) -> Maybe ByteString -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Connection -> Handle -> ByteString -> IO ()
sendFragment Connection
conn Handle
th) Maybe ByteString
mbs
    (Maybe Status, Maybe Integer) -> IO (Maybe Status, Maybe Integer)
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
_ (RspRaw IO ByteString -> (ByteString -> IO ()) -> IO ()
withApp IO ByteString
src) = do
    IO ByteString -> (ByteString -> IO ()) -> IO ()
withApp IO ByteString
recv ByteString -> IO ()
send
    (Maybe Status, Maybe Integer) -> IO (Maybe Status, Maybe Integer)
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 ByteString
recv = do
        ByteString
bs <- IO ByteString
src
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
T.tickle Handle
th
        ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
    send :: ByteString -> IO ()
send ByteString
bs = Connection -> ByteString -> IO ()
connSendAll Connection
conn ByteString
bs IO () -> IO () -> IO ()
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 (RspFile FilePath
path (Just FilePart
part) IndexedHeader
_ Bool
isHead IO ()
hook) =
    Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> Status
-> ResponseHeaders
-> IndexedHeader
-> FilePath
-> Integer
-> Integer
-> Bool
-> IO ()
-> IO (Maybe Status, Maybe Integer)
sendRspFile2XX Connection
conn InternalInfo
ii Handle
th HttpVersion
ver Status
s0 ResponseHeaders
hs IndexedHeader
rspidxhdr FilePath
path Integer
beg Integer
len Bool
isHead 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 (RspFile FilePath
path Maybe FilePart
Nothing IndexedHeader
reqidxhdr Bool
isHead 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
-> IO (Maybe Status, Maybe Integer)
sendRspFile404 Connection
conn InternalInfo
ii Handle
th HttpVersion
ver ResponseHeaders
hs0 IndexedHeader
rspidxhdr
        Right FileInfo
finfo -> case FileInfo
-> ResponseHeaders -> IndexedHeader -> IndexedHeader -> RspFileInfo
conditionalRequest FileInfo
finfo ResponseHeaders
hs0 IndexedHeader
rspidxhdr IndexedHeader
reqidxhdr of
          WithoutBody Status
s         -> Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> Status
-> ResponseHeaders
-> IndexedHeader
-> Rsp
-> IO (Maybe Status, Maybe Integer)
sendRsp Connection
conn InternalInfo
ii Handle
th HttpVersion
ver Status
s ResponseHeaders
hs0 IndexedHeader
rspidxhdr Rsp
RspNoBody
          WithBody Status
s ResponseHeaders
hs Integer
beg Integer
len -> Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> Status
-> ResponseHeaders
-> IndexedHeader
-> FilePath
-> Integer
-> Integer
-> Bool
-> IO ()
-> IO (Maybe Status, Maybe Integer)
sendRspFile2XX Connection
conn InternalInfo
ii Handle
th HttpVersion
ver Status
s ResponseHeaders
hs IndexedHeader
rspidxhdr FilePath
path Integer
beg Integer
len Bool
isHead IO ()
hook

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

sendRspFile2XX :: Connection
               -> InternalInfo
               -> T.Handle
               -> H.HttpVersion
               -> H.Status
               -> H.ResponseHeaders
               -> IndexedHeader
               -> FilePath
               -> Integer
               -> Integer
               -> Bool
               -> IO ()
               -> IO (Maybe H.Status, Maybe Integer)
sendRspFile2XX :: Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> Status
-> ResponseHeaders
-> IndexedHeader
-> FilePath
-> Integer
-> Integer
-> Bool
-> IO ()
-> IO (Maybe Status, Maybe Integer)
sendRspFile2XX Connection
conn InternalInfo
ii Handle
th HttpVersion
ver Status
s ResponseHeaders
hs IndexedHeader
rspidxhdr FilePath
path Integer
beg Integer
len Bool
isHead IO ()
hook
  | Bool
isHead = Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> Status
-> ResponseHeaders
-> IndexedHeader
-> Rsp
-> IO (Maybe Status, Maybe Integer)
sendRsp Connection
conn InternalInfo
ii Handle
th HttpVersion
ver Status
s ResponseHeaders
hs IndexedHeader
rspidxhdr Rsp
RspNoBody
  | Bool
otherwise = do
      ByteString
lheader <- HttpVersion -> Status -> ResponseHeaders -> IO ByteString
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 (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' [ByteString
lheader]
      (Maybe Status, Maybe Integer) -> IO (Maybe Status, Maybe Integer)
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
               -> IO (Maybe H.Status, Maybe Integer)
sendRspFile404 :: Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> ResponseHeaders
-> IndexedHeader
-> IO (Maybe Status, Maybe Integer)
sendRspFile404 Connection
conn InternalInfo
ii Handle
th HttpVersion
ver ResponseHeaders
hs0 IndexedHeader
rspidxhdr = Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> Status
-> ResponseHeaders
-> IndexedHeader
-> Rsp
-> IO (Maybe Status, Maybe Integer)
sendRsp Connection
conn InternalInfo
ii Handle
th HttpVersion
ver Status
s ResponseHeaders
hs IndexedHeader
rspidxhdr (Builder -> Bool -> Rsp
RspBuilder Builder
body Bool
True)
  where
    s :: Status
s = Status
H.notFound404
    hs :: ResponseHeaders
hs =  HeaderName -> ByteString -> ResponseHeaders -> ResponseHeaders
replaceHeader HeaderName
H.hContentType ByteString
"text/plain; charset=utf-8" ResponseHeaders
hs0
    body :: Builder
body = ByteString -> Builder
byteString ByteString
"File not found"

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

-- | Use 'connSendAll' to send this data while respecting timeout rules.
sendFragment :: Connection -> T.Handle -> ByteString -> IO ()
sendFragment :: Connection -> Handle -> ByteString -> IO ()
sendFragment Connection { connSendAll :: Connection -> ByteString -> IO ()
connSendAll = ByteString -> IO ()
send } Handle
th ByteString
bs = do
    Handle -> IO ()
T.resume Handle
th
    ByteString -> IO ()
send ByteString
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 ByteString -> Bool
forall a. (Eq a, FoldCase a, IsString a) => Maybe a -> Bool
checkPersist11 Maybe ByteString
conn
    | Bool
otherwise       = Maybe ByteString -> Bool
forall a. (Eq a, FoldCase a, IsString a) => Maybe a -> Bool
checkPersist10 Maybe ByteString
conn
  where
    ver :: HttpVersion
ver = Request -> HttpVersion
httpVersion Request
req
    conn :: Maybe ByteString
conn = IndexedHeader
reqidxhdr IndexedHeader -> BufSize -> Maybe ByteString
forall i e. Ix i => Array i e -> i -> e
! RequestHeaderIndex -> BufSize
forall a. Enum a => a -> BufSize
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 ByteString -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ByteString -> Bool) -> Maybe ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ IndexedHeader
rspidxhdr IndexedHeader -> BufSize -> Maybe ByteString
forall i e. Ix i => Array i e -> i -> e
! ResponseHeaderIndex -> BufSize
forall a. Enum a => a -> BufSize
fromEnum ResponseHeaderIndex
ResContentLength

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

hasBody :: H.Status -> Bool
hasBody :: Status -> Bool
hasBody Status
s = BufSize
sc BufSize -> BufSize -> Bool
forall a. Eq a => a -> a -> Bool
/= BufSize
204
         Bool -> Bool -> Bool
&& BufSize
sc BufSize -> BufSize -> Bool
forall a. Eq a => a -> a -> Bool
/= BufSize
304
         Bool -> Bool -> Bool
&& BufSize
sc BufSize -> BufSize -> Bool
forall a. Ord a => a -> a -> Bool
>= BufSize
200
  where
    sc :: BufSize
sc = Status -> BufSize
H.statusCode Status
s

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

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

addDate :: IO D.GMTDate -> IndexedHeader -> H.ResponseHeaders -> IO H.ResponseHeaders
addDate :: IO ByteString
-> IndexedHeader -> ResponseHeaders -> IO ResponseHeaders
addDate IO ByteString
getdate IndexedHeader
rspidxhdr ResponseHeaders
hdrs = case IndexedHeader
rspidxhdr IndexedHeader -> BufSize -> Maybe ByteString
forall i e. Ix i => Array i e -> i -> e
! ResponseHeaderIndex -> BufSize
forall a. Enum a => a -> BufSize
fromEnum ResponseHeaderIndex
ResDate of
    Maybe ByteString
Nothing -> do
        ByteString
gmtdate <- IO ByteString
getdate
        ResponseHeaders -> IO ResponseHeaders
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, ByteString
gmtdate) (HeaderName, ByteString) -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: ResponseHeaders
hdrs
    Just ByteString
_ -> ResponseHeaders -> IO ResponseHeaders
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 :: ByteString -> IndexedHeader -> ResponseHeaders -> ResponseHeaders
addServer ByteString
"" IndexedHeader
rspidxhdr ResponseHeaders
hdrs = case IndexedHeader
rspidxhdr IndexedHeader -> BufSize -> Maybe ByteString
forall i e. Ix i => Array i e -> i -> e
! ResponseHeaderIndex -> BufSize
forall a. Enum a => a -> BufSize
fromEnum ResponseHeaderIndex
ResServer of
    Maybe ByteString
Nothing -> ResponseHeaders
hdrs
    Maybe ByteString
_       -> ((HeaderName, ByteString) -> 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)
-> ((HeaderName, ByteString) -> HeaderName)
-> (HeaderName, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, ByteString) -> HeaderName
forall a b. (a, b) -> a
fst) ResponseHeaders
hdrs
addServer ByteString
serverName IndexedHeader
rspidxhdr ResponseHeaders
hdrs = case IndexedHeader
rspidxhdr IndexedHeader -> BufSize -> Maybe ByteString
forall i e. Ix i => Array i e -> i -> e
! ResponseHeaderIndex -> BufSize
forall a. Enum a => a -> BufSize
fromEnum ResponseHeaderIndex
ResServer of
    Maybe ByteString
Nothing -> (HeaderName
H.hServer, ByteString
serverName) (HeaderName, ByteString) -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: ResponseHeaders
hdrs
    Maybe ByteString
_       -> ResponseHeaders
hdrs

addAltSvc :: Settings -> H.ResponseHeaders -> H.ResponseHeaders
addAltSvc :: Settings -> ResponseHeaders -> ResponseHeaders
addAltSvc Settings
settings ResponseHeaders
hs = case Settings -> Maybe ByteString
settingsAltSvc Settings
settings of
                Maybe ByteString
Nothing -> ResponseHeaders
hs
                Just  ByteString
v -> (HeaderName
"Alt-Svc", ByteString
v) (HeaderName, ByteString) -> 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 -> ByteString -> ResponseHeaders -> ResponseHeaders
replaceHeader HeaderName
k ByteString
v ResponseHeaders
hdrs = (HeaderName
k,ByteString
v) (HeaderName, ByteString) -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: ((HeaderName, ByteString) -> (HeaderName, ByteString) -> Bool)
-> (HeaderName, ByteString) -> ResponseHeaders -> ResponseHeaders
forall a. (a -> a -> Bool) -> a -> [a] -> [a]
deleteBy (HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
(==) (HeaderName -> HeaderName -> Bool)
-> ((HeaderName, ByteString) -> HeaderName)
-> (HeaderName, ByteString)
-> (HeaderName, ByteString)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (HeaderName, ByteString) -> HeaderName
forall a b. (a, b) -> a
fst) (HeaderName
k,ByteString
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 =
    ByteString -> Builder
byteString (ByteString -> Builder) -> IO ByteString -> IO Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HttpVersion -> Status -> ResponseHeaders -> IO ByteString
composeHeader HttpVersion
ver Status
s (ResponseHeaders -> ResponseHeaders
addTransferEncoding ResponseHeaders
hs)
composeHeaderBuilder HttpVersion
ver Status
s ResponseHeaders
hs Bool
False =
    ByteString -> Builder
byteString (ByteString -> Builder) -> IO ByteString -> IO Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HttpVersion -> Status -> ResponseHeaders -> IO ByteString
composeHeader HttpVersion
ver Status
s ResponseHeaders
hs