core: batch db operations for group leave and delete

src/Simplex/Chat.hs

@@ -10,7 +10,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 
 module Simplex.Chat where
 
@@ -311,7 +311,7 @@
     . map (\ServerCfg {server} -> server)
     . filter (\ServerCfg {enabled} -> enabled)
 
 cfgServers :: UserProtocol p => SProtocolType p -> (DefaultAgentServers -> NonEmpty (ProtoServerWithAuth p))
 cfgServers p DefaultAgentServers {smp, xftp} = case p of
   SPSMP -> smp
   SPXFTP -> xftp
@@ -1004,7 +1004,8 @@
       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
+        deleteFilesFilesystem user filesInfo
         when (contactReady ct && contactActive ct && notify) $
           void (sendDirectContactMessage ct XDirectDel) `catchChatError` const (pure ())
         contactConnIds <- map aConnId <$> withStore' (\db -> getContactConnections db userId ct)
@@ -1027,7 +1028,8 @@
       unless canDelete $ throwChatError $ CEGroupUserRole gInfo GROwner
       filesInfo <- withStore' $ \db -> getGroupFileInfo db user gInfo
       withChatLock "deleteChat group" . procCmd $ do
-        deleteFilesAndConns user filesInfo
+        cancelFilesInProgress user filesInfo
+        deleteFilesFilesystem user filesInfo
         when (memberActive membership && isOwner) . void $ sendGroupMessage' user gInfo members XGrpDel
         deleteGroupLinkIfExists user gInfo
         deleteMembersConnections user members
@@ -1038,37 +1040,38 @@
         withStore' $ \db -> deleteGroupItemsAndMembers db user gInfo members
         withStore' $ \db -> deleteGroup db user gInfo
         let contactIds = mapMaybe memberContactId members
-        deleteAgentConnectionsAsync user . concat =<< mapM deleteUnusedContact contactIds
+        (errs, connIds) <- partitionEithers <$> withStoreBatch (\db -> map (deleteUnusedContact db) contactIds)
+        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) $> [])
-          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
+        deleteUnusedContact :: DB.Connection -> ContactId -> IO (Either ChatError [ConnId])
+        deleteUnusedContact db contactId = runExceptT $ withExceptT ChatErrorStore $ do
+          ct <- getContact db user contactId
+          if directOrUsed ct
+            then pure []
+            else liftIO $ do
+              checkContactHasGroups db user ct >>= \case
+                Just _ -> pure []
+                Nothing -> do
+                  conns <- getContactConnections db userId ct
+                  setContactDeleted db user ct
+                  pure $ 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
+      deleteFilesFilesystem user 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
+      deleteFilesFilesystem user filesInfo
       withStore' $ \db -> deleteGroupCIs db user gInfo
       membersToDelete <- withStore' $ \db -> getGroupMembersForExpiration db user gInfo
       forM_ membersToDelete $ \m -> withStore' $ \db -> deleteGroupMember db user m
@@ -1077,7 +1080,7 @@
       nf <- withStore $ \db -> getNoteFolder db user chatId
       filesInfo <- withStore' $ \db -> getNoteFolderFileInfo db user nf
       withChatLock "clearChat local" . procCmd $ do
-        mapM_ (deleteFile user) filesInfo
+        deleteFilesFilesystem user filesInfo
         withStore' $ \db -> deleteNoteFolderFiles db userId nf
         withStore' $ \db -> deleteNoteFolderCIs db user nf
         pure $ CRChatCleared user (AChatInfo SCTLocal $ LocalChat nf)
@@ -1763,7 +1766,9 @@
           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)
@@ -2420,7 +2425,8 @@
     deleteChatUser :: User -> Bool -> m ChatResponse
     deleteChatUser user delSMPQueues = do
       filesInfo <- withStore' (`getUserFileInfo` user)
-      forM_ filesInfo $ \fileInfo -> deleteFile user fileInfo
+      cancelFilesInProgress user filesInfo
+      deleteFilesFilesystem user filesInfo
       withAgent $ \a -> deleteUser a (aUserId user) delSMPQueues
       withStore' (`deleteUserRecord` user)
       when (activeUser user) $ chatWriteVar currentUser Nothing
@@ -2628,20 +2634,101 @@
     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
