rustls 0.1.0.0 → 0.2.0.0
raw patch · 8 files changed
+434/−275 lines, 8 filesdep +mtldep ~containersdep ~hedgehogdep ~network
Dependencies added: mtl
Dependency ranges changed: containers, hedgehog, network
Files
- CHANGELOG.md +10/−0
- README.md +1/−1
- cbits/hs_rustls.h +15/−0
- rustls.cabal +6/−4
- src/Rustls.hs +179/−112
- src/Rustls/Internal.hs +56/−45
- src/Rustls/Internal/FFI.hs +79/−43
- test/Main.hs +88/−70
CHANGELOG.md view
@@ -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)
README.md view
@@ -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 ```
cbits/hs_rustls.h view
@@ -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
rustls.cabal view
@@ -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,
src/Rustls.hs view
@@ -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)
src/Rustls/Internal.hs view
@@ -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 -- <https://www.iana.org/assignments/tls-extensiontype-values/tls-extensiontype-values.xhtml#alpn-protocol-ids> -- 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 <https://www.iana.org/assignments/tls-parameters/tls-parameters.xhtml#tls-parameters-4> 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+ -- <https://www.iana.org/assignments/tls-parameters/tls-parameters.xhtml#tls-parameters-4>+ -- 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+ -- <https://www.iana.org/assignments/tls-parameters/tls-parameters.xhtml#tls-parameters-4>+ -- 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'.
src/Rustls/Internal/FFI.hs view
@@ -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
test/Main.hs view
@@ -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+ }