    {-# 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, H.Status, Bool)
    fromResponse :: Settings
    -> InternalInfo
    -> Request
    -> Response
    -> IO (Response, Status, Bool)
    fromResponse settings :: Settings
    settings ii :: InternalInfo
    ii req :: Request
    req rsp :: Response
    rsp = do
        GMTDate
    date <- InternalInfo -> IO GMTDate
    getDate InternalInfo
    ii
        rspst :: (Response, Status, Bool)
    rspst@(h2rsp :: Response
    h2rsp, st :: Status
    st, hasBody :: Bool
    hasBody) <- 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, Status, Bool)
    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, 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  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, 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
          _ -> FilePath -> IO (Response, Status, Bool)
    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, Status, Bool) -> IO (Response, Status, Bool)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Response, Status, Bool)
    rspst
          Just h2data :: 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 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, H.Status, Bool)
    responseFile :: Status
    -> ResponseHeaders
    -> Bool
    -> FilePath
    -> Maybe FilePart
    -> InternalInfo
    -> ResponseHeaders
    -> IO (Response, Status, Bool)
    responseFile st :: Status
    st rsphdr :: ResponseHeaders
    rsphdr _ _ _ _ _
      | 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 st :: Status
    st rsphdr :: ResponseHeaders
    rsphdr isHead :: Bool
    isHead path :: FilePath
    path (Just fp :: FilePart
    fp) _ _ =
        (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 _ 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, 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 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, 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 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, 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 st :: Status
    st rsphdr :: ResponseHeaders
    rsphdr isHead :: Bool
    isHead fileSpec :: 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 st :: Status
    st rsphdr :: ResponseHeaders
    rsphdr isHead :: Bool
    isHead builder :: 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 st :: Status
    st rsphdr :: ResponseHeaders
    rsphdr isHead :: Bool
    isHead strmbdy :: 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 st :: Status
    st rsphdr :: 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 rsphdr :: 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 "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