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

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

import qualified UnliftIO
import qualified Data.ByteString.Builder as BB
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 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
    GMTDate
date <- InternalInfo -> IO GMTDate
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' = GMTDate -> GMTDate -> ResponseHeaders -> ResponseHeaders
add GMTDate
date GMTDate
svr ResponseHeaders
rsphdr
          Status
-> ResponseHeaders
-> Bool
-> FilePath
-> Maybe FilePart
-> InternalInfo
-> ResponseHeaders
-> IO (Response, Status, Bool)
responseFile    Status
st ResponseHeaders
rsphdr' Bool
isHead FilePath
path Maybe FilePart
mpart InternalInfo
ii ResponseHeaders
reqhdr
      ResponseBuilder Status
st ResponseHeaders
rsphdr Builder
builder -> do
          let rsphdr' :: ResponseHeaders
rsphdr' = GMTDate -> GMTDate -> ResponseHeaders -> ResponseHeaders
add GMTDate
date GMTDate
svr ResponseHeaders
rsphdr
          (Response, Status, Bool) -> IO (Response, Status, Bool)
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 -> Bool -> Builder -> (Response, Status, Bool)
responseBuilder Status
st ResponseHeaders
rsphdr' Bool
isHead Builder
builder
      ResponseStream  Status
st ResponseHeaders
rsphdr StreamingBody
strmbdy -> do
          let rsphdr' :: ResponseHeaders
rsphdr' = GMTDate -> GMTDate -> ResponseHeaders -> ResponseHeaders
add GMTDate
date GMTDate
svr ResponseHeaders
rsphdr
          (Response, Status, Bool) -> IO (Response, Status, Bool)
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
-> Bool
-> StreamingBody
-> (Response, Status, Bool)
responseStream  Status
st ResponseHeaders
rsphdr' Bool
isHead 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 (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 (m :: * -> *) a. Monad m => a -> m a
return (Response
h2rsp', Status
st, Bool
hasBody)
  where
    !isHead :: Bool
isHead = Request -> GMTDate
requestMethod Request
req GMTDate -> GMTDate -> Bool
forall a. Eq a => a -> a -> Bool
== GMTDate
H.methodHead
    !reqhdr :: ResponseHeaders
reqhdr = Request -> ResponseHeaders
requestHeaders Request
req
    !svr :: GMTDate
svr    = Settings -> GMTDate
S.settingsServerName Settings
settings
    add :: GMTDate -> GMTDate -> ResponseHeaders -> ResponseHeaders
add GMTDate
date GMTDate
server ResponseHeaders
rsphdr = Settings -> ResponseHeaders -> ResponseHeaders
R.addAltSvc Settings
settings (ResponseHeaders -> ResponseHeaders)
-> ResponseHeaders -> ResponseHeaders
forall a b. (a -> b) -> a -> b
$
        (HeaderName
H.hDate, GMTDate
date) (HeaderName, GMTDate) -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: (HeaderName
H.hServer, GMTDate
server) (HeaderName, GMTDate) -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: ResponseHeaders
rsphdr
    -- fixme: not adding svr if already exists

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

responseFile :: H.Status -> H.ResponseHeaders -> Bool
             -> FilePath -> Maybe FilePart -> InternalInfo -> H.RequestHeaders
             -> IO (H2.Response, H.Status, Bool)
responseFile :: Status
-> ResponseHeaders
-> Bool
-> FilePath
-> Maybe FilePart
-> InternalInfo
-> ResponseHeaders
-> IO (Response, Status, Bool)
responseFile Status
st ResponseHeaders
rsphdr Bool
_ FilePath
_ Maybe FilePart
_ InternalInfo
_ ResponseHeaders
_
  | Status -> Bool
noBody Status
st = (Response, Status, Bool) -> IO (Response, Status, Bool)
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 Bool
isHead FilePath
path (Just FilePart
fp) InternalInfo
_ ResponseHeaders
_ =
    (Response, Status, Bool) -> IO (Response, Status, Bool)
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 -> Bool -> FileSpec -> (Response, Status, Bool)
responseFile2XX Status
st ResponseHeaders
rsphdr Bool
isHead 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 Bool
isHead 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 (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 -> IndexedHeader -> IndexedHeader -> RspFileInfo
conditionalRequest FileInfo
finfo ResponseHeaders
rsphdr IndexedHeader
rspidx IndexedHeader
reqidx of
                WithoutBody Status
s                -> (Response, Status, Bool) -> IO (Response, Status, Bool)
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 (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 -> Bool -> FileSpec -> (Response, Status, Bool)
responseFile2XX Status
s ResponseHeaders
rsphdr' Bool
isHead FileSpec
fileSpec

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

responseFile2XX :: H.Status -> H.ResponseHeaders -> Bool -> H2.FileSpec -> (H2.Response, H.Status, Bool)
responseFile2XX :: Status
-> ResponseHeaders -> Bool -> FileSpec -> (Response, Status, Bool)
responseFile2XX Status
st ResponseHeaders
rsphdr Bool
isHead FileSpec
fileSpec
  | Bool
isHead = 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 -> Bool
                -> BB.Builder
                -> (H2.Response, H.Status, Bool)
responseBuilder :: Status
-> ResponseHeaders -> Bool -> Builder -> (Response, Status, Bool)
responseBuilder Status
st ResponseHeaders
rsphdr Bool
isHead Builder
builder
  | Status -> Bool
noBody Status
st = Status -> ResponseHeaders -> (Response, Status, Bool)
responseNoBody Status
st ResponseHeaders
rsphdr
  | Bool
isHead    = 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 -> Bool
               -> StreamingBody
               -> (H2.Response, H.Status, Bool)
responseStream :: Status
-> ResponseHeaders
-> Bool
-> StreamingBody
-> (Response, Status, Bool)
responseStream Status
st ResponseHeaders
rsphdr Bool
isHead StreamingBody
strmbdy
  | Status -> Bool
noBody Status
st = Status -> ResponseHeaders -> (Response, Status, Bool)
responseNoBody Status
st ResponseHeaders
rsphdr
  | Bool
isHead    = 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 -> GMTDate -> ResponseHeaders -> ResponseHeaders
R.replaceHeader HeaderName
H.hContentType GMTDate
"text/plain; charset=utf-8" ResponseHeaders
rsphdr
    !body :: Builder
body = GMTDate -> Builder
BB.byteString GMTDate
"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