diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,15 @@ # Revision history for rustls +## 0.2.0.0 -- 24.09.2024 + + * Use rustls-ffi 0.14.0. + * New feature: accessing the OS certificate store via + `rustls-platform-verifier`. + * Cipher suites are now tied to a specific cryptography provider. + * TLS versions are now automatically derived from the specified cipher + suites. + * Support GHC 9.10 + ## 0.1.0.0 -- 06.04.2024 * Use rustls-ffi 0.13.0, including new functionality (like recovactions) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -25,7 +25,7 @@ Make sure to have [Cargo](https://doc.rust-lang.org/stable/cargo/getting-started/installation.html) installed. Then, clone and install rustls-ffi: ```bash -git clone https://github.com/rustls/rustls-ffi -b v0.13.0 +git clone https://github.com/rustls/rustls-ffi -b v0.14.0 cd rustls-ffi make DESTDIR=/path/to/some/dir install ``` diff --git a/cbits/hs_rustls.h b/cbits/hs_rustls.h --- a/cbits/hs_rustls.h +++ b/cbits/hs_rustls.h @@ -17,4 +17,19 @@ *str = rustls_supported_ciphersuite_get_name(supported_ciphersuite); } +static inline void hs_rustls_connection_get_negotiated_ciphersuite_name( + const struct rustls_connection *conn, rustls_str *str); +static inline void hs_rustls_connection_get_negotiated_ciphersuite_name( + const struct rustls_connection *conn, rustls_str *str) { + *str = rustls_connection_get_negotiated_ciphersuite_name(conn); +} + +static inline uint16_t hs_rustls_supported_ciphersuite_protocol_version( + const struct rustls_supported_ciphersuite *supported_ciphersuite); +static inline uint16_t hs_rustls_supported_ciphersuite_protocol_version( + const struct rustls_supported_ciphersuite *supported_ciphersuite) { + return (uint16_t)rustls_supported_ciphersuite_protocol_version( + supported_ciphersuite); +} + #endif diff --git a/rustls.cabal b/rustls.cabal --- a/rustls.cabal +++ b/rustls.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: rustls -version: 0.1.0.0 +version: 0.2.0.0 synopsis: TLS bindings for Rustls description: TLS bindings for [Rustls](https://github.com/rustls/rustls) @@ -60,8 +60,10 @@ build-depends: base >=4.16 && <5, bytestring >=0.10 && <0.13, + containers >=0.6 && <0.8, derive-storable ^>=0.3, - network ^>=3.1, + mtl >=2.2 && <2.4, + network >=3.1 && <3.3, resourcet ^>=1.2 || ^>=1.3, text >=2.0 && <2.2, transformers >=0.5.6 && <0.7, @@ -83,10 +85,10 @@ async ^>=2.2, base, bytestring, - containers >=0.6 && <0.8, + containers, directory ^>=1.3, filepath >=1.4 && <1.6, - hedgehog >=1.0 && <1.5, + hedgehog >=1.0 && <1.6, process ^>=1.6, resourcet, rustls, diff --git a/src/Rustls.hs b/src/Rustls.hs --- a/src/Rustls.hs +++ b/src/Rustls.hs @@ -27,8 +27,7 @@ -- -- It is encouraged to share a single `clientConfig` when creating multiple -- -- TLS connections. -- clientConfig <- --- Rustls.buildClientConfig $ --- Rustls.defaultClientConfigBuilder serverCertVerifier +-- Rustls.buildClientConfig =<< Rustls.defaultClientConfigBuilder -- let backend = Rustls.mkSocketBackend socket -- newConnection = -- Rustls.newClientConnection backend clientConfig "example.org" @@ -36,18 +35,6 @@ -- 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' @@ -108,7 +95,7 @@ HandshakeQuery, getALPNProtocol, getTLSVersion, - getCipherSuite, + getNegotiatedCipherSuite, getSNIHostname, getPeerCertificate, @@ -132,6 +119,13 @@ mkSocketBackend, mkByteStringBackend, + -- ** Crypto provider + CryptoProvider, + getDefaultCryptoProvider, + setCryptoProviderCipherSuites, + cryptoProviderCipherSuites, + cryptoProviderTLSVersions, + -- ** Types ALPNProtocol (..), PEMCertificates (..), @@ -140,13 +134,8 @@ DERCertificate (..), CertificateRevocationList (..), TLSVersion (TLS12, TLS13, unTLSVersion), - defaultTLSVersions, - allTLSVersions, - CipherSuite, - cipherSuiteID, - showCipherSuite, - defaultCipherSuites, - allCipherSuites, + CipherSuite (..), + NegotiatedCipherSuite (..), -- ** Exceptions RustlsException, @@ -159,6 +148,7 @@ import Control.Concurrent.MVar import Control.Exception qualified as E import Control.Monad (forever, void, when) +import Control.Monad.Except (MonadError (..), liftEither) import Control.Monad.IO.Class import Control.Monad.Trans.Cont import Control.Monad.Trans.Reader @@ -168,9 +158,11 @@ import Data.ByteString.Internal qualified as BI import Data.ByteString.Unsafe qualified as BU import Data.Coerce +import Data.Containers.ListUtils (nubOrd) import Data.Foldable (for_, toList) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE +import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T import Data.Text.Foreign qualified as T @@ -189,52 +181,116 @@ -- >>> import Control.Monad.IO.Class -- >>> import Data.Acquire --- | Combined version string of Rustls and rustls-ffi. +-- | Combined version string of Rustls and rustls-ffi, as well as the Rustls +-- cryptography provider. -- -- >>> version --- "rustls-ffi/0.13.0/rustls/0.23.4" +-- "rustls-ffi/0.14.0/rustls/0.23.13/aws-lc-rs" version :: Text version = unsafePerformIO $ alloca \strPtr -> do FFI.hsVersion strPtr strToText =<< peek strPtr {-# NOINLINE version #-} -peekNonEmpty :: (Storable a, Coercible a b) => ConstPtr a -> CSize -> NonEmpty b -peekNonEmpty (ConstPtr as) len = - NE.fromList . coerce . unsafePerformIO $ peekArray (cSizeToInt len) as +buildCryptoProvider :: Ptr FFI.CryptoProviderBuilder -> IO CryptoProvider +buildCryptoProvider builder = alloca \cryptoProviderPtr -> do + rethrowR =<< FFI.cryptoProviderBuilderBuild builder cryptoProviderPtr + ConstPtr cryptoProviderPtr <- peek cryptoProviderPtr + CryptoProvider <$> newForeignPtr FFI.cryptoProviderFree cryptoProviderPtr --- | All 'TLSVersion's supported by Rustls. -allTLSVersions :: NonEmpty TLSVersion -allTLSVersions = peekNonEmpty FFI.allVersions FFI.allVersionsLen -{-# NOINLINE allTLSVersions #-} +-- | Get the process-wide default Rustls cryptography provider. +getDefaultCryptoProvider :: (MonadIO m) => m CryptoProvider +getDefaultCryptoProvider = liftIO $ E.mask_ $ evalContT do + builderPtr <- ContT alloca + builder <- + ContT $ + E.bracketOnError + do + -- This actually also sets the process-wide default crypto provider if + -- not already set, which is a side effect. + rethrowR =<< FFI.cryptoProviderBuilderNewFromDefault builderPtr + peek builderPtr + FFI.cryptoProviderBuilderFree + liftIO $ buildCryptoProvider builder --- | The default 'TLSVersion's used by Rustls. A subset of 'allTLSVersions'. -defaultTLSVersions :: NonEmpty TLSVersion -defaultTLSVersions = peekNonEmpty FFI.defaultVersions FFI.defaultVersionsLen -{-# NOINLINE defaultTLSVersions #-} +-- | Create a derived 'CryptoProvider' by restricting the cipher suites to the +-- ones in the given list. +setCryptoProviderCipherSuites :: + (MonadError RustlsException m) => + -- | Must be a subset of 'cryptoProviderCipherSuites'. Only the + -- 'cipherSuiteID' is used. + [CipherSuite] -> + CryptoProvider -> + m CryptoProvider +setCryptoProviderCipherSuites cipherSuites cryptoProvider = + liftEither $ unsafePerformIO $ E.try $ E.mask_ $ evalContT do + cryptoProviderPtr <- withCryptoProvider cryptoProvider + builder <- + ContT $ + E.bracketOnError + (FFI.cryptoProviderBuilderNewWithBase cryptoProviderPtr) + FFI.cryptoProviderBuilderFree --- | All 'CipherSuite's supported by Rustls. -allCipherSuites :: NonEmpty CipherSuite -allCipherSuites = peekNonEmpty FFI.allCipherSuites FFI.allCipherSuitesLen -{-# NOINLINE allCipherSuites #-} + let filteredCipherSuites = + [ cipherSuitePtr + | i <- [1 .. len], + let cipherSuitePtr = + FFI.cryptoProviderCiphersuitesGet cryptoProviderPtr (i - 1) + cipherSuiteID = FFI.supportedCipherSuiteGetSuite cipherSuitePtr, + cipherSuiteID `Set.member` cipherSuiteIDs + ] + where + len = FFI.cryptoProviderCiphersuitesLen cryptoProviderPtr + cipherSuiteIDs = Set.fromList $ cipherSuiteID <$> cipherSuites --- | The default 'CipherSuite's used by Rustls. A subset of 'allCipherSuites'. -defaultCipherSuites :: NonEmpty CipherSuite -defaultCipherSuites = peekNonEmpty FFI.defaultCipherSuites FFI.defaultCipherSuitesLen -{-# NOINLINE defaultCipherSuites #-} + (csPtr, csLen) <- ContT \cb -> withArrayLen filteredCipherSuites \len ptr -> + cb (ConstPtr ptr, intToCSize len) + liftIO $ rethrowR =<< FFI.cryptoProviderBuilderSetCipherSuites builder csPtr csLen --- | A 'ClientConfigBuilder' with good defaults. -defaultClientConfigBuilder :: ServerCertVerifier -> ClientConfigBuilder -defaultClientConfigBuilder serverCertVerifier = - ClientConfigBuilder - { clientConfigServerCertVerifier = serverCertVerifier, - clientConfigTLSVersions = [], - clientConfigCipherSuites = [], - clientConfigALPNProtocols = [], - clientConfigEnableSNI = True, - clientConfigCertifiedKeys = [] - } + liftIO $ buildCryptoProvider builder +withCryptoProvider :: CryptoProvider -> ContT a IO (ConstPtr FFI.CryptoProvider) +withCryptoProvider = + fmap ConstPtr . ContT . withForeignPtr . unCryptoProvider + +-- | Get the cipher suites supported by the given cryptography provider. +cryptoProviderCipherSuites :: CryptoProvider -> [CipherSuite] +cryptoProviderCipherSuites cryptoProvider = unsafePerformIO $ evalContT do + cryptoProviderPtr <- withCryptoProvider cryptoProvider + liftIO do + let len = FFI.cryptoProviderCiphersuitesLen cryptoProviderPtr + for [1 .. len] \i -> do + let cipherSuitePtr = FFI.cryptoProviderCiphersuitesGet cryptoProviderPtr (i - 1) + cipherSuiteID = FFI.supportedCipherSuiteGetSuite cipherSuitePtr + cipherSuiteName <- + alloca \strPtr -> do + FFI.hsSupportedCipherSuiteGetName cipherSuitePtr strPtr + strToText =<< peek strPtr + cipherSuiteTLSVersion <- + FFI.hsSupportedCiphersuiteProtocolVersion cipherSuitePtr + pure CipherSuite {..} + +-- | Get all TLS versions supported by at least one of the cipher suites +-- supported by the given cryptography provider. +cryptoProviderTLSVersions :: CryptoProvider -> [TLSVersion] +cryptoProviderTLSVersions = + nubOrd + . fmap cipherSuiteTLSVersion + . cryptoProviderCipherSuites + +-- | A 'ClientConfigBuilder' with good defaults, using the OS certificate store. +defaultClientConfigBuilder :: (MonadIO m) => m ClientConfigBuilder +defaultClientConfigBuilder = do + cryptoProvider <- getDefaultCryptoProvider + pure + ClientConfigBuilder + { clientConfigCryptoProvider = cryptoProvider, + clientConfigServerCertVerifier = PlatformServerCertVerifier, + clientConfigALPNProtocols = [], + clientConfigEnableSNI = True, + clientConfigCertifiedKeys = [] + } + withCertifiedKeys :: [CertifiedKey] -> ContT a IO (ConstPtr (ConstPtr FFI.CertifiedKey), CSize) withCertifiedKeys certifiedKeys = do certKeys <- for certifiedKeys withCertifiedKey @@ -264,33 +320,24 @@ pure $ FFI.SliceBytes (castPtr buf) (intToCSize len) configBuilderNew :: - ( ConstPtr (ConstPtr FFI.SupportedCipherSuite) -> - CSize -> + ( ConstPtr FFI.CryptoProvider -> ConstPtr TLSVersion -> CSize -> Ptr (Ptr configBuilder) -> IO FFI.Result ) -> - [CipherSuite] -> - [TLSVersion] -> + CryptoProvider -> IO (Ptr configBuilder) -configBuilderNew configBuilderNewCustom cipherSuites tlsVersions = evalContT do +configBuilderNew configBuilderNewCustom cryptoProvider = evalContT do + cryptoProviderPtr <- withCryptoProvider cryptoProvider builderPtr <- ContT alloca - (cipherSuitesLen, cipherSuitesPtr) <- - if null cipherSuites - then pure (FFI.defaultCipherSuitesLen, FFI.defaultCipherSuites) - else ContT \cb -> withArrayLen (coerce cipherSuites) \len ptr -> - cb (intToCSize len, ConstPtr ptr) (tlsVersionsLen, tlsVersionsPtr) <- - if null tlsVersions - then pure (FFI.defaultVersionsLen, FFI.defaultVersions) - else ContT \cb -> withArrayLen tlsVersions \len ptr -> - cb (intToCSize len, ConstPtr ptr) + ContT \cb -> withArrayLen (cryptoProviderTLSVersions cryptoProvider) \len ptr -> + cb (intToCSize len, ConstPtr ptr) liftIO do rethrowR =<< configBuilderNewCustom - cipherSuitesPtr - cipherSuitesLen + cryptoProviderPtr tlsVersionsPtr tlsVersionsLen builderPtr @@ -340,31 +387,36 @@ E.bracketOnError ( configBuilderNew FFI.clientConfigBuilderNewCustom - clientConfigCipherSuites - clientConfigTLSVersions + clientConfigCryptoProvider ) FFI.clientConfigBuilderFree - let ServerCertVerifier {..} = clientConfigServerCertVerifier - rootCertStore <- withRootCertStore $ toList serverCertVerifierCertificates - scvb <- - ContT $ - E.bracket - (FFI.webPkiServerCertVerifierBuilderNew rootCertStore) - FFI.webPkiServerCertVerifierBuilderFree - crls :: [CStringLen] <- - for serverCertVerifierCRLs $ - ContT . BU.unsafeUseAsCStringLen . unCertificateRevocationList - liftIO $ for_ crls \(ptr, len) -> - FFI.webPkiServerCertVerifierBuilderAddCrl - scvb - (ConstPtr (castPtr ptr)) - (intToCSize len) - scvPtr <- ContT alloca - let buildScv = do - rethrowR =<< FFI.webPkiServerCertVerifierBuilderBuild scvb scvPtr - peek scvPtr - scv <- ContT $ E.bracket buildScv FFI.serverCertVerifierFree + cryptoProviderPtr <- withCryptoProvider clientConfigCryptoProvider + + scv <- case clientConfigServerCertVerifier of + PlatformServerCertVerifier -> + withCryptoProvider clientConfigCryptoProvider + >>= liftIO . FFI.platformServerCertVerifierWithProvider + ServerCertVerifier {..} -> do + rootCertStore <- withRootCertStore $ toList serverCertVerifierCertificates + scvb <- + ContT $ + E.bracket + (FFI.webPkiServerCertVerifierBuilderNewWithProvider cryptoProviderPtr rootCertStore) + FFI.webPkiServerCertVerifierBuilderFree + crls :: [CStringLen] <- + for serverCertVerifierCRLs $ + ContT . BU.unsafeUseAsCStringLen . unCertificateRevocationList + liftIO $ for_ crls \(ptr, len) -> + FFI.webPkiServerCertVerifierBuilderAddCrl + scvb + (ConstPtr (castPtr ptr)) + (intToCSize len) + scvPtr <- ContT alloca + let buildScv = do + rethrowR =<< FFI.webPkiServerCertVerifierBuilderBuild scvb scvPtr + peek scvPtr + ContT $ E.bracket buildScv FFI.serverCertVerifierFree liftIO $ FFI.clientConfigBuilderSetServerVerifier builder (ConstPtr scv) (alpnPtr, len) <- withALPNProtocols clientConfigALPNProtocols @@ -378,10 +430,12 @@ let clientConfigLogCallback = Nothing + clientConfigPtrPtr <- ContT alloca liftIO do + rethrowR =<< FFI.clientConfigBuilderBuild builder clientConfigPtrPtr clientConfigPtr <- newForeignPtr FFI.clientConfigFree . unConstPtr - =<< FFI.clientConfigBuilderBuild builder + =<< peek clientConfigPtrPtr pure ClientConfig {..} -- | Build a 'ServerConfigBuilder' into a 'ServerConfig'. @@ -395,11 +449,12 @@ E.bracketOnError ( configBuilderNew FFI.serverConfigBuilderNewCustom - serverConfigCipherSuites - serverConfigTLSVersions + serverConfigCryptoProvider ) FFI.serverConfigBuilderFree + cryptoProviderPtr <- withCryptoProvider serverConfigCryptoProvider + (alpnPtr, len) <- withALPNProtocols serverConfigALPNProtocols liftIO $ rethrowR =<< FFI.serverConfigBuilderSetALPNProtocols builder alpnPtr len @@ -417,7 +472,7 @@ ccvb <- ContT $ E.bracket - (FFI.webPkiClientCertVerifierBuilderNew roots) + (FFI.webPkiClientCertVerifierBuilderNewWithProvider cryptoProviderPtr roots) FFI.webPkiClientCertVerifierBuilderFree crls :: [CStringLen] <- for clientCertVerifierCRLs $ @@ -439,24 +494,28 @@ ccv <- ContT $ E.bracket buildCcv FFI.clientCertVerifierFree liftIO $ FFI.serverConfigBuilderSetClientVerifier builder (ConstPtr ccv) + serverConfigPtrPtr <- ContT alloca liftIO do + rethrowR =<< FFI.serverConfigBuilderBuild builder serverConfigPtrPtr serverConfigPtr <- newForeignPtr FFI.serverConfigFree . unConstPtr - =<< FFI.serverConfigBuilderBuild builder + =<< peek serverConfigPtrPtr let serverConfigLogCallback = Nothing pure ServerConfig {..} -- | A 'ServerConfigBuilder' with good defaults. -defaultServerConfigBuilder :: NonEmpty CertifiedKey -> ServerConfigBuilder -defaultServerConfigBuilder certifiedKeys = - ServerConfigBuilder - { serverConfigCertifiedKeys = certifiedKeys, - serverConfigTLSVersions = [], - serverConfigCipherSuites = [], - serverConfigALPNProtocols = [], - serverConfigIgnoreClientOrder = False, - serverConfigClientCertVerifier = Nothing - } +defaultServerConfigBuilder :: + (MonadIO m) => NonEmpty CertifiedKey -> m ServerConfigBuilder +defaultServerConfigBuilder certifiedKeys = do + cryptoProvider <- getDefaultCryptoProvider + pure + ServerConfigBuilder + { serverConfigCryptoProvider = cryptoProvider, + serverConfigCertifiedKeys = certifiedKeys, + serverConfigALPNProtocols = [], + serverConfigIgnoreClientOrder = False, + serverConfigClientCertVerifier = Nothing + } -- | Allocate a new logging callback, taking a 'LogLevel' and a message. -- @@ -584,12 +643,20 @@ pure ver -- | Get the negotiated cipher suite. -getCipherSuite :: HandshakeQuery side CipherSuite -getCipherSuite = handshakeQuery \Connection' {conn} -> do - !cipherSuite <- FFI.connectionGetNegotiatedCipherSuite (ConstPtr conn) - when (cipherSuite == ConstPtr nullPtr) $ +getNegotiatedCipherSuite :: HandshakeQuery side NegotiatedCipherSuite +getNegotiatedCipherSuite = handshakeQuery \Connection' {conn} -> do + negotiatedCipherSuiteID <- + FFI.connectionGetNegotiatedCipherSuite (ConstPtr conn) + when (negotiatedCipherSuiteID == 0) $ fail "internal rustls error: no cipher suite negotiated" - pure $ CipherSuite cipherSuite + + negotiatedCipherSuiteName <- alloca \strPtr -> do + FFI.connectionGetNegotiatedCipherSuiteName (ConstPtr conn) strPtr + strToText =<< peek strPtr + when (T.null negotiatedCipherSuiteName) $ + fail "internal rustls error: no cipher suite negotiated" + + pure NegotiatedCipherSuite {..} -- | Get the SNI hostname set by the client, if any. getSNIHostname :: HandshakeQuery Server (Maybe Text) diff --git a/src/Rustls/Internal.hs b/src/Rustls/Internal.hs --- a/src/Rustls/Internal.hs +++ b/src/Rustls/Internal.hs @@ -12,7 +12,6 @@ import Data.ByteString qualified as B import Data.ByteString.Unsafe qualified as BU import Data.Coerce (coerce) -import Data.Function (on) import Data.Functor (void) import Data.List.NonEmpty (NonEmpty) import Data.Text (Text) @@ -26,47 +25,58 @@ import Rustls.Internal.FFI qualified as FFI import System.IO.Unsafe (unsafePerformIO) +-- | A cryptography provider for Rustls. +-- +-- In particular, this contains the set of supported TLS cipher suites. +newtype CryptoProvider = CryptoProvider + { unCryptoProvider :: ForeignPtr FFI.CryptoProvider + } + +instance Show CryptoProvider where + show _ = "CryptoProvider" + -- | An ALPN protocol ID. See -- -- for a list of registered IDs. newtype ALPNProtocol = ALPNProtocol {unALPNProtocol :: ByteString} deriving stock (Show, Eq, Ord, Generic) --- | A TLS cipher suite supported by Rustls. -newtype CipherSuite = CipherSuite (ConstPtr FFI.SupportedCipherSuite) - --- | Get the IANA value from a cipher suite. The bytes are interpreted in network order. --- --- See for a list. -cipherSuiteID :: CipherSuite -> Word16 -cipherSuiteID (CipherSuite cipherSuitePtr) = - FFI.supportedCipherSuiteGetSuite cipherSuitePtr - -instance Eq CipherSuite where - (==) = (==) `on` cipherSuiteID - -instance Ord CipherSuite where - compare = compare `on` cipherSuiteID - --- | Get the text representation of a cipher suite. -showCipherSuite :: CipherSuite -> Text -showCipherSuite (CipherSuite cipherSuitePtr) = unsafePerformIO $ - alloca \strPtr -> do - FFI.hsSupportedCipherSuiteGetName cipherSuitePtr strPtr - strToText =<< peek strPtr +-- | A TLS cipher suite supported by a Rustls cryptography provider. +data CipherSuite = CipherSuite + { -- | The IANA value of the cipher suite. The bytes are interpreted in + -- network order. + -- + -- See + -- + -- for a list. + cipherSuiteID :: Word16, + -- | The text representation of the cipher suite. + cipherSuiteName :: Text, + -- | The TLS version of the cipher suite. + cipherSuiteTLSVersion :: FFI.TLSVersion + } + deriving stock (Show, Eq, Ord, Generic) -instance Show CipherSuite where - show = T.unpack . showCipherSuite +-- | A negotiated TLS cipher suite. Subset of 'CipherSuite'. +data NegotiatedCipherSuite = NegotiatedCipherSuite + { -- | The IANA value of the cipher suite. The bytes are interpreted in + -- network order. + -- + -- See + -- + -- for a list. + negotiatedCipherSuiteID :: Word16, + -- | The text representation of the cipher suite. + negotiatedCipherSuiteName :: Text + } + deriving stock (Show, Eq, Ord, Generic) -- | Rustls client config builder. data ClientConfigBuilder = ClientConfigBuilder - { -- | The server certificate verifier. + { -- | The cryptography provider. + clientConfigCryptoProvider :: CryptoProvider, + -- | The server certificate verifier. clientConfigServerCertVerifier :: ServerCertVerifier, - -- | Supported 'FFI.TLSVersion's. When empty, good defaults are used. - clientConfigTLSVersions :: [FFI.TLSVersion], - -- | Supported 'CipherSuite's in order of preference. When empty, good - -- defaults are used. - clientConfigCipherSuites :: [CipherSuite], -- | ALPN protocols. clientConfigALPNProtocols :: [ALPNProtocol], -- | Whether to enable Server Name Indication. Defaults to 'True'. @@ -80,13 +90,18 @@ deriving stock (Show, Generic) -- | How to verify TLS server certificates. -data ServerCertVerifier = ServerCertVerifier - { -- | Certificates used to verify TLS server certificates. - serverCertVerifierCertificates :: NonEmpty PEMCertificates, - -- | List of certificate revocation lists used to verify TLS server - -- certificates. - serverCertVerifierCRLs :: [CertificateRevocationList] - } +data ServerCertVerifier + = -- | Verify the validity of TLS certificates based on the operating system's + -- certificate facilities, using + -- [rustls-platform-verifier](https://github.com/rustls/rustls-platform-verifier). + PlatformServerCertVerifier + | ServerCertVerifier + { -- | Certificates used to verify TLS server certificates. + serverCertVerifierCertificates :: NonEmpty PEMCertificates, + -- | List of certificate revocation lists used to verify TLS server + -- certificates. + serverCertVerifierCRLs :: [CertificateRevocationList] + } deriving stock (Show, Generic) -- | A source of PEM-encoded certificates. @@ -165,14 +180,10 @@ -- | Rustls client config builder. data ServerConfigBuilder = ServerConfigBuilder - { -- | List of 'CertifiedKey's. + { -- | The cryptography provider. + serverConfigCryptoProvider :: CryptoProvider, + -- | List of 'CertifiedKey's. serverConfigCertifiedKeys :: NonEmpty CertifiedKey, - -- | Supported 'FFI.TLSVersion's. When empty, good defaults are - -- used. - serverConfigTLSVersions :: [FFI.TLSVersion], - -- | Supported 'CipherSuite's in order of preference. When empty, good - -- defaults are used. - serverConfigCipherSuites :: [CipherSuite], -- | ALPN protocols. serverConfigALPNProtocols :: [ALPNProtocol], -- | Ignore the client's ciphersuite order. Defaults to 'False'. diff --git a/src/Rustls/Internal/FFI.hs b/src/Rustls/Internal/FFI.hs --- a/src/Rustls/Internal/FFI.hs +++ b/src/Rustls/Internal/FFI.hs @@ -17,10 +17,11 @@ clientConfigBuilderSetCertifiedKey, WebPkiServerCertVerifierBuilder, ServerCertVerifier, - webPkiServerCertVerifierBuilderNew, + webPkiServerCertVerifierBuilderNewWithProvider, webPkiServerCertVerifierBuilderAddCrl, webPkiServerCertVerifierBuilderFree, webPkiServerCertVerifierBuilderBuild, + platformServerCertVerifierWithProvider, serverCertVerifierFree, clientConfigBuilderSetServerVerifier, @@ -42,7 +43,7 @@ serverConfigBuilderSetCertifiedKeys, WebPkiClientCertVerifierBuilder, ClientCertVerifier, - webPkiClientCertVerifierBuilderNew, + webPkiClientCertVerifierBuilderNewWithProvider, webPkiClientCertVerifierBuilderAddCrl, webPkiClientCertVerifierBuilderAllowUnauthenticated, webPkiClientCertVerifierBuilderFree, @@ -85,6 +86,7 @@ connectionGetALPNProtocol, connectionGetProtocolVersion, connectionGetNegotiatedCipherSuite, + connectionGetNegotiatedCipherSuiteName, serverConnectionGetSNIHostname, connectionGetPeerCertificate, @@ -117,20 +119,25 @@ -- ** TLS params SupportedCipherSuite, - allCipherSuites, - allCipherSuitesLen, - defaultCipherSuites, - defaultCipherSuitesLen, supportedCipherSuiteGetSuite, hsSupportedCipherSuiteGetName, + hsSupportedCiphersuiteProtocolVersion, TLSVersion (..), pattern TLS12, pattern TLS13, - allVersions, - allVersionsLen, - defaultVersions, - defaultVersionsLen, + -- ** Crypto provider + CryptoProvider, + CryptoProviderBuilder, + cryptoProviderBuilderNewFromDefault, + cryptoProviderBuilderNewWithBase, + cryptoProviderBuilderSetCipherSuites, + cryptoProviderBuilderBuild, + cryptoProviderBuilderFree, + cryptoProviderFree, + cryptoProviderCiphersuitesLen, + cryptoProviderCiphersuitesGet, + -- ** Root cert store RootCertStoreBuilder, RootCertStore, @@ -206,8 +213,7 @@ foreign import capi unsafe "rustls.h rustls_client_config_builder_new_custom" clientConfigBuilderNewCustom :: - ConstPtr (ConstPtr SupportedCipherSuite) -> - CSize -> + ConstPtr CryptoProvider -> ConstPtr TLSVersion -> CSize -> Ptr (Ptr ClientConfigBuilder) -> @@ -217,7 +223,8 @@ clientConfigBuilderFree :: Ptr ClientConfigBuilder -> IO () foreign import capi unsafe "rustls.h rustls_client_config_builder_build" - clientConfigBuilderBuild :: Ptr ClientConfigBuilder -> IO (ConstPtr ClientConfig) + clientConfigBuilderBuild :: + Ptr ClientConfigBuilder -> Ptr (ConstPtr ClientConfig) -> IO Result foreign import capi unsafe "rustls.h &rustls_client_config_free" clientConfigFree :: FinalizerPtr ClientConfig @@ -249,9 +256,11 @@ {-# CTYPE "rustls.h" "rustls_server_cert_verifier" #-} ServerCertVerifier -foreign import capi unsafe "rustls.h rustls_web_pki_server_cert_verifier_builder_new" - webPkiServerCertVerifierBuilderNew :: - ConstPtr RootCertStore -> IO (Ptr WebPkiServerCertVerifierBuilder) +foreign import capi unsafe "rustls.h rustls_web_pki_server_cert_verifier_builder_new_with_provider" + webPkiServerCertVerifierBuilderNewWithProvider :: + ConstPtr CryptoProvider -> + ConstPtr RootCertStore -> + IO (Ptr WebPkiServerCertVerifierBuilder) foreign import capi unsafe "rustls.h rustls_web_pki_server_cert_verifier_builder_add_crl" webPkiServerCertVerifierBuilderAddCrl :: @@ -265,6 +274,10 @@ webPkiServerCertVerifierBuilderBuild :: Ptr WebPkiServerCertVerifierBuilder -> Ptr (Ptr ServerCertVerifier) -> IO Result +foreign import capi unsafe "rustls.h rustls_platform_server_cert_verifier_with_provider" + platformServerCertVerifierWithProvider :: + ConstPtr CryptoProvider -> IO (Ptr ServerCertVerifier) + foreign import capi unsafe "rustls.h rustls_server_cert_verifier_free" serverCertVerifierFree :: Ptr ServerCertVerifier -> IO () @@ -273,14 +286,14 @@ Ptr ClientConfigBuilder -> ConstPtr ServerCertVerifier -> IO () -- Server + data {-# CTYPE "rustls.h" "rustls_server_config" #-} ServerConfig data {-# CTYPE "rustls.h" "rustls_server_config_builder" #-} ServerConfigBuilder foreign import capi unsafe "rustls.h rustls_server_config_builder_new_custom" serverConfigBuilderNewCustom :: - ConstPtr (ConstPtr SupportedCipherSuite) -> - CSize -> + ConstPtr CryptoProvider -> ConstPtr TLSVersion -> CSize -> Ptr (Ptr ServerConfigBuilder) -> @@ -290,7 +303,8 @@ serverConfigBuilderFree :: Ptr ServerConfigBuilder -> IO () foreign import capi unsafe "rustls.h rustls_server_config_builder_build" - serverConfigBuilderBuild :: Ptr ServerConfigBuilder -> IO (ConstPtr ServerConfig) + serverConfigBuilderBuild :: + Ptr ServerConfigBuilder -> Ptr (ConstPtr ServerConfig) -> IO Result foreign import capi unsafe "rustls.h &rustls_server_config_free" serverConfigFree :: FinalizerPtr ServerConfig @@ -319,9 +333,11 @@ -- TODO all features? -foreign import capi unsafe "rustls.h rustls_web_pki_client_cert_verifier_builder_new" - webPkiClientCertVerifierBuilderNew :: - ConstPtr RootCertStore -> IO (Ptr WebPkiClientCertVerifierBuilder) +foreign import capi unsafe "rustls.h rustls_web_pki_client_cert_verifier_builder_new_with_provider" + webPkiClientCertVerifierBuilderNewWithProvider :: + ConstPtr CryptoProvider -> + ConstPtr RootCertStore -> + IO (Ptr WebPkiClientCertVerifierBuilder) foreign import capi unsafe "rustls.h rustls_web_pki_client_cert_verifier_builder_add_crl" webPkiClientCertVerifierBuilderAddCrl :: @@ -383,8 +399,11 @@ connectionGetProtocolVersion :: ConstPtr Connection -> IO TLSVersion foreign import capi unsafe "rustls.h rustls_connection_get_negotiated_ciphersuite" - connectionGetNegotiatedCipherSuite :: ConstPtr Connection -> IO (ConstPtr SupportedCipherSuite) + connectionGetNegotiatedCipherSuite :: ConstPtr Connection -> IO Word16 +foreign import capi unsafe "rustls.h hs_rustls_connection_get_negotiated_ciphersuite_name" + connectionGetNegotiatedCipherSuiteName :: ConstPtr Connection -> Ptr Str -> IO () + foreign import capi unsafe "rustls.h rustls_server_connection_get_server_name" serverConnectionGetSNIHostname :: ConstPtr Connection -> Ptr Word8 -> CSize -> Ptr CSize -> IO Result @@ -455,24 +474,15 @@ data {-# CTYPE "rustls.h" "rustls_supported_ciphersuite" #-} SupportedCipherSuite -foreign import capi "rustls.h value RUSTLS_ALL_CIPHER_SUITES" - allCipherSuites :: ConstPtr (Ptr SupportedCipherSuite) - -foreign import capi "rustls.h value RUSTLS_ALL_CIPHER_SUITES_LEN" - allCipherSuitesLen :: CSize - -foreign import capi "rustls.h value RUSTLS_DEFAULT_CIPHER_SUITES" - defaultCipherSuites :: ConstPtr (ConstPtr SupportedCipherSuite) - -foreign import capi "rustls.h value RUSTLS_DEFAULT_CIPHER_SUITES_LEN" - defaultCipherSuitesLen :: CSize - foreign import capi unsafe "rustls.h rustls_supported_ciphersuite_get_suite" supportedCipherSuiteGetSuite :: ConstPtr SupportedCipherSuite -> Word16 foreign import capi unsafe "hs_rustls.h hs_rustls_supported_ciphersuite_get_name" hsSupportedCipherSuiteGetName :: ConstPtr SupportedCipherSuite -> Ptr Str -> IO () +foreign import capi unsafe "hs_rustls.h hs_rustls_supported_ciphersuite_protocol_version" + hsSupportedCiphersuiteProtocolVersion :: ConstPtr SupportedCipherSuite -> IO TLSVersion + -- | A TLS protocol version supported by Rustls. newtype {-# CTYPE "stdint.h" "uint16_t" #-} TLSVersion = TLSVersion { unTLSVersion :: Word16 @@ -484,17 +494,43 @@ pattern TLS12 = TLSVersion 0x0303 pattern TLS13 = TLSVersion 0x0304 -foreign import capi "rustls.h value RUSTLS_ALL_VERSIONS" - allVersions :: ConstPtr TLSVersion +-- Crypto provider -foreign import capi "rustls.h value RUSTLS_ALL_VERSIONS_LEN" - allVersionsLen :: CSize +data {-# CTYPE "rustls.h" "rustls_crypto_provider" #-} CryptoProvider -foreign import capi "rustls.h value RUSTLS_DEFAULT_VERSIONS" - defaultVersions :: ConstPtr TLSVersion +data {-# CTYPE "rustls.h" "rustls_crypto_provider_builder" #-} CryptoProviderBuilder -foreign import capi "rustls.h value RUSTLS_DEFAULT_VERSIONS_LEN" - defaultVersionsLen :: CSize +foreign import capi unsafe "rustls.h rustls_crypto_provider_builder_new_from_default" + cryptoProviderBuilderNewFromDefault :: Ptr (Ptr CryptoProviderBuilder) -> IO Result + +foreign import capi unsafe "rustls.h rustls_crypto_provider_builder_new_with_base" + cryptoProviderBuilderNewWithBase :: ConstPtr CryptoProvider -> IO (Ptr CryptoProviderBuilder) + +foreign import capi unsafe "rustls.h rustls_crypto_provider_builder_set_cipher_suites" + cryptoProviderBuilderSetCipherSuites :: + Ptr CryptoProviderBuilder -> + ConstPtr (ConstPtr SupportedCipherSuite) -> + CSize -> + IO Result + +foreign import capi unsafe "rustls.h rustls_crypto_provider_builder_build" + cryptoProviderBuilderBuild :: + Ptr CryptoProviderBuilder -> + Ptr (ConstPtr CryptoProvider) -> + IO Result + +foreign import capi unsafe "rustls.h rustls_crypto_provider_builder_free" + cryptoProviderBuilderFree :: Ptr CryptoProviderBuilder -> IO () + +foreign import capi unsafe "rustls.h &rustls_crypto_provider_free" + cryptoProviderFree :: FinalizerPtr CryptoProvider + +foreign import capi unsafe "rustls.h rustls_crypto_provider_ciphersuites_len" + cryptoProviderCiphersuitesLen :: ConstPtr CryptoProvider -> CSize + +foreign import capi unsafe "rustls.h rustls_crypto_provider_ciphersuites_get" + cryptoProviderCiphersuitesGet :: + ConstPtr CryptoProvider -> CSize -> ConstPtr SupportedCipherSuite -- Root cert store diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -11,12 +11,12 @@ import Data.Acquire import Data.ByteString (ByteString) import Data.ByteString qualified as B +import Data.Containers.ListUtils (nubOrd) import Data.Foldable (for_) import Data.Functor (void) import Data.IORef -import Data.List.NonEmpty qualified as NE -import Data.Maybe (fromMaybe, isJust) -import Data.Set qualified as S +import Data.Maybe (isJust) +import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T import Hedgehog @@ -36,30 +36,27 @@ main = defaultMain . testGroup "Basic Rustls tests" $ [ testCase "TLS versions" do - S.fromList [Rustls.TLS12, Rustls.TLS13] - @?= S.fromList (NE.toList Rustls.defaultTLSVersions) - assertBool "Unexpected default TLS versions" $ - S.fromList (NE.toList Rustls.defaultTLSVersions) - `S.isSubsetOf` S.fromList (NE.toList Rustls.allTLSVersions), + cryptoProvider <- Rustls.getDefaultCryptoProvider + Set.fromList [Rustls.TLS12, Rustls.TLS13] + @?= Set.fromList (Rustls.cryptoProviderTLSVersions cryptoProvider), testCase "Cipher suites" do - let defaultCipherSuites = S.fromList (NE.toList Rustls.defaultCipherSuites) - allCipherSuites = S.fromList (NE.toList Rustls.allCipherSuites) - assertBool "Unexpected default cipher suites" $ - defaultCipherSuites `S.isSubsetOf` allCipherSuites - assertBool "Misbehaving ID function for cipher suites" $ - S.map Rustls.cipherSuiteID defaultCipherSuites - `S.isSubsetOf` S.map Rustls.cipherSuiteID allCipherSuites - assertBool "Misbehaving display function for cipher suites" $ - S.map Rustls.showCipherSuite defaultCipherSuites - `S.isSubsetOf` S.map Rustls.showCipherSuite allCipherSuites, + cryptoProvider <- Rustls.getDefaultCryptoProvider + let cipherSuites = Rustls.cryptoProviderCipherSuites cryptoProvider + nubOrd cipherSuites @=? cipherSuites + let cipherSuiteIDs = Rustls.cipherSuiteID <$> cipherSuites + nubOrd cipherSuiteIDs @=? cipherSuiteIDs + let cipherSuiteNames = Rustls.cipherSuiteName <$> cipherSuites + nubOrd cipherSuiteNames @=? cipherSuiteNames, testInMemory ] testInMemory :: TestTree testInMemory = withMiniCA \(fmap snd -> getMiniCA) -> testProperty "Test in-memory TLS" $ property do - testSetup <- forAll . genTestSetup =<< liftIO getMiniCA + cryptoProvider <- liftIO Rustls.getDefaultCryptoProvider + testSetup <- forAll . genTestSetup cryptoProvider =<< liftIO getMiniCA + (res, tlsLogLines) <- runInMemoryTest testSetup footnote $ "TLS log:\n" <> T.unpack (T.unlines tlsLogLines) @@ -68,13 +65,15 @@ Rustls.ClientConfigBuilder {..} = clientConfigBuilder Rustls.ServerConfigBuilder {..} = serverConfigBuilder clientTLSVersions = - nonEmptySet Rustls.defaultTLSVersions clientConfigTLSVersions + Set.fromList $ Rustls.cryptoProviderTLSVersions clientConfigCryptoProvider serverTLSVersions = - nonEmptySet Rustls.defaultTLSVersions serverConfigTLSVersions + Set.fromList $ Rustls.cryptoProviderTLSVersions serverConfigCryptoProvider clientCipherSuites = - nonEmptySet Rustls.defaultCipherSuites clientConfigCipherSuites + Set.fromList . fmap toNegotiatedCipherSuite $ + Rustls.cryptoProviderCipherSuites clientConfigCryptoProvider serverCipherSuites = - nonEmptySet Rustls.defaultCipherSuites serverConfigCipherSuites + Set.fromList . fmap toNegotiatedCipherSuite $ + Rustls.cryptoProviderCipherSuites serverConfigCryptoProvider case res of Right TestOutcome {..} -> do label "Success" @@ -84,18 +83,18 @@ then sniHostname === Just testHostname else sniHostname === Nothing assert $ - S.fromList [clientTLSVersion, serverTLSVersion] - `S.isSubsetOf` S.fromList [Rustls.TLS12, Rustls.TLS13] + Set.fromList [clientTLSVersion, serverTLSVersion] + `Set.isSubsetOf` Set.fromList [Rustls.TLS12, Rustls.TLS13] negotiatedClientALPNProtocol === negotiatedServerALPNProtocol assert $ - maybe S.empty S.singleton negotiatedClientALPNProtocol - `S.isSubsetOf` ( S.fromList clientConfigALPNProtocols - `S.intersection` S.fromList serverConfigALPNProtocols - ) + maybe Set.empty Set.singleton negotiatedClientALPNProtocol + `Set.isSubsetOf` ( Set.fromList clientConfigALPNProtocols + `Set.intersection` Set.fromList serverConfigALPNProtocols + ) clientCipherSuite === serverCipherSuite assert $ clientCipherSuite - `S.member` (clientCipherSuites `S.intersection` serverCipherSuites) + `Set.member` (clientCipherSuites `Set.intersection` serverCipherSuites) assert $ isJust clientPeerCert case Rustls.clientCertVerifierPolicy <$> serverConfigClientCertVerifier of Nothing -> @@ -105,21 +104,24 @@ Just Rustls.AllowAnyAnonymousOrAuthenticatedClient -> isJust serverPeerCert /== null clientConfigCertifiedKeys Left (ex :: Rustls.RustlsException) -> do - label "Expected TLS failure" annotate $ E.displayException ex if - | S.fromList clientConfigALPNProtocols - `S.disjoint` S.fromList serverConfigALPNProtocols -> + | Set.fromList clientConfigALPNProtocols + `Set.disjoint` Set.fromList serverConfigALPNProtocols -> do + label "Expected TLS failure: No common ALPN protocol" success - | clientTLSVersions `S.disjoint` serverTLSVersions -> + | clientTLSVersions `Set.disjoint` serverTLSVersions -> do + label "Expected TLS failure: No common TLS version" success | Just Rustls.AllowAnyAuthenticatedClient <- Rustls.clientCertVerifierPolicy <$> serverConfigClientCertVerifier, - null clientConfigCertifiedKeys -> + null clientConfigCertifiedKeys -> do + label "Expected TLS failure: No client cert" success + | Rustls.PlatformServerCertVerifier <- clientConfigServerCertVerifier -> do + label "Expected TLS failure: Platform verifier denies self-signed cert" + success | otherwise -> failure - where - nonEmptySet def = S.fromList . NE.toList . fromMaybe def . NE.nonEmpty testHostname :: Text testHostname = "example.org" @@ -140,28 +142,31 @@ miniCAClientCertKey, miniCAServerCertKey :: Rustls.CertifiedKey } -genTestSetup :: (MonadGen m) => MiniCA -> m TestSetup -genTestSetup MiniCA {..} = do +genTestSetup :: (MonadGen m) => Rustls.CryptoProvider -> MiniCA -> m TestSetup +genTestSetup cryptoProvider MiniCA {..} = do commonALPNProtocols <- genALPNProtocols + clientConfigCryptoProvider <- genCryptoProvider clientConfigServerCertVerifier <- do - parsing <- Gen.enumBounded - serverCertVerifierCertificates <- - pure - <$> Gen.element - [ Rustls.PEMCertificatesInMemory miniCACert parsing, - Rustls.PemCertificatesFromFile miniCAFile parsing - ] - let serverCertVerifierCRLs = [] -- TODO test this - pure Rustls.ServerCertVerifier {..} + Gen.frequency + [ (1, pure Rustls.PlatformServerCertVerifier), + (10,) do + parsing <- Gen.enumBounded + serverCertVerifierCertificates <- + pure + <$> Gen.element + [ Rustls.PEMCertificatesInMemory miniCACert parsing, + Rustls.PemCertificatesFromFile miniCAFile parsing + ] + let serverCertVerifierCRLs = [] -- TODO test this + pure Rustls.ServerCertVerifier {..} + ] clientConfigALPNProtocols <- (commonALPNProtocols <>) <$> genALPNProtocols clientConfigEnableSNI <- Gen.bool_ - clientConfigTLSVersions <- genTLSVersions clientConfigCertifiedKeys <- Gen.subsequence [miniCAClientCertKey] - let clientConfigCipherSuites = getCipherSuites clientConfigTLSVersions - clientConfigBuilder = Rustls.ClientConfigBuilder {..} + let clientConfigBuilder = Rustls.ClientConfigBuilder {..} + serverConfigCryptoProvider <- genCryptoProvider serverConfigALPNProtocols <- (commonALPNProtocols <>) <$> genALPNProtocols serverConfigIgnoreClientOrder <- Gen.bool_ - serverConfigTLSVersions <- genTLSVersions serverConfigClientCertVerifier <- Gen.maybe do clientCertVerifierPolicy <- Gen.enumBounded let clientCertVerifierCertificates = @@ -171,8 +176,7 @@ Rustls.PEMCertificateParsingStrict clientCertVerifierCRLs = [] -- TODO test this pure Rustls.ClientCertVerifier {..} - let serverConfigCipherSuites = getCipherSuites serverConfigTLSVersions - serverConfigCertifiedKeys = pure miniCAServerCertKey + let serverConfigCertifiedKeys = pure miniCAServerCertKey serverConfigBuilder = Rustls.ServerConfigBuilder {..} clientSends <- -- TODO using 0 as a lower bound should work, but causes timeouts for some @@ -185,16 +189,31 @@ genALPNProtocols = Gen.list (Range.constant 0 10) $ Rustls.ALPNProtocol <$> Gen.bytes (Range.constant 1 10) - genTLSVersions = - Gen.shuffle =<< Gen.subsequence (NE.toList Rustls.allTLSVersions) - getCipherSuites tlsVersions = - filter ((`elem` tlsVersions) . tlsVersionFromCipherSuite) $ - NE.toList Rustls.allCipherSuites + genCryptoProvider = + Gen.frequency + [ (1, pure cryptoProvider), + (10,) do + tlsVersions <- Gen.shuffle =<< Gen.subsequence allTLSVersions + let cipherSuites = + [ cipherSuite + | cipherSuite <- allCipherSuites, + Rustls.cipherSuiteTLSVersion cipherSuite `elem` tlsVersions + ] + pure case Rustls.setCryptoProviderCipherSuites cipherSuites cryptoProvider of + Left e -> error $ "unexpected: " <> show e + Right cp -> cp + ] + where + allTLSVersions = Rustls.cryptoProviderTLSVersions cryptoProvider + allCipherSuites = Rustls.cryptoProviderCipherSuites cryptoProvider + data TestOutcome = TestOutcome - { negotiatedClientALPNProtocol, negotiatedServerALPNProtocol :: Maybe Rustls.ALPNProtocol, + { negotiatedClientALPNProtocol, + negotiatedServerALPNProtocol :: + Maybe Rustls.ALPNProtocol, clientTLSVersion, serverTLSVersion :: Rustls.TLSVersion, - clientCipherSuite, serverCipherSuite :: Rustls.CipherSuite, + clientCipherSuite, serverCipherSuite :: Rustls.NegotiatedCipherSuite, sniHostname :: Maybe Text, clientPeerCert, serverPeerCert :: Maybe Rustls.DERCertificate, clientReceived, serverReceived :: [ByteString] @@ -220,7 +239,7 @@ (,,,,) <$> Rustls.getALPNProtocol <*> Rustls.getTLSVersion - <*> Rustls.getCipherSuite + <*> Rustls.getNegotiatedCipherSuite <*> Rustls.getSNIHostname <*> Rustls.getPeerCertificate 0 received <- @@ -246,7 +265,7 @@ (,,,) <$> Rustls.getALPNProtocol <*> Rustls.getTLSVersion - <*> Rustls.getCipherSuite + <*> Rustls.getNegotiatedCipherSuite <*> Rustls.getPeerCertificate 0 received <- recordOutput . for_ clientSends $ \bs -> do Rustls.writeBS conn bs @@ -331,10 +350,9 @@ line = "[" <> id <> "] [" <> lvlTxt <> "] " <> msg atomicModifyIORef' ref ((,()) . (line :)) -tlsVersionFromCipherSuite :: Rustls.CipherSuite -> Rustls.TLSVersion -tlsVersionFromCipherSuite cipherSuite - | "TLS_" `T.isPrefixOf` str = Rustls.TLS12 - | "TLS13_" `T.isPrefixOf` str = Rustls.TLS13 - | otherwise = error "unexpected cipher suite" - where - str = Rustls.showCipherSuite cipherSuite +toNegotiatedCipherSuite :: Rustls.CipherSuite -> Rustls.NegotiatedCipherSuite +toNegotiatedCipherSuite Rustls.CipherSuite {..} = + Rustls.NegotiatedCipherSuite + { negotiatedCipherSuiteID = cipherSuiteID, + negotiatedCipherSuiteName = cipherSuiteName + }