core: update simplexmq (digest entity id); integrate xftp snd delete (#2183)

2026-03-30 14:15:55 +00:00 · 2023-04-14 15:32:12 +04:00
parent 4e01970d69
commit eb36f64676
6 changed files with 52 additions and 21 deletions
--- a/cabal.project
+++ b/cabal.project
@@ -7,7 +7,7 @@ constraints: zip +disable-bzip2 +disable-zstd
 source-repository-package
    type: git
    location: https://github.com/simplex-chat/simplexmq.git
-    tag: 5e39c479758c8646ba2f943575bf9dca4212a2fe
+    tag: 9f0b9a83d6dfbd926daf09883a81bf370544f48e

 source-repository-package
    type: git
--- a/scripts/nix/sha256map.nix
+++ b/scripts/nix/sha256map.nix
@@ -1,5 +1,5 @@
 {
-  "https://github.com/simplex-chat/simplexmq.git"."5e39c479758c8646ba2f943575bf9dca4212a2fe" = "00i6w13zzv05gamxbas3yspq241s917f0vg2mnnwvmvqq2x5f4jq";
+  "https://github.com/simplex-chat/simplexmq.git"."9f0b9a83d6dfbd926daf09883a81bf370544f48e" = "1pnsk2qzb10d3j7rxjqvbwirymky5d55b13y3a6mwj7qbgzzqcy9";
  "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
  "https://github.com/kazu-yamamoto/http2.git"."b5a1b7200cf5bc7044af34ba325284271f6dff25" = "0dqb50j57an64nf4qcf5vcz4xkd1vzvghvf8bk529c1k30r9nfzb";
  "https://github.com/simplex-chat/direct-sqlcipher.git"."34309410eb2069b029b8fc1872deb1e0db123294" = "0kwkmhyfsn2lixdlgl15smgr1h5gjk7fky6abzh8rng2h5ymnffd";
--- a/src/Simplex/Chat.hs
+++ b/src/Simplex/Chat.hs
@@ -60,7 +60,7 @@ import Simplex.Chat.Store
 import Simplex.Chat.Types
 import Simplex.FileTransfer.Client.Presets (defaultXFTPServers)
 import Simplex.FileTransfer.Description (ValidFileDescription, gb, kb, mb)
-import Simplex.FileTransfer.Protocol (FileParty (..))
+import Simplex.FileTransfer.Protocol (FileParty (..), FilePartyI)
 import Simplex.Messaging.Agent as Agent
 import Simplex.Messaging.Agent.Client (AgentStatsKey (..))
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), createAgentStore, defaultAgentConfig)
@@ -1961,7 +1961,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
 receiveViaCompleteFD :: ChatMonad m => User -> FileTransferId -> RcvFileDescr -> m ()
 receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete} =
  when fileDescrComplete $ do
-    rd <- parseRcvFileDescription fileDescrText
+    rd <- parseFileDescription fileDescrText
    aFileId <- withAgent $ \a -> xftpReceiveFile a (aUserId user) rd
    startReceivingFile user fileId
    withStore' $ \db -> updateRcvFileAgentId db fileId (Just $ AgentRcvFileId aFileId)
@@ -2335,9 +2335,9 @@ processAgentMsgSndFile _corrId aFileId msg =
              liftIO $ updateCIFileStatus db user fileId status
              getChatItemByFileId db user fileId
            toView $ CRSndFileProgressXFTP user ci ft sndProgress sndTotal
-        SFDONE _sndDescr rfds ->
+        SFDONE sndDescr rfds ->
          unless cancelled $ do
-            -- TODO save sender file description
+            withStore' $ \db -> setSndFTPrivateSndDescr db user fileId (fileDescrText sndDescr)
            ci@(AChatItem _ d cInfo _ci@ChatItem {meta = CIMeta {itemSharedMsgId = msgId_, itemDeleted}}) <-
              withStore $ \db -> getChatItemByFileId db user fileId
            case (msgId_, itemDeleted) of
