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

module Network.Wai.Handler.Warp.HTTP2 (
    http2
  , http2server
  ) where

import qualified Data.IORef as I
import qualified Control.Exception as E
import qualified Network.HTTP2.Server as H2
import Network.Socket (SockAddr)
import Network.Wai
import Network.Wai.Internal (ResponseReceived(..))
import qualified System.TimeManager as T

import Network.Wai.Handler.Warp.HTTP2.File
import Network.Wai.Handler.Warp.HTTP2.PushPromise
import Network.Wai.Handler.Warp.HTTP2.Request
import Network.Wai.Handler.Warp.HTTP2.Response
import Network.Wai.Handler.Warp.Imports
import qualified Network.Wai.Handler.Warp.Settings as S
import Network.Wai.Handler.Warp.Types

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

http2 :: S.Settings
      -> InternalInfo
      -> Connection
      -> Transport
      -> SockAddr
      -> (BufSize -> IO ByteString)
      -> (ByteString -> IO ())
      -> Application
      -> IO ()
http2 :: Settings
-> InternalInfo
-> Connection
-> Transport
-> SockAddr
-> (BufSize -> IO ByteString)
-> (ByteString -> IO ())
-> Application
-> IO ()
http2 settings :: Settings
settings ii :: InternalInfo
ii conn :: Connection
conn transport :: Transport
transport addr :: SockAddr
addr readN :: BufSize -> IO ByteString
readN send :: ByteString -> IO ()
send app :: Application
app =
    Config -> Server -> IO ()
H2.run Config
conf (Server -> IO ()) -> Server -> IO ()
forall a b. (a -> b) -> a -> b
$ Settings
-> InternalInfo -> Transport -> SockAddr -> Application -> Server
http2server Settings
settings InternalInfo
ii Transport
transport SockAddr
addr Application
app
  where
    conf :: Config
conf = $WConfig :: Buffer
-> BufSize
-> (ByteString -> IO ())
-> (BufSize -> IO ByteString)
-> PositionReadMaker
-> Config
H2.Config {
        confWriteBuffer :: Buffer
confWriteBuffer       = Connection -> Buffer
connWriteBuffer Connection
conn
      , confBufferSize :: BufSize
confBufferSize        = Connection -> BufSize
connBufferSize Connection
conn
      , confSendAll :: ByteString -> IO ()
confSendAll           = ByteString -> IO ()
send
      , confReadN :: BufSize -> IO ByteString
confReadN             = BufSize -> IO ByteString
readN
      , confPositionReadMaker :: PositionReadMaker
confPositionReadMaker = InternalInfo -> PositionReadMaker
pReadMaker InternalInfo
ii
      }

-- | Converting WAI application to the server type of http2 library.
--
-- Since 3.3.11
http2server :: S.Settings
            -> InternalInfo
            -> Transport
            -> SockAddr
            -> Application
            -> H2.Server
http2server :: Settings
-> InternalInfo -> Transport -> SockAddr -> Application -> Server
http2server settings :: Settings
settings ii :: InternalInfo
ii transport :: Transport
transport addr :: SockAddr
addr app :: Application
app h2req0 :: Request
h2req0 aux0 :: Aux
aux0 response :: Response -> [PushPromise] -> IO ()
response = do
    Request
req <- Request -> Aux -> IO Request
toWAIRequest Request
h2req0 Aux
aux0
    IORef (Maybe (Response, [PushPromise], Status))
ref <- Maybe (Response, [PushPromise], Status)
-> IO (IORef (Maybe (Response, [PushPromise], Status)))
forall a. a -> IO (IORef a)
I.newIORef Maybe (Response, [PushPromise], Status)
forall a. Maybe a
Nothing
    Either SomeException ResponseReceived
eResponseReceived <- IO ResponseReceived -> IO (Either SomeException ResponseReceived)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO ResponseReceived -> IO (Either SomeException ResponseReceived))
-> IO ResponseReceived
-> IO (Either SomeException ResponseReceived)
forall a b. (a -> b) -> a -> b
$ Application
app Request
req ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \rsp :: Response
rsp -> do
        let st :: Status
st = Response -> Status
responseStatus Response
rsp
        Response
h2rsp <- Settings -> InternalInfo -> Request -> Response -> IO Response
fromResponse Settings
settings InternalInfo
ii Request
req Response
rsp
        [PushPromise]
pps <- InternalInfo -> Request -> IO [PushPromise]
fromPushPromises InternalInfo
ii Request
req
        IORef (Maybe (Response, [PushPromise], Status))
