From 4128a2c8536411a1eb49105360f50e141248feab Mon Sep 17 00:00:00 2001 From: Ed Asriyan Date: Sat, 4 Jul 2026 17:19:43 +0000 Subject: [PATCH] smp-server: add serverInfoBytes to THandleParams and related functions --- src/Simplex/FileTransfer/Client.hs | 2 +- src/Simplex/FileTransfer/Server.hs | 2 +- src/Simplex/Messaging/Agent.hs | 7 +-- src/Simplex/Messaging/Agent/Client.hs | 14 +++-- src/Simplex/Messaging/Client.hs | 3 +- .../Messaging/Notifications/Transport.hs | 3 +- src/Simplex/Messaging/Server.hs | 6 ++- src/Simplex/Messaging/Transport.hs | 53 ++++++++++++------- tests/AgentTests/FunctionalAPITests.hs | 2 +- tests/AgentTests/NotificationTests.hs | 2 +- tests/CoreTests/BatchingTests.hs | 3 +- tests/XFTPAgent.hs | 4 +- 12 files changed, 65 insertions(+), 36 deletions(-) diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index 9d19d0492c..0c6b5e4b97 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -147,7 +147,7 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, let HTTP2Client {sessionId, sessionALPN} = http2Client v = VersionXFTP 1 thServerVRange = versionToRange v - thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, batch = True, serviceAuth = False} + thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, batch = True, serviceAuth = False, serverInfoBytes = Nothing} logDebug $ "Client negotiated handshake protocol: " <> tshow sessionALPN thParams@THandleParams {thVersion} <- case sessionALPN of Just alpn diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index 3cd19e7c1c..abd9672de0 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -157,7 +157,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira reqBody <- getHTTP2Body r xftpBlockSize let v = VersionXFTP 1 thServerVRange = versionToRange v - thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, batch = True, serviceAuth = False} + thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, batch = True, serviceAuth = False, serverInfoBytes = Nothing} req0 = XFTPTransportRequest {thParams = thParams0, request = r, reqBody, sendResponse, sniUsed, addCORS = addCORS'} flip runReaderT env $ case sessionALPN of Nothing -> processRequest req0 diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 34e90f127d..f6e2a7883a 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -199,6 +199,7 @@ import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Agent.Store.Entity import Simplex.Messaging.Agent.Store.Interface (closeDBStore, execSQL, getCurrentMigrations) import Simplex.Messaging.Agent.Store.Shared (UpMigration (..), upMigration) +import Simplex.Messaging.Server.Information (ServerPublicInfo) import qualified Simplex.Messaging.Agent.TSessionSubs as SS import Simplex.Messaging.Client (NetworkRequestMode (..), ProtocolClientError (..), SMPClientError, ServerTransmission (..), ServerTransmissionBatch, TransportSessionMode (..), nonBlockingWriteTBQueue, smpErrorClientNotice, temporaryClientError, unexpectedResponse) import qualified Simplex.Messaging.Crypto as C @@ -634,11 +635,11 @@ getConnectionRatchetAdHash c = withAgentEnv c . getConnectionRatchetAdHash' c {-# INLINE getConnectionRatchetAdHash #-} -- | Test protocol server -testProtocolServer :: forall p. ProtocolTypeI p => AgentClient -> NetworkRequestMode -> UserId -> ProtoServerWithAuth p -> IO (Maybe ProtocolTestFailure) +testProtocolServer :: forall p. ProtocolTypeI p => AgentClient -> NetworkRequestMode -> UserId -> ProtoServerWithAuth p -> IO (Either ProtocolTestFailure (Maybe ServerPublicInfo)) testProtocolServer c nm userId srv = withAgentEnv' c $ case protocolTypeI @p of SPSMP -> runSMPServerTest c nm userId srv - SPXFTP -> runXFTPServerTest c nm userId srv - SPNTF -> runNTFServerTest c nm userId srv + SPXFTP -> maybe (Right Nothing) Left <$> runXFTPServerTest c nm userId srv + SPNTF -> maybe (Right Nothing) Left <$> runNTFServerTest c nm userId srv -- | set SOCKS5 proxy on/off and optionally set TCP timeouts for fast network setNetworkConfig :: AgentClient -> NetworkConfig -> AE () diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index bb4f1a9507..aab3e88782 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -205,7 +205,9 @@ import Control.Monad.Reader import Control.Monad.Trans.Except import Crypto.Random (ChaChaDRG) import qualified Data.Aeson as J +import qualified Data.Aeson as Aeson import qualified Data.Aeson.TH as J +import qualified Data.ByteString.Lazy.Char8 as LB import Data.Bifunctor (bimap, first, second) import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Char8 (ByteString) @@ -304,11 +306,12 @@ import Simplex.Messaging.Protocol import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Protocol.Types import Simplex.Messaging.Server.QueueStore.QueueInfo +import Simplex.Messaging.Server.Information (ServerPublicInfo) import Simplex.Messaging.Session import Simplex.Messaging.SystemTime import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Transport (HandshakeError (..), SMPServiceRole (..), SMPVersion, ServiceCredentials (..), SessionId, THClientService' (..), THandleAuth (..), THandleParams (sessionId, thAuth, thVersion), TransportError (..), TransportPeer (..), sndAuthKeySMPVersion, shortLinksSMPVersion, newNtfCredsSMPVersion) +import Simplex.Messaging.Transport (HandshakeError (..), SMPServiceRole (..), SMPVersion, ServiceCredentials (..), SessionId, THClientService' (..), THandleAuth (..), THandleParams (sessionId, thAuth, thVersion, serverInfoBytes), TransportError (..), TransportPeer (..), sndAuthKeySMPVersion, shortLinksSMPVersion, newNtfCredsSMPVersion) import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Transport.Credentials import Simplex.Messaging.Util @@ -1281,7 +1284,7 @@ data ProtocolTestFailure = ProtocolTestFailure } deriving (Eq, Show) -runSMPServerTest :: AgentClient -> NetworkRequestMode -> UserId -> SMPServerWithAuth -> AM' (Maybe ProtocolTestFailure) +runSMPServerTest :: AgentClient -> NetworkRequestMode -> UserId -> SMPServerWithAuth -> AM' (Either ProtocolTestFailure (Maybe ServerPublicInfo)) runSMPServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth srv auth) = do cfg <- getClientConfig c smpCfg C.AuthAlg ra <- asks $ rcvAuthAlg . config @@ -1292,6 +1295,7 @@ runSMPServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth sr ts <- readTVarIO $ proxySessTs c getProtocolClient g nm tSess cfg presetDomains Nothing ts (\_ -> pure ()) >>= \case Right smp -> do + let serverInfo = serverInfoBytes (thParams smp) >>= Aeson.decode . LB.fromStrict rKeys@(_, rpKey) <- atomically $ C.generateAuthKeyPair ra g (sKey, spKey) <- atomically $ C.generateAuthKeyPair sa g (dhKey, _) <- atomically $ C.generateKeyPair g @@ -1303,8 +1307,10 @@ runSMPServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth sr _ -> secureSMPQueue smp nm rpKey rcvId sKey liftError (testErr TSDeleteQueue) $ deleteSMPQueue smp nm rpKey rcvId ok <- netTimeoutInt (tcpTimeout $ networkConfig cfg) nm `timeout` closeProtocolClient smp - pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok - Left e -> pure (Just $ testErr TSConnect e) + pure $ case either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok of + Just failErr -> Left failErr + Nothing -> Right serverInfo + Left e -> pure $ Left (testErr TSConnect e) where addr = B.unpack $ strEncode srv testErr :: ProtocolTestStep -> SMPClientError -> ProtocolTestFailure diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index dc811fa0bf..0e741c3179 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -230,7 +230,8 @@ smpClientStub g sessionId thVersion thAuth = do implySessId = thVersion >= authCmdsSMPVersion, encryptBlock = Nothing, batch = True, - serviceAuth = thVersion >= serviceCertsSMPVersion + serviceAuth = thVersion >= serviceCertsSMPVersion, + serverInfoBytes = Nothing }, sessionTs = ts, client_ = diff --git a/src/Simplex/Messaging/Notifications/Transport.hs b/src/Simplex/Messaging/Notifications/Transport.hs index 3df1e53ea5..861327470c 100644 --- a/src/Simplex/Messaging/Notifications/Transport.hs +++ b/src/Simplex/Messaging/Notifications/Transport.hs @@ -186,5 +186,6 @@ ntfTHandle c = THandle {connection = c, params} implySessId = False, encryptBlock = Nothing, batch = False, - serviceAuth = False + serviceAuth = False, + serverInfoBytes = Nothing } diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 36ac471f9a..b82addbbed 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -56,6 +56,7 @@ import Control.Monad.Trans.Except import Control.Monad.STM (retry) import Crypto.Random (ChaChaDRG) import Data.Bifunctor (first, second) +import qualified Data.Aeson as J import Data.ByteString.Base64 (encode) import qualified Data.ByteString.Builder as BLD import Data.ByteString.Char8 (ByteString) @@ -739,9 +740,10 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt idSize <- asks $ queueIdBytes . config kh <- asks serverIdentity ks <- atomically . C.generateKeyPair =<< asks random - ServerConfig {smpServerVRange, smpHandshakeTimeout} <- asks config + ServerConfig {smpServerVRange, smpHandshakeTimeout, information} <- asks config + let serverInfo = LB.toStrict . J.encode <$> information labelMyThread $ "smp handshake for " <> transportName tp - liftIO (timeout smpHandshakeTimeout . runExceptT $ smpServerHandshake srvCert srvSignKey h ks kh smpServerVRange $ getClientService ms g idSize) >>= \case + liftIO (timeout smpHandshakeTimeout . runExceptT $ smpServerHandshake srvCert srvSignKey h ks kh smpServerVRange serverInfo $ getClientService ms g idSize) >>= \case Just (Right th) -> runClientTransport th _ -> pure () diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 51a2955eb5..51a367b3cc 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -58,6 +58,7 @@ module Simplex.Messaging.Transport clientNoticesSMPVersion, rcvServiceSMPVersion, namesSMPVersion, + serverInfoSMPVersion, simplexMQVersion, smpBlockSize, TransportConfig (..), @@ -108,7 +109,7 @@ module Simplex.Messaging.Transport ) where -import Control.Applicative (optional) +import Control.Applicative (optional, (<|>)) import Control.Concurrent.STM import Control.Monad import Control.Monad.Except @@ -173,6 +174,7 @@ smpBlockSize = 16384 -- 17 - create notification credentials with NEW (7/12/2025) -- 18 - support client notices (10/10/2025) -- 19 - service subscriptions to messages (10/20/2025) +-- 20 - server public information in handshake (7/5/2026) data SMPVersion @@ -227,6 +229,9 @@ rcvServiceSMPVersion = VersionSMP 19 namesSMPVersion :: VersionSMP namesSMPVersion = VersionSMP 20 +serverInfoSMPVersion :: VersionSMP +serverInfoSMPVersion = VersionSMP 20 + minClientSMPRelayVersion :: VersionSMP minClientSMPRelayVersion = VersionSMP 6 @@ -496,7 +501,9 @@ data THandleParams v p = THandleParams -- based on protocol version batch :: Bool, -- | include service signature (or '0' if it is absent), based on protocol version - serviceAuth :: Bool + serviceAuth :: Bool, + -- | JSON-encoded ServerPublicInfo from handshake, present when server version >= serverInfoSMPVersion + serverInfoBytes :: Maybe ByteString } data THandleAuth (p :: TransportPeer) where @@ -548,7 +555,9 @@ data SMPServerHandshake = SMPServerHandshake sessionId :: SessionId, -- pub key to agree shared secrets for command authorization and entity ID encryption. -- todo C.PublicKeyX25519 - authPubKey :: Maybe CertChainPubKey + authPubKey :: Maybe CertChainPubKey, + -- | optional server public information (JSON-encoded ServerPublicInfo), sent when version >= serverInfoSMPVersion + serverInfo :: Maybe ByteString } -- This is the third handshake message that SMP server sends to services @@ -638,16 +647,21 @@ ifHasProxy v a b = if v >= proxyServerHandshakeSMPVersion then a else b ifHasService :: VersionSMP -> a -> a -> a ifHasService v a b = if v >= serviceCertsSMPVersion then a else b +ifHasServerInfo :: VersionSMP -> a -> a -> a +ifHasServerInfo v a b = if v >= serverInfoSMPVersion then a else b + instance Encoding SMPServerHandshake where - smpEncode SMPServerHandshake {smpVersionRange, sessionId, authPubKey} = - smpEncode (smpVersionRange, sessionId) <> auth + smpEncode SMPServerHandshake {smpVersionRange, sessionId, authPubKey, serverInfo} = + smpEncode (smpVersionRange, sessionId) <> auth <> info where auth = encodeAuthEncryptCmds (maxVersion smpVersionRange) authPubKey + info = ifHasServerInfo (maxVersion smpVersionRange) (smpEncode (Large <$> serverInfo)) "" smpP = do (smpVersionRange, sessionId) <- smpP -- TODO drop SMP v6: remove special parser and make key non-optional authPubKey <- authEncryptCmdsP (maxVersion smpVersionRange) smpP - pure SMPServerHandshake {smpVersionRange, sessionId, authPubKey} + serverInfo <- ifHasServerInfo (maxVersion smpVersionRange) ((fmap unLarge <$> smpP) <|> pure Nothing) (pure Nothing) + pure SMPServerHandshake {smpVersionRange, sessionId, authPubKey, serverInfo} -- newtype for CertificateChain and a session key signed with this certificate data CertChainPubKey = CertChainPubKey @@ -763,12 +777,13 @@ smpServerHandshake :: C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> + Maybe ByteString -> (SMPServiceRole -> X.CertificateChain -> XV.Fingerprint -> ExceptT TransportError IO ServiceId) -> ExceptT TransportError IO (THandleSMP c 'TServer) -smpServerHandshake srvCert srvSignKey c (k, pk) kh smpVRange getService = do +smpServerHandshake srvCert srvSignKey c (k, pk) kh smpVRange serverInfo getService = do let sk = C.signX509 srvSignKey $ C.publicToX509 k smpVersionRange = maybe legacyServerSMPRelayVRange (const smpVRange) $ getSessionALPN c - sendHandshake th $ SMPServerHandshake {sessionId, smpVersionRange, authPubKey = Just (CertChainPubKey srvCert sk)} + sendHandshake th $ SMPServerHandshake {sessionId, smpVersionRange, authPubKey = Just (CertChainPubKey srvCert sk), serverInfo} SMPClientHandshake {smpVersion = v, keyHash, authPubKey = k', proxyServer, clientService} <- getHandshake th when (keyHash /= kh) $ throwE $ TEHandshake IDENTITY case compatibleVRange' smpVersionRange v of @@ -801,7 +816,7 @@ smpServerHandshake srvCert srvSignKey c (k, pk) kh smpVRange getService = do -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a smpClientHandshake :: forall c. Transport c => c 'TClient -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> Bool -> Maybe (ServiceCredentials, C.KeyPairEd25519) -> ExceptT TransportError IO (THandleSMP c 'TClient) smpClientHandshake c ks_ keyHash@(C.KeyHash kh) vRange proxyServer serviceKeys_ = do - SMPServerHandshake {sessionId = sessId, smpVersionRange, authPubKey} <- getHandshake th + SMPServerHandshake {sessionId = sessId, smpVersionRange, authPubKey, serverInfo} <- getHandshake th when (sessionId /= sessId) $ throwE TEBadSession -- Below logic downgrades version range in case the "client" is SMP proxy server and it is -- connected to the destination server of the version 11 or older. @@ -838,7 +853,7 @@ smpClientHandshake c ks_ keyHash@(C.KeyHash kh) vRange proxyServer serviceKeys_ hs = SMPClientHandshake {smpVersion = v, keyHash, authPubKey = fst <$> ks_, proxyServer, clientService} sendHandshake th hs service <- mapM getClientService serviceKeys - liftIO $ smpTHandleClient th v vr (snd <$> ks_) ck_ proxyServer service + liftIO $ smpTHandleClient th v vr (snd <$> ks_) ck_ proxyServer service serverInfo Nothing -> throwE TEVersion where th@THandle {params = THandleParams {sessionId}} = smpTHandle c @@ -856,14 +871,14 @@ smpTHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> VersionRang smpTHandleServer th v vr pk k_ proxyServer peerClientService = do let thAuth = Just THAuthServer {serverPrivKey = pk, peerClientService, sessSecret' = (`C.dh'` pk) <$!> k_} be <- blockEncryption th v proxyServer thAuth - pure $ smpTHandle_ th v vr thAuth $ uncurry TSbChainKeys <$> be + pure $ smpTHandle_ th v vr thAuth (uncurry TSbChainKeys <$> be) Nothing -smpTHandleClient :: forall c. THandleSMP c 'TClient -> VersionSMP -> VersionRangeSMP -> Maybe C.PrivateKeyX25519 -> Maybe (C.PublicKeyX25519, CertChainPubKey) -> Bool -> Maybe THClientService -> IO (THandleSMP c 'TClient) -smpTHandleClient th v vr pk_ ck_ proxyServer clientService = do +smpTHandleClient :: forall c. THandleSMP c 'TClient -> VersionSMP -> VersionRangeSMP -> Maybe C.PrivateKeyX25519 -> Maybe (C.PublicKeyX25519, CertChainPubKey) -> Bool -> Maybe THClientService -> Maybe ByteString -> IO (THandleSMP c 'TClient) +smpTHandleClient th v vr pk_ ck_ proxyServer clientService serverInfoBytes = do let thAuth = clientTHParams <$!> ck_ be <- blockEncryption th v proxyServer thAuth -- swap is needed to use client's sndKey as server's rcvKey and vice versa - pure $ smpTHandle_ th v vr thAuth $ uncurry TSbChainKeys . swap <$> be + pure $ smpTHandle_ th v vr thAuth (uncurry TSbChainKeys . swap <$> be) serverInfoBytes where clientTHParams (k, ck) = THAuthClient @@ -883,8 +898,8 @@ blockEncryption THandle {params = THandleParams {sessionId}} v proxyServer = \ca be :: Maybe C.DhSecretX25519 -> IO (Maybe (TVar C.SbChainKey, TVar C.SbChainKey)) be = mapM $ \(C.DhSecretX25519 secret) -> bimapM newTVarIO newTVarIO $ C.sbcInit sessionId secret -smpTHandle_ :: forall c p. THandleSMP c p -> VersionSMP -> VersionRangeSMP -> Maybe (THandleAuth p) -> Maybe TSbChainKeys -> THandleSMP c p -smpTHandle_ th@THandle {params} v vr thAuth encryptBlock = +smpTHandle_ :: forall c p. THandleSMP c p -> VersionSMP -> VersionRangeSMP -> Maybe (THandleAuth p) -> Maybe TSbChainKeys -> Maybe ByteString -> THandleSMP c p +smpTHandle_ th@THandle {params} v vr thAuth encryptBlock serverInfoBytes = -- TODO drop SMP v6: make thAuth non-optional -- * Note: update version-based parameters in smpTHParamsSetVersion as well. let params' = @@ -894,7 +909,8 @@ smpTHandle_ th@THandle {params} v vr thAuth encryptBlock = thAuth, implySessId = v >= authCmdsSMPVersion, encryptBlock, - serviceAuth = v >= serviceCertsSMPVersion -- optional service signature will be encoded for all commands and responses + serviceAuth = v >= serviceCertsSMPVersion, -- optional service signature will be encoded for all commands and responses + serverInfoBytes } in (th :: THandleSMP c p) {params = params'} @@ -933,7 +949,8 @@ smpTHandle c = THandle {connection = c, params} implySessId = False, encryptBlock = Nothing, batch = True, - serviceAuth = False + serviceAuth = False, + serverInfoBytes = Nothing } $(J.deriveJSON (sumTypeJSON id) ''HandshakeError) diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index fba0eac4ad..56c1076053 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -3629,7 +3629,7 @@ testSMPServerConnectionTest (t, msType) newQueueBasicAuth srv = withSmpServerConfigOn t cfg' testPort2 $ \_ -> do -- initially passed server is not running withAgent 1 agentCfg initAgentServers testDB $ \a -> - testProtocolServer a NRMInteractive 1 srv + either Just (const Nothing) <$> testProtocolServer a NRMInteractive 1 srv where cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {newQueueBasicAuth} diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index 6a1c5cef99..a0568d2782 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -540,7 +540,7 @@ testRunNTFServerTests :: ASrvTransport -> NtfServer -> IO (Maybe ProtocolTestFai testRunNTFServerTests t srv = withNtfServer t $ withAgent 1 agentCfg initAgentServers testDB $ \a -> - testProtocolServer a NRMInteractive 1 $ ProtoServerWithAuth srv Nothing + either Just (const Nothing) <$> testProtocolServer a NRMInteractive 1 (ProtoServerWithAuth srv Nothing) testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO () testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {agentEnv = Env {config = aliceCfg, store}} bob = do diff --git a/tests/CoreTests/BatchingTests.hs b/tests/CoreTests/BatchingTests.hs index 8a285721b6..4ffb25fea5 100644 --- a/tests/CoreTests/BatchingTests.hs +++ b/tests/CoreTests/BatchingTests.hs @@ -421,7 +421,8 @@ testTHandleParams v sessionId = implySessId = v >= authCmdsSMPVersion, encryptBlock = Nothing, batch = True, - serviceAuth = v >= serviceCertsSMPVersion + serviceAuth = v >= serviceCertsSMPVersion, + serverInfoBytes = Nothing } testTHandleAuth :: VersionSMP -> TVar ChaChaDRG -> C.APublicAuthKey -> IO (Maybe (THandleAuth 'TClient)) diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index af1d2f5c24..459822fe8f 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -99,7 +99,7 @@ testXFTPServerTest newFileBasicAuth srv = withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2} $ \_ -> -- initially passed server is not running withAgent 1 agentCfg initAgentServers testDB $ \a -> - testProtocolServer a NRMInteractive 1 srv + either Just (const Nothing) <$> testProtocolServer a NRMInteractive 1 srv rfProgress :: forall m. (HasCallStack, MonadIO m, MonadFail m) => AgentClient -> Int64 -> m () rfProgress c expected = loop 0 @@ -685,4 +685,4 @@ testXFTPServerTest_ :: HasCallStack => XFTPServerWithAuth -> IO (Maybe ProtocolT testXFTPServerTest_ srv = -- initially passed server is not running withAgent 1 agentCfg initAgentServers testDB $ \a -> - testProtocolServer a NRMInteractive 1 srv + either Just (const Nothing) <$> testProtocolServer a NRMInteractive 1 srv