option to enable/disable TLS handshake error logs (disable by default) (#581)

* option to enable/disable TLS handshake error logs (disable by default) * refactor
2026-06-07 11:02:05 +00:00 · 2022-12-27 10:13:51 +00:00
parent 66d3465c19
commit 874f9f5cd6
16 changed files with 105 additions and 76 deletions
@@ -48,7 +48,7 @@ runSMPAgentBlocking (ATransport t) started cfg@AgentConfig {tcpPort, caCertifica
    smpAgent _ = do
      -- tlsServerParams is not in Env to avoid breaking functional API w/t key and certificate generation
      tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
-      runTransportServer started tcpPort tlsServerParams $ \(h :: c) -> do
+      runTransportServer started tcpPort tlsServerParams True $ \(h :: c) -> do
        liftIO . putLn h $ "Welcome to SMP agent v" <> B.pack simplexMQVersion
        c <- getAgentClient initServers
        logConnection c True
@@ -57,6 +57,7 @@ module Simplex.Messaging.Client
    NetworkConfig (..),
    defaultClientConfig,
    defaultNetworkConfig,
+    transportClientConfig,
    chooseTransportHost,
    ServerTransmission,
  )
@@ -90,7 +91,7 @@ import Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
-import Simplex.Messaging.Transport.Client (SocksProxy, TransportHost (..), runTransportClient)
+import Simplex.Messaging.Transport.Client (SocksProxy, TransportClientConfig (..), TransportHost (..), runTransportClient)
 import Simplex.Messaging.Transport.KeepAlive
 import Simplex.Messaging.Transport.WebSockets (WS)
 import Simplex.Messaging.Util (bshow, liftError, raceAny_)
@@ -159,7 +160,8 @@ data NetworkConfig = NetworkConfig
    -- | TCP keep-alive options, Nothing to skip enabling keep-alive
    tcpKeepAlive :: Maybe KeepAliveOpts,
    -- | period for SMP ping commands (microseconds)
-    smpPingInterval :: Int
+    smpPingInterval :: Int,
+    logTLSErrors :: Bool
  }
  deriving (Eq, Show, Generic, FromJSON)

@@ -176,9 +178,14 @@ defaultNetworkConfig =
      tcpConnectTimeout = 7_500_000,
      tcpTimeout = 5_000_000,
      tcpKeepAlive = Just defaultKeepAliveOpts,
-      smpPingInterval = 600_000_000 -- 10min
+      smpPingInterval = 600_000_000, -- 10min
+      logTLSErrors = False
    }

