{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BangPatterns #-}
{-# 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 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
fromResponse :: Settings -> InternalInfo -> Request -> Response -> IO Response
fromResponse settings :: Settings
settings ii :: InternalInfo
ii req :: Request
req rsp :: Response
rsp = do
    GMTDate
date <- InternalInfo -> IO GMTDate
getDate InternalInfo
ii
    Response
h2rsp <- case Response
rsp of
      ResponseFile    st :: Status
st rsphdr :: ResponseHeaders
rsphdr path :: FilePath
path mpart :: 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
responseFile    Status
st ResponseHeaders
rsphdr' Bool
isHead FilePath
path Maybe FilePart
mpart InternalInfo
ii ResponseHeaders
reqhdr
      ResponseBuilder st :: Status
st rsphdr :: ResponseHeaders
rsphdr builder :: Builder
builder -> do
          let rsphdr' :: ResponseHeaders
rsphdr' = GMTDate -> GMTDate -> ResponseHeaders -> ResponseHeaders
add GMTDate
date GMTDate
svr ResponseHeaders
rsphdr
          Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> Bool -> Builder -> Response
responseBuilder Status
st ResponseHeaders
rsphdr' Bool
isHead Builder
builder
      ResponseStream  st :: Status
st rsphdr :: ResponseHeaders
rsphdr strmbdy :: StreamingBody
strmbdy -> do
          let rsphdr' :: ResponseHeaders
rsphdr' = GMTDate -> GMTDate -> ResponseHeaders -> ResponseHeaders
add GMTDate
date GMTDate
svr ResponseHeaders
rsphdr
          Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> Bool -> StreamingBody -> Response
responseStream  Status
st ResponseHeaders
rsphdr' Bool
isHead StreamingBody
strmbdy
      _ -> FilePath -> IO Response
forall a. HasCallStack => FilePath -> a
error "ResponseRaw is not supported in HTTP/2"
    Maybe HTTP2Data
mh2data <- Request -> IO (Maybe HTTP2Data)
getHTTP2Data Request
req
    case Maybe HTTP2Data
mh2data of
      Nothing     -> Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
h2rsp
      Just h2data :: HTTP2Data
h2data -> do
          let !trailers :: TrailersMaker
trailers = HTTP2Data -> TrailersMaker
http2dataTrailers HTTP2Data
h2data
          Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Response -> TrailersMaker -> Response
H2.setResponseTrailersMaker Response
h2rsp TrailersMaker
trailers
  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 date :: GMTDate
date server :: GMTDate
server rsphdr :: 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
responseFile :: Status
-> ResponseHeaders
-> Bool
-> FilePath
-> Maybe FilePart
-> InternalInfo
-> ResponseHeaders
-> IO Response
responseFile st :: Status
st rsphdr :: ResponseHeaders
rsphdr _ _ _ _ _
  | Status -> Bool
noBody Status
st = Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> Response
responseNoBody Status
st ResponseHeaders
rsphdr

responseFile st :: Status
st rsphdr :: ResponseHeaders
rsphdr isHead :: Bool
isHead path :: FilePath
path (Just fp :: FilePart
fp) _ _ =
    Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> Bool -> FileSpec -> Response
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 _ rsphdr :: ResponseHeaders
rsphdr isHead :: Bool
isHead path :: FilePath
path Nothing ii :: InternalInfo
ii reqhdr :: 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 -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ ResponseHeaders -> Response
response404 ResponseHeaders
rsphdr
        Right finfo :: 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 s :: Status
s                -> Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> Response
responseNoBody Status
s ResponseHeaders
rsphdr
                WithBody s :: Status
s rsphdr' :: ResponseHeaders
rsphdr' off :: Integer
off bytes :: 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 -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> Bool -> FileSpec -> Response
responseFile2XX Status
s ResponseHeaders
rsphdr' Bool
isHead FileSpec
fileSpec

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

responseFile2XX :: H.Status -> H.ResponseHeaders -> Bool -> H2.FileSpec -> H2.Response
responseFile2XX :: Status -> ResponseHeaders -> Bool -> FileSpec -> Response
responseFile2XX st :: Status
st rsphdr :: ResponseHeaders
rsphdr isHead :: Bool
isHead fileSpec :: FileSpec
fileSpec
  | Bool
isHead = Status -> ResponseHeaders -> Response
responseNoBody Status
st ResponseHeaders
rsphdr
  | Bool
otherwise = Status -> ResponseHeaders -> FileSpec -> Response
H2.responseFile Status
st ResponseHeaders
rsphdr FileSpec
fileSpec

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

responseBuilder :: H.Status -> H.ResponseHeaders -> Bool
                -> BB.Builder
                -> H2.Response
responseBuilder :: Status -> ResponseHeaders -> Bool -> Builder -> Response
responseBuilder st :: Status
st rsphdr :: ResponseHeaders
rsphdr isHead :: Bool
isHead builder :: Builder
builder
  | Status -> Bool
noBody Status
st = Status -> ResponseHeaders -> Response
responseNoBody Status
st ResponseHeaders
rsphdr
  | Bool
isHead    = Status -> ResponseHeaders -> Response
responseNoBody Status
st ResponseHeaders
rsphdr
  | Bool
otherwise = Status -> ResponseHeaders -> Builder -> Response
H2.responseBuilder Status
st ResponseHeaders
rsphdr Builder
builder

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

responseStream :: H.Status -> H.ResponseHeaders -> Bool
               -> StreamingBody
               -> H2.Response
responseStream :: Status -> ResponseHeaders -> Bool -> StreamingBody -> Response
responseStream st :: Status
st rsphdr :: ResponseHeaders
rsphdr isHead :: Bool
isHead strmbdy :: StreamingBody
strmbdy
  | Status -> Bool
noBody Status
st = Status -> ResponseHeaders -> Response
responseNoBody Status
st ResponseHeaders
rsphdr
  | Bool
isHead    = Status -> ResponseHeaders -> Response
responseNoBody Status
st ResponseHeaders
rsphdr
  | Bool
otherwise = Status -> ResponseHeaders -> StreamingBody -> Response
H2.responseStreaming Status
st ResponseHeaders
rsphdr StreamingBody
strmbdy

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

responseNoBody :: H.Status -> H.ResponseHeaders -> H2.Response
responseNoBody :: Status -> ResponseHeaders -> Response
responseNoBody st :: Status
st rsphdr :: ResponseHeaders
rsphdr = Status -> ResponseHeaders -> Response
H2.responseNoBody Status
st ResponseHeaders
rsphdr

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

response404 :: H.ResponseHeaders -> H2.Response
response404 :: ResponseHeaders -> Response
response404 rsphdr :: ResponseHeaders
rsphdr = Status -> ResponseHeaders -> Builder -> Response
H2.responseBuilder Status
H.notFound404 ResponseHeaders
rsphdr' Builder
body
  where
    !rsphdr' :: ResponseHeaders
rsphdr' = HeaderName -> GMTDate -> ResponseHeaders -> ResponseHeaders
R.replaceHeader HeaderName
H.hContentType "text/plain; charset=utf-8" ResponseHeaders
rsphdr
    !body :: Builder
body = GMTDate -> Builder
BB.byteString "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