{-# 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.List (deleteBy)
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 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 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         -> 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
        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 forall a. Maybe a
Nothing
        Handle -> IO ()
T.tickle Handle
th
        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 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 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 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 -> 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 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 = forall a b. (a -> b) -> [a] -> [b]
map (HeaderValue -> HeaderValue
sanitize 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 forall a. Eq a => a -> a -> Bool
== Word8
_cr Bool -> Bool -> Bool
|| Word8
w 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 forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> HeaderValue -> HeaderValue
S.filter (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 forall a. a -> [a] -> [a]
: 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 (Char, HeaderValue)
C8.uncons HeaderValue
line of
        Maybe (Char, HeaderValue)
Nothing                           -> forall a. Maybe a
Nothing
        Just (Char
first, HeaderValue
_)
          | Char
first forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
first forall a. Eq a => a -> a -> Bool
== Char
'\t' -> forall a. a -> Maybe a
Just HeaderValue
line
          | Bool
otherwise                     -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ HeaderValue
" " forall a. Semigroup a => a -> a -> a
<> HeaderValue
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
        -> 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Connection -> HeaderValue -> IO ()
connSendAll Connection
conn
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Status
s, 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 forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
chunkedTransferEncoding Builder
body
                                 forall a. Semigroup a => a -> a -> a
<> Builder
chunkedTransferTerminator
         | Bool
otherwise    = Builder
header 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
T.tickle Handle
th) Builder
hdrBdy
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Status
s, 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 forall a b. (a -> b) -> a -> b
$ IO Buffer -> BufferAllocStrategy
reuseBufferStrategy
                    forall a b. (a -> b) -> a -> b
$ IORef WriteBuffer -> IO Buffer
toBuilderBuffer 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
                    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (HeaderValue -> Bool
S.null HeaderValue
bs) 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 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)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needsChunked forall a b. (a -> b) -> a -> b
$ Builder -> IO ()
send Builder
chunkedTransferTerminator
    Maybe HeaderValue
mbs <- BuilderFinish
finish
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Connection -> Handle -> HeaderValue -> IO ()
sendFragment Connection
conn Handle
th) Maybe HeaderValue
mbs
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Status
s, 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
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
  where
    recv :: IO HeaderValue
recv = do
        HeaderValue
bs <- IO HeaderValue
src
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (HeaderValue -> Bool
S.null HeaderValue
bs) forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
T.tickle Handle
th
        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 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
_ Bool
isHead IO ()
hook) =
    Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> Status
-> ResponseHeaders
-> IndexedHeader
-> Int
-> HeaderValue
-> 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 Int
maxRspBufSize HeaderValue
method 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 Int
maxRspBufSize HeaderValue
method (RspFile FilePath
path Maybe FilePart
Nothing IndexedHeader
reqidxhdr Bool
isHead IO ()
hook) = do
    Either IOException FileInfo
efinfo <- forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOException a)
UnliftIO.tryIO 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
-> Bool
-> 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 Bool
isHead IO ()
hook

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

sendRspFile2XX :: Connection
               -> InternalInfo
               -> T.Handle
               -> H.HttpVersion
               -> H.Status
               -> H.ResponseHeaders
               -> IndexedHeader
               -> Int
               -> H.Method
               -> FilePath
               -> Integer
               -> Integer
               -> Bool
               -> IO ()
               -> IO (Maybe H.Status, Maybe Integer)
sendRspFile2XX :: Connection
-> InternalInfo
-> Handle
-> HttpVersion
-> Status
-> ResponseHeaders
-> IndexedHeader
-> Int
-> HeaderValue
-> 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 Int
maxRspBufSize HeaderValue
method FilePath
path Integer
beg Integer
len Bool
isHead IO ()
hook
  | Bool
isHead = 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 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]
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Status
s, 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 forall a. Eq a => a -> a -> Bool
== HttpVersion
H.http11 = forall {a}. (Eq a, FoldCase a, IsString a) => Maybe a -> Bool
checkPersist11 Maybe HeaderValue
conn
    | Bool
otherwise       = 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 forall i e. Ix i => Array i e -> i -> e
! forall a. Enum a => a -> Int
fromEnum RequestHeaderIndex
ReqConnection
    checkPersist11 :: Maybe a -> Bool
checkPersist11 (Just a
x)
        | forall s. FoldCase s => s -> s
CI.foldCase a
x forall a. Eq a => a -> a -> Bool
== a
"close"      = Bool
False
    checkPersist11 Maybe a
_                    = Bool
True
    checkPersist10 :: Maybe a -> Bool
checkPersist10 (Just a
x)
        | forall s. FoldCase s => s -> s
CI.foldCase a
x 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 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 = forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ IndexedHeader
rspidxhdr forall i e. Ix i => Array i e -> i -> e
! forall a. Enum a => a -> Int
fromEnum ResponseHeaderIndex
ResContentLength

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

hasBody :: H.Status -> Bool
hasBody :: Status -> Bool
hasBody Status
s = Int
sc forall a. Eq a => a -> a -> Bool
/= Int
204
         Bool -> Bool -> Bool
&& Int
sc forall a. Eq a => a -> a -> Bool
/= Int
304
         Bool -> Bool -> Bool
&& Int
sc 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") 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 forall i e. Ix i => Array i e -> i -> e
! forall a. Enum a => a -> Int
fromEnum ResponseHeaderIndex
ResDate of
    Maybe HeaderValue
Nothing -> do
        HeaderValue
gmtdate <- IO HeaderValue
getdate
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (HeaderName
H.hDate, HeaderValue
gmtdate) forall a. a -> [a] -> [a]
: ResponseHeaders
hdrs
    Just HeaderValue
_ -> 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 forall i e. Ix i => Array i e -> i -> e
! forall a. Enum a => a -> Int
fromEnum ResponseHeaderIndex
ResServer of
    Maybe HeaderValue
Nothing -> ResponseHeaders
hdrs
    Maybe HeaderValue
_       -> forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/= HeaderName
H.hServer) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) ResponseHeaders
hdrs
addServer HeaderValue
serverName IndexedHeader
rspidxhdr ResponseHeaders
hdrs = case IndexedHeader
rspidxhdr forall i e. Ix i => Array i e -> i -> e
! forall a. Enum a => a -> Int
fromEnum ResponseHeaderIndex
ResServer of
    Maybe HeaderValue
Nothing -> (HeaderName
H.hServer, HeaderValue
serverName) 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) 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) forall a. a -> [a] -> [a]
: forall a. (a -> a -> Bool) -> a -> [a] -> [a]
deleteBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` 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 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HttpVersion -> Status -> ResponseHeaders -> IO HeaderValue
composeHeader HttpVersion
ver Status
s ResponseHeaders
hs