simplexmq/src/Simplex/Messaging/Transport/HTTP2/Client.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Simplex.Messaging.Transport.HTTP2.Client
  ( HTTP2Client (..),
    HClient (..),
    HTTP2Response (..),
    HTTP2ClientConfig (..),
    HTTP2ClientError (..),
    defaultHTTP2ClientConfig,
    getHTTP2Client,
    getVerifiedHTTP2Client,
    attachHTTP2Client,
    closeHTTP2Client,
    sendRequest,
    sendRequestDirect,
  ) where

import Control.Concurrent.Async
import Control.Exception (Handler (..), IOException, SomeAsyncException, SomeException)
import qualified Control.Exception as E
import Control.Monad
import Data.Functor (($>))
import Data.Time (UTCTime, getCurrentTime)
import qualified Data.X509 as X
import qualified Data.X509.CertificateStore as XS
import Network.HPACK (BufferSize)
import Network.HTTP2.Client (ClientConfig (..), Request, Response)
import qualified Network.HTTP2.Client as H
import Network.Socket (HostName, ServiceName)
import Network.Socks5 (SocksCredentials)
import qualified Network.TLS as T
import Numeric.Natural (Natural)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (NetworkError (..), toNetworkError)
import Simplex.Messaging.Transport (ALPN, STransportPeer (..), SessionId, TLS (tlsALPN, tlsPeerCert, tlsUniq), TransportPeer (..), TransportPeerI (..), getServerVerifyKey)
import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), defaultTcpConnectTimeout, runTLSTransportClient)
import Simplex.Messaging.Transport.HTTP2
import Simplex.Messaging.Util (eitherToMaybe)
import UnliftIO.STM
import UnliftIO.Timeout

data HTTP2Client = HTTP2Client
  { action :: Maybe (Async HTTP2Response),
    sessionId :: SessionId,
    sessionALPN :: Maybe ALPN,
    serverKey :: Maybe C.APublicVerifyKey, -- may not always be a key we control (i.e. APNS with apple-mandated key types)
    serverCerts :: X.CertificateChain,
    sessionTs :: UTCTime,
    sendReq :: Request -> (Response -> IO HTTP2Response) -> IO HTTP2Response,
    client_ :: HClient
  }

data HClient = HClient
  { connected :: TVar Bool,
    disconnected :: IO (),
    host :: TransportHost,
    port :: ServiceName,
    config :: HTTP2ClientConfig,
    reqQ :: TBQueue (Request, TMVar HTTP2Response)
  }

data HTTP2Response = HTTP2Response
  { response :: Response,
    respBody :: HTTP2Body
  }

data HTTP2ClientConfig = HTTP2ClientConfig
  { qSize :: Natural,
    connTimeout :: Int,
    transportConfig :: TransportClientConfig,
    bufferSize :: BufferSize,
    bodyHeadSize :: Int,
    suportedTLSParams :: T.Supported
  }
  deriving (Show)

defaultHTTP2ClientConfig :: HTTP2ClientConfig
defaultHTTP2ClientConfig =
  HTTP2ClientConfig
    { qSize = 64,
      connTimeout = defaultTcpConnectTimeout,
      transportConfig =
        TransportClientConfig
          { socksProxy = Nothing,
            tcpConnectTimeout = defaultTcpConnectTimeout,
            tcpKeepAlive = Nothing,
            logTLSErrors = True,
            clientCredentials = Nothing,
            clientALPN = Nothing,
            useSNI = False
          },
      bufferSize = defaultHTTP2BufferSize,
      bodyHeadSize = 16384,
      suportedTLSParams = http2TLSParams
    }

data HTTP2ClientError = HCResponseTimeout | HCNetworkError NetworkError | HCIOError String
  deriving (Show)

httpClientHandlers :: [Handler (Either HTTP2ClientError a)]
httpClientHandlers =
  [ Handler $ \(e :: IOException) -> pure $ Left $ HCIOError $ E.displayException e,
    Handler $ \(e :: SomeAsyncException) -> E.throwIO e,
    Handler $ \(e :: SomeException) -> pure $ Left $ HCNetworkError $ toNetworkError e
  ]

getHTTP2Client :: HostName -> ServiceName -> Maybe XS.CertificateStore -> HTTP2ClientConfig -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
getHTTP2Client host port = getVerifiedHTTP2Client Nothing (THDomainName host) port Nothing

getVerifiedHTTP2Client :: Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> Maybe XS.CertificateStore -> HTTP2ClientConfig -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
getVerifiedHTTP2Client socksCreds host port keyHash caStore config disconnected = getVerifiedHTTP2ClientWith config host port disconnected setup
  where
    setup = runHTTP2Client (suportedTLSParams config) caStore (transportConfig config) (bufferSize config) socksCreds host port keyHash

-- HTTP2 client can be run on both client and server TLS connections.
attachHTTP2Client :: forall p. TransportPeerI p => HTTP2ClientConfig -> TransportHost -> ServiceName -> IO () -> Int -> TLS p -> IO (Either HTTP2ClientError HTTP2Client)
attachHTTP2Client config host port disconnected bufferSize tls = getVerifiedHTTP2ClientWith config host port disconnected setup
  where
    setup :: (TLS p -> H.Client HTTP2Response) -> IO HTTP2Response
    setup = runHTTP2ClientWith bufferSize host ($ tls)

