diff --git a/src/Simplex/Messaging/Agent/Server.hs b/src/Simplex/Messaging/Agent/Server.hs index 7193cd772..45b6be121 100644 --- a/src/Simplex/Messaging/Agent/Server.hs +++ b/src/Simplex/Messaging/Agent/Server.hs @@ -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 diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 2918d5d29..370965c7f 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -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 diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index 18ff71370..54b30e0f9 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -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 diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs index 95f7c45ae..068af65c9 100644 --- a/src/Simplex/Messaging/Notifications/Server/Env.hs +++ b/src/Simplex/Messaging/Notifications/Server/Env.hs @@ -55,7 +55,8 @@ data NtfServerConfig = NtfServerConfig logStatsInterval :: Maybe Int, logStatsStartTime :: Int, serverStatsLogFile :: FilePath, - serverStatsBackupFile :: Maybe FilePath + serverStatsBackupFile :: Maybe FilePath, + logTLSErrors :: Bool } defaultInactiveClientExpiration :: ExpirationConfig diff --git a/src/Simplex/Messaging/Notifications/Server/Main.hs b/src/Simplex/Messaging/Notifications/Server/Main.hs index bd3eb6580..15139ec90 100644 --- a/src/Simplex/Messaging/Notifications/Server/Main.hs +++ b/src/Simplex/Messaging/Notifications/Server/Main.hs @@ -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 diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 01d3b1a65..9fdb99599 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -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. diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 58eb3e8a6..61458fdc8 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -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 diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 769790490..35ecce103 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -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 diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 053a85cae..7d0f3cc1d 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -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 diff --git a/src/Simplex/Messaging/Transport/Client.hs b/src/Simplex/Messaging/Transport/Client.hs index 400d0e04e..d6f95f20a 100644 --- a/src/Simplex/Messaging/Transport/Client.hs +++ b/src/Simplex/Messaging/Transport/Client.hs @@ -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 diff --git a/src/Simplex/Messaging/Transport/HTTP2/Client.hs b/src/Simplex/Messaging/Transport/HTTP2/Client.hs index 428eee214..085af91a6 100644 --- a/src/Simplex/Messaging/Transport/HTTP2/Client.hs +++ b/src/Simplex/Messaging/Transport/HTTP2/Client.hs @@ -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 diff --git a/src/Simplex/Messaging/Transport/HTTP2/Server.hs b/src/Simplex/Messaging/Transport/HTTP2/Server.hs index f546c4a0e..11a7cdd3b 100644 --- a/src/Simplex/Messaging/Transport/HTTP2/Server.hs +++ b/src/Simplex/Messaging/Transport/HTTP2/Server.hs @@ -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` []) diff --git a/src/Simplex/Messaging/Transport/Server.hs b/src/Simplex/Messaging/Transport/Server.hs index 84d04e68a..d7ce49d9b 100644 --- a/src/Simplex/Messaging/Transport/Server.hs +++ b/src/Simplex/Messaging/Transport/Server.hs @@ -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) diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index 42a31db54..c4d614531 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -44,7 +44,6 @@ import Simplex.Messaging.Transport.Client import Simplex.Messaging.Transport.HTTP2 (http2TLSParams) import Simplex.Messaging.Transport.HTTP2.Client import Simplex.Messaging.Transport.HTTP2.Server -import Simplex.Messaging.Transport.KeepAlive import Test.Hspec import UnliftIO.Async import UnliftIO.Concurrent @@ -70,7 +69,7 @@ ntfTestStoreLogFile = "tests/tmp/ntf-server-store.log" testNtfClient :: (Transport c, MonadUnliftIO m, MonadFail m) => (THandle c -> m a) -> m a testNtfClient client = do Right host <- pure $ chooseTransportHost defaultNetworkConfig testHost - runTransportClient Nothing host ntfTestPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h -> + runTransportClient defaultTransportClientConfig host ntfTestPort (Just testKeyHash) $ \h -> liftIO (runExceptT $ ntfClientHandshake h testKeyHash supportedNTFServerVRange) >>= \case Right th -> client th Left e -> error $ show e @@ -101,7 +100,8 @@ ntfServerCfg = logStatsInterval = Nothing, logStatsStartTime = 0, serverStatsLogFile = "tests/ntf-server-stats.daily.log", - serverStatsBackupFile = Nothing + serverStatsBackupFile = Nothing, + logTLSErrors = True } withNtfServerStoreLog :: ATransport -> (ThreadId -> IO a) -> IO a @@ -178,7 +178,8 @@ apnsMockServerConfig = serverSupported = http2TLSParams, caCertificateFile = "tests/fixtures/ca.crt", privateKeyFile = "tests/fixtures/server.key", - certificateFile = "tests/fixtures/server.crt" + certificateFile = "tests/fixtures/server.crt", + logTLSErrors = True } withAPNSMockServer :: (APNSMockServer -> IO ()) -> IO () diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs index 11ac7f23f..16efc39f0 100644 --- a/tests/SMPAgentClient.hs +++ b/tests/SMPAgentClient.hs @@ -31,7 +31,6 @@ import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Client -import Simplex.Messaging.Transport.KeepAlive import Test.Hspec import UnliftIO.Concurrent import UnliftIO.Directory @@ -227,7 +226,7 @@ withSmpAgent t = withSmpAgentOn t (agentTestPort, testPort, testDB) testSMPAgentClientOn :: (Transport c, MonadUnliftIO m, MonadFail m) => ServiceName -> (c -> m a) -> m a testSMPAgentClientOn port' client = do Right useHost <- pure $ chooseTransportHost defaultNetworkConfig agentTestHost - runTransportClient Nothing useHost port' (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h -> do + runTransportClient defaultTransportClientConfig useHost port' (Just testKeyHash) $ \h -> do line <- liftIO $ getLn h if line == "Welcome to SMP agent v" <> B.pack simplexMQVersion then client h diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 0af206b40..1bca4d060 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -23,7 +23,6 @@ import Simplex.Messaging.Server (runSMPServerBlocking) import Simplex.Messaging.Server.Env.STM import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Client -import Simplex.Messaging.Transport.KeepAlive import Simplex.Messaging.Version import Test.Hspec import UnliftIO.Concurrent @@ -58,7 +57,7 @@ testServerStatsBackupFile = "tests/tmp/smp-server-stats.log" testSMPClient :: (Transport c, MonadUnliftIO m, MonadFail m) => (THandle c -> m a) -> m a testSMPClient client = do Right useHost <- pure $ chooseTransportHost defaultNetworkConfig testHost - runTransportClient Nothing useHost testPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h -> + runTransportClient defaultTransportClientConfig useHost testPort (Just testKeyHash) $ \h -> liftIO (runExceptT $ smpClientHandshake h testKeyHash supportedSMPServerVRange) >>= \case Right th -> client th Left e -> error $ show e @@ -88,7 +87,8 @@ cfg = caCertificateFile = "tests/fixtures/ca.crt", privateKeyFile = "tests/fixtures/server.key", certificateFile = "tests/fixtures/server.crt", - smpServerVRange = supportedSMPServerVRange + smpServerVRange = supportedSMPServerVRange, + logTLSErrors = True } withSmpServerStoreMsgLogOnV2 :: ATransport -> ServiceName -> (ThreadId -> IO a) -> IO a