From 62e39ae857bf382253b48679c8ebae7dad7ffddb Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Sun, 26 Jul 2026 15:53:04 +0100 Subject: [PATCH] server information --- src/Simplex/FileTransfer/Client.hs | 2 +- src/Simplex/FileTransfer/Server.hs | 2 +- src/Simplex/Messaging/Agent.hs | 6 ++-- src/Simplex/Messaging/Agent/Client.hs | 12 ++----- src/Simplex/Messaging/Client.hs | 2 +- .../Messaging/Notifications/Transport.hs | 2 +- src/Simplex/Messaging/Server/Information.hs | 3 +- src/Simplex/Messaging/Server/Main.hs | 9 ++--- src/Simplex/Messaging/Server/Web.hs | 4 +-- src/Simplex/Messaging/Transport.hs | 30 +++++++++-------- tests/AgentTests/EqInstances.hs | 13 ++++++++ tests/AgentTests/FunctionalAPITests.hs | 33 ++++++++++++++----- tests/AgentTests/NotificationTests.hs | 9 ++--- tests/CoreTests/BatchingTests.hs | 2 +- tests/XFTPAgent.hs | 23 +++++-------- 15 files changed, 86 insertions(+), 66 deletions(-) diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index 32aeb083d..a5cd4acfe 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -141,7 +141,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, serviceAuth = False, serverInfoBytes = Nothing} + thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, serviceAuth = False, serverInfo = 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 834e794f1..9f7499782 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, serviceAuth = False, serverInfoBytes = Nothing} + thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, serviceAuth = False, serverInfo = 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 14fcc7775..18a7ac980 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -676,11 +676,11 @@ getConnectionRatchetAdHash c = withAgentEnv c . getConnectionRatchetAdHash' c {-# INLINE getConnectionRatchetAdHash #-} -- | Test protocol server -testProtocolServer :: forall p. ProtocolTypeI p => AgentClient -> NetworkRequestMode -> UserId -> ProtoServerWithAuth p -> IO (Either ProtocolTestFailure (Either String ServerPublicInfo)) +testProtocolServer :: forall p. ProtocolTypeI p => AgentClient -> NetworkRequestMode -> UserId -> ProtoServerWithAuth p -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo))) testProtocolServer c nm userId srv = withAgentEnv' c $ case protocolTypeI @p of SPSMP -> runSMPServerTest c nm userId srv - SPXFTP -> maybe (Right (Left "no info for XFTP")) Left <$> runXFTPServerTest c nm userId srv - SPNTF -> maybe (Right (Left "no info for NTF")) Left <$> 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 215fe8cc6..718bcc228 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -206,7 +206,6 @@ import Control.Monad.Trans.Except import Crypto.Random (ChaChaDRG) import qualified Data.Aeson as J 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) @@ -310,7 +309,7 @@ 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, serverInfoBytes), TransportError (..), TransportPeer (..), shortLinksSMPVersion, newNtfCredsSMPVersion) +import Simplex.Messaging.Transport (HandshakeError (..), SMPServiceRole (..), SMPVersion, ServiceCredentials (..), SessionId, THClientService' (..), THandleAuth (..), THandleParams (sessionId, thAuth, thVersion, serverInfo), TransportError (..), TransportPeer (..), shortLinksSMPVersion, newNtfCredsSMPVersion) import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Transport.Credentials import Simplex.Messaging.Util @@ -1286,7 +1285,7 @@ data ProtocolTestFailure = ProtocolTestFailure } deriving (Eq, Show) -runSMPServerTest :: AgentClient -> NetworkRequestMode -> UserId -> SMPServerWithAuth -> AM' (Either ProtocolTestFailure (Either String ServerPublicInfo)) +runSMPServerTest :: AgentClient -> NetworkRequestMode -> UserId -> SMPServerWithAuth -> AM' (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo))) runSMPServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth srv auth) = do cfg <- getClientConfig c smpCfg C.AuthAlg ra <- asks $ rcvAuthAlg . config @@ -1297,9 +1296,6 @@ 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 = case serverInfoBytes (thParams smp) of - Nothing -> Left "No server info received" - Just bs -> J.eitherDecodeStrict bs rKeys@(_, rpKey) <- atomically $ C.generateAuthKeyPair ra g (sKey, spKey) <- atomically $ C.generateAuthKeyPair sa g (dhKey, _) <- atomically $ C.generateKeyPair g @@ -1311,9 +1307,7 @@ 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 $ case either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok of - Just failErr -> Left failErr - Nothing -> Right serverInfo + pure $ r >> maybe (Left (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const $ Right $ serverInfo (thParams smp)) ok Left e -> pure $ Left (testErr TSConnect e) where addr = B.unpack $ strEncode srv diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 0463417d5..6f5234558 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -230,7 +230,7 @@ smpClientStub g sessionId thVersion thAuth = do implySessId = True, encryptBlock = Nothing, serviceAuth = thVersion >= serviceCertsSMPVersion, - serverInfoBytes = Nothing + serverInfo = Nothing }, sessionTs = ts, client_ = diff --git a/src/Simplex/Messaging/Notifications/Transport.hs b/src/Simplex/Messaging/Notifications/Transport.hs index 976bfce56..837f31fa2 100644 --- a/src/Simplex/Messaging/Notifications/Transport.hs +++ b/src/Simplex/Messaging/Notifications/Transport.hs @@ -161,5 +161,5 @@ ntfTHandle c = THandle {connection = c, params} implySessId = True, encryptBlock = Nothing, serviceAuth = False, - serverInfoBytes = Nothing + serverInfo = Nothing } diff --git a/src/Simplex/Messaging/Server/Information.hs b/src/Simplex/Messaging/Server/Information.hs index d9b3891f7..2f1f046e7 100644 --- a/src/Simplex/Messaging/Server/Information.hs +++ b/src/Simplex/Messaging/Server/Information.hs @@ -26,7 +26,6 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Int (Int64) import Data.Maybe (isJust) import Data.Text (Text) -import Simplex.Messaging.Agent.Protocol (ConnectionLink, ConnectionMode (..)) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON) @@ -112,7 +111,7 @@ data Entity = Entity {name :: Text, country :: Maybe Text} deriving (Show) data ServerContactAddress = ServerContactAddress - { simplex :: Maybe (ConnectionLink 'CMContact), + { simplex :: Maybe Text, email :: Maybe Text, -- it is recommended that it matches DNS email address, if either is present pgp :: Maybe PGPKey } diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 747226eb5..138a25fc0 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -59,7 +59,7 @@ import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1, encodeUtf8) import qualified Data.Text.IO as T import Options.Applicative -import Simplex.Messaging.Agent.Protocol (ConnectionLink (..), connReqUriP') +import Simplex.Messaging.Agent.Protocol (ConnectionLink (..), ConnectionMode (..), connReqUriP') import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..)) import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SMPWebPortServers (..), SocksMode (..), defaultNetworkConfig, textToHostMode) @@ -85,7 +85,7 @@ import Simplex.Messaging.Transport (supportedProxyClientSMPRelayVRange, alpnSupp import Simplex.Messaging.Transport.Client (TransportHost (..), defaultSocksProxy) import Simplex.Messaging.Transport.HTTP2 (httpALPN) import Simplex.Messaging.Transport.Server (ServerCredentials (..), mkTransportServerConfig) -import Simplex.Messaging.Util (eitherToMaybe, ifM) +import Simplex.Messaging.Util (eitherToMaybe, ifM, safeDecodeUtf8) import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist) import System.Exit (exitFailure) import System.FilePath (combine) @@ -787,12 +787,13 @@ serverPublicInfo ini = serverInfo <$!> infoValue "source_code" <$!> infoValue nameField countryValue field = (either error id . validCountryValue (T.unpack field) . T.unpack) <$!> infoValue field iniContacts simplexField emailField pgpKeyUriField pgpKeyFingerprintField = - let simplex = either error id . parseAll linkP . encodeUtf8 <$!> eitherToMaybe (lookupValue "INFORMATION" simplexField ini) + let addr :: Maybe (ConnectionLink 'CMContact) = either error id . parseAll linkP . encodeUtf8 <$!> eitherToMaybe (lookupValue "INFORMATION" simplexField ini) + simplex = safeDecodeUtf8 . strEncode <$> addr linkP = CLFull <$> connReqUriP' Nothing <|> CLShort <$> strP email = infoValue emailField pkURI_ = infoValue pgpKeyUriField pkFingerprint_ = infoValue pgpKeyFingerprintField - in case (simplex, email, pkURI_, pkFingerprint_) of + in case (addr, email, pkURI_, pkFingerprint_) of (Nothing, Nothing, Nothing, _) -> Nothing (Nothing, Nothing, _, Nothing) -> Nothing (_, _, pkURI, pkFingerprint) -> Just ServerContactAddress {simplex, email, pgp = PGPKey <$> pkURI <*> pkFingerprint} diff --git a/src/Simplex/Messaging/Server/Web.hs b/src/Simplex/Messaging/Server/Web.hs index 7044a7e39..09e3180ed 100644 --- a/src/Simplex/Messaging/Server/Web.hs +++ b/src/Simplex/Messaging/Server/Web.hs @@ -270,14 +270,14 @@ serverInfoSubsts simplexmqSource information = ] admin ServerContactAddress {simplex, email, pgp} = [ ("admin", Just ""), - ("adminSimplex", strEncode <$> simplex), + ("adminSimplex", encodeUtf8 <$> simplex), ("adminEmail", encodeUtf8 <$> email), ("adminPGP", encodeUtf8 . pkURI <$> pgp), ("adminPGPFingerprint", encodeUtf8 . pkFingerprint <$> pgp) ] complaints ServerContactAddress {simplex, email, pgp} = [ ("complaints", Just ""), - ("complaintsSimplex", strEncode <$> simplex), + ("complaintsSimplex", encodeUtf8 <$> simplex), ("complaintsEmail", encodeUtf8 <$> email), ("complaintsPGP", encodeUtf8 . pkURI <$> pgp), ("complaintsPGPFingerprint", encodeUtf8 . pkFingerprint <$> pgp) diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index cf3518441..aef23ae9f 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -103,12 +103,13 @@ module Simplex.Messaging.Transport ) where -import Control.Applicative (optional, (<|>)) +import Control.Applicative (optional) import Control.Concurrent.STM import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class import Control.Monad.Trans.Except (throwE) +import qualified Data.Aeson as J import qualified Data.Aeson.TH as J import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Bifunctor (first) @@ -134,9 +135,10 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (dropPrefix, parseRead1, sumTypeJSON) +import Simplex.Messaging.Server.Information import Simplex.Messaging.Transport.Buffer import Simplex.Messaging.Transport.Shared -import Simplex.Messaging.Util (bshow, catchAll, catchAll_, liftEitherWith) +import Simplex.Messaging.Util (bshow, catchAll, catchAll_, liftEitherWith, (<$$>)) import Simplex.Messaging.Version import Simplex.Messaging.Version.Internal import System.IO.Error (isEOFError) @@ -466,7 +468,7 @@ data THandleParams v p = THandleParams -- | include service signature (or '0' if it is absent), based on protocol version serviceAuth :: Bool, -- | JSON-encoded ServerPublicInfo from handshake, present when server version >= serverInfoSMPVersion - serverInfoBytes :: Maybe ByteString + serverInfo :: Maybe (Either String ServerPublicInfo) } data THandleAuth (p :: TransportPeer) where @@ -520,7 +522,7 @@ data SMPServerHandshake = SMPServerHandshake -- todo C.PublicKeyX25519 authPubKey :: CertChainPubKey, -- | optional server public information (JSON-encoded ServerPublicInfo), sent when version >= serverInfoSMPVersion - serverInfo :: Maybe ByteString + serverInfoBytes :: Maybe ByteString } -- This is the third handshake message that SMP server sends to services @@ -610,14 +612,14 @@ 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, serverInfo} = + smpEncode SMPServerHandshake {smpVersionRange, sessionId, authPubKey, serverInfoBytes} = smpEncode (smpVersionRange, sessionId, authPubKey) <> info where - info = ifHasServerInfo (maxVersion smpVersionRange) (smpEncode (Large <$> serverInfo)) "" + info = ifHasServerInfo (maxVersion smpVersionRange) (smpEncode (Large <$> serverInfoBytes)) "" smpP = do (smpVersionRange, sessionId, authPubKey) <- smpP - serverInfo <- ifHasServerInfo (maxVersion smpVersionRange) ((fmap unLarge <$> smpP) <|> pure Nothing) (pure Nothing) - pure SMPServerHandshake {smpVersionRange, sessionId, authPubKey, serverInfo} + serverInfoBytes <- ifHasServerInfo (maxVersion smpVersionRange) (unLarge <$$> smpP) (pure Nothing) + pure SMPServerHandshake {smpVersionRange, sessionId, authPubKey, serverInfoBytes} -- newtype for CertificateChain and a session key signed with this certificate data CertChainPubKey = CertChainPubKey @@ -728,9 +730,9 @@ smpServerHandshake :: Maybe ByteString -> (SMPServiceRole -> X.CertificateChain -> XV.Fingerprint -> ExceptT TransportError IO ServiceId) -> ExceptT TransportError IO (THandleSMP c 'TServer) -smpServerHandshake srvCert srvSignKey c (k, pk) kh smpVersionRange serverInfo getService = do +smpServerHandshake srvCert srvSignKey c (k, pk) kh smpVersionRange serverInfoBytes getService = do let sk = C.signX509 srvSignKey $ C.publicToX509 k - sendHandshake th $ SMPServerHandshake {sessionId, smpVersionRange, authPubKey = CertChainPubKey srvCert sk, serverInfo} + sendHandshake th $ SMPServerHandshake {sessionId, smpVersionRange, authPubKey = CertChainPubKey srvCert sk, serverInfoBytes} SMPClientHandshake {smpVersion = v, keyHash, authPubKey = k', proxyServer, clientService} <- getHandshake th when (keyHash /= kh) $ throwE $ TEHandshake IDENTITY case compatibleVRange' smpVersionRange v of @@ -763,7 +765,7 @@ smpServerHandshake srvCert srvSignKey c (k, pk) kh smpVersionRange serverInfo ge -- 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) smpVRange proxyServer serviceKeys_ = do - SMPServerHandshake {sessionId = sessId, smpVersionRange, authPubKey = certKey@(CertChainPubKey chain exact), serverInfo} <- getHandshake th + SMPServerHandshake {sessionId = sessId, smpVersionRange, authPubKey = certKey@(CertChainPubKey chain exact), serverInfoBytes} <- getHandshake th when (sessionId /= sessId) $ throwE TEBadSession case smpVersionRange `compatibleVRange` smpVRange of Just (Compatible vr) -> do @@ -782,7 +784,7 @@ smpClientHandshake c ks_ keyHash@(C.KeyHash kh) smpVRange proxyServer serviceKey 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 serverInfo + liftIO $ smpTHandleClient th v vr (snd <$> ks_) ck proxyServer service serverInfoBytes Nothing -> throwE TEVersion where th@THandle {params = THandleParams {sessionId}} = smpTHandle c @@ -838,7 +840,7 @@ smpTHandle_ th@THandle {params} v vr thAuth encryptBlock serverInfoBytes = thAuth, encryptBlock, serviceAuth = v >= serviceCertsSMPVersion, -- optional service signature will be encoded for all commands and responses - serverInfoBytes + serverInfo = J.eitherDecodeStrict' <$> serverInfoBytes } in (th :: THandleSMP c p) {params = params'} @@ -877,7 +879,7 @@ smpTHandle c = THandle {connection = c, params} implySessId = True, encryptBlock = Nothing, serviceAuth = False, - serverInfoBytes = Nothing + serverInfo = Nothing } $(J.deriveJSON (sumTypeJSON id) ''HandshakeError) diff --git a/tests/AgentTests/EqInstances.hs b/tests/AgentTests/EqInstances.hs index cdfb3406b..1bb72efe7 100644 --- a/tests/AgentTests/EqInstances.hs +++ b/tests/AgentTests/EqInstances.hs @@ -8,6 +8,7 @@ import Data.Type.Equality import Simplex.Messaging.Agent.Protocol (ABinaryConnectionRequestUri (..), AMessage (..), AMessageReceipt (..), AgentMessage (..), APrivHeader (..), ShortLinkCreds (..)) import Simplex.Messaging.Agent.Store import Simplex.Messaging.Client (ProxiedRelay (..)) +import Simplex.Messaging.Server.Information instance (Eq rq, Eq sq) => Eq (SomeConn' rq sq) where SomeConn d c == SomeConn d' c' = case testEquality d d' of @@ -46,3 +47,15 @@ deriving instance Eq AMessageReceipt deriving instance Eq AMessage deriving instance Eq AgentMessage + +deriving instance Eq Entity + +deriving instance Eq HostingType + +deriving instance Eq PGPKey + +deriving instance Eq ServerConditions + +deriving instance Eq ServerContactAddress + +deriving instance Eq ServerPublicInfo diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index f02010c71..8f1b29340 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -105,6 +105,7 @@ import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Protocol.Types import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..), ServerStoreCfg (..), StorePaths (..)) import Simplex.Messaging.Server.Expiration +import Simplex.Messaging.Server.Information (ServerPublicInfo (..)) import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) import Simplex.Messaging.Server.QueueStore.QueueInfo import Simplex.Messaging.Server.StoreLog (StoreLogRecord (..)) @@ -561,17 +562,17 @@ functionalAPITests ps = do it "auth both " $ testBasicAuth ps True (Nothing, v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 2 it "auth, disabled" $ testBasicAuth ps False (Nothing, v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0 describe "SMP server test via agent API" $ do - it "should pass without basic auth" $ testSMPServerConnectionTest ps Nothing (noAuthSrv testSMPServer2) `shouldReturn` Nothing + it "should pass without basic auth" $ testSMPServerConnectionTest ps Nothing (noAuthSrv testSMPServer2) `shouldReturn` Right (Just (Right testServerInformation)) let srv1 = testSMPServer2 {keyHash = "1234"} it "should fail with incorrect fingerprint" $ do - testSMPServerConnectionTest ps Nothing (noAuthSrv srv1) `shouldReturn` Just (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) $ NETWORK NEUnknownCAError) + testSMPServerConnectionTest ps Nothing (noAuthSrv srv1) `shouldReturn` Left (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) $ NETWORK NEUnknownCAError) describe "server with password" $ do let auth = Just "abcd" srv = ProtoServerWithAuth testSMPServer2 - authErr = Just (ProtocolTestFailure TSCreateQueue $ SMP (B.unpack $ strEncode testSMPServer2) AUTH) - it "should pass with correct password" $ testSMPServerConnectionTest ps auth (srv auth) `shouldReturn` Nothing - it "should fail without password" $ testSMPServerConnectionTest ps auth (srv Nothing) `shouldReturn` authErr - it "should fail with incorrect password" $ testSMPServerConnectionTest ps auth (srv $ Just "wrong") `shouldReturn` authErr + authErr = ProtocolTestFailure TSCreateQueue $ SMP (B.unpack $ strEncode testSMPServer2) AUTH + it "should pass with correct password" $ testSMPServerConnectionTest ps auth (srv auth) `shouldReturn` Right (Just (Right testServerInformation)) + it "should fail without password" $ testSMPServerConnectionTest ps auth (srv Nothing) `shouldReturn` Left authErr + it "should fail with incorrect password" $ testSMPServerConnectionTest ps auth (srv $ Just "wrong") `shouldReturn` Left authErr describe "getRatchetAdHash" $ it "should return the same data for both peers" $ withSmpServer ps testRatchetAdHash @@ -3921,14 +3922,28 @@ testCreateQueueAuth clnt1 clnt2 sqSecured baseId = do sndAuthAlg = C.AuthAlg C.SX25519 in getSMPAgentClient' clientId agentCfg {smpCfg, sndAuthAlg} servers db -testSMPServerConnectionTest :: (ASrvTransport, AStoreType) -> Maybe BasicAuth -> SMPServerWithAuth -> IO (Maybe ProtocolTestFailure) +testSMPServerConnectionTest :: (ASrvTransport, AStoreType) -> Maybe BasicAuth -> SMPServerWithAuth -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo))) testSMPServerConnectionTest (t, msType) newQueueBasicAuth srv = withSmpServerConfigOn t cfg' testPort2 $ \_ -> do -- initially passed server is not running withAgent 1 agentCfg initAgentServers testDB $ \a -> - either Just (const Nothing) <$> testProtocolServer a NRMInteractive 1 srv + testProtocolServer a NRMInteractive 1 srv where - cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {newQueueBasicAuth} + cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {newQueueBasicAuth, information = Just testServerInformation} + +testServerInformation :: ServerPublicInfo +testServerInformation = + ServerPublicInfo + { sourceCode = "https://github.com/simplex-chat/simplexmq", + usageConditions = Nothing, + operator = Nothing, + website = Nothing, + adminContacts = Nothing, + complaintsContacts = Nothing, + hosting = Nothing, + hostingType = Nothing, + serverCountry = Nothing + } testRatchetAdHash :: HasCallStack => IO () testRatchetAdHash = diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index b354289af..ed6455deb 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -82,6 +82,7 @@ import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Protocol (ErrorType (AUTH), NetworkError (..), MsgFlags (MsgFlags), NMsgMeta (..), NtfServer, ProtocolServer (..), SMPMsgMeta (..), SubscriptionMode (..)) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..)) +import Simplex.Messaging.Server.Information (ServerPublicInfo (..)) import Simplex.Messaging.Transport (ASrvTransport) import Simplex.Messaging.Transport.Server (TransportServerConfig (..)) import System.Process (callCommand) @@ -134,10 +135,10 @@ notificationTests ps@(t, _) = do withAPNSMockServer $ \apns -> testNtfTokenReRegisterInvalidOnCheck t apns describe "notification server tests" $ do - it "should pass" $ testRunNTFServerTests t testNtfServer `shouldReturn` Nothing + it "should pass" $ testRunNTFServerTests t testNtfServer `shouldReturn` Right Nothing let srv1 = testNtfServer {keyHash = "1234"} it "should fail with incorrect fingerprint" $ do - testRunNTFServerTests t srv1 `shouldReturn` Just (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) $ NETWORK NEUnknownCAError) + testRunNTFServerTests t srv1 `shouldReturn` Left (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) $ NETWORK NEUnknownCAError) describe "Managing notification subscriptions" $ do describe "should create notification subscription for existing connection" $ testNtfMatrix ps testNotificationSubscriptionExistingConnection @@ -536,11 +537,11 @@ testNtfTokenReRegisterInvalidOnCheck t apns = do NTActive <- checkNtfToken a tkn1 pure () -testRunNTFServerTests :: ASrvTransport -> NtfServer -> IO (Maybe ProtocolTestFailure) +testRunNTFServerTests :: ASrvTransport -> NtfServer -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo))) testRunNTFServerTests t srv = withNtfServer t $ withAgent 1 agentCfg initAgentServers testDB $ \a -> - either Just (const Nothing) <$> testProtocolServer a NRMInteractive 1 (ProtoServerWithAuth srv 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 4c28c5b03..960c2113e 100644 --- a/tests/CoreTests/BatchingTests.hs +++ b/tests/CoreTests/BatchingTests.hs @@ -248,7 +248,7 @@ testTHandleParams sessionId = implySessId = True, encryptBlock = Nothing, serviceAuth = True, - serverInfoBytes = Nothing + serverInfo = Nothing } testTHandleAuth :: TVar ChaChaDRG -> C.APublicAuthKey -> IO (Maybe (THandleAuth 'TClient)) diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index 459822fe8..34da3d125 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -41,6 +41,7 @@ import qualified Simplex.Messaging.Crypto.File as CF import Simplex.Messaging.Encoding.String (StrEncoding (..)) import Simplex.Messaging.Protocol (BasicAuth, NetworkError (..), ProtoServerWithAuth (..), ProtocolServer (..), XFTPServerWithAuth) import Simplex.Messaging.Server.Expiration (ExpirationConfig (..)) +import Simplex.Messaging.Server.Information (ServerPublicInfo) import Simplex.Messaging.Util (tshow) import System.Directory (doesDirectoryExist, doesFileExist, getFileSize, listDirectory, removeFile) import System.FilePath (()) @@ -82,24 +83,24 @@ xftpAgentTests = it "if file is expired on server, should report error and continue receiving next file" testXFTPAgentExpiredOnServer it "should request additional recipient IDs when number of recipients exceeds maximum per request" testXFTPAgentRequestAdditionalRecipientIDs describe "XFTP server test via agent API" $ do - it "should pass without basic auth" $ \_ -> testXFTPServerTest Nothing (noAuthSrv testXFTPServer2) `shouldReturn` Nothing + it "should pass without basic auth" $ \_ -> testXFTPServerTest Nothing (noAuthSrv testXFTPServer2) `shouldReturn` Right Nothing let srv1 = testXFTPServer2 {keyHash = "1234"} it "should fail with incorrect fingerprint" $ \_ -> do - testXFTPServerTest Nothing (noAuthSrv srv1) `shouldReturn` Just (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) $ NETWORK NEUnknownCAError) + testXFTPServerTest Nothing (noAuthSrv srv1) `shouldReturn` Left (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) $ NETWORK NEUnknownCAError) describe "server with password" $ do let auth = Just "abcd" srv = ProtoServerWithAuth testXFTPServer2 - authErr = Just (ProtocolTestFailure TSCreateFile $ XFTP (B.unpack $ strEncode testXFTPServer2) AUTH) - it "should pass with correct password" $ \_ -> testXFTPServerTest auth (srv auth) `shouldReturn` Nothing - it "should fail without password" $ \_ -> testXFTPServerTest auth (srv Nothing) `shouldReturn` authErr - it "should fail with incorrect password" $ \_ -> testXFTPServerTest auth (srv $ Just "wrong") `shouldReturn` authErr + authErr = ProtocolTestFailure TSCreateFile $ XFTP (B.unpack $ strEncode testXFTPServer2) AUTH + it "should pass with correct password" $ \_ -> testXFTPServerTest auth (srv auth) `shouldReturn` Right Nothing + it "should fail without password" $ \_ -> testXFTPServerTest auth (srv Nothing) `shouldReturn` Left authErr + it "should fail with incorrect password" $ \_ -> testXFTPServerTest auth (srv $ Just "wrong") `shouldReturn` Left authErr -testXFTPServerTest :: HasCallStack => Maybe BasicAuth -> XFTPServerWithAuth -> IO (Maybe ProtocolTestFailure) +testXFTPServerTest :: HasCallStack => Maybe BasicAuth -> XFTPServerWithAuth -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo))) testXFTPServerTest newFileBasicAuth srv = withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2} $ \_ -> -- initially passed server is not running withAgent 1 agentCfg initAgentServers testDB $ \a -> - either Just (const Nothing) <$> testProtocolServer a NRMInteractive 1 srv + testProtocolServer a NRMInteractive 1 srv rfProgress :: forall m. (HasCallStack, MonadIO m, MonadFail m) => AgentClient -> Int64 -> m () rfProgress c expected = loop 0 @@ -680,9 +681,3 @@ testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer $ do void $ testReceive rcp (rfds !! 99) filePath void $ testReceive rcp (rfds !! 299) filePath void $ testReceive rcp (rfds !! 499) filePath - -testXFTPServerTest_ :: HasCallStack => XFTPServerWithAuth -> IO (Maybe ProtocolTestFailure) -testXFTPServerTest_ srv = - -- initially passed server is not running - withAgent 1 agentCfg initAgentServers testDB $ \a -> - either Just (const Nothing) <$> testProtocolServer a NRMInteractive 1 srv