+transportClientConfig :: NetworkConfig -> TransportClientConfig
+transportClientConfig NetworkConfig {socksProxy, tcpKeepAlive, logTLSErrors} =
+  TransportClientConfig {socksProxy, tcpKeepAlive, logTLSErrors}
+
 -- | protocol client configuration.
 data ProtocolClientConfig = ProtocolClientConfig
  { -- | size of TBQueue to use for server commands and responses
@@ -241,7 +248,7 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, networkConfig,
        `catch` \(e :: IOException) -> pure . Left $ PCEIOError e
    Left e -> pure $ Left e
  where
-    NetworkConfig {tcpConnectTimeout, tcpTimeout, tcpKeepAlive, socksProxy, smpPingInterval} = networkConfig
+    NetworkConfig {tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig
    mkProtocolClient :: TransportHost -> STM (PClient msg)
    mkProtocolClient transportHost = do
      connected <- newTVar False
@@ -265,9 +272,10 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, networkConfig,
    runClient :: (ServiceName, ATransport) -> TransportHost -> PClient msg -> IO (Either ProtocolClientError (ProtocolClient msg))
    runClient (port', ATransport t) useHost c = do
      cVar <- newEmptyTMVarIO
+      let tcConfig = transportClientConfig networkConfig
      action <-
        async $
-          runTransportClient socksProxy useHost port' (Just $ keyHash protocolServer) tcpKeepAlive (client t c cVar)
+          runTransportClient tcConfig useHost port' (Just $ keyHash protocolServer) (client t c cVar)
            `finally` atomically (putTMVar cVar $ Left PCENetworkError)
      c_ <- tcpConnectTimeout `timeout` atomically (takeTMVar cVar)
      pure $ case c_ of
@@ -66,7 +66,7 @@ runNtfServerBlocking started cfg = runReaderT (ntfServer cfg started) =<< newNtf
 type M a = ReaderT NtfEnv IO a

 ntfServer :: NtfServerConfig -> TMVar Bool -> M ()
-ntfServer cfg@NtfServerConfig {transports} started = do
+ntfServer cfg@NtfServerConfig {transports, logTLSErrors} started = do
  restoreServerStats
  s <- asks subscriber
  ps <- asks pushServer
@@ -77,7 +77,7 @@ ntfServer cfg@NtfServerConfig {transports} started = do
    runServer :: (ServiceName, ATransport) -> M ()
    runServer (tcpPort, ATransport t) = do
      serverParams <- asks tlsServerParams
-      runTransportServer started tcpPort serverParams (runClient t)
+      runTransportServer started tcpPort serverParams logTLSErrors (runClient t)

    runClient :: Transport c => TProxy c -> c -> M ()
    runClient _ h = do
@@ -55,7 +55,8 @@ data NtfServerConfig = NtfServerConfig
    logStatsInterval :: Maybe Int,
    logStatsStartTime :: Int,
    serverStatsLogFile :: FilePath,
-    serverStatsBackupFile :: Maybe FilePath
+    serverStatsBackupFile :: Maybe FilePath,
+    logTLSErrors :: Bool
  }

 defaultInactiveClientExpiration :: ExpirationConfig
@@ -71,12 +71,13 @@ ntfServerCLI cfgPath logPath =
          \# and restoring it when the server is started.\n\
          \# Log is compacted on start (deleted objects are removed).\n"
            <> ("enable: " <> onOff enableStoreLog <> "\n\n")
-            <> "log_stats: off\n\n"
-            <> "[TRANSPORT]\n"
-            <> "# host is only used to print server address on start\n"
+            <> "log_stats: off\n\n\
+               \[TRANSPORT]\n\
+               \# host is only used to print server address on start\n"
            <> ("host: " <> host <> "\n")
            <> ("port: " <> defaultServerPort <> "\n")
-            <> "websockets: off\n"
+            <> "log_tls_errors: off\n\
+               \websockets: off\n"
    runServer ini = do
      hSetBuffering stdout LineBuffering
      hSetBuffering stderr LineBuffering
@@ -111,7 +112,8 @@ ntfServerCLI cfgPath logPath =
              logStatsInterval = logStats $> 86400, -- seconds
              logStatsStartTime = 0, -- seconds from 00:00 UTC
              serverStatsLogFile = combine logPath "ntf-server-stats.daily.log",
-              serverStatsBackupFile = logStats $> combine logPath "ntf-server-stats.log"
+              serverStatsBackupFile = logStats $> combine logPath "ntf-server-stats.log",
+              logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
            }

 data CliCommand
@@ -97,14 +97,13 @@ runSMPServer cfg = do
 -- This function uses passed TMVar to signal when the server is ready to accept TCP requests (True)
 -- and when it is disconnected from the TCP socket once the server thread is killed (False).
 runSMPServerBlocking :: TMVar Bool -> ServerConfig -> IO ()
-runSMPServerBlocking started cfg = newEnv cfg >>= runReaderT (smpServer started)
+runSMPServerBlocking started cfg = newEnv cfg >>= runReaderT (smpServer started cfg)

 type M a = ReaderT Env IO a

-smpServer :: TMVar Bool -> M ()
-smpServer started = do
+smpServer :: TMVar Bool -> ServerConfig -> M ()
+smpServer started cfg@ServerConfig {transports, logTLSErrors} = do
  s <- asks server
-  cfg@ServerConfig {transports} <- asks config
  restoreServerStats
  restoreServerMessages
  raceAny_
@@ -117,7 +116,7 @@ smpServer started = do
    runServer :: (ServiceName, ATransport) -> M ()
    runServer (tcpPort, ATransport t) = do
      serverParams <- asks tlsServerParams
-      runTransportServer started tcpPort serverParams (runClient t)
+      runTransportServer started tcpPort serverParams logTLSErrors (runClient t)

    serverThread ::
      forall s.
@@ -67,7 +67,8 @@ data ServerConfig = ServerConfig
    privateKeyFile :: FilePath,
    certificateFile :: FilePath,
    -- | SMP client-server protocol version range
-    smpServerVRange :: VersionRange
+    smpServerVRange :: VersionRange,
+    logTLSErrors :: Bool
  }

 defaultMessageExpiration :: ExpirationConfig
