HTTP2.hs

module Network.GRPC.Util.HTTP2 (
    -- * General auxiliary
    fromHeaderTable
    -- * Configuration
  , withConfigForInsecure
  , withConfigForSecure
    -- * Settings
  , mkServerConfig
  , mkTlsSettings
    -- * Timeouts
  , withTimeManager
  ) where

import Control.Exception
import Data.Bifunctor
import Data.ByteString qualified as Strict (ByteString)
import Foreign (mallocBytes, free)
import Network.HPACK (BufferSize)
import Network.HPACK qualified as HPACK
import Network.HPACK.Token qualified as HPACK
import Network.HTTP.Types qualified as HTTP
import Network.HTTP2.Server qualified as Server
import Network.HTTP2.TLS.Server qualified as Server.TLS
import Network.Socket (Socket, SockAddr)
import Network.Socket qualified as Socket
import Network.Socket.BufferPool (Recv)
import Network.Socket.BufferPool qualified as Recv
import Network.Socket.ByteString qualified as Socket
import System.TimeManager qualified as Time (Manager)
import System.TimeManager qualified as TimeManager

import Network.GRPC.Common.HTTP2Settings

{-------------------------------------------------------------------------------
  General auxiliary
-------------------------------------------------------------------------------}

fromHeaderTable :: HPACK.TokenHeaderTable -> [HTTP.Header]
fromHeaderTable = map (first HPACK.tokenKey) . fst

{-------------------------------------------------------------------------------
  Configuration
-------------------------------------------------------------------------------}

-- | Create config to be used with @http2@ (without TLS)
--
-- We do not use @allocSimpleConfig@ from @http2:Network.HTTP2.Server@, but
-- instead create a config that is very similar to the config created by
-- 'allocConfigForSecure'.
withConfigForInsecure ::
     Time.Manager
  -> Socket
  -> (Server.Config -> IO a)
  -> IO a
withConfigForInsecure mgr sock k = do
    -- @recv@ does not provide a way to deallocate a buffer pool, and
    -- @http2-tls@ (in @freeServerConfig@) does not attempt to deallocate it.
    -- We follow suit here.
    pool   <- Recv.newBufferPool readBufferLowerLimit readBufferSize
    mysa   <- Socket.getSocketName sock
    peersa <- Socket.getPeerName sock
    withConfig
      mgr
      (Socket.sendAll sock)
      (Recv.receive sock pool)
      mysa
      peersa
      k
  where
    def :: Server.TLS.Settings
    def = Server.TLS.defaultSettings

    -- Use the defaults from @http2-tls@
    readBufferLowerLimit, readBufferSize :: Int
    readBufferLowerLimit = Server.TLS.settingsReadBufferLowerLimit def
    readBufferSize       = Server.TLS.settingsReadBufferSize       def

-- | Create config to be used with @http2-tls@ (with TLS)
--
-- This is adapted from @allocConfigForServer@ in
-- @http2-tls:Network.HTTP2.TLS.Config@.
withConfigForSecure ::
     Time.Manager
  -> Server.TLS.IOBackend
  -> (Server.Config -> IO a)
  -> IO a
withConfigForSecure mgr backend =
    withConfig
      mgr
      (Server.TLS.send         backend)
      (Server.TLS.recv         backend)
      (Server.TLS.mySockAddr   backend)
      (Server.TLS.peerSockAddr backend)

-- | Internal generalization
withConfig ::
     Time.Manager
  -> (Strict.ByteString -> IO ())
  -> Recv
  -> SockAddr
  -> SockAddr
  -> (Server.Config -> IO a)
  -> IO a
withConfig mgr send recv mysa peersa k =
    bracket (mallocBytes writeBufferSize) free $ \buf -> do
      recvN <- Recv.makeRecvN mempty recv
      k Server.Config {
          confWriteBuffer       = buf
        , confBufferSize        = writeBufferSize
        , confSendAll           = send
        , confReadN             = recvN
        , confPositionReadMaker = Server.defaultPositionReadMaker
        , confTimeoutManager    = mgr
        , confMySockAddr        = mysa
        , confPeerSockAddr      = peersa
        }
  where
    -- This is the default value for @settingsSendBufferSize@ in @http2-tls@
    -- and the default value given in the documentation in @http2@.
    writeBufferSize :: BufferSize
    writeBufferSize = 4096