+cancelFilesInProgress :: forall m. ChatMonad m => User -> [CIFileInfo] -> m ()
+cancelFilesInProgress user filesInfo = do
+  let filesInfo' = filter (not . fileEnded) filesInfo
+  (_errs, fts) <- partitionEithers <$> withStoreBatch (\db -> map (getFTransfer db) filesInfo')
+  let fts' = filter (not . ftCancelled) fts
+  updateFilesCancelled fts'
+  let (sndXFTPs, rcvXFTPs, sndSMPs, rcvSMPs) = partitionFTs fts'
+  cancelSndXFTPs sndXFTPs
+  cancelRcvXFTPs rcvXFTPs
+  let sndSMPConnIds = sndSMPConns sndSMPs
+  rcvSMPConnIds <- cancelRcvSMPs rcvSMPs
+  deleteAgentConnectionsAsync user $ sndSMPConnIds <> rcvSMPConnIds
+  where
+    fileEnded CIFileInfo {fileStatus} = case fileStatus of
+      Just (AFS _ status) -> ciFileEnded status
+      Nothing -> True
+    getFTransfer :: DB.Connection -> CIFileInfo -> IO (Either ChatError FileTransfer)
+    getFTransfer db CIFileInfo {fileId} =
+      runExceptT $
+        withExceptT ChatErrorStore $
+          getFileTransfer db user fileId
+    ftCancelled = \case
+      FTSnd FileTransferMeta {cancelled} _ -> cancelled
+      FTRcv RcvFileTransfer {cancelled} -> cancelled
+    updateFilesCancelled :: [FileTransfer] -> m ()
+    updateFilesCancelled fts =
+      void . withStoreBatch' $ \db -> map (updateFTCancelled db) fts
+      where
+        updateFTCancelled :: DB.Connection -> FileTransfer -> IO ()
+        updateFTCancelled db = \case
+          FTSnd FileTransferMeta {fileId} sfts -> do
+            updateFileCancelled db user fileId CIFSSndCancelled
+            forM_ sfts updateSndFTCancelled
+            where
+              updateSndFTCancelled :: SndFileTransfer -> IO ()
+              updateSndFTCancelled ft@SndFileTransfer {fileStatus}
+                | fileStatus == FSCancelled || fileStatus == FSComplete = pure ()
+                | otherwise = do
+                    updateSndFileStatus db ft FSCancelled
+                    deleteSndFileChunks db ft
+          FTRcv ft@RcvFileTransfer {fileId} -> do
+            updateFileCancelled db user fileId CIFSRcvCancelled
+            updateRcvFileStatus db fileId FSCancelled
+            deleteRcvFileChunks db ft
+    partitionFTs :: [FileTransfer] -> ([CancelSndXFTPFile], [CancelRcvXFTPFile], [CancelSndSMPFile], [CancelRcvSMPFile])
+    partitionFTs = foldr partitionHelper ([], [], [], [])
+      where
+        partitionHelper x (sndXFTPs, rcvXFTPs, sndSMPs, rcvSMPs) = case x of
+          FTSnd ftm@FileTransferMeta {xftpSndFile} sfts -> case xftpSndFile of
+            Just xsf -> (CancelSndXFTPFile ftm sfts xsf : sndXFTPs, rcvXFTPs, sndSMPs, rcvSMPs)
+            Nothing -> (sndXFTPs, rcvXFTPs, CancelSndSMPFile ftm sfts : sndSMPs, rcvSMPs)
+          FTRcv ft@RcvFileTransfer {xftpRcvFile} -> case xftpRcvFile of
+            Just xrf -> (sndXFTPs, CancelRcvXFTPFile ft xrf : rcvXFTPs, sndSMPs, rcvSMPs)
+            Nothing -> (sndXFTPs, rcvXFTPs, sndSMPs, CancelRcvSMPFile ft : rcvSMPs)
+    cancelSndXFTPs :: [CancelSndXFTPFile] -> m ()
+    cancelSndXFTPs sndXFTPs = do
+      let xsfIds = map (\(CancelSndXFTPFile FileTransferMeta {fileId} _ xsf) -> (xsf, fileId)) sndXFTPs
+      agentXFTPDeleteSndFilesRemote user xsfIds
+    cancelRcvXFTPs :: [CancelRcvXFTPFile] -> m ()
+    cancelRcvXFTPs rcvXFTPs = do
+      forM_ rcvXFTPs $ \(CancelRcvXFTPFile RcvFileTransfer {fileId} _) ->
+        closeFileHandle fileId rcvFiles `catchChatError` \_ -> pure ()
+      let xrfIds = map (\(CancelRcvXFTPFile RcvFileTransfer {fileId} xrf) -> (xrf, fileId)) rcvXFTPs
+      agentXFTPDeleteRcvFiles xrfIds
+    sndSMPConns :: [CancelSndSMPFile] -> [ConnId]
+    sndSMPConns sndSMPs =
+      join $ forM sndSMPs $ \(CancelSndSMPFile _ sfts) ->
+        mapMaybe fileConnId sfts
+      where
+        fileConnId SndFileTransfer {agentConnId = AgentConnId acId, fileStatus, fileInline}
+          | fileStatus == FSCancelled || fileStatus == FSComplete = Nothing
+          | isNothing fileInline = Just acId
+          | otherwise = Nothing
+    cancelRcvSMPs :: [CancelRcvSMPFile] -> m [ConnId]
+    cancelRcvSMPs rcvSMPs = do
+      forM_ rcvSMPs $ \(CancelRcvSMPFile RcvFileTransfer {fileId}) ->
+        closeFileHandle fileId rcvFiles `catchChatError` \_ -> pure ()
+      pure $ mapMaybe fileConnId rcvSMPs
+      where
+        fileConnId (CancelRcvSMPFile ft@RcvFileTransfer {xftpRcvFile, rcvFileInline}) =
+          if isNothing xftpRcvFile && isNothing rcvFileInline then liveRcvFileTransferConnId ft else Nothing
+
+data CancelSndXFTPFile = CancelSndXFTPFile FileTransferMeta [SndFileTransfer] XFTPSndFile
 
-deleteFile :: ChatMonad m => User -> CIFileInfo -> m [ConnId]
-deleteFile user fileInfo = deleteFile' user fileInfo False
+data CancelRcvXFTPFile = CancelRcvXFTPFile RcvFileTransfer XFTPRcvFile
 
-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
+data CancelSndSMPFile = CancelSndSMPFile FileTransferMeta [SndFileTransfer]
+
+newtype CancelRcvSMPFile = CancelRcvSMPFile RcvFileTransfer
+
+deleteFilesFilesystem :: ChatMonad m => User -> [CIFileInfo] -> m ()
+deleteFilesFilesystem user filesInfo =
+  forM_ filesInfo $ \CIFileInfo {filePath} ->
+    forM_ filePath $ \fPath ->
+      deleteFileLocally fPath `catchChatError` (toView . CRChatError (Just user))
 
 deleteFileLocally :: forall m. ChatMonad m => FilePath -> m ()
 deleteFileLocally fPath =
@@ -2654,24 +2741,6 @@
     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
@@ -3222,13 +3291,15 @@
     processContact expirationDate ct = do
       waitChatStartedAndActivated
       filesInfo <- withStoreCtx' (Just "processContact, getContactExpiredFileInfo") $ \db -> getContactExpiredFileInfo db user ct expirationDate
-      deleteFilesAndConns user filesInfo
+      cancelFilesInProgress user filesInfo
+      deleteFilesFilesystem user 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
+      deleteFilesFilesystem user 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
@@ -5882,7 +5953,7 @@
         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
@@ -6197,18 +6268,19 @@
     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]