@@ -109,26 +109,27 @@ smpServerCLI cfgPath logPath =
                <> ("restore_messages: " <> onOff enableStoreLog <> "\n\n")
                <> "# Log daily server statistics to CSV file\n"
                <> ("log_stats: " <> onOff logStats <> "\n\n")
-                <> "[AUTH]\n"
-                <> "# Set new_queues option to off to completely prohibit creating new messaging queues.\n"
-                <> "# This can be useful when you want to decommission the server, but not all connections are switched yet.\n"
-                <> "new_queues: on\n\n"
-                <> "# Use create_password option to enable basic auth to create new messaging queues.\n"
-                <> "# The password should be used as part of server address in client configuration:\n"
-                <> "# smp://fingerprint:password@host1,host2\n"
-                <> "# The password will not be shared with the connecting contacts, you must share it only\n"
-                <> "# with the users who you want to allow creating messaging queues on your server.\n"
+                <> "[AUTH]\n\
+                   \# Set new_queues option to off to completely prohibit creating new messaging queues.\n\
+                   \# This can be useful when you want to decommission the server, but not all connections are switched yet.\n\
+                   \new_queues: on\n\n\
+                   \# Use create_password option to enable basic auth to create new messaging queues.\n\
+                   \# The password should be used as part of server address in client configuration:\n\
+                   \# smp://fingerprint:password@host1,host2\n\
+                   \# The password will not be shared with the connecting contacts, you must share it only\n\
+                   \# with the users who you want to allow creating messaging queues on your server.\n"
                <> ( case basicAuth of
                       Just auth -> "create_password: " <> T.unpack (safeDecodeUtf8 $ strEncode auth)
                       _ -> "# create_password: password to create new queues (any printable ASCII characters without whitespace, '@', ':' and '/')"
                   )
-                <> "\n\n"
-                <> "[TRANSPORT]\n"
-                <> "# host is only used to print server address on start\n"
+                <> "\n\n\
+                   \[TRANSPORT]\n\
+                   \# host is only used to print server address on start\n"
                <> ("host: " <> host <> "\n")
                <> ("port: " <> defaultServerPort <> "\n")
-                <> "websockets: off\n\n"
-                <> "[INACTIVE_CLIENTS]\n\
+                <> "log_tls_errors: off\n\
+                   \websockets: off\n\n\
+                   \[INACTIVE_CLIENTS]\n\
                   \# TTL and interval to check inactive clients\n\
                   \disconnect: off\n"
                <> ("# ttl: " <> show (ttl defaultInactiveClientExpiration) <> "\n")
@@ -191,7 +192,8 @@ smpServerCLI cfgPath logPath =
              logStatsStartTime = 0, -- seconds from 00:00 UTC
              serverStatsLogFile = combine logPath "smp-server-stats.daily.log",
              serverStatsBackupFile = logStats $> combine logPath "smp-server-stats.log",
-              smpServerVRange = supportedSMPServerVRange
+              smpServerVRange = supportedSMPServerVRange,
+              logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
            }

 data CliCommand
