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

module Network.Wai.Handler.Warp.HTTP2.Response (
    fromResponse,
) where

import qualified Control.Exception as E
import qualified Data.ByteString.Builder as BB
import qualified Data.List as L (find)
import qualified Network.HTTP.Types as H
import qualified Network.HTTP2.Server as H2
import Network.Wai hiding (responseBuilder, responseFile, responseStream)
import Network.Wai.Internal (Response (..))

import Network.Wai.Handler.Warp.File
import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data)
import Network.Wai.Handler.Warp.HTTP2.Types
import Network.Wai.Handler.Warp.Header
import qualified Network.Wai.Handler.Warp.Response as R
import qualified Network.Wai.Handler.Warp.Settings as S
import Network.Wai.Handler.Warp.Types

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

fromResponse
    :: S.Settings
    -> InternalInfo
    -> Request
    -> Response
    -> IO (H2.Response, H.Status, Bool)
fromResponse :: Settings
-> InternalInfo
-> Request
-> Response
-> IO (Response, Status, Bool)
fromResponse Settings
settings InternalInfo
ii Request
req Response
rsp = do
    Method
date <- InternalInfo -> IO Method
getDate InternalInfo
ii
    rspst :: (Response, Status, Bool)
rspst@(Response
h2rsp, Status
st, Bool
hasBody) <- case Response
rsp of
        ResponseFile Status
st ResponseHeaders
rsphdr FilePath
path Maybe FilePart
mpart -> do
            let rsphdr' :: ResponseHeaders
rsphdr' = Method -> ResponseHeaders -> ResponseHeaders
add Method
date ResponseHeaders
rsphdr
            Status
-> ResponseHeaders
-> Method
-> FilePath
-> Maybe FilePart
-> InternalInfo
-> ResponseHeaders
-> IO (Response, Status, Bool)
responseFile Status
st ResponseHeaders
rsphdr' Method
method FilePath
path Maybe FilePart
mpart InternalInfo
ii ResponseHeaders
reqhdr
        ResponseBuilder Status
st ResponseHeaders
rsphdr Builder
builder -> do
            let rsphdr' :: ResponseHeaders
rsphdr' = Method -> ResponseHeaders -> ResponseHeaders
add Method
date ResponseHeaders
rsphdr
            (Response, Status, Bool) -> IO (Response, Status, Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Response, Status, Bool) -> IO (Response, Status, Bool))
-> (Response, Status, Bool) -> IO (Response, Status, Bool)
forall a b. (a -> b) -> a -> b
$ Status
-> ResponseHeaders -> Method -> Builder -> (Response, Status, Bool)
responseBuilder Status
st ResponseHeaders
rsphdr' Method
method Builder
builder
        ResponseStream Status
st ResponseHeaders
rsphdr StreamingBody
strmbdy -> do
            let rsphdr' :: ResponseHeaders
rsphdr' = Method -> ResponseHeaders -> ResponseHeaders
add Method
date ResponseHeaders
rsphdr
            (Response, Status, Bool) -> IO (Response, Status, Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Response, Status, Bool) -> IO (Response, Status, Bool))
-> (Response, Status, Bool) -> IO (Response, Status, Bool)
forall a b. (a -> b) -> a -> b
$ Status
-> ResponseHeaders
-> Method
-> StreamingBody
-> (Response, Status, Bool)
responseStream Status
st ResponseHeaders
rsphdr' Method
method StreamingBody
strmbdy
        Response
_ -> FilePath -> IO (Response, Status, Bool)
forall a. HasCallStack => FilePath -> a
error FilePath
"ResponseRaw is not supported in HTTP/2"
    Maybe HTTP2Data
mh2data <- Request -> IO (Maybe HTTP2Data)
getHTTP2Data Request
req
    case Maybe HTTP2Data
mh2data of
        Maybe HTTP2Data
