{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Network.Wai.Handler.Warp.Response (
sendResponse,
sanitizeHeaderValue,
warpVersion,
hasBody,
replaceHeader,
addServer,
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
sendResponse
:: Settings
-> Connection
-> InternalInfo
-> T.Handle
-> Request
-> IndexedHeader
-> IO ByteString
-> Response
-> IO Bool
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
(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
!ret :: Bool
ret = case Response
response of
ResponseFile{} -> Bool
isPersist
ResponseBuilder{} -> Bool
isKeepAlive
ResponseStream{} -> Bool
isKeepAlive
ResponseRaw{} -> Bool
False
sanitizeHeaders :: H.ResponseHeaders -> H.ResponseHeaders
= (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
| Bool
otherwise = HeaderValue
v
{-# 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
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
-> Int
-> 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
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)
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
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
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"
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
infoFromRequest
:: Request
-> IndexedHeader
-> ( Bool
, Bool
)
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
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
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
:: H.HeaderName -> HeaderValue -> H.ResponseHeaders -> H.ResponseHeaders
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
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