{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
module Network.HTTP2.TLS.Client (
run,
runH2C,
Client,
HostName,
Authority,
PortNumber,
runTLS,
ClientConfig,
defaultClientConfig,
defaultAuthority,
runWithConfig,
runH2CWithConfig,
runTLSWithConfig,
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.HTTP2.TLS.Client.Settings
import Network.HTTP2.TLS.Config
import Network.HTTP2.TLS.IO
import Network.HTTP2.TLS.Internal (gclose)
import qualified Network.HTTP2.TLS.Server.Settings as Server
import Network.HTTP2.TLS.Supported
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
-> (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
runTLSWithConfig
:: ClientConfig
-> Settings
-> HostName
-> PortNumber
-> ByteString
-> (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 =
IO Socket -> (Socket -> IO ()) -> (Socket -> IO a) -> IO a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracket IO Socket
open Socket -> IO ()
gclose ((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
open :: IO Socket
open :: IO Socket
open = [AddrInfoFlag] -> HostName -> PortNumber -> IO Socket
openTCP (Settings -> [AddrInfoFlag]
settingsAddrInfoFlags Settings
settings) HostName
serverName PortNumber
port
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
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"}
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 =
IO Socket -> (Socket -> IO ()) -> (Socket -> IO a) -> IO a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracket IO Socket
open Socket -> IO ()
close ((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
open :: IO Socket
open = [AddrInfoFlag] -> HostName -> PortNumber -> IO Socket
openTCP (Settings -> [AddrInfoFlag]
settingsAddrInfoFlags Settings
defaultSettings) HostName
serverName PortNumber
port
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
}
}
defaultAuthority :: HostName -> Authority
defaultAuthority :: HostName -> HostName
defaultAuthority = HostName -> HostName
forall a. a -> a
id
openTCP :: [AddrInfoFlag] -> HostName -> PortNumber -> IO Socket
openTCP :: [AddrInfoFlag] -> HostName -> PortNumber -> IO Socket
openTCP [AddrInfoFlag]
flags HostName
h PortNumber
p = do
AddrInfo
ai <- [AddrInfoFlag] -> HostName -> PortNumber -> IO AddrInfo
makeAddrInfo [AddrInfoFlag]
flags HostName
h PortNumber
p
Socket
sock <- AddrInfo -> IO Socket
openSocket AddrInfo
ai
Socket -> SockAddr -> IO ()
connect Socket
sock (SockAddr -> IO ()) -> SockAddr -> IO ()
forall a b. (a -> b) -> a -> b
$ AddrInfo -> SockAddr
addrAddress AddrInfo
ai
Socket -> IO Socket
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock
makeAddrInfo :: [AddrInfoFlag] -> HostName -> PortNumber -> IO AddrInfo
makeAddrInfo :: [AddrInfoFlag] -> HostName -> PortNumber -> IO AddrInfo
makeAddrInfo [AddrInfoFlag]
flags HostName
nh PortNumber
p = do
let hints :: AddrInfo
hints =
AddrInfo
defaultHints
{ addrFlags = flags
, addrSocketType = Stream
}
let np :: HostName
np = PortNumber -> HostName
forall a. Show a => a -> HostName
show PortNumber
p
[AddrInfo] -> AddrInfo
forall a. HasCallStack => [a] -> a
head ([AddrInfo] -> AddrInfo) -> IO [AddrInfo] -> IO AddrInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe AddrInfo -> Maybe HostName -> Maybe HostName -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) (HostName -> Maybe HostName
forall a. a -> Maybe a
Just HostName
nh) (HostName -> Maybe HostName
forall a. a -> Maybe a
Just HostName
np)
getClientParams
:: Settings
-> HostName
-> PortNumber
-> ByteString
-> 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 =
(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
}