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

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

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

data HTTP2ClientConfig = HTTP2ClientConfig
  { HTTP2ClientConfig -> Natural
qSize :: Natural,
    HTTP2ClientConfig -> Int
connTimeout :: Int,
    HTTP2ClientConfig -> TransportClientConfig
transportConfig :: TransportClientConfig,
    HTTP2ClientConfig -> Int
bufferSize :: BufferSize,
    HTTP2ClientConfig -> Int
bodyHeadSize :: Int,
    HTTP2ClientConfig -> Supported
suportedTLSParams :: T.Supported
  }
  deriving (Int -> HTTP2ClientConfig -> ShowS
[HTTP2ClientConfig] -> ShowS
HTTP2ClientConfig -> ServiceName
(Int -> HTTP2ClientConfig -> ShowS)
-> (HTTP2ClientConfig -> ServiceName)
-> ([HTTP2ClientConfig] -> ShowS)
-> Show HTTP2ClientConfig
forall a.
(Int -> a -> ShowS)
-> (a -> ServiceName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HTTP2ClientConfig -> ShowS
showsPrec :: Int -> HTTP2ClientConfig -> ShowS
$cshow :: HTTP2ClientConfig -> ServiceName
show :: HTTP2ClientConfig -> ServiceName
$cshowList :: [HTTP2ClientConfig] -> ShowS
showList :: [HTTP2ClientConfig] -> ShowS
Show)

defaultHTTP2ClientConfig :: HTTP2ClientConfig
defaultHTTP2ClientConfig :: HTTP2ClientConfig
defaultHTTP2ClientConfig =
  HTTP2ClientConfig
    { $sel:qSize:HTTP2ClientConfig :: Natural
qSize = Natural
64,
      $sel:connTimeout:HTTP2ClientConfig :: Int
connTimeout = Int
defaultTcpConnectTimeout,
      $sel:transportConfig:HTTP2ClientConfig :: TransportClientConfig
transportConfig =
        TransportClientConfig
          { $sel:socksProxy:TransportClientConfig :: Maybe SocksProxy
socksProxy = Maybe SocksProxy
forall a. Maybe a
Nothing,
            $sel:tcpConnectTimeout:TransportClientConfig :: Int
tcpConnectTimeout = Int
defaultTcpConnectTimeout,
            $sel:tcpKeepAlive:TransportClientConfig :: Maybe KeepAliveOpts
tcpKeepAlive = Maybe KeepAliveOpts
forall a. Maybe a
Nothing,
            $sel:logTLSErrors:TransportClientConfig :: Bool
logTLSErrors = Bool
True,
            $sel:clientCredentials:TransportClientConfig :: Maybe Credential
clientCredentials = Maybe Credential
forall a. Maybe a
Nothing,
            $sel:clientALPN:TransportClientConfig :: Maybe [SessionId]
clientALPN = Maybe [SessionId]
forall a. Maybe a
Nothing,
            $sel:useSNI:TransportClientConfig :: Bool
useSNI = Bool
False
          },
      $sel:bufferSize:HTTP2ClientConfig :: Int
bufferSize = Int
defaultHTTP2BufferSize,
      $sel:bodyHeadSize:HTTP2ClientConfig :: Int
bodyHeadSize = Int
16384,
      $sel:suportedTLSParams:HTTP2ClientConfig :: Supported
suportedTLSParams = Supported
http2TLSParams
    }

data HTTP2ClientError = HCResponseTimeout | HCNetworkError NetworkError | HCIOError IOException
  deriving (Int -> HTTP2ClientError -> ShowS
[HTTP2ClientError] -> ShowS
HTTP2ClientError -> ServiceName
(Int -> HTTP2ClientError -> ShowS)
-> (HTTP2ClientError -> ServiceName)
-> ([HTTP2ClientError] -> ShowS)
-> Show HTTP2ClientError
forall a.
(Int -> a -> ShowS)
-> (a -> ServiceName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HTTP2ClientError -> ShowS
showsPrec :: Int -> HTTP2ClientError -> ShowS
$cshow :: HTTP2ClientError -> ServiceName
show :: HTTP2ClientError -> ServiceName
$cshowList :: [HTTP2ClientError] -> ShowS
showList :: [HTTP2ClientError] -> ShowS
Show)

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

getVerifiedHTTP2Client :: Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> Maybe XS.CertificateStore -> HTTP2ClientConfig -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
getVerifiedHTTP2Client :: Maybe SocksCredentials
-> TransportHost
-> ServiceName
-> Maybe KeyHash
-> Maybe CertificateStore
-> HTTP2ClientConfig
-> IO ()
-> IO (Either HTTP2ClientError HTTP2Client)
getVerifiedHTTP2Client Maybe SocksCredentials
socksCreds TransportHost
host ServiceName
port Maybe KeyHash
keyHash Maybe CertificateStore
caStore HTTP2ClientConfig
config IO ()
disconnected = HTTP2ClientConfig
-> TransportHost
-> ServiceName
-> IO ()
-> ((TLS 'TClient -> Client HTTP2Response) -> IO HTTP2Response)
-> IO (Either HTTP2ClientError HTTP2Client)
forall (p :: TransportPeer).
TransportPeerI p =>
HTTP2ClientConfig
-> TransportHost
-> ServiceName
-> IO ()
-> ((TLS p -> Client HTTP2Response) -> IO HTTP2Response)
-> IO (Either HTTP2ClientError HTTP2Client)
getVerifiedHTTP2ClientWith HTTP2ClientConfig
config TransportHost
host ServiceName
port IO ()
disconnected (TLS 'TClient -> Client HTTP2Response) -> IO HTTP2Response
setup
  where
    setup :: (TLS 'TClient -> Client HTTP2Response) -> IO HTTP2Response
setup = Supported
-> Maybe CertificateStore
-> TransportClientConfig
-> Int
-> Maybe SocksCredentials
-> TransportHost
-> ServiceName
-> Maybe KeyHash
-> (TLS 'TClient -> Client HTTP2Response)
-> IO HTTP2Response
forall a.
Supported
-> Maybe CertificateStore
-> TransportClientConfig
-> Int
-> Maybe SocksCredentials
-> TransportHost
-> ServiceName
-> Maybe KeyHash
-> (TLS 'TClient -> Client a)
-> IO a
runHTTP2Client (HTTP2ClientConfig -> Supported
suportedTLSParams HTTP2ClientConfig
config) Maybe CertificateStore
caStore (HTTP2ClientConfig -> TransportClientConfig
transportConfig HTTP2ClientConfig
config) (HTTP2ClientConfig -> Int
bufferSize HTTP2ClientConfig
config) Maybe SocksCredentials
socksCreds TransportHost
host ServiceName
port Maybe KeyHash
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 :: forall (p :: TransportPeer).
TransportPeerI p =>
HTTP2ClientConfig
-> TransportHost
-> ServiceName
-> IO ()
-> Int
-> TLS p
-> IO (Either HTTP2ClientError HTTP2Client)
attachHTTP2Client HTTP2ClientConfig
config TransportHost
host ServiceName
port IO ()
disconnected Int
bufferSize TLS p
tls = HTTP2ClientConfig
-> TransportHost
-> ServiceName
-> IO ()
-> ((TLS p -> Client HTTP2Response) -> IO HTTP2Response)
-> IO (Either HTTP2ClientError HTTP2Client)
forall (p :: TransportPeer).
TransportPeerI p =>
HTTP2ClientConfig
-> TransportHost
-> ServiceName
-> IO ()
-> ((TLS p -> Client HTTP2Response) -> IO HTTP2Response)
-> IO (Either HTTP2ClientError HTTP2Client)
getVerifiedHTTP2ClientWith HTTP2ClientConfig
config TransportHost
host ServiceName
port IO ()
disconnected (TLS p -> Client HTTP2Response) -> IO HTTP2Response
setup
  where
    setup :: (TLS p -> H.Client HTTP2Response) -> IO HTTP2Response
    setup :: (TLS p -> Client HTTP2Response) -> IO HTTP2Response
setup = Int
-> TransportHost
-> ((TLS p -> IO HTTP2Response) -> IO HTTP2Response)
-> (TLS p -> Client HTTP2Response)
-> IO HTTP2Response
forall a (p :: TransportPeer).
Int
-> TransportHost
-> ((TLS p -> IO a) -> IO a)
-> (TLS p -> Client a)
-> IO a
runHTTP2ClientWith Int
bufferSize TransportHost
host ((TLS p -> IO HTTP2Response) -> TLS p -> IO HTTP2Response
forall a b. (a -> b) -> a -> b
$ TLS p
tls)

getVerifiedHTTP2ClientWith :: forall p. TransportPeerI p => HTTP2ClientConfig -> TransportHost -> ServiceName -> IO () -> ((TLS p -> H.Client HTTP2Response) -> IO HTTP2Response) -> IO (Either HTTP2ClientError HTTP2Client)
getVerifiedHTTP2ClientWith :: forall (p :: TransportPeer).
TransportPeerI p =>
HTTP2ClientConfig
-> TransportHost
-> ServiceName
-> IO ()
-> ((TLS p -> Client HTTP2Response) -> IO HTTP2Response)
-> IO (Either HTTP2ClientError HTTP2Client)
getVerifiedHTTP2ClientWith HTTP2ClientConfig
config TransportHost
host ServiceName
port IO ()
disconnected (TLS p -> Client HTTP2Response) -> IO HTTP2Response
setup =
  (IO HClient
mkHTTPS2Client IO HClient
-> (HClient -> IO (Either HTTP2ClientError HTTP2Client))
-> IO (Either HTTP2ClientError HTTP2Client)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HClient -> IO (Either HTTP2ClientError HTTP2Client)
runClient)
    IO (Either HTTP2ClientError HTTP2Client)
-> (IOException -> IO (Either HTTP2ClientError HTTP2Client))
-> IO (Either HTTP2ClientError HTTP2Client)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(IOException
e :: IOException) -> Either HTTP2ClientError HTTP2Client
-> IO (Either HTTP2ClientError HTTP2Client)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either HTTP2ClientError HTTP2Client
 -> IO (Either HTTP2ClientError HTTP2Client))
-> (HTTP2ClientError -> Either HTTP2ClientError HTTP2Client)
-> HTTP2ClientError
-> IO (Either HTTP2ClientError HTTP2Client)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HTTP2ClientError -> Either HTTP2ClientError HTTP2Client
forall a b. a -> Either a b
Left (HTTP2ClientError -> IO (Either HTTP2ClientError HTTP2Client))
-> HTTP2ClientError -> IO (Either HTTP2ClientError HTTP2Client)
forall a b. (a -> b) -> a -> b
$ IOException -> HTTP2ClientError
HCIOError IOException
e
  where
    mkHTTPS2Client :: IO HClient
    mkHTTPS2Client :: IO HClient
mkHTTPS2Client = do
      TVar Bool
connected <- Bool -> IO (TVar Bool)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Bool
False
      TBQueue (Request, TMVar HTTP2Response)
reqQ <- Natural -> IO (TBQueue (Request, TMVar HTTP2Response))
forall (m :: * -> *) a. MonadIO m => Natural -> m (TBQueue a)
newTBQueueIO (Natural -> IO (TBQueue (Request, TMVar HTTP2Response)))
-> Natural -> IO (TBQueue (Request, TMVar HTTP2Response))
forall a b. (a -> b) -> a -> b
$ HTTP2ClientConfig -> Natural
qSize HTTP2ClientConfig
config
      HClient -> IO HClient
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HClient {TVar Bool
$sel:connected:HClient :: TVar Bool
connected :: TVar Bool
connected, IO ()
$sel:disconnected:HClient :: IO ()
disconnected :: IO ()
disconnected, TransportHost
$sel:host:HClient :: TransportHost
host :: TransportHost
host, ServiceName
$sel:port:HClient :: ServiceName
port :: ServiceName
port, HTTP2ClientConfig
$sel:config:HClient :: HTTP2ClientConfig
config :: HTTP2ClientConfig
config, TBQueue (Request, TMVar HTTP2Response)
$sel:reqQ:HClient :: TBQueue (Request, TMVar HTTP2Response)
reqQ :: TBQueue (Request, TMVar HTTP2Response)
reqQ}

    runClient :: HClient -> IO (Either HTTP2ClientError HTTP2Client)
    runClient :: HClient -> IO (Either HTTP2ClientError HTTP2Client)
runClient HClient
c = do
      TMVar (Either HTTP2ClientError HTTP2Client)
cVar <- IO (TMVar (Either HTTP2ClientError HTTP2Client))
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
      Async HTTP2Response
action <-
        IO HTTP2Response -> IO (Async HTTP2Response)
forall a. IO a -> IO (Async a)
async (IO HTTP2Response -> IO (Async HTTP2Response))
-> IO HTTP2Response -> IO (Async HTTP2Response)
forall a b. (a -> b) -> a -> b
$ (TLS p -> Client HTTP2Response) -> IO HTTP2Response
setup (HClient
-> TMVar (Either HTTP2ClientError HTTP2Client)
-> TLS p
-> Client HTTP2Response
client HClient
c TMVar (Either HTTP2ClientError HTTP2Client)
cVar) IO HTTP2Response
-> (SomeException -> IO HTTP2Response) -> IO HTTP2Response
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \SomeException
e -> do
          STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar (Either HTTP2ClientError HTTP2Client)
-> Either HTTP2ClientError HTTP2Client -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Either HTTP2ClientError HTTP2Client)
cVar (Either HTTP2ClientError HTTP2Client -> STM ())
-> Either HTTP2ClientError HTTP2Client -> STM ()
forall a b. (a -> b) -> a -> b
$ HTTP2ClientError -> Either HTTP2ClientError HTTP2Client
forall a b. a -> Either a b
Left (HTTP2ClientError -> Either HTTP2ClientError HTTP2Client)
-> HTTP2ClientError -> Either HTTP2ClientError HTTP2Client
forall a b. (a -> b) -> a -> b
$ NetworkError -> HTTP2ClientError
HCNetworkError (NetworkError -> HTTP2ClientError)
-> NetworkError -> HTTP2ClientError
forall a b. (a -> b) -> a -> b
$ SomeException -> NetworkError
toNetworkError SomeException
e
          SomeException -> IO HTTP2Response
forall e a. Exception e => e -> IO a
E.throwIO SomeException
e
      Maybe (Either HTTP2ClientError HTTP2Client)
c_ <- HTTP2ClientConfig -> Int
connTimeout HTTP2ClientConfig
config Int
-> IO (Either HTTP2ClientError HTTP2Client)
-> IO (Maybe (Either HTTP2ClientError HTTP2Client))
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
`timeout` STM (Either HTTP2ClientError HTTP2Client)
-> IO (Either HTTP2ClientError HTTP2Client)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TMVar (Either HTTP2ClientError HTTP2Client)
-> STM (Either HTTP2ClientError HTTP2Client)
forall a. TMVar a -> STM a
takeTMVar TMVar (Either HTTP2ClientError HTTP2Client)
cVar)
      case Maybe (Either HTTP2ClientError HTTP2Client)
c_ of
        Just (Right HTTP2Client
c') -> Either HTTP2ClientError HTTP2Client
-> IO (Either HTTP2ClientError HTTP2Client)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either HTTP2ClientError HTTP2Client
 -> IO (Either HTTP2ClientError HTTP2Client))
-> Either HTTP2ClientError HTTP2Client
-> IO (Either HTTP2ClientError HTTP2Client)
forall a b. (a -> b) -> a -> b
$ HTTP2Client -> Either HTTP2ClientError HTTP2Client
forall a b. b -> Either a b
Right HTTP2Client
c' {action = Just action}
        Just (Left HTTP2ClientError
e) -> Either HTTP2ClientError HTTP2Client
-> IO (Either HTTP2ClientError HTTP2Client)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either HTTP2ClientError HTTP2Client
 -> IO (Either HTTP2ClientError HTTP2Client))
-> Either HTTP2ClientError HTTP2Client
-> IO (Either HTTP2ClientError HTTP2Client)
forall a b. (a -> b) -> a -> b
$ HTTP2ClientError -> Either HTTP2ClientError HTTP2Client
forall a b. a -> Either a b
Left HTTP2ClientError
e
        Maybe (Either HTTP2ClientError HTTP2Client)
Nothing -> Async HTTP2Response -> IO ()
forall a. Async a -> IO ()
cancel Async HTTP2Response
action IO ()
-> Either HTTP2ClientError HTTP2Client
-> IO (Either HTTP2ClientError HTTP2Client)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> HTTP2ClientError -> Either HTTP2ClientError HTTP2Client
forall a b. a -> Either a b
Left (NetworkError -> HTTP2ClientError
HCNetworkError NetworkError
NETimeoutError)

    client :: HClient -> TMVar (Either HTTP2ClientError HTTP2Client) -> TLS p -> H.Client HTTP2Response
    client :: HClient
-> TMVar (Either HTTP2ClientError HTTP2Client)
-> TLS p
-> Client HTTP2Response
client HClient
c TMVar (Either HTTP2ClientError HTTP2Client)
cVar TLS p
tls forall b. Request -> (Response -> IO b) -> IO b
sendReq Aux
_aux = do
      UTCTime
sessionTs <- IO UTCTime
getCurrentTime
      let c' :: HTTP2Client
c' =
            HTTP2Client
              { $sel:action:HTTP2Client :: Maybe (Async HTTP2Response)
action = Maybe (Async HTTP2Response)
forall a. Maybe a
Nothing,
                $sel:client_:HTTP2Client :: HClient
client_ = HClient
c,
                $sel:serverKey:HTTP2Client :: Maybe APublicVerifyKey
serverKey = case forall (p :: TransportPeer). TransportPeerI p => STransportPeer p
sTransportPeer @p of
                  STransportPeer p
STClient -> Either ServiceName APublicVerifyKey -> Maybe APublicVerifyKey
forall a b. Either a b -> Maybe b
eitherToMaybe (Either ServiceName APublicVerifyKey -> Maybe APublicVerifyKey)
-> Either ServiceName APublicVerifyKey -> Maybe APublicVerifyKey
forall a b. (a -> b) -> a -> b
$ TLS 'TClient -> Either ServiceName APublicVerifyKey
forall (c :: TransportPeer -> *).
Transport c =>
c 'TClient -> Either ServiceName APublicVerifyKey
getServerVerifyKey TLS p
TLS 'TClient
tls
                  STransportPeer p
STServer -> Maybe APublicVerifyKey
forall a. Maybe a
Nothing,
                $sel:serverCerts:HTTP2Client :: CertificateChain
serverCerts = TLS p -> CertificateChain
forall (p :: TransportPeer). TLS p -> CertificateChain
tlsPeerCert TLS p
tls,
                Request -> (Response -> IO HTTP2Response) -> IO HTTP2Response
forall b. Request -> (Response -> IO b) -> IO b
$sel:sendReq:HTTP2Client :: Request -> (Response -> IO HTTP2Response) -> IO HTTP2Response
sendReq :: forall b. Request -> (Response -> IO b) -> IO b
sendReq,
                UTCTime
$sel:sessionTs:HTTP2Client :: UTCTime
sessionTs :: UTCTime
sessionTs,
                $sel:sessionId:HTTP2Client :: SessionId
sessionId = TLS p -> SessionId
forall (p :: TransportPeer). TLS p -> SessionId
tlsUniq TLS p
tls,
                $sel:sessionALPN:HTTP2Client :: Maybe SessionId
sessionALPN = TLS p -> Maybe SessionId
forall (p :: TransportPeer). TLS p -> Maybe SessionId
tlsALPN TLS p
tls
              }
      STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (HClient -> TVar Bool
connected HClient
c) Bool
True
        TMVar (Either HTTP2ClientError HTTP2Client)
-> Either HTTP2ClientError HTTP2Client -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Either HTTP2ClientError HTTP2Client)
cVar (HTTP2Client -> Either HTTP2ClientError HTTP2Client
forall a b. b -> Either a b
Right HTTP2Client
c')
      HTTP2Client -> Client HTTP2Response
process HTTP2Client
c' Request -> (Response -> IO b) -> IO b
forall b. Request -> (Response -> IO b) -> IO b
sendReq Aux
_aux IO HTTP2Response -> IO () -> IO HTTP2Response
forall a b. IO a -> IO b -> IO a
`E.finally` IO ()
disconnected

    process :: HTTP2Client -> H.Client HTTP2Response
    process :: HTTP2Client -> Client HTTP2Response
process HTTP2Client {$sel:client_:HTTP2Client :: HTTP2Client -> HClient
client_ = HClient {TBQueue (Request, TMVar HTTP2Response)
$sel:reqQ:HClient :: HClient -> TBQueue (Request, TMVar HTTP2Response)
reqQ :: TBQueue (Request, TMVar HTTP2Response)
reqQ}} forall b. Request -> (Response -> IO b) -> IO b
sendReq Aux
_aux = IO HTTP2Response -> IO HTTP2Response
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO HTTP2Response -> IO HTTP2Response)
-> IO HTTP2Response -> IO HTTP2Response
forall a b. (a -> b) -> a -> b
$ do
      (Request
req, TMVar HTTP2Response
respVar) <- STM (Request, TMVar HTTP2Response)
-> IO (Request, TMVar HTTP2Response)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Request, TMVar HTTP2Response)
 -> IO (Request, TMVar HTTP2Response))
-> STM (Request, TMVar HTTP2Response)
-> IO (Request, TMVar HTTP2Response)
forall a b. (a -> b) -> a -> b
$ TBQueue (Request, TMVar HTTP2Response)
-> STM (Request, TMVar HTTP2Response)
forall a. TBQueue a -> STM a
readTBQueue TBQueue (Request, TMVar HTTP2Response)
reqQ
      Request -> (Response -> IO HTTP2Response) -> IO HTTP2Response
forall b. Request -> (Response -> IO b) -> IO b
sendReq Request
req ((Response -> IO HTTP2Response) -> IO HTTP2Response)
-> (Response -> IO HTTP2Response) -> IO HTTP2Response
forall a b. (a -> b) -> a -> b
$ \Response
r -> do
        HTTP2Body
respBody <- Response -> Int -> IO HTTP2Body
forall a. HTTP2BodyChunk a => a -> Int -> IO HTTP2Body
getHTTP2Body Response
r (HTTP2ClientConfig -> Int
bodyHeadSize HTTP2ClientConfig
config)
        let resp :: HTTP2Response
resp = HTTP2Response {$sel:response:HTTP2Response :: Response
response = Response
r, HTTP2Body
$sel:respBody:HTTP2Response :: HTTP2Body
respBody :: HTTP2Body
respBody}
        STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar HTTP2Response -> HTTP2Response -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar HTTP2Response
respVar HTTP2Response
resp
        HTTP2Response -> IO HTTP2Response
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HTTP2Response
resp

-- | Disconnects client from the server and terminates client threads.
closeHTTP2Client :: HTTP2Client -> IO ()
closeHTTP2Client :: HTTP2Client -> IO ()
closeHTTP2Client = (Async HTTP2Response -> IO ())
-> Maybe (Async HTTP2Response) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Async HTTP2Response -> IO ()
forall a. Async a -> IO ()
uninterruptibleCancel (Maybe (Async HTTP2Response) -> IO ())
-> (HTTP2Client -> Maybe (Async HTTP2Response))
-> HTTP2Client
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HTTP2Client -> Maybe (Async HTTP2Response)
action

sendRequest :: HTTP2Client -> Request -> Maybe Int -> IO (Either HTTP2ClientError HTTP2Response)
sendRequest :: HTTP2Client
-> Request
-> Maybe Int
-> IO (Either HTTP2ClientError HTTP2Response)
sendRequest HTTP2Client {$sel:client_:HTTP2Client :: HTTP2Client -> HClient
client_ = HClient {HTTP2ClientConfig
$sel:config:HClient :: HClient -> HTTP2ClientConfig
config :: HTTP2ClientConfig
config, TBQueue (Request, TMVar HTTP2Response)
$sel:reqQ:HClient :: HClient -> TBQueue (Request, TMVar HTTP2Response)
reqQ :: TBQueue (Request, TMVar HTTP2Response)
reqQ}} Request
req Maybe Int
reqTimeout_ = do
  TMVar HTTP2Response
resp <- IO (TMVar HTTP2Response)
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
  STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TBQueue (Request, TMVar HTTP2Response)
-> (Request, TMVar HTTP2Response) -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue (Request, TMVar HTTP2Response)
reqQ (Request
req, TMVar HTTP2Response
resp)
  let reqTimeout :: Int
reqTimeout = HTTP2ClientConfig -> Maybe Int -> Int
http2RequestTimeout HTTP2ClientConfig
config Maybe Int
reqTimeout_
  Either HTTP2ClientError HTTP2Response
-> (HTTP2Response -> Either HTTP2ClientError HTTP2Response)
-> Maybe HTTP2Response
-> Either HTTP2ClientError HTTP2Response
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (HTTP2ClientError -> Either HTTP2ClientError HTTP2Response
forall a b. a -> Either a b
Left HTTP2ClientError
HCResponseTimeout) HTTP2Response -> Either HTTP2ClientError HTTP2Response
forall a b. b -> Either a b
Right (Maybe HTTP2Response -> Either HTTP2ClientError HTTP2Response)
-> IO (Maybe HTTP2Response)
-> IO (Either HTTP2ClientError HTTP2Response)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int
reqTimeout Int -> IO HTTP2Response -> IO (Maybe HTTP2Response)
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
`timeout` STM HTTP2Response -> IO HTTP2Response
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TMVar HTTP2Response -> STM HTTP2Response
forall a. TMVar a -> STM a
takeTMVar TMVar HTTP2Response
resp))