getVerifiedHTTP2ClientWith :: forall p. TransportPeerI p => HTTP2ClientConfig -> TransportHost -> ServiceName -> IO () -> ((TLS p -> H.Client HTTP2Response) -> IO HTTP2Response) -> IO (Either HTTP2ClientError HTTP2Client)
getVerifiedHTTP2ClientWith config host port disconnected setup =
  (mkHTTPS2Client >>= runClient)
    `E.catches` httpClientHandlers
  where
    mkHTTPS2Client :: IO HClient
    mkHTTPS2Client = do
      connected <- newTVarIO False
      reqQ <- newTBQueueIO $ qSize config
      pure HClient {connected, disconnected, host, port, config, reqQ}

    runClient :: HClient -> IO (Either HTTP2ClientError HTTP2Client)
    runClient c = do
      cVar <- newEmptyTMVarIO
      action <-
        async $ setup (client c cVar) `E.catch` \e -> do
          atomically $ putTMVar cVar $ Left $ HCNetworkError $ toNetworkError e
          E.throwIO e
      c_ <- connTimeout config `timeout` atomically (takeTMVar cVar)
      case c_ of
        Just (Right c') -> pure $ Right c' {action = Just action}
        Just (Left e) -> pure $ Left e
        Nothing -> cancel action $> Left (HCNetworkError NETimeoutError)

    client :: HClient -> TMVar (Either HTTP2ClientError HTTP2Client) -> TLS p -> H.Client HTTP2Response
    client c cVar tls sendReq = do
      sessionTs <- getCurrentTime
      let c' =
            HTTP2Client
              { action = Nothing,
                client_ = c,
                serverKey = case sTransportPeer @p of
                  STClient -> eitherToMaybe $ getServerVerifyKey tls
                  STServer -> Nothing,
                serverCerts = tlsPeerCert tls,
                sendReq,
                sessionTs,
                sessionId = tlsUniq tls,
                sessionALPN = tlsALPN tls
              }
      atomically $ do
        writeTVar (connected c) True
        putTMVar cVar (Right c')
      process c' sendReq `E.finally` disconnected

    process :: HTTP2Client -> H.Client HTTP2Response
    process HTTP2Client {client_ = HClient {reqQ}} sendReq = forever $ do
      (req, respVar) <- atomically $ readTBQueue reqQ
      sendReq req $ \r -> do
        respBody <- getHTTP2Body r (bodyHeadSize config)
        let resp = HTTP2Response {response = r, respBody}
        atomically $ putTMVar respVar resp
        pure resp

-- | Disconnects client from the server and terminates client threads.
closeHTTP2Client :: HTTP2Client -> IO ()
closeHTTP2Client = mapM_ uninterruptibleCancel . action

sendRequest :: HTTP2Client -> Request -> Maybe Int -> IO (Either HTTP2ClientError HTTP2Response)
sendRequest HTTP2Client {client_ = HClient {config, reqQ}} req reqTimeout_ = do
  resp <- newEmptyTMVarIO
  atomically $ writeTBQueue reqQ (req, resp)
  let reqTimeout = http2RequestTimeout config reqTimeout_
  maybe (Left HCResponseTimeout) Right <$> (reqTimeout `timeout` atomically (takeTMVar resp))

-- spec: spec/modules/Simplex/Messaging/Transport/HTTP2/Client.md#sendrequest-vs-sendrequestdirect--thread-safety
-- | this function should not be used until HTTP2 is thread safe, use sendRequest
sendRequestDirect :: HTTP2Client -> Request -> Maybe Int -> IO (Either HTTP2ClientError HTTP2Response)
sendRequestDirect HTTP2Client {client_ = HClient {config, disconnected}, sendReq} req reqTimeout_ = do
  let reqTimeout = http2RequestTimeout config reqTimeout_
  reqTimeout `timeout` ((Right <$> sendReq req process) `E.catches` httpClientHandlers) >>= \case
    Just (Right r) -> pure $ Right r
    Just (Left e) -> disconnected $> Left e
    Nothing -> pure $ Left HCResponseTimeout
  where
    process r = do
      respBody <- getHTTP2Body r $ bodyHeadSize config
      pure HTTP2Response {response = r, respBody}

http2RequestTimeout :: HTTP2ClientConfig -> Maybe Int -> Int
http2RequestTimeout HTTP2ClientConfig {connTimeout} = maybe connTimeout (connTimeout +)

runHTTP2Client :: forall a. T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> BufferSize -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (TLS 'TClient -> H.Client a) -> IO a
runHTTP2Client tlsParams caStore tcConfig bufferSize socksCreds host port keyHash = runHTTP2ClientWith bufferSize host setup
  where
    setup :: (TLS 'TClient -> IO a) -> IO a
    setup = runTLSTransportClient tlsParams caStore tcConfig socksCreds host port keyHash

-- HTTP2 client can be run on both client and server TLS connections.
runHTTP2ClientWith :: forall a p. BufferSize -> TransportHost -> ((TLS p -> IO a) -> IO a) -> (TLS p -> H.Client a) -> IO a
runHTTP2ClientWith bufferSize host setup client = setup $ \tls -> withHTTP2 bufferSize (run tls) (pure ()) tls
  where
    run :: TLS p -> H.Config -> IO a
    run tls cfg = H.run (ClientConfig "https" (strEncode host) 20) cfg $ client tls