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 :: TokenHeaderTable -> [Header]
fromHeaderTable = ((Token, ByteString) -> Header)
-> [(Token, ByteString)] -> [Header]
forall a b. (a -> b) -> [a] -> [b]
map ((Token -> HeaderName) -> (Token, ByteString) -> Header
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Token -> HeaderName
HPACK.tokenKey) ([(Token, ByteString)] -> [Header])
-> (TokenHeaderTable -> [(Token, ByteString)])
-> TokenHeaderTable
-> [Header]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenHeaderTable -> [(Token, ByteString)]
forall a b. (a, b) -> a
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 :: forall a. Manager -> Socket -> (Config -> IO a) -> IO a
withConfigForInsecure Manager
mgr Socket
sock Config -> IO a
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   <- Int -> Int -> IO BufferPool
Recv.newBufferPool Int
readBufferLowerLimit Int
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 :: Settings
def = Settings
Server.TLS.defaultSettings

    -- Use the defaults from @http2-tls@
    readBufferLowerLimit, readBufferSize :: Int
    readBufferLowerLimit :: Int
readBufferLowerLimit = Settings -> Int
Server.TLS.settingsReadBufferLowerLimit Settings
def
    readBufferSize :: Int
readBufferSize       = Settings -> Int
Server.TLS.settingsReadBufferSize       Settings
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 :: forall a. Manager -> IOBackend -> (Config -> IO a) -> IO a
withConfigForSecure Manager
mgr IOBackend
backend =
    Manager
-> (ByteString -> IO ())
-> Recv
-> SockAddr
-> SockAddr
-> (Config -> IO a)
-> IO a
forall a.
Manager
-> (ByteString -> IO ())
-> Recv
-> SockAddr
-> SockAddr
-> (Config -> IO a)
-> IO a
withConfig
      Manager
mgr
      (IOBackend -> ByteString -> IO ()
Server.TLS.send         IOBackend
backend)
      (IOBackend -> Recv
Server.TLS.recv         IOBackend
backend)
      (IOBackend -> SockAddr
Server.TLS.mySockAddr   IOBackend
backend)
      (IOBackend -> SockAddr
Server.TLS.peerSockAddr IOBackend
backend)

-- | Internal generalization
withConfig ::
     Time.Manager
  -> (Strict.ByteString -> IO ())
  -> Recv
  -> SockAddr
  -> SockAddr
  -> (Server.Config -> IO a)
  -> IO a
withConfig :: forall a.
Manager
-> (ByteString -> IO ())
-> Recv
-> SockAddr
-> SockAddr
-> (Config -> IO a)
-> IO a
withConfig Manager
mgr ByteString -> IO ()
send Recv
recv SockAddr
mysa SockAddr
peersa Config -> IO a
k =
    IO (Ptr Word8)
-> (Ptr Word8 -> IO ()) -> (Ptr Word8 -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Int -> IO (Ptr Word8)
forall a. Int -> IO (Ptr a)
mallocBytes Int
writeBufferSize) Ptr Word8 -> IO ()
forall a. Ptr a -> IO ()
free ((Ptr Word8 -> IO a) -> IO a) -> (Ptr Word8 -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
buf -> do
      recvN <- ByteString -> Recv -> IO RecvN
Recv.makeRecvN ByteString
forall a. Monoid a => a
mempty Recv
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 :: Int
writeBufferSize = Int
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 -> ServerConfig
mkServerConfig HTTP2Settings
http2Settings =
    ServerConfig
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
                  Maybe Int
Nothing    -> Settings -> Int
Server.pingRateLimit Settings
Server.defaultSettings
                  Just Int
limit -> Int
limit
            , Server.emptyFrameRateLimit =
                case http2OverrideEmptyFrameRateLimit http2Settings of
                  Maybe Int
Nothing    -> Settings -> Int
Server.emptyFrameRateLimit Settings
Server.defaultSettings
                  Just Int
limit -> Int
limit
            , Server.settingsRateLimit =
                case http2OverrideSettingsRateLimit http2Settings of
                  Maybe Int
Nothing    -> Settings -> Int
Server.settingsRateLimit Settings
Server.defaultSettings
                  Just Int
limit -> Int
limit
            , Server.rstRateLimit =
                case http2OverrideRstRateLimit http2Settings of
                  Maybe Int
Nothing    -> Settings -> Int
Server.rstRateLimit Settings
Server.defaultSettings
                  Just Int
limit -> Int
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 -> (String -> IO ()) -> Settings
mkTlsSettings HTTP2Settings
http2Settings String -> IO ()
keyLogger =
    Settings
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
            Maybe Int
Nothing    -> Settings -> Int
Server.pingRateLimit Settings
Server.defaultSettings
            Just Int
limit -> Int
limit
      , Server.TLS.settingsEmptyFrameRateLimit =
          case http2OverrideEmptyFrameRateLimit http2Settings of
            Maybe Int
Nothing    -> Settings -> Int
Server.emptyFrameRateLimit Settings
Server.defaultSettings
            Just Int
limit -> Int
limit
      , Server.TLS.settingsSettingsRateLimit =
          case http2OverrideSettingsRateLimit http2Settings of
            Maybe Int
Nothing    -> Settings -> Int
Server.settingsRateLimit Settings
Server.defaultSettings
            Just Int
limit -> Int
limit
      , Server.TLS.settingsRstRateLimit =
          case http2OverrideRstRateLimit http2Settings of
            Maybe Int
Nothing    -> Settings -> Int
Server.rstRateLimit Settings
Server.defaultSettings
            Just Int
limit -> Int
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 :: forall a. (Manager -> IO a) -> IO a
withTimeManager = Int -> (Manager -> IO a) -> IO a
forall a. Int -> (Manager -> IO a) -> IO a
TimeManager.withManager (Int
disableTimeout Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
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 :: Int
disableTimeout = Int
0