From 63789d0c6e7ef8924149a30e60bdda4c13b3fb1f Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Tue, 11 Jun 2024 22:48:06 +0300 Subject: [PATCH 1/2] deps: use tls-2.0 --- cabal.project | 2 +- package.yaml | 2 +- simplexmq.cabal | 12 ++++++------ src/Simplex/Messaging/Transport.hs | 8 +++++--- src/Simplex/Messaging/Transport/WebSockets.hs | 11 +++++++---- src/Simplex/RemoteControl/Client.hs | 6 ++---- 6 files changed, 22 insertions(+), 19 deletions(-) diff --git a/cabal.project b/cabal.project index 43afe30ea..38f2ce481 100644 --- a/cabal.project +++ b/cabal.project @@ -4,7 +4,7 @@ packages: . -- packages: . ../http2 -- packages: . ../network-transport -index-state: 2023-12-12T00:00:00Z +index-state: 2024-06-01T00:00:00Z package cryptostore flags: +use_crypton diff --git a/package.yaml b/package.yaml index ef747da0d..40f69146c 100644 --- a/package.yaml +++ b/package.yaml @@ -69,7 +69,7 @@ dependencies: - temporary == 1.3.* - time == 1.12.* - time-manager == 0.0.* - - tls >= 1.7.0 && < 1.8 + - tls >= 2.0.6 && < 2.1 - transformers == 0.6.* - unliftio == 0.2.* - unliftio-core == 0.2.* diff --git a/simplexmq.cabal b/simplexmq.cabal index bbe7583fa..3db522c0c 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -255,7 +255,7 @@ library , temporary ==1.3.* , time ==1.12.* , time-manager ==0.0.* - , tls >=1.7.0 && <1.8 + , tls >=2.0.6 && <2.1 , transformers ==0.6.* , unliftio ==0.2.* , unliftio-core ==0.2.* @@ -330,7 +330,7 @@ executable ntf-server , temporary ==1.3.* , time ==1.12.* , time-manager ==0.0.* - , tls >=1.7.0 && <1.8 + , tls >=2.0.6 && <2.1 , transformers ==0.6.* , unliftio ==0.2.* , unliftio-core ==0.2.* @@ -409,7 +409,7 @@ executable smp-server , temporary ==1.3.* , time ==1.12.* , time-manager ==0.0.* - , tls >=1.7.0 && <1.8 + , tls >=2.0.6 && <2.1 , transformers ==0.6.* , unliftio ==0.2.* , unliftio-core ==0.2.* @@ -487,7 +487,7 @@ executable xftp , temporary ==1.3.* , time ==1.12.* , time-manager ==0.0.* - , tls >=1.7.0 && <1.8 + , tls >=2.0.6 && <2.1 , transformers ==0.6.* , unliftio ==0.2.* , unliftio-core ==0.2.* @@ -562,7 +562,7 @@ executable xftp-server , temporary ==1.3.* , time ==1.12.* , time-manager ==0.0.* - , tls >=1.7.0 && <1.8 + , tls >=2.0.6 && <2.1 , transformers ==0.6.* , unliftio ==0.2.* , unliftio-core ==0.2.* @@ -678,7 +678,7 @@ test-suite simplexmq-test , time ==1.12.* , time-manager ==0.0.* , timeit ==2.0.* - , tls >=1.7.0 && <1.8 + , tls >=2.0.6 && <2.1 , transformers ==0.6.* , unliftio ==0.2.* , unliftio-core ==0.2.* diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 6eddcabf8..908af43f5 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -112,6 +112,7 @@ import Simplex.Messaging.Transport.Buffer import Simplex.Messaging.Util (bshow, catchAll, catchAll_, liftEitherWith) import Simplex.Messaging.Version import Simplex.Messaging.Version.Internal +import System.IO.Error (isEOFError) import UnliftIO.Exception (Exception) import qualified UnliftIO.Exception as E import UnliftIO.STM @@ -335,11 +336,12 @@ instance Transport TLS where getLn :: TLS -> IO ByteString getLn TLS {tlsContext, tlsBuffer} = do - getLnBuffered tlsBuffer (T.recvData tlsContext) `E.catch` handleEOF + getLnBuffered tlsBuffer (T.recvData tlsContext) `E.catches` [E.Handler handleTlsEOF, E.Handler handleEOF] where - handleEOF = \case - T.Error_EOF -> E.throwIO TEBadBlock + handleTlsEOF = \case + T.PostHandshake T.Error_EOF -> E.throwIO TEBadBlock e -> E.throwIO e + handleEOF e = if isEOFError e then E.throwIO TEBadBlock else E.throwIO e -- * SMP transport diff --git a/src/Simplex/Messaging/Transport/WebSockets.hs b/src/Simplex/Messaging/Transport/WebSockets.hs index 0883fcc28..866d0d197 100644 --- a/src/Simplex/Messaging/Transport/WebSockets.hs +++ b/src/Simplex/Messaging/Transport/WebSockets.hs @@ -25,6 +25,7 @@ import Simplex.Messaging.Transport withTlsUnique, ) import Simplex.Messaging.Transport.Buffer (trimCR) +import System.IO.Error (isEOFError) data WS = WS { wsPeer :: TransportPeer, @@ -108,9 +109,11 @@ makeTLSContextStream cxt = S.makeStream readStream writeStream where readStream :: IO (Maybe ByteString) - readStream = - (Just <$> T.recvData cxt) `E.catch` \case - T.Error_EOF -> pure Nothing - e -> E.throwIO e + readStream = (Just <$> T.recvData cxt) `E.catches` [E.Handler handleTlsEOF, E.Handler handleEOF] + where + handleTlsEOF = \case + T.PostHandshake T.Error_EOF -> pure Nothing + e -> E.throwIO e + handleEOF e = if isEOFError e then pure Nothing else E.throwIO e writeStream :: Maybe LB.ByteString -> IO () writeStream = maybe (closeTLS cxt) (T.sendData cxt) diff --git a/src/Simplex/RemoteControl/Client.hs b/src/Simplex/RemoteControl/Client.hs index de0cbce3b..644377abc 100644 --- a/src/Simplex/RemoteControl/Client.hs +++ b/src/Simplex/RemoteControl/Client.hs @@ -281,9 +281,7 @@ connectRCCtrl_ drg pairing'@RCCtrlPairing {caKey, caCert} inv@RCInvitation {ca, TLS.Credentials (creds : _) -> pure $ Just creds _ -> throwE $ RCEInternal "genTLSCredentials must generate credentials" let clientConfig = defaultTransportClientConfig {clientCredentials} - ExceptT . runTransportClient clientConfig Nothing host (show port) (Just ca) $ \tls@TLS {tlsBuffer, tlsContext} -> runExceptT $ do - -- pump socket to detect connection problems - liftIO $ peekBuffered tlsBuffer 100000 (TLS.recvData tlsContext) >>= logDebug . tshow -- should normally be ("", Nothing) here + ExceptT . runTransportClient clientConfig Nothing host (show port) (Just ca) $ \tls -> runExceptT $ do logDebug "Got TLS connection" r' <- newEmptyTMVarIO whenM (atomically $ tryPutTMVar r $ Right (tlsUniq tls, tls, r')) $ do @@ -305,7 +303,7 @@ connectRCCtrl_ drg pairing'@RCCtrlPairing {caKey, caCert} inv@RCInvitation {ca, catchRCError :: ExceptT RCErrorType IO a -> (RCErrorType -> ExceptT RCErrorType IO a) -> ExceptT RCErrorType IO a catchRCError = catchAllErrors $ \e -> case fromException e of - Just (TLS.Terminated _ _ (TLS.Error_Protocol (_, _, TLS.UnknownCa))) -> RCEIdentity + Just (TLS.Terminated _ _ (TLS.Error_Protocol _ TLS.UnknownCa)) -> RCEIdentity _ -> RCEException $ show e {-# INLINE catchRCError #-} From 3f510ccd23dd985ebe3848bc62b0260281bc02f8 Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Wed, 12 Jun 2024 15:24:44 +0300 Subject: [PATCH 2/2] roll back RCP "cleanup" --- src/Simplex/RemoteControl/Client.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Simplex/RemoteControl/Client.hs b/src/Simplex/RemoteControl/Client.hs index 644377abc..381397c6e 100644 --- a/src/Simplex/RemoteControl/Client.hs +++ b/src/Simplex/RemoteControl/Client.hs @@ -281,7 +281,9 @@ connectRCCtrl_ drg pairing'@RCCtrlPairing {caKey, caCert} inv@RCInvitation {ca, TLS.Credentials (creds : _) -> pure $ Just creds _ -> throwE $ RCEInternal "genTLSCredentials must generate credentials" let clientConfig = defaultTransportClientConfig {clientCredentials} - ExceptT . runTransportClient clientConfig Nothing host (show port) (Just ca) $ \tls -> runExceptT $ do + ExceptT . runTransportClient clientConfig Nothing host (show port) (Just ca) $ \tls@TLS {tlsBuffer, tlsContext} -> runExceptT $ do + -- pump socket to detect connection problems + liftIO $ peekBuffered tlsBuffer 100000 (TLS.recvData tlsContext) >>= logDebug . tshow -- should normally be ("", Nothing) here logDebug "Got TLS connection" r' <- newEmptyTMVarIO whenM (atomically $ tryPutTMVar r $ Right (tlsUniq tls, tls, r')) $ do