diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 9c9392c21..e2fef46ce 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -105,6 +105,7 @@ where import Control.Applicative (optional) import Control.Concurrent.STM +import Control.Logger.Simple (logWarn) import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class @@ -340,12 +341,15 @@ type ALPN = ByteString connectTLS :: T.TLSParams p => Maybe HostName -> TransportConfig -> p -> Socket -> IO T.Context connectTLS host_ TransportConfig {logTLSErrors} params sock = - E.bracketOnError (T.contextNew sock params) closeTLS $ \ctx -> - logHandshakeErrors (T.handshake ctx) $> ctx + E.bracketOnError (T.contextNew sock params) closeTLS $ \ctx -> do + logWarn $ "TLS: " <> peer <> " handshake starting" + logHandshakeErrors (T.handshake ctx) + logWarn ("TLS: " <> peer <> " handshake complete") $> ctx where logHandshakeErrors = if logTLSErrors then (`catchAll` logThrow) else id logThrow e = putStrLn ("TLS error" <> host <> ": " <> show e) >> E.throwIO e host = maybe "" (\h -> " (" <> h <> ")") host_ + peer = maybe "server" (const "client") host_ getTLS :: forall p. TransportPeerI p => TransportConfig -> Bool -> X.CertificateChain -> T.Context -> IO (TLS p) getTLS cfg tlsCertSent tlsPeerCert cxt = withTlsUnique @TLS @p cxt newTLS diff --git a/src/Simplex/Messaging/Transport/Client.hs b/src/Simplex/Messaging/Transport/Client.hs index 42be5125b..972e4ad3a 100644 --- a/src/Simplex/Messaging/Transport/Client.hs +++ b/src/Simplex/Messaging/Transport/Client.hs @@ -303,12 +303,15 @@ mkTLSClientParams supported caStore_ host port cafp_ clientCreds_ clientCredsSen where p = B.pack port onServerCert _ _ _ cc = do + logWarn "TLS: client received server certificate" errs <- maybe def (\ca -> validateCertificateChain ca host p cc) cafp_ atomically $ putTMVar serverCerts $ if null errs then Just cc else Nothing pure errs - onCertRequest = case clientCreds_ of - Just _ -> \_ -> clientCreds_ <$ writeIORef clientCredsSent True - Nothing -> \_ -> pure Nothing + onCertRequest _ = do + logWarn "TLS: client received certificate request" + case clientCreds_ of + Just _ -> clientCreds_ <$ writeIORef clientCredsSent True + Nothing -> pure Nothing validateCertificateChain :: C.KeyHash -> HostName -> ByteString -> X.CertificateChain -> IO [XV.FailedReason] validateCertificateChain (C.KeyHash kh) host port cc = case chainIdCaCerts cc of diff --git a/src/Simplex/Messaging/Transport/Server.hs b/src/Simplex/Messaging/Transport/Server.hs index 8ef8f7305..7539413fa 100644 --- a/src/Simplex/Messaging/Transport/Server.hs +++ b/src/Simplex/Messaging/Transport/Server.hs @@ -262,11 +262,13 @@ supportedTLSServerParams serverSupported TLSServerCredential {credential, sniCre { T.serverWantClientCert = False, T.serverHooks = def - { T.onServerNameIndication = case sniCredential of - Nothing -> \_ -> pure $ T.Credentials [credential] - Just sniCred -> \case + { T.onServerNameIndication = \sni -> do + logWarn $ "TLS: server received SNI " <> tshow sni + case sniCredential of Nothing -> pure $ T.Credentials [credential] - Just _host -> T.Credentials [sniCred] <$ atomically (writeTVar sniCredUsed True), + Just sniCred -> case sni of + Nothing -> pure $ T.Credentials [credential] + Just _host -> T.Credentials [sniCred] <$ atomically (writeTVar sniCredUsed True), T.onALPNClientSuggest = ( \alpn protos -> do let proto = fromMaybe "" $ find (`elem` alpn) protos @@ -284,7 +286,8 @@ paramsAskClientCert clientCert params = { T.serverWantClientCert = True, T.serverHooks = (T.serverHooks params) - { T.onClientCertificate = \cc -> + { T.onClientCertificate = \cc -> do + logWarn "TLS: server received client certificate" validateClientCertificate cc >>= \case Just reason -> T.CertificateUsageReject reason <$ atomically (tryPutTMVar clientCert Nothing) Nothing -> T.CertificateUsageAccept <$ atomically (tryPutTMVar clientCert $ Just cc)