Nothing -> (Response, Status, Bool) -> IO (Response, Status, Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Response, Status, Bool)
rspst
        Just HTTP2Data
h2data -> do
            let !trailers :: TrailersMaker
trailers = HTTP2Data -> TrailersMaker
http2dataTrailers HTTP2Data
h2data
                !h2rsp' :: Response
h2rsp' = Response -> TrailersMaker -> Response
H2.setResponseTrailersMaker Response
h2rsp TrailersMaker
trailers
            (Response, Status, Bool) -> IO (Response, Status, Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Response
h2rsp', Status
st, Bool
hasBody)
  where
    !method :: Method
method = Request -> Method
requestMethod Request
req
    !reqhdr :: ResponseHeaders
reqhdr = Request -> ResponseHeaders
requestHeaders Request
req
    !server :: Method
server = Settings -> Method
S.settingsServerName Settings
settings
    add :: Method -> ResponseHeaders -> ResponseHeaders
add Method
date ResponseHeaders
rsphdr =
        let hasServerHdr :: Maybe (HeaderName, Method)
hasServerHdr = ((HeaderName, Method) -> Bool)
-> ResponseHeaders -> Maybe (HeaderName, Method)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find ((HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
H.hServer) (HeaderName -> Bool)
-> ((HeaderName, Method) -> HeaderName)
-> (HeaderName, Method)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, Method) -> HeaderName
forall a b. (a, b) -> a
fst) ResponseHeaders
rsphdr
            addSVR :: ResponseHeaders -> ResponseHeaders
addSVR =
                (ResponseHeaders -> ResponseHeaders)
-> ((HeaderName, Method) -> ResponseHeaders -> ResponseHeaders)
-> Maybe (HeaderName, Method)
-> ResponseHeaders
-> ResponseHeaders
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((HeaderName
H.hServer, Method
server) (HeaderName, Method) -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
:) ((ResponseHeaders -> ResponseHeaders)
-> (HeaderName, Method) -> ResponseHeaders -> ResponseHeaders
forall a b. a -> b -> a
const ResponseHeaders -> ResponseHeaders
forall a. a -> a
id) Maybe (HeaderName, Method)
hasServerHdr
         in Settings -> ResponseHeaders -> ResponseHeaders
R.addAltSvc Settings
settings (ResponseHeaders -> ResponseHeaders)
-> ResponseHeaders -> ResponseHeaders
forall a b. (a -> b) -> a -> b
$
                (HeaderName
H.hDate, Method
date) (HeaderName, Method) -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: ResponseHeaders -> ResponseHeaders
addSVR ResponseHeaders
rsphdr

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

responseFile
    :: H.Status
    -> H.ResponseHeaders
    -> H.Method
    -> FilePath
    -> Maybe FilePart
    -> InternalInfo
    -> H.RequestHeaders
    -> IO (H2.Response, H.Status, Bool)
responseFile :: Status
-> ResponseHeaders
-> Method
-> FilePath
-> Maybe FilePart
-> InternalInfo
-> ResponseHeaders
-> IO (Response, Status, Bool)
responseFile Status
st ResponseHeaders
rsphdr Method
_ FilePath
_ Maybe FilePart
_ InternalInfo
_ ResponseHeaders
_
    | Status -> Bool
noBody Status
st = (Response, Status, Bool) -> IO (Response, Status, Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Response, Status, Bool) -> IO (Response, Status, Bool))
-> (Response, Status, Bool) -> IO (Response, Status, Bool)
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> (Response, Status, Bool)
responseNoBody Status
st ResponseHeaders
rsphdr
responseFile Status
st ResponseHeaders
rsphdr Method
method FilePath
path (Just FilePart
fp) InternalInfo
_ ResponseHeaders
_ =
    (Response, Status, Bool) -> IO (Response, Status, Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Response, Status, Bool) -> IO (Response, Status, Bool))