-- | this function should not be used until HTTP2 is thread safe, use sendRequest
sendRequestDirect :: HTTP2Client -> Request -> Maybe Int -> IO (Either HTTP2ClientError HTTP2Response)
sendRequestDirect :: HTTP2Client
-> Request
-> Maybe Int
-> IO (Either HTTP2ClientError HTTP2Response)
sendRequestDirect HTTP2Client {$sel:client_:HTTP2Client :: HTTP2Client -> HClient
client_ = HClient {HTTP2ClientConfig
$sel:config:HClient :: HClient -> HTTP2ClientConfig
config :: HTTP2ClientConfig
config, IO ()
$sel:disconnected:HClient :: HClient -> IO ()
disconnected :: IO ()
disconnected}, Request -> (Response -> IO HTTP2Response) -> IO HTTP2Response
$sel:sendReq:HTTP2Client :: HTTP2Client
-> Request -> (Response -> IO HTTP2Response) -> IO HTTP2Response
sendReq :: Request -> (Response -> IO HTTP2Response) -> IO HTTP2Response
sendReq} Request
req Maybe Int
reqTimeout_ = do
  let reqTimeout :: Int
reqTimeout = HTTP2ClientConfig -> Maybe Int -> Int
http2RequestTimeout HTTP2ClientConfig
config Maybe Int
reqTimeout_
  Int
