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

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

import qualified UnliftIO
import qualified Data.ByteString as BS
import Data.IORef (IORef, newIORef, writeIORef)
import qualified Data.IORef as I
import qualified Network.HTTP2.Frame as H2
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
import Network.Wai.Handler.Warp.Recv

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

http2 :: S.Settings -> InternalInfo -> Connection -> Transport -> Application -> SockAddr -> T.Handle -> ByteString -> IO ()
http2 :: Settings
-> InternalInfo
-> Connection
-> Transport
-> Application
-> SockAddr
-> Handle
-> ByteString
-> IO ()
http2 Settings
settings InternalInfo
ii Connection
conn Transport
transport Application
app SockAddr
origAddr Handle
th ByteString
bs = do
    IORef Bool
istatus <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
    BufSize -> IO ByteString
rawRecvN <- ByteString
-> IO ByteString -> RecvBuf -> IO (BufSize -> IO ByteString)
makeReceiveN ByteString
bs (Connection -> IO ByteString
connRecv Connection
conn) (Connection -> RecvBuf
connRecvBuf Connection
conn)
    -- This thread becomes the sender in http2 library.
    -- In the case of event source, one request comes and one
    -- worker gets busy. But it is likely that the receiver does
    -- not receive any data at all while the sender is sending
    -- output data from the worker. It's not good enough to tickle
    -- the time handler in the receiver only. So, we should tickle
    -- the time handler in both the receiver and the sender.
    let recvN :: BufSize -> IO ByteString
recvN = Handle
-> IORef Bool
-> BufSize
-> (BufSize -> IO ByteString)
-> BufSize
-> IO ByteString
wrappedRecvN Handle
th IORef Bool
istatus (Settings -> BufSize
S.settingsSlowlorisSize Settings
settings) BufSize -> IO ByteString
rawRecvN
        sendBS :: ByteString -> IO ()
sendBS ByteString
x = Connection -> ByteString -> IO ()
connSendAll Connection
conn ByteString
x IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
T.tickle Handle
th
        conf :: Config
conf = Config :: Buffer
-> BufSize
-> (ByteString -> IO ())
-> (BufSize -> IO ByteString)
-> PositionReadMaker
-> Manager
-> 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 ()
sendBS
          , confReadN :: BufSize -> IO ByteString
confReadN             = BufSize -> IO ByteString
recvN
          , confPositionReadMaker :: PositionReadMaker
confPositionReadMaker = InternalInfo -> PositionReadMaker
pReadMaker InternalInfo
ii
          , confTimeoutManager :: Manager
confTimeoutManager    = InternalInfo -> Manager
timeoutManager InternalInfo
ii
          }
    IO ()
checkTLS
    Connection -> Bool -> IO ()
setConnHTTP2 Connection
conn Bool
True
    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
origAddr Application
app
  where
    checkTLS :: IO ()
checkTLS = case Transport
transport of
        Transport
TCP -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- direct
        Transport
tls -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Transport -> Bool
tls12orLater Transport
tls) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> ErrorCodeId -> ByteString -> IO ()
goaway Connection
conn ErrorCodeId
H2.InadequateSecurity ByteString
"Weak TLS"
    tls12orLater :: Transport -> Bool
tls12orLater Transport
tls = Transport -> BufSize
tlsMajorVersion Transport
tls BufSize -> BufSize -> Bool
forall a. Eq a => a -> a -> Bool
== BufSize
3 Bool -> Bool -> Bool
&& Transport -> BufSize
tlsMinorVersion Transport
tls BufSize -> BufSize -> Bool
forall a. Ord a => a -> a -> Bool
>= BufSize
3

