rustls (empty) → 0.0.0.0
raw patch · 9 files changed
+2000/−0 lines, 9 filesdep +asyncdep +basedep +bytestring
Dependencies added: async, base, bytestring, containers, derive-storable, derive-storable-plugin, directory, filepath, hedgehog, network, process, resourcet, rustls, stm, tasty, tasty-hedgehog, tasty-hunit, temporary, text, transformers
Files
- CHANGELOG.md +1/−0
- LICENSE +121/−0
- README.md +46/−0
- cbits/hs_rustls.h +20/−0
- rustls.cabal +84/−0
- src/Rustls.hs +577/−0
- src/Rustls/Internal.hs +397/−0
- src/Rustls/Internal/FFI.hs +442/−0
- test/Main.hs +312/−0
+ CHANGELOG.md view
@@ -0,0 +1,1 @@+# Revision history for rustls
+ LICENSE view
@@ -0,0 +1,121 @@+Creative Commons Legal Code++CC0 1.0 Universal++ CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE+ LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN+ ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS+ INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES+ REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS+ PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM+ THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED+ HEREUNDER.++Statement of Purpose++The laws of most jurisdictions throughout the world automatically confer+exclusive Copyright and Related Rights (defined below) upon the creator+and subsequent owner(s) (each and all, an "owner") of an original work of+authorship and/or a database (each, a "Work").++Certain owners wish to permanently relinquish those rights to a Work for+the purpose of contributing to a commons of creative, cultural and+scientific works ("Commons") that the public can reliably and without fear+of later claims of infringement build upon, modify, incorporate in other+works, reuse and redistribute as freely as possible in any form whatsoever+and for any purposes, including without limitation commercial purposes.+These owners may contribute to the Commons to promote the ideal of a free+culture and the further production of creative, cultural and scientific+works, or to gain reputation or greater distribution for their Work in+part through the use and efforts of others.++For these and/or other purposes and motivations, and without any+expectation of additional consideration or compensation, the person+associating CC0 with a Work (the "Affirmer"), to the extent that he or she+is an owner of Copyright and Related Rights in the Work, voluntarily+elects to apply CC0 to the Work and publicly distribute the Work under its+terms, with knowledge of his or her Copyright and Related Rights in the+Work and the meaning and intended legal effect of CC0 on those rights.++1. Copyright and Related Rights. A Work made available under CC0 may be+protected by copyright and related or neighboring rights ("Copyright and+Related Rights"). Copyright and Related Rights include, but are not+limited to, the following:++ i. the right to reproduce, adapt, distribute, perform, display,+ communicate, and translate a Work;+ ii. moral rights retained by the original author(s) and/or performer(s);+iii. publicity and privacy rights pertaining to a person's image or+ likeness depicted in a Work;+ iv. rights protecting against unfair competition in regards to a Work,+ subject to the limitations in paragraph 4(a), below;+ v. rights protecting the extraction, dissemination, use and reuse of data+ in a Work;+ vi. database rights (such as those arising under Directive 96/9/EC of the+ European Parliament and of the Council of 11 March 1996 on the legal+ protection of databases, and under any national implementation+ thereof, including any amended or successor version of such+ directive); and+vii. other similar, equivalent or corresponding rights throughout the+ world based on applicable law or treaty, and any national+ implementations thereof.++2. Waiver. To the greatest extent permitted by, but not in contravention+of, applicable law, Affirmer hereby overtly, fully, permanently,+irrevocably and unconditionally waives, abandons, and surrenders all of+Affirmer's Copyright and Related Rights and associated claims and causes+of action, whether now known or unknown (including existing as well as+future claims and causes of action), in the Work (i) in all territories+worldwide, (ii) for the maximum duration provided by applicable law or+treaty (including future time extensions), (iii) in any current or future+medium and for any number of copies, and (iv) for any purpose whatsoever,+including without limitation commercial, advertising or promotional+purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each+member of the public at large and to the detriment of Affirmer's heirs and+successors, fully intending that such Waiver shall not be subject to+revocation, rescission, cancellation, termination, or any other legal or+equitable action to disrupt the quiet enjoyment of the Work by the public+as contemplated by Affirmer's express Statement of Purpose.++3. Public License Fallback. Should any part of the Waiver for any reason+be judged legally invalid or ineffective under applicable law, then the+Waiver shall be preserved to the maximum extent permitted taking into+account Affirmer's express Statement of Purpose. In addition, to the+extent the Waiver is so judged Affirmer hereby grants to each affected+person a royalty-free, non transferable, non sublicensable, non exclusive,+irrevocable and unconditional license to exercise Affirmer's Copyright and+Related Rights in the Work (i) in all territories worldwide, (ii) for the+maximum duration provided by applicable law or treaty (including future+time extensions), (iii) in any current or future medium and for any number+of copies, and (iv) for any purpose whatsoever, including without+limitation commercial, advertising or promotional purposes (the+"License"). The License shall be deemed effective as of the date CC0 was+applied by Affirmer to the Work. Should any part of the License for any+reason be judged legally invalid or ineffective under applicable law, such+partial invalidity or ineffectiveness shall not invalidate the remainder+of the License, and in such case Affirmer hereby affirms that he or she+will not (i) exercise any of his or her remaining Copyright and Related+Rights in the Work or (ii) assert any associated claims and causes of+action with respect to the Work, in either case contrary to Affirmer's+express Statement of Purpose.++4. Limitations and Disclaimers.++ a. No trademark or patent rights held by Affirmer are waived, abandoned,+ surrendered, licensed or otherwise affected by this document.+ b. Affirmer offers the Work as-is and makes no representations or+ warranties of any kind concerning the Work, express, implied,+ statutory or otherwise, including without limitation warranties of+ title, merchantability, fitness for a particular purpose, non+ infringement, or the absence of latent or other defects, accuracy, or+ the present or absence of errors, whether or not discoverable, all to+ the greatest extent permissible under applicable law.+ c. Affirmer disclaims responsibility for clearing rights of other persons+ that may apply to the Work or any use thereof, including without+ limitation any person's Copyright and Related Rights in the Work.+ Further, Affirmer disclaims responsibility for obtaining any necessary+ consents, permissions or other rights required for any use of the+ Work.+ d. Affirmer understands and acknowledges that Creative Commons is not a+ party to this document and has no duty or obligation with respect to+ this CC0 or use of the Work.
+ README.md view
@@ -0,0 +1,46 @@+# hs-rustls — Rustls for Haskell+[](https://github.com/amesgen/hs-rustls/actions)+[](https://hackage.haskell.org/package/rustls)++Haskell bindings for the [Rustls](https://github.com/rustls/rustls) TLS library via [rustls-ffi](https://github.com/rustls/rustls-ffi).++See [the haddocks](https://hackage.haskell.org/package/rustls/docs/Rustls.html) for documentation.++Also see:++ - [http-client-rustls](/http-client-rustls): Make HTTPS requests using [http-client](https://hackage.haskell.org/package/http-client) and Rustls.++## Development++### With Nix++When developing this library, just drop into a Nix shell.++If you want to depend on this library in another package, you have to make sure to include rustls-ffi as a native dependency. You can do so by depending on the `github:amesgen/hs-rustls?dir=nix-rustls` flake, and then using the `nix-rustls.packages.${system}.default` output.++### Without Nix++#### rustls-ffi++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+cd rustls-ffi+make DESTDIR=/path/to/some/dir install+```++Then, in a `cabal.project.local`, add these lines:++```cabal+extra-include-dirs: /path/to/some/dir/include+extra-lib-dirs: /path/to/some/dir/lib+```++With this, Cabal should be able to find the rustls-ffi native library.++> Note: This process might become less manual if sth like [haskell/cabal#7906](https://github.com/haskell/cabal/issues/7906) lands in Cabal.++#### Testing++When running the tests in this repo, you have to have [minica](https://github.com/jsha/minica) and [miniserve](https://github.com/svenstaro/miniserve) installed.
+ cbits/hs_rustls.h view
@@ -0,0 +1,20 @@+#ifndef HS_RUSTLS_H+#define HS_RUSTLS_H++#include "rustls.h"++static inline void hs_rustls_version(rustls_str *str);+static inline void hs_rustls_version(rustls_str *str) {+ *str = rustls_version();+}++static inline void hs_rustls_supported_ciphersuite_get_name(+ const struct rustls_supported_ciphersuite *supported_ciphersuite,+ rustls_str *str);+static inline void hs_rustls_supported_ciphersuite_get_name(+ const struct rustls_supported_ciphersuite *supported_ciphersuite,+ rustls_str *str) {+ *str = rustls_supported_ciphersuite_get_name(supported_ciphersuite);+}++#endif
+ rustls.cabal view
@@ -0,0 +1,84 @@+cabal-version: 2.4+name: rustls+version: 0.0.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++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++source-repository head+ location: https://github.com/amesgen/hs-rustls+ type: git++flag derive-storable-plugin+ description: Use derive-storable-plugin+ default: True+ manual: True++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++library+ import: commons+ ghc-options: -Wmissing-export-lists+ hs-source-dirs: src+ exposed-modules:+ Rustls+ Rustls.Internal+ Rustls.Internal.FFI+ build-depends:+ base >= 4.12 && < 5+ , bytestring >= 0.10 && < 0.12+ , text ^>= 1.2 || ^>= 2.0+ , derive-storable ^>= 0.3+ , transformers >= 0.5.6 && < 0.7+ , resourcet ^>= 1.2+ , network ^>= 3.1+ if flag(derive-storable-plugin)+ build-depends: derive-storable-plugin+ cpp-options: -DDERIVE_STORABLE_PLUGIN+ extra-libraries: rustls+ include-dirs: cbits++test-suite tasty+ import: commons+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: test+ 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.3+ , hedgehog >= 1.0 && < 1.2+ , 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
+ src/Rustls.hs view
@@ -0,0 +1,577 @@+-- | TLS bindings for [Rustls](https://github.com/rustls/rustls) via+-- [rustls-ffi](https://github.com/rustls/rustls-ffi).+--+-- See the [README on GitHub](https://github.com/amesgen/hs-rustls/tree/main/rustls)+-- for setup instructions.+--+-- Currently, most of the functionality exposed by rustls-ffi is available,+-- while rustls-ffi is still missing some more niche Rustls features.+--+-- Also see [http-client-rustls](https://hackage.haskell.org/package/http-client-rustls)+-- for making HTTPS requests using+-- [http-client](https://hackage.haskell.org/package/http-client) and Rustls.+--+-- == Client example+--+-- Suppose you have alread opened a 'Network.Socket.Socket' to @example.org@,+-- port 443 (see e.g. the examples at "Network.Socket"). This small example+-- showcases how to perform a simple HTTP GET request:+--+-- >>> :set -XOverloadedStrings+-- >>> import qualified Rustls+-- >>> import Network.Socket (Socket)+-- >>> import Data.Acquire (withAcquire)+-- >>> :{+-- example :: Socket -> IO ()+-- example socket = do+-- -- It is encouraged to share a single `clientConfig` when creating multiple+-- -- TLS connections.+-- clientConfig <-+-- Rustls.buildClientConfig $ Rustls.defaultClientConfigBuilder roots+-- let newConnection =+-- Rustls.newClientConnection socket clientConfig "example.org"+-- withAcquire newConnection $ \conn -> do+-- Rustls.writeBS conn "GET /"+-- recv <- Rustls.readBS conn 1000 -- max number of bytes to read+-- print recv+-- where+-- -- For now, rustls-ffi does not provide a built-in way to access+-- -- the OS certificate store.+-- roots = Rustls.ClientRootsFromFile "/etc/ssl/certs/ca-certificates.crt"+-- :}+--+-- == Using 'Acquire'+--+-- Some API functions (like 'newClientConnection' and 'newServerConnection')+-- return an 'Acquire' from+-- [resourcet](https://hackage.haskell.org/package/resourcet), as it is a+-- convenient abstraction for exposing a value that should be consumed in a+-- "bracketed" manner.+--+-- Usually, it can be used via 'Data.Acquire.with' or 'withAcquire', or via+-- 'allocateAcquire' when a 'Control.Monad.Trans.Resource.MonadResource'+-- constraint is available. If you really need the extra flexibility, you can+-- also access separate @open…@ and @close…@ functions by reaching for+-- "Data.Acquire.Internal".+module Rustls+ ( -- * Client++ -- ** Builder+ ClientConfigBuilder (..),+ defaultClientConfigBuilder,+ ClientRoots (..),+ PEMCertificates (..),++ -- ** Config+ ClientConfig,+ clientConfigLogCallback,+ buildClientConfig,++ -- ** Open a connection+ newClientConnection,++ -- * Server++ -- ** Builder+ ServerConfigBuilder (..),+ defaultServerConfigBuilder,+ ClientCertVerifier (..),++ -- ** Config+ ServerConfig,+ serverConfigLogCallback,+ buildServerConfig,++ -- ** Open a connection+ newServerConnection,++ -- * Connection+ Connection,+ Side (..),++ -- ** Read and write+ readBS,+ writeBS,++ -- ** Handshaking+ handshake,+ HandshakeQuery,+ getALPNProtocol,+ getTLSVersion,+ getCipherSuite,+ getSNIHostname,+ getPeerCertificate,++ -- ** Closing+ sendCloseNotify,++ -- ** Logging+ LogCallback,+ newLogCallback,+ LogLevel (..),++ -- ** Raw 'Ptr'-based API+ readPtr,+ writePtr,++ -- * Misc+ version,++ -- ** Backend+ Backend (..),+ ByteStringBackend (..),++ -- ** Types+ ALPNProtocol (..),+ CertifiedKey (..),+ DERCertificate (..),+ TLSVersion (TLS12, TLS13, unTLSVersion),+ defaultTLSVersions,+ allTLSVersions,+ CipherSuite,+ cipherSuiteID,+ showCipherSuite,+ defaultCipherSuites,+ allCipherSuites,++ -- ** Exceptions+ RustlsException,+ isCertError,+ )+where++import Control.Concurrent (forkFinally, killThread)+import Control.Concurrent.MVar+import qualified Control.Exception as E+import Control.Monad (forever, when, (<=<))+import Control.Monad.IO.Class+import Control.Monad.Trans.Cont+import Control.Monad.Trans.Reader+import Data.Acquire+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Internal as BI+import qualified Data.ByteString.Unsafe as BU+import Data.Coerce+import Data.Foldable (for_)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NE+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Foreign as T+import Foreign+import Foreign.C+import GHC.Generics (Generic)+import Rustls.Internal+import Rustls.Internal.FFI (TLSVersion (..))+import qualified Rustls.Internal.FFI as FFI+import System.IO (hPutStrLn, stderr)+import System.IO.Unsafe (unsafePerformIO)++-- $setup+-- >>> import Control.Monad.IO.Class+-- >>> import Data.Acquire++-- | Combined version string of Rustls and rustls-ffi.+--+-- >>> version+-- "rustls-ffi/0.9.1/rustls/0.20.4"+version :: Text+version = unsafePerformIO $ alloca \strPtr -> do+ FFI.hsVersion strPtr+ strToText =<< peek strPtr+{-# NOINLINE version #-}++peekNonEmpty :: (Storable a, Coercible a b) => Ptr a -> CSize -> NonEmpty b+peekNonEmpty as len =+ NE.fromList . coerce . unsafePerformIO $ peekArray (cSizeToInt len) as++-- | All 'TLSVersion's supported by Rustls.+allTLSVersions :: NonEmpty TLSVersion+allTLSVersions = peekNonEmpty FFI.allVersions FFI.allVersionsLen+{-# NOINLINE allTLSVersions #-}++-- | The default 'TLSVersion's used by Rustls. A subset of 'defaultTLSVersions'.+defaultTLSVersions :: NonEmpty TLSVersion+defaultTLSVersions = peekNonEmpty FFI.defaultVersions FFI.defaultVersionsLen+{-# NOINLINE defaultTLSVersions #-}++-- | All 'CipherSuite's supported by Rustls.+allCipherSuites :: NonEmpty CipherSuite+allCipherSuites = peekNonEmpty FFI.allCipherSuites FFI.allCipherSuitesLen+{-# NOINLINE allCipherSuites #-}++-- | The default 'CipherSuite's used by Rustls. A subset of 'allCipherSuites'.+defaultCipherSuites :: NonEmpty CipherSuite+defaultCipherSuites = peekNonEmpty FFI.defaultCipherSuites FFI.defaultCipherSuitesLen+{-# NOINLINE defaultCipherSuites #-}++-- | A 'ClientConfigBuilder' with good defaults.+defaultClientConfigBuilder :: ClientRoots -> ClientConfigBuilder+defaultClientConfigBuilder roots =+ ClientConfigBuilder+ { clientConfigTLSVersions = [],+ clientConfigCipherSuites = [],+ clientConfigRoots = roots,+ clientConfigALPNProtocols = [],+ clientConfigEnableSNI = True,+ clientConfigCertifiedKeys = []+ }++withCertifiedKeys :: [CertifiedKey] -> ((Ptr (Ptr FFI.CertifiedKey), CSize) -> IO a) -> IO a+withCertifiedKeys certifiedKeys cb =+ withMany withCertifiedKey certifiedKeys \certKeys ->+ withArrayLen certKeys \len ptr -> cb (ptr, intToCSize len)+ where+ withCertifiedKey CertifiedKey {..} cb =+ BU.unsafeUseAsCStringLen certificateChain \(castPtr -> certPtr, intToCSize -> certLen) ->+ BU.unsafeUseAsCStringLen privateKey \(castPtr -> privPtr, intToCSize -> privLen) ->+ alloca \certKeyPtr -> do+ rethrowR =<< FFI.certifiedKeyBuild certPtr certLen privPtr privLen certKeyPtr+ cb =<< peek certKeyPtr++withALPNProtocols :: [ALPNProtocol] -> ((Ptr FFI.SliceBytes, CSize) -> IO a) -> IO a+withALPNProtocols bss cb = do+ withMany withSliceBytes (coerce bss) \bsPtrs ->+ withArrayLen bsPtrs \len bsPtr -> cb (bsPtr, intToCSize len)+ where+ withSliceBytes bs cb =+ BU.unsafeUseAsCStringLen bs \(castPtr -> buf, intToCSize -> len) ->+ cb $ FFI.SliceBytes buf len++configBuilderNew ::+ ( Ptr (Ptr FFI.SupportedCipherSuite) ->+ CSize ->+ Ptr TLSVersion ->+ CSize ->+ Ptr (Ptr configBuilder) ->+ IO FFI.Result+ ) ->+ [CipherSuite] ->+ [TLSVersion] ->+ IO (Ptr configBuilder)+configBuilderNew configBuilderNewCustom cipherSuites tlsVersions = evalContT do+ builderPtr <- ContT alloca+ (cipherSuitesLen, cipherSuitesPtr) <-+ if null cipherSuites+ then pure (FFI.defaultCipherSuitesLen, FFI.defaultCipherSuites)+ else ContT \cb -> withArrayLen (coerce cipherSuites) \len ptr ->+ cb (intToCSize len, ptr)+ (tlsVersionsLen, tlsVersionsPtr) <-+ if null tlsVersions+ then pure (FFI.defaultVersionsLen, FFI.defaultVersions)+ else ContT \cb -> withArrayLen tlsVersions \len ptr ->+ cb (intToCSize len, ptr)+ liftIO do+ rethrowR+ =<< configBuilderNewCustom+ cipherSuitesPtr+ cipherSuitesLen+ tlsVersionsPtr+ tlsVersionsLen+ builderPtr+ peek builderPtr++withRootCertStore :: [PEMCertificates] -> (Ptr 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 (castPtr buf) (intToCSize len) strict+ for_ certs \case+ PEMCertificatesStrict bs -> addPEM bs True+ PEMCertificatesLax bs -> addPEM bs False+ action store++-- | Build a 'ClientConfigBuilder' into a 'ClientConfig'.+--+-- This is a relatively expensive operation, so it is a good idea to share one+-- 'ClientConfig' when creating multiple 'Connection's.+buildClientConfig :: MonadIO m => ClientConfigBuilder -> m ClientConfig+buildClientConfig ClientConfigBuilder {..} = 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+ 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 =<< 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 =<< FFI.serverConfigBuilderBuild builder+ let serverConfigLogCallback = Nothing+ pure ServerConfig {..}++-- | A 'ServerConfigBuilder' with good defaults.+defaultServerConfigBuilder :: NonEmpty CertifiedKey -> ServerConfigBuilder+defaultServerConfigBuilder certifiedKeys =+ ServerConfigBuilder+ { serverConfigCertifiedKeys = certifiedKeys,+ serverConfigTLSVersions = [],+ serverConfigCipherSuites = [],+ serverConfigALPNProtocols = [],+ serverConfigIgnoreClientOrder = False,+ serverConfigClientCertVerifier = Nothing+ }++-- | Allocate a new logging callback, taking a 'LogLevel' and a message.+--+-- 🚫 Make sure that its lifetime encloses those of the 'Connection's which you+-- configured to use it.+newLogCallback :: (LogLevel -> Text -> IO ()) -> Acquire LogCallback+newLogCallback cb = fmap LogCallback . flip mkAcquire freeHaskellFunPtr $+ FFI.mkLogCallback \_ logParamsPtr -> ignoreExceptions do+ FFI.LogParams {..} <- peek logParamsPtr+ let logLevel = case rustlsLogParamsLevel of+ FFI.LogLevel 1 -> Right LogLevelError+ FFI.LogLevel 2 -> Right LogLevelWarn+ FFI.LogLevel 3 -> Right LogLevelInfo+ FFI.LogLevel 4 -> Right LogLevelDebug+ FFI.LogLevel 5 -> Right LogLevelTrace+ FFI.LogLevel l -> Left l+ case logLevel of+ Left l -> hPutStrLn stderr $ "invalid Rustls log level: " <> show l+ Right logLevel -> do+ msg <- strToText rustlsLogParamsMessage+ cb logLevel msg `E.catch` \(e :: E.SomeException) ->+ hPutStrLn stderr $ "Rustls log callback errored: " <> E.displayException e++newConnection ::+ Backend b =>+ b ->+ ForeignPtr config ->+ Maybe LogCallback ->+ (Ptr config -> Ptr (Ptr FFI.Connection) -> IO FFI.Result) ->+ Acquire (Connection side)+newConnection backend configPtr logCallback connectionNew =+ mkAcquire acquire release+ where+ acquire = do+ conn <-+ alloca \connPtrPtr ->+ withForeignPtr configPtr \cfgPtr -> liftIO do+ rethrowR =<< connectionNew cfgPtr connPtrPtr+ peek connPtrPtr+ ioMsgReq <- newEmptyMVar+ ioMsgRes <- newEmptyMVar+ lenPtr <- malloc+ readWriteCallback <- FFI.mkReadWriteCallback \_ud buf len iPtr -> do+ putMVar ioMsgRes $ UsingBuffer buf len iPtr+ Done ioResult <- takeMVar ioMsgReq+ pure ioResult+ let freeCallback = freeHaskellFunPtr readWriteCallback+ interact = forever do+ Request readOrWrite <- takeMVar ioMsgReq+ let readOrWriteTls = case readOrWrite of+ Read -> FFI.connectionReadTls+ Write -> FFI.connectionWriteTls+ _ <- readOrWriteTls conn readWriteCallback nullPtr lenPtr+ putMVar ioMsgRes DoneFFI+ interactThread <- forkFinally interact (const freeCallback)+ for_ logCallback $ FFI.connectionSetLogCallback conn . unLogCallback+ Connection <$> newMVar Connection' {..}+ release (Connection c) = do+ Just Connection' {..} <- tryTakeMVar c+ FFI.connectionFree conn+ free lenPtr+ killThread interactThread++-- | Initialize a TLS connection as a client.+newClientConnection ::+ Backend b =>+ b ->+ ClientConfig ->+ -- | Hostname.+ Text ->+ Acquire (Connection Client)+newClientConnection b ClientConfig {..} hostname =+ newConnection b clientConfigPtr clientConfigLogCallback \configPtr connPtrPtr ->+ withCString (T.unpack hostname) \hostnamePtr ->+ FFI.clientConnectionNew configPtr hostnamePtr connPtrPtr++-- | Initialize a TLS connection as a server.+newServerConnection ::+ Backend b =>+ b ->+ ServerConfig ->+ Acquire (Connection Server)+newServerConnection b ServerConfig {..} =+ newConnection b serverConfigPtr serverConfigLogCallback FFI.serverConnectionNew++-- | Ensure that the connection is handshaked. It is only necessary to call this+-- if you want to obtain connection information. You can do so by providing a+-- 'HandshakeQuery'.+--+-- >>> :{+-- getALPNAndTLSVersion ::+-- MonadIO m =>+-- Connection side ->+-- m (Maybe ALPNProtocol, TLSVersion)+-- getALPNAndTLSVersion conn =+-- handshake conn $ (,) <$> getALPNProtocol <*> getTLSVersion+-- :}+handshake :: MonadIO m => Connection side -> HandshakeQuery side a -> m a+handshake conn (HandshakeQuery query) = liftIO do+ withConnection conn \c -> do+ runTLS c TLSHandshake+ runReaderT query c++-- | Get the negotiated ALPN protocol, if any.+getALPNProtocol :: HandshakeQuery side (Maybe ALPNProtocol)+getALPNProtocol = handshakeQuery \Connection' {conn, lenPtr} ->+ alloca \bufPtrPtr -> do+ FFI.connectionGetALPNProtocol conn bufPtrPtr lenPtr+ bufPtr <- peek bufPtrPtr+ len <- peek lenPtr+ !alpn <- B.packCStringLen (castPtr bufPtr, cSizeToInt len)+ pure $ if B.null alpn then Nothing else Just $ ALPNProtocol alpn++-- | Get the negotiated TLS protocol version.+getTLSVersion :: HandshakeQuery side TLSVersion+getTLSVersion = handshakeQuery \Connection' {conn} -> do+ !ver <- FFI.connectionGetProtocolVersion conn+ when (unTLSVersion ver == 0) $+ fail "internal rustls error: no protocol version negotiated"+ pure ver++-- | Get the negotiated cipher suite.+getCipherSuite :: HandshakeQuery side CipherSuite+getCipherSuite = handshakeQuery \Connection' {conn} -> do+ !cipherSuite <- FFI.connectionGetNegotiatedCipherSuite conn+ when (cipherSuite == nullPtr) $+ fail "internal rustls error: no cipher suite negotiated"+ pure $ CipherSuite cipherSuite++-- | Get the SNI hostname set by the client, if any.+getSNIHostname :: HandshakeQuery Server (Maybe Text)+getSNIHostname = handshakeQuery \Connection' {conn, lenPtr} ->+ let go n = allocaBytes (cSizeToInt n) \bufPtr -> do+ res <- FFI.serverConnectionGetSNIHostname conn bufPtr n lenPtr+ if res == FFI.resultInsufficientSize+ then go (2 * n)+ else do+ rethrowR res+ len <- peek lenPtr+ !sni <- T.peekCStringLen (castPtr bufPtr, cSizeToInt len)+ pure $ if T.null sni then Nothing else Just sni+ in go 16++-- | A DER-encoded certificate.+newtype DERCertificate = DERCertificate {unDERCertificate :: ByteString}+ deriving stock (Show, Eq, Ord, Generic)++-- | Get the @i@-th certificate provided by the peer.+--+-- Index @0@ is the end entity certificate. Higher indices are certificates in+-- the chain. Requesting an index higher than what is available returns+-- 'Nothing'.+getPeerCertificate :: CSize -> HandshakeQuery side (Maybe DERCertificate)+getPeerCertificate i = handshakeQuery \Connection' {conn, lenPtr} -> do+ certPtr <- FFI.connectionGetPeerCertificate conn i+ if certPtr == nullPtr+ then pure Nothing+ else alloca \bufPtrPtr -> do+ rethrowR =<< FFI.certificateGetDER certPtr bufPtrPtr lenPtr+ bufPtr <- peek bufPtrPtr+ len <- cSizeToInt <$> peek lenPtr+ !bs <- B.packCStringLen (castPtr bufPtr, len)+ pure $ Just $ DERCertificate bs++-- | Send a @close_notify@ warning alert. This informs the peer that the+-- connection is being closed.+sendCloseNotify :: MonadIO m => Connection side -> m ()+sendCloseNotify conn = liftIO $+ withConnection conn \c@Connection' {conn} -> do+ FFI.connectionSendCloseNotify conn+ runTLS c TLSWrite++-- | 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+ rethrowR =<< FFI.connectionRead conn buf len lenPtr+ peek lenPtr++-- | Read data from the Rustls 'Connection' into a 'ByteString'. The result will+-- not be longer than the given length.+readBS ::+ MonadIO m =>+ Connection side ->+ -- | Maximum result length. Note that a buffer of this size will be allocated.+ Int ->+ m ByteString+readBS conn maxLen = liftIO $+ BI.createAndTrim maxLen \buf ->+ cSizeToInt <$> readPtr conn buf (intToCSize maxLen)++-- | Write data to the Rustls 'Connection' from the given buffer.+writePtr :: MonadIO m => Connection side -> Ptr Word8 -> CSize -> m CSize+writePtr conn buf len = liftIO $+ withConnection conn \c@Connection' {..} -> do+ rethrowR =<< FFI.connectionWrite conn buf len lenPtr+ runTLS c TLSWrite+ peek lenPtr++-- | Write a 'ByteString' to the Rustls 'Connection'.+writeBS :: MonadIO m => Connection side -> ByteString -> m ()+writeBS conn bs = liftIO $ BU.unsafeUseAsCStringLen bs go+ where+ go (buf, len) = do+ written <- cSizeToInt <$> writePtr conn (castPtr buf) (intToCSize len)+ when (written < len) $+ go (buf `plusPtr` len, len - written)
+ src/Rustls/Internal.hs view
@@ -0,0 +1,397 @@+{-# OPTIONS_GHC -Wno-missing-export-lists #-}++-- | Internal module, not subject to PVP.+module Rustls.Internal where++import Control.Concurrent (ThreadId)+import Control.Concurrent.MVar+import qualified Control.Exception 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.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 Foreign hiding (void)+import Foreign.C+import GHC.Generics (Generic)+import qualified Network.Socket as NS+import qualified Rustls.Internal.FFI as FFI+import System.IO.Unsafe (unsafePerformIO)++-- | An ALPN protocol ID. See+-- <https://www.iana.org/assignments/tls-extensiontype-values/tls-extensiontype-values.xhtml#alpn-protocol-ids>+-- for a list of registered IDs.+newtype ALPNProtocol = ALPNProtocol {unALPNProtocol :: ByteString}+ deriving stock (Show, Eq, Ord, Generic)++-- | A TLS cipher suite supported by Rustls.+newtype CipherSuite = CipherSuite (Ptr FFI.SupportedCipherSuite)++-- | Get the IANA value from a cipher suite. The bytes are interpreted in network order.+--+-- See <https://www.iana.org/assignments/tls-parameters/tls-parameters.xhtml#tls-parameters-4> for a list.+cipherSuiteID :: CipherSuite -> Word16+cipherSuiteID (CipherSuite cipherSuitePtr) =+ FFI.supportedCipherSuiteGetSuite cipherSuitePtr++instance Eq CipherSuite where+ (==) = (==) `on` cipherSuiteID++instance Ord CipherSuite where+ compare = compare `on` cipherSuiteID++-- | Get the text representation of a cipher suite.+showCipherSuite :: CipherSuite -> Text+showCipherSuite (CipherSuite cipherSuitePtr) = unsafePerformIO $+ alloca \strPtr -> do+ FFI.hsSupportedCipherSuiteGetName cipherSuitePtr strPtr+ strToText =<< peek strPtr++instance Show CipherSuite where+ show = T.unpack . showCipherSuite++-- | Rustls client config builder.+data ClientConfigBuilder = ClientConfigBuilder+ { -- | Client root certificates.+ clientConfigRoots :: ClientRoots,+ -- | Supported 'FFI.TLSVersion's. When empty, good defaults are used.+ clientConfigTLSVersions :: [FFI.TLSVersion],+ -- | Supported 'CipherSuite's in order of preference. When empty, good+ -- defaults are used.+ clientConfigCipherSuites :: [CipherSuite],+ -- | ALPN protocols.+ clientConfigALPNProtocols :: [ALPNProtocol],+ -- | Whether to enable Server Name Indication. Defaults to 'True'.+ clientConfigEnableSNI :: Bool,+ -- | List of 'CertifiedKey's for client authentication.+ --+ -- Clients that want to support both ECDSA and RSA certificates will want+ -- the ECDSA to go first in the list.+ clientConfigCertifiedKeys :: [CertifiedKey]+ }+ 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"++-- | In-memory 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+ deriving stock (Show, Generic)++-- | A complete chain of certificates plus a private key for the leaf certificate.+data CertifiedKey = CertifiedKey+ { -- | PEM-encoded certificate chain.+ certificateChain :: ByteString,+ -- | PEM-encoded private key.+ privateKey :: ByteString+ }+ deriving stock (Generic)++instance Show CertifiedKey where+ show _ = "CertifiedKey"++-- | Assembled configuration for a Rustls client connection.+data ClientConfig = ClientConfig+ { clientConfigPtr :: ForeignPtr FFI.ClientConfig,+ -- | A logging callback. If it throws an exception, a note will be printed+ -- to stderr.+ --+ -- Note that this is a record selector, so you can use it as a setter:+ --+ -- >>> :{+ -- setLogCallback :: LogCallback -> ClientConfig -> ClientConfig+ -- setLogCallback logCallback clientConfig =+ -- clientConfig { clientConfigLogCallback = Just logCallback }+ -- :}+ clientConfigLogCallback :: Maybe LogCallback+ }++-- | 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]+ deriving stock (Show, Generic)++-- | Rustls client config builder.+data ServerConfigBuilder = ServerConfigBuilder+ { -- | List of 'CertifiedKey's.+ serverConfigCertifiedKeys :: NonEmpty CertifiedKey,+ -- | Supported 'FFI.TLSVersion's. When empty, good defaults are+ -- used.+ serverConfigTLSVersions :: [FFI.TLSVersion],+ -- | Supported 'CipherSuite's in order of preference. When empty, good+ -- defaults are used.+ serverConfigCipherSuites :: [CipherSuite],+ -- | ALPN protocols.+ serverConfigALPNProtocols :: [ALPNProtocol],+ -- | Ignore the client's ciphersuite order. Defaults to 'False'.+ serverConfigIgnoreClientOrder :: Bool,+ -- | Optionally, a client cert verifier.+ serverConfigClientCertVerifier :: Maybe ClientCertVerifier+ }+ deriving stock (Show, Generic)++-- | Assembled configuration for a Rustls server connection.+data ServerConfig = ServerConfig+ { serverConfigPtr :: ForeignPtr FFI.ServerConfig,+ -- | A logging callback. If it throws an exception, a note will be printed+ -- to stderr.+ --+ -- Note that this is a record selector, so you can use it as a setter:+ --+ -- >>> :{+ -- setLogCallback :: LogCallback -> ServerConfig -> ServerConfig+ -- setLogCallback logCallback serverConfig =+ -- serverConfig { serverConfigLogCallback = Just logCallback }+ -- :}+ serverConfigLogCallback :: Maybe LogCallback+ }++-- | Rustls log level.+data LogLevel+ = LogLevelError+ | LogLevelWarn+ | LogLevelInfo+ | LogLevelDebug+ | LogLevelTrace+ deriving stock (Show, Eq, Ord, Enum, Bounded, Generic)++-- | A Rustls connection logging callback.+newtype LogCallback = LogCallback {unLogCallback :: FunPtr FFI.LogCallback}++-- | A 'Monad' to get TLS connection information via 'Rustls.handshake'.+newtype HandshakeQuery (side :: Side) a = HandshakeQuery (ReaderT Connection' IO a)+ deriving newtype (Functor, Applicative, Monad)++type role HandshakeQuery nominal _++handshakeQuery :: (Connection' -> IO a) -> HandshakeQuery side a+handshakeQuery = coerce++-- | TLS exception thrown by Rustls.+--+-- Use 'E.displayException' for a human-friendly representation.+newtype RustlsException = RustlsException {rustlsErrorCode :: Word32}+ deriving stock (Show)++instance E.Exception RustlsException where+ displayException RustlsException {rustlsErrorCode} =+ unwords+ [ "Rustls error:",+ T.unpack (resultMsg (FFI.Result rustlsErrorCode)),+ "(" <> show rustlsErrorCode <> ")"+ ]++resultMsg :: FFI.Result -> Text+resultMsg r = unsafePerformIO $+ alloca \lenPtr -> allocaBytes (cSizeToInt msgLen) \buf -> do+ FFI.errorMsg r buf msgLen lenPtr+ len <- peek lenPtr+ T.peekCStringLen (buf, cSizeToInt len)+ where+ msgLen = 1024 -- a bit pessimistic?++-- | Checks if the given 'RustlsException' represents a certificate error.+isCertError :: RustlsException -> Bool+isCertError RustlsException {rustlsErrorCode} =+ toBool @CBool $ FFI.resultIsCertError (FFI.Result rustlsErrorCode)++rethrowR :: FFI.Result -> IO ()+rethrowR = \case+ r | r == FFI.resultOk -> mempty+ FFI.Result rustlsErrorCode ->+ E.throwIO $ RustlsException rustlsErrorCode++-- | 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++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)++-- | 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++-- | Type-level indicator whether a 'Connection' is client- or server-side.+data Side = Client | Server++-- | A Rustls connection.+newtype Connection (side :: Side) = Connection (MVar Connection')++type role Connection nominal++data Connection' = forall b.+ Backend b =>+ Connection'+ { conn :: Ptr FFI.Connection,+ backend :: b,+ lenPtr :: Ptr CSize,+ ioMsgReq :: MVar IOMsgReq,+ ioMsgRes :: MVar IOMsgRes,+ interactThread :: ThreadId+ }++withConnection :: Connection side -> (Connection' -> IO a) -> IO a+withConnection (Connection c) = withMVar c++data ReadOrWrite = Read | Write++-- GHC will delay async exceptions to (non-interruptible) FFI calls until they+-- finish. In particular, this means that when a (safe) FFI call invokes a+-- Haskell callback, it is uncancelable. As usages of this library will most+-- likely involve actual I/O (which really should be able to be cancelled), we+-- invoke the respective FFI functions (which will themselves then call back+-- into Haskell) in a separate thread, and interact with it via message passing+-- (see the 'IOMsgReq' and 'IOMsgRes' types).++-- | Messages sent to the background thread.+data IOMsgReq+ = -- | Request to start a read or a write FFI call from the background thread.+ -- It should respond with 'UsingBuffer'.+ Request ReadOrWrite+ | -- | Notify the background thread that we are done interacting with the+ -- buffer.+ Done FFI.IOResult++-- | Messages sent from the background thread.+data IOMsgRes+ = -- | Reply with a buffer, either containing the read data, or awaiting a+ -- write to this buffer.+ UsingBuffer (Ptr Word8) CSize (Ptr CSize)+ | -- | Notify that the FFI call finished.+ DoneFFI++interactTLS :: Connection' -> ReadOrWrite -> IO ()+interactTLS Connection' {..} readOrWrite = E.uninterruptibleMask \restore -> do+ putMVar ioMsgReq $ Request readOrWrite+ UsingBuffer buf len readPtr <- takeMVar ioMsgRes+ poke readPtr+ =<< restore (readOrWriteBackend buf len)+ `E.onException` done FFI.ioResultErr+ done FFI.ioResultOk+ where+ readOrWriteBackend = case readOrWrite of+ Read -> backendRead backend+ Write -> backendWrite backend+ done ioResult = do+ putMVar ioMsgReq $ Done ioResult+ DoneFFI <- takeMVar ioMsgRes+ pure ()++data RunTLSMode = TLSHandshake | TLSRead | TLSWrite+ deriving (Eq)++runTLS :: Connection' -> RunTLSMode -> IO ()+runTLS c@Connection' {..} = \case+ TLSHandshake -> loopWhileTrue do+ toBool @CBool <$> FFI.connectionIsHandshaking conn >>= \case+ True -> (||) <$> runWrite <*> runRead+ False -> pure False+ TLSRead -> do+ runTLS c TLSHandshake+ loopWhileTrue runRead+ TLSWrite -> do+ runTLS c TLSHandshake+ loopWhileTrue runWrite+ where+ runRead = do+ wantsRead <- toBool @CBool <$> FFI.connectionWantsRead 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++ runWrite = do+ wantsWrite <- toBool @CBool <$> FFI.connectionWantsWrite conn+ when wantsWrite $+ interactTLS c Write+ pure wantsWrite++ loopWhileTrue action = do+ continue <- action+ when continue $ loopWhileTrue action++cSizeToInt :: CSize -> Int+cSizeToInt = fromIntegral+{-# INLINE cSizeToInt #-}++intToCSize :: Int -> CSize+intToCSize = fromIntegral+{-# INLINE intToCSize #-}++strToText :: FFI.Str -> IO Text+strToText (FFI.Str buf len) = T.peekCStringLen (buf, cSizeToInt len)++ignoreExceptions :: IO () -> IO ()+ignoreExceptions = void . E.try @E.SomeException++ignoreSyncExceptions :: IO () -> IO ()+ignoreSyncExceptions = E.handle \case+ (E.fromException -> Just e@(E.SomeAsyncException _)) -> E.throwIO e+ _ -> pure ()
+ src/Rustls/Internal/FFI.hs view
@@ -0,0 +1,442 @@+#if DERIVE_STORABLE_PLUGIN+{-# OPTIONS_GHC -fplugin=Foreign.Storable.Generic.Plugin #-}+#endif++-- | Internal module, not subject to PVP.+module Rustls.Internal.FFI+ ( -- * Client++ -- ** Config+ ClientConfig,+ ClientConfigBuilder,+ clientConfigBuilderNewCustom,+ clientConfigBuilderFree,+ clientConfigBuilderBuild,+ clientConfigFree,+ clientConfigBuilderSetALPNProtocols,+ clientConfigBuilderSetEnableSNI,+ clientConfigBuilderSetCertifiedKey,+ clientConfigBuilderLoadRootsFromFile,+ clientConfigBuilderUseRoots,++ -- ** Connection+ clientConnectionNew,+ serverConnectionNew,++ -- * Server++ -- ** Config+ ServerConfig,+ ServerConfigBuilder,+ serverConfigBuilderNewCustom,+ serverConfigBuilderFree,+ serverConfigBuilderBuild,+ serverConfigFree,+ serverConfigBuilderSetALPNProtocols,+ serverConfigBuilderSetIgnoreClientOrder,+ serverConfigBuilderSetCertifiedKeys,+ ClientCertVerifier,+ clientCertVerifierNew,+ clientCertVerifierFree,+ serverConfigBuilderSetClientVerifier,+ ClientCertVerifierOptional,+ clientCertVerifierOptionalNew,+ clientCertVerifierOptionalFree,+ serverConfigBuilderSetClientVerifierOptional,++ -- * Certificate stuff+ CertifiedKey,+ certifiedKeyBuild,+ certifiedKeyFree,+ Certificate,+ certificateGetDER,++ -- * Connection+ Connection,+ connectionFree,++ -- ** Read/write+ ReadWriteCallback,+ mkReadWriteCallback,++ -- *** Read+ connectionWantsRead,+ connectionRead,+ connectionReadTls,++ -- *** Write+ connectionWantsWrite,+ connectionWrite,+ connectionWriteTls,++ -- ** Misc+ connectionProcessNewPackets,+ connectionIsHandshaking,+ connectionSendCloseNotify,+ connectionSetBufferLimit,+ connectionGetALPNProtocol,+ connectionGetProtocolVersion,+ connectionGetNegotiatedCipherSuite,+ serverConnectionGetSNIHostname,+ connectionGetPeerCertificate,++ -- ** Logging+ connectionSetLogCallback,+ LogCallback,+ mkLogCallback,+ LogParams (..),+ LogLevel (..),++ -- * Misc+ Str (..),+ SliceBytes (..),+ hsVersion,+ Userdata,++ -- ** 'Result'+ Result (..),+ resultIsCertError,+ errorMsg,++ -- *** Some values+ resultOk,+ resultInsufficientSize,++ -- ** 'IOResult'+ IOResult (..),+ ioResultOk,+ ioResultErr,++ -- ** TLS params+ SupportedCipherSuite,+ allCipherSuites,+ allCipherSuitesLen,+ defaultCipherSuites,+ defaultCipherSuitesLen,+ supportedCipherSuiteGetSuite,+ hsSupportedCipherSuiteGetName,+ TLSVersion (..),+ pattern TLS12,+ pattern TLS13,+ allVersions,+ allVersionsLen,+ defaultVersions,+ defaultVersionsLen,++ -- ** Root cert store+ RootCertStore,+ rootCertStoreNew,+ rootCertStoreAddPEM,+ rootCertStoreFree,+ )+where++import Data.Word+import Foreign+import Foreign.C+import Foreign.Storable.Generic+import GHC.Generics (Generic)++-- Misc++data {-# CTYPE "rustls.h" "rustls_str" #-} Str = Str CString CSize+ deriving stock (Generic)+ deriving anyclass (GStorable)++data {-# CTYPE "rustls.h" "rustls_slice_bytes" #-} SliceBytes = SliceBytes (Ptr Word8) CSize+ deriving stock (Generic)+ deriving anyclass (GStorable)++foreign import capi unsafe "hs_rustls.h hs_rustls_version"+ hsVersion :: Ptr Str -> IO ()++newtype {-# CTYPE "rustls.h" "rustls_result" #-} Result = Result Word32+ deriving stock (Show, Eq, Ord)++foreign import capi "rustls.h value RUSTLS_RESULT_OK"+ resultOk :: Result++foreign import capi "rustls.h value RUSTLS_RESULT_INSUFFICIENT_SIZE"+ resultInsufficientSize :: Result++foreign import capi unsafe "rustls.h rustls_result_is_cert_error"+ resultIsCertError :: Result -> CBool++foreign import capi unsafe "rustls.h rustls_error"+ errorMsg :: Result -> CString -> CSize -> Ptr CSize -> IO ()++newtype {-# CTYPE "rustls.h" "rustls_io_result" #-} IOResult = IOResult CInt+ deriving stock (Eq)++ioResultOk :: IOResult+ioResultOk = IOResult 0++ioResultErr :: IOResult+ioResultErr = IOResult 1++-- | (Unused) userdata.+data Userdata++-- Client++data {-# CTYPE "rustls.h" "rustls_client_config" #-} ClientConfig++data {-# CTYPE "rustls.h" "rustls_client_config_builder" #-} ClientConfigBuilder++foreign import capi unsafe "rustls.h rustls_client_config_builder_new_custom"+ clientConfigBuilderNewCustom ::+ Ptr (Ptr SupportedCipherSuite) ->+ CSize ->+ Ptr TLSVersion ->+ CSize ->+ Ptr (Ptr ClientConfigBuilder) ->+ IO Result++foreign import capi unsafe "rustls.h rustls_client_config_builder_free"+ clientConfigBuilderFree :: Ptr ClientConfigBuilder -> IO ()++foreign import capi unsafe "rustls.h rustls_client_config_builder_build"+ clientConfigBuilderBuild :: Ptr ClientConfigBuilder -> IO (Ptr ClientConfig)++foreign import capi unsafe "rustls.h &rustls_client_config_free"+ clientConfigFree :: FinalizerPtr ClientConfig++foreign import capi unsafe "rustls.h rustls_client_connection_new"+ clientConnectionNew ::+ Ptr ClientConfig ->+ -- | Hostname.+ CString ->+ Ptr (Ptr Connection) ->+ IO Result++foreign import capi unsafe "rustls.h rustls_client_config_builder_load_roots_from_file"+ clientConfigBuilderLoadRootsFromFile :: Ptr ClientConfigBuilder -> CString -> 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 -> Ptr 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 -> Ptr RootCertStore -> IO Result++foreign import capi unsafe "rustls.h rustls_client_config_builder_set_alpn_protocols"+ clientConfigBuilderSetALPNProtocols :: Ptr ClientConfigBuilder -> Ptr SliceBytes -> CSize -> IO Result++foreign import capi unsafe "rustls.h rustls_client_config_builder_set_enable_sni"+ clientConfigBuilderSetEnableSNI :: Ptr ClientConfigBuilder -> CBool -> IO ()++foreign import capi unsafe "rustls.h rustls_client_config_builder_set_certified_key"+ clientConfigBuilderSetCertifiedKey :: Ptr ClientConfigBuilder -> Ptr (Ptr CertifiedKey) -> CSize -> IO Result++-- TODO add callback-based cert validation?++-- Server+data {-# CTYPE "rustls.h" "rustls_server_config" #-} ServerConfig++data {-# CTYPE "rustls.h" "rustls_server_config_builder" #-} ServerConfigBuilder++foreign import capi unsafe "rustls.h rustls_server_config_builder_new_custom"+ serverConfigBuilderNewCustom ::+ Ptr (Ptr SupportedCipherSuite) ->+ CSize ->+ Ptr TLSVersion ->+ CSize ->+ Ptr (Ptr ServerConfigBuilder) ->+ IO Result++foreign import capi unsafe "rustls.h rustls_server_config_builder_free"+ serverConfigBuilderFree :: Ptr ServerConfigBuilder -> IO ()++foreign import capi unsafe "rustls.h rustls_server_config_builder_build"+ serverConfigBuilderBuild :: Ptr ServerConfigBuilder -> IO (Ptr ServerConfig)++foreign import capi unsafe "rustls.h &rustls_server_config_free"+ serverConfigFree :: FinalizerPtr ServerConfig++foreign import capi unsafe "rustls.h rustls_server_connection_new"+ serverConnectionNew :: Ptr ServerConfig -> Ptr (Ptr Connection) -> IO Result++foreign import capi unsafe "rustls.h rustls_server_config_builder_set_alpn_protocols"+ serverConfigBuilderSetALPNProtocols :: Ptr ServerConfigBuilder -> Ptr SliceBytes -> CSize -> IO Result++foreign import capi unsafe "rustls.h rustls_server_config_builder_set_ignore_client_order"+ serverConfigBuilderSetIgnoreClientOrder :: Ptr ServerConfigBuilder -> CBool -> IO Result++foreign import capi unsafe "rustls.h rustls_server_config_builder_set_certified_keys"+ serverConfigBuilderSetCertifiedKeys :: Ptr ServerConfigBuilder -> Ptr (Ptr CertifiedKey) -> CSize -> IO Result++data {-# CTYPE "rustls.h" "rustls_client_cert_verifier" #-} ClientCertVerifier++foreign import capi unsafe "rustls.h rustls_client_cert_verifier_new"+ clientCertVerifierNew :: Ptr RootCertStore -> IO (Ptr ClientCertVerifier)++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 -> Ptr ClientCertVerifier -> IO ()++data {-# CTYPE "rustls.h" "rustls_client_cert_verifier_optional" #-} ClientCertVerifierOptional++foreign import capi unsafe "rustls.h rustls_client_cert_verifier_optional_new"+ clientCertVerifierOptionalNew :: Ptr RootCertStore -> IO (Ptr ClientCertVerifierOptional)++foreign import capi unsafe "rustls.h rustls_client_cert_verifier_optional_free"+ clientCertVerifierOptionalFree :: Ptr ClientCertVerifierOptional -> IO ()++foreign import capi unsafe "rustls.h rustls_server_config_builder_set_client_verifier_optional"+ serverConfigBuilderSetClientVerifierOptional :: Ptr ServerConfigBuilder -> Ptr ClientCertVerifierOptional -> IO ()++-- add custom session persistence functions?++-- connection++data {-# CTYPE "rustls.h" "rustls_connection" #-} Connection++foreign import capi unsafe "rustls.h rustls_connection_free"+ connectionFree :: Ptr Connection -> IO ()++type LogCallback = Ptr Userdata -> Ptr LogParams -> IO ()++foreign import ccall "wrapper"+ mkLogCallback :: LogCallback -> IO (FunPtr LogCallback)++newtype LogLevel = LogLevel CSize+ deriving stock (Eq)+ deriving newtype (Storable)++data LogParams = LogParams+ { rustlsLogParamsLevel :: LogLevel,+ rustlsLogParamsMessage :: Str+ }+ deriving stock (Generic)+ deriving anyclass (GStorable)++foreign import capi unsafe "rustls.h rustls_connection_set_log_callback"+ connectionSetLogCallback :: Ptr Connection -> FunPtr LogCallback -> IO ()++foreign import capi unsafe "rustls.h rustls_connection_is_handshaking"+ connectionIsHandshaking :: Ptr Connection -> IO CBool++foreign import capi unsafe "rustls.h rustls_connection_get_alpn_protocol"+ connectionGetALPNProtocol :: Ptr Connection -> Ptr (Ptr Word8) -> Ptr CSize -> IO ()++foreign import capi unsafe "rustls.h rustls_connection_get_protocol_version"+ connectionGetProtocolVersion :: Ptr Connection -> IO TLSVersion++foreign import capi unsafe "rustls.h rustls_connection_get_negotiated_ciphersuite"+ connectionGetNegotiatedCipherSuite :: Ptr Connection -> IO (Ptr SupportedCipherSuite)++foreign import capi unsafe "rustls.h rustls_server_connection_get_sni_hostname"+ serverConnectionGetSNIHostname :: Ptr Connection -> Ptr Word8 -> CSize -> Ptr CSize -> IO Result++foreign import capi unsafe "rustls.h rustls_connection_get_peer_certificate"+ connectionGetPeerCertificate :: Ptr Connection -> CSize -> IO (Ptr Certificate)++-- connection read/write++type ReadWriteCallback = Ptr Userdata -> Ptr Word8 -> CSize -> Ptr CSize -> IO IOResult++foreign import ccall "wrapper"+ mkReadWriteCallback :: ReadWriteCallback -> IO (FunPtr ReadWriteCallback)++-- connection read++foreign import capi "rustls.h rustls_connection_read_tls"+ connectionReadTls ::+ Ptr Connection -> FunPtr ReadWriteCallback -> Ptr Userdata -> Ptr CSize -> IO IOResult++foreign import capi "rustls.h rustls_connection_read"+ connectionRead :: Ptr Connection -> Ptr Word8 -> CSize -> Ptr CSize -> IO Result++foreign import capi unsafe "rustls.h rustls_connection_wants_read"+ connectionWantsRead :: Ptr Connection -> IO CBool++-- connection write++foreign import capi "rustls.h rustls_connection_write_tls"+ connectionWriteTls ::+ Ptr Connection -> FunPtr ReadWriteCallback -> Ptr Userdata -> Ptr CSize -> IO IOResult++foreign import capi "rustls.h rustls_connection_write"+ connectionWrite :: Ptr Connection -> Ptr Word8 -> CSize -> Ptr CSize -> IO Result++foreign import capi unsafe "rustls.h rustls_connection_wants_write"+ connectionWantsWrite :: Ptr Connection -> IO CBool++-- misc++foreign import capi "rustls.h rustls_connection_process_new_packets"+ connectionProcessNewPackets :: Ptr Connection -> IO Result++foreign import capi "rustls.h rustls_connection_send_close_notify"+ connectionSendCloseNotify :: Ptr Connection -> IO ()++-- TODO high level bindings?+foreign import capi unsafe "rustls.h rustls_connection_set_buffer_limit"+ connectionSetBufferLimit :: Ptr Connection -> CSize -> IO ()++data {-# CTYPE "rustls.h" "rustls_certified_key" #-} CertifiedKey++foreign import capi unsafe "rustls.h rustls_certified_key_build"+ certifiedKeyBuild :: Ptr Word8 -> CSize -> Ptr Word8 -> CSize -> Ptr (Ptr CertifiedKey) -> IO Result++foreign import capi unsafe "rustls.h rustls_certified_key_free"+ certifiedKeyFree :: Ptr CertifiedKey -> IO ()++data {-# CTYPE "rustls.h" "rustls_certificate" #-} Certificate++foreign import capi unsafe "rustls.h rustls_certificate_get_der"+ certificateGetDER :: Ptr Certificate -> Ptr (Ptr Word8) -> Ptr CSize -> IO Result++-- TLS params++data {-# CTYPE "rustls.h" "rustls_supported_ciphersuite" #-} SupportedCipherSuite++foreign import capi "rustls.h value RUSTLS_ALL_CIPHER_SUITES"+ allCipherSuites :: Ptr (Ptr SupportedCipherSuite)++foreign import capi "rustls.h value RUSTLS_ALL_CIPHER_SUITES_LEN"+ allCipherSuitesLen :: CSize++foreign import capi "rustls.h value RUSTLS_DEFAULT_CIPHER_SUITES"+ defaultCipherSuites :: Ptr (Ptr SupportedCipherSuite)++foreign import capi "rustls.h value RUSTLS_DEFAULT_CIPHER_SUITES_LEN"+ defaultCipherSuitesLen :: CSize++foreign import capi unsafe "rustls.h rustls_supported_ciphersuite_get_suite"+ supportedCipherSuiteGetSuite :: Ptr SupportedCipherSuite -> Word16++foreign import capi unsafe "hs_rustls.h hs_rustls_supported_ciphersuite_get_name"+ hsSupportedCipherSuiteGetName :: Ptr SupportedCipherSuite -> Ptr Str -> IO ()++-- | A TLS protocol version supported by Rustls.+newtype {-# CTYPE "stdint.h" "uint16_t" #-} TLSVersion = TLSVersion+ { unTLSVersion :: Word16+ }+ deriving stock (Show, Eq, Ord)+ deriving newtype (Storable)++pattern TLS12, TLS13 :: TLSVersion+pattern TLS12 = TLSVersion 0x0303+pattern TLS13 = TLSVersion 0x0304++foreign import capi "rustls.h value RUSTLS_ALL_VERSIONS"+ allVersions :: Ptr TLSVersion++foreign import capi "rustls.h value RUSTLS_ALL_VERSIONS_LEN"+ allVersionsLen :: CSize++foreign import capi "rustls.h value RUSTLS_DEFAULT_VERSIONS"+ defaultVersions :: Ptr TLSVersion++foreign import capi "rustls.h value RUSTLS_DEFAULT_VERSIONS_LEN"+ defaultVersionsLen :: CSize
+ test/Main.hs view
@@ -0,0 +1,312 @@+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.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.Foldable (for_)+import Data.Functor (void)+import Data.IORef+import qualified Data.List.NonEmpty as NE+import Data.Maybe (fromMaybe, isJust)+import qualified Data.Set as S+import Data.Text (Text)+import qualified Data.Text 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 System.FilePath ((</>))+import qualified System.IO.Temp as Temp+import qualified System.Process as Process+import Test.Tasty+import Test.Tasty.HUnit hiding (assert)+import Test.Tasty.Hedgehog++data TestSetup = TestSetup+ { clientConfigBuilder :: Rustls.ClientConfigBuilder,+ serverConfigBuilder :: Rustls.ServerConfigBuilder,+ clientSends :: [ByteString]+ }+ deriving stock (Show)++data MiniCA = MiniCA+ { miniCAFile :: FilePath,+ miniCACert :: ByteString,+ miniCAClientCertKey, miniCAServerCertKey :: Rustls.CertifiedKey+ }++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]+ ]+ clientConfigALPNProtocols <- (commonALPNProtocols <>) <$> genALPNProtocols+ clientConfigEnableSNI <- Gen.bool_+ clientConfigTLSVersions <- genTLSVersions+ clientConfigCertifiedKeys <- Gen.subsequence [miniCAClientCertKey]+ let clientConfigCipherSuites = getCipherSuites clientConfigTLSVersions+ clientConfigBuilder = Rustls.ClientConfigBuilder {..}+ serverConfigALPNProtocols <- (commonALPNProtocols <>) <$> genALPNProtocols+ serverConfigIgnoreClientOrder <- Gen.bool_+ serverConfigTLSVersions <- genTLSVersions+ serverConfigClientCertVerifier <-+ Gen.element+ [ Nothing,+ Just $ Rustls.ClientCertVerifier [Rustls.PEMCertificatesStrict miniCACert],+ Just $ Rustls.ClientCertVerifierOptional [Rustls.PEMCertificatesStrict miniCACert]+ ]+ let serverConfigCipherSuites = getCipherSuites serverConfigTLSVersions+ serverConfigCertifiedKeys = pure miniCAServerCertKey+ serverConfigBuilder = Rustls.ServerConfigBuilder {..}+ clientSends <-+ Gen.list (Range.linear 0 10) $+ Gen.filterT (/= "close") $+ Gen.bytes (Range.linear 1 50)+ pure TestSetup {..}+ where+ genALPNProtocols =+ Gen.list (Range.constant 0 10) $+ Rustls.ALPNProtocol <$> Gen.bytes (Range.constant 1 10)+ genTLSVersions =+ Gen.shuffle =<< Gen.subsequence (NE.toList Rustls.allTLSVersions)+ getCipherSuites tlsVersions =+ filter ((`elem` tlsVersions) . tlsVersionFromCipherSuite) $+ NE.toList Rustls.allCipherSuites++data TestOutcome = TestOutcome+ { negotiatedClientALPNProtocol, negotiatedServerALPNProtocol :: Maybe Rustls.ALPNProtocol,+ clientTLSVersion, serverTLSVersion :: Rustls.TLSVersion,+ clientCipherSuite, serverCipherSuite :: Rustls.CipherSuite,+ sniHostname :: Maybe Text,+ clientPeerCert, serverPeerCert :: Maybe Rustls.DERCertificate,+ clientReceived, serverReceived :: [ByteString]+ }++main :: IO ()+main =+ defaultMain . testGroup "Basic Rustls tests" $+ [ testCase "Test version" $ Rustls.version @?= "rustls-ffi/0.9.1/rustls/0.20.4",+ testCase "TLS versions" do+ S.fromList [Rustls.TLS12, Rustls.TLS13]+ @?= S.fromList (NE.toList Rustls.defaultTLSVersions)+ assertBool "Unexpected default TLS versions" $+ S.fromList (NE.toList Rustls.defaultTLSVersions)+ `S.isSubsetOf` S.fromList (NE.toList Rustls.allTLSVersions),+ testCase "Cipher suites" do+ let defaultCipherSuites = S.fromList (NE.toList Rustls.defaultCipherSuites)+ allCipherSuites = S.fromList (NE.toList Rustls.allCipherSuites)+ assertBool "Unexpected default cipher suites" $+ defaultCipherSuites `S.isSubsetOf` allCipherSuites+ assertBool "Misbehaving ID function for cipher suites" $+ S.map Rustls.cipherSuiteID defaultCipherSuites+ `S.isSubsetOf` S.map Rustls.cipherSuiteID allCipherSuites+ assertBool "Misbehaving display function for cipher suites" $+ S.map Rustls.showCipherSuite defaultCipherSuites+ `S.isSubsetOf` S.map Rustls.showCipherSuite allCipherSuites,+ testInMemory+ ]+ where+ testHostname = "example.org"+ testMessageLen = 1000+ testInMemory = withMiniCA \(fmap snd -> getMiniCA) ->+ testPropertyNamed "Test in-memory TLS" "Test in-memory TLS" $ property do+ TestSetup {..} <- forAll . genTestSetup =<< liftIO getMiniCA++ logRef <- liftIO $ newIORef []++ let runServer backend = withAcquire+ do+ lc <- mkTestLogCallback logRef "SERVER"+ rustlsConfig <-+ liftIO . fmap (\cfg -> cfg {Rustls.serverConfigLogCallback = Just lc}) $+ Rustls.buildServerConfig serverConfigBuilder+ Rustls.newServerConnection backend rustlsConfig+ \conn -> do+ (alpnProtocol, tlsVersion, cipherSuite, sniHostname, peerCert) <-+ Rustls.handshake conn $+ (,,,,)+ <$> Rustls.getALPNProtocol+ <*> Rustls.getTLSVersion+ <*> Rustls.getCipherSuite+ <*> Rustls.getSNIHostname+ <*> Rustls.getPeerCertificate 0+ received <-+ let go = do+ bs <- Rustls.readBS conn testMessageLen+ when (bs /= "close") do+ modify' (bs :)+ Rustls.writeBS conn bs+ go+ in recordOutput go+ pure (alpnProtocol, tlsVersion, cipherSuite, sniHostname, peerCert, received)++ runClient backend = withAcquire+ do+ lc <- mkTestLogCallback logRef "CLIENT"+ rustlsConfig <-+ liftIO . fmap (\cfg -> cfg {Rustls.clientConfigLogCallback = Just lc}) $+ Rustls.buildClientConfig clientConfigBuilder+ Rustls.newClientConnection backend rustlsConfig testHostname+ \conn -> do+ (alpnProtocol, tlsVersion, cipherSuite, peerCert) <-+ Rustls.handshake conn $+ (,,,)+ <$> Rustls.getALPNProtocol+ <*> Rustls.getTLSVersion+ <*> Rustls.getCipherSuite+ <*> Rustls.getPeerCertificate 0+ received <- recordOutput . for_ clientSends $ \bs -> do+ Rustls.writeBS conn bs+ bs <- Rustls.readBS conn testMessageLen+ modify' (bs :)+ Rustls.writeBS conn "close"+ pure (alpnProtocol, tlsVersion, cipherSuite, peerCert, received)++ (backend0, backend1) <- mkConnectedBSBackends++ res <- liftIO . runExceptT $ do+ ( ( negotiatedServerALPNProtocol,+ serverTLSVersion,+ serverCipherSuite,+ sniHostname,+ serverPeerCert,+ serverReceived+ ),+ ( negotiatedClientALPNProtocol,+ clientTLSVersion,+ clientCipherSuite,+ clientPeerCert,+ clientReceived+ )+ ) <-+ ExceptT . E.try $ concurrently (runServer backend0) (runClient backend1)+ pure TestOutcome {..}++ do+ logLines <- liftIO $ T.unlines . reverse <$> readIORef logRef+ footnote $ "TLS log:\n" <> T.unpack logLines++ let Rustls.ClientConfigBuilder {..} = clientConfigBuilder+ Rustls.ServerConfigBuilder {..} = serverConfigBuilder+ clientTLSVersions =+ nonEmptySet Rustls.defaultTLSVersions clientConfigTLSVersions+ serverTLSVersions =+ nonEmptySet Rustls.defaultTLSVersions serverConfigTLSVersions+ clientCipherSuites =+ nonEmptySet Rustls.defaultCipherSuites clientConfigCipherSuites+ serverCipherSuites =+ nonEmptySet Rustls.defaultCipherSuites serverConfigCipherSuites+ case res of+ Right TestOutcome {..} -> do+ label "Success"+ clientSends === serverReceived+ clientSends === clientReceived+ if clientConfigEnableSNI+ then sniHostname === Just testHostname+ else sniHostname === Nothing+ assert $+ S.fromList [clientTLSVersion, serverTLSVersion]+ `S.isSubsetOf` S.fromList [Rustls.TLS12, Rustls.TLS13]+ negotiatedClientALPNProtocol === negotiatedServerALPNProtocol+ assert $+ maybe S.empty S.singleton negotiatedClientALPNProtocol+ `S.isSubsetOf` ( S.fromList clientConfigALPNProtocols+ `S.intersection` S.fromList serverConfigALPNProtocols+ )+ clientCipherSuite === serverCipherSuite+ assert $+ clientCipherSuite+ `S.member` (clientCipherSuites `S.intersection` serverCipherSuites)+ assert $ isJust clientPeerCert+ case serverConfigClientCertVerifier of+ Nothing ->+ serverPeerCert === Nothing+ Just (Rustls.ClientCertVerifier _) ->+ assert $ isJust serverPeerCert+ Just (Rustls.ClientCertVerifierOptional _) ->+ 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+ where+ recordOutput = fmap reverse . flip execStateT []++ nonEmptySet def = S.fromList . NE.toList . fromMaybe def . NE.nonEmpty++ withMiniCA = withResource+ do+ tmpDir <-+ flip Temp.createTempDirectory "hs-rustls-minica"+ =<< Temp.getCanonicalTemporaryDirectory+ let runMiniCA domain =+ void $ Process.readCreateProcess (cp {Process.cwd = Just tmpDir}) ""+ where+ cp = Process.proc "minica" ["-domains", domain]+ for_ ["example.org", "client.example.org"] runMiniCA+ let miniCAFile = tmpDir </> "minica.pem"+ miniCACert <- B.readFile miniCAFile+ let miniCACertKey domain = do+ privateKey <- B.readFile $ tmpDir </> domain </> "key.pem"+ certificateChain <- B.readFile $ tmpDir </> domain </> "cert.pem"+ pure Rustls.CertifiedKey {..}+ miniCAClientCertKey <- miniCACertKey "client.example.org"+ miniCAServerCertKey <- miniCACertKey "example.org"+ pure (tmpDir, MiniCA {..})+ do \(tmpDir, _) -> Dir.removeDirectoryRecursive tmpDir++mkConnectedBSBackends :: MonadIO m => m (Rustls.ByteStringBackend, Rustls.ByteStringBackend)+mkConnectedBSBackends = liftIO do+ (buf0, buf1) <- join (liftA2 (,)) newEmptyTMVarIO+ pure (mkBSBackend buf0 buf1, mkBSBackend buf1 buf0)+ where+ mkBSBackend readBuf writeBuf = Rustls.ByteStringBackend {..}+ where+ bsbRead len = atomically do+ (bs, bs') <- B.splitAt len <$> takeTMVar readBuf+ unless (B.null bs') $ putTMVar readBuf bs'+ pure bs+ bsbWrite bs =+ atomically $ putTMVar writeBuf bs++mkTestLogCallback :: IORef [Text] -> Text -> Acquire Rustls.LogCallback+mkTestLogCallback ref id = Rustls.newLogCallback \lvl msg -> do+ let lvlTxt = case lvl of+ Rustls.LogLevelError -> "ERROR"+ Rustls.LogLevelWarn -> "WARN"+ Rustls.LogLevelInfo -> "INFO"+ Rustls.LogLevelDebug -> "DEBUG"+ Rustls.LogLevelTrace -> "TRACE"+ line = "[" <> id <> "] [" <> lvlTxt <> "] " <> msg+ atomicModifyIORef' ref ((,()) . (line :))++tlsVersionFromCipherSuite :: Rustls.CipherSuite -> Rustls.TLSVersion+tlsVersionFromCipherSuite cipherSuite+ | "TLS_" `T.isPrefixOf` str = Rustls.TLS12+ | "TLS13_" `T.isPrefixOf` str = Rustls.TLS13+ | otherwise = error "unexpected cipher suite"+ where+ str = Rustls.showCipherSuite cipherSuite