-- | TLS bindings for [Rustls](https://github.com/rustls/rustls) via
-- [rustls-ffi](https://github.com/rustls/rustls-ffi).
--
-- See the [README on GitHub](https://github.com/amesgen/hs-rustls/tree/main/rustls)
-- for setup instructions.
--
-- Currently, most of the functionality exposed by rustls-ffi is available,
-- while rustls-ffi is still missing some more niche Rustls features.
--
-- Also see [http-client-rustls](https://hackage.haskell.org/package/http-client-rustls)
-- for making HTTPS requests using
-- [http-client](https://hackage.haskell.org/package/http-client) and Rustls.
--
-- == Client example
--
-- Suppose you have already opened a 'Network.Socket.Socket' to @example.org@,
-- port 443 (see e.g. the examples at "Network.Socket"). This small example
-- showcases how to perform a simple HTTP GET request:
--
-- >>> :set -XOverloadedStrings
-- >>> import qualified Rustls
-- >>> import Network.Socket (Socket)
-- >>> import Data.Acquire (withAcquire)
-- >>> :{
-- example :: Socket -> IO ()
-- example socket = do
--   -- It is encouraged to share a single `clientConfig` when creating multiple
--   -- TLS connections.
--   clientConfig <-
--     Rustls.buildClientConfig $
--       Rustls.defaultClientConfigBuilder serverCertVerifier
--   let backend = Rustls.mkSocketBackend socket
--       newConnection =
--         Rustls.newClientConnection backend clientConfig "example.org"
--   withAcquire newConnection $ \conn -> do
--     Rustls.writeBS conn "GET /"
--     recv <- Rustls.readBS conn 1000 -- max number of bytes to read
--     print recv
--   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 = []
--         }
-- :}
--
-- == Using 'Acquire'
--
-- Some API functions (like 'newClientConnection' and 'newServerConnection')
-- return an 'Acquire' from
-- [resourcet](https://hackage.haskell.org/package/resourcet), as it is a
-- convenient abstraction for exposing a value that should be consumed in a
-- "bracketed" manner.
--
-- Usually, it can be used via 'Data.Acquire.with' or 'withAcquire', or via
-- 'allocateAcquire' when a 'Control.Monad.Trans.Resource.MonadResource'
-- constraint is available. If you really need the extra flexibility, you can
-- also access separate @open…@ and @close…@ functions by reaching for
-- "Data.Acquire.Internal".
module Rustls
  ( -- * Client

    -- ** Builder
    ClientConfigBuilder (..),
    defaultClientConfigBuilder,
    ServerCertVerifier (..),

    -- ** Config
    ClientConfig,
    clientConfigLogCallback,
    buildClientConfig,

    -- ** Open a connection
    newClientConnection,

    -- * Server

    -- ** Builder
    ServerConfigBuilder (..),
    defaultServerConfigBuilder,
    ClientCertVerifier (..),
    ClientCertVerifierPolicy (..),

    -- ** Config
    ServerConfig,
    serverConfigLogCallback,
    buildServerConfig,

    -- ** Open a connection
    newServerConnection,

    -- * Connection
    Connection,
    Side (..),

    -- ** Read and write
    readBS,
    writeBS,

    -- ** Handshaking
    handshake,
    HandshakeQuery,
    getALPNProtocol,
    getTLSVersion,
    getCipherSuite,
    getSNIHostname,
    getPeerCertificate,

    -- ** Closing
    sendCloseNotify,

    -- ** Logging
    LogCallback,
    newLogCallback,
    LogLevel (..),

    -- ** Raw 'Ptr'-based API
    readPtr,
    writePtr,

    -- * Misc
    version,

    -- ** Backend
    Backend (..),
    mkSocketBackend,
    mkByteStringBackend,

    -- ** Types
    ALPNProtocol (..),
    PEMCertificates (..),
    PEMCertificateParsing (..),
    CertifiedKey (..),
    DERCertificate (..),
    CertificateRevocationList (..),
    TLSVersion (TLS12, TLS13, unTLSVersion),
    defaultTLSVersions,
    allTLSVersions,
    CipherSuite,
    cipherSuiteID,
    showCipherSuite,
    defaultCipherSuites,
    allCipherSuites,

    -- ** Exceptions
    RustlsException,
    isCertError,
    RustlsLogException (..),
  )
where

import Control.Concurrent (forkFinally, killThread)
import Control.Concurrent.MVar
import Control.Exception qualified as E
import Control.Monad (forever, void, when)
import Control.Monad.IO.Class
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Reader
import Data.Acquire
import Data.ByteString (ByteString)
import Data.ByteString qualified as B
import Data.ByteString.Internal qualified as BI
import Data.ByteString.Unsafe qualified as BU
import Data.Coerce
import Data.Foldable (for_, toList)
import Data.List.NonEmpty (NonEmpty)
import Data.List.NonEmpty qualified as NE
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Foreign qualified as T
import Data.Traversable (for)
import Data.Word
import Foreign hiding (void)
import Foreign.C
import GHC.Conc (reportError)
import GHC.Generics (Generic)
import Rustls.Internal
import Rustls.Internal.FFI (ConstPtr (..), TLSVersion (..))
import Rustls.Internal.FFI qualified as FFI
import System.IO.Unsafe (unsafePerformIO)

-- $setup
-- >>> import Control.Monad.IO.Class
-- >>> import Data.Acquire

-- | Combined version string of Rustls and rustls-ffi.
--
-- >>> version
-- "rustls-ffi/0.13.0/rustls/0.23.4"
version :: Text
version :: Text
version = IO Text -> Text
forall a. IO a -> a
unsafePerformIO (IO Text -> Text) -> IO Text -> Text
forall a b. (a -> b) -> a -> b
$ (Ptr Str -> IO Text) -> IO Text
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr Str
strPtr -> do
  Ptr Str -> IO ()
FFI.hsVersion Ptr Str
strPtr
  Str -> IO Text
strToText (Str -> IO Text) -> IO Str -> IO Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr Str -> IO Str
forall a. Storable a => Ptr a -> IO a
peek Ptr Str
strPtr
{-# NOINLINE version #-}

peekNonEmpty :: (Storable a, Coercible a b) => ConstPtr a -> CSize -> NonEmpty b
peekNonEmpty :: forall a b.
(Storable a, Coercible a b) =>
ConstPtr a -> CSize -> NonEmpty b
peekNonEmpty (ConstPtr Ptr a
as) CSize
len =
  [b] -> NonEmpty b
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList ([b] -> NonEmpty b) -> (IO [a] -> [b]) -> IO [a] -> NonEmpty b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [b]
forall a b. Coercible a b => a -> b
coerce ([a] -> [b]) -> (IO [a] -> [a]) -> IO [a] -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO [a] -> [a]
forall a. IO a -> a
unsafePerformIO (IO [a] -> NonEmpty b) -> IO [a] -> NonEmpty b
forall a b. (a -> b) -> a -> b
$ Int -> Ptr a -> IO [a]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray (CSize -> Int
cSizeToInt CSize
len) Ptr a
as

-- | All 'TLSVersion's supported by Rustls.
allTLSVersions :: NonEmpty TLSVersion
allTLSVersions :: NonEmpty TLSVersion
allTLSVersions = ConstPtr TLSVersion -> CSize -> NonEmpty TLSVersion
forall a b.
(Storable a, Coercible a b) =>
ConstPtr a -> CSize -> NonEmpty b
peekNonEmpty ConstPtr TLSVersion
FFI.allVersions CSize
FFI.allVersionsLen
{-# NOINLINE allTLSVersions #-}

-- | The default 'TLSVersion's used by Rustls. A subset of 'allTLSVersions'.
defaultTLSVersions :: NonEmpty TLSVersion
defaultTLSVersions :: NonEmpty TLSVersion
defaultTLSVersions = ConstPtr TLSVersion -> CSize -> NonEmpty TLSVersion
forall a b.
(Storable a, Coercible a b) =>
ConstPtr a -> CSize -> NonEmpty b
peekNonEmpty ConstPtr TLSVersion
FFI.defaultVersions CSize
FFI.defaultVersionsLen
{-# NOINLINE defaultTLSVersions #-}

-- | All 'CipherSuite's supported by Rustls.
allCipherSuites :: NonEmpty CipherSuite
allCipherSuites :: NonEmpty CipherSuite
allCipherSuites = ConstPtr (Ptr SupportedCipherSuite)
-> CSize -> NonEmpty CipherSuite
forall a b.
(Storable a, Coercible a b) =>
ConstPtr a -> CSize -> NonEmpty b
peekNonEmpty ConstPtr (Ptr SupportedCipherSuite)
FFI.allCipherSuites CSize
FFI.allCipherSuitesLen
{-# NOINLINE allCipherSuites #-}

-- | The default 'CipherSuite's used by Rustls. A subset of 'allCipherSuites'.
defaultCipherSuites :: NonEmpty CipherSuite
defaultCipherSuites :: NonEmpty CipherSuite
defaultCipherSuites = ConstPtr (ConstPtr SupportedCipherSuite)
-> CSize -> NonEmpty CipherSuite
forall a b.
(Storable a, Coercible a b) =>
ConstPtr a -> CSize -> NonEmpty b
peekNonEmpty ConstPtr (ConstPtr SupportedCipherSuite)
FFI.defaultCipherSuites CSize
FFI.defaultCipherSuitesLen
{-# NOINLINE defaultCipherSuites #-}

-- | A 'ClientConfigBuilder' with good defaults.
defaultClientConfigBuilder :: ServerCertVerifier -> ClientConfigBuilder
defaultClientConfigBuilder :: ServerCertVerifier -> ClientConfigBuilder
defaultClientConfigBuilder ServerCertVerifier
serverCertVerifier =
  ClientConfigBuilder
    { clientConfigServerCertVerifier :: ServerCertVerifier
clientConfigServerCertVerifier = ServerCertVerifier
serverCertVerifier,
      clientConfigTLSVersions :: [TLSVersion]
clientConfigTLSVersions = [],
      clientConfigCipherSuites :: [CipherSuite]
clientConfigCipherSuites = [],
      clientConfigALPNProtocols :: [ALPNProtocol]
clientConfigALPNProtocols = [],
      clientConfigEnableSNI :: Bool
clientConfigEnableSNI = Bool
True,
      clientConfigCertifiedKeys :: [CertifiedKey]
clientConfigCertifiedKeys = []
    }

withCertifiedKeys :: [CertifiedKey] -> ContT a IO (ConstPtr (ConstPtr FFI.CertifiedKey), CSize)
withCertifiedKeys :: forall a.
[CertifiedKey]
-> ContT a IO (ConstPtr (ConstPtr CertifiedKey), CSize)
withCertifiedKeys [CertifiedKey]
certifiedKeys = do
  [ConstPtr CertifiedKey]
certKeys <- [CertifiedKey]
-> (CertifiedKey -> ContT a IO (ConstPtr CertifiedKey))
-> ContT a IO [ConstPtr CertifiedKey]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [CertifiedKey]
certifiedKeys CertifiedKey -> ContT a IO (ConstPtr CertifiedKey)
forall {r}. CertifiedKey -> ContT r IO (ConstPtr CertifiedKey)
withCertifiedKey
  (((ConstPtr (ConstPtr CertifiedKey), CSize) -> IO a) -> IO a)
-> ContT a IO (ConstPtr (ConstPtr CertifiedKey), CSize)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT \(ConstPtr (ConstPtr CertifiedKey), CSize) -> IO a
cb -> [ConstPtr CertifiedKey]
-> (Int -> Ptr (ConstPtr CertifiedKey) -> IO a) -> IO a
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen [ConstPtr CertifiedKey]
certKeys \Int
len Ptr (ConstPtr CertifiedKey)
ptr -> (ConstPtr (ConstPtr CertifiedKey), CSize) -> IO a
cb (Ptr (ConstPtr CertifiedKey) -> ConstPtr (ConstPtr CertifiedKey)
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr (ConstPtr CertifiedKey)
ptr, Int -> CSize
intToCSize Int
len)
  where
    withCertifiedKey :: CertifiedKey -> ContT r IO (ConstPtr CertifiedKey)
withCertifiedKey CertifiedKey {ByteString
certificateChain :: ByteString
privateKey :: ByteString
certificateChain :: CertifiedKey -> ByteString
privateKey :: CertifiedKey -> ByteString
..} = do
      (Ptr CChar
certPtr, Int
certLen) <- (((Ptr CChar, Int) -> IO r) -> IO r) -> ContT r IO (Ptr CChar, Int)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT ((((Ptr CChar, Int) -> IO r) -> IO r)
 -> ContT r IO (Ptr CChar, Int))
-> (((Ptr CChar, Int) -> IO r) -> IO r)
-> ContT r IO (Ptr CChar, Int)
forall a b. (a -> b) -> a -> b
$ ByteString -> ((Ptr CChar, Int) -> IO r) -> IO r
forall a. ByteString -> ((Ptr CChar, Int) -> IO a) -> IO a
BU.unsafeUseAsCStringLen ByteString
certificateChain
      (Ptr CChar
privPtr, Int
privLen) <- (((Ptr CChar, Int) -> IO r) -> IO r) -> ContT r IO (Ptr CChar, Int)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT ((((Ptr CChar, Int) -> IO r) -> IO r)
 -> ContT r IO (Ptr CChar, Int))
-> (((Ptr CChar, Int) -> IO r) -> IO r)
-> ContT r IO (Ptr CChar, Int)
forall a b. (a -> b) -> a -> b
$ ByteString -> ((Ptr CChar, Int) -> IO r) -> IO r
forall a. ByteString -> ((Ptr CChar, Int) -> IO a) -> IO a
BU.unsafeUseAsCStringLen ByteString
privateKey
      Ptr (ConstPtr CertifiedKey)
certKeyPtr <- ((Ptr (ConstPtr CertifiedKey) -> IO r) -> IO r)
-> ContT r IO (Ptr (ConstPtr CertifiedKey))
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (Ptr (ConstPtr CertifiedKey) -> IO r) -> IO r
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca
      IO (ConstPtr CertifiedKey) -> ContT r IO (ConstPtr CertifiedKey)
forall a. IO a -> ContT r IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
        Result -> IO ()
rethrowR
          (Result -> IO ()) -> IO Result -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ConstPtr Word8
-> CSize
-> ConstPtr Word8
-> CSize
-> Ptr (ConstPtr CertifiedKey)
-> IO Result
FFI.certifiedKeyBuild
            (Ptr Word8 -> ConstPtr Word8
forall a. Ptr a -> ConstPtr a
ConstPtr (Ptr Word8 -> ConstPtr Word8) -> Ptr Word8 -> ConstPtr Word8
forall a b. (a -> b) -> a -> b
$ Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
certPtr)
            (Int -> CSize
intToCSize Int
certLen)
            (Ptr Word8 -> ConstPtr Word8
forall a. Ptr a -> ConstPtr a
ConstPtr (Ptr Word8 -> ConstPtr Word8) -> Ptr Word8 -> ConstPtr Word8
forall a b. (a -> b) -> a -> b
$ Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
privPtr)
            (Int -> CSize
intToCSize Int
privLen)
            Ptr (ConstPtr CertifiedKey)
certKeyPtr
        Ptr (ConstPtr CertifiedKey) -> IO (ConstPtr CertifiedKey)
forall a. Storable a => Ptr a -> IO a
peek Ptr (ConstPtr CertifiedKey)
certKeyPtr

withALPNProtocols :: [ALPNProtocol] -> ContT a IO (ConstPtr FFI.SliceBytes, CSize)
withALPNProtocols :: forall a. [ALPNProtocol] -> ContT a IO (ConstPtr SliceBytes, CSize)
withALPNProtocols [ALPNProtocol]
bss = do
  [SliceBytes]
bsPtrs <- [ByteString]
-> (ByteString -> ContT a IO SliceBytes) -> ContT a IO [SliceBytes]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for ([ALPNProtocol] -> [ByteString]
forall a b. Coercible a b => a -> b
coerce [ALPNProtocol]
bss) ByteString -> ContT a IO SliceBytes
forall {r}. ByteString -> ContT r IO SliceBytes
withSliceBytes
  (((ConstPtr SliceBytes, CSize) -> IO a) -> IO a)
-> ContT a IO (ConstPtr SliceBytes, CSize)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT \(ConstPtr SliceBytes, CSize) -> IO a
cb -> [SliceBytes] -> (Int -> Ptr SliceBytes -> IO a) -> IO a
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen [SliceBytes]
bsPtrs \Int
len Ptr SliceBytes
bsPtr -> (ConstPtr SliceBytes, CSize) -> IO a
cb (Ptr SliceBytes -> ConstPtr SliceBytes
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr SliceBytes
bsPtr, Int -> CSize
intToCSize Int
len)
  where
    withSliceBytes :: ByteString -> ContT r IO SliceBytes
withSliceBytes ByteString
bs = do
      (Ptr CChar
buf, Int
len) <- (((Ptr CChar, Int) -> IO r) -> IO r) -> ContT r IO (Ptr CChar, Int)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT ((((Ptr CChar, Int) -> IO r) -> IO r)
 -> ContT r IO (Ptr CChar, Int))
-> (((Ptr CChar, Int) -> IO r) -> IO r)
-> ContT r IO (Ptr CChar, Int)
forall a b. (a -> b) -> a -> b
$ ByteString -> ((Ptr CChar, Int) -> IO r) -> IO r
forall a. ByteString -> ((Ptr CChar, Int) -> IO a) -> IO a
BU.unsafeUseAsCStringLen ByteString
bs
      SliceBytes -> ContT r IO SliceBytes
forall a. a -> ContT r IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SliceBytes -> ContT r IO SliceBytes)
-> SliceBytes -> ContT r IO SliceBytes
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> CSize -> SliceBytes
FFI.SliceBytes (Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
buf) (Int -> CSize
intToCSize Int
len)

configBuilderNew ::
  ( ConstPtr (ConstPtr FFI.SupportedCipherSuite) ->
    CSize ->
    ConstPtr TLSVersion ->
    CSize ->
    Ptr (Ptr configBuilder) ->
    IO FFI.Result
  ) ->
  [CipherSuite] ->
  [TLSVersion] ->
  IO (Ptr configBuilder)
configBuilderNew :: forall configBuilder.
(ConstPtr (ConstPtr SupportedCipherSuite)
 -> CSize
 -> ConstPtr TLSVersion
 -> CSize
 -> Ptr (Ptr configBuilder)
 -> IO Result)
-> [CipherSuite] -> [TLSVersion] -> IO (Ptr configBuilder)
configBuilderNew ConstPtr (ConstPtr SupportedCipherSuite)
-> CSize
-> ConstPtr TLSVersion
-> CSize
-> Ptr (Ptr configBuilder)
-> IO Result
configBuilderNewCustom [CipherSuite]
cipherSuites [TLSVersion]
tlsVersions = ContT (Ptr configBuilder) IO (Ptr configBuilder)
-> IO (Ptr configBuilder)
forall (m :: * -> *) r. Monad m => ContT r m r -> m r
evalContT do
  Ptr (Ptr configBuilder)
builderPtr <- ((Ptr (Ptr configBuilder) -> IO (Ptr configBuilder))
 -> IO (Ptr configBuilder))
-> ContT (Ptr configBuilder) IO (Ptr (Ptr configBuilder))
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (Ptr (Ptr configBuilder) -> IO (Ptr configBuilder))
-> IO (Ptr configBuilder)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca
  (CSize
cipherSuitesLen, ConstPtr (ConstPtr SupportedCipherSuite)
cipherSuitesPtr) <-
    if [CipherSuite] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CipherSuite]
cipherSuites
      then (CSize, ConstPtr (ConstPtr SupportedCipherSuite))
-> ContT
     (Ptr configBuilder)
     IO
     (CSize, ConstPtr (ConstPtr SupportedCipherSuite))
forall a. a -> ContT (Ptr configBuilder) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CSize
FFI.defaultCipherSuitesLen, ConstPtr (ConstPtr SupportedCipherSuite)
FFI.defaultCipherSuites)
      else (((CSize, ConstPtr (ConstPtr SupportedCipherSuite))
  -> IO (Ptr configBuilder))
 -> IO (Ptr configBuilder))
-> ContT
     (Ptr configBuilder)
     IO
     (CSize, ConstPtr (ConstPtr SupportedCipherSuite))
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT \(CSize, ConstPtr (ConstPtr SupportedCipherSuite))
-> IO (Ptr configBuilder)
cb -> [ConstPtr SupportedCipherSuite]
-> (Int
    -> Ptr (ConstPtr SupportedCipherSuite) -> IO (Ptr configBuilder))
-> IO (Ptr configBuilder)
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen ([CipherSuite] -> [ConstPtr SupportedCipherSuite]
forall a b. Coercible a b => a -> b
coerce [CipherSuite]
cipherSuites) \Int
len Ptr (ConstPtr SupportedCipherSuite)
ptr ->
        (CSize, ConstPtr (ConstPtr SupportedCipherSuite))
-> IO (Ptr configBuilder)
cb (Int -> CSize
intToCSize Int
len, Ptr (ConstPtr SupportedCipherSuite)
-> ConstPtr (ConstPtr SupportedCipherSuite)
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr (ConstPtr SupportedCipherSuite)
ptr)
  (CSize
tlsVersionsLen, ConstPtr TLSVersion
tlsVersionsPtr) <-
    if [TLSVersion] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TLSVersion]
tlsVersions
      then (CSize, ConstPtr TLSVersion)
-> ContT (Ptr configBuilder) IO (CSize, ConstPtr TLSVersion)
forall a. a -> ContT (Ptr configBuilder) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CSize
FFI.defaultVersionsLen, ConstPtr TLSVersion
FFI.defaultVersions)
      else (((CSize, ConstPtr TLSVersion) -> IO (Ptr configBuilder))
 -> IO (Ptr configBuilder))
-> ContT (Ptr configBuilder) IO (CSize, ConstPtr TLSVersion)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT \(CSize, ConstPtr TLSVersion) -> IO (Ptr configBuilder)
cb -> [TLSVersion]
-> (Int -> Ptr TLSVersion -> IO (Ptr configBuilder))
-> IO (Ptr configBuilder)
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen [TLSVersion]
tlsVersions \Int
len Ptr TLSVersion
ptr ->
        (CSize, ConstPtr TLSVersion) -> IO (Ptr configBuilder)
cb (Int -> CSize
intToCSize Int
len, Ptr TLSVersion -> ConstPtr TLSVersion
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr TLSVersion
ptr)
  IO (Ptr configBuilder)
-> ContT (Ptr configBuilder) IO (Ptr configBuilder)
forall a. IO a -> ContT (Ptr configBuilder) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
    Result -> IO ()
rethrowR
      (Result -> IO ()) -> IO Result -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ConstPtr (ConstPtr SupportedCipherSuite)
-> CSize
-> ConstPtr TLSVersion
-> CSize
-> Ptr (Ptr configBuilder)
-> IO Result
configBuilderNewCustom
        ConstPtr (ConstPtr SupportedCipherSuite)
cipherSuitesPtr
        CSize
cipherSuitesLen
        ConstPtr TLSVersion
tlsVersionsPtr
        CSize
tlsVersionsLen
        Ptr (Ptr configBuilder)
builderPtr
    Ptr (Ptr configBuilder) -> IO (Ptr configBuilder)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr configBuilder)
builderPtr

withRootCertStore :: [PEMCertificates] -> ContT a IO (ConstPtr FFI.RootCertStore)
withRootCertStore :: forall a. [PEMCertificates] -> ContT a IO (ConstPtr RootCertStore)
withRootCertStore [PEMCertificates]
certs = do
  Ptr RootCertStoreBuilder
storeBuilder <-
    ((Ptr RootCertStoreBuilder -> IO a) -> IO a)
-> ContT a IO (Ptr RootCertStoreBuilder)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((Ptr RootCertStoreBuilder -> IO a) -> IO a)
 -> ContT a IO (Ptr RootCertStoreBuilder))
-> ((Ptr RootCertStoreBuilder -> IO a) -> IO a)
-> ContT a IO (Ptr RootCertStoreBuilder)
forall a b. (a -> b) -> a -> b
$ IO (Ptr RootCertStoreBuilder)
-> (Ptr RootCertStoreBuilder -> IO ())
-> (Ptr RootCertStoreBuilder -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket IO (Ptr RootCertStoreBuilder)
FFI.rootCertStoreBuilderNew Ptr RootCertStoreBuilder -> IO ()
FFI.rootCertStoreBuilderFree
  let isStrict :: PEMCertificateParsing -> CBool
      isStrict :: PEMCertificateParsing -> CBool
isStrict =
        forall a. Num a => Bool -> a
fromBool @CBool (Bool -> CBool)
-> (PEMCertificateParsing -> Bool)
-> PEMCertificateParsing
-> CBool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
          PEMCertificateParsing
PEMCertificateParsingStrict -> Bool
True
          PEMCertificateParsing
PEMCertificateParsingLax -> Bool
False
  [PEMCertificates]
-> (PEMCertificates -> ContT a IO ()) -> ContT a IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [PEMCertificates]
certs \case
    PEMCertificatesInMemory ByteString
bs PEMCertificateParsing
parsing -> do
      (Ptr CChar
buf, Int
len) <- (((Ptr CChar, Int) -> IO a) -> IO a) -> ContT a IO (Ptr CChar, Int)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT ((((Ptr CChar, Int) -> IO a) -> IO a)
 -> ContT a IO (Ptr CChar, Int))
-> (((Ptr CChar, Int) -> IO a) -> IO a)
-> ContT a IO (Ptr CChar, Int)
forall a b. (a -> b) -> a -> b
$ ByteString -> ((Ptr CChar, Int) -> IO a) -> IO a
forall a. ByteString -> ((Ptr CChar, Int) -> IO a) -> IO a
BU.unsafeUseAsCStringLen ByteString
bs
      IO () -> ContT a IO ()
forall a. IO a -> ContT a IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ContT a IO ()) -> IO () -> ContT a IO ()
forall a b. (a -> b) -> a -> b
$
        Result -> IO ()
rethrowR
          (Result -> IO ()) -> IO Result -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr RootCertStoreBuilder
-> ConstPtr Word8 -> CSize -> CBool -> IO Result
FFI.rootCertStoreBuilderAddPem
            Ptr RootCertStoreBuilder
storeBuilder
            (Ptr Word8 -> ConstPtr Word8
forall a. Ptr a -> ConstPtr a
ConstPtr (Ptr Word8 -> ConstPtr Word8) -> Ptr Word8 -> ConstPtr Word8
forall a b. (a -> b) -> a -> b
$ Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
buf)
            (Int -> CSize
intToCSize Int
len)
            (PEMCertificateParsing -> CBool
isStrict PEMCertificateParsing
parsing)
    PemCertificatesFromFile FilePath
path PEMCertificateParsing
parsing -> do
      Ptr CChar
pathPtr <- ((Ptr CChar -> IO a) -> IO a) -> ContT a IO (Ptr CChar)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((Ptr CChar -> IO a) -> IO a) -> ContT a IO (Ptr CChar))
-> ((Ptr CChar -> IO a) -> IO a) -> ContT a IO (Ptr CChar)
forall a b. (a -> b) -> a -> b
$ FilePath -> (Ptr CChar -> IO a) -> IO a
forall a. FilePath -> (Ptr CChar -> IO a) -> IO a
withCString FilePath
path
      IO () -> ContT a IO ()
forall a. IO a -> ContT a IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ContT a IO ()) -> IO () -> ContT a IO ()
forall a b. (a -> b) -> a -> b
$
        Result -> IO ()
rethrowR
          (Result -> IO ()) -> IO Result -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr RootCertStoreBuilder -> ConstCString -> CBool -> IO Result
FFI.rootCertStoreBuilderLoadRootsFromFile
            Ptr RootCertStoreBuilder
storeBuilder
            (Ptr CChar -> ConstCString
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr CChar
pathPtr)
            (PEMCertificateParsing -> CBool
isStrict PEMCertificateParsing
parsing)
  Ptr (ConstPtr RootCertStore)
storePtr <- ((Ptr (ConstPtr RootCertStore) -> IO a) -> IO a)
-> ContT a IO (Ptr (ConstPtr RootCertStore))
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (Ptr (ConstPtr RootCertStore) -> IO a) -> IO a
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca
  let buildRootCertStore :: IO (ConstPtr RootCertStore)
buildRootCertStore = do
        IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Result -> IO ()
rethrowR (Result -> IO ()) -> IO Result -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr RootCertStoreBuilder
-> Ptr (ConstPtr RootCertStore) -> IO Result
FFI.rootCertStoreBuilderBuild Ptr RootCertStoreBuilder
storeBuilder Ptr (ConstPtr RootCertStore)
storePtr
        Ptr (ConstPtr RootCertStore) -> IO (ConstPtr RootCertStore)
forall a. Storable a => Ptr a -> IO a
peek Ptr (ConstPtr RootCertStore)
storePtr
  ((ConstPtr RootCertStore -> IO a) -> IO a)
-> ContT a IO (ConstPtr RootCertStore)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((ConstPtr RootCertStore -> IO a) -> IO a)
 -> ContT a IO (ConstPtr RootCertStore))
