more logs

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

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

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)