HTTP2.hs

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

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

import qualified Control.Exception as E
import qualified Data.ByteString as BS
import Data.IORef (readIORef)
import qualified Data.IORef as I
import GHC.Conc.Sync (labelThread, myThreadId)
import qualified Network.HTTP2.Client as H2C
import qualified Network.HTTP2.Frame as H2
import qualified Network.HTTP2.Server as H2
import Network.Socket (SockAddr)
import Network.Socket.BufferPool
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

-- Early Hints wiring needs both the http-semantics 'auxSendInformational' field
-- (0.4.1) and the http2 sender support that actually emits it (5.4.2).
#define HAS_EARLY_HINTS_SUPPORT (MIN_VERSION_http_semantics(0,4,1) && MIN_VERSION_http2(5,4,2))

#if HAS_EARLY_HINTS_SUPPORT
import qualified Network.HTTP.Types as H
#endif

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

http2
    :: S.Settings
    -> InternalInfo
    -> Connection
    -> Transport
    -> Application
    -> SockAddr
    -> T.Handle
    -> ByteString
    -> IO ()
http2 settings ii conn transport app peersa th bs = do
    rawRecvN <- makeRecvN bs $ connRecv conn
    writeBuffer <- readIORef $ connWriteBuffer 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 = wrappedRecvN th (S.settingsSlowlorisSize settings) rawRecvN
        sendBS x = connSendAll conn x >> T.tickle th
        conf =
            H2.defaultConfig
                { H2.confWriteBuffer = bufBuffer writeBuffer
                , H2.confBufferSize = bufSize writeBuffer
                , H2.confSendAll = sendBS
                , H2.confReadN = recvN
                , H2.confPositionReadMaker = pReadMaker ii
                , H2.confTimeoutManager = timeoutManager ii
                , H2.confMySockAddr = connMySockAddr conn
                , H2.confPeerSockAddr = peersa
                , H2.confReadNTimeout = True
                }
    ok <- checkTLS
    setConnHTTP2 conn True
    when ok $
        endedNormally $
            H2.run H2.defaultServerConfig conf $
                http2server "Warp HTTP/2" settings ii transport peersa app
  where
    -- http2 ends a connection which has run its course with
    -- 'ConnectionIsClosed', which is no exception to report.
    endedNormally = E.handle $ \e -> case e of
        H2C.ConnectionIsClosed -> return ()
        _ -> E.throwIO e
    -- A GOAWAY ends the connection, so there is nothing left to serve
    -- on it.
    checkTLS = case transport of
        TCP -> return True -- direct
        tls
            | tls12orLater tls -> return True
            | otherwise -> do
                goaway conn H2.InadequateSecurity "Weak TLS"
                return False
    tls12orLater tls = tlsMajorVersion tls == 3 && tlsMinorVersion tls >= 3

-- | Converting WAI application to the server type of http2 library.
--
-- @since 3.3.11
http2server
    :: String
    -> S.Settings
    -> InternalInfo
    -> Transport
    -> SockAddr
    -> Application
    -> H2.Server
http2server label settings ii transport addr app h2req0 aux0 response = do
    tid <- myThreadId
    labelThread tid (label ++ " http2server " ++ show addr)
    req0 <- toWAIRequest h2req0 aux0
#if HAS_EARLY_HINTS_SUPPORT
    let req = req0{requestSendEarlyHints = H2.auxSendInformational aux0 (H.mkStatus 103 "Early Hints")}
#else
    let req = req0
#endif
    ref <- I.newIORef Nothing
    eResponseReceived <- E.try $ app req $ \rsp -> do
        (h2rsp, st, hasBody) <- fromResponse settings ii req rsp
        pps <- if hasBody then fromPushPromises ii req else return []
        I.writeIORef ref $ Just (h2rsp, pps, st)
        _ <- response h2rsp pps
        return ResponseReceived
    msent <- I.readIORef ref
    let logSent (h2rsp, pps, st) = do
            let msiz = fromIntegral <$> H2.responseBodySize h2rsp
            logResponse req st msiz
            mapM_ (logPushPromise req) pps
    case eResponseReceived of
        Right ResponseReceived -> case msent of
            Just sent -> logSent sent
            -- Reachable only through Network.Wai.Internal: the
            -- application said it had answered without answering.
            Nothing -> E.throwIO $ userError "no response from the application"
        Left e
            | isAsyncException e -> E.throwIO e
            | otherwise -> do
                S.settingsOnException settings (Just req) e
                case msent of
                    -- The response has gone out, so this exception
                    -- cannot replace it, which is what istatus keeps
                    -- HTTP/1 from doing.
                    Just sent -> logSent sent
                    Nothing -> do
                        let ersp = S.settingsOnExceptionResponse settings e
                        (h2rsp, _, _) <- fromResponse settings ii req ersp
                        _ <- response h2rsp []
                        logSent (h2rsp, [], responseStatus ersp)
    return ()
  where
    toWAIRequest h2req aux = toRequest ii settings addr hdr bdylen bdy th transport
      where
        !hdr = H2.requestHeaders h2req
        !bdy = H2.getRequestBodyChunk h2req
        !bdylen = H2.requestBodySize h2req
        !th = H2.auxTimeHandle aux

    logResponse = S.settingsLogger settings

    logPushPromise req pp = logger req path siz
      where
        !logger = S.settingsServerPushLogger settings
        !path = H2.promiseRequestPath pp
        !siz = case H2.responseBodySize $ H2.promiseResponse pp of
            Nothing -> 0
            Just s -> fromIntegral s

wrappedRecvN
    :: T.Handle -> Int -> (BufSize -> IO ByteString) -> (BufSize -> IO ByteString)
wrappedRecvN th slowlorisSize readN bufsize = do
    bs <- E.handle handler $ readN bufsize
    -- 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).
    when
        (BS.length bs > 0 && BS.length bs >= slowlorisSize || bufsize <= slowlorisSize)
        $ T.tickle th
    return bs
  where
    handler :: E.SomeException -> IO ByteString
    handler = throughAsync (return "")

-- connClose must not be called here since Run:fork calls it
--
-- The SETTINGS frame is this server's half of the connection preface,
-- which RFC 9113 has it send before anything else, GOAWAY included.
goaway :: Connection -> H2.ErrorCode -> ByteString -> IO ()
goaway Connection{..} etype debugmsg = connSendAll $ preface <> bytestream
  where
    einfo = H2.encodeInfo id 0
    preface = H2.encodeFrame einfo $ H2.SettingsFrame []
    frame = H2.GoAwayFrame 0 etype debugmsg
    bytestream = H2.encodeFrame einfo frame