-> ((ConstPtr RootCertStore -> IO a) -> IO a)
-> ContT a IO (ConstPtr RootCertStore)
forall a b. (a -> b) -> a -> b
$ IO (ConstPtr RootCertStore)
-> (ConstPtr RootCertStore -> IO ())
-> (ConstPtr RootCertStore -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket IO (ConstPtr RootCertStore)
buildRootCertStore ConstPtr RootCertStore -> IO ()
FFI.rootCertStoreFree

-- | Build a 'ClientConfigBuilder' into a 'ClientConfig'.
--
-- This is a relatively expensive operation, so it is a good idea to share one
-- 'ClientConfig' when creating multiple 'Connection's.
buildClientConfig :: (MonadIO m) => ClientConfigBuilder -> m ClientConfig
buildClientConfig :: forall (m :: * -> *).
MonadIO m =>
ClientConfigBuilder -> m ClientConfig
buildClientConfig ClientConfigBuilder {Bool
[TLSVersion]
[CertifiedKey]
[CipherSuite]
[ALPNProtocol]
ServerCertVerifier
clientConfigServerCertVerifier :: ClientConfigBuilder -> ServerCertVerifier
clientConfigTLSVersions :: ClientConfigBuilder -> [TLSVersion]
clientConfigCipherSuites :: ClientConfigBuilder -> [CipherSuite]
clientConfigALPNProtocols :: ClientConfigBuilder -> [ALPNProtocol]
clientConfigEnableSNI :: ClientConfigBuilder -> Bool
clientConfigCertifiedKeys :: ClientConfigBuilder -> [CertifiedKey]
clientConfigServerCertVerifier :: ServerCertVerifier
clientConfigTLSVersions :: [TLSVersion]
clientConfigCipherSuites :: [CipherSuite]
clientConfigALPNProtocols :: [ALPNProtocol]
clientConfigEnableSNI :: Bool
clientConfigCertifiedKeys :: [CertifiedKey]
..} = IO ClientConfig -> m ClientConfig
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ClientConfig -> m ClientConfig)
-> (IO ClientConfig -> IO ClientConfig)
-> IO ClientConfig
-> m ClientConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO ClientConfig -> IO ClientConfig
forall a. IO a -> IO a
E.mask_ (IO ClientConfig -> m ClientConfig)
-> IO ClientConfig -> m ClientConfig
forall a b. (a -> b) -> a -> b
$ ContT ClientConfig IO ClientConfig -> IO ClientConfig
forall (m :: * -> *) r. Monad m => ContT r m r -> m r
evalContT do
  Ptr ClientConfigBuilder