@@ -2350,6 +2350,7 @@ processAgentMsgSndFile _corrId aFileId msg =
                    withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText extraRFDs)
                    msgDeliveryId <- sendFileDescription sft rfd sharedMsgId $ sendDirectContactMessage ct
                    withStore' $ \db -> updateSndFTDeliveryXFTP db sft msgDeliveryId
+                    agentXFTPDeleteSndFileInternal user aFileId
                  (_, _, SMDSnd, GroupChat g@GroupInfo {groupId}) -> do
                    ms <- withStore' $ \db -> getGroupMembers db user g
                    let rfdsMemberFTs = zip rfds $ memberFTs ms
@@ -2359,6 +2360,7 @@ processAgentMsgSndFile _corrId aFileId msg =
                    ci' <- withStore $ \db -> do
                      liftIO $ updateCIFileStatus db user fileId CIFSSndComplete
                      getChatItemByFileId db user fileId
+                    agentXFTPDeleteSndFileInternal user aFileId
                    toView $ CRSndFileCompleteXFTP user ci' ft
                    where
                      memberFTs :: [GroupMember] -> [(Connection, SndFileTransfer)]
@@ -2378,9 +2380,10 @@ processAgentMsgSndFile _corrId aFileId msg =
        SFERR e -> do
          -- update chat item status
          -- send status to view
-          -- agentXFTPDeleteSndFile
+          agentXFTPDeleteSndFileInternal user aFileId
          throwChatError $ CEXFTPSndFile fileId (AgentSndFileId aFileId) e
      where
+        fileDescrText :: FilePartyI p => ValidFileDescription p -> T.Text
        fileDescrText = safeDecodeUtf8 . strEncode
        sendFileDescription :: SndFileTransfer -> ValidFileDescription 'FRecipient -> SharedMsgId -> (ChatMsgEvent 'Json -> m (SndMessage, Int64)) -> m Int64
        sendFileDescription sft rfd msgId sendMsg = do
@@ -3810,8 +3813,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
          groupMsgToView g' m ci msgMeta
        createGroupFeatureChangedItems user cd CIRcvGroupFeature g g'

