core: batch db operations for group leave and delete (#3807)
* core: batch db operations for group leave and delete * remove comment * batch delete files * cleanup * rename * use new agent api * refactor * refactor, catch error * refactor * update simplexmq --------- Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
This commit is contained in:
spaced4ndy
GitHub
parent
ec8ae9febe
commit
51a2e09714
@ -12,7 +12,7 @@ constraints: zip +disable-bzip2 +disable-zstd
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/simplex-chat/simplexmq.git
|
||||
tag: 0d843ea4ce1b26a25b55756bf86d1007629896c5
|
||||
tag: 050a921fbbdf21690cab7765bf6237fdc5a419cb
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
{
|
||||
"https://github.com/simplex-chat/simplexmq.git"."0d843ea4ce1b26a25b55756bf86d1007629896c5" = "0p3mw5kpqhxsjhairx7qaacv33hm11wmbax6jzv2w49nwkcpnbal";
|
||||
"https://github.com/simplex-chat/simplexmq.git"."050a921fbbdf21690cab7765bf6237fdc5a419cb" = "0bc8x3pv3l6wjcfx06yhyydf2amaw5jjax2wcbgbxzrhqz10xf1v";
|
||||
"https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
|
||||
"https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d";
|
||||
"https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl";
|
||||
|
||||
@ -939,7 +939,8 @@ processChatCommand' vr = \case
|
||||
ct <- withStore $ \db -> getContact db user chatId
|
||||
filesInfo <- withStore' $ \db -> getContactFileInfo db user ct
|
||||
withChatLock "deleteChat direct" . procCmd $ do
|
||||
deleteFilesAndConns user filesInfo
|
||||
cancelFilesInProgress user filesInfo
|
||||
deleteFilesLocally filesInfo
|
||||
when (contactReady ct && contactActive ct && notify) $
|
||||
void (sendDirectContactMessage ct XDirectDel) `catchChatError` const (pure ())
|
||||
contactConnIds <- map aConnId <$> withStore' (\db -> getContactConnections db userId ct)
|
||||
@ -962,7 +963,8 @@ processChatCommand' vr = \case
|
||||
unless canDelete $ throwChatError $ CEGroupUserRole gInfo GROwner
|
||||
filesInfo <- withStore' $ \db -> getGroupFileInfo db user gInfo
|
||||
withChatLock "deleteChat group" . procCmd $ do
|
||||
deleteFilesAndConns user filesInfo
|
||||
cancelFilesInProgress user filesInfo
|
||||
deleteFilesLocally filesInfo
|
||||
when (memberActive membership && isOwner) . void $ sendGroupMessage' user gInfo members XGrpDel
|
||||
deleteGroupLinkIfExists user gInfo
|
||||
deleteMembersConnections user members
|
||||
@ -973,37 +975,40 @@ processChatCommand' vr = \case
|
||||
withStore' $ \db -> deleteGroupItemsAndMembers db user gInfo members
|
||||
withStore' $ \db -> deleteGroup db user gInfo
|
||||
let contactIds = mapMaybe memberContactId members
|
||||
deleteAgentConnectionsAsync user . concat =<< mapM deleteUnusedContact contactIds
|
||||
(errs1, (errs2, connIds)) <- second unzip . partitionEithers <$> withStoreBatch (\db -> map (deleteUnusedContact db) contactIds)
|
||||
let errs = errs1 <> mapMaybe (fmap ChatErrorStore) errs2
|
||||
unless (null errs) $ toView $ CRChatErrors (Just user) errs
|
||||
deleteAgentConnectionsAsync user $ concat connIds
|
||||
pure $ CRGroupDeletedUser user gInfo
|
||||
where
|
||||
deleteUnusedContact :: ContactId -> m [ConnId]
|
||||
deleteUnusedContact contactId =
|
||||
(withStore (\db -> getContact db user contactId) >>= delete)
|
||||
`catchChatError` (\e -> toView (CRChatError (Just user) e) $> [])
|
||||
deleteUnusedContact :: DB.Connection -> ContactId -> IO (Either ChatError (Maybe StoreError, [ConnId]))
|
||||
deleteUnusedContact db contactId = runExceptT . withExceptT ChatErrorStore $ do
|
||||
ct <- getContact db user contactId
|
||||
ifM
|
||||
((directOrUsed ct ||) . isJust <$> liftIO (checkContactHasGroups db user ct))
|
||||
(pure (Nothing, []))
|
||||
(getConnections ct)
|
||||
where
|
||||
delete ct
|
||||
| directOrUsed ct = pure []
|
||||
| otherwise =
|
||||
withStore' (\db -> checkContactHasGroups db user ct) >>= \case
|
||||
Just _ -> pure []
|
||||
Nothing -> do
|
||||
conns <- withStore' $ \db -> getContactConnections db userId ct
|
||||
withStore (\db -> setContactDeleted db user ct)
|
||||
`catchChatError` (toView . CRChatError (Just user))
|
||||
pure $ map aConnId conns
|
||||
getConnections :: Contact -> ExceptT StoreError IO (Maybe StoreError, [ConnId])
|
||||
getConnections ct = do
|
||||
conns <- liftIO $ getContactConnections db userId ct
|
||||
e_ <- (setContactDeleted db user ct $> Nothing) `catchStoreError` (pure . Just)
|
||||
pure (e_, map aConnId conns)
|
||||
CTLocal -> pure $ chatCmdError (Just user) "not supported"
|
||||
CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
|
||||
APIClearChat (ChatRef cType chatId) -> withUser $ \user@User {userId} -> case cType of
|
||||
CTDirect -> do
|
||||
ct <- withStore $ \db -> getContact db user chatId
|
||||
filesInfo <- withStore' $ \db -> getContactFileInfo db user ct
|
||||
deleteFilesAndConns user filesInfo
|
||||
cancelFilesInProgress user filesInfo
|
||||
deleteFilesLocally filesInfo
|
||||
withStore' $ \db -> deleteContactCIs db user ct
|
||||
pure $ CRChatCleared user (AChatInfo SCTDirect $ DirectChat ct)
|
||||
CTGroup -> do
|
||||
gInfo <- withStore $ \db -> getGroupInfo db vr user chatId
|
||||
filesInfo <- withStore' $ \db -> getGroupFileInfo db user gInfo
|
||||
deleteFilesAndConns user filesInfo
|
||||
cancelFilesInProgress user filesInfo
|
||||
deleteFilesLocally filesInfo
|
||||
withStore' $ \db -> deleteGroupCIs db user gInfo
|
||||
membersToDelete <- withStore' $ \db -> getGroupMembersForExpiration db user gInfo
|
||||
forM_ membersToDelete $ \m -> withStore' $ \db -> deleteGroupMember db user m
|
||||
@ -1012,7 +1017,7 @@ processChatCommand' vr = \case
|
||||
nf <- withStore $ \db -> getNoteFolder db user chatId
|
||||
filesInfo <- withStore' $ \db -> getNoteFolderFileInfo db user nf
|
||||
withChatLock "clearChat local" . procCmd $ do
|
||||
mapM_ (deleteFile user) filesInfo
|
||||
deleteFilesLocally filesInfo
|
||||
withStore' $ \db -> deleteNoteFolderFiles db userId nf
|
||||
withStore' $ \db -> deleteNoteFolderCIs db user nf
|
||||
pure $ CRChatCleared user (AChatInfo SCTLocal $ LocalChat nf)
|
||||
@ -1697,7 +1702,9 @@ processChatCommand' vr = \case
|
||||
pure $ CRUserDeletedMember user gInfo m {memberStatus = GSMemRemoved}
|
||||
APILeaveGroup groupId -> withUser $ \user@User {userId} -> do
|
||||
Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db vr user groupId
|
||||
filesInfo <- withStore' $ \db -> getGroupFileInfo db user gInfo
|
||||
withChatLock "leaveGroup" . procCmd $ do
|
||||
cancelFilesInProgress user filesInfo
|
||||
(msg, _) <- sendGroupMessage' user gInfo members XGrpLeave
|
||||
ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent SGEUserLeft)
|
||||
toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci)
|
||||
@ -2351,7 +2358,8 @@ processChatCommand' vr = \case
|
||||
deleteChatUser :: User -> Bool -> m ChatResponse
|
||||
deleteChatUser user delSMPQueues = do
|
||||
filesInfo <- withStore' (`getUserFileInfo` user)
|
||||
forM_ filesInfo $ \fileInfo -> deleteFile user fileInfo
|
||||
cancelFilesInProgress user filesInfo
|
||||
deleteFilesLocally filesInfo
|
||||
withAgent $ \a -> deleteUser a (aUserId user) delSMPQueues
|
||||
withStore' (`deleteUserRecord` user)
|
||||
when (activeUser user) $ chatWriteVar currentUser Nothing
|
||||
@ -2559,50 +2567,72 @@ setAllExpireCIFlags b = do
|
||||
keys <- M.keys <$> readTVar expireFlags
|
||||
forM_ keys $ \k -> TM.insert k b expireFlags
|
||||
|
||||
deleteFilesAndConns :: ChatMonad m => User -> [CIFileInfo] -> m ()
|
||||
deleteFilesAndConns user filesInfo = do
|
||||
connIds <- mapM (deleteFile user) filesInfo
|
||||
deleteAgentConnectionsAsync user $ concat connIds
|
||||
|
||||
deleteFile :: ChatMonad m => User -> CIFileInfo -> m [ConnId]
|
||||
deleteFile user fileInfo = deleteFile' user fileInfo False
|
||||
|
||||
deleteFile' :: forall m. ChatMonad m => User -> CIFileInfo -> Bool -> m [ConnId]
|
||||
deleteFile' user ciFileInfo@CIFileInfo {filePath} sendCancel = do
|
||||
aConnIds <- cancelFile' user ciFileInfo sendCancel
|
||||
forM_ filePath $ \fPath ->
|
||||
deleteFileLocally fPath `catchChatError` (toView . CRChatError (Just user))
|
||||
pure aConnIds
|
||||
|
||||
deleteFileLocally :: forall m. ChatMonad m => FilePath -> m ()
|
||||
deleteFileLocally fPath =
|
||||
withFilesFolder $ \filesFolder -> liftIO $ do
|
||||
let fsFilePath = filesFolder </> fPath
|
||||
removeFile fsFilePath `catchAll` \_ ->
|
||||
removePathForcibly fsFilePath `catchAll_` pure ()
|
||||
cancelFilesInProgress :: forall m. ChatMonad m => User -> [CIFileInfo] -> m ()
|
||||
cancelFilesInProgress user filesInfo = do
|
||||
let filesInfo' = filter (not . fileEnded) filesInfo
|
||||
(sfs, rfs) <- splitFTTypes <$> withStoreBatch (\db -> map (getFT db) filesInfo')
|
||||
forM_ rfs $ \RcvFileTransfer {fileId} -> closeFileHandle fileId rcvFiles `catchChatError` \_ -> pure ()
|
||||
void . withStoreBatch' $ \db -> map (updateSndFileCancelled db) sfs
|
||||
void . withStoreBatch' $ \db -> map (updateRcvFileCancelled db) rfs
|
||||
let xsfIds = mapMaybe (\(FileTransferMeta {fileId, xftpSndFile}, _) -> (,fileId) <$> xftpSndFile) sfs
|
||||
xrfIds = mapMaybe (\RcvFileTransfer {fileId, xftpRcvFile} -> (,fileId) <$> xftpRcvFile) rfs
|
||||
agentXFTPDeleteSndFilesRemote user xsfIds
|
||||
agentXFTPDeleteRcvFiles xrfIds
|
||||
let smpSFConnIds = concatMap (\(ft, sfts) -> mapMaybe (smpSndFileConnId ft) sfts) sfs
|
||||
smpRFConnIds = mapMaybe smpRcvFileConnId rfs
|
||||
deleteAgentConnectionsAsync user smpSFConnIds
|
||||
deleteAgentConnectionsAsync user smpRFConnIds
|
||||
where
|
||||
fileEnded CIFileInfo {fileStatus} = case fileStatus of
|
||||
Just (AFS _ status) -> ciFileEnded status
|
||||
Nothing -> True
|
||||
getFT :: DB.Connection -> CIFileInfo -> IO (Either ChatError FileTransfer)
|
||||
getFT db CIFileInfo {fileId} = runExceptT . withExceptT ChatErrorStore $ getFileTransfer db user fileId
|
||||
updateSndFileCancelled :: DB.Connection -> (FileTransferMeta, [SndFileTransfer]) -> IO ()
|
||||
updateSndFileCancelled db (FileTransferMeta {fileId}, sfts) = do
|
||||
updateFileCancelled db user fileId CIFSSndCancelled
|
||||
forM_ sfts updateSndFTCancelled
|
||||
where
|
||||
updateSndFTCancelled :: SndFileTransfer -> IO ()
|
||||
updateSndFTCancelled ft = unless (sndFTEnded ft) $ do
|
||||
updateSndFileStatus db ft FSCancelled
|
||||
deleteSndFileChunks db ft
|
||||
updateRcvFileCancelled :: DB.Connection -> RcvFileTransfer -> IO ()
|
||||
updateRcvFileCancelled db ft@RcvFileTransfer {fileId} = do
|
||||
updateFileCancelled db user fileId CIFSRcvCancelled
|
||||
updateRcvFileStatus db fileId FSCancelled
|
||||
deleteRcvFileChunks db ft
|
||||
splitFTTypes :: [Either ChatError FileTransfer] -> ([(FileTransferMeta, [SndFileTransfer])], [RcvFileTransfer])
|
||||
splitFTTypes = foldr addFT ([], []) . rights
|
||||
where
|
||||
addFT f (sfs, rfs) = case f of
|
||||
FTSnd ft@FileTransferMeta {cancelled} sfts | not cancelled -> ((ft, sfts) : sfs, rfs)
|
||||
FTRcv ft@RcvFileTransfer {cancelled} | not cancelled -> (sfs, ft : rfs)
|
||||
_ -> (sfs, rfs)
|
||||
smpSndFileConnId :: FileTransferMeta -> SndFileTransfer -> Maybe ConnId
|
||||
smpSndFileConnId FileTransferMeta {xftpSndFile} sft@SndFileTransfer {agentConnId = AgentConnId acId, fileInline}
|
||||
| isNothing xftpSndFile && isNothing fileInline && not (sndFTEnded sft) = Just acId
|
||||
| otherwise = Nothing
|
||||
smpRcvFileConnId :: RcvFileTransfer -> Maybe ConnId
|
||||
smpRcvFileConnId ft@RcvFileTransfer {xftpRcvFile, rcvFileInline}
|
||||
| isNothing xftpRcvFile && isNothing rcvFileInline = liveRcvFileTransferConnId ft
|
||||
| otherwise = Nothing
|
||||
sndFTEnded SndFileTransfer {fileStatus} = fileStatus == FSCancelled || fileStatus == FSComplete
|
||||
|
||||
deleteFilesLocally :: forall m. ChatMonad m => [CIFileInfo] -> m ()
|
||||
deleteFilesLocally files =
|
||||
withFilesFolder $ \filesFolder ->
|
||||
liftIO . forM_ files $ \CIFileInfo {filePath} ->
|
||||
mapM_ (delete . (filesFolder </>)) filePath
|
||||
where
|
||||
delete :: FilePath -> IO ()
|
||||
delete fPath =
|
||||
removeFile fPath `catchAll` \_ ->
|
||||
removePathForcibly fPath `catchAll_` pure ()
|
||||
-- perform an action only if filesFolder is set (i.e. on mobile devices)
|
||||
withFilesFolder :: (FilePath -> m ()) -> m ()
|
||||
withFilesFolder action = asks filesFolder >>= readTVarIO >>= mapM_ action
|
||||
|
||||
cancelFile' :: forall m. ChatMonad m => User -> CIFileInfo -> Bool -> m [ConnId]
|
||||
cancelFile' user CIFileInfo {fileId, fileStatus} sendCancel =
|
||||
case fileStatus of
|
||||
Just fStatus -> cancel' fStatus `catchChatError` (\e -> toView (CRChatError (Just user) e) $> [])
|
||||
Nothing -> pure []
|
||||
where
|
||||
cancel' :: ACIFileStatus -> m [ConnId]
|
||||
cancel' (AFS dir status) =
|
||||
if ciFileEnded status
|
||||
then pure []
|
||||
else case dir of
|
||||
SMDSnd -> do
|
||||
(ftm@FileTransferMeta {cancelled}, fts) <- withStore (\db -> getSndFileTransfer db user fileId)
|
||||
if cancelled then pure [] else cancelSndFile user ftm fts sendCancel
|
||||
SMDRcv -> do
|
||||
ft@RcvFileTransfer {cancelled} <- withStore (\db -> getRcvFileTransfer db user fileId)
|
||||
if cancelled then pure [] else maybeToList <$> cancelRcvFileTransfer user ft
|
||||
|
||||
updateCallItemStatus :: ChatMonad m => User -> Contact -> Call -> WebRTCCallStatus -> Maybe MessageId -> m ()
|
||||
updateCallItemStatus user ct Call {chatItemId} receivedStatus msgId_ = do
|
||||
aciContent_ <- callStatusItemContent user ct chatItemId receivedStatus
|
||||
@ -3166,13 +3196,15 @@ expireChatItems user@User {userId} ttl sync = do
|
||||
processContact expirationDate ct = do
|
||||
waitChatStartedAndActivated
|
||||
filesInfo <- withStoreCtx' (Just "processContact, getContactExpiredFileInfo") $ \db -> getContactExpiredFileInfo db user ct expirationDate
|
||||
deleteFilesAndConns user filesInfo
|
||||
cancelFilesInProgress user filesInfo
|
||||
deleteFilesLocally filesInfo
|
||||
withStoreCtx' (Just "processContact, deleteContactExpiredCIs") $ \db -> deleteContactExpiredCIs db user ct expirationDate
|
||||
processGroup :: UTCTime -> UTCTime -> GroupInfo -> m ()
|
||||
processGroup expirationDate createdAtCutoff gInfo = do
|
||||
waitChatStartedAndActivated
|
||||
filesInfo <- withStoreCtx' (Just "processGroup, getGroupExpiredFileInfo") $ \db -> getGroupExpiredFileInfo db user gInfo expirationDate createdAtCutoff
|
||||
deleteFilesAndConns user filesInfo
|
||||
cancelFilesInProgress user filesInfo
|
||||
deleteFilesLocally filesInfo
|
||||
withStoreCtx' (Just "processGroup, deleteGroupExpiredCIs") $ \db -> deleteGroupExpiredCIs db user gInfo expirationDate createdAtCutoff
|
||||
membersToDelete <- withStoreCtx' (Just "processGroup, getGroupMembersForExpiration") $ \db -> getGroupMembersForExpiration db user gInfo
|
||||
forM_ membersToDelete $ \m -> withStoreCtx' (Just "processGroup, deleteGroupMember") $ \db -> deleteGroupMember db user m
|
||||
@ -5838,7 +5870,7 @@ deleteMembersConnections user members = do
|
||||
filter (\Connection {connStatus} -> connStatus /= ConnDeleted) $
|
||||
mapMaybe (\GroupMember {activeConn} -> activeConn) members
|
||||
deleteAgentConnectionsAsync user $ map aConnId memberConns
|
||||
forM_ memberConns $ \conn -> withStore' $ \db -> updateConnectionStatus db conn ConnDeleted
|
||||
void . withStoreBatch' $ \db -> map (\conn -> updateConnectionStatus db conn ConnDeleted) memberConns
|
||||
|
||||
deleteMemberConnection :: ChatMonad m => User -> GroupMember -> m ()
|
||||
deleteMemberConnection user GroupMember {activeConn} = do
|
||||
@ -6153,18 +6185,19 @@ deleteGroupCI user gInfo ci@ChatItem {file} byUser timed byGroupMember_ deletedT
|
||||
gItem = AChatItem SCTGroup msgDirection (GroupChat gInfo)
|
||||
|
||||
deleteLocalCI :: (ChatMonad m, MsgDirectionI d) => User -> NoteFolder -> ChatItem 'CTLocal d -> Bool -> Bool -> m ChatResponse
|
||||
deleteLocalCI user nf ci@ChatItem {file} byUser timed = do
|
||||
forM_ file $ \CIFile {fileSource} -> do
|
||||
forM_ (CF.filePath <$> fileSource) $ \fPath ->
|
||||
deleteFileLocally fPath `catchChatError` (toView . CRChatError (Just user))
|
||||
deleteLocalCI user nf ci@ChatItem {file = file_} byUser timed = do
|
||||
forM_ file_ $ \file -> do
|
||||
let filesInfo = [mkCIFileInfo file]
|
||||
deleteFilesLocally filesInfo
|
||||
withStore' $ \db -> deleteLocalChatItem db user nf ci
|
||||
pure $ CRChatItemDeleted user (AChatItem SCTLocal msgDirection (LocalChat nf) ci) Nothing byUser timed
|
||||
|
||||
deleteCIFile :: (ChatMonad m, MsgDirectionI d) => User -> Maybe (CIFile d) -> m ()
|
||||
deleteCIFile user file_ =
|
||||
forM_ file_ $ \file -> do
|
||||
fileAgentConnIds <- deleteFile' user (mkCIFileInfo file) True
|
||||
deleteAgentConnectionsAsync user fileAgentConnIds
|
||||
let filesInfo = [mkCIFileInfo file]
|
||||
cancelFilesInProgress user filesInfo
|
||||
deleteFilesLocally filesInfo
|
||||
|
||||
markDirectCIDeleted :: (ChatMonad m, MsgDirectionI d) => User -> Contact -> ChatItem 'CTDirect d -> MessageId -> Bool -> UTCTime -> m ChatResponse
|
||||
markDirectCIDeleted user ct ci@ChatItem {file} msgId byUser deletedTs = do
|
||||
@ -6185,8 +6218,8 @@ markGroupCIDeleted user gInfo ci@ChatItem {file} msgId byUser byGroupMember_ del
|
||||
cancelCIFile :: (ChatMonad m, MsgDirectionI d) => User -> Maybe (CIFile d) -> m ()
|
||||
cancelCIFile user file_ =
|
||||
forM_ file_ $ \file -> do
|
||||
fileAgentConnIds <- cancelFile' user (mkCIFileInfo file) True
|
||||
deleteAgentConnectionsAsync user fileAgentConnIds
|
||||
let filesInfo = [mkCIFileInfo file]
|
||||
cancelFilesInProgress user filesInfo
|
||||
|
||||
createAgentConnectionAsync :: forall m c. (ChatMonad m, ConnectionModeI c) => User -> CommandFunction -> Bool -> SConnectionMode c -> SubscriptionMode -> m (CommandId, ConnId)
|
||||
createAgentConnectionAsync user cmdFunction enableNtfs cMode subMode = do
|
||||
@ -6228,20 +6261,43 @@ agentXFTPDeleteRcvFile aFileId fileId = do
|
||||
withAgent (`xftpDeleteRcvFile` aFileId)
|
||||
withStore' $ \db -> setRcvFTAgentDeleted db fileId
|
||||
|
||||
agentXFTPDeleteSndFileRemote :: ChatMonad m => User -> XFTPSndFile -> FileTransferId -> m ()
|
||||
agentXFTPDeleteSndFileRemote user sndFile fileId = do
|
||||
-- the agent doesn't know about redirect, delete explicitly
|
||||
redirect_ <- withStore' $ \db -> lookupFileTransferRedirectMeta db user fileId
|
||||
forM_ redirect_ $ \FileTransferMeta {fileId = fileIdRedirect, xftpSndFile = sndFileRedirect_} ->
|
||||
mapM_ (handleError (const $ pure ()) . remove fileIdRedirect) sndFileRedirect_
|
||||
remove fileId sndFile
|
||||
agentXFTPDeleteRcvFiles :: ChatMonad m => [(XFTPRcvFile, FileTransferId)] -> m ()
|
||||
agentXFTPDeleteRcvFiles rcvFiles = do
|
||||
let rcvFiles' = filter (not . agentRcvFileDeleted . fst) rcvFiles
|
||||
rfIds = mapMaybe fileIds rcvFiles'
|
||||
withAgent $ \a -> xftpDeleteRcvFiles a (map fst rfIds)
|
||||
void . withStoreBatch' $ \db -> map (setRcvFTAgentDeleted db . snd) rfIds
|
||||
where
|
||||
remove fId XFTPSndFile {agentSndFileId = AgentSndFileId aFileId, privateSndFileDescr, agentSndFileDeleted} =
|
||||
unless agentSndFileDeleted $ do
|
||||
forM_ privateSndFileDescr $ \sfdText -> do
|
||||
sd <- parseFileDescription sfdText
|
||||
withAgent $ \a -> xftpDeleteSndFileRemote a (aUserId user) aFileId sd
|
||||
withStore' $ \db -> setSndFTAgentDeleted db user fId
|
||||
fileIds :: (XFTPRcvFile, FileTransferId) -> Maybe (RcvFileId, FileTransferId)
|
||||
fileIds (XFTPRcvFile {agentRcvFileId = Just (AgentRcvFileId aFileId)}, fileId) = Just (aFileId, fileId)
|
||||
fileIds _ = Nothing
|
||||
|
||||
agentXFTPDeleteSndFileRemote :: ChatMonad m => User -> XFTPSndFile -> FileTransferId -> m ()
|
||||
agentXFTPDeleteSndFileRemote user xsf fileId =
|
||||
agentXFTPDeleteSndFilesRemote user [(xsf, fileId)]
|
||||
|
||||
agentXFTPDeleteSndFilesRemote :: forall m. ChatMonad m => User -> [(XFTPSndFile, FileTransferId)] -> m ()
|
||||
agentXFTPDeleteSndFilesRemote user sndFiles = do
|
||||
(_errs, redirects) <- partitionEithers <$> withStoreBatch' (\db -> map (lookupFileTransferRedirectMeta db user . snd) sndFiles)
|
||||
let redirects' = mapMaybe mapRedirectMeta $ concat redirects
|
||||
sndFilesAll = redirects' <> sndFiles
|
||||
sndFilesAll' = filter (not . agentSndFileDeleted . fst) sndFilesAll
|
||||
sndFilesAll'' <- catMaybes <$> mapM sndFileDescr sndFilesAll'
|
||||
let sfs = map (\(XFTPSndFile {agentSndFileId = AgentSndFileId aFileId}, sfd, _) -> (aFileId, sfd)) sndFilesAll''
|
||||
withAgent $ \a -> xftpDeleteSndFilesRemote a (aUserId user) sfs
|
||||
void . withStoreBatch' $ \db -> map (setSndFTAgentDeleted db user . (\(_, _, fId) -> fId)) sndFilesAll''
|
||||
where
|
||||
mapRedirectMeta :: FileTransferMeta -> Maybe (XFTPSndFile, FileTransferId)
|
||||
mapRedirectMeta FileTransferMeta {fileId = fileId, xftpSndFile = Just sndFileRedirect} = Just (sndFileRedirect, fileId)
|
||||
mapRedirectMeta _ = Nothing
|
||||
sndFileDescr :: (XFTPSndFile, FileTransferId) -> m (Maybe (XFTPSndFile, ValidFileDescription 'FSender, FileTransferId))
|
||||
sndFileDescr (xsf@XFTPSndFile {privateSndFileDescr}, fileId) =
|
||||
join <$> forM privateSndFileDescr parseSndDescr
|
||||
where
|
||||
parseSndDescr sfdText =
|
||||
tryChatError (parseFileDescription sfdText) >>= \case
|
||||
Left _ -> pure Nothing
|
||||
Right sd -> pure $ Just (xsf, sd, fileId)
|
||||
|
||||
userProfileToSend :: User -> Maybe Profile -> Maybe Contact -> Bool -> Profile
|
||||
userProfileToSend user@User {profile = p} incognitoProfile ct inGroup = do
|
||||
|
||||
@ -1252,6 +1252,14 @@ mkChatError :: SomeException -> ChatError
|
||||
mkChatError = ChatError . CEException . show
|
||||
{-# INLINE mkChatError #-}
|
||||
|
||||
catchStoreError :: ExceptT StoreError IO a -> (StoreError -> ExceptT StoreError IO a) -> ExceptT StoreError IO a
|
||||
catchStoreError = catchAllErrors mkStoreError
|
||||
{-# INLINE catchStoreError #-}
|
||||
|
||||
mkStoreError :: SomeException -> StoreError
|
||||
mkStoreError = SEInternalError . show
|
||||
{-# INLINE mkStoreError #-}
|
||||
|
||||
chatCmdError :: Maybe User -> String -> ChatResponse
|
||||
chatCmdError user = CRChatCmdError user . ChatError . CECommandError
|
||||
|
||||
|
||||
@ -46,7 +46,7 @@ import Database.SQLite.Simple.ToField (ToField (..))
|
||||
import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Chat.Types.Util
|
||||
import Simplex.FileTransfer.Description (FileDigest)
|
||||
import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), APartyCmdTag (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, SAEntity (..), UserId)
|
||||
import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), APartyCmdTag (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, RcvFileId, SAEntity (..), SndFileId, UserId)
|
||||
import Simplex.Messaging.Crypto.File (CryptoFileArgs (..))
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, sumTypeJSON, taggedObjectJSON)
|
||||
@ -1142,7 +1142,7 @@ instance FromField AgentConnId where fromField f = AgentConnId <$> fromField f
|
||||
|
||||
instance ToField AgentConnId where toField (AgentConnId m) = toField m
|
||||
|
||||
newtype AgentSndFileId = AgentSndFileId ConnId
|
||||
newtype AgentSndFileId = AgentSndFileId SndFileId
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance StrEncoding AgentSndFileId where
|
||||
@ -1161,7 +1161,7 @@ instance FromField AgentSndFileId where fromField f = AgentSndFileId <$> fromFie
|
||||
|
||||
instance ToField AgentSndFileId where toField (AgentSndFileId m) = toField m
|
||||
|
||||
newtype AgentRcvFileId = AgentRcvFileId ConnId
|
||||
newtype AgentRcvFileId = AgentRcvFileId RcvFileId
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance StrEncoding AgentRcvFileId where
|
||||
|
||||
@ -20,7 +20,6 @@ import Simplex.Chat.Options (ChatOpts (..))
|
||||
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..))
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Util (unlessM)
|
||||
import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist, getFileSize)
|
||||
import Test.Hspec hiding (it)
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user