{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
{-# 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 (responseFile, responseBuilder, responseStream)
import Network.Wai.Internal (Response(..))
import qualified UnliftIO

import Network.Wai.Handler.Warp.File
import Network.Wai.Handler.Warp.Header
import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data)
import Network.Wai.Handler.Warp.HTTP2.Types
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
          forall (m :: * -> *) a. Monad m => a -> m a
return 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
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Status
-> ResponseHeaders
-> Method
-> StreamingBody
-> (Response, Status, Bool)
responseStream  Status
st ResponseHeaders
rsphdr' Method
method StreamingBody
strmbdy
      Response
_ -> 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     -> 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
          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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find ((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
rsphdr
            addSVR :: ResponseHeaders -> ResponseHeaders
addSVR =
                forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((HeaderName
H.hServer, Method
server) forall a. a -> [a] -> [a]
:) (forall a b. a -> b -> a
const forall a. a -> a
id) Maybe (HeaderName, Method)
hasServerHdr
        in Settings -> ResponseHeaders -> ResponseHeaders
R.addAltSvc Settings
settings forall a b. (a -> b) -> a -> b
$
            (HeaderName
H.hDate, Method
date) 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 = forall (m :: * -> *) a. Monad m => a -> m a
return 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
_ =
    forall (m :: * -> *) a. Monad m => a -> m a
return 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'   = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ FilePart -> Integer
filePartOffset FilePart
fp
    !bytes' :: FileOffset
bytes' = forall a b. (Integral a, Num b) => a -> b
fromIntegral 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 <- 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) -> forall (m :: * -> *) a. Monad m => a -> m a
return 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                -> forall (m :: * -> *) a. Monad m => a -> m a
return 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'   = forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
off
                        !bytes' :: FileOffset
bytes' = 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'
                    forall (m :: * -> *) a. Monad m => a -> m a
return 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 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 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 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> Bool
R.hasBody