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

Author: epoberezkin

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,)

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} ->

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

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

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