{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}

-- | Running an HTTP\/2 client over TLS.
module Network.HTTP2.TLS.Client (
    -- * Runners
    run,
    runH2C,
    Client,
    HostName,
    Authority,
    PortNumber,
    runTLS,

    -- ** Generalized API
    ClientConfig,
    defaultClientConfig,
    defaultAuthority,
    runWithConfig,
    runH2CWithConfig,
    runTLSWithConfig,

    -- * Settings
    Settings,
    defaultSettings,
    settingsKeyLogger,
    settingsValidateCert,
    settingsCAStore,
    settingsAddrInfoFlags,
    settingsCacheLimit,
    settingsConcurrentStreams,
    settingsConnectionWindowSize,
    settingsStreamWindowSize,
    settingsServerNameOverride,
    settingsSessionManager,
    settingsWantSessionResume,
    settingsUseEarlyData,
) where

import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS.C8
import Data.Default.Class (def)
import Data.Maybe (fromMaybe)
import Data.X509.Validation (validateDefault)
import Network.HTTP2.Client (Authority, Client, ClientConfig)
import qualified Network.HTTP2.Client as H2Client
import Network.Socket
import Network.TLS hiding (HostName)
import qualified UnliftIO.Exception as E
import Network.Run.TCP

import Network.HTTP2.TLS.Client.Settings
import Network.HTTP2.TLS.Config
import Network.HTTP2.TLS.IO
import qualified Network.HTTP2.TLS.Server.Settings as Server
import Network.HTTP2.TLS.Supported

----------------------------------------------------------------
-- Default API

run :: Settings -> HostName -> PortNumber -> Client a -> IO a
run :: forall a. Settings -> HostName -> PortNumber -> Client a -> IO a
run Settings
settings HostName
serverName PortNumber
port Client a
client =
    ClientConfig
-> Settings -> HostName -> PortNumber -> Client a -> IO a
forall a.
ClientConfig
-> Settings -> HostName -> PortNumber -> Client a -> IO a
runWithConfig
        (Settings -> HostName -> ClientConfig
defaultClientConfig Settings
settings (HostName -> ClientConfig) -> HostName -> ClientConfig
forall a b. (a -> b) -> a -> b
$ HostName -> HostName
defaultAuthority HostName
serverName)
        Settings
settings
        HostName
serverName
        PortNumber
port
        Client a
client

runTLS
    :: Settings
    -> HostName
    -> PortNumber
    -> ByteString
    -- ^ ALPN
    -> (Context -> SockAddr -> SockAddr -> IO a)
    -> IO a
runTLS :: forall a.
Settings
-> HostName
-> PortNumber
-> Scheme
-> (Context -> SockAddr -> SockAddr -> IO a)
-> IO a
runTLS Settings
settings HostName
serverName PortNumber
port Scheme
alpn Context -> SockAddr -> SockAddr -> IO a
action =
    ClientConfig
-> Settings
-> HostName
-> PortNumber
-> Scheme
-> (Context -> SockAddr -> SockAddr -> IO a)
-> IO a
forall a.
ClientConfig
-> Settings
-> HostName
-> PortNumber
-> Scheme
-> (Context -> SockAddr -> SockAddr -> IO a)
-> IO a
runTLSWithConfig
        (Settings -> HostName -> ClientConfig
defaultClientConfig Settings
settings (HostName -> ClientConfig) -> HostName -> ClientConfig
forall a b. (a -> b) -> a -> b
$ HostName -> HostName
defaultAuthority HostName
serverName)
        Settings
settings
        HostName
serverName
        PortNumber
port
        Scheme
alpn
        Context -> SockAddr -> SockAddr -> IO a
action

runH2C :: Settings -> HostName -> PortNumber -> Client a -> IO a
runH2C :: forall a. Settings -> HostName -> PortNumber -> Client a -> IO a
runH2C Settings
settings HostName
serverName PortNumber
port Client a
client =
    ClientConfig -> HostName -> PortNumber -> Client a -> IO a
forall a.
ClientConfig -> HostName -> PortNumber -> Client a -> IO a
runH2CWithConfig
        (Settings -> HostName -> ClientConfig
defaultClientConfig Settings
settings (HostName -> ClientConfig) -> HostName -> ClientConfig
forall a b. (a -> b) -> a -> b
$ HostName -> HostName
defaultAuthority HostName
serverName)
        HostName
serverName
        PortNumber
port
        Client a
client

----------------------------------------------------------------
-- Generalized API

-- | Running a TLS client.
runTLSWithConfig
    :: ClientConfig
    -> Settings
    -> HostName
    -> PortNumber
    -> ByteString
    -- ^ ALPN
    -> (Context -> SockAddr -> SockAddr -> IO a)
    -> IO a
