dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-07-28 18:40:28 +00:00
Code Issues Packages Projects Releases Wiki Activity

server information

Browse Source
This commit is contained in:
Evgeny Poberezkin
2026-07-26 16:26:11 +01:00
parent df0c3ff108
commit a8c2ff60a2
15 changed files with 86 additions and 66 deletions
Download Patch File Download Diff File Expand all files Collapse all files
tests/AgentTests/EqInstances.hs
+13
View File
@@ -8,6 +8,7 @@ import Data.Type.Equality
import Simplex.Messaging.Agent.Protocol (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
@@ -31,3 +32,15 @@ deriving instance Eq ShortLinkCreds
deriving instance Show ProxiedRelay
deriving instance Eq ProxiedRelay
deriving instance Eq Entity
deriving instance Eq HostingType
deriving instance Eq PGPKey
deriving instance Eq ServerConditions
deriving instance Eq ServerContactAddress
deriving instance Eq ServerPublicInfo
tests/AgentTests/FunctionalAPITests.hs
+24 -9
View File
@@ -106,6 +106,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 (..))
@@ -534,17 +535,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
@@ -3635,14 +3636,28 @@ testCreateQueueAuth srvVersion clnt1 clnt2 sqSecured baseId = do
sndAuthAlg = if srvVersion >= authCmdsSMPVersion && clntVersion >= authCmdsSMPVersion then C.AuthAlg C.SX25519 else C.AuthAlg C.SEd25519
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 =
tests/AgentTests/NotificationTests.hs
+5 -4
View File
@@ -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
tests/CoreTests/BatchingTests.hs
+1 -1
View File
@@ -422,7 +422,7 @@ testTHandleParams v sessionId =
encryptBlock = Nothing,
batch = True,
serviceAuth = v >= serviceCertsSMPVersion,
serverInfoBytes = Nothing
serverInfo = Nothing
}
testTHandleAuth :: VersionSMP -> TVar ChaChaDRG -> C.APublicAuthKey -> IO (Maybe (THandleAuth 'TClient))
tests/XFTPAgent.hs
+9 -14
View File
@@ -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