diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -25,7 +25,7 @@ Make sure to have [Cargo](https://doc.rust-lang.org/stable/cargo/getting-started/installation.html) installed. Then, clone and install rustls-ffi: ```bash -git clone https://github.com/rustls/rustls-ffi +git clone https://github.com/rustls/rustls-ffi -b v0.9.2 cd rustls-ffi make DESTDIR=/path/to/some/dir install ``` diff --git a/rustls.cabal b/rustls.cabal --- a/rustls.cabal +++ b/rustls.cabal @@ -1,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 diff --git a/src/Rustls.hs b/src/Rustls.hs --- a/src/Rustls.hs +++ b/src/Rustls.hs @@ -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 diff --git a/src/Rustls/Internal.hs b/src/Rustls/Internal.hs --- a/src/Rustls/Internal.hs +++ b/src/Rustls/Internal.hs @@ -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 diff --git a/src/Rustls/Internal/FFI.hs b/src/Rustls/Internal/FFI.hs --- a/src/Rustls/Internal/FFI.hs +++ b/src/Rustls/Internal/FFI.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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)