+    deleteFilesFilesystem user 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
+    deleteFilesFilesystem user 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
@@ -6229,8 +6301,8 @@
 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
@@ -6272,13 +6344,36 @@
   withAgent (`xftpDeleteRcvFile` aFileId)
   withStore' $ \db -> setRcvFTAgentDeleted db fileId
 
+agentXFTPDeleteRcvFiles :: ChatMonad m => [(XFTPRcvFile, FileTransferId)] -> m ()
+agentXFTPDeleteRcvFiles rcvFiles = do
+  let rcvFiles' = filter (not . agentRcvFileDeleted . fst) rcvFiles
+  fileIds' <- forM rcvFiles' $ \case
+    (XFTPRcvFile {agentRcvFileId = Just (AgentRcvFileId aFileId)}, fileId) -> do
+      withAgent (`xftpDeleteRcvFile` aFileId)
+      pure $ Just fileId
+    _ -> pure Nothing
+  void . withStoreBatch' $ \db -> map (setRcvFTAgentDeleted db) (catMaybes fileIds')
+
 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
+agentXFTPDeleteSndFileRemote user xsf fileId =
+  agentXFTPDeleteSndFilesRemote user [(xsf, fileId)]
+
+agentXFTPDeleteSndFilesRemote :: forall m. ChatMonad m => User -> [(XFTPSndFile, FileTransferId)] -> m ()
+agentXFTPDeleteSndFilesRemote user sndFiles = do
+  let sndFiles' = filter (not . agentSndFileDeleted . fst) sndFiles
+  sndFiles'' <- catMaybes <$> mapM sndFileDescr sndFiles'
+  forM_ sndFiles'' $ \(XFTPSndFile {agentSndFileId = AgentSndFileId aFileId}, sd, _) ->
+    withAgent $ \a -> xftpDeleteSndFileRemote a (aUserId user) aFileId sd
+  void . withStoreBatch' $ \db -> map (setSndFTAgentDeleted db user . (\(_, _, fId) -> fId)) sndFiles''
+  where
+    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