builder <-
    ((Ptr ClientConfigBuilder -> IO ClientConfig) -> IO ClientConfig)
-> ContT ClientConfig IO (Ptr ClientConfigBuilder)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((Ptr ClientConfigBuilder -> IO ClientConfig) -> IO ClientConfig)
 -> ContT ClientConfig IO (Ptr ClientConfigBuilder))
-> ((Ptr ClientConfigBuilder -> IO ClientConfig)
    -> IO ClientConfig)
-> ContT ClientConfig IO (Ptr ClientConfigBuilder)
forall a b. (a -> b) -> a -> b
$
      IO (Ptr ClientConfigBuilder)
-> (Ptr ClientConfigBuilder -> IO ())
-> (Ptr ClientConfigBuilder -> IO ClientConfig)
-> IO ClientConfig
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracketOnError
        ( (ConstPtr (ConstPtr SupportedCipherSuite)
 -> CSize
 -> ConstPtr TLSVersion
 -> CSize
 -> Ptr (Ptr ClientConfigBuilder)
 -> IO Result)
-> [CipherSuite] -> [TLSVersion] -> IO (Ptr ClientConfigBuilder)
forall configBuilder.
(ConstPtr (ConstPtr SupportedCipherSuite)
 -> CSize
 -> ConstPtr TLSVersion
 -> CSize
 -> Ptr (Ptr configBuilder)
 -> IO Result)
-> [CipherSuite] -> [TLSVersion] -> IO (Ptr configBuilder)
configBuilderNew
            ConstPtr (ConstPtr SupportedCipherSuite)
-> CSize
-> ConstPtr TLSVersion
-> CSize
-> Ptr (Ptr ClientConfigBuilder)
-> IO Result
FFI.clientConfigBuilderNewCustom
            [CipherSuite]
clientConfigCipherSuites
            [TLSVersion]
clientConfigTLSVersions
        )
        Ptr ClientConfigBuilder -> IO ()
FFI.clientConfigBuilderFree

  let ServerCertVerifier {[CertificateRevocationList]
NonEmpty PEMCertificates
serverCertVerifierCertificates :: NonEmpty PEMCertificates
serverCertVerifierCRLs :: [CertificateRevocationList]
serverCertVerifierCertificates :: ServerCertVerifier -> NonEmpty PEMCertificates
serverCertVerifierCRLs :: ServerCertVerifier -> [CertificateRevocationList]
..} = ServerCertVerifier
clientConfigServerCertVerifier
  ConstPtr RootCertStore
rootCertStore <- [PEMCertificates] -> ContT ClientConfig IO (ConstPtr RootCertStore)
forall a. [PEMCertificates] -> ContT a IO (ConstPtr RootCertStore)
withRootCertStore ([PEMCertificates]
 -> ContT ClientConfig IO (ConstPtr RootCertStore))
-> [PEMCertificates]
-> ContT ClientConfig IO (ConstPtr RootCertStore)
forall a b. (a -> b) -> a -> b
$ NonEmpty PEMCertificates -> [PEMCertificates]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty PEMCertificates
serverCertVerifierCertificates
  Ptr WebPkiServerCertVerifierBuilder
scvb <-
    ((Ptr WebPkiServerCertVerifierBuilder -> IO ClientConfig)
 -> IO ClientConfig)
-> ContT ClientConfig IO (Ptr WebPkiServerCertVerifierBuilder)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((Ptr WebPkiServerCertVerifierBuilder -> IO ClientConfig)
  -> IO ClientConfig)
 -> ContT ClientConfig IO (Ptr WebPkiServerCertVerifierBuilder))
-> ((Ptr WebPkiServerCertVerifierBuilder -> IO ClientConfig)
    -> IO ClientConfig)
-> ContT ClientConfig IO (Ptr WebPkiServerCertVerifierBuilder)
forall a b. (a -> b) -> a -> b
$
      IO (Ptr WebPkiServerCertVerifierBuilder)
-> (Ptr WebPkiServerCertVerifierBuilder -> IO ())
-> (Ptr WebPkiServerCertVerifierBuilder -> IO ClientConfig)
-> IO ClientConfig
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket
        (ConstPtr RootCertStore -> IO (Ptr WebPkiServerCertVerifierBuilder)
FFI.webPkiServerCertVerifierBuilderNew ConstPtr RootCertStore
rootCertStore)
        Ptr WebPkiServerCertVerifierBuilder -> IO ()
FFI.webPkiServerCertVerifierBuilderFree
  [(Ptr CChar, Int)]
crls :: [CStringLen] <-
    [CertificateRevocationList]
-> (CertificateRevocationList
    -> ContT ClientConfig IO (Ptr CChar, Int))
-> ContT ClientConfig IO [(Ptr CChar, Int)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [CertificateRevocationList]
serverCertVerifierCRLs ((CertificateRevocationList
  -> ContT ClientConfig IO (Ptr CChar, Int))
 -> ContT ClientConfig IO [(Ptr CChar, Int)])
-> (CertificateRevocationList
    -> ContT ClientConfig IO (Ptr CChar, Int))
-> ContT ClientConfig IO [(Ptr CChar, Int)]
forall a b. (a -> b) -> a -> b
$
      (((Ptr CChar, Int) -> IO ClientConfig) -> IO ClientConfig)
-> ContT ClientConfig IO (Ptr CChar, Int)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT ((((Ptr CChar, Int) -> IO ClientConfig) -> IO ClientConfig)
 -> ContT ClientConfig IO (Ptr CChar, Int))
-> (CertificateRevocationList
    -> ((Ptr CChar, Int) -> IO ClientConfig) -> IO ClientConfig)
-> CertificateRevocationList
-> ContT ClientConfig IO (Ptr CChar, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString
-> ((Ptr CChar, Int) -> IO ClientConfig) -> IO ClientConfig
forall a. ByteString -> ((Ptr CChar, Int) -> IO a) -> IO a
BU.unsafeUseAsCStringLen (ByteString
 -> ((Ptr CChar, Int) -> IO ClientConfig) -> IO ClientConfig)
-> (CertificateRevocationList -> ByteString)
-> CertificateRevocationList
-> ((Ptr CChar, Int) -> IO ClientConfig)
-> IO ClientConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CertificateRevocationList -> ByteString
unCertificateRevocationList
  IO () -> ContT ClientConfig IO ()
forall a. IO a -> ContT ClientConfig IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ContT ClientConfig IO ())
-> IO () -> ContT ClientConfig IO ()
forall a b. (a -> b) -> a -> b
$ [(Ptr CChar, Int)] -> ((Ptr CChar, Int) -> IO Result) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(Ptr CChar, Int)]
crls \(Ptr CChar
ptr, Int
len) ->
    Ptr WebPkiServerCertVerifierBuilder
