diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 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.9.2 +git clone https://github.com/rustls/rustls-ffi -b v0.13.0 cd rustls-ffi make DESTDIR=/path/to/some/dir install ``` diff --git a/rustls.cabal b/rustls.cabal --- a/rustls.cabal +++ b/rustls.cabal @@ -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, diff --git a/src/Rustls.hs b/src/Rustls.hs --- a/src/Rustls.hs +++ b/src/Rustls.hs @@ -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'. diff --git a/src/Rustls/Internal.hs b/src/Rustls/Internal.hs --- a/src/Rustls/Internal.hs +++ b/src/Rustls/Internal.hs @@ -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. +-- +-- +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 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 @@ -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 () diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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