reqTimeout Int
-> IO (Either IOException HTTP2Response)
-> IO (Maybe (Either IOException HTTP2Response))
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
`timeout` IO HTTP2Response -> IO (Either IOException HTTP2Response)
forall e a. Exception e => IO a -> IO (Either e a)
try (Request -> (Response -> IO HTTP2Response) -> IO HTTP2Response
sendReq Request
req Response -> IO HTTP2Response
process) IO (Maybe (Either IOException HTTP2Response))
-> (Maybe (Either IOException HTTP2Response)
    -> IO (Either HTTP2ClientError HTTP2Response))
-> IO (Either HTTP2ClientError HTTP2Response)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just (Right HTTP2Response
r) -> Either HTTP2ClientError HTTP2Response
-> IO (Either HTTP2ClientError HTTP2Response)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either HTTP2ClientError HTTP2Response
 -> IO (Either HTTP2ClientError HTTP2Response))
-> Either HTTP2ClientError HTTP2Response
-> IO (Either HTTP2ClientError HTTP2Response)
forall a b. (a -> b) -> a -> b
$ HTTP2Response -> Either HTTP2ClientError HTTP2Response
forall a b. b -> Either a b
Right HTTP2Response
r
    Just (Left IOException
e) -> IO ()
disconnected IO ()
-> Either HTTP2ClientError HTTP2Response
-> IO (Either HTTP2ClientError HTTP2Response)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> HTTP2ClientError -> Either HTTP2ClientError HTTP2Response
forall a b. a -> Either a b
Left (IOException -> HTTP2ClientError
HCIOError IOException
e)
    Maybe (Either IOException HTTP2Response)