-> ConstPtr Word8 -> CSize -> IO Result
FFI.webPkiServerCertVerifierBuilderAddCrl
      Ptr WebPkiServerCertVerifierBuilder
scvb
      (Ptr Word8 -> ConstPtr Word8
forall a. Ptr a -> ConstPtr a
ConstPtr (Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
ptr))
      (Int -> CSize
intToCSize Int
len)
  Ptr (Ptr ServerCertVerifier)
scvPtr <- ((Ptr (Ptr ServerCertVerifier) -> IO ClientConfig)
 -> IO ClientConfig)
-> ContT ClientConfig IO (Ptr (Ptr ServerCertVerifier))
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (Ptr (Ptr ServerCertVerifier) -> IO ClientConfig)
-> IO ClientConfig
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca
  let buildScv :: IO (Ptr ServerCertVerifier)
buildScv = do
        Result -> IO ()
rethrowR (Result -> IO ()) -> IO Result -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr WebPkiServerCertVerifierBuilder
-> Ptr (Ptr ServerCertVerifier) -> IO Result
FFI.webPkiServerCertVerifierBuilderBuild Ptr WebPkiServerCertVerifierBuilder
scvb Ptr (Ptr ServerCertVerifier)
scvPtr
        Ptr (Ptr ServerCertVerifier) -> IO (Ptr ServerCertVerifier)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr ServerCertVerifier)
scvPtr
  Ptr ServerCertVerifier
scv <- ((Ptr ServerCertVerifier -> IO ClientConfig) -> IO ClientConfig)
-> ContT ClientConfig IO (Ptr ServerCertVerifier)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((Ptr ServerCertVerifier -> IO ClientConfig) -> IO ClientConfig)
 -> ContT ClientConfig IO (Ptr ServerCertVerifier))
-> ((Ptr ServerCertVerifier -> IO ClientConfig) -> IO ClientConfig)
-> ContT ClientConfig IO (Ptr ServerCertVerifier)
forall a b. (a -> b) -> a -> b
$ IO (Ptr ServerCertVerifier)
-> (Ptr ServerCertVerifier -> IO ())
-> (Ptr ServerCertVerifier -> IO ClientConfig)
-> IO ClientConfig
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket IO (Ptr ServerCertVerifier)
buildScv Ptr ServerCertVerifier -> IO ()
FFI.serverCertVerifierFree
  IO () -> ContT ClientConfig IO ()
forall a. IO a -> ContT ClientConfig IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ContT ClientConfig IO ())
-> IO () -> ContT ClientConfig IO ()
forall a b. (a -> b) -> a -> b
$ Ptr ClientConfigBuilder -> ConstPtr ServerCertVerifier -> IO ()
FFI.clientConfigBuilderSetServerVerifier Ptr ClientConfigBuilder
builder (Ptr ServerCertVerifier -> ConstPtr ServerCertVerifier
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr ServerCertVerifier
scv)

  (ConstPtr SliceBytes
alpnPtr, CSize
len) <- [ALPNProtocol]
-> ContT ClientConfig IO (ConstPtr SliceBytes, CSize)
forall a. [ALPNProtocol] -> ContT a IO (ConstPtr SliceBytes, CSize)
withALPNProtocols [ALPNProtocol]
clientConfigALPNProtocols
  IO () -> ContT ClientConfig IO ()
forall a. IO a -> ContT ClientConfig IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ContT ClientConfig IO ())
-> IO () -> ContT ClientConfig IO ()
forall a b. (a -> b) -> a -> b
$ Result -> IO ()
rethrowR (Result -> IO ()) -> IO Result -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr ClientConfigBuilder
-> ConstPtr SliceBytes -> CSize -> IO Result
FFI.clientConfigBuilderSetALPNProtocols Ptr ClientConfigBuilder
builder ConstPtr SliceBytes
alpnPtr CSize
len

  IO () -> ContT ClientConfig IO ()
forall a. IO a -> ContT ClientConfig IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ContT ClientConfig IO ())
-> IO () -> ContT ClientConfig IO ()
forall a b. (a -> b) -> a -> b
$
    Ptr ClientConfigBuilder -> CBool -> IO ()
FFI.clientConfigBuilderSetEnableSNI Ptr ClientConfigBuilder
builder (forall a. Num a => Bool -> a
fromBool @CBool Bool
clientConfigEnableSNI)

  (ConstPtr (ConstPtr CertifiedKey)
ptr, CSize
len) <- [CertifiedKey]
-> ContT ClientConfig IO (ConstPtr (ConstPtr CertifiedKey), CSize)
forall a.
[CertifiedKey]
-> ContT a IO (ConstPtr (ConstPtr CertifiedKey), CSize)
withCertifiedKeys [CertifiedKey]
clientConfigCertifiedKeys
  IO () -> ContT ClientConfig IO ()
forall a. IO a -> ContT ClientConfig IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ContT ClientConfig IO ())
-> IO () -> ContT ClientConfig IO ()
forall a b. (a -> b) -> a -> b
$ Result -> IO ()
rethrowR (Result -> IO ()) -> IO Result -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr ClientConfigBuilder
-> ConstPtr (ConstPtr CertifiedKey) -> CSize -> IO Result
FFI.clientConfigBuilderSetCertifiedKey Ptr ClientConfigBuilder
builder ConstPtr (ConstPtr CertifiedKey)
ptr CSize
len

  let clientConfigLogCallback :: Maybe a
clientConfigLogCallback = Maybe a
forall a. Maybe a
Nothing

  IO ClientConfig -> ContT ClientConfig IO ClientConfig
forall a. IO a -> ContT ClientConfig IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
    ForeignPtr ClientConfig
clientConfigPtr <-
      FinalizerPtr ClientConfig
-> Ptr ClientConfig -> IO (ForeignPtr ClientConfig)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr ClientConfig
FFI.clientConfigFree (Ptr ClientConfig -> IO (ForeignPtr ClientConfig))
-> (ConstPtr ClientConfig -> Ptr ClientConfig)
-> ConstPtr ClientConfig
-> IO (ForeignPtr ClientConfig)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstPtr ClientConfig -> Ptr ClientConfig
forall a. ConstPtr a -> Ptr a
unConstPtr
        (ConstPtr ClientConfig -> IO (ForeignPtr ClientConfig))
-> IO (ConstPtr ClientConfig) -> IO (ForeignPtr ClientConfig)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr ClientConfigBuilder -> IO (ConstPtr ClientConfig)
FFI.clientConfigBuilderBuild Ptr ClientConfigBuilder
builder
    ClientConfig -> IO ClientConfig
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientConfig {Maybe LogCallback
ForeignPtr ClientConfig
forall a. Maybe a
clientConfigLogCallback :: Maybe LogCallback
clientConfigLogCallback :: forall a. Maybe a
clientConfigPtr :: ForeignPtr ClientConfig
clientConfigPtr :: ForeignPtr ClientConfig
..}

-- | Build a 'ServerConfigBuilder' into a 'ServerConfig'.
--
-- This is a relatively expensive operation, so it is a good idea to share one
-- 'ServerConfig' when creating multiple 'Connection's.
buildServerConfig :: (MonadIO m) => ServerConfigBuilder -> m ServerConfig
buildServerConfig :: forall (m :: * -> *).
MonadIO m =>
ServerConfigBuilder -> m ServerConfig
buildServerConfig ServerConfigBuilder {Bool
[TLSVersion]
[CipherSuite]
[ALPNProtocol]
Maybe ClientCertVerifier
NonEmpty CertifiedKey
serverConfigCertifiedKeys :: NonEmpty CertifiedKey
serverConfigTLSVersions :: [TLSVersion]
serverConfigCipherSuites :: [CipherSuite]
serverConfigALPNProtocols :: [ALPNProtocol]
serverConfigIgnoreClientOrder :: Bool
serverConfigClientCertVerifier :: Maybe ClientCertVerifier
serverConfigCertifiedKeys :: ServerConfigBuilder -> NonEmpty CertifiedKey
serverConfigTLSVersions :: ServerConfigBuilder -> [TLSVersion]
serverConfigCipherSuites :: ServerConfigBuilder -> [CipherSuite]
serverConfigALPNProtocols :: ServerConfigBuilder -> [ALPNProtocol]
serverConfigIgnoreClientOrder :: ServerConfigBuilder -> Bool
serverConfigClientCertVerifier :: ServerConfigBuilder -> Maybe ClientCertVerifier
..} = IO ServerConfig -> m ServerConfig
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ServerConfig -> m ServerConfig)
-> (IO ServerConfig -> IO ServerConfig)
-> IO ServerConfig
-> m ServerConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO ServerConfig -> IO ServerConfig
forall a. IO a -> IO a
E.mask_ (IO ServerConfig -> m ServerConfig)
-> IO ServerConfig -> m ServerConfig
forall a b. (a -> b) -> a -> b
$ ContT ServerConfig IO ServerConfig -> IO ServerConfig
forall (m :: * -> *) r. Monad m => ContT r m r -> m r
evalContT do
  Ptr ServerConfigBuilder
builder <-
    ((Ptr ServerConfigBuilder -> IO ServerConfig) -> IO ServerConfig)
-> ContT ServerConfig IO (Ptr ServerConfigBuilder)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((Ptr ServerConfigBuilder -> IO ServerConfig) -> IO ServerConfig)
 -> ContT ServerConfig IO (Ptr ServerConfigBuilder))
-> ((Ptr ServerConfigBuilder -> IO ServerConfig)
    -> IO ServerConfig)
-> ContT ServerConfig IO (Ptr ServerConfigBuilder)
forall a b. (a -> b) -> a -> b
$
      IO (Ptr ServerConfigBuilder)
-> (Ptr ServerConfigBuilder -> IO ())
-> (Ptr ServerConfigBuilder -> IO ServerConfig)
-> IO ServerConfig
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracketOnError
        ( (ConstPtr (ConstPtr SupportedCipherSuite)
 -> CSize
 -> ConstPtr TLSVersion
 -> CSize
 -> Ptr (Ptr ServerConfigBuilder)
 -> IO Result)
-> [CipherSuite] -> [TLSVersion] -> IO (Ptr ServerConfigBuilder)
forall configBuilder.
(ConstPtr (ConstPtr SupportedCipherSuite)
 -> CSize
 -> ConstPtr TLSVersion
 -> CSize
 -> Ptr (Ptr configBuilder)
 -> IO Result)
-> [CipherSuite] -> [TLSVersion] -> IO (Ptr configBuilder)
configBuilderNew
            ConstPtr (ConstPtr SupportedCipherSuite)
-> CSize
-> ConstPtr TLSVersion
-> CSize
-> Ptr (Ptr ServerConfigBuilder)
-> IO Result
FFI.serverConfigBuilderNewCustom
            [CipherSuite]
serverConfigCipherSuites
            [TLSVersion]
serverConfigTLSVersions
        )
        Ptr ServerConfigBuilder -> IO ()
FFI.serverConfigBuilderFree

  (ConstPtr SliceBytes
alpnPtr, CSize
len) <- [ALPNProtocol]
-> ContT ServerConfig IO (ConstPtr SliceBytes, CSize)
forall a. [ALPNProtocol] -> ContT a IO (ConstPtr SliceBytes, CSize)
withALPNProtocols [ALPNProtocol]
serverConfigALPNProtocols
  IO () -> ContT ServerConfig IO ()
forall a. IO a -> ContT ServerConfig IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ContT ServerConfig IO ())
-> IO () -> ContT ServerConfig IO ()
forall a b. (a -> b) -> a -> b
$ Result -> IO ()
rethrowR (Result -> IO ()) -> IO Result -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr ServerConfigBuilder
-> ConstPtr SliceBytes -> CSize -> IO Result
FFI.serverConfigBuilderSetALPNProtocols Ptr ServerConfigBuilder
builder ConstPtr SliceBytes
alpnPtr CSize
len

  IO () -> ContT ServerConfig IO ()
forall a. IO a -> ContT ServerConfig IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ContT ServerConfig IO ())
-> IO () -> ContT ServerConfig IO ()
forall a b. (a -> b) -> a -> b
$
    Result -> IO ()
