-- | Make HTTPS connections using
-- [http-client](https://hackage.haskell.org/package/http-client) and
-- [Rustls](https://github.com/rustls/rustls).
--
-- >>> import qualified Rustls
-- >>> import qualified Network.HTTP.Client as HTTP
-- >>> :{
-- newRustlsManager :: IO HTTP.Manager
-- newRustlsManager = do
--   clientConfig <-
--     Rustls.buildClientConfig $
--       Rustls.defaultClientConfigBuilder serverCertVerifier
--   HTTP.newManager $ rustlsManagerSettings clientConfig
--   where
--     -- For now, rustls-ffi does not provide a built-in way to access
--     -- the OS certificate store.
--     serverCertVerifier =
--       Rustls.ServerCertVerifier
--         { Rustls.serverCertVerifierCertificates =
--             pure $
--               Rustls.PemCertificatesFromFile
--                 "/etc/ssl/certs/ca-certificates.crt"
--                 Rustls.PEMCertificateParsingStrict,
--           Rustls.serverCertVerifierCRLs = []
--         }
-- >>> :}
--
-- >>> :{
-- example = do
--   mgr <- newRustlsManager -- this should be shared across multiple requests
--   req <- HTTP.parseUrlThrow "https://example.org"
--   res <- HTTP.httpLbs req mgr
--   print $ HTTP.responseBody res
-- :}
module Network.HTTP.Client.Rustls
  ( rustlsManagerSettings,
  )
where

import Control.Exception qualified as E
import Data.Acquire (ReleaseType (..))
import Data.Acquire.Internal (Acquire (..), Allocated (..))
import Data.ByteString.Builder.Extra qualified as B
import Data.Text qualified as T
import Network.HTTP.Client qualified as HTTP
import Network.HTTP.Client.Internal qualified as HTTP
import Network.Socket qualified as NS
import Rustls qualified

-- | Get TLS-enabled HTTP 'HTTP.ManagerSettings' from a Rustls
-- 'Rustls.ClientConfig', consumable via 'HTTP.newManager'.
rustlsManagerSettings :: Rustls.ClientConfig -> HTTP.ManagerSettings
rustlsManagerSettings :: ClientConfig -> ManagerSettings
rustlsManagerSettings ClientConfig
conf =
  ManagerSettings
HTTP.defaultManagerSettings
    { HTTP.managerTlsConnection = pure \Maybe HostAddress
hostAddress String
host Int
port ->
        (Socket -> IO ())
-> Maybe HostAddress
-> String
-> Int
-> (Socket -> IO Connection)
-> IO Connection
forall a.
(Socket -> IO ())
-> Maybe HostAddress -> String -> Int -> (Socket -> IO a) -> IO a
HTTP.withSocket Socket -> IO ()
forall a. Monoid a => a
mempty Maybe HostAddress
hostAddress String
host Int
port \Socket
sock ->
          ClientConfig -> Socket -> String -> IO Connection
makeTlsConnection ClientConfig
conf Socket
sock String
host,
      HTTP.managerTlsProxyConnection = pure \ByteString
connStr Connection -> IO ()
checkConn String
serverName Maybe HostAddress
_ String
host Int
port ->
        (Socket -> IO ())
-> Maybe HostAddress
-> String
-> Int
-> (Socket -> IO Connection)
-> IO Connection
forall a.
(Socket -> IO ())
-> Maybe HostAddress -> String -> Int -> (Socket -> IO a) -> IO a
HTTP.withSocket Socket -> IO ()
forall a. Monoid a => a
mempty Maybe HostAddress
forall a. Maybe a
Nothing String
host Int
port \Socket
sock -> do
          Connection
conn <- Socket -> Int -> IO Connection
HTTP.socketConnection Socket
sock Int
B.defaultChunkSize
          Connection -> ByteString -> IO ()
HTTP.connectionWrite Connection
conn ByteString
connStr
          Connection -> IO ()
checkConn Connection
conn
          ClientConfig -> Socket -> String -> IO Connection
makeTlsConnection ClientConfig
conf Socket
sock String
serverName,
      HTTP.managerWrapException = \Request
req ->
        forall e a. Exception e => (e -> IO a) -> IO a -> IO a
E.handle @Rustls.RustlsException
          (HttpException -> IO a
forall e a. Exception e => e -> IO a
E.throwIO (HttpException -> IO a)
-> (RustlsException -> HttpException) -> RustlsException -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> HttpExceptionContent -> HttpException
HTTP.HttpExceptionRequest Request
req (HttpExceptionContent -> HttpException)
-> (RustlsException -> HttpExceptionContent)
-> RustlsException
-> HttpException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> HttpExceptionContent
HTTP.InternalException (SomeException -> HttpExceptionContent)
-> (RustlsException -> SomeException)
-> RustlsException
-> HttpExceptionContent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RustlsException -> SomeException
forall e. Exception e => e -> SomeException
E.toException)
          (IO a -> IO a) -> (IO a -> IO a) -> IO a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ManagerSettings -> forall a. Request -> IO a -> IO a
HTTP.managerWrapException ManagerSettings
HTTP.defaultManagerSettings Request
req
    }
  where
    makeTlsConnection :: ClientConfig -> Socket -> String -> IO Connection
makeTlsConnection ClientConfig
conf Socket
socket String
hostname = ((forall a. IO a -> IO a) -> IO Connection) -> IO Connection
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
E.mask \forall a. IO a -> IO a
restore -> do
      let strippedHost :: Text
strippedHost = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String
HTTP.strippedHostName String
hostname
          backend :: Backend
backend = Socket -> Backend
Rustls.mkSocketBackend Socket
socket
          Acquire (forall a. IO a -> IO a) -> IO (Allocated (Connection 'Client))
allocate = Backend -> ClientConfig -> Text -> Acquire (Connection 'Client)
Rustls.newClientConnection Backend
backend ClientConfig
conf Text
strippedHost
      Allocated Connection 'Client
conn ReleaseType -> IO ()
freeConn <- (forall a. IO a -> IO a) -> IO (Allocated (Connection 'Client))
allocate IO b -> IO b
forall a. IO a -> IO a
restore
      IO ByteString -> (ByteString -> IO ()) -> IO () -> IO Connection
HTTP.makeConnection
        do Connection 'Client -> Int -> IO ByteString
forall (m :: * -> *) (side :: Side).
MonadIO m =>
Connection side -> Int -> m ByteString
Rustls.readBS Connection 'Client
conn (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
B.defaultChunkSize)
        do Connection 'Client -> ByteString -> IO ()
forall (m :: * -> *) (side :: Side).
MonadIO m =>
Connection side -> ByteString -> m ()
Rustls.writeBS Connection 'Client
conn
        do ReleaseType -> IO ()
freeConn ReleaseType
ReleaseNormal; Socket -> IO ()
NS.close Socket
socket