-- | 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 alread 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 roots
--   let newConnection =
--         Rustls.newClientConnection socket 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.
--     roots = Rustls.ClientRootsFromFile "/etc/ssl/certs/ca-certificates.crt"
-- :}
--
-- == 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,
    ClientRoots (..),
    PEMCertificates (..),

    -- ** Config
    ClientConfig,
    clientConfigLogCallback,
    buildClientConfig,

    -- ** Open a connection
    newClientConnection,

    -- * Server

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

    -- ** 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 (..),
    ByteStringBackend (..),

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

    -- ** Exceptions
    RustlsException,
    isCertError,
  )
where

import Control.Concurrent (forkFinally, killThread)
import Control.Concurrent.MVar
import qualified Control.Exception as E
import Control.Monad (forever, when, (<=<))
import Control.Monad.IO.Class
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Reader
import Data.Acquire
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Internal as BI
import qualified Data.ByteString.Unsafe as BU
import Data.Coerce
import Data.Foldable (for_)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Foreign as T
import Foreign
import Foreign.C
import GHC.Generics (Generic)
import Rustls.Internal
import Rustls.Internal.FFI (TLSVersion (..))
import qualified Rustls.Internal.FFI as FFI
import System.IO (hPutStrLn, stderr)
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.9.1/rustls/0.20.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) => Ptr a -> CSize -> NonEmpty b
peekNonEmpty :: Ptr a -> CSize -> NonEmpty b
peekNonEmpty Ptr a
as CSize
len =
  [b] -> NonEmpty b
forall a. [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]
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 = Ptr TLSVersion -> CSize -> NonEmpty TLSVersion
forall a b.
(Storable a, Coercible a b) =>
Ptr a -> CSize -> NonEmpty b
peekNonEmpty Ptr TLSVersion
FFI.allVersions CSize
FFI.allVersionsLen
{-# NOINLINE allTLSVersions #-}

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

-- | All 'CipherSuite's supported by Rustls.
allCipherSuites :: NonEmpty CipherSuite
allCipherSuites :: NonEmpty CipherSuite
allCipherSuites = Ptr (Ptr SupportedCipherSuite) -> CSize -> NonEmpty CipherSuite
forall a b.
(Storable a, Coercible a b) =>
Ptr a -> CSize -> NonEmpty b
peekNonEmpty Ptr (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 = Ptr (Ptr SupportedCipherSuite) -> CSize -> NonEmpty CipherSuite
forall a b.
(Storable a, Coercible a b) =>
Ptr a -> CSize -> NonEmpty b
peekNonEmpty Ptr (Ptr SupportedCipherSuite)
FFI.defaultCipherSuites CSize
FFI.defaultCipherSuitesLen
{-# NOINLINE defaultCipherSuites #-}

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

withCertifiedKeys :: [CertifiedKey] -> ((Ptr (Ptr FFI.CertifiedKey), CSize) -> IO a) -> IO a
withCertifiedKeys :: [CertifiedKey] -> ((Ptr (Ptr CertifiedKey), CSize) -> IO a) -> IO a
withCertifiedKeys [CertifiedKey]
certifiedKeys (Ptr (Ptr CertifiedKey), CSize) -> IO a
cb =
  (CertifiedKey -> (Ptr CertifiedKey -> IO a) -> IO a)
-> [CertifiedKey] -> ([Ptr CertifiedKey] -> IO a) -> IO a
forall a b res.
(a -> (b -> res) -> res) -> [a] -> ([b] -> res) -> res
withMany CertifiedKey -> (Ptr CertifiedKey -> IO a) -> IO a
forall a. CertifiedKey -> (Ptr CertifiedKey -> IO a) -> IO a
withCertifiedKey [CertifiedKey]
certifiedKeys \[Ptr CertifiedKey]
certKeys ->
    [Ptr CertifiedKey]
-> (Int -> Ptr (Ptr CertifiedKey) -> IO a) -> IO a
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen [Ptr CertifiedKey]
certKeys \Int
len Ptr (Ptr CertifiedKey)
ptr -> (Ptr (Ptr CertifiedKey), CSize) -> IO a
cb (Ptr (Ptr CertifiedKey)
ptr, Int -> CSize
intToCSize Int
len)
  where
    withCertifiedKey :: CertifiedKey -> (Ptr CertifiedKey -> IO a) -> IO a
withCertifiedKey CertifiedKey {ByteString
privateKey :: CertifiedKey -> ByteString
certificateChain :: CertifiedKey -> ByteString
privateKey :: ByteString
certificateChain :: ByteString
..} Ptr CertifiedKey -> IO a
cb =
      ByteString -> (CStringLen -> IO a) -> IO a
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BU.unsafeUseAsCStringLen ByteString
certificateChain \(Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr -> Ptr Word8
certPtr, Int -> CSize
intToCSize -> CSize
certLen) ->
        ByteString -> (CStringLen -> IO a) -> IO a
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BU.unsafeUseAsCStringLen ByteString
privateKey \(Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr -> Ptr Word8
privPtr, Int -> CSize
intToCSize -> CSize
privLen) ->
          (Ptr (Ptr CertifiedKey) -> IO a) -> IO a
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr (Ptr CertifiedKey)
certKeyPtr -> do
            Result -> IO ()
rethrowR (Result -> IO ()) -> IO Result -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr Word8
-> CSize
-> Ptr Word8
-> CSize
-> Ptr (Ptr CertifiedKey)
-> IO Result
FFI.certifiedKeyBuild Ptr Word8
certPtr CSize
certLen Ptr Word8
privPtr CSize
privLen Ptr (Ptr CertifiedKey)
certKeyPtr
            Ptr CertifiedKey -> IO a
cb (Ptr CertifiedKey -> IO a) -> IO (Ptr CertifiedKey) -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr (Ptr CertifiedKey) -> IO (Ptr CertifiedKey)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr CertifiedKey)
certKeyPtr

withALPNProtocols :: [ALPNProtocol] -> ((Ptr FFI.SliceBytes, CSize) -> IO a) -> IO a
withALPNProtocols :: [ALPNProtocol] -> ((Ptr SliceBytes, CSize) -> IO a) -> IO a
withALPNProtocols [ALPNProtocol]
bss (Ptr SliceBytes, CSize) -> IO a
cb = do
  (ByteString -> (SliceBytes -> IO a) -> IO a)
-> [ByteString] -> ([SliceBytes] -> IO a) -> IO a
forall a b res.
(a -> (b -> res) -> res) -> [a] -> ([b] -> res) -> res
withMany ByteString -> (SliceBytes -> IO a) -> IO a
forall a. ByteString -> (SliceBytes -> IO a) -> IO a
withSliceBytes ([ALPNProtocol] -> [ByteString]
coerce [ALPNProtocol]
bss) \[SliceBytes]
bsPtrs ->
    [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 -> (Ptr SliceBytes, CSize) -> IO a
cb (Ptr SliceBytes
bsPtr, Int -> CSize
intToCSize Int
len)
  where
    withSliceBytes :: ByteString -> (SliceBytes -> IO a) -> IO a
withSliceBytes ByteString
bs SliceBytes -> IO a
cb =
      ByteString -> (CStringLen -> IO a) -> IO a
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BU.unsafeUseAsCStringLen ByteString
bs \(Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr -> Ptr Word8
buf, Int -> CSize
intToCSize -> CSize
len) ->
        SliceBytes -> IO a
cb (SliceBytes -> IO a) -> SliceBytes -> IO a
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> CSize -> SliceBytes
FFI.SliceBytes Ptr Word8
buf CSize
len

configBuilderNew ::
  ( Ptr (Ptr FFI.SupportedCipherSuite) ->
    CSize ->
    Ptr TLSVersion ->
    CSize ->
    Ptr (Ptr configBuilder) ->
    IO FFI.Result
  ) ->
  [CipherSuite] ->
  [TLSVersion] ->
  IO (Ptr configBuilder)
configBuilderNew :: (Ptr (Ptr SupportedCipherSuite)
 -> CSize
 -> Ptr TLSVersion
 -> CSize
 -> Ptr (Ptr configBuilder)
 -> IO Result)
-> [CipherSuite] -> [TLSVersion] -> IO (Ptr configBuilder)
configBuilderNew Ptr (Ptr SupportedCipherSuite)
-> CSize
-> Ptr 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, Ptr (Ptr SupportedCipherSuite)
cipherSuitesPtr) <-
    if [CipherSuite] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CipherSuite]
cipherSuites
      then (CSize, Ptr (Ptr SupportedCipherSuite))
-> ContT
     (Ptr configBuilder) IO (CSize, Ptr (Ptr SupportedCipherSuite))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CSize
FFI.defaultCipherSuitesLen, Ptr (Ptr SupportedCipherSuite)
FFI.defaultCipherSuites)
      else (((CSize, Ptr (Ptr SupportedCipherSuite))
  -> IO (Ptr configBuilder))
 -> IO (Ptr configBuilder))