rethrowR
      (Result -> IO ()) -> IO Result -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr ServerConfigBuilder -> CBool -> IO Result
FFI.serverConfigBuilderSetIgnoreClientOrder
        Ptr ServerConfigBuilder
builder
        (forall a. Num a => Bool -> a
fromBool @CBool Bool
serverConfigIgnoreClientOrder)

  (ConstPtr (ConstPtr CertifiedKey)
ptr, CSize
len) <- [CertifiedKey]
-> ContT ServerConfig IO (ConstPtr (ConstPtr CertifiedKey), CSize)
forall a.
[CertifiedKey]
-> ContT a IO (ConstPtr (ConstPtr CertifiedKey), CSize)
withCertifiedKeys (NonEmpty CertifiedKey -> [CertifiedKey]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty CertifiedKey
serverConfigCertifiedKeys)
  IO () -> ContT ServerConfig IO ()
forall a. IO a -> ContT ServerConfig IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ContT ServerConfig IO ())
-> IO () -> ContT ServerConfig IO ()
forall a b. (a -> b) -> a -> b
$ Result -> IO ()
rethrowR (Result -> IO ()) -> IO Result -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr ServerConfigBuilder
-> ConstPtr (ConstPtr CertifiedKey) -> CSize -> IO Result
FFI.serverConfigBuilderSetCertifiedKeys Ptr ServerConfigBuilder
builder ConstPtr (ConstPtr CertifiedKey)
ptr CSize
len

  Maybe ClientCertVerifier
-> (ClientCertVerifier -> ContT ServerConfig IO ())
-> ContT ServerConfig IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe ClientCertVerifier
serverConfigClientCertVerifier \ClientCertVerifier {[CertificateRevocationList]
NonEmpty PEMCertificates
ClientCertVerifierPolicy
clientCertVerifierPolicy :: ClientCertVerifierPolicy
clientCertVerifierCertificates :: NonEmpty PEMCertificates
clientCertVerifierCRLs :: [CertificateRevocationList]
clientCertVerifierPolicy :: ClientCertVerifier -> ClientCertVerifierPolicy
clientCertVerifierCertificates :: ClientCertVerifier -> NonEmpty PEMCertificates
clientCertVerifierCRLs :: ClientCertVerifier -> [CertificateRevocationList]
..} -> do
    ConstPtr RootCertStore
roots <- [PEMCertificates] -> ContT ServerConfig IO (ConstPtr RootCertStore)
forall a. [PEMCertificates] -> ContT a IO (ConstPtr RootCertStore)
withRootCertStore ([PEMCertificates]
 -> ContT ServerConfig IO (ConstPtr RootCertStore))
-> [PEMCertificates]
-> ContT ServerConfig IO (ConstPtr RootCertStore)
forall a b. (a -> b) -> a -> b
$ NonEmpty PEMCertificates -> [PEMCertificates]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty PEMCertificates
clientCertVerifierCertificates
    Ptr WebPkiClientCertVerifierBuilder
ccvb <-
      ((Ptr WebPkiClientCertVerifierBuilder -> IO ServerConfig)
 -> IO ServerConfig)
-> ContT ServerConfig IO (Ptr WebPkiClientCertVerifierBuilder)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((Ptr WebPkiClientCertVerifierBuilder -> IO ServerConfig)
  -> IO ServerConfig)
 -> ContT ServerConfig IO (Ptr WebPkiClientCertVerifierBuilder))
-> ((Ptr WebPkiClientCertVerifierBuilder -> IO ServerConfig)
    -> IO ServerConfig)
-> ContT ServerConfig IO (Ptr WebPkiClientCertVerifierBuilder)
forall a b. (a -> b) -> a -> b
$
        IO (Ptr WebPkiClientCertVerifierBuilder)
-> (Ptr WebPkiClientCertVerifierBuilder -> IO ())
-> (Ptr WebPkiClientCertVerifierBuilder -> IO ServerConfig)
-> IO ServerConfig
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket
          (ConstPtr RootCertStore -> IO (Ptr WebPkiClientCertVerifierBuilder)
FFI.webPkiClientCertVerifierBuilderNew ConstPtr RootCertStore
roots)
          Ptr WebPkiClientCertVerifierBuilder -> IO ()
FFI.webPkiClientCertVerifierBuilderFree
    [(Ptr CChar, Int)]
crls :: [CStringLen] <-
      [CertificateRevocationList]
-> (CertificateRevocationList
    -> ContT ServerConfig IO (Ptr CChar, Int))
-> ContT ServerConfig IO [(Ptr CChar, Int)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [CertificateRevocationList]
clientCertVerifierCRLs ((CertificateRevocationList
  -> ContT ServerConfig IO (Ptr CChar, Int))
 -> ContT ServerConfig IO [(Ptr CChar, Int)])
-> (CertificateRevocationList
    -> ContT ServerConfig IO (Ptr CChar, Int))
-> ContT ServerConfig IO [(Ptr CChar, Int)]
forall a b. (a -> b) -> a -> b
$
        (((Ptr CChar, Int) -> IO ServerConfig) -> IO ServerConfig)
-> ContT ServerConfig IO (Ptr CChar, Int)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT ((((Ptr CChar, Int) -> IO ServerConfig) -> IO ServerConfig)
 -> ContT ServerConfig IO (Ptr CChar, Int))
-> (CertificateRevocationList
    -> ((Ptr CChar, Int) -> IO ServerConfig) -> IO ServerConfig)
-> CertificateRevocationList
-> ContT ServerConfig IO (Ptr CChar, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString
-> ((Ptr CChar, Int) -> IO ServerConfig) -> IO ServerConfig
forall a. ByteString -> ((Ptr CChar, Int) -> IO a) -> IO a
BU.unsafeUseAsCStringLen (ByteString
 -> ((Ptr CChar, Int) -> IO ServerConfig) -> IO ServerConfig)
-> (CertificateRevocationList -> ByteString)
-> CertificateRevocationList
-> ((Ptr CChar, Int) -> IO ServerConfig)
-> IO ServerConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CertificateRevocationList -> ByteString
unCertificateRevocationList
    IO () -> ContT ServerConfig IO ()
forall a. IO a -> ContT ServerConfig IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
      case ClientCertVerifierPolicy
clientCertVerifierPolicy of
        ClientCertVerifierPolicy
AllowAnyAuthenticatedClient -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        ClientCertVerifierPolicy
AllowAnyAnonymousOrAuthenticatedClient ->
          Result -> IO ()
rethrowR (Result -> IO ()) -> IO Result -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr WebPkiClientCertVerifierBuilder -> IO Result
FFI.webPkiClientCertVerifierBuilderAllowUnauthenticated Ptr WebPkiClientCertVerifierBuilder
ccvb
      [(Ptr CChar, Int)] -> ((Ptr CChar, Int) -> IO Result) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(Ptr CChar, Int)]
crls \(Ptr CChar
ptr, Int
len) ->
        Ptr WebPkiClientCertVerifierBuilder
-> ConstPtr Word8 -> CSize -> IO Result
FFI.webPkiClientCertVerifierBuilderAddCrl
          Ptr WebPkiClientCertVerifierBuilder
ccvb
          (Ptr Word8 -> ConstPtr Word8
forall a. Ptr a -> ConstPtr a
ConstPtr (Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
ptr))
          (Int -> CSize
intToCSize Int
len)
    Ptr (Ptr ClientCertVerifier)
ccvPtr <- ((Ptr (Ptr ClientCertVerifier) -> IO ServerConfig)
 -> IO ServerConfig)
-> ContT ServerConfig IO (Ptr (Ptr ClientCertVerifier))
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (Ptr (Ptr ClientCertVerifier) -> IO ServerConfig)
-> IO ServerConfig
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca
    let buildCcv :: IO (Ptr ClientCertVerifier)
buildCcv = do
          Result -> IO ()
rethrowR (Result -> IO ()) -> IO Result -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr WebPkiClientCertVerifierBuilder
-> Ptr (Ptr ClientCertVerifier) -> IO Result
FFI.webPkiClientCertVerifierBuilderBuild Ptr WebPkiClientCertVerifierBuilder
ccvb Ptr (Ptr ClientCertVerifier)
ccvPtr
          Ptr (Ptr ClientCertVerifier) -> IO (Ptr ClientCertVerifier)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr ClientCertVerifier)
ccvPtr
    Ptr ClientCertVerifier
ccv <- ((Ptr ClientCertVerifier -> IO ServerConfig) -> IO ServerConfig)
-> ContT ServerConfig IO (Ptr ClientCertVerifier)
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((Ptr ClientCertVerifier -> IO ServerConfig) -> IO ServerConfig)
 -> ContT ServerConfig IO (Ptr ClientCertVerifier))
-> ((Ptr ClientCertVerifier -> IO ServerConfig) -> IO ServerConfig)
-> ContT ServerConfig IO (Ptr ClientCertVerifier)
forall a b. (a -> b) -> a -> b
$ IO (Ptr ClientCertVerifier)
-> (Ptr ClientCertVerifier -> IO ())
-> (Ptr ClientCertVerifier -> IO ServerConfig)
-> IO ServerConfig
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket IO (Ptr ClientCertVerifier)
buildCcv Ptr ClientCertVerifier -> IO ()
FFI.clientCertVerifierFree
    IO () -> ContT ServerConfig IO ()
forall a. IO a -> ContT ServerConfig IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ContT ServerConfig IO ())
-> IO () -> ContT ServerConfig IO ()
forall a b. (a -> b) -> a -> b
$ Ptr ServerConfigBuilder -> ConstPtr ClientCertVerifier -> IO ()
FFI.serverConfigBuilderSetClientVerifier Ptr ServerConfigBuilder
builder (Ptr ClientCertVerifier -> ConstPtr ClientCertVerifier
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr ClientCertVerifier
ccv)

  IO ServerConfig -> ContT ServerConfig IO ServerConfig
forall a. IO a -> ContT ServerConfig IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
    ForeignPtr ServerConfig
serverConfigPtr <-
      FinalizerPtr ServerConfig
-> Ptr ServerConfig -> IO (ForeignPtr ServerConfig)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr ServerConfig
FFI.serverConfigFree (Ptr ServerConfig -> IO (ForeignPtr ServerConfig))
-> (ConstPtr ServerConfig -> Ptr ServerConfig)
-> ConstPtr ServerConfig
-> IO (ForeignPtr ServerConfig)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstPtr ServerConfig -> Ptr ServerConfig
forall a. ConstPtr a -> Ptr a
unConstPtr
        (ConstPtr ServerConfig -> IO (ForeignPtr ServerConfig))
-> IO (ConstPtr ServerConfig) -> IO (ForeignPtr ServerConfig)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr ServerConfigBuilder -> IO (ConstPtr ServerConfig)
FFI.serverConfigBuilderBuild Ptr ServerConfigBuilder
builder
    let serverConfigLogCallback :: Maybe a
serverConfigLogCallback = Maybe a
forall a. Maybe a
Nothing
    ServerConfig -> IO ServerConfig
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ServerConfig {Maybe LogCallback
ForeignPtr ServerConfig
forall a. Maybe a
serverConfigLogCallback :: Maybe LogCallback
serverConfigPtr :: ForeignPtr ServerConfig
serverConfigLogCallback :: forall a. Maybe a
serverConfigPtr :: ForeignPtr ServerConfig
..}

-- | A 'ServerConfigBuilder' with good defaults.
defaultServerConfigBuilder :: NonEmpty CertifiedKey -> ServerConfigBuilder
defaultServerConfigBuilder :: NonEmpty CertifiedKey -> ServerConfigBuilder
defaultServerConfigBuilder NonEmpty CertifiedKey
certifiedKeys =
  ServerConfigBuilder
    { serverConfigCertifiedKeys :: NonEmpty CertifiedKey
serverConfigCertifiedKeys = NonEmpty CertifiedKey
certifiedKeys,
      serverConfigTLSVersions :: [TLSVersion]
serverConfigTLSVersions = [],
      serverConfigCipherSuites :: [CipherSuite]
serverConfigCipherSuites = [],
      serverConfigALPNProtocols :: [ALPNProtocol]
serverConfigALPNProtocols = [],
      serverConfigIgnoreClientOrder :: Bool
serverConfigIgnoreClientOrder = Bool
False,
      serverConfigClientCertVerifier :: Maybe ClientCertVerifier
serverConfigClientCertVerifier = Maybe ClientCertVerifier
forall a. Maybe a
Nothing
    }