runTLSWithConfig :: forall a.
ClientConfig
-> Settings
-> HostName
-> PortNumber
-> Scheme
-> (Context -> SockAddr -> SockAddr -> IO a)
-> IO a
runTLSWithConfig ClientConfig
cliconf Settings
settings HostName
serverName PortNumber
port Scheme
alpn Context -> SockAddr -> SockAddr -> IO a
action =
    HostName -> HostName -> (Socket -> IO a) -> IO a
forall a. HostName -> HostName -> (Socket -> IO a) -> IO a
runTCPClient HostName
serverName (PortNumber -> HostName
forall a. Show a => a -> HostName
show PortNumber
port) ((Socket -> IO a) -> IO a) -> (Socket -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Socket
sock -> do
        SockAddr
mysa <- Socket -> IO SockAddr
getSocketName Socket
sock
        SockAddr
peersa <- Socket -> IO SockAddr
getPeerName Socket
sock
        IO Context -> (Context -> IO ()) -> (Context -> IO a) -> IO a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracket (Socket -> ClientParams -> IO Context
forall (m :: * -> *) backend params.
(MonadIO m, HasBackend backend, TLSParams params) =>
backend -> params -> m Context
contextNew Socket
sock ClientParams
params) Context -> IO ()
forall (m :: * -> *). MonadIO m => Context -> m ()
bye ((Context -> IO a) -> IO a) -> (Context -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Context
ctx -> do
            Context -> IO ()
forall (m :: * -> *). MonadIO m => Context -> m ()
handshake Context
ctx
            Context -> SockAddr -> SockAddr -> IO a
action Context
ctx SockAddr
mysa SockAddr
peersa
  where
    -- TLS client parameters
    params :: ClientParams
    params :: ClientParams
params =
        Settings -> HostName -> PortNumber -> Scheme -> ClientParams
getClientParams
            Settings
settings
            ( HostName -> Maybe HostName -> HostName
forall a. a -> Maybe a -> a
fromMaybe (ClientConfig -> HostName
H2Client.authority ClientConfig
cliconf) (Maybe HostName -> HostName) -> Maybe HostName -> HostName
forall a b. (a -> b) -> a -> b
$
                Settings -> Maybe HostName
settingsServerNameOverride Settings
settings
            )
            PortNumber
port
            Scheme
alpn

-- | Running an HTTP\/2 client over TLS (over TCP).
runWithConfig
    :: ClientConfig -> Settings -> HostName -> PortNumber -> Client a -> IO a
runWithConfig :: forall a.
ClientConfig
-> Settings -> HostName -> PortNumber -> Client a -> IO a
runWithConfig ClientConfig
cliconf Settings
settings HostName
serverName PortNumber
port Client a
client =
    ClientConfig
-> Settings
-> HostName
-> PortNumber
-> Scheme
-> (Context -> SockAddr -> SockAddr -> IO a)
-> IO a
forall a.
ClientConfig
-> Settings
-> HostName
-> PortNumber
-> Scheme
-> (Context -> SockAddr -> SockAddr -> IO a)
-> IO a
runTLSWithConfig ClientConfig
cliconf Settings
settings HostName
serverName PortNumber
port Scheme
"h2" ((Context -> SockAddr -> SockAddr -> IO a) -> IO a)
-> (Context -> SockAddr -> SockAddr -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Context
ctx SockAddr
mysa SockAddr
peersa ->
        ClientConfig
-> (Scheme -> IO ())
-> IO Scheme
-> SockAddr
-> SockAddr
-> Client a
-> IO a
forall a.
ClientConfig
-> (Scheme -> IO ())
-> IO Scheme
-> SockAddr
-> SockAddr
-> Client a
-> IO a
run' ClientConfig
cliconf' (Context -> Scheme -> IO ()
sendTLS Context
ctx) (Context -> IO Scheme
recvTLS Context
ctx) SockAddr
mysa SockAddr
peersa Client a
client
  where
    cliconf' :: ClientConfig
    cliconf' :: ClientConfig
cliconf' = ClientConfig
cliconf{H2Client.scheme = "https"}

-- | Running an HTTP\/2 client over TCP.
runH2CWithConfig :: ClientConfig -> HostName -> PortNumber -> Client a -> IO a
runH2CWithConfig :: forall a.
ClientConfig -> HostName -> PortNumber -> Client a -> IO a
runH2CWithConfig ClientConfig
cliconf HostName
serverName PortNumber
port Client a
client =
    HostName -> HostName -> (Socket -> IO a) -> IO a
forall a. HostName -> HostName -> (Socket -> IO a) -> IO a
runTCPClient HostName
serverName (PortNumber -> HostName
forall a. Show a => a -> HostName
show PortNumber
port) ((Socket -> IO a) -> IO a) -> (Socket -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Socket
sock -> do
        SockAddr
mysa <- Socket -> IO SockAddr
getSocketName Socket
sock
        SockAddr
peersa <- Socket -> IO SockAddr
getPeerName Socket
sock
        IO Scheme
recv <- Settings -> Socket -> IO (IO Scheme)
mkRecvTCP Settings
Server.defaultSettings Socket
sock
        ClientConfig
-> (Scheme -> IO ())
-> IO Scheme
-> SockAddr
-> SockAddr
-> Client a
-> IO a
forall a.
ClientConfig
-> (Scheme -> IO ())
-> IO Scheme
-> SockAddr
-> SockAddr
-> Client a
-> IO a
run' ClientConfig
cliconf' (Socket -> Scheme -> IO ()
sendTCP Socket
sock) IO Scheme
recv SockAddr
mysa SockAddr
peersa Client a
client
  where
    cliconf' :: ClientConfig
    cliconf' :: ClientConfig
cliconf' = ClientConfig
cliconf{H2Client.scheme = "http"}

run'
    :: ClientConfig
    -> (ByteString -> IO ())
    -> IO ByteString
    -> SockAddr
    -> SockAddr
    -> Client a
    -> IO a
run' :: forall a.
ClientConfig
-> (Scheme -> IO ())
-> IO Scheme
-> SockAddr
-> SockAddr
-> Client a
-> IO a
run' ClientConfig
cliconf Scheme -> IO ()
send IO Scheme
recv SockAddr
mysa SockAddr
peersa Client a
client =
    IO Config -> (Config -> IO ()) -> (Config -> IO a) -> IO a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracket
        ((Scheme -> IO ()) -> IO Scheme -> SockAddr -> SockAddr -> IO Config
allocConfigForClient Scheme -> IO ()
send IO Scheme
recv SockAddr
mysa SockAddr
peersa)
        Config -> IO ()
freeConfigForClient
        (\Config
conf -> ClientConfig -> Config -> Client a -> IO a
forall a. ClientConfig -> Config -> Client a -> IO a
H2Client.run ClientConfig
cliconf Config
conf Client a
client)

defaultClientConfig
    :: Settings
    -> Authority
    -> ClientConfig
defaultClientConfig :: Settings -> HostName -> ClientConfig
defaultClientConfig Settings{Bool
Int
[AddrInfoFlag]
Maybe HostName
Maybe (Scheme, SessionData)
CertificateStore
SessionManager
HostName -> IO ()
settingsKeyLogger :: Settings -> HostName -> IO ()
settingsValidateCert :: Settings -> Bool
settingsCAStore :: Settings -> CertificateStore
settingsAddrInfoFlags :: Settings -> [AddrInfoFlag]
settingsCacheLimit :: Settings -> Int
settingsConcurrentStreams :: Settings -> Int
settingsConnectionWindowSize :: Settings -> Int
settingsStreamWindowSize :: Settings -> Int
settingsServerNameOverride :: Settings -> Maybe HostName
settingsSessionManager :: Settings -> SessionManager
settingsWantSessionResume :: Settings -> Maybe (Scheme, SessionData)
settingsUseEarlyData :: Settings -> Bool
settingsKeyLogger :: HostName -> IO ()
settingsValidateCert :: Bool
settingsCAStore :: CertificateStore
settingsServerNameOverride :: Maybe HostName
settingsAddrInfoFlags :: [AddrInfoFlag]
settingsCacheLimit :: Int
settingsConcurrentStreams :: Int
settingsStreamWindowSize :: Int
settingsConnectionWindowSize :: Int
settingsSessionManager :: SessionManager
settingsWantSessionResume :: Maybe (Scheme, SessionData)
settingsUseEarlyData :: Bool
..} HostName
auth =
    ClientConfig
H2Client.defaultClientConfig
        { H2Client.scheme = "https"
        , H2Client.authority = auth
        , H2Client.cacheLimit = settingsCacheLimit
        , H2Client.connectionWindowSize = settingsConnectionWindowSize
        , H2Client.settings =
            (H2Client.settings $ H2Client.defaultClientConfig)
                { H2Client.initialWindowSize = settingsStreamWindowSize
                , H2Client.maxConcurrentStreams = Just settingsConcurrentStreams
                }
        }

-- | Default authority
--
-- When we connect to a server, we can distinguish between three names, all of
-- which may be different:
--
-- 1. The 'HostName', used for the DNS lookup to get the server's IP
-- 2. The HTTP2 @:authority@ pseudo-header
-- 3. The TLS SNI (Server Name Indicator).
--    This is different from (2) only in exceptional circumstances, see
--    'settingsServerNameOverride'.
--
-- In /most/ cases, however, all three names are identical, and so the default
-- 'Authority' is simply equal to the 'ServerName'.
defaultAuthority :: HostName -> Authority
defaultAuthority :: HostName -> HostName
defaultAuthority = HostName -> HostName
forall a. a -> a
id

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

getClientParams
    :: Settings
    -> HostName
    -- ^ Server name (for TLS SNI)
    -> PortNumber
    -- ^ Port number
    -- This is not used for validation, but improves caching; see documentation of
    -- [ServiceID](https://hackage.haskell.org/package/x509-validation-1.6.12/docs/Data-X509-Validation.html#t:ServiceID).
    -> ByteString
    -- ^ ALPN
    -> ClientParams
getClientParams :: Settings -> HostName -> PortNumber -> Scheme -> ClientParams
getClientParams Settings{Bool
Int
[AddrInfoFlag]
Maybe HostName
Maybe (Scheme, SessionData)
CertificateStore
SessionManager
HostName -> IO ()
settingsKeyLogger :: Settings -> HostName -> IO ()
settingsValidateCert :: Settings -> Bool
settingsCAStore :: Settings -> CertificateStore
settingsAddrInfoFlags :: Settings -> [AddrInfoFlag]
settingsCacheLimit :: Settings -> Int
settingsConcurrentStreams :: Settings -> Int
settingsConnectionWindowSize :: Settings -> Int
settingsStreamWindowSize :: Settings -> Int
settingsServerNameOverride :: Settings -> Maybe HostName
settingsSessionManager :: Settings -> SessionManager
settingsWantSessionResume :: Settings -> Maybe (Scheme, SessionData)
settingsUseEarlyData :: Settings -> Bool
settingsKeyLogger :: HostName -> IO ()
settingsValidateCert :: Bool
settingsCAStore :: CertificateStore
settingsServerNameOverride :: Maybe HostName
settingsAddrInfoFlags :: [AddrInfoFlag]
settingsCacheLimit :: Int
settingsConcurrentStreams :: Int
settingsStreamWindowSize :: Int
settingsConnectionWindowSize :: Int
settingsSessionManager :: SessionManager
settingsWantSessionResume :: Maybe (Scheme, SessionData)
settingsUseEarlyData :: Bool
..} HostName
serverName PortNumber
port Scheme
alpn =
    -- RFC 4366 mandates UTF-8 for SNI
    -- <https://datatracker.ietf.org/doc/html/rfc4366#section-3.1>
    (HostName -> Scheme -> ClientParams
defaultParamsClient HostName
serverName (HostName -> Scheme
BS.C8.pack (HostName -> Scheme) -> HostName -> Scheme
forall a b. (a -> b) -> a -> b
$ PortNumber -> HostName
forall a. Show a => a -> HostName
show PortNumber
port))
        { clientSupported = supported
        , clientWantSessionResume = settingsWantSessionResume
        , clientUseServerNameIndication = True
        , clientShared = shared
        , clientHooks = hooks
        , clientDebug = debug
#if MIN_VERSION_tls(2,0,0)
        , clientUseEarlyData = settingsUseEarlyData
#else
        , clientEarlyData = Nothing
#endif

        }
  where
    shared :: Shared
shared =
        Shared
forall a. Default a => a
def
            { sharedValidationCache = validateCache
            , sharedCAStore = settingsCAStore
            , sharedSessionManager = settingsSessionManager
            }
    supported :: Supported
supported = Supported
strongSupported
    hooks :: ClientHooks
hooks =
        ClientHooks
forall a. Default a => a
def
            { onSuggestALPN = return $ Just [alpn]
            , onServerCertificate = validateCert
            }
    validateCache :: ValidationCache
validateCache
        | Bool
settingsValidateCert = ValidationCache
forall a. Default a => a
def
        | Bool
otherwise =
            ValidationCacheQueryCallback
-> ValidationCacheAddCallback -> ValidationCache
ValidationCache
                (\ServiceID
_ Fingerprint
_ Certificate
_ -> ValidationCacheResult -> IO ValidationCacheResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ValidationCacheResult
ValidationCachePass)
                (\ServiceID
_ Fingerprint
_ Certificate
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
    validateCert :: CertificateStore
-> ValidationCache
-> ServiceID
-> CertificateChain
-> IO [FailedReason]
validateCert
        | Bool
settingsValidateCert = CertificateStore
-> ValidationCache
-> ServiceID
-> CertificateChain
-> IO [FailedReason]
validateDefault
        | Bool
otherwise = \CertificateStore
_ ValidationCache
_ ServiceID
_ CertificateChain
_ -> [FailedReason] -> IO [FailedReason]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    debug :: DebugParams
debug =
        DebugParams
forall a. Default a => a
def
            { debugKeyLogger = settingsKeyLogger
            }