-> (Response, Status, Bool) -> IO (Response, Status, Bool)
forall a b. (a -> b) -> a -> b
$ Status
-> ResponseHeaders
-> Method
-> FileSpec
-> (Response, Status, Bool)
responseFile2XX Status
st ResponseHeaders
rsphdr Method
method FileSpec
fileSpec
  where
    !off' :: FileOffset
off' = Integer -> FileOffset
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> FileOffset) -> Integer -> FileOffset
forall a b. (a -> b) -> a -> b
$ FilePart -> Integer
filePartOffset FilePart
fp
    !bytes' :: FileOffset
bytes' = Integer -> FileOffset
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> FileOffset) -> Integer -> FileOffset
forall a b. (a -> b) -> a -> b
$ FilePart -> Integer
filePartByteCount FilePart
fp
    !fileSpec :: FileSpec
fileSpec = FilePath -> FileOffset -> FileOffset -> FileSpec
H2.FileSpec FilePath
path FileOffset
off' FileOffset
bytes'
responseFile Status
_ ResponseHeaders
rsphdr Method
method FilePath
path Maybe FilePart
Nothing InternalInfo
ii ResponseHeaders
reqhdr = do
    Either IOException FileInfo
efinfo <- IO FileInfo -> IO (Either IOException FileInfo)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO FileInfo -> IO (Either IOException FileInfo))
-> IO FileInfo -> IO (Either IOException FileInfo)
forall a b. (a -> b) -> a -> b
$ InternalInfo -> FilePath -> IO FileInfo
getFileInfo InternalInfo
ii FilePath
path
    case Either IOException FileInfo
efinfo of
        Left (IOException
_ex :: E.IOException) -> (Response, Status, Bool) -> IO (Response, Status, Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Response, Status, Bool) -> IO (Response, Status, Bool))
-> (Response, Status, Bool) -> IO (Response, Status, Bool)
forall a b. (a -> b) -> a -> b
$ ResponseHeaders -> (Response, Status, Bool)
response404 ResponseHeaders
rsphdr
        Right FileInfo
finfo -> do
            let reqidx :: IndexedHeader
reqidx = ResponseHeaders -> IndexedHeader
indexRequestHeader ResponseHeaders
reqhdr
                rspidx :: IndexedHeader
rspidx = ResponseHeaders -> IndexedHeader
indexResponseHeader ResponseHeaders
rsphdr
            case FileInfo
-> ResponseHeaders
-> Method
-> IndexedHeader
-> IndexedHeader
-> RspFileInfo
conditionalRequest FileInfo
finfo ResponseHeaders
rsphdr Method
method IndexedHeader
rspidx IndexedHeader
reqidx of
                WithoutBody Status
s -> (Response, Status, Bool) -> IO (Response, Status, Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Response, Status, Bool) -> IO (Response, Status, Bool))
-> (Response, Status, Bool) -> IO (Response, Status, Bool)
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> (Response, Status, Bool)
responseNoBody Status
s ResponseHeaders
rsphdr
                WithBody Status
s ResponseHeaders
rsphdr' Integer
off Integer
bytes -> do
                    let !off' :: FileOffset
off' = Integer -> FileOffset
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
off
                        !bytes' :: FileOffset
bytes' = Integer -> FileOffset
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
bytes
                        !fileSpec :: FileSpec
fileSpec = FilePath -> FileOffset -> FileOffset -> FileSpec
H2.FileSpec FilePath
path FileOffset
off' FileOffset
bytes'
                    (Response, Status, Bool) -> IO (Response, Status, Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Response, Status, Bool) -> IO (Response, Status, Bool))
-> (Response, Status, Bool) -> IO (Response, Status, Bool)
forall a b. (a -> b) -> a -> b
$ Status
-> ResponseHeaders
-> Method
-> FileSpec
-> (Response, Status, Bool)
responseFile2XX Status
s ResponseHeaders
rsphdr' Method
method FileSpec
fileSpec

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

