log client hooks

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

@@ -29,7 +29,7 @@ module Simplex.Messaging.Transport.Client
 where
 
 import Control.Applicative (optional, (<|>))
-import Control.Logger.Simple (logError)
+import Control.Logger.Simple (logError, logWarn)
 import Control.Monad
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Attoparsec.ByteString.Char8 as A
@@ -181,7 +181,9 @@ runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy,
     tls <- set CHContext $ connectTLS (Just hostName) tCfg clientParams sock
     chain <- takePeerCertChain serverCert
     sent <- readIORef clientCredsSent
-    client =<< set CHTransport (getTransportConnection tCfg sent chain tls)
+    c <- set CHTransport (getTransportConnection tCfg sent chain tls)
+    logWarn $ "ALPN: client negotiated " <> tshow (getSessionALPN c)
+    client c
   where
     closeConn = readIORef >=> mapM_ (\c -> E.uninterruptibleMask_ $ closeConn_ c `catchAll_` pure ())
     closeConn_ = \case
@@ -294,19 +296,25 @@ mkTLSClientParams supported caStore_ host port cafp_ clientCreds_ clientCredsSen
         def
           { T.onServerCertificate = onServerCert,
             T.onCertificateRequest = onCertRequest,
-            T.onSuggestALPN = pure alpn_
+            T.onSuggestALPN = alpn_ <$ logWarn ("ALPN: client offering " <> tshow alpn_),
+            T.onCustomFFDHEGroup = \dh pub -> do
+              logWarn "TLS client hook onCustomFFDHEGroup"
+              (T.onCustomFFDHEGroup def) dh pub
           },
       T.clientSupported = supported
     }
   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

@@ -31,6 +31,7 @@ module Simplex.Messaging.Transport.Server
   )
 where
 
+import Debug.Trace
 import Control.Applicative ((<|>))
 import Control.Logger.Simple
 import Control.Monad
@@ -139,6 +140,7 @@ runTransportServerSocketState ss started getSocket threadLabel srvSupported srvC
       sniUsed <- newTVarIO False
       let srvParams = supportedTLSServerParams srvSupported srvCreds sniUsed $ serverALPN cfg
       h <- setupTLS_ srvParams
+      logWarn $ "ALPN: server negotiated " <> tshow (getSessionALPN h)
       sni <- readTVarIO sniUsed
       pure (sni, h)
       where
@@ -261,12 +263,28 @@ 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),
-            T.onALPNClientSuggest = (\alpn -> pure . fromMaybe "" . find (`elem` alpn)) <$> alpn_
+                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
+                  logWarn $ "ALPN: client offered " <> tshow protos <> ", server selected " <> tshow proto
+                  pure proto
+              )
+                <$> alpn_,
+            T.onCipherChoosing = \v cs ->
+              traceShow "TLS: server hook onCipherChoosing" $ (T.onCipherChoosing def) v cs,
+            T.onNewHandshake = \m -> do
+              logWarn "TLS: server hook onNewHandshake"
+              (T.onNewHandshake def) m,
+            T.onEncryptedExtensionsCreating = \es -> do
+              logWarn "TLS: server hook onEncryptedExtensionsCreating"
+              (T.onEncryptedExtensionsCreating def) es
           },
       T.serverSupported = serverSupported
     }
@@ -277,7 +295,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)