-- | 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 roots
--   HTTP.newManager $ rustlsManagerSettings clientConfig
--   where
--     -- For now, rustls-ffi does not provide a built-in way to access
--     -- the OS certificate store.
--     roots = Rustls.ClientRootsFromFile "/etc/ssl/certs/ca-certificates.crt"
-- >>> :}
--
-- >>> :{
-- 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 qualified Control.Exception as E
import Data.Acquire (ReleaseType (..))
import Data.Acquire.Internal (Acquire (..), Allocated (..))
import qualified Data.ByteString.Builder.Extra as B
import qualified Data.Text as T
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Client.Internal as HTTP
import qualified Network.Socket as NS
import qualified Rustls

-- | 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
    { managerTlsConnection :: IO (Maybe HostAddress -> String -> Int -> IO Connection)
HTTP.managerTlsConnection = (Maybe HostAddress -> String -> Int -> IO Connection)
-> IO (Maybe HostAddress -> String -> Int -> IO Connection)
forall (f :: * -> *) a. Applicative f => a -> f a
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,
      managerTlsProxyConnection :: IO
  (ByteString
   -> (Connection -> IO ())
   -> String
   -> Maybe HostAddress
   -> String
   -> Int
   -> IO Connection)
HTTP.managerTlsProxyConnection = (ByteString
 -> (Connection -> IO ())
 -> String
 -> Maybe HostAddress
 -> String
 -> Int
 -> IO Connection)
-> IO
     (ByteString
      -> (Connection -> IO ())
      -> String
      -> Maybe HostAddress
      -> String
      -> Int
      -> IO Connection)
forall (f :: * -> *) a. Applicative f => a -> f a
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,
      managerWrapException :: forall a. Request -> IO a -> IO a
HTTP.managerWrapException = \Request
req ->
        (RustlsException -> IO a) -> IO a -> IO a
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 -> Request -> IO a -> IO a
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
          Acquire (forall a. IO a -> IO a) -> IO (Allocated (Connection 'Client))
allocate = Socket -> ClientConfig -> Text -> Acquire (Connection 'Client)
forall b.
Backend b =>
b -> ClientConfig -> Text -> Acquire (Connection 'Client)
Rustls.newClientConnection Socket
socket ClientConfig
conf Text
strippedHost
      Allocated Connection 'Client
conn ReleaseType -> IO ()
freeConn <- (forall a. IO a -> IO a) -> IO (Allocated (Connection 'Client))
allocate 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