rustls 0.0.0.0 → 0.0.1.0
raw patch · 7 files changed
+382/−305 lines, 7 filesdep ~tasty-hedgehogdep ~text
Dependency ranges changed: tasty-hedgehog, text
Files
- CHANGELOG.md +10/−0
- README.md +1/−1
- rustls.cabal +6/−6
- src/Rustls.hs +84/−61
- src/Rustls/Internal.hs +18/−10
- src/Rustls/Internal/FFI.hs +76/−51
- test/Main.hs +187/−176
CHANGELOG.md view
@@ -1,1 +1,11 @@ # Revision history for rustls++## 0.0.1.0 -- 12.03.2022++ * Use rustls-ffi 0.9.2+ * Use `ConstPtr` on GHC 9.6.1+ * Report `LogCallback` exceptions via uncaught exception handler++## 0.0.0.0 -- 24.06.2022++ * Initial release
README.md view
@@ -25,7 +25,7 @@ Make sure to have [Cargo](https://doc.rust-lang.org/stable/cargo/getting-started/installation.html) installed. Then, clone and install rustls-ffi: ```bash-git clone https://github.com/rustls/rustls-ffi+git clone https://github.com/rustls/rustls-ffi -b v0.9.2 cd rustls-ffi make DESTDIR=/path/to/some/dir install ```
rustls.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: rustls-version: 0.0.0.0+version: 0.0.1.0 synopsis: TLS bindings for Rustls description:@@ -27,7 +27,7 @@ flag derive-storable-plugin description: Use derive-storable-plugin default: True- manual: True+ manual: False common commons default-language: Haskell2010@@ -47,10 +47,10 @@ build-depends: base >= 4.12 && < 5 , bytestring >= 0.10 && < 0.12- , text ^>= 1.2 || ^>= 2.0+ , text ^>= 2.0.1 , derive-storable ^>= 0.3 , transformers >= 0.5.6 && < 0.7- , resourcet ^>= 1.2+ , resourcet ^>= 1.2 || ^>= 1.3 , network ^>= 3.1 if flag(derive-storable-plugin) build-depends: derive-storable-plugin@@ -69,8 +69,8 @@ , rustls , tasty >= 1.3 && < 1.5 , tasty-hunit ^>= 0.10- , tasty-hedgehog >= 1.0 && < 1.3- , hedgehog >= 1.0 && < 1.2+ , tasty-hedgehog >= 1.0 && < 1.5+ , hedgehog >= 1.0 && < 1.3 , text , bytestring , containers ^>= 0.6
src/Rustls.hs view
@@ -137,6 +137,7 @@ -- ** Exceptions RustlsException, isCertError,+ RustlsLogException (..), ) where @@ -161,11 +162,11 @@ import qualified Data.Text.Foreign as T import Foreign import Foreign.C+import GHC.Conc (reportError) import GHC.Generics (Generic) import Rustls.Internal-import Rustls.Internal.FFI (TLSVersion (..))+import Rustls.Internal.FFI (ConstPtr (..), TLSVersion (..)) import qualified Rustls.Internal.FFI as FFI-import System.IO (hPutStrLn, stderr) import System.IO.Unsafe (unsafePerformIO) -- $setup@@ -175,15 +176,15 @@ -- | Combined version string of Rustls and rustls-ffi. -- -- >>> version--- "rustls-ffi/0.9.1/rustls/0.20.4"+-- "rustls-ffi/0.9.2/rustls/0.20.8" 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 =+peekNonEmpty :: (Storable a, Coercible a b) => ConstPtr a -> CSize -> NonEmpty b+peekNonEmpty (ConstPtr as) len = NE.fromList . coerce . unsafePerformIO $ peekArray (cSizeToInt len) as -- | All 'TLSVersion's supported by Rustls.@@ -191,7 +192,7 @@ allTLSVersions = peekNonEmpty FFI.allVersions FFI.allVersionsLen {-# NOINLINE allTLSVersions #-} --- | The default 'TLSVersion's used by Rustls. A subset of 'defaultTLSVersions'.+-- | The default 'TLSVersion's used by Rustls. A subset of 'allTLSVersions'. defaultTLSVersions :: NonEmpty TLSVersion defaultTLSVersions = peekNonEmpty FFI.defaultVersions FFI.defaultVersionsLen {-# NOINLINE defaultTLSVersions #-}@@ -218,31 +219,37 @@ clientConfigCertifiedKeys = [] } -withCertifiedKeys :: [CertifiedKey] -> ((Ptr (Ptr FFI.CertifiedKey), CSize) -> IO a) -> IO a+withCertifiedKeys :: [CertifiedKey] -> ((ConstPtr (ConstPtr FFI.CertifiedKey), CSize) -> IO a) -> IO a withCertifiedKeys certifiedKeys cb = withMany withCertifiedKey certifiedKeys \certKeys ->- withArrayLen certKeys \len ptr -> cb (ptr, intToCSize len)+ withArrayLen certKeys \len ptr -> cb (ConstPtr ptr, intToCSize len) where withCertifiedKey CertifiedKey {..} cb =- BU.unsafeUseAsCStringLen certificateChain \(castPtr -> certPtr, intToCSize -> certLen) ->- BU.unsafeUseAsCStringLen privateKey \(castPtr -> privPtr, intToCSize -> privLen) ->+ BU.unsafeUseAsCStringLen certificateChain \(certPtr, certLen) ->+ BU.unsafeUseAsCStringLen privateKey \(privPtr, privLen) -> alloca \certKeyPtr -> do- rethrowR =<< FFI.certifiedKeyBuild certPtr certLen privPtr privLen certKeyPtr+ rethrowR+ =<< FFI.certifiedKeyBuild+ (ConstPtr $ castPtr certPtr)+ (intToCSize certLen)+ (ConstPtr $ castPtr privPtr)+ (intToCSize privLen)+ certKeyPtr cb =<< peek certKeyPtr -withALPNProtocols :: [ALPNProtocol] -> ((Ptr FFI.SliceBytes, CSize) -> IO a) -> IO a+withALPNProtocols :: [ALPNProtocol] -> ((ConstPtr FFI.SliceBytes, CSize) -> IO a) -> IO a withALPNProtocols bss cb = do withMany withSliceBytes (coerce bss) \bsPtrs ->- withArrayLen bsPtrs \len bsPtr -> cb (bsPtr, intToCSize len)+ 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 configBuilderNew ::- ( Ptr (Ptr FFI.SupportedCipherSuite) ->+ ( ConstPtr (ConstPtr FFI.SupportedCipherSuite) -> CSize ->- Ptr TLSVersion ->+ ConstPtr TLSVersion -> CSize -> Ptr (Ptr configBuilder) -> IO FFI.Result@@ -256,12 +263,12 @@ if null cipherSuites then pure (FFI.defaultCipherSuitesLen, FFI.defaultCipherSuites) else ContT \cb -> withArrayLen (coerce cipherSuites) \len ptr ->- cb (intToCSize len, ptr)+ cb (intToCSize len, ConstPtr ptr) (tlsVersionsLen, tlsVersionsPtr) <- if null tlsVersions then pure (FFI.defaultVersionsLen, FFI.defaultVersions) else ContT \cb -> withArrayLen tlsVersions \len ptr ->- cb (intToCSize len, ptr)+ cb (intToCSize len, ConstPtr ptr) liftIO do rethrowR =<< configBuilderNewCustom@@ -272,21 +279,27 @@ builderPtr peek builderPtr -withRootCertStore :: [PEMCertificates] -> (Ptr FFI.RootCertStore -> IO a) -> IO a+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 (castPtr buf) (intToCSize len) strict+ 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 store+ action $ ConstPtr 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 :: (MonadIO m) => ClientConfigBuilder -> m ClientConfig buildClientConfig ClientConfigBuilder {..} = liftIO . E.mask_ $ E.bracketOnError ( configBuilderNew@@ -299,7 +312,7 @@ case clientConfigRoots of ClientRootsFromFile rootsPath -> withCString rootsPath $- rethrowR <=< FFI.clientConfigBuilderLoadRootsFromFile builder+ rethrowR <=< FFI.clientConfigBuilderLoadRootsFromFile builder . ConstPtr ClientRootsInMemory certs -> withRootCertStore certs $ rethrowR <=< FFI.clientConfigBuilderUseRoots builder withALPNProtocols clientConfigALPNProtocols \(alpnPtr, len) ->@@ -309,14 +322,15 @@ rethrowR =<< FFI.clientConfigBuilderSetCertifiedKey builder ptr len let clientConfigLogCallback = Nothing clientConfigPtr <-- newForeignPtr FFI.clientConfigFree =<< FFI.clientConfigBuilderBuild builder+ 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 :: (MonadIO m) => ServerConfigBuilder -> m ServerConfig buildServerConfig ServerConfigBuilder {..} = liftIO . E.mask_ $ E.bracketOnError ( configBuilderNew@@ -351,7 +365,8 @@ FFI.clientCertVerifierOptionalFree FFI.serverConfigBuilderSetClientVerifierOptional serverConfigPtr <-- newForeignPtr FFI.serverConfigFree =<< FFI.serverConfigBuilderBuild builder+ newForeignPtr FFI.serverConfigFree . unConstPtr+ =<< FFI.serverConfigBuilderBuild builder let serverConfigLogCallback = Nothing pure ServerConfig {..} @@ -369,11 +384,14 @@ -- | Allocate a new logging callback, taking a 'LogLevel' and a message. --+-- If it throws an exception, it will be wrapped in a 'RustlsLogException' and+-- passed to 'reportError'.+-- -- 🚫 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.mkLogCallback \_ (ConstPtr logParamsPtr) -> ignoreExceptions do FFI.LogParams {..} <- peek logParamsPtr let logLevel = case rustlsLogParamsLevel of FFI.LogLevel 1 -> Right LogLevelError@@ -381,20 +399,21 @@ FFI.LogLevel 3 -> Right LogLevelInfo FFI.LogLevel 4 -> Right LogLevelDebug FFI.LogLevel 5 -> Right LogLevelTrace- FFI.LogLevel l -> Left l+ l -> Left l case logLevel of- Left l -> hPutStrLn stderr $ "invalid Rustls log level: " <> show l+ Left l -> report $ E.SomeException $ RustlsUnknownLogLevel l Right logLevel -> do msg <- strToText rustlsLogParamsMessage- cb logLevel msg `E.catch` \(e :: E.SomeException) ->- hPutStrLn stderr $ "Rustls log callback errored: " <> E.displayException e+ cb logLevel msg `E.catch` report+ where+ report = reportError . E.SomeException . RustlsLogException newConnection ::- Backend b =>+ (Backend b) => b -> ForeignPtr config -> Maybe LogCallback ->- (Ptr config -> Ptr (Ptr FFI.Connection) -> IO FFI.Result) ->+ (ConstPtr config -> Ptr (Ptr FFI.Connection) -> IO FFI.Result) -> Acquire (Connection side) newConnection backend configPtr logCallback connectionNew = mkAcquire acquire release@@ -403,22 +422,26 @@ conn <- alloca \connPtrPtr -> withForeignPtr configPtr \cfgPtr -> liftIO do- rethrowR =<< connectionNew cfgPtr connPtrPtr+ rethrowR =<< connectionNew (ConstPtr 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+ let readWriteCallback toBuf _ud buf len iPtr = do+ putMVar ioMsgRes $ UsingBuffer (toBuf buf) len iPtr+ Done ioResult <- takeMVar ioMsgReq+ pure ioResult+ readCallback <- FFI.mkReadCallback $ readWriteCallback id+ writeCallback <- FFI.mkWriteCallback $ readWriteCallback unConstPtr+ let freeCallback = do+ freeHaskellFunPtr readCallback+ freeHaskellFunPtr writeCallback interact = forever do Request readOrWrite <- takeMVar ioMsgReq let readOrWriteTls = case readOrWrite of- Read -> FFI.connectionReadTls- Write -> FFI.connectionWriteTls- _ <- readOrWriteTls conn readWriteCallback nullPtr lenPtr+ Read -> flip FFI.connectionReadTls readCallback+ Write -> flip FFI.connectionWriteTls writeCallback+ _ <- readOrWriteTls conn nullPtr lenPtr putMVar ioMsgRes DoneFFI interactThread <- forkFinally interact (const freeCallback) for_ logCallback $ FFI.connectionSetLogCallback conn . unLogCallback@@ -431,7 +454,7 @@ -- | Initialize a TLS connection as a client. newClientConnection ::- Backend b =>+ (Backend b) => b -> ClientConfig -> -- | Hostname.@@ -439,12 +462,12 @@ Acquire (Connection Client) newClientConnection b ClientConfig {..} hostname = newConnection b clientConfigPtr clientConfigLogCallback \configPtr connPtrPtr ->- withCString (T.unpack hostname) \hostnamePtr ->- FFI.clientConnectionNew configPtr hostnamePtr connPtrPtr+ T.withCString hostname \hostnamePtr ->+ FFI.clientConnectionNew configPtr (ConstPtr hostnamePtr) connPtrPtr -- | Initialize a TLS connection as a server. newServerConnection ::- Backend b =>+ (Backend b) => b -> ServerConfig -> Acquire (Connection Server)@@ -463,7 +486,7 @@ -- getALPNAndTLSVersion conn = -- handshake conn $ (,) <$> getALPNProtocol <*> getTLSVersion -- :}-handshake :: MonadIO m => Connection side -> HandshakeQuery side a -> m a+handshake :: (MonadIO m) => Connection side -> HandshakeQuery side a -> m a handshake conn (HandshakeQuery query) = liftIO do withConnection conn \c -> do runTLS c TLSHandshake@@ -473,8 +496,8 @@ getALPNProtocol :: HandshakeQuery side (Maybe ALPNProtocol) getALPNProtocol = handshakeQuery \Connection' {conn, lenPtr} -> alloca \bufPtrPtr -> do- FFI.connectionGetALPNProtocol conn bufPtrPtr lenPtr- bufPtr <- peek bufPtrPtr+ FFI.connectionGetALPNProtocol (ConstPtr conn) bufPtrPtr lenPtr+ ConstPtr bufPtr <- peek bufPtrPtr len <- peek lenPtr !alpn <- B.packCStringLen (castPtr bufPtr, cSizeToInt len) pure $ if B.null alpn then Nothing else Just $ ALPNProtocol alpn@@ -482,7 +505,7 @@ -- | Get the negotiated TLS protocol version. getTLSVersion :: HandshakeQuery side TLSVersion getTLSVersion = handshakeQuery \Connection' {conn} -> do- !ver <- FFI.connectionGetProtocolVersion conn+ !ver <- FFI.connectionGetProtocolVersion (ConstPtr conn) when (unTLSVersion ver == 0) $ fail "internal rustls error: no protocol version negotiated" pure ver@@ -490,8 +513,8 @@ -- | Get the negotiated cipher suite. getCipherSuite :: HandshakeQuery side CipherSuite getCipherSuite = handshakeQuery \Connection' {conn} -> do- !cipherSuite <- FFI.connectionGetNegotiatedCipherSuite conn- when (cipherSuite == nullPtr) $+ !cipherSuite <- FFI.connectionGetNegotiatedCipherSuite (ConstPtr conn)+ when (cipherSuite == ConstPtr nullPtr) $ fail "internal rustls error: no cipher suite negotiated" pure $ CipherSuite cipherSuite @@ -499,7 +522,7 @@ 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+ res <- FFI.serverConnectionGetSNIHostname (ConstPtr conn) bufPtr n lenPtr if res == FFI.resultInsufficientSize then go (2 * n) else do@@ -520,26 +543,26 @@ -- 'Nothing'. getPeerCertificate :: CSize -> HandshakeQuery side (Maybe DERCertificate) getPeerCertificate i = handshakeQuery \Connection' {conn, lenPtr} -> do- certPtr <- FFI.connectionGetPeerCertificate conn i- if certPtr == nullPtr+ certPtr <- FFI.connectionGetPeerCertificate (ConstPtr conn) i+ if certPtr == ConstPtr nullPtr then pure Nothing else alloca \bufPtrPtr -> do rethrowR =<< FFI.certificateGetDER certPtr bufPtrPtr lenPtr- bufPtr <- peek bufPtrPtr+ ConstPtr 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 :: (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 :: (MonadIO m) => Connection side -> Ptr Word8 -> CSize -> m CSize readPtr conn buf len = liftIO $ withConnection conn \c@Connection' {..} -> do runTLS c TLSWrite@@ -550,7 +573,7 @@ -- | Read data from the Rustls 'Connection' into a 'ByteString'. The result will -- not be longer than the given length. readBS ::- MonadIO m =>+ (MonadIO m) => Connection side -> -- | Maximum result length. Note that a buffer of this size will be allocated. Int ->@@ -560,7 +583,7 @@ 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 :: (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@@ -568,7 +591,7 @@ peek lenPtr -- | Write a 'ByteString' to the Rustls 'Connection'.-writeBS :: MonadIO m => Connection side -> ByteString -> m ()+writeBS :: (MonadIO m) => Connection side -> ByteString -> m () writeBS conn bs = liftIO $ BU.unsafeUseAsCStringLen bs go where go (buf, len) = do
src/Rustls/Internal.hs view
@@ -22,6 +22,7 @@ import Foreign.C import GHC.Generics (Generic) import qualified Network.Socket as NS+import Rustls.Internal.FFI (ConstPtr (..)) import qualified Rustls.Internal.FFI as FFI import System.IO.Unsafe (unsafePerformIO) @@ -32,7 +33,7 @@ deriving stock (Show, Eq, Ord, Generic) -- | A TLS cipher suite supported by Rustls.-newtype CipherSuite = CipherSuite (Ptr FFI.SupportedCipherSuite)+newtype CipherSuite = CipherSuite (ConstPtr FFI.SupportedCipherSuite) -- | Get the IANA value from a cipher suite. The bytes are interpreted in network order. --@@ -114,8 +115,7 @@ -- | 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.+ -- | A logging callback. -- -- Note that this is a record selector, so you can use it as a setter: --@@ -158,8 +158,7 @@ -- | 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.+ -- | A logging callback. -- -- Note that this is a record selector, so you can use it as a setter: --@@ -226,6 +225,15 @@ FFI.Result rustlsErrorCode -> E.throwIO $ RustlsException rustlsErrorCode +-- | Wrapper for exceptions thrown in a 'LogCallback'.+newtype RustlsLogException = RustlsLogException E.SomeException+ deriving stock (Show)+ deriving anyclass (E.Exception)++data RustlsUnknownLogLevel = RustlsUnknownLogLevel FFI.LogLevel+ 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.@@ -284,7 +292,7 @@ type role Connection nominal data Connection' = forall b.- Backend b =>+ (Backend b) => Connection' { conn :: Ptr FFI.Connection, backend :: b,@@ -330,7 +338,7 @@ UsingBuffer buf len readPtr <- takeMVar ioMsgRes poke readPtr =<< restore (readOrWriteBackend buf len)- `E.onException` done FFI.ioResultErr+ `E.onException` done FFI.ioResultErr done FFI.ioResultOk where readOrWriteBackend = case readOrWrite of@@ -347,7 +355,7 @@ runTLS :: Connection' -> RunTLSMode -> IO () runTLS c@Connection' {..} = \case TLSHandshake -> loopWhileTrue do- toBool @CBool <$> FFI.connectionIsHandshaking conn >>= \case+ toBool @CBool <$> FFI.connectionIsHandshaking (ConstPtr conn) >>= \case True -> (||) <$> runWrite <*> runRead False -> pure False TLSRead -> do@@ -358,7 +366,7 @@ loopWhileTrue runWrite where runRead = do- wantsRead <- toBool @CBool <$> FFI.connectionWantsRead conn+ wantsRead <- toBool @CBool <$> FFI.connectionWantsRead (ConstPtr conn) when wantsRead do interactTLS c Read r <- FFI.connectionProcessNewPackets conn@@ -368,7 +376,7 @@ pure wantsRead runWrite = do- wantsWrite <- toBool @CBool <$> FFI.connectionWantsWrite conn+ wantsWrite <- toBool @CBool <$> FFI.connectionWantsWrite (ConstPtr conn) when wantsWrite $ interactTLS c Write pure wantsWrite
src/Rustls/Internal/FFI.hs view
@@ -4,8 +4,11 @@ -- | Internal module, not subject to PVP. module Rustls.Internal.FFI- ( -- * Client+ ( ConstPtr (..),+ ConstCString, + -- * Client+ -- ** Config ClientConfig, ClientConfigBuilder,@@ -56,15 +59,17 @@ connectionFree, -- ** Read/write- ReadWriteCallback,- mkReadWriteCallback, -- *** Read+ ReadCallback,+ mkReadCallback, connectionWantsRead, connectionRead, connectionReadTls, -- *** Write+ WriteCallback,+ mkWriteCallback, connectionWantsWrite, connectionWrite, connectionWriteTls,@@ -137,6 +142,15 @@ import Foreign.Storable.Generic import GHC.Generics (Generic) +#if MIN_VERSION_base(4,18,0)+import Foreign.C.ConstPtr+#else+newtype ConstPtr a = ConstPtr {unConstPtr :: Ptr a}+ deriving newtype (Show, Eq, Storable)+#endif++type ConstCString = ConstPtr CChar+ -- Misc data {-# CTYPE "rustls.h" "rustls_str" #-} Str = Str CString CSize@@ -185,9 +199,9 @@ foreign import capi unsafe "rustls.h rustls_client_config_builder_new_custom" clientConfigBuilderNewCustom ::- Ptr (Ptr SupportedCipherSuite) ->+ ConstPtr (ConstPtr SupportedCipherSuite) -> CSize ->- Ptr TLSVersion ->+ ConstPtr TLSVersion -> CSize -> Ptr (Ptr ClientConfigBuilder) -> IO Result@@ -196,21 +210,21 @@ clientConfigBuilderFree :: Ptr ClientConfigBuilder -> IO () foreign import capi unsafe "rustls.h rustls_client_config_builder_build"- clientConfigBuilderBuild :: Ptr ClientConfigBuilder -> IO (Ptr ClientConfig)+ clientConfigBuilderBuild :: Ptr ClientConfigBuilder -> IO (ConstPtr 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 ->+ ConstPtr ClientConfig -> -- | Hostname.- CString ->+ ConstCString -> 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+ clientConfigBuilderLoadRootsFromFile :: Ptr ClientConfigBuilder -> ConstCString -> IO Result data {-# CTYPE "rustls.h" "rustls_root_cert_store" #-} RootCertStore @@ -218,22 +232,24 @@ 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+ 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 -> Ptr RootCertStore -> IO Result+ clientConfigBuilderUseRoots :: Ptr ClientConfigBuilder -> ConstPtr RootCertStore -> IO Result foreign import capi unsafe "rustls.h rustls_client_config_builder_set_alpn_protocols"- clientConfigBuilderSetALPNProtocols :: Ptr ClientConfigBuilder -> Ptr SliceBytes -> CSize -> IO Result+ clientConfigBuilderSetALPNProtocols ::+ Ptr ClientConfigBuilder -> ConstPtr 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+ clientConfigBuilderSetCertifiedKey ::+ Ptr ClientConfigBuilder -> ConstPtr (ConstPtr CertifiedKey) -> CSize -> IO Result -- TODO add callback-based cert validation? @@ -244,9 +260,9 @@ foreign import capi unsafe "rustls.h rustls_server_config_builder_new_custom" serverConfigBuilderNewCustom ::- Ptr (Ptr SupportedCipherSuite) ->+ ConstPtr (ConstPtr SupportedCipherSuite) -> CSize ->- Ptr TLSVersion ->+ ConstPtr TLSVersion -> CSize -> Ptr (Ptr ServerConfigBuilder) -> IO Result@@ -255,44 +271,49 @@ serverConfigBuilderFree :: Ptr ServerConfigBuilder -> IO () foreign import capi unsafe "rustls.h rustls_server_config_builder_build"- serverConfigBuilderBuild :: Ptr ServerConfigBuilder -> IO (Ptr ServerConfig)+ serverConfigBuilderBuild :: Ptr ServerConfigBuilder -> IO (ConstPtr 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+ serverConnectionNew :: ConstPtr 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+ serverConfigBuilderSetALPNProtocols ::+ Ptr ServerConfigBuilder -> ConstPtr 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+ serverConfigBuilderSetCertifiedKeys ::+ Ptr ServerConfigBuilder -> ConstPtr (ConstPtr 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)+ clientCertVerifierNew :: ConstPtr RootCertStore -> IO (ConstPtr ClientCertVerifier) foreign import capi unsafe "rustls.h rustls_client_cert_verifier_free"- clientCertVerifierFree :: Ptr ClientCertVerifier -> IO ()+ clientCertVerifierFree :: ConstPtr ClientCertVerifier -> IO () foreign import capi unsafe "rustls.h rustls_server_config_builder_set_client_verifier"- serverConfigBuilderSetClientVerifier :: Ptr ServerConfigBuilder -> Ptr ClientCertVerifier -> IO ()+ serverConfigBuilderSetClientVerifier ::+ Ptr ServerConfigBuilder -> ConstPtr 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)+ clientCertVerifierOptionalNew ::+ ConstPtr RootCertStore -> IO (ConstPtr ClientCertVerifierOptional) foreign import capi unsafe "rustls.h rustls_client_cert_verifier_optional_free"- clientCertVerifierOptionalFree :: Ptr ClientCertVerifierOptional -> IO ()+ clientCertVerifierOptionalFree :: ConstPtr ClientCertVerifierOptional -> IO () foreign import capi unsafe "rustls.h rustls_server_config_builder_set_client_verifier_optional"- serverConfigBuilderSetClientVerifierOptional :: Ptr ServerConfigBuilder -> Ptr ClientCertVerifierOptional -> IO ()+ serverConfigBuilderSetClientVerifierOptional ::+ Ptr ServerConfigBuilder -> ConstPtr ClientCertVerifierOptional -> IO () -- add custom session persistence functions? @@ -303,13 +324,13 @@ foreign import capi unsafe "rustls.h rustls_connection_free" connectionFree :: Ptr Connection -> IO () -type LogCallback = Ptr Userdata -> Ptr LogParams -> IO ()+type LogCallback = Ptr Userdata -> ConstPtr LogParams -> IO () foreign import ccall "wrapper" mkLogCallback :: LogCallback -> IO (FunPtr LogCallback) newtype LogLevel = LogLevel CSize- deriving stock (Eq)+ deriving stock (Show, Eq) deriving newtype (Storable) data LogParams = LogParams@@ -323,53 +344,56 @@ connectionSetLogCallback :: Ptr Connection -> FunPtr LogCallback -> IO () foreign import capi unsafe "rustls.h rustls_connection_is_handshaking"- connectionIsHandshaking :: Ptr Connection -> IO CBool+ connectionIsHandshaking :: ConstPtr Connection -> IO CBool foreign import capi unsafe "rustls.h rustls_connection_get_alpn_protocol"- connectionGetALPNProtocol :: Ptr Connection -> Ptr (Ptr Word8) -> Ptr CSize -> IO ()+ connectionGetALPNProtocol :: ConstPtr Connection -> Ptr (ConstPtr Word8) -> Ptr CSize -> IO () foreign import capi unsafe "rustls.h rustls_connection_get_protocol_version"- connectionGetProtocolVersion :: Ptr Connection -> IO TLSVersion+ connectionGetProtocolVersion :: ConstPtr Connection -> IO TLSVersion foreign import capi unsafe "rustls.h rustls_connection_get_negotiated_ciphersuite"- connectionGetNegotiatedCipherSuite :: Ptr Connection -> IO (Ptr SupportedCipherSuite)+ connectionGetNegotiatedCipherSuite :: ConstPtr Connection -> IO (ConstPtr SupportedCipherSuite) foreign import capi unsafe "rustls.h rustls_server_connection_get_sni_hostname"- serverConnectionGetSNIHostname :: Ptr Connection -> Ptr Word8 -> CSize -> Ptr CSize -> IO Result+ serverConnectionGetSNIHostname :: ConstPtr 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)+ connectionGetPeerCertificate :: ConstPtr Connection -> CSize -> IO (ConstPtr Certificate) --- connection read/write+-- connection read -type ReadWriteCallback = Ptr Userdata -> Ptr Word8 -> CSize -> Ptr CSize -> IO IOResult+type ReadCallback = Ptr Userdata -> Ptr Word8 -> CSize -> Ptr CSize -> IO IOResult foreign import ccall "wrapper"- mkReadWriteCallback :: ReadWriteCallback -> IO (FunPtr ReadWriteCallback)---- connection read+ mkReadCallback :: ReadCallback -> IO (FunPtr ReadCallback) foreign import capi "rustls.h rustls_connection_read_tls" connectionReadTls ::- Ptr Connection -> FunPtr ReadWriteCallback -> Ptr Userdata -> Ptr CSize -> IO IOResult+ Ptr Connection -> FunPtr ReadCallback -> 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+ connectionWantsRead :: ConstPtr Connection -> IO CBool -- connection write +type WriteCallback = Ptr Userdata -> ConstPtr Word8 -> CSize -> Ptr CSize -> IO IOResult++foreign import ccall "wrapper"+ mkWriteCallback :: WriteCallback -> IO (FunPtr WriteCallback)+ foreign import capi "rustls.h rustls_connection_write_tls" connectionWriteTls ::- Ptr Connection -> FunPtr ReadWriteCallback -> Ptr Userdata -> Ptr CSize -> IO IOResult+ Ptr Connection -> FunPtr WriteCallback -> 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+ connectionWantsWrite :: ConstPtr Connection -> IO CBool -- misc @@ -386,37 +410,38 @@ 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+ certifiedKeyBuild ::+ ConstPtr Word8 -> CSize -> ConstPtr Word8 -> CSize -> Ptr (ConstPtr CertifiedKey) -> IO Result foreign import capi unsafe "rustls.h rustls_certified_key_free"- certifiedKeyFree :: Ptr CertifiedKey -> IO ()+ certifiedKeyFree :: ConstPtr 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+ certificateGetDER :: ConstPtr Certificate -> Ptr (ConstPtr 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)+ allCipherSuites :: ConstPtr (Ptr SupportedCipherSuite) foreign import capi "rustls.h value RUSTLS_ALL_CIPHER_SUITES_LEN" allCipherSuitesLen :: CSize foreign import capi "rustls.h value RUSTLS_DEFAULT_CIPHER_SUITES"- defaultCipherSuites :: Ptr (Ptr SupportedCipherSuite)+ defaultCipherSuites :: ConstPtr (ConstPtr SupportedCipherSuite) foreign import capi "rustls.h value RUSTLS_DEFAULT_CIPHER_SUITES_LEN" defaultCipherSuitesLen :: CSize foreign import capi unsafe "rustls.h rustls_supported_ciphersuite_get_suite"- supportedCipherSuiteGetSuite :: Ptr SupportedCipherSuite -> Word16+ supportedCipherSuiteGetSuite :: ConstPtr SupportedCipherSuite -> Word16 foreign import capi unsafe "hs_rustls.h hs_rustls_supported_ciphersuite_get_name"- hsSupportedCipherSuiteGetName :: Ptr SupportedCipherSuite -> Ptr Str -> IO ()+ hsSupportedCipherSuiteGetName :: ConstPtr SupportedCipherSuite -> Ptr Str -> IO () -- | A TLS protocol version supported by Rustls. newtype {-# CTYPE "stdint.h" "uint16_t" #-} TLSVersion = TLSVersion@@ -430,13 +455,13 @@ pattern TLS13 = TLSVersion 0x0304 foreign import capi "rustls.h value RUSTLS_ALL_VERSIONS"- allVersions :: Ptr TLSVersion+ allVersions :: ConstPtr 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+ defaultVersions :: ConstPtr TLSVersion foreign import capi "rustls.h value RUSTLS_DEFAULT_VERSIONS_LEN" defaultVersionsLen :: CSize
test/Main.hs view
@@ -32,6 +32,100 @@ import Test.Tasty.HUnit hiding (assert) import Test.Tasty.Hedgehog +main :: IO ()+main =+ defaultMain . testGroup "Basic Rustls tests" $+ [ testCase "TLS versions" do+ S.fromList [Rustls.TLS12, Rustls.TLS13]+ @?= S.fromList (NE.toList Rustls.defaultTLSVersions)+ assertBool "Unexpected default TLS versions" $+ S.fromList (NE.toList Rustls.defaultTLSVersions)+ `S.isSubsetOf` S.fromList (NE.toList Rustls.allTLSVersions),+ 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+ ]++testInMemory :: TestTree+testInMemory = withMiniCA \(fmap snd -> getMiniCA) ->+ testProperty "Test in-memory TLS" $ property do+ testSetup <- forAll . genTestSetup =<< liftIO getMiniCA++ (res, tlsLogLines) <- runInMemoryTest testSetup++ footnote $ "TLS log:\n" <> T.unpack (T.unlines tlsLogLines)++ let TestSetup {..} = testSetup+ 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+ nonEmptySet def = S.fromList . NE.toList . fromMaybe def . NE.nonEmpty++testHostname :: Text+testHostname = "example.org"++testMessageLen :: Int+testMessageLen = 1000+ data TestSetup = TestSetup { clientConfigBuilder :: Rustls.ClientConfigBuilder, serverConfigBuilder :: Rustls.ServerConfigBuilder,@@ -45,7 +139,7 @@ miniCAClientCertKey, miniCAServerCertKey :: Rustls.CertifiedKey } -genTestSetup :: MonadGen m => MiniCA -> m TestSetup+genTestSetup :: (MonadGen m) => MiniCA -> m TestSetup genTestSetup MiniCA {..} = do commonALPNProtocols <- genALPNProtocols clientConfigRoots <-@@ -96,189 +190,106 @@ 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)+runInMemoryTest ::+ (MonadIO m) =>+ TestSetup ->+ m (Either Rustls.RustlsException TestOutcome, [Text])+runInMemoryTest TestSetup {..} = do+ logRef <- liftIO $ newIORef [] - 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+ let runServer backend = withAcquire+ do+ lc <- mkTestLogCallback logRef "SERVER"+ rustlsConfig <-+ (\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- 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 {..}+ 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- logLines <- liftIO $ T.unlines . reverse <$> readIORef logRef- footnote $ "TLS log:\n" <> T.unpack logLines+ lc <- mkTestLogCallback logRef "CLIENT"+ rustlsConfig <-+ (\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) - 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 []+ (backend0, backend1) <- mkConnectedBSBackends - nonEmptySet def = S.fromList . NE.toList . fromMaybe def . NE.nonEmpty+ 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 {..}+ tlsLogLines <- liftIO $ reverse <$> readIORef logRef+ pure (res, tlsLogLines)+ where+ recordOutput = fmap reverse . flip execStateT [] - 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+withMiniCA :: (IO (FilePath, MiniCA) -> TestTree) -> TestTree+withMiniCA = withResource+ do+ tmpDir <-+ flip Temp.createTempDirectory "hs-rustls-minica"+ =<< Temp.getCanonicalTemporaryDirectory+ for_ ["example.org", "client.example.org"] \domain -> do+ let cp = Process.proc "minica" ["-domains", domain]+ void $ Process.readCreateProcess (cp {Process.cwd = Just tmpDir}) ""+ 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 {..})+ \(tmpDir, _) -> Dir.removeDirectoryRecursive tmpDir -mkConnectedBSBackends :: MonadIO m => m (Rustls.ByteStringBackend, Rustls.ByteStringBackend)+mkConnectedBSBackends :: (MonadIO m) => m (Rustls.ByteStringBackend, Rustls.ByteStringBackend) mkConnectedBSBackends = liftIO do (buf0, buf1) <- join (liftA2 (,)) newEmptyTMVarIO pure (mkBSBackend buf0 buf1, mkBSBackend buf1 buf0)