-parseRcvFileDescription :: ChatMonad m => Text -> m (ValidFileDescription 'FRecipient)
-parseRcvFileDescription =
+parseFileDescription :: (ChatMonad m, FilePartyI p) => Text -> m (ValidFileDescription p)
+parseFileDescription =
  liftEither . first (ChatError . CEInvalidFileDescription) . (strDecode . encodeUtf8)

 sendDirectFileInline :: ChatMonad m => Contact -> FileTransferMeta -> SharedMsgId -> m ()
@@ -3939,11 +3942,9 @@ cancelSndFile user FileTransferMeta {fileId, xftpSndFile} fts sendCancel = do
  case xftpSndFile of
    Nothing ->
      catMaybes <$> forM fts (\ft -> cancelSndFileTransfer user ft sendCancel)
-    Just _patternAgentSndFileId -> do
+    Just xsf -> do
      forM_ fts (\ft -> cancelSndFileTransfer user ft False)
-      -- TODO unless agentSndFileDeleted, do agentXFTPDeleteSndFile:
-      -- TODO   - with agent xftpDeleteSndFile
-      -- TODO   - with store setSndFTAgentDeleted
+      agentXFTPDeleteSndFileRemote user xsf fileId `catchError` (toView . CRChatError (Just user))
      pure []

 cancelSndFileTransfer :: ChatMonad m => User -> SndFileTransfer -> Bool -> m (Maybe ConnId)
@@ -4192,6 +4193,18 @@ agentXFTPDeleteRcvFile user aFileId fileId = do
  withAgent $ \a -> xftpDeleteRcvFile a (aUserId user) aFileId
  withStore' $ \db -> setRcvFTAgentDeleted db fileId

+agentXFTPDeleteSndFileInternal :: ChatMonad m => User -> SndFileId -> m ()
+agentXFTPDeleteSndFileInternal user aFileId = do
+  withAgent (\a -> xftpDeleteSndFileInternal a (aUserId user) aFileId) `catchError` (toView . CRChatError (Just user))
+
+agentXFTPDeleteSndFileRemote :: ChatMonad m => User -> XFTPSndFile -> FileTransferId -> m ()
+agentXFTPDeleteSndFileRemote user XFTPSndFile {agentSndFileId = AgentSndFileId aFileId, privateSndFileDescr, agentSndFileDeleted} fileId =
+  unless agentSndFileDeleted $
+    forM_ privateSndFileDescr $ \sfdText -> do
+      sd <- parseFileDescription sfdText
+      withAgent $ \a -> xftpDeleteSndFileRemote a (aUserId user) aFileId sd
+      withStore' $ \db -> setSndFTAgentDeleted db user fileId
+
 userProfileToSend :: User -> Maybe Profile -> Maybe Contact -> Profile
 userProfileToSend user@User {profile = p} incognitoProfile ct =
  let p' = fromMaybe (fromLocalProfile p) incognitoProfile
--- a/src/Simplex/Chat/Store.hs
+++ b/src/Simplex/Chat/Store.hs
@@ -159,9 +159,11 @@ module Simplex.Chat.Store
    getSndFTViaMsgDelivery,
    createSndFileTransferXFTP,
    createSndFTDescrXFTP,
+    setSndFTPrivateSndDescr,
    updateSndFTDescrXFTP,
    createExtraSndFTDescrs,
    updateSndFTDeliveryXFTP,
+    setSndFTAgentDeleted,
    getXFTPSndFileDBId,
    getXFTPRcvFileDBId,
    updateFileCancelled,
@@ -2789,7 +2791,7 @@ getSndFTViaMsgDelivery db User {userId} Connection {connId, agentConnId} agentMs
 createSndFileTransferXFTP :: DB.Connection -> User -> ContactOrGroup -> FilePath -> FileInvitation -> AgentSndFileId -> Integer -> IO FileTransferMeta
 createSndFileTransferXFTP db User {userId} contactOrGroup filePath FileInvitation {fileName, fileSize} agentSndFileId chunkSize = do
  currentTs <- getCurrentTime
-  let xftpSndFile = Just XFTPSndFile {agentSndFileId, privateSndFileDescr = Nothing}
+  let xftpSndFile = Just XFTPSndFile {agentSndFileId, privateSndFileDescr = Nothing, agentSndFileDeleted = False}
  DB.execute
    db
    "INSERT INTO files (contact_id, group_id, user_id, file_name, file_path, file_size, chunk_size, agent_snd_file_id, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)"
@@ -2811,6 +2813,14 @@ createSndFTDescrXFTP db User {userId} m Connection {connId} FileTransferMeta {fi
    "INSERT INTO snd_files (file_id, file_status, file_descr_id, group_member_id, connection_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)"
    (fileId, fileStatus, fileDescrId, groupMemberId' <$> m, connId, currentTs, currentTs)

+setSndFTPrivateSndDescr :: DB.Connection -> User -> FileTransferId -> Text -> IO ()
+setSndFTPrivateSndDescr db User {userId} fileId sfdText = do
+  currentTs <- getCurrentTime
+  DB.execute
+    db
+    "UPDATE files SET private_snd_file_descr = ?, updated_at = ? WHERE user_id = ? AND file_id = ?"
+    (sfdText, currentTs, userId, fileId)
+
 updateSndFTDescrXFTP :: DB.Connection -> User -> SndFileTransfer -> Text -> IO ()
 updateSndFTDescrXFTP db user@User {userId} sft@SndFileTransfer {fileId, fileDescrId} rfdText = do
  currentTs <- getCurrentTime
@@ -2841,6 +2851,14 @@ updateSndFTDeliveryXFTP db SndFileTransfer {connId, fileId, fileDescrId} msgDeli
    "UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_descr_id = ?"
    (msgDeliveryId, connId, fileId, fileDescrId)

+setSndFTAgentDeleted :: DB.Connection -> User -> FileTransferId -> IO ()
+setSndFTAgentDeleted db User {userId} fileId = do
+  currentTs <- getCurrentTime
+  DB.execute
+    db
+    "UPDATE files SET agent_snd_file_deleted = 1, updated_at = ? WHERE user_id = ? AND file_id = ?"
+    (currentTs, userId, fileId)
+
 getXFTPSndFileDBId :: DB.Connection -> User -> AgentSndFileId -> ExceptT StoreError IO FileTransferId
 getXFTPSndFileDBId db User {userId} aSndFileId =
  ExceptT . firstRow fromOnly (SESndFileNotFoundXFTP aSndFileId) $
@@ -3330,15 +3348,15 @@ getFileTransferMeta db User {userId} fileId =
    DB.query
      db
      [sql|
-        SELECT file_name, file_size, chunk_size, file_path, file_inline, agent_snd_file_id, private_snd_file_descr, cancelled
+        SELECT file_name, file_size, chunk_size, file_path, file_inline, agent_snd_file_id, agent_snd_file_deleted, private_snd_file_descr, cancelled
        FROM files
        WHERE user_id = ? AND file_id = ?
      |]
      (userId, fileId)
  where
-    fileTransferMeta :: (String, Integer, Integer, FilePath, Maybe InlineFileMode, Maybe AgentSndFileId, Maybe Text, Maybe Bool) -> FileTransferMeta
-    fileTransferMeta (fileName, fileSize, chunkSize, filePath, fileInline, aSndFileId_, privateSndFileDescr, cancelled_) =
-      let xftpSndFile = (\fId -> XFTPSndFile {agentSndFileId = fId, privateSndFileDescr}) <$> aSndFileId_
+    fileTransferMeta :: (String, Integer, Integer, FilePath, Maybe InlineFileMode, Maybe AgentSndFileId, Bool, Maybe Text, Maybe Bool) -> FileTransferMeta
+    fileTransferMeta (fileName, fileSize, chunkSize, filePath, fileInline, aSndFileId_, agentSndFileDeleted, privateSndFileDescr, cancelled_) =
+      let xftpSndFile = (\fId -> XFTPSndFile {agentSndFileId = fId, privateSndFileDescr, agentSndFileDeleted}) <$> aSndFileId_
       in FileTransferMeta {fileId, xftpSndFile, fileName, fileSize, chunkSize, filePath, fileInline, cancelled = fromMaybe False cancelled_}

 getContactFileInfo :: DB.Connection -> User -> Contact -> IO [CIFileInfo]
--- a/src/Simplex/Chat/Types.hs
+++ b/src/Simplex/Chat/Types.hs
@@ -1737,8 +1737,8 @@ instance ToJSON FileTransferMeta where toEncoding = J.genericToEncoding J.defaul

 data XFTPSndFile = XFTPSndFile
  { agentSndFileId :: AgentSndFileId,
-    privateSndFileDescr :: Maybe Text
-    -- TODO agentSndFileDeleted :: Bool
+    privateSndFileDescr :: Maybe Text,
+    agentSndFileDeleted :: Bool
  }
  deriving (Eq, Show, Generic)

--- a/stack.yaml
+++ b/stack.yaml
@@ -49,7 +49,7 @@ extra-deps:
  # - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561
  # - ../simplexmq
  - github: simplex-chat/simplexmq
-    commit: 5e39c479758c8646ba2f943575bf9dca4212a2fe
+    commit: 9f0b9a83d6dfbd926daf09883a81bf370544f48e
  - github: kazu-yamamoto/http2
    commit: b5a1b7200cf5bc7044af34ba325284271f6dff25
  # - ../direct-sqlcipher