-- | Allocate a new logging callback, taking a 'LogLevel' and a message.
--
-- If it throws an exception, it will be wrapped in a 'RustlsLogException' and
-- passed to 'reportError'.
--
-- 🚫 Make sure that its lifetime encloses those of the 'Connection's which you
-- configured to use it.
newLogCallback :: (LogLevel -> Text -> IO ()) -> Acquire LogCallback
newLogCallback :: (LogLevel -> Text -> IO ()) -> Acquire LogCallback
newLogCallback LogLevel -> Text -> IO ()
cb = (FunPtr LogCallback -> LogCallback)
-> Acquire (FunPtr LogCallback) -> Acquire LogCallback
forall a b. (a -> b) -> Acquire a -> Acquire b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FunPtr LogCallback -> LogCallback
LogCallback (Acquire (FunPtr LogCallback) -> Acquire LogCallback)
-> (IO (FunPtr LogCallback) -> Acquire (FunPtr LogCallback))
-> IO (FunPtr LogCallback)
-> Acquire LogCallback
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IO (FunPtr LogCallback)
 -> (FunPtr LogCallback -> IO ()) -> Acquire (FunPtr LogCallback))
-> (FunPtr LogCallback -> IO ())
-> IO (FunPtr LogCallback)
-> Acquire (FunPtr LogCallback)
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO (FunPtr LogCallback)
-> (FunPtr LogCallback -> IO ()) -> Acquire (FunPtr LogCallback)
forall a. IO a -> (a -> IO ()) -> Acquire a
mkAcquire FunPtr LogCallback -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr (IO (FunPtr LogCallback) -> Acquire LogCallback)
-> IO (FunPtr LogCallback) -> Acquire LogCallback
forall a b. (a -> b) -> a -> b
$
  LogCallback -> IO (FunPtr LogCallback)
FFI.mkLogCallback \Ptr Userdata
_ (ConstPtr Ptr LogParams
logParamsPtr) -> IO () -> IO ()
ignoreExceptions do
    FFI.LogParams {LogLevel
Str
rustlsLogParamsLevel :: LogLevel
rustlsLogParamsMessage :: Str
rustlsLogParamsLevel :: LogParams -> LogLevel
rustlsLogParamsMessage :: LogParams -> Str
..} <- Ptr LogParams -> IO LogParams
forall a. Storable a => Ptr a -> IO a
peek Ptr LogParams
logParamsPtr
    let logLevel :: Either LogLevel LogLevel
logLevel = case LogLevel
rustlsLogParamsLevel of
          FFI.LogLevel CSize
1 -> LogLevel -> Either LogLevel LogLevel
forall a b. b -> Either a b
Right LogLevel
LogLevelError
          FFI.LogLevel CSize
2 -> LogLevel -> Either LogLevel LogLevel
forall a b. b -> Either a b
Right LogLevel
LogLevelWarn
          FFI.LogLevel CSize
3 -> LogLevel -> Either LogLevel LogLevel
forall a b. b -> Either a b
Right LogLevel
LogLevelInfo
          FFI.LogLevel CSize
4 -> LogLevel -> Either LogLevel LogLevel
forall a b. b -> Either a b
Right LogLevel
LogLevelDebug
          FFI.LogLevel CSize
5 -> LogLevel -> Either LogLevel LogLevel
forall a b. b -> Either a b
Right LogLevel
LogLevelTrace
          LogLevel
l -> LogLevel -> Either LogLevel LogLevel
forall a b. a -> Either a b
Left LogLevel
l
    case Either LogLevel LogLevel
logLevel of
      Left LogLevel
l -> SomeException -> IO ()
report (SomeException -> IO ()) -> SomeException -> IO ()
forall a b. (a -> b) -> a -> b
$ RustlsUnknownLogLevel -> SomeException
forall e. Exception e => e -> SomeException
E.SomeException (RustlsUnknownLogLevel -> SomeException)
-> RustlsUnknownLogLevel -> SomeException
forall a b. (a -> b) -> a -> b
$ LogLevel -> RustlsUnknownLogLevel
RustlsUnknownLogLevel LogLevel
l
      Right LogLevel
logLevel -> do
        Text
msg <- Str -> IO Text
strToText Str
rustlsLogParamsMessage
        LogLevel -> Text -> IO ()