-> ContT
     (Ptr configBuilder) IO (CSize, Ptr (Ptr SupportedCipherSuite))
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT \(CSize, Ptr (Ptr SupportedCipherSuite)) -> IO (Ptr configBuilder)
cb -> [Ptr SupportedCipherSuite]
-> (Int
    -> Ptr (Ptr SupportedCipherSuite) -> IO (Ptr configBuilder))
-> IO (Ptr configBuilder)
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen ([CipherSuite] -> [Ptr SupportedCipherSuite]
coerce [CipherSuite]
cipherSuites) \Int
len Ptr (Ptr SupportedCipherSuite)
ptr ->
        (CSize, Ptr (Ptr SupportedCipherSuite)) -> IO (Ptr configBuilder)
cb (Int -> CSize
intToCSize Int
len, Ptr (Ptr SupportedCipherSuite)
ptr)
  (CSize
tlsVersionsLen, Ptr TLSVersion
tlsVersionsPtr) <-
    if [TLSVersion] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TLSVersion]
tlsVersions
      then (CSize, Ptr TLSVersion)
-> ContT (Ptr configBuilder) IO (CSize, Ptr TLSVersion)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CSize
FFI.defaultVersionsLen, Ptr TLSVersion
FFI.defaultVersions)
      else (((CSize, Ptr TLSVersion) -> IO (Ptr configBuilder))
 -> IO (Ptr configBuilder))
-> ContT (Ptr configBuilder) IO (CSize, Ptr TLSVersion)
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT \(CSize, Ptr 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, Ptr TLSVersion) -> IO (Ptr configBuilder)
cb (Int -> CSize
intToCSize Int
len, Ptr TLSVersion
ptr)
  IO (Ptr configBuilder)
-> ContT (Ptr configBuilder) IO (Ptr configBuilder)
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
=<< Ptr (Ptr SupportedCipherSuite)
-> CSize
-> Ptr TLSVersion
-> CSize
-> Ptr (Ptr configBuilder)
-> IO Result
configBuilderNewCustom
        Ptr (Ptr SupportedCipherSuite)
cipherSuitesPtr
        CSize
cipherSuitesLen
        Ptr 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] -> (Ptr FFI.RootCertStore -> IO a) -> IO a