@@ -154,12 +154,14 @@ data TLS = TLS
    getLock :: TMVar ()
  }

-connectTLS :: T.TLSParams p => p -> Socket -> IO T.Context
-connectTLS params sock =
-  E.bracketOnError (T.contextNew sock params) closeTLS $ \ctx -> do
-    T.handshake ctx
-      `catchAll` \e -> putStrLn ("exception: " <> show e) >> E.throwIO e
-    pure ctx
+connectTLS :: T.TLSParams p => Maybe HostName -> Bool -> p -> Socket -> IO T.Context
+connectTLS host_ logErrors params sock =
+  E.bracketOnError (T.contextNew sock params) closeTLS $ \ctx ->
+    logHandshakeErrors (T.handshake ctx) $> ctx
+  where
+    logHandshakeErrors = if logErrors then (`catchAll` logThrow) else id
+    logThrow e = putStrLn ("TLS error" <> host <> ": " <> show e) >> E.throwIO e
+    host = maybe "" (\h -> " (" <> h <> ")") host_

 getTLS :: TransportPeer -> T.Context -> IO TLS
 getTLS tlsPeer cxt = withTlsUnique tlsPeer cxt newTLS
@@ -1,5 +1,6 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}

@@ -8,7 +9,9 @@ module Simplex.Messaging.Transport.Client
    runTLSTransportClient,
    smpClientHandshake,
    defaultSMPPort,
+    defaultTransportClientConfig,
    defaultSocksProxy,
+    TransportClientConfig (..),
    SocksProxy,
    TransportHost (..),
    TransportHosts (..),
@@ -93,20 +96,31 @@ instance IsString TransportHost where fromString = parseString strDecode

 instance IsString (NonEmpty TransportHost) where fromString = parseString strDecode

+data TransportClientConfig = TransportClientConfig
+  { socksProxy :: Maybe SocksProxy,
+    tcpKeepAlive :: Maybe KeepAliveOpts,
+    logTLSErrors :: Bool
+  }
+  deriving (Eq, Show)
+
+defaultTransportClientConfig :: TransportClientConfig
+defaultTransportClientConfig = TransportClientConfig Nothing (Just defaultKeepAliveOpts) True
+
 -- | Connect to passed TCP host:port and pass handle to the client.
-runTransportClient :: (Transport c, MonadUnliftIO m) => Maybe SocksProxy -> TransportHost -> ServiceName -> Maybe C.KeyHash -> Maybe KeepAliveOpts -> (c -> m a) -> m a
+runTransportClient :: (Transport c, MonadUnliftIO m) => TransportClientConfig -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> m a) -> m a
 runTransportClient = runTLSTransportClient supportedParameters Nothing

-runTLSTransportClient :: (Transport c, MonadUnliftIO m) => T.Supported -> Maybe XS.CertificateStore -> Maybe SocksProxy -> TransportHost -> ServiceName -> Maybe C.KeyHash -> Maybe KeepAliveOpts -> (c -> m a) -> m a
-runTLSTransportClient tlsParams caStore_ socksProxy_ host port keyHash keepAliveOpts client = do
-  let clientParams = mkTLSClientParams tlsParams caStore_ (B.unpack $ strEncode host) port keyHash
-      connectTCP = case socksProxy_ of
+runTLSTransportClient :: (Transport c, MonadUnliftIO m) => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> m a) -> m a
+runTLSTransportClient tlsParams caStore_ TransportClientConfig {socksProxy, tcpKeepAlive, logTLSErrors} host port keyHash client = do
+  let hostName = B.unpack $ strEncode host
+      clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash
+      connectTCP = case socksProxy of
        Just proxy -> connectSocksClient proxy $ hostAddr host
-        _ -> connectTCPClient . B.unpack $ strEncode host
+        _ -> connectTCPClient hostName
  c <- liftIO $ do
    sock <- connectTCP port