responseFile2XX
    :: H.Status
    -> H.ResponseHeaders
    -> H.Method
    -> H2.FileSpec
    -> (H2.Response, H.Status, Bool)
responseFile2XX :: Status
-> ResponseHeaders
-> Method
-> FileSpec
-> (Response, Status, Bool)
responseFile2XX Status
st ResponseHeaders
rsphdr Method
method FileSpec
fileSpec
    | Method
method Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
H.methodHead = Status -> ResponseHeaders -> (Response, Status, Bool)
responseNoBody Status
st ResponseHeaders
rsphdr
    | Bool
otherwise = (Status -> ResponseHeaders -> FileSpec -> Response
H2.responseFile Status
st ResponseHeaders
rsphdr FileSpec
fileSpec, Status
st, Bool
True)

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

responseBuilder
    :: H.Status
    -> H.ResponseHeaders
    -> H.Method
    -> BB.Builder
    -> (H2.Response, H.Status, Bool)
responseBuilder :: Status
-> ResponseHeaders -> Method -> Builder -> (Response, Status, Bool)
responseBuilder Status
st ResponseHeaders
rsphdr Method
method Builder
builder
    | Method
method Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
H.methodHead Bool -> Bool -> Bool
|| Status -> Bool
noBody Status
st = Status -> ResponseHeaders -> (Response, Status, Bool)
responseNoBody Status
st ResponseHeaders
rsphdr
    | Bool
otherwise = (Status -> ResponseHeaders -> Builder -> Response
H2.responseBuilder Status
st ResponseHeaders
rsphdr Builder
builder, Status
st, Bool
True)

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

responseStream
    :: H.Status
    -> H.ResponseHeaders
    -> H.Method
    -> StreamingBody
    -> (H2.Response, H.Status, Bool)
responseStream :: Status
-> ResponseHeaders
-> Method
-> StreamingBody
-> (Response, Status, Bool)
responseStream Status
st ResponseHeaders
rsphdr Method
method StreamingBody
strmbdy
    | Method
method Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
H.methodHead Bool -> Bool -> Bool
|| Status -> Bool
noBody Status
st = Status -> ResponseHeaders -> (Response, Status, Bool)
responseNoBody Status
st ResponseHeaders
rsphdr
    | Bool
otherwise = (Status -> ResponseHeaders -> StreamingBody -> Response
H2.responseStreaming Status
st ResponseHeaders
rsphdr StreamingBody
strmbdy, Status
st, Bool
True)

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

responseNoBody :: H.Status -> H.ResponseHeaders -> (H2.Response, H.Status, Bool)
responseNoBody :: Status -> ResponseHeaders -> (Response, Status, Bool)
responseNoBody Status
st ResponseHeaders
rsphdr = (Status -> ResponseHeaders -> Response
H2.responseNoBody Status
st ResponseHeaders
rsphdr, Status
st, Bool
False)

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

response404 :: H.ResponseHeaders -> (H2.Response, H.Status, Bool)
response404 :: ResponseHeaders -> (Response, Status, Bool)
response404 ResponseHeaders
rsphdr = (Response
h2rsp, Status
st, Bool
True)
  where
    h2rsp :: Response
h2rsp = Status -> ResponseHeaders -> Builder -> Response
H2.responseBuilder Status
st ResponseHeaders
rsphdr' Builder
body
    st :: Status
st = Status
H.notFound404
    !rsphdr' :: ResponseHeaders
rsphdr' = HeaderName -> Method -> ResponseHeaders -> ResponseHeaders
R.replaceHeader HeaderName
H.hContentType Method
"text/plain; charset=utf-8" ResponseHeaders
rsphdr
    !body :: Builder
body = Method -> Builder
BB.byteString Method
"File not found"

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

noBody :: H.Status -> Bool
noBody :: Status -> Bool
noBody = Bool -> Bool
not (Bool -> Bool) -> (Status -> Bool) -> Status -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> Bool
R.hasBody