Nothing -> Either HTTP2ClientError HTTP2Response
-> IO (Either HTTP2ClientError HTTP2Response)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either HTTP2ClientError HTTP2Response
 -> IO (Either HTTP2ClientError HTTP2Response))
-> Either HTTP2ClientError HTTP2Response
-> IO (Either HTTP2ClientError HTTP2Response)
forall a b. (a -> b) -> a -> b
$ HTTP2ClientError -> Either HTTP2ClientError HTTP2Response
forall a b. a -> Either a b
Left HTTP2ClientError
HCResponseTimeout
  where
    process :: Response -> IO HTTP2Response
process Response
r = do
      HTTP2Body
respBody <- Response -> Int -> IO HTTP2Body
forall a. HTTP2BodyChunk a => a -> Int -> IO HTTP2Body
getHTTP2Body Response
r (Int -> IO HTTP2Body) -> Int -> IO HTTP2Body
forall a b. (a -> b) -> a -> b
$ HTTP2ClientConfig -> Int
bodyHeadSize HTTP2ClientConfig
config
      HTTP2Response -> IO HTTP2Response
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HTTP2Response {$sel:response:HTTP2Response :: Response
response = Response
r, HTTP2Body
$sel:respBody:HTTP2Response :: HTTP2Body
respBody :: HTTP2Body
respBody}