-    mapM_ (setSocketKeepAlive sock) keepAliveOpts
-    connectTLS clientParams sock >>= getClientConnection
+    mapM_ (setSocketKeepAlive sock) tcpKeepAlive
+    connectTLS (Just hostName) logTLSErrors clientParams sock >>= getClientConnection
  client c `E.finally` liftIO (closeConnection c)
  where
    hostAddr = \case
@@ -19,9 +19,8 @@ import qualified Network.HTTP2.Client as H
 import Network.Socket (HostName, ServiceName)
 import qualified Network.TLS as T
 import Numeric.Natural (Natural)
-import Simplex.Messaging.Transport.Client (TransportHost (..), runTLSTransportClient)
+import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), runTLSTransportClient)
 import Simplex.Messaging.Transport.HTTP2 (http2TLSParams, withTlsConfig)
-import Simplex.Messaging.Transport.KeepAlive (KeepAliveOpts)
 import UnliftIO.STM
 import UnliftIO.Timeout

@@ -43,7 +42,7 @@ data HTTP2Response = HTTP2Response
 data HTTP2ClientConfig = HTTP2ClientConfig
  { qSize :: Natural,
    connTimeout :: Int,
-    tcpKeepAlive :: Maybe KeepAliveOpts,
+    transportConfig :: TransportClientConfig,
    caStoreFile :: FilePath,
    suportedTLSParams :: T.Supported
  }
@@ -54,7 +53,7 @@ defaultHTTP2ClientConfig =
  HTTP2ClientConfig
    { qSize = 64,
      connTimeout = 10000000,
-      tcpKeepAlive = Nothing,
+      transportConfig = TransportClientConfig Nothing Nothing True,
      caStoreFile = "/etc/ssl/cert.pem",
      suportedTLSParams = http2TLSParams
    }
@@ -63,7 +62,7 @@ data HTTP2ClientError = HCResponseTimeout | HCNetworkError | HCNetworkError1 | H
  deriving (Show)

 getHTTP2Client :: HostName -> ServiceName -> HTTP2ClientConfig -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
-getHTTP2Client host port config@HTTP2ClientConfig {tcpKeepAlive, connTimeout, caStoreFile, suportedTLSParams} disconnected =
+getHTTP2Client host port config@HTTP2ClientConfig {transportConfig, connTimeout, caStoreFile, suportedTLSParams} disconnected =
  (atomically mkHTTPS2Client >>= runClient)
    `E.catch` \(e :: IOException) -> pure . Left $ HCIOError e
  where
@@ -80,7 +79,7 @@ getHTTP2Client host port config@HTTP2ClientConfig {tcpKeepAlive, connTimeout, ca
      when (isNothing caStore) . putStrLn $ "Error loading CertificateStore from " <> caStoreFile
      action <-
        async $
-          runHTTP2Client suportedTLSParams caStore host port tcpKeepAlive (client c cVar)
+          runHTTP2Client suportedTLSParams caStore transportConfig host port (client c cVar)
            `E.finally` atomically (putTMVar cVar $ Left HCNetworkError)
      conn_ <- connTimeout `timeout` atomically (takeTMVar cVar)
      pure $ case conn_ of
@@ -119,9 +118,9 @@ sendRequest HTTP2Client {reqQ, config} req = do
  atomically $ writeTBQueue reqQ (req, resp)
  maybe (Left HCResponseTimeout) Right <$> (connTimeout config `timeout` atomically (takeTMVar resp))

-runHTTP2Client :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe KeepAliveOpts -> ((Request -> (Response -> IO ()) -> IO ()) -> IO ()) -> IO ()
-runHTTP2Client tlsParams caStore host port keepAliveOpts client =
-  runTLSTransportClient tlsParams caStore Nothing (THDomainName host) port Nothing keepAliveOpts $ \c ->
+runHTTP2Client :: T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> HostName -> ServiceName -> ((Request -> (Response -> IO ()) -> IO ()) -> IO ()) -> IO ()
+runHTTP2Client tlsParams caStore tcConfig host port client =
+  runTLSTransportClient tlsParams caStore tcConfig (THDomainName host) port Nothing $ \c ->
    withTlsConfig c 16384 (`run` client)
  where
    run = H.run $ ClientConfig "https" (B.pack host) 20
@@ -25,7 +25,8 @@ data HTTP2ServerConfig = HTTP2ServerConfig
    serverSupported :: T.Supported,
    caCertificateFile :: FilePath,
    privateKeyFile :: FilePath,
-    certificateFile :: FilePath
+    certificateFile :: FilePath,
+    logTLSErrors :: Bool
  }
  deriving (Show)