withRootCertStore :: [PEMCertificates] -> (Ptr RootCertStore -> IO a) -> IO a
withRootCertStore [PEMCertificates]
certs Ptr RootCertStore -> IO a
action =
  IO (Ptr RootCertStore)
-> (Ptr RootCertStore -> IO ())
-> (Ptr RootCertStore -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket IO (Ptr RootCertStore)
FFI.rootCertStoreNew Ptr RootCertStore -> IO ()
FFI.rootCertStoreFree \Ptr RootCertStore
store -> do
    let addPEM :: ByteString -> Bool -> IO ()
addPEM ByteString
bs (Num CBool => Bool -> CBool
forall a. Num a => Bool -> a
fromBool @CBool -> CBool
strict) = ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BU.unsafeUseAsCStringLen ByteString
bs \(Ptr CChar
buf, Int
len) ->
          Result -> IO ()
rethrowR (Result -> IO ()) -> IO Result -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr RootCertStore -> Ptr Word8 -> CSize -> CBool -> IO Result
FFI.rootCertStoreAddPEM Ptr RootCertStore
store (Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
buf) (Int -> CSize
intToCSize Int
len) CBool
strict
    [PEMCertificates] -> (PEMCertificates -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [PEMCertificates]
certs \case
      PEMCertificatesStrict ByteString
bs -> ByteString -> Bool -> IO ()
addPEM ByteString
bs Bool
True
      PEMCertificatesLax ByteString
bs -> ByteString -> Bool -> IO ()
addPEM ByteString
bs Bool
False
    Ptr RootCertStore -> IO a
action Ptr RootCertStore
store

-- | 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 :: ClientConfigBuilder -> m ClientConfig
buildClientConfig ClientConfigBuilder {Bool
[TLSVersion]
[CertifiedKey]
[CipherSuite]
[ALPNProtocol]
ClientRoots
clientConfigCertifiedKeys :: [CertifiedKey]
clientConfigEnableSNI :: Bool
clientConfigALPNProtocols :: [ALPNProtocol]
clientConfigCipherSuites :: [CipherSuite]
clientConfigTLSVersions :: [TLSVersion]
clientConfigRoots :: ClientRoots
clientConfigCertifiedKeys :: ClientConfigBuilder -> [CertifiedKey]
clientConfigEnableSNI :: ClientConfigBuilder -> Bool
clientConfigALPNProtocols :: ClientConfigBuilder -> [ALPNProtocol]
clientConfigRoots :: ClientConfigBuilder -> ClientRoots
clientConfigCipherSuites :: ClientConfigBuilder -> [CipherSuite]
clientConfigTLSVersions :: ClientConfigBuilder -> [TLSVersion]
..} = IO ClientConfig -> m ClientConfig
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
$
  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
    ( (Ptr (Ptr SupportedCipherSuite)
 -> CSize
 -> Ptr TLSVersion
 -> CSize
 -> Ptr (Ptr ClientConfigBuilder)
 -> IO Result)
-> [CipherSuite] -> [TLSVersion] -> IO (Ptr ClientConfigBuilder)
forall configBuilder.
(Ptr (Ptr SupportedCipherSuite)
 -> CSize
 -> Ptr TLSVersion
 -> CSize
 -> Ptr (Ptr configBuilder)
 -> IO Result)
-> [CipherSuite] -> [TLSVersion] -> IO (Ptr configBuilder)
configBuilderNew
        Ptr (Ptr SupportedCipherSuite)
-> CSize
-> Ptr TLSVersion
-> CSize
-> Ptr (Ptr ClientConfigBuilder)
-> IO Result
FFI.clientConfigBuilderNewCustom
        [CipherSuite]
clientConfigCipherSuites
        [TLSVersion]
clientConfigTLSVersions
    )
    Ptr ClientConfigBuilder -> IO ()
FFI.clientConfigBuilderFree
    \Ptr ClientConfigBuilder
builder -> do
      case ClientRoots
clientConfigRoots of
        ClientRootsFromFile FilePath
rootsPath ->
          FilePath -> (Ptr CChar -> IO ()) -> IO ()
forall a. FilePath -> (Ptr CChar -> IO a) -> IO a
withCString FilePath
rootsPath ((Ptr CChar -> IO ()) -> IO ()) -> (Ptr CChar -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
            Result -> IO ()
rethrowR (Result -> IO ()) -> (Ptr CChar -> IO Result) -> Ptr CChar -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Ptr ClientConfigBuilder -> Ptr CChar -> IO Result
FFI.clientConfigBuilderLoadRootsFromFile Ptr ClientConfigBuilder
builder
        ClientRootsInMemory [PEMCertificates]
certs ->
          [PEMCertificates] -> (Ptr RootCertStore -> IO ()) -> IO ()
forall a. [PEMCertificates] -> (Ptr RootCertStore -> IO a) -> IO a
withRootCertStore [PEMCertificates]
certs ((Ptr RootCertStore -> IO ()) -> IO ())
-> (Ptr RootCertStore -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Result -> IO ()
rethrowR (Result -> IO ())
-> (Ptr RootCertStore -> IO Result) -> Ptr RootCertStore -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Ptr ClientConfigBuilder -> Ptr RootCertStore -> IO Result
FFI.clientConfigBuilderUseRoots Ptr ClientConfigBuilder
builder
      [ALPNProtocol] -> ((Ptr SliceBytes, CSize) -> IO ()) -> IO ()
forall a.
[ALPNProtocol] -> ((Ptr SliceBytes, CSize) -> IO a) -> IO a
withALPNProtocols [ALPNProtocol]
clientConfigALPNProtocols \(Ptr SliceBytes
alpnPtr, CSize
len) ->
        Result -> IO ()
rethrowR (Result -> IO ()) -> IO Result -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr ClientConfigBuilder -> Ptr SliceBytes -> CSize -> IO Result
FFI.clientConfigBuilderSetALPNProtocols Ptr ClientConfigBuilder
builder Ptr SliceBytes
alpnPtr CSize
len
      Ptr ClientConfigBuilder -> CBool -> IO ()
FFI.clientConfigBuilderSetEnableSNI Ptr ClientConfigBuilder
builder (Bool -> CBool
forall a. Num a => Bool -> a
fromBool @CBool Bool
clientConfigEnableSNI)
      [CertifiedKey]
-> ((Ptr (Ptr CertifiedKey), CSize) -> IO ()) -> IO ()
forall a.
[CertifiedKey] -> ((Ptr (Ptr CertifiedKey), CSize) -> IO a) -> IO a
withCertifiedKeys [CertifiedKey]
clientConfigCertifiedKeys \(Ptr (Ptr CertifiedKey)
ptr, CSize
len) ->
        Result -> IO ()
rethrowR (Result -> IO ()) -> IO Result -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr ClientConfigBuilder
-> Ptr (Ptr CertifiedKey) -> CSize -> IO Result
FFI.clientConfigBuilderSetCertifiedKey Ptr ClientConfigBuilder
builder Ptr (Ptr CertifiedKey)
ptr CSize
len
      let clientConfigLogCallback :: Maybe a
clientConfigLogCallback = Maybe a
forall a. Maybe a
Nothing
      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))
-> IO (Ptr ClientConfig) -> IO (ForeignPtr ClientConfig)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr ClientConfigBuilder -> IO (Ptr ClientConfig)
FFI.clientConfigBuilderBuild Ptr ClientConfigBuilder
builder
      ClientConfig -> IO ClientConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientConfig :: ForeignPtr ClientConfig -> Maybe LogCallback -> ClientConfig
ClientConfig {Maybe LogCallback
ForeignPtr ClientConfig
forall a. Maybe a
clientConfigPtr :: ForeignPtr ClientConfig
clientConfigPtr :: ForeignPtr ClientConfig
clientConfigLogCallback :: forall a. Maybe a
clientConfigLogCallback :: Maybe LogCallback
..}

-- | 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 :: ServerConfigBuilder -> m ServerConfig
buildServerConfig ServerConfigBuilder {Bool
[TLSVersion]
[CipherSuite]
[ALPNProtocol]
Maybe ClientCertVerifier
NonEmpty CertifiedKey
serverConfigClientCertVerifier :: ServerConfigBuilder -> Maybe ClientCertVerifier
serverConfigIgnoreClientOrder :: ServerConfigBuilder -> Bool
serverConfigALPNProtocols :: ServerConfigBuilder -> [ALPNProtocol]
serverConfigCipherSuites :: ServerConfigBuilder -> [CipherSuite]
serverConfigTLSVersions :: ServerConfigBuilder -> [TLSVersion]
serverConfigCertifiedKeys :: ServerConfigBuilder -> NonEmpty CertifiedKey
serverConfigClientCertVerifier :: Maybe ClientCertVerifier
serverConfigIgnoreClientOrder :: Bool
serverConfigALPNProtocols :: [ALPNProtocol]
serverConfigCipherSuites :: [CipherSuite]
serverConfigTLSVersions :: [TLSVersion]
serverConfigCertifiedKeys :: NonEmpty CertifiedKey
..} = IO ServerConfig -> m ServerConfig
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
$
  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
    ( (Ptr (Ptr SupportedCipherSuite)
 -> CSize
 -> Ptr TLSVersion
 -> CSize
 -> Ptr (Ptr ServerConfigBuilder)
 -> IO Result)
-> [CipherSuite] -> [TLSVersion] -> IO (Ptr ServerConfigBuilder)
forall configBuilder.
(Ptr (Ptr SupportedCipherSuite)
 -> CSize
 -> Ptr TLSVersion
 -> CSize
 -> Ptr (Ptr configBuilder)
 -> IO Result)
-> [CipherSuite] -> [TLSVersion] -> IO (Ptr configBuilder)
configBuilderNew
        Ptr (Ptr SupportedCipherSuite)
-> CSize
-> Ptr TLSVersion
-> CSize
-> Ptr (Ptr ServerConfigBuilder)
-> IO Result
FFI.serverConfigBuilderNewCustom
        [CipherSuite]
serverConfigCipherSuites
        [TLSVersion]
serverConfigTLSVersions
    )
    Ptr ServerConfigBuilder -> IO ()
FFI.serverConfigBuilderFree
    \Ptr ServerConfigBuilder
builder -> do
      [ALPNProtocol] -> ((Ptr SliceBytes, CSize) -> IO ()) -> IO ()
forall a.
[ALPNProtocol] -> ((Ptr SliceBytes, CSize) -> IO a) -> IO a
withALPNProtocols [ALPNProtocol]
serverConfigALPNProtocols \(Ptr SliceBytes
alpnPtr, CSize
len) ->
        Result -> IO ()
rethrowR (Result -> IO ()) -> IO Result -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr ServerConfigBuilder -> Ptr SliceBytes -> CSize -> IO Result
FFI.serverConfigBuilderSetALPNProtocols Ptr ServerConfigBuilder
builder Ptr SliceBytes
alpnPtr CSize
len
      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
          (Bool -> CBool
forall a. Num a => Bool -> a
fromBool @CBool Bool
serverConfigIgnoreClientOrder)
      [CertifiedKey]
-> ((Ptr (Ptr CertifiedKey), CSize) -> IO ()) -> IO ()
forall a.
[CertifiedKey] -> ((Ptr (Ptr CertifiedKey), CSize) -> IO a) -> IO a
withCertifiedKeys (NonEmpty CertifiedKey -> [CertifiedKey]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty CertifiedKey
serverConfigCertifiedKeys) \(Ptr (Ptr CertifiedKey)
ptr, CSize
len) ->
        Result -> IO ()
rethrowR (Result -> IO ()) -> IO Result -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr ServerConfigBuilder
-> Ptr (Ptr CertifiedKey) -> CSize -> IO Result
FFI.serverConfigBuilderSetCertifiedKeys Ptr ServerConfigBuilder
builder Ptr (Ptr CertifiedKey)
ptr CSize
len
      let setBuilderCCV :: [PEMCertificates]
-> (Ptr RootCertStore -> IO a)
-> (a -> IO b)
-> (Ptr ServerConfigBuilder -> a -> IO a)
-> IO a
setBuilderCCV [PEMCertificates]
certs Ptr RootCertStore -> IO a
ccvNew a -> IO b
ccvFree Ptr ServerConfigBuilder -> a -> IO a
setCCV =
            [PEMCertificates] -> (Ptr RootCertStore -> IO a) -> IO a
forall a. [PEMCertificates] -> (Ptr RootCertStore -> IO a) -> IO a
withRootCertStore [PEMCertificates]
certs \Ptr RootCertStore
roots ->
              IO a -> (a -> IO b) -> (a -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket (Ptr RootCertStore -> IO a
ccvNew Ptr RootCertStore
roots) a -> IO b
ccvFree ((a -> IO a) -> IO a) -> (a -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ Ptr ServerConfigBuilder -> a -> IO a
setCCV Ptr ServerConfigBuilder
builder
      Maybe ClientCertVerifier -> (ClientCertVerifier -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe ClientCertVerifier
serverConfigClientCertVerifier \case
        ClientCertVerifier [PEMCertificates]
certs -> do
          [PEMCertificates]
-> (Ptr RootCertStore -> IO (Ptr ClientCertVerifier))
-> (Ptr ClientCertVerifier -> IO ())
-> (Ptr ServerConfigBuilder -> Ptr ClientCertVerifier -> IO ())
-> IO ()
forall a b a.
[PEMCertificates]
-> (Ptr RootCertStore -> IO a)
-> (a -> IO b)
-> (Ptr ServerConfigBuilder -> a -> IO a)
-> IO a
setBuilderCCV
            [PEMCertificates]
certs
            Ptr RootCertStore -> IO (Ptr ClientCertVerifier)
FFI.clientCertVerifierNew
            Ptr ClientCertVerifier -> IO ()
FFI.clientCertVerifierFree
            Ptr ServerConfigBuilder -> Ptr ClientCertVerifier -> IO ()
FFI.serverConfigBuilderSetClientVerifier
        ClientCertVerifierOptional [PEMCertificates]
certs -> do
          [PEMCertificates]
-> (Ptr RootCertStore -> IO (Ptr ClientCertVerifierOptional))
-> (Ptr ClientCertVerifierOptional -> IO ())
-> (Ptr ServerConfigBuilder
    -> Ptr ClientCertVerifierOptional -> IO ())
-> IO ()
forall a b a.
[PEMCertificates]
-> (Ptr RootCertStore -> IO a)
-> (a -> IO b)
-> (Ptr ServerConfigBuilder -> a -> IO a)
-> IO a
setBuilderCCV
            [PEMCertificates]
certs
            Ptr RootCertStore -> IO (Ptr ClientCertVerifierOptional)
FFI.clientCertVerifierOptionalNew
            Ptr ClientCertVerifierOptional -> IO ()
FFI.clientCertVerifierOptionalFree
            Ptr ServerConfigBuilder -> Ptr ClientCertVerifierOptional -> IO ()
FFI.serverConfigBuilderSetClientVerifierOptional
      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))
-> IO (Ptr ServerConfig) -> IO (ForeignPtr ServerConfig)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr ServerConfigBuilder -> IO (Ptr ServerConfig)
FFI.serverConfigBuilderBuild Ptr ServerConfigBuilder
builder
      let serverConfigLogCallback :: Maybe a
serverConfigLogCallback = Maybe a
forall a. Maybe a
Nothing
      ServerConfig -> IO ServerConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure ServerConfig :: ForeignPtr ServerConfig -> Maybe LogCallback -> ServerConfig
ServerConfig {Maybe LogCallback
ForeignPtr ServerConfig
forall a. Maybe a
serverConfigPtr :: ForeignPtr ServerConfig
serverConfigLogCallback :: forall a. Maybe a
serverConfigPtr :: ForeignPtr ServerConfig
serverConfigLogCallback :: Maybe LogCallback
..}

-- | A 'ServerConfigBuilder' with good defaults.
defaultServerConfigBuilder :: NonEmpty CertifiedKey -> ServerConfigBuilder
defaultServerConfigBuilder :: NonEmpty CertifiedKey -> ServerConfigBuilder
defaultServerConfigBuilder NonEmpty CertifiedKey
certifiedKeys =
  ServerConfigBuilder :: NonEmpty CertifiedKey
-> [TLSVersion]
-> [CipherSuite]
-> [ALPNProtocol]
-> Bool
-> Maybe ClientCertVerifier
-> ServerConfigBuilder
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.
--
-- 🚫 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 (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
_ Ptr LogParams
logParamsPtr -> IO () -> IO ()
ignoreExceptions do
    FFI.LogParams {LogLevel
Str
rustlsLogParamsMessage :: LogParams -> Str
rustlsLogParamsLevel :: LogParams -> LogLevel
rustlsLogParamsMessage :: Str
rustlsLogParamsLevel :: LogLevel
..} <- Ptr LogParams -> IO LogParams
forall a. Storable a => Ptr a -> IO a
peek Ptr LogParams
logParamsPtr
    let logLevel :: Either CSize LogLevel
logLevel = case LogLevel
rustlsLogParamsLevel of
          FFI.LogLevel CSize
1 -> LogLevel -> Either CSize LogLevel
forall a b. b -> Either a b
Right LogLevel
LogLevelError
          FFI.LogLevel CSize
2 -> LogLevel -> Either CSize LogLevel
forall a b. b -> Either a b
Right LogLevel
LogLevelWarn
          FFI.LogLevel CSize
3 -> LogLevel -> Either CSize LogLevel
forall a b. b -> Either a b
Right LogLevel
LogLevelInfo
          FFI.LogLevel CSize
4 -> LogLevel -> Either CSize LogLevel
forall a b. b -> Either a b
Right LogLevel
LogLevelDebug
          FFI.LogLevel CSize
5 -> LogLevel -> Either CSize LogLevel
forall a b. b -> Either a b
Right LogLevel
LogLevelTrace
          FFI.LogLevel CSize
l -> CSize -> Either CSize LogLevel
forall a b. a -> Either a b
Left CSize
l
    case Either CSize LogLevel
logLevel of
      Left CSize
l -> Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"invalid Rustls log level: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> CSize -> FilePath
forall a. Show a => a -> FilePath
show CSize
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
e :: E.SomeException) ->
          Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Rustls log callback errored: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> SomeException -> FilePath
forall e. Exception e => e -> FilePath
E.displayException SomeException
e

newConnection ::
  Backend b =>
  b ->
  ForeignPtr config ->
  Maybe LogCallback ->
  (Ptr config -> Ptr (Ptr FFI.Connection) -> IO FFI.Result) ->
  Acquire (Connection side)
newConnection :: b
-> ForeignPtr config
-> Maybe LogCallback
-> (Ptr config -> Ptr (Ptr Connection) -> IO Result)
-> Acquire (Connection side)
newConnection b
backend ForeignPtr config
configPtr Maybe LogCallback
logCallback Ptr 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 (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
=<< Ptr config -> Ptr (Ptr Connection) -> IO Result
connectionNew 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
      FunPtr ReadWriteCallback
readWriteCallback <- ReadWriteCallback -> IO (FunPtr ReadWriteCallback)
FFI.mkReadWriteCallback \Ptr Userdata
_ud Ptr Word8
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 Ptr Word8
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 (f :: * -> *) a. Applicative f => a -> f a
pure IOResult
ioResult
      let freeCallback :: IO ()
freeCallback = FunPtr ReadWriteCallback -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr FunPtr ReadWriteCallback
readWriteCallback
          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
-> FunPtr ReadWriteCallback
-> Ptr Userdata
-> Ptr CSize
-> IO IOResult
readOrWriteTls = case ReadOrWrite
readOrWrite of
                  ReadOrWrite
Read -> Ptr Connection
-> FunPtr ReadWriteCallback
-> Ptr Userdata
-> Ptr CSize
-> IO IOResult
FFI.connectionReadTls
                  ReadOrWrite
Write -> Ptr Connection
-> FunPtr ReadWriteCallback
-> Ptr Userdata
-> Ptr CSize
-> IO IOResult
FFI.connectionWriteTls
            IOResult
_ <- Ptr Connection
-> FunPtr ReadWriteCallback
-> Ptr Userdata
-> Ptr CSize
-> IO IOResult
readOrWriteTls Ptr Connection
conn FunPtr ReadWriteCallback
readWriteCallback 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' :: forall b.
Backend b =>
Ptr Connection
-> b
-> Ptr CSize
-> MVar IOMsgReq
-> MVar IOMsgRes
-> ThreadId
-> Connection'
Connection' {b
Ptr CSize
Ptr Connection
ThreadId
MVar IOMsgRes
MVar IOMsgReq
interactThread :: ThreadId
ioMsgRes :: MVar IOMsgRes
ioMsgReq :: MVar IOMsgReq
lenPtr :: Ptr CSize
backend :: b
conn :: Ptr Connection
interactThread :: ThreadId
lenPtr :: Ptr CSize
ioMsgRes :: MVar IOMsgRes
ioMsgReq :: MVar IOMsgReq
conn :: Ptr Connection
backend :: b
..}
    release :: Connection side -> IO ()
release (Connection MVar Connection'
c) = do
      Just Connection' {b
Ptr CSize
Ptr Connection
ThreadId
MVar IOMsgRes
MVar IOMsgReq
interactThread :: ThreadId
ioMsgRes :: MVar IOMsgRes
ioMsgReq :: MVar IOMsgReq
lenPtr :: Ptr CSize
backend :: b
conn :: Ptr Connection
interactThread :: Connection' -> ThreadId
ioMsgRes :: Connection' -> MVar IOMsgRes
ioMsgReq :: Connection' -> MVar IOMsgReq
lenPtr :: Connection' -> Ptr CSize
backend :: ()
conn :: Connection' -> Ptr Connection
..} <- 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 b =>
  b ->
  ClientConfig ->
  -- | Hostname.
  Text ->
  Acquire (Connection Client)
newClientConnection :: b -> ClientConfig -> Text -> Acquire (Connection 'Client)
newClientConnection b
b ClientConfig {Maybe LogCallback
ForeignPtr ClientConfig
clientConfigLogCallback :: Maybe LogCallback
clientConfigPtr :: ForeignPtr ClientConfig
clientConfigPtr :: ClientConfig -> ForeignPtr ClientConfig
clientConfigLogCallback :: ClientConfig -> Maybe LogCallback
..} Text
hostname =
  b
-> ForeignPtr ClientConfig
-> Maybe LogCallback
-> (Ptr ClientConfig -> Ptr (Ptr Connection) -> IO Result)
-> Acquire (Connection 'Client)
forall b config (side :: Side).
Backend b =>
b
-> ForeignPtr config
-> Maybe LogCallback
-> (Ptr config -> Ptr (Ptr Connection) -> IO Result)
-> Acquire (Connection side)
newConnection b
b ForeignPtr ClientConfig
clientConfigPtr Maybe LogCallback
clientConfigLogCallback \Ptr ClientConfig
configPtr Ptr (Ptr Connection)
connPtrPtr ->
    FilePath -> (Ptr CChar -> IO Result) -> IO Result
forall a. FilePath -> (Ptr CChar -> IO a) -> IO a
withCString (Text -> FilePath
T.unpack Text
hostname) \Ptr CChar
hostnamePtr ->
      Ptr ClientConfig -> Ptr CChar -> Ptr (Ptr Connection) -> IO Result
FFI.clientConnectionNew Ptr ClientConfig
configPtr Ptr CChar
hostnamePtr Ptr (Ptr Connection)
connPtrPtr

-- | Initialize a TLS connection as a server.
newServerConnection ::
  Backend b =>
  b ->
  ServerConfig ->
  Acquire (Connection Server)
newServerConnection :: b -> ServerConfig -> Acquire (Connection 'Server)
newServerConnection b
b ServerConfig {Maybe LogCallback
ForeignPtr ServerConfig
serverConfigLogCallback :: Maybe LogCallback
serverConfigPtr :: ForeignPtr ServerConfig
serverConfigPtr :: ServerConfig -> ForeignPtr ServerConfig
serverConfigLogCallback :: ServerConfig -> Maybe LogCallback
..} =
  b
-> ForeignPtr ServerConfig
-> Maybe LogCallback
-> (Ptr ServerConfig -> Ptr (Ptr Connection) -> IO Result)
-> Acquire (Connection 'Server)
forall b config (side :: Side).
Backend b =>
b
-> ForeignPtr config
-> Maybe LogCallback
-> (Ptr config -> Ptr (Ptr Connection) -> IO Result)
-> Acquire (Connection side)
newConnection b
b ForeignPtr ServerConfig
serverConfigPtr Maybe LogCallback
serverConfigLogCallback Ptr 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 :: Connection side -> HandshakeQuery side a -> m a
handshake Connection side
conn (HandshakeQuery ReaderT Connection' IO a
query) = 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' -> RunTLSMode -> IO ()
runTLS Connection'
c RunTLSMode
TLSHandshake
    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 :: 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 :: Ptr Connection
conn :: Connection' -> Ptr Connection
conn, Ptr CSize
lenPtr :: Ptr CSize
lenPtr :: Connection' -> Ptr CSize
lenPtr} ->
  (Ptr (Ptr Word8) -> IO (Maybe ALPNProtocol))
-> IO (Maybe ALPNProtocol)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr (Ptr Word8)
bufPtrPtr -> do
    Ptr Connection -> Ptr (Ptr Word8) -> Ptr CSize -> IO ()
FFI.connectionGetALPNProtocol Ptr Connection
conn Ptr (Ptr Word8)
bufPtrPtr Ptr CSize
lenPtr
    Ptr Word8
bufPtr <- Ptr (Ptr Word8) -> IO (Ptr Word8)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr Word8)
bufPtrPtr
    CSize
len <- Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
lenPtr
    !ByteString
alpn <- CStringLen -> 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 (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 :: 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 :: Ptr Connection
conn :: Connection' -> Ptr Connection
conn} -> do
  !TLSVersion
ver <- Ptr Connection -> IO TLSVersion
FFI.connectionGetProtocolVersion 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 (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"internal rustls error: no protocol version negotiated"
  TLSVersion -> IO TLSVersion
forall (f :: * -> *) a. Applicative f => a -> f a
pure TLSVersion
ver

-- | Get the negotiated cipher suite.
getCipherSuite :: HandshakeQuery side CipherSuite
getCipherSuite :: 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 :: Ptr Connection
conn :: Connection' -> Ptr Connection
conn} -> do
  !Ptr SupportedCipherSuite
cipherSuite <- Ptr Connection -> IO (Ptr SupportedCipherSuite)
FFI.connectionGetNegotiatedCipherSuite Ptr Connection
conn
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ptr SupportedCipherSuite
cipherSuite Ptr SupportedCipherSuite -> Ptr SupportedCipherSuite -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr SupportedCipherSuite
forall a. Ptr a
nullPtr) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    FilePath -> IO ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"internal rustls error: no cipher suite negotiated"
  CipherSuite -> IO CipherSuite
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CipherSuite -> IO CipherSuite) -> CipherSuite -> IO CipherSuite
forall a b. (a -> b) -> a -> b
$ Ptr SupportedCipherSuite -> CipherSuite
CipherSuite Ptr 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 :: Ptr Connection
conn :: Connection' -> Ptr Connection
conn, Ptr CSize
lenPtr :: Ptr CSize
lenPtr :: Connection' -> 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 <- Ptr Connection -> Ptr Word8 -> CSize -> Ptr CSize -> IO Result
FFI.serverConnectionGetSNIHostname 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 <- CStringLen -> 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 (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 -> FilePath -> FilePath
[DERCertificate] -> FilePath -> FilePath
DERCertificate -> FilePath
(Int -> DERCertificate -> FilePath -> FilePath)
-> (DERCertificate -> FilePath)
-> ([DERCertificate] -> FilePath -> FilePath)
-> Show DERCertificate
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [DERCertificate] -> FilePath -> FilePath
$cshowList :: [DERCertificate] -> FilePath -> FilePath
show :: DERCertificate -> FilePath
$cshow :: DERCertificate -> FilePath
showsPrec :: Int -> DERCertificate -> FilePath -> FilePath
$cshowsPrec :: Int -> DERCertificate -> FilePath -> FilePath
Show, DERCertificate -> DERCertificate -> Bool
(DERCertificate -> DERCertificate -> Bool)
-> (DERCertificate -> DERCertificate -> Bool) -> Eq DERCertificate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DERCertificate -> DERCertificate -> Bool
$c/= :: DERCertificate -> DERCertificate -> Bool
== :: DERCertificate -> DERCertificate -> Bool
$c== :: 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
min :: DERCertificate -> DERCertificate -> DERCertificate
$cmin :: DERCertificate -> DERCertificate -> DERCertificate
max :: DERCertificate -> DERCertificate -> DERCertificate
$cmax :: DERCertificate -> DERCertificate -> DERCertificate
>= :: DERCertificate -> DERCertificate -> Bool
$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
compare :: DERCertificate -> DERCertificate -> Ordering
$ccompare :: DERCertificate -> DERCertificate -> Ordering
$cp1Ord :: Eq 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
$cto :: forall x. Rep DERCertificate x -> DERCertificate
$cfrom :: forall x. DERCertificate -> Rep DERCertificate x
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 :: 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 :: Ptr Connection
conn :: Connection' -> Ptr Connection
conn, Ptr CSize
lenPtr :: Ptr CSize
lenPtr :: Connection' -> Ptr CSize
lenPtr} -> do
  Ptr Certificate
certPtr <- Ptr Connection -> CSize -> IO (Ptr Certificate)
FFI.connectionGetPeerCertificate Ptr Connection
conn CSize
i
  if Ptr Certificate
certPtr Ptr Certificate -> Ptr Certificate -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr Certificate
forall a. Ptr a
nullPtr
    then Maybe DERCertificate -> IO (Maybe DERCertificate)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DERCertificate
forall a. Maybe a
Nothing
    else (Ptr (Ptr Word8) -> IO (Maybe DERCertificate))
-> IO (Maybe DERCertificate)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr (Ptr Word8)
bufPtrPtr -> do
      Result -> IO ()
rethrowR (Result -> IO ()) -> IO Result -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr Certificate -> Ptr (Ptr Word8) -> Ptr CSize -> IO Result
FFI.certificateGetDER Ptr Certificate
certPtr Ptr (Ptr Word8)
bufPtrPtr Ptr CSize
lenPtr
      Ptr Word8
bufPtr <- Ptr (Ptr Word8) -> IO (Ptr Word8)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr 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 <- CStringLen -> 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 (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 :: Connection side -> m ()
sendCloseNotify Connection side
conn = IO () -> m ()
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 :: Ptr Connection
conn :: Connection' -> Ptr Connection
conn} -> do
    Ptr Connection -> IO ()
FFI.connectionSendCloseNotify Ptr Connection
conn
    Connection' -> RunTLSMode -> IO ()
runTLS Connection'
c RunTLSMode
TLSWrite

-- | Read data from the Rustls 'Connection' into the given buffer.
readPtr :: MonadIO m => Connection side -> Ptr Word8 -> CSize -> m CSize
readPtr :: Connection side -> Ptr Word8 -> CSize -> m CSize
readPtr Connection side
conn Ptr Word8
buf CSize
len = IO CSize -> m CSize
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' {b
Ptr CSize
Ptr Connection
ThreadId
MVar IOMsgRes
MVar IOMsgReq
interactThread :: ThreadId
ioMsgRes :: MVar IOMsgRes
ioMsgReq :: MVar IOMsgReq
lenPtr :: Ptr CSize
backend :: b
conn :: Ptr Connection
interactThread :: Connection' -> ThreadId
ioMsgRes :: Connection' -> MVar IOMsgRes
ioMsgReq :: Connection' -> MVar IOMsgReq
lenPtr :: Connection' -> Ptr CSize
backend :: ()
conn :: Connection' -> Ptr Connection
..} -> do
    Connection' -> RunTLSMode -> IO ()
runTLS Connection'
c RunTLSMode
TLSWrite
    Connection' -> RunTLSMode -> IO ()
runTLS Connection'
c RunTLSMode
TLSRead
    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 :: Connection side -> Int -> m ByteString
readBS Connection side
conn Int
maxLen = IO ByteString -> m ByteString
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 :: Connection side -> Ptr Word8 -> CSize -> m CSize
writePtr Connection side
conn Ptr Word8
buf CSize
len = IO CSize -> m CSize
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' {b
Ptr CSize
Ptr Connection
ThreadId
MVar IOMsgRes
MVar IOMsgReq
interactThread :: ThreadId
ioMsgRes :: MVar IOMsgRes
ioMsgReq :: MVar IOMsgReq
lenPtr :: Ptr CSize
backend :: b
conn :: Ptr Connection
interactThread :: Connection' -> ThreadId
ioMsgRes :: Connection' -> MVar IOMsgRes
ioMsgReq :: Connection' -> MVar IOMsgReq
lenPtr :: Connection' -> Ptr CSize
backend :: ()
conn :: Connection' -> Ptr Connection
..} -> do
    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
    Connection' -> RunTLSMode -> IO ()
runTLS Connection'
c RunTLSMode
TLSWrite
    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 :: Connection side -> ByteString -> m ()
writeBS Connection side
conn ByteString
bs = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BU.unsafeUseAsCStringLen ByteString
bs CStringLen -> 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)