-> Maybe (Response, [PushPromise], Status) -> IO ()
forall a. IORef a -> a -> IO ()
I.writeIORef IORef (Maybe (Response, [PushPromise], Status))
ref (Maybe (Response, [PushPromise], Status) -> IO ())
-> Maybe (Response, [PushPromise], Status) -> IO ()
forall a b. (a -> b) -> a -> b
$ (Response, [PushPromise], Status)
-> Maybe (Response, [PushPromise], Status)
forall a. a -> Maybe a
Just (Response
h2rsp, [PushPromise]
pps, Status
st)
        ()
_ <- Response -> [PushPromise] -> IO ()
response Response
h2rsp [PushPromise]
pps
        ResponseReceived -> IO ResponseReceived
forall (m :: * -> *) a. Monad m => a -> m a
return ResponseReceived
ResponseReceived
    case Either SomeException ResponseReceived
eResponseReceived of
      Right ResponseReceived -> do
          Just (h2rsp :: Response
h2rsp, pps :: [PushPromise]
pps, st :: Status
st) <- IORef (Maybe (Response, [PushPromise], Status))
-> IO (Maybe (Response, [PushPromise], Status))
forall a. IORef a -> IO a
I.readIORef IORef (Maybe (Response, [PushPromise], Status))
ref
          let msiz :: Maybe Integer
msiz = BufSize -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (BufSize -> Integer) -> Maybe BufSize -> Maybe Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response -> Maybe BufSize
H2.responseBodySize Response
h2rsp
          Request -> Status -> Maybe Integer -> IO ()
logResponse Request
req Status
st Maybe Integer
msiz
          (PushPromise -> IO ()) -> [PushPromise] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Request -> PushPromise -> IO ()
logPushPromise Request
req) [PushPromise]
pps
      Left e :: SomeException
e@(E.SomeException _)
        -- killed by the local worker manager
        | Just E.ThreadKilled  <- SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
e -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        -- killed by the local timeout manager
        | Just T.TimeoutThread <- SomeException -> Maybe TimeoutThread
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
e -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        | Bool
otherwise -> do
            Settings -> Maybe Request -> SomeException -> IO ()
S.settingsOnException Settings
settings (Request -> Maybe Request
forall a. a -> Maybe a
Just Request
req) SomeException
e
            let ersp :: Response
ersp = Settings -> SomeException -> Response
S.settingsOnExceptionResponse Settings
settings SomeException
e
                st :: Status
st = Response -> Status
responseStatus Response
ersp
            Response
h2rsp' <- Settings -> InternalInfo -> Request -> Response -> IO Response
fromResponse Settings
settings InternalInfo
ii Request
req Response
ersp
            let msiz :: Maybe Integer
msiz = BufSize -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (BufSize -> Integer) -> Maybe BufSize -> Maybe Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response -> Maybe BufSize
H2.responseBodySize Response
h2rsp'
            ()
_ <- Response -> [PushPromise] -> IO ()
response Response
h2rsp' []
            Request -> Status -> Maybe Integer -> IO ()
logResponse Request
req Status
st Maybe Integer
msiz
    () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    toWAIRequest :: Request -> Aux -> IO Request
toWAIRequest h2req :: Request
h2req aux :: Aux
aux = InternalInfo -> Settings -> SockAddr -> ToReq
toRequest InternalInfo
ii Settings
settings SockAddr
addr HeaderTable
hdr Maybe BufSize
bdylen IO ByteString
bdy Handle
th Transport
transport
      where
        !hdr :: HeaderTable
hdr = Request -> HeaderTable
H2.requestHeaders Request
h2req
        !bdy :: IO ByteString
bdy = Request -> IO ByteString
H2.getRequestBodyChunk Request
h2req
        !bdylen :: Maybe BufSize
bdylen = Request -> Maybe BufSize
H2.requestBodySize Request
h2req
        !th :: Handle
th = Aux -> Handle
H2.auxTimeHandle Aux
aux

    logResponse :: Request -> Status -> Maybe Integer -> IO ()
logResponse = Settings -> Request -> Status -> Maybe Integer -> IO ()
S.settingsLogger Settings
settings

    logPushPromise :: Request -> PushPromise -> IO ()
logPushPromise req :: Request
req pp :: PushPromise
pp = Request -> ByteString -> Integer -> IO ()
logger Request
req ByteString
path Integer
siz
      where
        !logger :: Request -> ByteString -> Integer -> IO ()
logger = Settings -> Request -> ByteString -> Integer -> IO ()
S.settingsServerPushLogger Settings
settings
        !path :: ByteString
path = PushPromise -> ByteString
H2.promiseRequestPath PushPromise
pp
        !siz :: Integer
siz = case Response -> Maybe BufSize
H2.responseBodySize (Response -> Maybe BufSize) -> Response -> Maybe BufSize
forall a b. (a -> b) -> a -> b
$ PushPromise -> Response
H2.promiseResponse PushPromise
pp of
            Nothing -> 0
            Just s :: BufSize
s  -> BufSize -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral BufSize
s