@@ -42,12 +43,12 @@ data HTTP2Server = HTTP2Server
  }

 getHTTP2Server :: HTTP2ServerConfig -> IO HTTP2Server
-getHTTP2Server HTTP2ServerConfig {qSize, http2Port, serverSupported, caCertificateFile, certificateFile, privateKeyFile} = do
+getHTTP2Server HTTP2ServerConfig {qSize, http2Port, serverSupported, caCertificateFile, certificateFile, privateKeyFile, logTLSErrors} = do
  tlsServerParams <- loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile
  started <- newEmptyTMVarIO
  reqQ <- newTBQueueIO qSize
  action <- async $
-    runHTTP2Server started http2Port tlsServerParams $ \r sendResponse -> do
+    runHTTP2Server started http2Port tlsServerParams logTLSErrors $ \r sendResponse -> do
      reqBody <- getRequestBody r ""
      reqTrailers <- H.getRequestTrailers r
      atomically $ writeTBQueue reqQ HTTP2Request {request = r, reqBody, reqTrailers, sendResponse}
@@ -62,9 +63,9 @@ getHTTP2Server HTTP2ServerConfig {qSize, http2Port, serverSupported, caCertifica
 closeHTTP2Server :: HTTP2Server -> IO ()
 closeHTTP2Server = uninterruptibleCancel . action

-runHTTP2Server :: TMVar Bool -> ServiceName -> T.ServerParams -> HTTP2ServerFunc -> IO ()
-runHTTP2Server started port serverParams http2Server =
-  runTransportServer started port serverParams $ \c -> withTlsConfig c 16384 (`H.run` server)
+runHTTP2Server :: TMVar Bool -> ServiceName -> T.ServerParams -> Bool -> HTTP2ServerFunc -> IO ()
+runHTTP2Server started port serverParams logTLSErrors http2Server =
+  runTransportServer started port serverParams logTLSErrors $ \c -> withTlsConfig c 16384 (`H.run` server)
  where
    server :: Request -> Aux -> (Response -> [PushPromise] -> IO ()) -> IO ()
    server req _aux sendResp = http2Server req (`sendResp` [])
@@ -35,12 +35,12 @@ import UnliftIO.STM
 -- | Run transport server (plain TCP or WebSockets) on passed TCP port and signal when server started and stopped via passed TMVar.
 --
 -- All accepted connections are passed to the passed function.
-runTransportServer :: forall c m. (Transport c, MonadUnliftIO m) => TMVar Bool -> ServiceName -> T.ServerParams -> (c -> m ()) -> m ()
-runTransportServer started port serverParams server = do
+runTransportServer :: forall c m. (Transport c, MonadUnliftIO m) => TMVar Bool -> ServiceName -> T.ServerParams -> Bool -> (c -> m ()) -> m ()
+runTransportServer started port serverParams logTLSErrors server = do
  u <- askUnliftIO
  liftIO . runTCPServer started port $ \conn ->
    E.bracket
-      (connectTLS serverParams conn >>= getServerConnection)
+      (connectTLS Nothing logTLSErrors serverParams conn >>= getServerConnection)
      closeConnection
      (unliftIO u . server)