http2RequestTimeout :: HTTP2ClientConfig -> Maybe Int -> Int
http2RequestTimeout :: HTTP2ClientConfig -> Maybe Int -> Int
http2RequestTimeout HTTP2ClientConfig {Int
$sel:connTimeout:HTTP2ClientConfig :: HTTP2ClientConfig -> Int
connTimeout :: Int
connTimeout} = Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
connTimeout (Int
connTimeout Int -> Int -> Int
forall a. Num a => a -> a -> a
+)

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 :: forall a.
Supported
-> Maybe CertificateStore
-> TransportClientConfig
-> Int
-> Maybe SocksCredentials
-> TransportHost
-> ServiceName
-> Maybe KeyHash
-> (TLS 'TClient -> Client a)
-> IO a
runHTTP2Client Supported
tlsParams Maybe CertificateStore
caStore TransportClientConfig
tcConfig Int
bufferSize Maybe SocksCredentials
socksCreds TransportHost
host ServiceName
port Maybe KeyHash
keyHash = Int
-> TransportHost
-> ((TLS 'TClient -> IO a) -> IO a)
-> (TLS 'TClient -> Client a)
-> IO a
forall a (p :: TransportPeer).
Int
-> TransportHost
-> ((TLS p -> IO a) -> IO a)
-> (TLS p -> Client a)
-> IO a
runHTTP2ClientWith Int
bufferSize TransportHost
host (TLS 'TClient -> IO a) -> IO a
setup
  where
    setup :: (TLS 'TClient -> IO a) -> IO a
    setup :: (TLS 'TClient -> IO a) -> IO a
setup = Supported
-> Maybe CertificateStore
-> TransportClientConfig
-> Maybe SocksCredentials
-> TransportHost
-> ServiceName
-> Maybe KeyHash
-> (TLS 'TClient -> IO a)
-> IO a
forall (c :: TransportPeer -> *) a.
Transport c =>
Supported
-> Maybe CertificateStore
-> TransportClientConfig
-> Maybe SocksCredentials
-> TransportHost
-> ServiceName
-> Maybe KeyHash
-> (c 'TClient -> IO a)
-> IO a
runTLSTransportClient Supported
tlsParams Maybe CertificateStore
caStore TransportClientConfig
tcConfig Maybe SocksCredentials
socksCreds TransportHost
host ServiceName
port Maybe KeyHash
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 :: forall a (p :: TransportPeer).
Int
-> TransportHost
-> ((TLS p -> IO a) -> IO a)
-> (TLS p -> Client a)
-> IO a
runHTTP2ClientWith Int
bufferSize TransportHost
host (TLS p -> IO a) -> IO a
setup TLS p -> Client a
client = (TLS p -> IO a) -> IO a
setup ((TLS p -> IO a) -> IO a) -> (TLS p -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \TLS p
tls -> Int -> (Config -> IO a) -> IO () -> TLS p -> IO a
forall a (p :: TransportPeer).
Int -> (Config -> IO a) -> IO () -> TLS p -> IO a
withHTTP2 Int
bufferSize (TLS p -> Config -> IO a
run TLS p
tls) (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) TLS p
tls
  where
    run :: TLS p -> H.Config -> IO a
    cliconf :: ClientConfig
cliconf = ClientConfig
H.defaultClientConfig {scheme = "https", authority = (strEncode host)}
    run :: TLS p -> Config -> IO a
run TLS p
tls Config
cfg = ClientConfig -> Config -> Client a -> IO a
forall a. ClientConfig -> Config -> Client a -> IO a
H.run ClientConfig
cliconf Config
cfg (Client a -> IO a) -> Client a -> IO a
forall a b. (a -> b) -> a -> b
$ TLS p -> Client a
client TLS p
tls