{-------------------------------------------------------------------------------
  Settings

  NOTE: If we want to override 'HTTP2.TLS.settingsReadBufferLowerLimit' or
  'HTTP2.TLS.settingsReadBufferSize', we should also modify
  'allocConfigForInsecure'.
-------------------------------------------------------------------------------}

mkServerConfig :: HTTP2Settings -> Server.ServerConfig
mkServerConfig http2Settings =
    Server.defaultServerConfig {
        Server.connectionWindowSize = fromIntegral $
          http2ConnectionWindowSize http2Settings
      , Server.settings =
          Server.defaultSettings {
              Server.initialWindowSize = fromIntegral $
                http2StreamWindowSize http2Settings
            , Server.maxConcurrentStreams = Just . fromIntegral $
                http2MaxConcurrentStreams http2Settings
            , Server.pingRateLimit =
                case http2OverridePingRateLimit http2Settings of
                  Nothing    -> Server.pingRateLimit Server.defaultSettings
                  Just limit -> limit
            , Server.emptyFrameRateLimit =
                case http2OverrideEmptyFrameRateLimit http2Settings of
                  Nothing    -> Server.emptyFrameRateLimit Server.defaultSettings
                  Just limit -> limit
            , Server.settingsRateLimit =
                case http2OverrideSettingsRateLimit http2Settings of
                  Nothing    -> Server.settingsRateLimit Server.defaultSettings
                  Just limit -> limit
            , Server.rstRateLimit =
                case http2OverrideRstRateLimit http2Settings of
                  Nothing    -> Server.rstRateLimit Server.defaultSettings
                  Just limit -> limit
            }
      }

-- | Settings for secure server (with TLS)
--
-- NOTE: This overlaps with the values in 'mkServerConfig', and I /think/ we
-- don't actually need this, because we don't use @runWithSocket@ from
-- @http2-tls@ (but rather @runTLSWithSocket@. However, we set them here anyway
-- for completeness and in case @http2-tls@ decides to use them elsewhere.
mkTlsSettings ::
     HTTP2Settings
  -> (String -> IO ())  -- ^ Key logger
  -> Server.TLS.Settings
mkTlsSettings http2Settings keyLogger =
    Server.TLS.defaultSettings {
        Server.TLS.settingsKeyLogger =
          keyLogger
      , Server.TLS.settingsTimeout =
          disableTimeout
      , Server.TLS.settingsConnectionWindowSize = fromIntegral $
          http2ConnectionWindowSize http2Settings
      , Server.TLS.settingsStreamWindowSize = fromIntegral $
          http2StreamWindowSize http2Settings
      , Server.TLS.settingsConcurrentStreams = fromIntegral $
          http2MaxConcurrentStreams http2Settings
      , Server.TLS.settingsPingRateLimit =
          case http2OverridePingRateLimit http2Settings of
            Nothing    -> Server.pingRateLimit Server.defaultSettings
            Just limit -> limit
      , Server.TLS.settingsEmptyFrameRateLimit =
          case http2OverrideEmptyFrameRateLimit http2Settings of
            Nothing    -> Server.emptyFrameRateLimit Server.defaultSettings
            Just limit -> limit
      , Server.TLS.settingsSettingsRateLimit =
          case http2OverrideSettingsRateLimit http2Settings of
            Nothing    -> Server.settingsRateLimit Server.defaultSettings
            Just limit -> limit
      , Server.TLS.settingsRstRateLimit =
          case http2OverrideRstRateLimit http2Settings of
            Nothing    -> Server.rstRateLimit Server.defaultSettings
            Just limit -> limit
      }

{-------------------------------------------------------------------------------
  Timeouts
-------------------------------------------------------------------------------}

-- | Allocate time manager (without any actual timeouts)
--
-- The @http2@ ecosystem relies on a time manager for timeouts; we don't use
-- those timeouts (see disableTimeout), but must still provide a time manager
-- for insecure connections. For secure connections the time manager is
-- allocated in 'Network.Run.Timeout.runTCPServerWithSocket' from @network-run@.
-- In that package it allocates a single manager for the entire server (it
-- allocates the manager before calling accept), so we should do the same in the
-- insecure case for better consistency between the two setups; this also avoids
-- the possibility of leaking managers.
withTimeManager :: (Time.Manager -> IO a) -> IO a
withTimeManager = TimeManager.withManager (disableTimeout * 1_000_000)

-- | Disable timeouts in http2/http2-tls
--
-- A value of 0 (or lower) disables timeouts as of @time-manager-0.2.2@.
disableTimeout :: Int
disableTimeout = 0