{-# 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
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