From 07eaf9157bdce58de161e3618e03ccb8acff24bf Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sun, 25 May 2025 17:03:02 +0100 Subject: [PATCH] smp server: allow getting and deleting short links for the old contact queues (#1549) * smp server: allow getting and deleting short links for the old contact queues * fix verifaction of legacy contact queues * test --- src/Simplex/Messaging/Server.hs | 34 ++++++----- .../Messaging/Server/QueueStore/Postgres.hs | 7 ++- tests/AgentTests/FunctionalAPITests.hs | 59 ++++++++++++++++++- tests/AgentTests/NotificationTests.hs | 13 +--- tests/SMPClient.hs | 6 +- 5 files changed, 85 insertions(+), 34 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 755548ad6..af5f445a5 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -1049,7 +1049,7 @@ verifyTransmission ms auth_ tAuth authorized queueId cmd = Cmd SSender PING -> pure $ VRVerified Nothing Cmd SSender RFWD {} -> pure $ VRVerified Nothing Cmd SSenderLink (LKEY k) -> verifySecure SSenderLink k - Cmd SSenderLink LGET -> verifyQueue (\q -> if isContact (snd q) then VRVerified (Just q) else VRFailed) <$> get SSenderLink + Cmd SSenderLink LGET -> verifyQueue (\q -> if isContactQueue (snd q) then VRVerified (Just q) else VRFailed) <$> get SSenderLink -- NSUB will not be accepted without authorization Cmd SNotifier NSUB -> verifyQueue (\q -> maybe dummyVerify (\n -> Just q `verifiedWith` notifierKey n) (notifier $ snd q)) <$> get SNotifier Cmd SProxiedClient _ -> pure $ VRVerified Nothing @@ -1067,12 +1067,15 @@ verifyTransmission ms auth_ tAuth authorized queueId cmd = allowedKey k = \case QueueRec {queueMode = Just QMMessaging, senderKey} -> maybe True (k ==) senderKey _ -> False - isContact = \case - QueueRec {queueMode = Just QMContact} -> True - _ -> False get :: DirectParty p => SParty p -> M (Either ErrorType (StoreQueue s, QueueRec)) get party = liftIO $ getQueueRec ms party queueId +isContactQueue :: QueueRec -> Bool +isContactQueue QueueRec {queueMode, senderKey} = case queueMode of + Just QMMessaging -> False + Just QMContact -> True + Nothing -> isNothing senderKey -- for backward compatibility with pre-SKEY contact addresses + verifyCmdAuthorization :: Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> C.APublicAuthKey -> Bool verifyCmdAuthorization auth_ tAuth authorized key = maybe False (verify key) tAuth where @@ -1231,7 +1234,7 @@ client RFWD encBlock -> (corrId, NoEntity,) <$> processForwardedCommand encBlock Cmd SSenderLink command -> Just <$> case command of LKEY k -> withQueue $ \q qr -> checkMode QMMessaging qr $ secureQueue_ q k $>> getQueueLink_ q qr - LGET -> withQueue $ \q qr -> checkMode QMContact qr $ getQueueLink_ q qr + LGET -> withQueue $ \q qr -> checkContact qr $ getQueueLink_ q qr Cmd SNotifier NSUB -> Just <$> subscribeNotifications Cmd SRecipient command -> Just <$> case command of @@ -1247,17 +1250,11 @@ client KEY sKey -> withQueue $ \q _ -> either err (corrId,entId,) <$> secureQueue_ q sKey RKEY rKeys -> withQueue $ \q qr -> checkMode QMContact qr $ OK <$$ liftIO (updateKeys (queueStore ms) q rKeys) LSET lnkId d -> - withQueue $ \q QueueRec {queueMode, senderKey, queueData} -> - liftIO $ either err (corrId,entId,) - -- this check allows adding link data to contact addresses created prior to SKEY, - -- using `queueMode == Just QMContact` would prevent it, they have queueMode `Nothing`. - <$> if queueMode /= Just QMMessaging && isNothing senderKey - then case queueData of - Just (lnkId', _) | lnkId' /= lnkId -> pure $ Left AUTH - _ -> OK <$$ addQueueLinkData (queueStore ms) q lnkId d - else pure $ Left AUTH + withQueue $ \q qr -> checkContact qr $ liftIO $ case queueData qr of + Just (lnkId', _) | lnkId' /= lnkId -> pure $ Left AUTH + _ -> OK <$$ addQueueLinkData (queueStore ms) q lnkId d LDEL -> - withQueue $ \q qr -> checkMode QMContact qr $ liftIO $ case queueData qr of + withQueue $ \q qr -> checkContact qr $ liftIO $ case queueData qr of Just _ -> OK <$$ deleteQueueLinkData (queueStore ms) q Nothing -> pure $ Right OK NKEY nKey dhKey -> withQueue $ \q _ -> addQueueNotifier_ q nKey dhKey @@ -1327,6 +1324,13 @@ client pure $ IDS QIK {rcvId, sndId, rcvPublicDhKey, queueMode, linkId = fst <$> queueData} -- , serverNtfCreds = snd <$> ntf (corrId,entId,) <$> tryCreate (3 :: Int) + -- this check allows to support contact queues created prior to SKEY, + -- using `queueMode == Just QMContact` would prevent it, as they have queueMode `Nothing`. + checkContact :: QueueRec -> M (Either ErrorType BrokerMsg) -> M (Transmission BrokerMsg) + checkContact qr a = + either err (corrId,entId,) + <$> if isContactQueue qr then a else pure $ Left AUTH + checkMode :: QueueMode -> QueueRec -> M (Either ErrorType BrokerMsg) -> M (Transmission BrokerMsg) checkMode qm QueueRec {queueMode} a = either err (corrId,entId,) diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs index 38158313d..7d2107f5a 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs @@ -25,6 +25,7 @@ module Simplex.Messaging.Server.QueueStore.Postgres foldQueueRecs, handleDuplicate, withLog_, + withDB', ) where @@ -138,7 +139,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where db [sql| SELECT - (SELECT COUNT(1) FROM msg_queues WHERE deleted_at IS NULL) AS queue_count, + (SELECT COUNT(1) FROM msg_queues WHERE deleted_at IS NULL) AS queue_count, (SELECT COUNT(1) FROM msg_queues WHERE deleted_at IS NULL AND notifier_id IS NOT NULL) AS notifier_count |] pure QueueCounts {queueCount, notifierCount} @@ -221,7 +222,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where _ -> throwE AUTH addQueueLinkData :: PostgresQueueStore q -> q -> LinkId -> QueueLinkData -> IO (Either ErrorType ()) - addQueueLinkData st sq lnkId d = + addQueueLinkData st sq lnkId d = withQueueRec sq "addQueueLinkData" $ \q -> case queueData q of Nothing -> addLink q $ \db -> DB.execute db qry (d :. (lnkId, rId)) @@ -335,7 +336,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where unblockQueue st sq = setStatusDB "unblockQueue" st sq EntityActive $ withLog "unblockQueue" st (`logUnblockQueue` recipientId sq) - + updateQueueTime :: PostgresQueueStore q -> q -> RoundedSystemTime -> IO (Either ErrorType QueueRec) updateQueueTime st sq t = withQueueRec sq "updateQueueTime" $ \q@QueueRec {updatedAt} -> diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 8c5bfec3f..91671ea2f 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -71,18 +71,20 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.Map as M import Data.Maybe (isJust, isNothing) import qualified Data.Set as S +import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1) +import qualified Data.Text.IO as T import Data.Time.Clock (diffUTCTime, getCurrentTime) import Data.Time.Clock.System (SystemTime (..), getSystemTime) import Data.Type.Equality (testEquality, (:~:) (Refl)) import Data.Word (Word16) import GHC.Stack (withFrozenCallStack) import SMPAgentClient -import SMPClient (cfgJ2QS, cfgMS, prevRange, prevVersion, proxyCfgJ2QS, proxyCfgMS, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServers2, withSmpServerConfigOn, withSmpServerProxy, withSmpServersProxy2, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) +import SMPClient import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) import qualified Simplex.Messaging.Agent as A import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), ServerQueueInfo (..), UserNetworkInfo (..), UserNetworkType (..), waitForUserNetwork) -import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), createAgentStore) +import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), Env (..), InitialAgentServers (..), createAgentStore) import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, REQ, SENT) import qualified Simplex.Messaging.Agent.Protocol as A import Simplex.Messaging.Agent.Store.Common (DBStore (..), withTransaction) @@ -115,6 +117,15 @@ import XFTPClient (testXFTPServer) #if defined(dbPostgres) import Fixtures #endif +#if defined(dbServerPostgres) +import qualified Database.PostgreSQL.Simple as PSQL +import Simplex.Messaging.Agent.Store (Connection (..), StoredRcvQueue (..), SomeConn (..)) +import Simplex.Messaging.Agent.Store.AgentStore (getConn) +import Simplex.Messaging.Server.MsgStore.Journal (JournalQueue) +import Simplex.Messaging.Server.MsgStore.Types (QSType (..)) +import Simplex.Messaging.Server.QueueStore.Postgres +import Simplex.Messaging.Server.QueueStore.Types (QueueStoreClass (..)) +#endif type AEntityTransmission e = (ACorrId, ConnId, AEvent e) @@ -320,6 +331,7 @@ functionalAPITests ps = do it "should get 1-time link data after restart" $ testInviationShortLinkRestart ps it "should connect via contact short link after restart" $ testContactShortLinkRestart ps it "should connect via added contact short link after restart" $ testAddContactShortLinkRestart ps + it "should create and get short links with the old contact queues" $ testOldContactQueueShortLink ps describe "Message delivery" $ do describe "update connection agent version on received messages" $ do it "should increase if compatible, shouldn'ps decrease" $ @@ -1307,6 +1319,49 @@ testAddContactShortLinkRestart ps = withAgentClients2 $ \a b -> do connReq4 `shouldBe` connReq linkUserData updatedConnData' `shouldBe` updatedData +testOldContactQueueShortLink :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testOldContactQueueShortLink ps@(_, msType) = withAgentClients2 $ \a b -> do + (contactId, CCLink connReq Nothing) <- withSmpServer ps $ runRight $ + A.createConnection a 1 True SCMContact Nothing Nothing CR.IKPQOn SMOnlyCreate + -- make it an "old" queue + let updateStoreLog f = replaceSubstringInFile f " queue_mode=C" "" + () <- case testServerStoreConfig msType of + ASSCfg _ _ (SSCMemory (Just StorePaths {storeLogFile})) -> updateStoreLog storeLogFile + ASSCfg _ _ (SSCMemoryJournal {storeLogFile}) -> updateStoreLog storeLogFile + ASSCfg _ _ (SSCDatabaseJournal {storeCfg}) -> do +#if defined(dbServerPostgres) + let AgentClient {agentEnv = Env {store}} = a + Right (SomeConn _ (ContactConnection _ RcvQueue {rcvId})) <- withTransaction store (`getConn` contactId) + st :: PostgresQueueStore (JournalQueue 'QSPostgres) <- newQueueStore @(JournalQueue 'QSPostgres) storeCfg + Right 1 <- runExceptT $ withDB' "test" st $ \db -> PSQL.execute db "UPDATE msg_queues SET queue_mode = ? WHERE recipient_id = ?" (Nothing :: Maybe QueueMode, rcvId) + closeQueueStore @(JournalQueue 'QSPostgres) st +#else + error "no dbServerPostgres flag" +#endif + _ -> pure () + + withSmpServer ps $ do + let userData = "some user data" + shortLink <- runRight $ setContactShortLink a contactId userData Nothing + (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink + strDecode (strEncode shortLink) `shouldBe` Right shortLink + connReq' `shouldBe` connReq + linkUserData connData' `shouldBe` userData + -- update user data + let updatedData = "updated user data" + shortLink' <- runRight $ setContactShortLink a contactId updatedData Nothing + shortLink' `shouldBe` shortLink + -- check updated + (connReq'', updatedConnData') <- runRight $ getConnShortLink b 1 shortLink + connReq'' `shouldBe` connReq + linkUserData updatedConnData' `shouldBe` updatedData + +replaceSubstringInFile :: FilePath -> T.Text -> T.Text -> IO () +replaceSubstringInFile filePath oldText newText = do + content <- T.readFile filePath + let newContent = T.replace oldText newText content + T.writeFile filePath newContent + testIncreaseConnAgentVersion :: HasCallStack => (ASrvTransport, AStoreType) -> IO () testIncreaseConnAgentVersion ps = do alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index 9a202d980..fecbf1af1 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -53,15 +53,12 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L -import Data.Text (Text) -import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) -import qualified Data.Text.IO as TIO import Data.Time.Clock.System (systemToUTCTime) import qualified Database.PostgreSQL.Simple as PSQL import NtfClient import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testNtfServer, testNtfServer2) -import SMPClient (cfgJ2QS, cfgMS, cfgVPrev, ntfTestPort, ntfTestPort2, serverStoreConfig, testPort, testPort2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) +import SMPClient (cfgJ2QS, cfgMS, cfgVPrev, ntfTestPort, ntfTestPort2, testServerStoreConfig, testPort, testPort2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore') import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers) @@ -195,7 +192,7 @@ testNtfMatrix ps@(_, msType) runTest = do runNtfTestCfg :: HasCallStack => (ASrvTransport, AStoreType) -> AgentMsgId -> ServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO () runNtfTestCfg (t, msType) baseId smpCfg ntfCfg aCfg bCfg runTest = do - let smpCfg' = smpCfg {serverStoreCfg = serverStoreConfig msType} + let smpCfg' = smpCfg {serverStoreCfg = testServerStoreConfig msType} withSmpServerConfigOn t smpCfg' testPort $ \_ -> withAPNSMockServer $ \apns -> withNtfServerCfg ntfCfg {transports = [(ntfTestPort, t, False)]} $ \_ -> @@ -498,12 +495,6 @@ testNtfTokenReRegisterInvalid t apns = do NTActive <- checkNtfToken a tkn1 pure () -replaceSubstringInFile :: FilePath -> Text -> Text -> IO () -replaceSubstringInFile filePath oldText newText = do - content <- TIO.readFile filePath - let newContent = T.replace oldText newText content - TIO.writeFile filePath newContent - testNtfTokenReRegisterInvalidOnCheck :: ASrvTransport -> APNSMockServer -> IO () testNtfTokenReRegisterInvalidOnCheck t apns = do tkn <- withNtfServer t $ do diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 6549e46dc..1d433e360 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -190,7 +190,7 @@ cfgMS msType = maxJournalStateLines = 2, queueIdBytes = 24, msgIdBytes = 24, - serverStoreCfg = serverStoreConfig msType, + serverStoreCfg = testServerStoreConfig msType, storeNtfsFile = Nothing, allowNewQueues = True, newQueueBasicAuth = Nothing, @@ -229,8 +229,8 @@ cfgMS msType = defaultStartOptions :: StartOptions defaultStartOptions = StartOptions {maintenance = False, compactLog = False, logLevel = testLogLevel, skipWarnings = False, confirmMigrations = MCYesUp} -serverStoreConfig :: AStoreType -> AServerStoreCfg -serverStoreConfig = serverStoreConfig_ False +testServerStoreConfig :: AStoreType -> AServerStoreCfg +testServerStoreConfig = serverStoreConfig_ False serverStoreConfig_ :: Bool -> AStoreType -> AServerStoreCfg serverStoreConfig_ useDbStoreLog = \case