cb LogLevel
logLevel Text
msg IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` SomeException -> IO ()
report
  where
    report :: SomeException -> IO ()
report = SomeException -> IO ()
reportError (SomeException -> IO ())
-> (SomeException -> SomeException) -> SomeException -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RustlsLogException -> SomeException
forall e. Exception e => e -> SomeException
E.SomeException (RustlsLogException -> SomeException)
-> (SomeException -> RustlsLogException)
-> SomeException
-> SomeException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> RustlsLogException
RustlsLogException

newConnection ::
  Backend ->
  ForeignPtr config ->
  Maybe LogCallback ->
  (ConstPtr config -> Ptr (Ptr FFI.Connection) -> IO FFI.Result) ->
  Acquire (Connection side)
newConnection :: forall config (side :: Side).
Backend
-> ForeignPtr config
-> Maybe LogCallback
-> (ConstPtr config -> Ptr (Ptr Connection) -> IO Result)
-> Acquire (Connection side)
newConnection Backend
backend ForeignPtr config
configPtr Maybe LogCallback
logCallback ConstPtr config -> Ptr (Ptr Connection) -> IO Result
connectionNew =
  IO (Connection side)
-> (Connection side -> IO ()) -> Acquire (Connection side)
forall a. IO a -> (a -> IO ()) -> Acquire a
mkAcquire IO (Connection side)
forall {side :: Side}. IO (Connection side)
acquire Connection side -> IO ()
forall {side :: Side}. Connection side -> IO ()
release
  where
    acquire :: IO (Connection side)
acquire = do
      Ptr Connection
conn <-
        (Ptr (Ptr Connection) -> IO (Ptr Connection))
-> IO (Ptr Connection)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr (Ptr Connection)
connPtrPtr ->
          ForeignPtr config
-> (Ptr config -> IO (Ptr Connection)) -> IO (Ptr Connection)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr config
configPtr \Ptr config
cfgPtr -> IO (Ptr Connection) -> IO (Ptr Connection)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
            Result -> IO ()
rethrowR (Result -> IO ()) -> IO Result -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ConstPtr config -> Ptr (Ptr Connection) -> IO Result
connectionNew (Ptr config -> ConstPtr config
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr config
cfgPtr) Ptr (Ptr Connection)
connPtrPtr
            Ptr (Ptr Connection) -> IO (Ptr Connection)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr Connection)
connPtrPtr
      MVar IOMsgReq
ioMsgReq <- IO (MVar IOMsgReq)
forall a. IO (MVar a)
newEmptyMVar
      MVar IOMsgRes
ioMsgRes <- IO (MVar IOMsgRes)
forall a. IO (MVar a)
newEmptyMVar
      Ptr CSize
lenPtr <- IO (Ptr CSize)
forall a. Storable a => IO (Ptr a)
malloc
      let readWriteCallback :: (t -> Ptr Word8) -> p -> t -> CSize -> Ptr CSize -> IO IOResult
readWriteCallback t -> Ptr Word8
toBuf p
_ud t
buf CSize
len Ptr CSize
iPtr = do
            MVar IOMsgRes -> IOMsgRes -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar IOMsgRes
ioMsgRes (IOMsgRes -> IO ()) -> IOMsgRes -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> CSize -> Ptr CSize -> IOMsgRes
UsingBuffer (t -> Ptr Word8
toBuf t
buf) CSize
len Ptr CSize
iPtr
            Done IOResult
ioResult <- MVar IOMsgReq -> IO IOMsgReq
forall a. MVar a -> IO a
takeMVar MVar IOMsgReq
ioMsgReq
            IOResult -> IO IOResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IOResult
ioResult
      FunPtr ReadCallback
readCallback <- ReadCallback -> IO (FunPtr ReadCallback)
FFI.mkReadCallback (ReadCallback -> IO (FunPtr ReadCallback))
-> ReadCallback -> IO (FunPtr ReadCallback)
forall a b. (a -> b) -> a -> b
$ (Ptr Word8 -> Ptr Word8) -> ReadCallback
forall {t} {p}.
(t -> Ptr Word8) -> p -> t -> CSize -> Ptr CSize -> IO IOResult
readWriteCallback Ptr Word8 -> Ptr Word8
forall a. a -> a
id
      FunPtr WriteCallback
writeCallback <- WriteCallback -> IO (FunPtr WriteCallback)
FFI.mkWriteCallback (WriteCallback -> IO (FunPtr WriteCallback))
-> WriteCallback -> IO (FunPtr WriteCallback)
forall a b. (a -> b) -> a -> b
$ (ConstPtr Word8 -> Ptr Word8) -> WriteCallback
forall {t} {p}.
(t -> Ptr Word8) -> p -> t -> CSize -> Ptr CSize -> IO IOResult
readWriteCallback ConstPtr Word8 -> Ptr Word8
forall a. ConstPtr a -> Ptr a
unConstPtr
      let freeCallback :: IO ()
freeCallback = do
            FunPtr ReadCallback -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr FunPtr ReadCallback
readCallback
            FunPtr WriteCallback -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr FunPtr WriteCallback
writeCallback
          interact :: IO b
interact = IO () -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever do
            Request ReadOrWrite
readOrWrite <- MVar IOMsgReq -> IO IOMsgReq
forall a. MVar a -> IO a
takeMVar MVar IOMsgReq
ioMsgReq
            let readOrWriteTls :: Ptr Connection -> Ptr Userdata -> Ptr CSize -> IO IOResult
readOrWriteTls = case ReadOrWrite
readOrWrite of
                  ReadOrWrite
Read -> (Ptr Connection
 -> FunPtr ReadCallback -> Ptr Userdata -> Ptr CSize -> IO IOResult)
-> FunPtr ReadCallback
-> Ptr Connection
-> Ptr Userdata
-> Ptr CSize
-> IO IOResult
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ptr Connection
-> FunPtr ReadCallback -> Ptr Userdata -> Ptr CSize -> IO IOResult
FFI.connectionReadTls FunPtr ReadCallback
readCallback
                  ReadOrWrite
Write -> (Ptr Connection
 -> FunPtr WriteCallback
 -> Ptr Userdata
 -> Ptr CSize
 -> IO IOResult)
-> FunPtr WriteCallback
-> Ptr Connection
-> Ptr Userdata
-> Ptr CSize
-> IO IOResult
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ptr Connection
-> FunPtr WriteCallback -> Ptr Userdata -> Ptr CSize -> IO IOResult
FFI.connectionWriteTls FunPtr WriteCallback
writeCallback
            IOResult
_ <- Ptr Connection -> Ptr Userdata -> Ptr CSize -> IO IOResult
readOrWriteTls Ptr Connection
conn Ptr Userdata
forall a. Ptr a
nullPtr Ptr CSize
lenPtr
            MVar IOMsgRes -> IOMsgRes -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar IOMsgRes
ioMsgRes IOMsgRes
DoneFFI
      ThreadId
interactThread <- IO Any -> (Either SomeException Any -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally IO Any
forall {b}. IO b
interact (IO () -> Either SomeException Any -> IO ()
forall a b. a -> b -> a
const IO ()
freeCallback)
      Maybe LogCallback -> (LogCallback -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe LogCallback
logCallback ((LogCallback -> IO ()) -> IO ())
-> (LogCallback -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr Connection -> FunPtr LogCallback -> IO ()
FFI.connectionSetLogCallback Ptr Connection
conn (FunPtr LogCallback -> IO ())
-> (LogCallback -> FunPtr LogCallback) -> LogCallback -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogCallback -> FunPtr LogCallback
unLogCallback
      MVar Connection' -> Connection side
forall (side :: Side). MVar Connection' -> Connection side
Connection (MVar Connection' -> Connection side)
-> IO (MVar Connection') -> IO (Connection side)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection' -> IO (MVar Connection')
forall a. a -> IO (MVar a)
newMVar Connection' {Ptr CSize
Ptr Connection
MVar IOMsgRes
MVar IOMsgReq
ThreadId
Backend
backend :: Backend
conn :: Ptr Connection
ioMsgReq :: MVar IOMsgReq
ioMsgRes :: MVar IOMsgRes
lenPtr :: Ptr CSize
interactThread :: ThreadId
conn :: Ptr Connection
backend :: Backend
lenPtr :: Ptr CSize
ioMsgReq :: MVar IOMsgReq
ioMsgRes :: MVar IOMsgRes
interactThread :: ThreadId
..}
    release :: Connection side -> IO ()
release (Connection MVar Connection'
c) = do
      Just Connection' {Ptr CSize
Ptr Connection
MVar IOMsgRes
MVar IOMsgReq
ThreadId
Backend
conn :: Connection' -> Ptr Connection
backend :: Connection' -> Backend
lenPtr :: Connection' -> Ptr CSize
ioMsgReq :: Connection' -> MVar IOMsgReq
ioMsgRes :: Connection' -> MVar IOMsgRes
interactThread :: Connection' -> ThreadId
conn :: Ptr Connection
backend :: Backend
lenPtr :: Ptr CSize
ioMsgReq :: MVar IOMsgReq
ioMsgRes :: MVar IOMsgRes
interactThread :: ThreadId
..} <- MVar Connection' -> IO (Maybe Connection')
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar Connection'
c
      Ptr Connection -> IO ()
FFI.connectionFree Ptr Connection
conn
      Ptr CSize -> IO ()
forall a. Ptr a -> IO ()
free Ptr CSize
lenPtr
      ThreadId -> IO ()
killThread ThreadId
interactThread

-- | Initialize a TLS connection as a client.
newClientConnection ::
  Backend ->
  ClientConfig ->
  -- | Hostname.
  Text ->
  Acquire (Connection Client)
newClientConnection :: Backend -> ClientConfig -> Text -> Acquire (Connection 'Client)
newClientConnection Backend
b ClientConfig {Maybe LogCallback
ForeignPtr ClientConfig
clientConfigLogCallback :: ClientConfig -> Maybe LogCallback
clientConfigPtr :: ClientConfig -> ForeignPtr ClientConfig
clientConfigPtr :: ForeignPtr ClientConfig
clientConfigLogCallback :: Maybe LogCallback
..} Text
hostname =
  Backend
-> ForeignPtr ClientConfig
-> Maybe LogCallback
-> (ConstPtr ClientConfig -> Ptr (Ptr Connection) -> IO Result)
-> Acquire (Connection 'Client)
forall config (side :: Side).
Backend
-> ForeignPtr config
-> Maybe LogCallback
-> (ConstPtr config -> Ptr (Ptr Connection) -> IO Result)
-> Acquire (Connection side)
newConnection Backend
b ForeignPtr ClientConfig
clientConfigPtr Maybe LogCallback
clientConfigLogCallback \ConstPtr ClientConfig
configPtr Ptr (Ptr Connection)
connPtrPtr ->
    Text -> (Ptr CChar -> IO Result) -> IO Result
forall a. Text -> (Ptr CChar -> IO a) -> IO a
T.withCString Text
hostname \Ptr CChar
hostnamePtr ->
      ConstPtr ClientConfig
-> ConstCString -> Ptr (Ptr Connection) -> IO Result
FFI.clientConnectionNew ConstPtr ClientConfig
configPtr (Ptr CChar -> ConstCString
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr CChar
hostnamePtr) Ptr (Ptr Connection)
connPtrPtr

-- | Initialize a TLS connection as a server.
newServerConnection ::
  Backend ->
  ServerConfig ->
  Acquire (Connection Server)
newServerConnection :: Backend -> ServerConfig -> Acquire (Connection 'Server)
newServerConnection Backend
b ServerConfig {Maybe LogCallback
ForeignPtr ServerConfig
serverConfigLogCallback :: ServerConfig -> Maybe LogCallback
serverConfigPtr :: ServerConfig -> ForeignPtr ServerConfig
serverConfigPtr :: ForeignPtr ServerConfig
serverConfigLogCallback :: Maybe LogCallback
..} =
  Backend
-> ForeignPtr ServerConfig
-> Maybe LogCallback
-> (ConstPtr ServerConfig -> Ptr (Ptr Connection) -> IO Result)
-> Acquire (Connection 'Server)
forall config (side :: Side).
Backend
-> ForeignPtr config
-> Maybe LogCallback
-> (ConstPtr config -> Ptr (Ptr Connection) -> IO Result)
-> Acquire (Connection side)
newConnection Backend
b ForeignPtr ServerConfig
serverConfigPtr Maybe LogCallback
serverConfigLogCallback ConstPtr ServerConfig -> Ptr (Ptr Connection) -> IO Result
FFI.serverConnectionNew

-- | Ensure that the connection is handshaked. It is only necessary to call this
-- if you want to obtain connection information. You can do so by providing a
-- 'HandshakeQuery'.
--
-- >>> :{
-- getALPNAndTLSVersion ::
--   MonadIO m =>
--   Connection side ->
--   m (Maybe ALPNProtocol, TLSVersion)
-- getALPNAndTLSVersion conn =
--   handshake conn $ (,) <$> getALPNProtocol <*> getTLSVersion
-- :}
handshake :: (MonadIO m) => Connection side -> HandshakeQuery side a -> m a
handshake :: forall (m :: * -> *) (side :: Side) a.
MonadIO m =>
Connection side -> HandshakeQuery side a -> m a
handshake Connection side
conn (HandshakeQuery ReaderT Connection' IO a
query) = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
  Connection side -> (Connection' -> IO a) -> IO a
forall (side :: Side) a.
Connection side -> (Connection' -> IO a) -> IO a
withConnection Connection side
conn \Connection'
c -> do
    ()
_ <- Connection' -> IO ()
completePriorIO Connection'
c
    ReaderT Connection' IO a -> Connection' -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Connection' IO a
query Connection'
c

-- | Get the negotiated ALPN protocol, if any.
getALPNProtocol :: HandshakeQuery side (Maybe ALPNProtocol)
getALPNProtocol :: forall (side :: Side). HandshakeQuery side (Maybe ALPNProtocol)
getALPNProtocol = (Connection' -> IO (Maybe ALPNProtocol))
-> HandshakeQuery side (Maybe ALPNProtocol)
forall a (side :: Side).
(Connection' -> IO a) -> HandshakeQuery side a
handshakeQuery \Connection' {Ptr Connection
conn :: Connection' -> Ptr Connection
conn :: Ptr Connection
conn, Ptr CSize
lenPtr :: Connection' -> Ptr CSize
lenPtr :: Ptr CSize
lenPtr} ->
  (Ptr (ConstPtr Word8) -> IO (Maybe ALPNProtocol))
-> IO (Maybe ALPNProtocol)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr (ConstPtr Word8)
bufPtrPtr -> do
    ConstPtr Connection -> Ptr (ConstPtr Word8) -> Ptr CSize -> IO ()
FFI.connectionGetALPNProtocol (Ptr Connection -> ConstPtr Connection
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr Connection
conn) Ptr (ConstPtr Word8)
bufPtrPtr Ptr CSize
lenPtr
    ConstPtr Ptr Word8
bufPtr <- Ptr (ConstPtr Word8) -> IO (ConstPtr Word8)
forall a. Storable a => Ptr a -> IO a
peek Ptr (ConstPtr Word8)
bufPtrPtr
    CSize
len <- Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
lenPtr
    !ByteString
alpn <- (Ptr CChar, Int) -> IO ByteString
B.packCStringLen (Ptr Word8 -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
bufPtr, CSize -> Int
cSizeToInt CSize
len)
    Maybe ALPNProtocol -> IO (Maybe ALPNProtocol)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ALPNProtocol -> IO (Maybe ALPNProtocol))
-> Maybe ALPNProtocol -> IO (Maybe ALPNProtocol)
forall a b. (a -> b) -> a -> b
$ if ByteString -> Bool
B.null ByteString
alpn then Maybe ALPNProtocol
forall a. Maybe a
Nothing else ALPNProtocol -> Maybe ALPNProtocol
forall a. a -> Maybe a
Just (ALPNProtocol -> Maybe ALPNProtocol)
-> ALPNProtocol -> Maybe ALPNProtocol
forall a b. (a -> b) -> a -> b
$ ByteString -> ALPNProtocol
ALPNProtocol ByteString
alpn

-- | Get the negotiated TLS protocol version.
getTLSVersion :: HandshakeQuery side TLSVersion
getTLSVersion :: forall (side :: Side). HandshakeQuery side TLSVersion
getTLSVersion = (Connection' -> IO TLSVersion) -> HandshakeQuery side TLSVersion
forall a (side :: Side).
(Connection' -> IO a) -> HandshakeQuery side a
handshakeQuery \Connection' {Ptr Connection
conn :: Connection' -> Ptr Connection
conn :: Ptr Connection
conn} -> do
  !TLSVersion
ver <- ConstPtr Connection -> IO TLSVersion
FFI.connectionGetProtocolVersion (Ptr Connection -> ConstPtr Connection
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr Connection
conn)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TLSVersion -> Word16
unTLSVersion TLSVersion
ver Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    FilePath -> IO ()
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"internal rustls error: no protocol version negotiated"
  TLSVersion -> IO TLSVersion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TLSVersion
ver

-- | Get the negotiated cipher suite.
getCipherSuite :: HandshakeQuery side CipherSuite
getCipherSuite :: forall (side :: Side). HandshakeQuery side CipherSuite
getCipherSuite = (Connection' -> IO CipherSuite) -> HandshakeQuery side CipherSuite
forall a (side :: Side).
(Connection' -> IO a) -> HandshakeQuery side a
handshakeQuery \Connection' {Ptr Connection
conn :: Connection' -> Ptr Connection
conn :: Ptr Connection
conn} -> do
  !ConstPtr SupportedCipherSuite
cipherSuite <- ConstPtr Connection -> IO (ConstPtr SupportedCipherSuite)
FFI.connectionGetNegotiatedCipherSuite (Ptr Connection -> ConstPtr Connection
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr Connection
conn)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConstPtr SupportedCipherSuite
cipherSuite ConstPtr SupportedCipherSuite
-> ConstPtr SupportedCipherSuite -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr SupportedCipherSuite -> ConstPtr SupportedCipherSuite
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr SupportedCipherSuite
forall a. Ptr a
nullPtr) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    FilePath -> IO ()
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"internal rustls error: no cipher suite negotiated"
  CipherSuite -> IO CipherSuite
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CipherSuite -> IO CipherSuite) -> CipherSuite -> IO CipherSuite
forall a b. (a -> b) -> a -> b
$ ConstPtr SupportedCipherSuite -> CipherSuite
CipherSuite ConstPtr SupportedCipherSuite
cipherSuite

-- | Get the SNI hostname set by the client, if any.
getSNIHostname :: HandshakeQuery Server (Maybe Text)
getSNIHostname :: HandshakeQuery 'Server (Maybe Text)
getSNIHostname = (Connection' -> IO (Maybe Text))
-> HandshakeQuery 'Server (Maybe Text)
forall a (side :: Side).
(Connection' -> IO a) -> HandshakeQuery side a
handshakeQuery \Connection' {Ptr Connection
conn :: Connection' -> Ptr Connection
conn :: Ptr Connection
conn, Ptr CSize
lenPtr :: Connection' -> Ptr CSize
lenPtr :: Ptr CSize
lenPtr} ->
  let go :: CSize -> IO (Maybe Text)
go CSize
n = Int -> (Ptr Word8 -> IO (Maybe Text)) -> IO (Maybe Text)
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes (CSize -> Int
cSizeToInt CSize
n) \Ptr Word8
bufPtr -> do
        Result
res <- ConstPtr Connection -> Ptr Word8 -> CSize -> Ptr CSize -> IO Result
FFI.serverConnectionGetSNIHostname (Ptr Connection -> ConstPtr Connection
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr Connection
conn) Ptr Word8
bufPtr CSize
n Ptr CSize
lenPtr
        if Result
res Result -> Result -> Bool
forall a. Eq a => a -> a -> Bool
== Result
FFI.resultInsufficientSize
          then CSize -> IO (Maybe Text)
go (CSize
2 CSize -> CSize -> CSize
forall a. Num a => a -> a -> a
* CSize
n)
          else do
            Result -> IO ()
rethrowR Result
res
            CSize
len <- Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
lenPtr
            !Text
sni <- (Ptr CChar, Int) -> IO Text
T.peekCStringLen (Ptr Word8 -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
bufPtr, CSize -> Int
cSizeToInt CSize
len)
            Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ if Text -> Bool
T.null Text
sni then Maybe Text
forall a. Maybe a
Nothing else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
sni
   in CSize -> IO (Maybe Text)
go CSize
16

-- | A DER-encoded certificate.
newtype DERCertificate = DERCertificate {DERCertificate -> ByteString
unDERCertificate :: ByteString}
  deriving stock (Int -> DERCertificate -> ShowS
[DERCertificate] -> ShowS
DERCertificate -> FilePath
(Int -> DERCertificate -> ShowS)
-> (DERCertificate -> FilePath)
-> ([DERCertificate] -> ShowS)
-> Show DERCertificate
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DERCertificate -> ShowS
showsPrec :: Int -> DERCertificate -> ShowS
$cshow :: DERCertificate -> FilePath
show :: DERCertificate -> FilePath
$cshowList :: [DERCertificate] -> ShowS
showList :: [DERCertificate] -> ShowS
Show, DERCertificate -> DERCertificate -> Bool
(DERCertificate -> DERCertificate -> Bool)
-> (DERCertificate -> DERCertificate -> Bool) -> Eq DERCertificate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DERCertificate -> DERCertificate -> Bool
== :: DERCertificate -> DERCertificate -> Bool
$c/= :: DERCertificate -> DERCertificate -> Bool
/= :: DERCertificate -> DERCertificate -> Bool
Eq, Eq DERCertificate
Eq DERCertificate =>
(DERCertificate -> DERCertificate -> Ordering)
-> (DERCertificate -> DERCertificate -> Bool)
-> (DERCertificate -> DERCertificate -> Bool)
-> (DERCertificate -> DERCertificate -> Bool)
-> (DERCertificate -> DERCertificate -> Bool)
-> (DERCertificate -> DERCertificate -> DERCertificate)
-> (DERCertificate -> DERCertificate -> DERCertificate)
-> Ord DERCertificate
DERCertificate -> DERCertificate -> Bool
DERCertificate -> DERCertificate -> Ordering
DERCertificate -> DERCertificate -> DERCertificate
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: DERCertificate -> DERCertificate -> Ordering
compare :: DERCertificate -> DERCertificate -> Ordering
$c< :: DERCertificate -> DERCertificate -> Bool
< :: DERCertificate -> DERCertificate -> Bool
$c<= :: DERCertificate -> DERCertificate -> Bool
<= :: DERCertificate -> DERCertificate -> Bool
$c> :: DERCertificate -> DERCertificate -> Bool
> :: DERCertificate -> DERCertificate -> Bool
$c>= :: DERCertificate -> DERCertificate -> Bool
>= :: DERCertificate -> DERCertificate -> Bool
$cmax :: DERCertificate -> DERCertificate -> DERCertificate
max :: DERCertificate -> DERCertificate -> DERCertificate
$cmin :: DERCertificate -> DERCertificate -> DERCertificate
min :: DERCertificate -> DERCertificate -> DERCertificate
Ord, (forall x. DERCertificate -> Rep DERCertificate x)
-> (forall x. Rep DERCertificate x -> DERCertificate)
-> Generic DERCertificate
forall x. Rep DERCertificate x -> DERCertificate
forall x. DERCertificate -> Rep DERCertificate x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DERCertificate -> Rep DERCertificate x
from :: forall x. DERCertificate -> Rep DERCertificate x
$cto :: forall x. Rep DERCertificate x -> DERCertificate
to :: forall x. Rep DERCertificate x -> DERCertificate
Generic)

-- | Get the @i@-th certificate provided by the peer.
--
-- Index @0@ is the end entity certificate. Higher indices are certificates in
-- the chain. Requesting an index higher than what is available returns
-- 'Nothing'.
getPeerCertificate :: CSize -> HandshakeQuery side (Maybe DERCertificate)
getPeerCertificate :: forall (side :: Side).
CSize -> HandshakeQuery side (Maybe DERCertificate)
getPeerCertificate CSize
i = (Connection' -> IO (Maybe DERCertificate))
-> HandshakeQuery side (Maybe DERCertificate)
forall a (side :: Side).
(Connection' -> IO a) -> HandshakeQuery side a
handshakeQuery \Connection' {Ptr Connection
conn :: Connection' -> Ptr Connection
conn :: Ptr Connection
conn, Ptr CSize
lenPtr :: Connection' -> Ptr CSize
lenPtr :: Ptr CSize
lenPtr} -> do
  ConstPtr Certificate
certPtr <- ConstPtr Connection -> CSize -> IO (ConstPtr Certificate)
FFI.connectionGetPeerCertificate (Ptr Connection -> ConstPtr Connection
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr Connection
conn) CSize
i
  if ConstPtr Certificate
certPtr ConstPtr Certificate -> ConstPtr Certificate -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr Certificate -> ConstPtr Certificate
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr Certificate
forall a. Ptr a
nullPtr
    then Maybe DERCertificate -> IO (Maybe DERCertificate)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DERCertificate
forall a. Maybe a
Nothing
    else (Ptr (ConstPtr Word8) -> IO (Maybe DERCertificate))
-> IO (Maybe DERCertificate)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr (ConstPtr Word8)
bufPtrPtr -> do
      Result -> IO ()
rethrowR (Result -> IO ()) -> IO Result -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ConstPtr Certificate
-> Ptr (ConstPtr Word8) -> Ptr CSize -> IO Result
FFI.certificateGetDER ConstPtr Certificate
certPtr Ptr (ConstPtr Word8)
bufPtrPtr Ptr CSize
lenPtr
      ConstPtr Ptr Word8
bufPtr <- Ptr (ConstPtr Word8) -> IO (ConstPtr Word8)
forall a. Storable a => Ptr a -> IO a
peek Ptr (ConstPtr Word8)
bufPtrPtr
      Int
len <- CSize -> Int
cSizeToInt (CSize -> Int) -> IO CSize -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
lenPtr
      !ByteString
bs <- (Ptr CChar, Int) -> IO ByteString
B.packCStringLen (Ptr Word8 -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
bufPtr, Int
len)
      Maybe DERCertificate -> IO (Maybe DERCertificate)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DERCertificate -> IO (Maybe DERCertificate))
-> Maybe DERCertificate -> IO (Maybe DERCertificate)
forall a b. (a -> b) -> a -> b
$ DERCertificate -> Maybe DERCertificate
forall a. a -> Maybe a
Just (DERCertificate -> Maybe DERCertificate)
-> DERCertificate -> Maybe DERCertificate
forall a b. (a -> b) -> a -> b
$ ByteString -> DERCertificate
DERCertificate ByteString
bs

-- | Send a @close_notify@ warning alert. This informs the peer that the
-- connection is being closed.
sendCloseNotify :: (MonadIO m) => Connection side -> m ()
sendCloseNotify :: forall (m :: * -> *) (side :: Side).
MonadIO m =>
Connection side -> m ()
sendCloseNotify Connection side
conn = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
  Connection side -> (Connection' -> IO ()) -> IO ()
forall (side :: Side) a.
Connection side -> (Connection' -> IO a) -> IO a
withConnection Connection side
conn \c :: Connection'
c@Connection' {Ptr Connection
conn :: Connection' -> Ptr Connection
conn :: Ptr Connection
conn} -> do
    Ptr Connection -> IO ()
FFI.connectionSendCloseNotify Ptr Connection
conn
    IO IsEOF -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO IsEOF -> IO ()) -> IO IsEOF -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection' -> IO IsEOF
completeIO Connection'
c

-- | Read data from the Rustls 'Connection' into the given buffer.
readPtr :: (MonadIO m) => Connection side -> Ptr Word8 -> CSize -> m CSize
readPtr :: forall (m :: * -> *) (side :: Side).
MonadIO m =>
Connection side -> Ptr Word8 -> CSize -> m CSize
readPtr Connection side
conn Ptr Word8
buf CSize
len = IO CSize -> m CSize
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CSize -> m CSize) -> IO CSize -> m CSize
forall a b. (a -> b) -> a -> b
$
  Connection side -> (Connection' -> IO CSize) -> IO CSize
forall (side :: Side) a.
Connection side -> (Connection' -> IO a) -> IO a
withConnection Connection side
conn \c :: Connection'
c@Connection' {Ptr CSize
Ptr Connection
MVar IOMsgRes
MVar IOMsgReq
ThreadId
Backend
conn :: Connection' -> Ptr Connection
backend :: Connection' -> Backend
lenPtr :: Connection' -> Ptr CSize
ioMsgReq :: Connection' -> MVar IOMsgReq
ioMsgRes :: Connection' -> MVar IOMsgRes
interactThread :: Connection' -> ThreadId
conn :: Ptr Connection
backend :: Backend
lenPtr :: Ptr CSize
ioMsgReq :: MVar IOMsgReq
ioMsgRes :: MVar IOMsgRes
interactThread :: ThreadId
..} -> do
    Connection' -> IO ()
completePriorIO Connection'
c
    IO Bool -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m ()
loopWhileTrue (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$
      Connection' -> IO Bool
getWantsRead Connection'
c IO Bool -> (Bool -> IO Bool) -> IO Bool
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> (IsEOF
NotEOF ==) (IsEOF -> Bool) -> IO IsEOF -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection' -> IO IsEOF
completeIO Connection'
c
        Bool
False -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Result -> IO ()
rethrowR (Result -> IO ()) -> IO Result -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr Connection -> Ptr Word8 -> CSize -> Ptr CSize -> IO Result
FFI.connectionRead Ptr Connection
conn Ptr Word8
buf CSize
len Ptr CSize
lenPtr
    Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
lenPtr

-- | Read data from the Rustls 'Connection' into a 'ByteString'. The result will
-- not be longer than the given length.
readBS ::
  (MonadIO m) =>
  Connection side ->
  -- | Maximum result length. Note that a buffer of this size will be allocated.
  Int ->
  m ByteString
readBS :: forall (m :: * -> *) (side :: Side).
MonadIO m =>
Connection side -> Int -> m ByteString
readBS Connection side
conn Int
maxLen = IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$
  Int -> (Ptr Word8 -> IO Int) -> IO ByteString
BI.createAndTrim Int
maxLen \Ptr Word8
buf ->
    CSize -> Int
cSizeToInt (CSize -> Int) -> IO CSize -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection side -> Ptr Word8 -> CSize -> IO CSize
forall (m :: * -> *) (side :: Side).
MonadIO m =>
Connection side -> Ptr Word8 -> CSize -> m CSize
readPtr Connection side
conn Ptr Word8
buf (Int -> CSize
intToCSize Int
maxLen)

-- | Write data to the Rustls 'Connection' from the given buffer.
writePtr :: (MonadIO m) => Connection side -> Ptr Word8 -> CSize -> m CSize
writePtr :: forall (m :: * -> *) (side :: Side).
MonadIO m =>
Connection side -> Ptr Word8 -> CSize -> m CSize
writePtr Connection side
conn Ptr Word8
buf CSize
len = IO CSize -> m CSize
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CSize -> m CSize) -> IO CSize -> m CSize
forall a b. (a -> b) -> a -> b
$
  Connection side -> (Connection' -> IO CSize) -> IO CSize
forall (side :: Side) a.
Connection side -> (Connection' -> IO a) -> IO a
withConnection Connection side
conn \c :: Connection'
c@Connection' {Ptr CSize
Ptr Connection
MVar IOMsgRes
MVar IOMsgReq
ThreadId
Backend
conn :: Connection' -> Ptr Connection
backend :: Connection' -> Backend
lenPtr :: Connection' -> Ptr CSize
ioMsgReq :: Connection' -> MVar IOMsgReq
ioMsgRes :: Connection' -> MVar IOMsgRes
interactThread :: Connection' -> ThreadId
conn :: Ptr Connection
backend :: Backend
lenPtr :: Ptr CSize
ioMsgReq :: MVar IOMsgReq
ioMsgRes :: MVar IOMsgRes
interactThread :: ThreadId
..} -> do
    Connection' -> IO ()
completePriorIO Connection'
c
    Result -> IO ()
rethrowR (Result -> IO ()) -> IO Result -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr Connection -> Ptr Word8 -> CSize -> Ptr CSize -> IO Result
FFI.connectionWrite Ptr Connection
conn Ptr Word8
buf CSize
len Ptr CSize
lenPtr
    IsEOF
_ <- Connection' -> IO IsEOF
completeIO Connection'
c
    Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
lenPtr

-- | Write a 'ByteString' to the Rustls 'Connection'.
writeBS :: (MonadIO m) => Connection side -> ByteString -> m ()
writeBS :: forall (m :: * -> *) (side :: Side).
MonadIO m =>
Connection side -> ByteString -> m ()
writeBS Connection side
conn ByteString
bs = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ((Ptr CChar, Int) -> IO ()) -> IO ()
forall a. ByteString -> ((Ptr CChar, Int) -> IO a) -> IO a
BU.unsafeUseAsCStringLen ByteString
bs (Ptr CChar, Int) -> IO ()
forall {m :: * -> *} {b}. MonadIO m => (Ptr b, Int) -> m ()
go
  where
    go :: (Ptr b, Int) -> m ()
go (Ptr b
buf, Int
len) = do
      Int
written <- CSize -> Int
cSizeToInt (CSize -> Int) -> m CSize -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection side -> Ptr Word8 -> CSize -> m CSize
forall (m :: * -> *) (side :: Side).
MonadIO m =>
Connection side -> Ptr Word8 -> CSize -> m CSize
writePtr Connection side
conn (Ptr b -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr b
buf) (Int -> CSize
intToCSize Int
len)
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
written Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        (Ptr b, Int) -> m ()
go (Ptr b
buf Ptr b -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
len, Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
written)