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

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

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 qualified UnliftIO

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 (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) -> (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