-- | 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 InternalInfo
ii Transport
transport SockAddr
addr Application
app Request
h2req0 Aux
aux0 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 (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
UnliftIO.tryAny (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
$ \Response
rsp -> do
        (Response
h2rsp,Status
st,Bool
hasBody) <- Settings
-> InternalInfo
-> Request
-> Response
-> IO (Response, Status, Bool)
fromResponse Settings
settings InternalInfo
ii Request
req Response
rsp
        [PushPromise]
pps <- if Bool
hasBody then InternalInfo -> Request -> IO [PushPromise]
fromPushPromises InternalInfo
ii Request
req else [PushPromise] -> IO [PushPromise]
forall (m :: * -> *) a. Monad m => a -> m a
return []
        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
ResponseReceived -> do
          Just (Response
h2rsp, [PushPromise]
pps, 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 SomeException
e -> 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',Status
_,Bool
_) <- Settings
-> InternalInfo
-> Request
-> Response
-> IO (Response, Status, Bool)
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 Request
h2req 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 Request
req 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
            Maybe BufSize
Nothing -> Integer
0
            Just BufSize
s  -> BufSize -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral BufSize
s

wrappedRecvN :: T.Handle -> IORef Bool -> Int -> (BufSize -> IO ByteString) -> (BufSize -> IO ByteString)
wrappedRecvN :: Handle
-> IORef Bool
-> BufSize
-> (BufSize -> IO ByteString)
-> BufSize
-> IO ByteString
wrappedRecvN Handle
th IORef Bool
istatus BufSize
slowlorisSize BufSize -> IO ByteString
readN BufSize
bufsize = do
    ByteString
bs <- BufSize -> IO ByteString
readN BufSize
bufsize
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
BS.null ByteString
bs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
istatus Bool
True
    -- TODO: think about the slowloris protection in HTTP2: current code
    -- might open a slow-loris attack vector. Rather than timing we should
    -- consider limiting the per-client connections assuming that in HTTP2
    -- we should allow only few connections per host (real-world
    -- deployments with large NATs may be trickier).
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> BufSize
BS.length ByteString
bs BufSize -> BufSize -> Bool
forall a. Ord a => a -> a -> Bool
>= BufSize
slowlorisSize Bool -> Bool -> Bool
|| BufSize
bufsize BufSize -> BufSize -> Bool
forall a. Ord a => a -> a -> Bool
<= BufSize
slowlorisSize) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
T.tickle Handle
th
    ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs

-- connClose must not be called here since Run:fork calls it
goaway :: Connection -> H2.ErrorCodeId -> ByteString -> IO ()
goaway :: Connection -> ErrorCodeId -> ByteString -> IO ()
goaway Connection{BufSize
IO ()
IO ByteString
Buffer
IORef Bool
[ByteString] -> IO ()
RecvBuf
ByteString -> IO ()
SendFile
connHTTP2 :: Connection -> IORef Bool
connFree :: Connection -> IO ()
connClose :: Connection -> IO ()
connSendFile :: Connection -> SendFile
connSendMany :: Connection -> [ByteString] -> IO ()
connHTTP2 :: IORef Bool
connBufferSize :: BufSize
connWriteBuffer :: Buffer
connRecvBuf :: RecvBuf
connRecv :: IO ByteString
connFree :: IO ()
connClose :: IO ()
connSendFile :: SendFile
connSendAll :: ByteString -> IO ()
connSendMany :: [ByteString] -> IO ()
connBufferSize :: Connection -> BufSize
connWriteBuffer :: Connection -> Buffer
connSendAll :: Connection -> ByteString -> IO ()
connRecvBuf :: Connection -> RecvBuf
connRecv :: Connection -> IO ByteString
..} ErrorCodeId
etype ByteString
debugmsg = ByteString -> IO ()
connSendAll ByteString
bytestream
  where
    einfo :: EncodeInfo
einfo = (FrameFlags -> FrameFlags) -> BufSize -> EncodeInfo
H2.encodeInfo FrameFlags -> FrameFlags
forall a. a -> a
id BufSize
0
    frame :: FramePayload
frame = BufSize -> ErrorCodeId -> ByteString -> FramePayload
H2.GoAwayFrame BufSize
0 ErrorCodeId
etype ByteString
debugmsg
    bytestream :: ByteString
bytestream = EncodeInfo -> FramePayload -> ByteString
H2.encodeFrame EncodeInfo
einfo FramePayload
frame