rustls 0.0.1.0 → 0.1.0.0
raw patch · 7 files changed
+621/−388 lines, 7 filesdep −derive-storable-plugindep ~basedep ~bytestringdep ~containers
Dependencies removed: derive-storable-plugin
Dependency ranges changed: base, bytestring, containers, filepath, hedgehog, tasty, text
Files
- CHANGELOG.md +6/−0
- README.md +1/−1
- rustls.cabal +59/−44
- src/Rustls.hs +213/−136
- src/Rustls/Internal.hs +175/−114
- src/Rustls/Internal/FFI.hs +106/−49
- test/Main.hs +61/−44
CHANGELOG.md view
@@ -1,5 +1,11 @@ # Revision history for rustls +## 0.1.0.0 -- 06.04.2024++ * Use rustls-ffi 0.13.0, including new functionality (like recovactions)+ * Only support GHC >= 9.2+ * `Backend` is now a record instead of a type class+ ## 0.0.1.0 -- 12.03.2022 * Use rustls-ffi 0.9.2
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.9.2+git clone https://github.com/rustls/rustls-ffi -b v0.13.0 cd rustls-ffi make DESTDIR=/path/to/some/dir install ```
rustls.cabal view
@@ -1,41 +1,53 @@ cabal-version: 2.4 name: rustls-version: 0.0.1.0-+version: 0.1.0.0 synopsis: TLS bindings for Rustls description: TLS bindings for [Rustls](https://github.com/rustls/rustls) via [rustls-ffi](https://github.com/rustls/rustls-ffi).-category: Cryptography, Network +category: Cryptography, Network author: amesgen maintainer: amesgen@amesgen.de homepage: https://github.com/amesgen/hs-rustls/tree/main/rustls bug-reports: https://github.com/amesgen/hs-rustls/issues license: CC0-1.0 license-file: LICENSE- extra-source-files:- cbits/hs_rustls.h- README.md CHANGELOG.md+ README.md+ cbits/hs_rustls.h source-repository head location: https://github.com/amesgen/hs-rustls type: git -flag derive-storable-plugin- description: Use derive-storable-plugin- default: True- manual: False- common commons- default-language: Haskell2010- ghc-options: -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-name-shadowing -Wno-unticked-promoted-constructors -fhide-source-paths- if impl(ghc >= 8.10)- ghc-options: -Wunused-packages- default-extensions: BangPatterns BlockArguments CApiFFI CPP DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies ExistentialQuantification GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiWayIf NamedFieldPuns OverloadedStrings PatternSynonyms RecordWildCards RoleAnnotations ScopedTypeVariables StrictData TupleSections TypeApplications ViewPatterns+ default-language: GHC2021+ ghc-options:+ -Wall+ -Wredundant-constraints+ -Wunused-packages+ -Wno-name-shadowing+ -Wno-unticked-promoted-constructors+ -fhide-source-paths + default-extensions:+ BlockArguments+ CApiFFI+ CPP+ DataKinds+ DeriveAnyClass+ DerivingStrategies+ LambdaCase+ MultiWayIf+ OverloadedStrings+ PatternSynonyms+ RecordWildCards+ RoleAnnotations+ StrictData+ ViewPatterns+ library import: commons ghc-options: -Wmissing-export-lists@@ -44,17 +56,16 @@ Rustls Rustls.Internal Rustls.Internal.FFI+ build-depends:- base >= 4.12 && < 5- , bytestring >= 0.10 && < 0.12- , text ^>= 2.0.1- , derive-storable ^>= 0.3- , transformers >= 0.5.6 && < 0.7- , resourcet ^>= 1.2 || ^>= 1.3- , network ^>= 3.1- if flag(derive-storable-plugin)- build-depends: derive-storable-plugin- cpp-options: -DDERIVE_STORABLE_PLUGIN+ base >=4.16 && <5,+ bytestring >=0.10 && <0.13,+ derive-storable ^>=0.3,+ network ^>=3.1,+ resourcet ^>=1.2 || ^>=1.3,+ text >=2.0 && <2.2,+ transformers >=0.5.6 && <0.7,+ extra-libraries: rustls include-dirs: cbits @@ -63,22 +74,26 @@ type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: test- ghc-options: -threaded -rtsopts -with-rtsopts=-N+ ghc-options:+ -threaded+ -rtsopts+ -with-rtsopts=-N+ build-depends:- base- , rustls- , tasty >= 1.3 && < 1.5- , tasty-hunit ^>= 0.10- , tasty-hedgehog >= 1.0 && < 1.5- , hedgehog >= 1.0 && < 1.3- , text- , bytestring- , containers ^>= 0.6- , transformers- , resourcet- , async ^>= 2.2- , stm ^>= 2.5- , process ^>= 1.6- , filepath ^>= 1.4- , directory ^>= 1.3- , temporary ^>= 1.3+ async ^>=2.2,+ base,+ bytestring,+ containers >=0.6 && <0.8,+ directory ^>=1.3,+ filepath >=1.4 && <1.6,+ hedgehog >=1.0 && <1.5,+ process ^>=1.6,+ resourcet,+ rustls,+ stm ^>=2.5,+ tasty >=1.3 && <1.6,+ tasty-hedgehog >=1.0 && <1.5,+ tasty-hunit ^>=0.10,+ temporary ^>=1.3,+ text,+ transformers,
src/Rustls.hs view
@@ -13,7 +13,7 @@ -- -- == Client example ----- Suppose you have alread opened a 'Network.Socket.Socket' to @example.org@,+-- Suppose you have already opened a 'Network.Socket.Socket' to @example.org@, -- port 443 (see e.g. the examples at "Network.Socket"). This small example -- showcases how to perform a simple HTTP GET request: --@@ -27,9 +27,11 @@ -- -- 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"+-- Rustls.buildClientConfig $+-- Rustls.defaultClientConfigBuilder serverCertVerifier+-- let backend = Rustls.mkSocketBackend socket+-- newConnection =+-- Rustls.newClientConnection backend clientConfig "example.org" -- withAcquire newConnection $ \conn -> do -- Rustls.writeBS conn "GET /" -- recv <- Rustls.readBS conn 1000 -- max number of bytes to read@@ -37,7 +39,15 @@ -- 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"+-- serverCertVerifier =+-- Rustls.ServerCertVerifier+-- { Rustls.serverCertVerifierCertificates =+-- pure $+-- Rustls.PemCertificatesFromFile+-- "/etc/ssl/certs/ca-certificates.crt"+-- Rustls.PEMCertificateParsingStrict,+-- Rustls.serverCertVerifierCRLs = []+-- } -- :} -- -- == Using 'Acquire'@@ -59,8 +69,7 @@ -- ** Builder ClientConfigBuilder (..), defaultClientConfigBuilder,- ClientRoots (..),- PEMCertificates (..),+ ServerCertVerifier (..), -- ** Config ClientConfig,@@ -76,6 +85,7 @@ ServerConfigBuilder (..), defaultServerConfigBuilder, ClientCertVerifier (..),+ ClientCertVerifierPolicy (..), -- ** Config ServerConfig,@@ -119,12 +129,16 @@ -- ** Backend Backend (..),- ByteStringBackend (..),+ mkSocketBackend,+ mkByteStringBackend, -- ** Types ALPNProtocol (..),+ PEMCertificates (..),+ PEMCertificateParsing (..), CertifiedKey (..), DERCertificate (..),+ CertificateRevocationList (..), TLSVersion (TLS12, TLS13, unTLSVersion), defaultTLSVersions, allTLSVersions,@@ -143,30 +157,32 @@ import Control.Concurrent (forkFinally, killThread) import Control.Concurrent.MVar-import qualified Control.Exception as E-import Control.Monad (forever, when, (<=<))+import Control.Exception qualified as E+import Control.Monad (forever, void, when) import Control.Monad.IO.Class import Control.Monad.Trans.Cont import Control.Monad.Trans.Reader import Data.Acquire import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import qualified Data.ByteString.Internal as BI-import qualified Data.ByteString.Unsafe as BU+import Data.ByteString qualified as B+import Data.ByteString.Internal qualified as BI+import Data.ByteString.Unsafe qualified as BU import Data.Coerce-import Data.Foldable (for_)+import Data.Foldable (for_, toList) import Data.List.NonEmpty (NonEmpty)-import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty qualified as NE import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Foreign as T-import Foreign+import Data.Text qualified as T+import Data.Text.Foreign qualified as T+import Data.Traversable (for)+import Data.Word+import Foreign hiding (void) import Foreign.C import GHC.Conc (reportError) import GHC.Generics (Generic) import Rustls.Internal import Rustls.Internal.FFI (ConstPtr (..), TLSVersion (..))-import qualified Rustls.Internal.FFI as FFI+import Rustls.Internal.FFI qualified as FFI import System.IO.Unsafe (unsafePerformIO) -- $setup@@ -176,7 +192,7 @@ -- | Combined version string of Rustls and rustls-ffi. -- -- >>> version--- "rustls-ffi/0.9.2/rustls/0.20.8"+-- "rustls-ffi/0.13.0/rustls/0.23.4" version :: Text version = unsafePerformIO $ alloca \strPtr -> do FFI.hsVersion strPtr@@ -208,43 +224,44 @@ {-# NOINLINE defaultCipherSuites #-} -- | A 'ClientConfigBuilder' with good defaults.-defaultClientConfigBuilder :: ClientRoots -> ClientConfigBuilder-defaultClientConfigBuilder roots =+defaultClientConfigBuilder :: ServerCertVerifier -> ClientConfigBuilder+defaultClientConfigBuilder serverCertVerifier = ClientConfigBuilder- { clientConfigTLSVersions = [],+ { clientConfigServerCertVerifier = serverCertVerifier,+ clientConfigTLSVersions = [], clientConfigCipherSuites = [],- clientConfigRoots = roots, clientConfigALPNProtocols = [], clientConfigEnableSNI = True, clientConfigCertifiedKeys = [] } -withCertifiedKeys :: [CertifiedKey] -> ((ConstPtr (ConstPtr FFI.CertifiedKey), CSize) -> IO a) -> IO a-withCertifiedKeys certifiedKeys cb =- withMany withCertifiedKey certifiedKeys \certKeys ->- withArrayLen certKeys \len ptr -> cb (ConstPtr ptr, intToCSize len)+withCertifiedKeys :: [CertifiedKey] -> ContT a IO (ConstPtr (ConstPtr FFI.CertifiedKey), CSize)+withCertifiedKeys certifiedKeys = do+ certKeys <- for certifiedKeys withCertifiedKey+ ContT \cb -> withArrayLen certKeys \len ptr -> cb (ConstPtr ptr, intToCSize len) where- withCertifiedKey CertifiedKey {..} cb =- BU.unsafeUseAsCStringLen certificateChain \(certPtr, certLen) ->- BU.unsafeUseAsCStringLen privateKey \(privPtr, privLen) ->- alloca \certKeyPtr -> do- rethrowR- =<< FFI.certifiedKeyBuild- (ConstPtr $ castPtr certPtr)- (intToCSize certLen)- (ConstPtr $ castPtr privPtr)- (intToCSize privLen)- certKeyPtr- cb =<< peek certKeyPtr+ withCertifiedKey CertifiedKey {..} = do+ (certPtr, certLen) <- ContT $ BU.unsafeUseAsCStringLen certificateChain+ (privPtr, privLen) <- ContT $ BU.unsafeUseAsCStringLen privateKey+ certKeyPtr <- ContT alloca+ liftIO do+ rethrowR+ =<< FFI.certifiedKeyBuild+ (ConstPtr $ castPtr certPtr)+ (intToCSize certLen)+ (ConstPtr $ castPtr privPtr)+ (intToCSize privLen)+ certKeyPtr+ peek certKeyPtr -withALPNProtocols :: [ALPNProtocol] -> ((ConstPtr FFI.SliceBytes, CSize) -> IO a) -> IO a-withALPNProtocols bss cb = do- withMany withSliceBytes (coerce bss) \bsPtrs ->- withArrayLen bsPtrs \len bsPtr -> cb (ConstPtr bsPtr, intToCSize len)+withALPNProtocols :: [ALPNProtocol] -> ContT a IO (ConstPtr FFI.SliceBytes, CSize)+withALPNProtocols bss = do+ bsPtrs <- for (coerce bss) withSliceBytes+ ContT \cb -> withArrayLen bsPtrs \len bsPtr -> cb (ConstPtr bsPtr, intToCSize len) where- withSliceBytes bs cb =- BU.unsafeUseAsCStringLen bs \(castPtr -> buf, intToCSize -> len) ->- cb $ FFI.SliceBytes buf len+ withSliceBytes bs = do+ (buf, len) <- ContT $ BU.unsafeUseAsCStringLen bs+ pure $ FFI.SliceBytes (castPtr buf) (intToCSize len) configBuilderNew :: ( ConstPtr (ConstPtr FFI.SupportedCipherSuite) ->@@ -279,97 +296,156 @@ builderPtr peek builderPtr -withRootCertStore :: [PEMCertificates] -> (ConstPtr FFI.RootCertStore -> IO a) -> IO a-withRootCertStore certs action =- E.bracket FFI.rootCertStoreNew FFI.rootCertStoreFree \store -> do- let addPEM bs (fromBool @CBool -> strict) =- BU.unsafeUseAsCStringLen bs \(buf, len) ->- rethrowR- =<< FFI.rootCertStoreAddPEM- store- (ConstPtr $ castPtr buf)- (intToCSize len)- strict- for_ certs \case- PEMCertificatesStrict bs -> addPEM bs True- PEMCertificatesLax bs -> addPEM bs False- action $ ConstPtr store+withRootCertStore :: [PEMCertificates] -> ContT a IO (ConstPtr FFI.RootCertStore)+withRootCertStore certs = do+ storeBuilder <-+ ContT $ E.bracket FFI.rootCertStoreBuilderNew FFI.rootCertStoreBuilderFree+ let isStrict :: PEMCertificateParsing -> CBool+ isStrict =+ fromBool @CBool . \case+ PEMCertificateParsingStrict -> True+ PEMCertificateParsingLax -> False+ for_ certs \case+ PEMCertificatesInMemory bs parsing -> do+ (buf, len) <- ContT $ BU.unsafeUseAsCStringLen bs+ liftIO $+ rethrowR+ =<< FFI.rootCertStoreBuilderAddPem+ storeBuilder+ (ConstPtr $ castPtr buf)+ (intToCSize len)+ (isStrict parsing)+ PemCertificatesFromFile path parsing -> do+ pathPtr <- ContT $ withCString path+ liftIO $+ rethrowR+ =<< FFI.rootCertStoreBuilderLoadRootsFromFile+ storeBuilder+ (ConstPtr pathPtr)+ (isStrict parsing)+ storePtr <- ContT alloca+ let buildRootCertStore = do+ liftIO $ rethrowR =<< FFI.rootCertStoreBuilderBuild storeBuilder storePtr+ peek storePtr+ ContT $ E.bracket buildRootCertStore FFI.rootCertStoreFree -- | Build a 'ClientConfigBuilder' into a 'ClientConfig'. -- -- This is a relatively expensive operation, so it is a good idea to share one -- 'ClientConfig' when creating multiple 'Connection's. buildClientConfig :: (MonadIO m) => ClientConfigBuilder -> m ClientConfig-buildClientConfig ClientConfigBuilder {..} = liftIO . E.mask_ $- E.bracketOnError- ( configBuilderNew- FFI.clientConfigBuilderNewCustom- clientConfigCipherSuites- clientConfigTLSVersions- )- FFI.clientConfigBuilderFree- \builder -> do- case clientConfigRoots of- ClientRootsFromFile rootsPath ->- withCString rootsPath $- rethrowR <=< FFI.clientConfigBuilderLoadRootsFromFile builder . ConstPtr- ClientRootsInMemory certs ->- withRootCertStore certs $ rethrowR <=< FFI.clientConfigBuilderUseRoots builder- withALPNProtocols clientConfigALPNProtocols \(alpnPtr, len) ->- rethrowR =<< FFI.clientConfigBuilderSetALPNProtocols builder alpnPtr len- FFI.clientConfigBuilderSetEnableSNI builder (fromBool @CBool clientConfigEnableSNI)- withCertifiedKeys clientConfigCertifiedKeys \(ptr, len) ->- rethrowR =<< FFI.clientConfigBuilderSetCertifiedKey builder ptr len- let clientConfigLogCallback = Nothing- clientConfigPtr <-- newForeignPtr FFI.clientConfigFree . unConstPtr- =<< FFI.clientConfigBuilderBuild builder- pure ClientConfig {..}+buildClientConfig ClientConfigBuilder {..} = liftIO . E.mask_ $ evalContT do+ builder <-+ ContT $+ E.bracketOnError+ ( configBuilderNew+ FFI.clientConfigBuilderNewCustom+ clientConfigCipherSuites+ clientConfigTLSVersions+ )+ 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+ liftIO $ FFI.clientConfigBuilderSetServerVerifier builder (ConstPtr scv)++ (alpnPtr, len) <- withALPNProtocols clientConfigALPNProtocols+ liftIO $ rethrowR =<< FFI.clientConfigBuilderSetALPNProtocols builder alpnPtr len++ liftIO $+ FFI.clientConfigBuilderSetEnableSNI builder (fromBool @CBool clientConfigEnableSNI)++ (ptr, len) <- withCertifiedKeys clientConfigCertifiedKeys+ liftIO $ rethrowR =<< FFI.clientConfigBuilderSetCertifiedKey builder ptr len++ let clientConfigLogCallback = Nothing++ liftIO do+ clientConfigPtr <-+ newForeignPtr FFI.clientConfigFree . unConstPtr+ =<< FFI.clientConfigBuilderBuild builder+ pure ClientConfig {..}+ -- | Build a 'ServerConfigBuilder' into a 'ServerConfig'. -- -- This is a relatively expensive operation, so it is a good idea to share one -- 'ServerConfig' when creating multiple 'Connection's. buildServerConfig :: (MonadIO m) => ServerConfigBuilder -> m ServerConfig-buildServerConfig ServerConfigBuilder {..} = liftIO . E.mask_ $- E.bracketOnError- ( configBuilderNew- FFI.serverConfigBuilderNewCustom- serverConfigCipherSuites- serverConfigTLSVersions- )- FFI.serverConfigBuilderFree- \builder -> do- withALPNProtocols serverConfigALPNProtocols \(alpnPtr, len) ->- rethrowR =<< FFI.serverConfigBuilderSetALPNProtocols builder alpnPtr len- rethrowR- =<< FFI.serverConfigBuilderSetIgnoreClientOrder- builder- (fromBool @CBool serverConfigIgnoreClientOrder)- withCertifiedKeys (NE.toList serverConfigCertifiedKeys) \(ptr, len) ->- rethrowR =<< FFI.serverConfigBuilderSetCertifiedKeys builder ptr len- let setBuilderCCV certs ccvNew ccvFree setCCV =- withRootCertStore certs \roots ->- E.bracket (ccvNew roots) ccvFree $ setCCV builder- for_ serverConfigClientCertVerifier \case- ClientCertVerifier certs -> do- setBuilderCCV- certs- FFI.clientCertVerifierNew- FFI.clientCertVerifierFree- FFI.serverConfigBuilderSetClientVerifier- ClientCertVerifierOptional certs -> do- setBuilderCCV- certs- FFI.clientCertVerifierOptionalNew- FFI.clientCertVerifierOptionalFree- FFI.serverConfigBuilderSetClientVerifierOptional- serverConfigPtr <-- newForeignPtr FFI.serverConfigFree . unConstPtr- =<< FFI.serverConfigBuilderBuild builder- let serverConfigLogCallback = Nothing- pure ServerConfig {..}+buildServerConfig ServerConfigBuilder {..} = liftIO . E.mask_ $ evalContT do+ builder <-+ ContT $+ E.bracketOnError+ ( configBuilderNew+ FFI.serverConfigBuilderNewCustom+ serverConfigCipherSuites+ serverConfigTLSVersions+ )+ FFI.serverConfigBuilderFree + (alpnPtr, len) <- withALPNProtocols serverConfigALPNProtocols+ liftIO $ rethrowR =<< FFI.serverConfigBuilderSetALPNProtocols builder alpnPtr len++ liftIO $+ rethrowR+ =<< FFI.serverConfigBuilderSetIgnoreClientOrder+ builder+ (fromBool @CBool serverConfigIgnoreClientOrder)++ (ptr, len) <- withCertifiedKeys (NE.toList serverConfigCertifiedKeys)+ liftIO $ rethrowR =<< FFI.serverConfigBuilderSetCertifiedKeys builder ptr len++ for_ serverConfigClientCertVerifier \ClientCertVerifier {..} -> do+ roots <- withRootCertStore $ NE.toList clientCertVerifierCertificates+ ccvb <-+ ContT $+ E.bracket+ (FFI.webPkiClientCertVerifierBuilderNew roots)+ FFI.webPkiClientCertVerifierBuilderFree+ crls :: [CStringLen] <-+ for clientCertVerifierCRLs $+ ContT . BU.unsafeUseAsCStringLen . unCertificateRevocationList+ liftIO do+ case clientCertVerifierPolicy of+ AllowAnyAuthenticatedClient -> pure ()+ AllowAnyAnonymousOrAuthenticatedClient ->+ rethrowR =<< FFI.webPkiClientCertVerifierBuilderAllowUnauthenticated ccvb+ for_ crls \(ptr, len) ->+ FFI.webPkiClientCertVerifierBuilderAddCrl+ ccvb+ (ConstPtr (castPtr ptr))+ (intToCSize len)+ ccvPtr <- ContT alloca+ let buildCcv = do+ rethrowR =<< FFI.webPkiClientCertVerifierBuilderBuild ccvb ccvPtr+ peek ccvPtr+ ccv <- ContT $ E.bracket buildCcv FFI.clientCertVerifierFree+ liftIO $ FFI.serverConfigBuilderSetClientVerifier builder (ConstPtr ccv)++ liftIO do+ serverConfigPtr <-+ newForeignPtr FFI.serverConfigFree . unConstPtr+ =<< FFI.serverConfigBuilderBuild builder+ let serverConfigLogCallback = Nothing+ pure ServerConfig {..}+ -- | A 'ServerConfigBuilder' with good defaults. defaultServerConfigBuilder :: NonEmpty CertifiedKey -> ServerConfigBuilder defaultServerConfigBuilder certifiedKeys =@@ -409,8 +485,7 @@ report = reportError . E.SomeException . RustlsLogException newConnection ::- (Backend b) =>- b ->+ Backend -> ForeignPtr config -> Maybe LogCallback -> (ConstPtr config -> Ptr (Ptr FFI.Connection) -> IO FFI.Result) ->@@ -454,8 +529,7 @@ -- | Initialize a TLS connection as a client. newClientConnection ::- (Backend b) =>- b ->+ Backend -> ClientConfig -> -- | Hostname. Text ->@@ -467,8 +541,7 @@ -- | Initialize a TLS connection as a server. newServerConnection ::- (Backend b) =>- b ->+ Backend -> ServerConfig -> Acquire (Connection Server) newServerConnection b ServerConfig {..} =@@ -489,7 +562,7 @@ handshake :: (MonadIO m) => Connection side -> HandshakeQuery side a -> m a handshake conn (HandshakeQuery query) = liftIO do withConnection conn \c -> do- runTLS c TLSHandshake+ _ <- completePriorIO c runReaderT query c -- | Get the negotiated ALPN protocol, if any.@@ -559,14 +632,17 @@ sendCloseNotify conn = liftIO $ withConnection conn \c@Connection' {conn} -> do FFI.connectionSendCloseNotify conn- runTLS c TLSWrite+ void $ completeIO c -- | Read data from the Rustls 'Connection' into the given buffer. readPtr :: (MonadIO m) => Connection side -> Ptr Word8 -> CSize -> m CSize readPtr conn buf len = liftIO $ withConnection conn \c@Connection' {..} -> do- runTLS c TLSWrite- runTLS c TLSRead+ completePriorIO c+ loopWhileTrue $+ getWantsRead c >>= \case+ True -> (NotEOF ==) <$> completeIO c+ False -> pure False rethrowR =<< FFI.connectionRead conn buf len lenPtr peek lenPtr @@ -586,8 +662,9 @@ writePtr :: (MonadIO m) => Connection side -> Ptr Word8 -> CSize -> m CSize writePtr conn buf len = liftIO $ withConnection conn \c@Connection' {..} -> do+ completePriorIO c rethrowR =<< FFI.connectionWrite conn buf len lenPtr- runTLS c TLSWrite+ _ <- completeIO c peek lenPtr -- | Write a 'ByteString' to the Rustls 'Connection'.
src/Rustls/Internal.hs view
@@ -5,25 +5,25 @@ import Control.Concurrent (ThreadId) import Control.Concurrent.MVar-import qualified Control.Exception as E+import Control.Exception qualified as E import Control.Monad (when) import Control.Monad.Trans.Reader import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import qualified Data.ByteString.Unsafe as BU+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)-import qualified Data.Text as T-import qualified Data.Text.Foreign as T+import Data.Text qualified as T+import Data.Text.Foreign qualified as T import Foreign hiding (void) import Foreign.C import GHC.Generics (Generic)-import qualified Network.Socket as NS+import Network.Socket qualified as NS import Rustls.Internal.FFI (ConstPtr (..))-import qualified Rustls.Internal.FFI as FFI+import Rustls.Internal.FFI qualified as FFI import System.IO.Unsafe (unsafePerformIO) -- | An ALPN protocol ID. See@@ -60,8 +60,8 @@ -- | Rustls client config builder. data ClientConfigBuilder = ClientConfigBuilder- { -- | Client root certificates.- clientConfigRoots :: ClientRoots,+ { -- | 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@@ -79,27 +79,35 @@ } deriving stock (Show, Generic) --- | How to look up root certificates.-data ClientRoots- = -- | Fetch PEM-encoded root certificates from a file.- ClientRootsFromFile FilePath- | -- | Use in-memory PEM-encoded certificates.- ClientRootsInMemory [PEMCertificates]- deriving stock (Generic)--instance Show ClientRoots where- show _ = "ClientRoots"+-- | 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]+ }+ deriving stock (Show, Generic) --- | In-memory PEM-encoded certificates.+-- | A source of PEM-encoded certificates. data PEMCertificates- = -- | Syntactically valid PEM-encoded certificates.- PEMCertificatesStrict ByteString- | -- | PEM-encoded certificates, ignored if syntactically invalid.- --- -- This may be useful on systems that have syntactically invalid root certificates.- PEMCertificatesLax ByteString+ = -- | In-memory PEM-encoded certificates.+ PEMCertificatesInMemory ByteString PEMCertificateParsing+ | -- | Fetch PEM-encoded root certificates from a file.+ PemCertificatesFromFile FilePath PEMCertificateParsing deriving stock (Show, Generic) +-- | Parsing mode for PEM-encoded certificates.+data PEMCertificateParsing+ = -- | Fail if syntactically invalid.+ PEMCertificateParsingStrict+ | -- | Ignore if syntactically invalid.+ --+ -- This may be useful on systems that have syntactically invalid root+ -- certificates.+ PEMCertificateParsingLax+ deriving stock (Show, Eq, Ord, Enum, Bounded, Generic)+ -- | A complete chain of certificates plus a private key for the leaf certificate. data CertifiedKey = CertifiedKey { -- | PEM-encoded certificate chain.@@ -128,14 +136,33 @@ } -- | How to verify TLS client certificates.-data ClientCertVerifier- = -- | Root certificates used to verify TLS client certificates.- ClientCertVerifier [PEMCertificates]- | -- | Root certificates used to verify TLS client certificates if present,- -- but does not reject clients which provide no certificate.- ClientCertVerifierOptional [PEMCertificates]+data ClientCertVerifier = ClientCertVerifier+ { -- | Which client connections are allowed.+ clientCertVerifierPolicy :: ClientCertVerifierPolicy,+ -- | Certificates used to verify TLS client certificates.+ clientCertVerifierCertificates :: NonEmpty PEMCertificates,+ -- | List of certificate revocation lists used to verify TLS client+ -- certificates.+ clientCertVerifierCRLs :: [CertificateRevocationList]+ } deriving stock (Show, Generic) +-- | Which client connections are allowed by a 'ClientCertVerifier'.+data ClientCertVerifierPolicy+ = -- | Allow any authenticated client (i.e. offering a trusted certificate),+ -- and reject clients offering none.+ AllowAnyAuthenticatedClient+ | -- | Allow any authenticated client (i.e. offering a trusted certificate),+ -- but also allow clients offering none.+ AllowAnyAnonymousOrAuthenticatedClient+ deriving stock (Show, Eq, Ord, Enum, Bounded, Generic)++-- | One or more PEM-encoded certificate revocation lists (CRL).+newtype CertificateRevocationList = CertificateRevocationList+ { unCertificateRevocationList :: ByteString+ }+ deriving stock (Show, Generic)+ -- | Rustls client config builder. data ServerConfigBuilder = ServerConfigBuilder { -- | List of 'CertifiedKey's.@@ -234,54 +261,54 @@ deriving stock (Show) deriving anyclass (E.Exception) --- | Underlying data sources for Rustls.-class Backend b where- -- | Read data from the backend into the given buffer.- backendRead ::- b ->- -- | Target buffer pointer.- Ptr Word8 ->- -- | Target buffer length.- CSize ->- -- | Amount of bytes read.- IO CSize-- -- | Write data from the given buffer to the backend.- backendWrite ::- b ->- -- | Source buffer pointer.- Ptr Word8 ->- -- | Source buffer length.- CSize ->- -- | Amount of bytes written.- IO CSize+-- | Underlying data source for Rustls.+data Backend = Backend+ { -- | Read data from the backend into the given buffer.+ backendRead ::+ -- Target buffer pointer.+ Ptr Word8 ->+ -- Target buffer length.+ CSize ->+ -- Amount of bytes read.+ IO CSize,+ -- | Write data from the given buffer to the backend.+ backendWrite ::+ -- Source buffer pointer.+ Ptr Word8 ->+ -- Source buffer length.+ CSize ->+ -- Amount of bytes written.+ IO CSize+ } -instance Backend NS.Socket where- backendRead s buf len =- intToCSize <$> NS.recvBuf s buf (cSizeToInt len)- backendWrite s buf len =- intToCSize <$> NS.sendBuf s buf (cSizeToInt len)+mkSocketBackend :: NS.Socket -> Backend+mkSocketBackend s = Backend {..}+ where+ backendRead buf len =+ intToCSize <$> NS.recvBuf s buf (cSizeToInt len)+ backendWrite buf len =+ intToCSize <$> NS.sendBuf s buf (cSizeToInt len) -- | An in-memory 'Backend'.-data ByteStringBackend = ByteStringBackend- { -- | Read a 'ByteString' with the given max length.- bsbRead :: Int -> IO ByteString,- -- | Write a 'ByteString'.- bsbWrite :: ByteString -> IO ()- }- deriving stock (Generic)---- | This instance will silently truncate 'ByteString's which are too long.-instance Backend ByteStringBackend where- backendRead ByteStringBackend {bsbRead} buf len = do- bs <- bsbRead (cSizeToInt len)- BU.unsafeUseAsCStringLen bs \(bsPtr, bsLen) -> do- let copyLen = bsLen `min` cSizeToInt len- copyBytes buf (castPtr bsPtr) copyLen- pure $ intToCSize copyLen- backendWrite ByteStringBackend {bsbWrite} buf len = do- bsbWrite =<< B.packCStringLen (castPtr buf, cSizeToInt len)- pure len+mkByteStringBackend ::+ -- | Read a 'ByteString' with the given max length.+ --+ -- This will silently truncate 'ByteString's which are too long.+ (Int -> IO ByteString) ->+ -- | Write a 'ByteString'.+ (ByteString -> IO ()) ->+ Backend+mkByteStringBackend bsbRead bsbWrite = Backend {..}+ where+ backendRead buf len = do+ bs <- bsbRead (cSizeToInt len)+ BU.unsafeUseAsCStringLen bs \(bsPtr, bsLen) -> do+ let copyLen = bsLen `min` cSizeToInt len+ copyBytes buf (castPtr bsPtr) copyLen+ pure $ intToCSize copyLen+ backendWrite buf len = do+ bsbWrite =<< B.packCStringLen (castPtr buf, cSizeToInt len)+ pure len -- | Type-level indicator whether a 'Connection' is client- or server-side. data Side = Client | Server@@ -291,11 +318,9 @@ type role Connection nominal -data Connection' = forall b.- (Backend b) =>- Connection'+data Connection' = Connection' { conn :: Ptr FFI.Connection,- backend :: b,+ backend :: Backend, lenPtr :: Ptr CSize, ioMsgReq :: MVar IOMsgReq, ioMsgRes :: MVar IOMsgRes,@@ -332,14 +357,16 @@ | -- | Notify that the FFI call finished. DoneFFI -interactTLS :: Connection' -> ReadOrWrite -> IO ()+interactTLS :: Connection' -> ReadOrWrite -> IO CSize interactTLS Connection' {..} readOrWrite = E.uninterruptibleMask \restore -> do putMVar ioMsgReq $ Request readOrWrite- UsingBuffer buf len readPtr <- takeMVar ioMsgRes- poke readPtr- =<< restore (readOrWriteBackend buf len)+ UsingBuffer buf len sizePtr <- takeMVar ioMsgRes+ size <-+ restore (readOrWriteBackend buf len) `E.onException` done FFI.ioResultErr+ poke sizePtr size done FFI.ioResultOk+ pure size where readOrWriteBackend = case readOrWrite of Read -> backendRead backend@@ -349,41 +376,75 @@ DoneFFI <- takeMVar ioMsgRes pure () -data RunTLSMode = TLSHandshake | TLSRead | TLSWrite- deriving (Eq)+data IsEOF = IsEOF | NotEOF+ deriving stock (Show, Eq) -runTLS :: Connection' -> RunTLSMode -> IO ()-runTLS c@Connection' {..} = \case- TLSHandshake -> loopWhileTrue do- toBool @CBool <$> FFI.connectionIsHandshaking (ConstPtr conn) >>= \case- True -> (||) <$> runWrite <*> runRead- False -> pure False- TLSRead -> do- runTLS c TLSHandshake- loopWhileTrue runRead- TLSWrite -> do- runTLS c TLSHandshake- loopWhileTrue runWrite+-- | Helper function, see @complete_io@ from rustls.+--+-- <https://github.com/rustls/rustls/blob/v/0.23.4/rustls/src/conn.rs#L544>+completeIO :: Connection' -> IO IsEOF+completeIO c@Connection' {..} = go NotEOF where- runRead = do- wantsRead <- toBool @CBool <$> FFI.connectionWantsRead (ConstPtr conn)- when wantsRead do- interactTLS c Read- r <- FFI.connectionProcessNewPackets conn- -- try to notify our peer that we encountered a TLS error- when (r /= FFI.resultOk) $ ignoreSyncExceptions $ void runWrite- rethrowR r- pure wantsRead+ go eof = do+ untilHandshaked <- getIsHandshaking c+ atLeastOneWrite <- getWantsWrite c + loopWhileTrue runWrite++ if not untilHandshaked && atLeastOneWrite+ then pure eof+ else do+ wantsRead <- getWantsRead c+ eof <-+ if eof == NotEOF && wantsRead+ then do+ bytesRead <- interactTLS c Read+ pure if bytesRead == 0 then IsEOF else NotEOF+ else pure eof++ r <- FFI.connectionProcessNewPackets conn+ -- try to notify our peer that we encountered a TLS error+ when (r /= FFI.resultOk) $ ignoreSyncExceptions $ void runWrite+ rethrowR r++ stillHandshaking <- getIsHandshaking c+ finished <- case (untilHandshaked, stillHandshaking) of+ (True, False) -> not <$> getWantsWrite c+ (False, _) -> pure True+ (True, True) -> do+ when (eof == IsEOF) $ fail "rustls: unexpected eof"+ pure False+ if finished then pure eof else go eof+ runWrite = do- wantsWrite <- toBool @CBool <$> FFI.connectionWantsWrite (ConstPtr conn)- when wantsWrite $- interactTLS c Write+ wantsWrite <- getWantsWrite c+ when wantsWrite $ void $ interactTLS c Write pure wantsWrite - loopWhileTrue action = do- continue <- action- when continue $ loopWhileTrue action+completePriorIO :: Connection' -> IO ()+completePriorIO c = do+ whenM (getIsHandshaking c) $ void $ completeIO c+ whenM (getWantsWrite c) $ void $ completeIO c++getIsHandshaking :: Connection' -> IO Bool+getIsHandshaking Connection' {conn} =+ toBool @CBool <$> FFI.connectionIsHandshaking (ConstPtr conn)++getWantsRead :: Connection' -> IO Bool+getWantsRead Connection' {conn} =+ toBool @CBool <$> FFI.connectionWantsRead (ConstPtr conn)++getWantsWrite :: Connection' -> IO Bool+getWantsWrite Connection' {conn} =+ toBool @CBool <$> FFI.connectionWantsWrite (ConstPtr conn)++-- utils++whenM :: (Monad m) => m Bool -> m () -> m ()+whenM cond action = cond >>= \case True -> action; False -> pure ()++loopWhileTrue :: (Monad m) => m Bool -> m ()+loopWhileTrue action = whenM action $ loopWhileTrue action cSizeToInt :: CSize -> Int cSizeToInt = fromIntegral
src/Rustls/Internal/FFI.hs view
@@ -1,7 +1,3 @@-#if DERIVE_STORABLE_PLUGIN-{-# OPTIONS_GHC -fplugin=Foreign.Storable.Generic.Plugin #-}-#endif- -- | Internal module, not subject to PVP. module Rustls.Internal.FFI ( ConstPtr (..),@@ -19,8 +15,14 @@ clientConfigBuilderSetALPNProtocols, clientConfigBuilderSetEnableSNI, clientConfigBuilderSetCertifiedKey,- clientConfigBuilderLoadRootsFromFile,- clientConfigBuilderUseRoots,+ WebPkiServerCertVerifierBuilder,+ ServerCertVerifier,+ webPkiServerCertVerifierBuilderNew,+ webPkiServerCertVerifierBuilderAddCrl,+ webPkiServerCertVerifierBuilderFree,+ webPkiServerCertVerifierBuilderBuild,+ serverCertVerifierFree,+ clientConfigBuilderSetServerVerifier, -- ** Connection clientConnectionNew,@@ -38,14 +40,15 @@ serverConfigBuilderSetALPNProtocols, serverConfigBuilderSetIgnoreClientOrder, serverConfigBuilderSetCertifiedKeys,+ WebPkiClientCertVerifierBuilder, ClientCertVerifier,- clientCertVerifierNew,+ webPkiClientCertVerifierBuilderNew,+ webPkiClientCertVerifierBuilderAddCrl,+ webPkiClientCertVerifierBuilderAllowUnauthenticated,+ webPkiClientCertVerifierBuilderFree,+ webPkiClientCertVerifierBuilderBuild, clientCertVerifierFree, serverConfigBuilderSetClientVerifier,- ClientCertVerifierOptional,- clientCertVerifierOptionalNew,- clientCertVerifierOptionalFree,- serverConfigBuilderSetClientVerifierOptional, -- * Certificate stuff CertifiedKey,@@ -129,9 +132,13 @@ defaultVersionsLen, -- ** Root cert store+ RootCertStoreBuilder, RootCertStore,- rootCertStoreNew,- rootCertStoreAddPEM,+ rootCertStoreBuilderNew,+ rootCertStoreBuilderAddPem,+ rootCertStoreBuilderLoadRootsFromFile,+ rootCertStoreBuilderFree,+ rootCertStoreBuilderBuild, rootCertStoreFree, ) where@@ -223,23 +230,6 @@ Ptr (Ptr Connection) -> IO Result -foreign import capi unsafe "rustls.h rustls_client_config_builder_load_roots_from_file"- clientConfigBuilderLoadRootsFromFile :: Ptr ClientConfigBuilder -> ConstCString -> IO Result--data {-# CTYPE "rustls.h" "rustls_root_cert_store" #-} RootCertStore--foreign import capi unsafe "rustls.h rustls_root_cert_store_new"- rootCertStoreNew :: IO (Ptr RootCertStore)--foreign import capi unsafe "rustls.h rustls_root_cert_store_add_pem"- rootCertStoreAddPEM :: Ptr RootCertStore -> ConstPtr Word8 -> CSize -> CBool -> IO Result--foreign import capi unsafe "rustls.h rustls_root_cert_store_free"- rootCertStoreFree :: Ptr RootCertStore -> IO ()--foreign import capi unsafe "rustls.h rustls_client_config_builder_use_roots"- clientConfigBuilderUseRoots :: Ptr ClientConfigBuilder -> ConstPtr RootCertStore -> IO Result- foreign import capi unsafe "rustls.h rustls_client_config_builder_set_alpn_protocols" clientConfigBuilderSetALPNProtocols :: Ptr ClientConfigBuilder -> ConstPtr SliceBytes -> CSize -> IO Result@@ -251,8 +241,37 @@ clientConfigBuilderSetCertifiedKey :: Ptr ClientConfigBuilder -> ConstPtr (ConstPtr CertifiedKey) -> CSize -> IO Result --- TODO add callback-based cert validation?+data+ {-# CTYPE "rustls.h" "rustls_web_pki_server_cert_verifier_builder" #-}+ WebPkiServerCertVerifierBuilder +data+ {-# 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_add_crl"+ webPkiServerCertVerifierBuilderAddCrl ::+ Ptr WebPkiServerCertVerifierBuilder -> ConstPtr Word8 -> CSize -> IO Result++foreign import capi unsafe "rustls.h rustls_web_pki_server_cert_verifier_builder_free"+ webPkiServerCertVerifierBuilderFree ::+ Ptr WebPkiServerCertVerifierBuilder -> IO ()++foreign import capi unsafe "rustls.h rustls_web_pki_server_cert_verifier_builder_build"+ webPkiServerCertVerifierBuilderBuild ::+ Ptr WebPkiServerCertVerifierBuilder -> Ptr (Ptr ServerCertVerifier) -> IO Result++foreign import capi unsafe "rustls.h rustls_server_cert_verifier_free"+ serverCertVerifierFree :: Ptr ServerCertVerifier -> IO ()++foreign import capi unsafe "rustls.h rustls_client_config_builder_set_server_verifier"+ clientConfigBuilderSetServerVerifier ::+ Ptr ClientConfigBuilder -> ConstPtr ServerCertVerifier -> IO ()+ -- Server data {-# CTYPE "rustls.h" "rustls_server_config" #-} ServerConfig @@ -290,31 +309,42 @@ serverConfigBuilderSetCertifiedKeys :: Ptr ServerConfigBuilder -> ConstPtr (ConstPtr CertifiedKey) -> CSize -> IO Result -data {-# CTYPE "rustls.h" "rustls_client_cert_verifier" #-} ClientCertVerifier+data+ {-# CTYPE "rustls.h" "rustls_web_pki_client_cert_verifier_builder" #-}+ WebPkiClientCertVerifierBuilder -foreign import capi unsafe "rustls.h rustls_client_cert_verifier_new"- clientCertVerifierNew :: ConstPtr RootCertStore -> IO (ConstPtr ClientCertVerifier)+data+ {-# CTYPE "rustls.h" "rustls_client_cert_verifier" #-}+ ClientCertVerifier -foreign import capi unsafe "rustls.h rustls_client_cert_verifier_free"- clientCertVerifierFree :: ConstPtr ClientCertVerifier -> IO ()+-- TODO all features? -foreign import capi unsafe "rustls.h rustls_server_config_builder_set_client_verifier"- serverConfigBuilderSetClientVerifier ::- Ptr ServerConfigBuilder -> ConstPtr ClientCertVerifier -> IO ()+foreign import capi unsafe "rustls.h rustls_web_pki_client_cert_verifier_builder_new"+ webPkiClientCertVerifierBuilderNew ::+ ConstPtr RootCertStore -> IO (Ptr WebPkiClientCertVerifierBuilder) -data {-# CTYPE "rustls.h" "rustls_client_cert_verifier_optional" #-} ClientCertVerifierOptional+foreign import capi unsafe "rustls.h rustls_web_pki_client_cert_verifier_builder_add_crl"+ webPkiClientCertVerifierBuilderAddCrl ::+ Ptr WebPkiClientCertVerifierBuilder -> ConstPtr Word8 -> CSize -> IO Result -foreign import capi unsafe "rustls.h rustls_client_cert_verifier_optional_new"- clientCertVerifierOptionalNew ::- ConstPtr RootCertStore -> IO (ConstPtr ClientCertVerifierOptional)+foreign import capi unsafe "rustls.h rustls_web_pki_client_cert_verifier_builder_allow_unauthenticated"+ webPkiClientCertVerifierBuilderAllowUnauthenticated ::+ Ptr WebPkiClientCertVerifierBuilder -> IO Result -foreign import capi unsafe "rustls.h rustls_client_cert_verifier_optional_free"- clientCertVerifierOptionalFree :: ConstPtr ClientCertVerifierOptional -> IO ()+foreign import capi unsafe "rustls.h rustls_web_pki_client_cert_verifier_builder_free"+ webPkiClientCertVerifierBuilderFree :: Ptr WebPkiClientCertVerifierBuilder -> IO () -foreign import capi unsafe "rustls.h rustls_server_config_builder_set_client_verifier_optional"- serverConfigBuilderSetClientVerifierOptional ::- Ptr ServerConfigBuilder -> ConstPtr ClientCertVerifierOptional -> IO ()+foreign import capi unsafe "rustls.h rustls_web_pki_client_cert_verifier_builder_build"+ webPkiClientCertVerifierBuilderBuild ::+ Ptr WebPkiClientCertVerifierBuilder -> Ptr (Ptr ClientCertVerifier) -> IO Result +foreign import capi unsafe "rustls.h rustls_client_cert_verifier_free"+ clientCertVerifierFree :: Ptr ClientCertVerifier -> IO ()++foreign import capi unsafe "rustls.h rustls_server_config_builder_set_client_verifier"+ serverConfigBuilderSetClientVerifier ::+ Ptr ServerConfigBuilder -> ConstPtr ClientCertVerifier -> IO ()+ -- add custom session persistence functions? -- connection@@ -355,7 +385,7 @@ foreign import capi unsafe "rustls.h rustls_connection_get_negotiated_ciphersuite" connectionGetNegotiatedCipherSuite :: ConstPtr Connection -> IO (ConstPtr SupportedCipherSuite) -foreign import capi unsafe "rustls.h rustls_server_connection_get_sni_hostname"+foreign import capi unsafe "rustls.h rustls_server_connection_get_server_name" serverConnectionGetSNIHostname :: ConstPtr Connection -> Ptr Word8 -> CSize -> Ptr CSize -> IO Result foreign import capi unsafe "rustls.h rustls_connection_get_peer_certificate"@@ -465,3 +495,30 @@ foreign import capi "rustls.h value RUSTLS_DEFAULT_VERSIONS_LEN" defaultVersionsLen :: CSize++-- Root cert store++data {-# CTYPE "rustls.h" "rustls_root_cert_store_builder" #-} RootCertStoreBuilder++data {-# CTYPE "rustls.h" "rustls_root_cert_store" #-} RootCertStore++foreign import capi unsafe "rustls.h rustls_root_cert_store_builder_new"+ rootCertStoreBuilderNew :: IO (Ptr RootCertStoreBuilder)++foreign import capi unsafe "rustls.h rustls_root_cert_store_builder_add_pem"+ rootCertStoreBuilderAddPem ::+ Ptr RootCertStoreBuilder -> ConstPtr Word8 -> CSize -> CBool -> IO Result++foreign import capi unsafe "rustls.h rustls_root_cert_store_builder_load_roots_from_file"+ rootCertStoreBuilderLoadRootsFromFile ::+ Ptr RootCertStoreBuilder -> ConstCString -> CBool -> IO Result++foreign import capi unsafe "rustls.h rustls_root_cert_store_builder_free"+ rootCertStoreBuilderFree :: Ptr RootCertStoreBuilder -> IO ()++foreign import capi unsafe "rustls.h rustls_root_cert_store_builder_build"+ rootCertStoreBuilderBuild ::+ Ptr RootCertStoreBuilder -> Ptr (ConstPtr RootCertStore) -> IO Result++foreign import capi unsafe "rustls.h rustls_root_cert_store_free"+ rootCertStoreFree :: ConstPtr RootCertStore -> IO ()
test/Main.hs view
@@ -1,33 +1,33 @@ module Main where -import Control.Applicative (liftA2) import Control.Concurrent.Async (concurrently) import Control.Concurrent.STM.TMVar-import qualified Control.Exception as E-import Control.Monad (join, unless, when)+import Control.Exception qualified as E+import Control.Monad (unless, when) import Control.Monad.IO.Class import Control.Monad.STM (atomically) import Control.Monad.Trans.Except import Control.Monad.Trans.State.Strict (execStateT, modify') import Data.Acquire import Data.ByteString (ByteString)-import qualified Data.ByteString as B+import Data.ByteString qualified as B import Data.Foldable (for_) import Data.Functor (void) import Data.IORef-import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty qualified as NE import Data.Maybe (fromMaybe, isJust)-import qualified Data.Set as S+import Data.Set qualified as S import Data.Text (Text)-import qualified Data.Text as T+import Data.Text qualified as T import Hedgehog-import qualified Hedgehog.Gen as Gen-import qualified Hedgehog.Range as Range-import qualified Rustls-import qualified System.Directory as Dir+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import Rustls qualified+import System.Directory qualified as Dir import System.FilePath ((</>))-import qualified System.IO.Temp as Temp-import qualified System.Process as Process+import System.IO.Temp qualified as Temp+import System.Process qualified as Process+import System.Timeout import Test.Tasty import Test.Tasty.HUnit hiding (assert) import Test.Tasty.Hedgehog@@ -97,26 +97,27 @@ clientCipherSuite `S.member` (clientCipherSuites `S.intersection` serverCipherSuites) assert $ isJust clientPeerCert- case serverConfigClientCertVerifier of+ case Rustls.clientCertVerifierPolicy <$> serverConfigClientCertVerifier of Nothing -> serverPeerCert === Nothing- Just (Rustls.ClientCertVerifier _) ->+ Just Rustls.AllowAnyAuthenticatedClient -> assert $ isJust serverPeerCert- Just (Rustls.ClientCertVerifierOptional _) ->+ 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 ->- success- | clientTLSVersions `S.disjoint` serverTLSVersions ->- success- | Just (Rustls.ClientCertVerifier _) <- serverConfigClientCertVerifier,- null clientConfigCertifiedKeys ->- success- | otherwise -> failure+ | S.fromList clientConfigALPNProtocols+ `S.disjoint` S.fromList serverConfigALPNProtocols ->+ success+ | clientTLSVersions `S.disjoint` serverTLSVersions ->+ success+ | Just Rustls.AllowAnyAuthenticatedClient <-+ Rustls.clientCertVerifierPolicy <$> serverConfigClientCertVerifier,+ null clientConfigCertifiedKeys ->+ success+ | otherwise -> failure where nonEmptySet def = S.fromList . NE.toList . fromMaybe def . NE.nonEmpty @@ -142,12 +143,16 @@ genTestSetup :: (MonadGen m) => MiniCA -> m TestSetup genTestSetup MiniCA {..} = do commonALPNProtocols <- genALPNProtocols- clientConfigRoots <-- Gen.element- [ Rustls.ClientRootsFromFile miniCAFile,- Rustls.ClientRootsInMemory [Rustls.PEMCertificatesStrict miniCACert],- Rustls.ClientRootsInMemory [Rustls.PEMCertificatesLax miniCACert]- ]+ 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 {..} clientConfigALPNProtocols <- (commonALPNProtocols <>) <$> genALPNProtocols clientConfigEnableSNI <- Gen.bool_ clientConfigTLSVersions <- genTLSVersions@@ -157,17 +162,22 @@ serverConfigALPNProtocols <- (commonALPNProtocols <>) <$> genALPNProtocols serverConfigIgnoreClientOrder <- Gen.bool_ serverConfigTLSVersions <- genTLSVersions- serverConfigClientCertVerifier <-- Gen.element- [ Nothing,- Just $ Rustls.ClientCertVerifier [Rustls.PEMCertificatesStrict miniCACert],- Just $ Rustls.ClientCertVerifierOptional [Rustls.PEMCertificatesStrict miniCACert]- ]+ serverConfigClientCertVerifier <- Gen.maybe do+ clientCertVerifierPolicy <- Gen.enumBounded+ let clientCertVerifierCertificates =+ pure $+ Rustls.PEMCertificatesInMemory+ miniCACert+ Rustls.PEMCertificateParsingStrict+ clientCertVerifierCRLs = [] -- TODO test this+ pure Rustls.ClientCertVerifier {..} let serverConfigCipherSuites = getCipherSuites serverConfigTLSVersions serverConfigCertifiedKeys = pure miniCAServerCertKey serverConfigBuilder = Rustls.ServerConfigBuilder {..} clientSends <-- Gen.list (Range.linear 0 10) $+ -- TODO using 0 as a lower bound should work, but causes timeouts for some+ -- reason+ Gen.list (Range.linear 1 10) $ Gen.filterT (/= "close") $ Gen.bytes (Range.linear 1 50) pure TestSetup {..}@@ -245,7 +255,7 @@ Rustls.writeBS conn "close" pure (alpnProtocol, tlsVersion, cipherSuite, peerCert, received) - (backend0, backend1) <- mkConnectedBSBackends+ (backend0, backend1) <- mkConnectedBackends res <- liftIO . runExceptT $ do ( ( negotiatedServerALPNProtocol,@@ -262,13 +272,19 @@ clientReceived ) ) <-- ExceptT . E.try $ concurrently (runServer backend0) (runClient backend1)+ ExceptT . E.try . timeout' $+ concurrently (runServer backend0) (runClient backend1) pure TestOutcome {..} tlsLogLines <- liftIO $ reverse <$> readIORef logRef pure (res, tlsLogLines) where recordOutput = fmap reverse . flip execStateT [] + timeout' action =+ timeout (10 ^ (6 :: Int)) action >>= \case+ Just a -> pure a+ Nothing -> fail "timeout!"+ withMiniCA :: (IO (FilePath, MiniCA) -> TestTree) -> TestTree withMiniCA = withResource do@@ -289,12 +305,13 @@ pure (tmpDir, MiniCA {..}) \(tmpDir, _) -> Dir.removeDirectoryRecursive tmpDir -mkConnectedBSBackends :: (MonadIO m) => m (Rustls.ByteStringBackend, Rustls.ByteStringBackend)-mkConnectedBSBackends = liftIO do- (buf0, buf1) <- join (liftA2 (,)) newEmptyTMVarIO+mkConnectedBackends :: (MonadIO m) => m (Rustls.Backend, Rustls.Backend)+mkConnectedBackends = liftIO do+ buf0 <- newEmptyTMVarIO+ buf1 <- newEmptyTMVarIO pure (mkBSBackend buf0 buf1, mkBSBackend buf1 buf0) where- mkBSBackend readBuf writeBuf = Rustls.ByteStringBackend {..}+ mkBSBackend readBuf writeBuf = Rustls.mkByteStringBackend bsbRead bsbWrite where bsbRead len = atomically do (bs, bs') <- B.splitAt len <$> takeTMVar readBuf