From 51a2e097148282597a863f865b0f92e539c3fd8a Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Mon, 26 Feb 2024 15:36:42 +0400 Subject: [PATCH] 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 --- cabal.project | 2 +- scripts/nix/sha256map.nix | 2 +- src/Simplex/Chat.hs | 224 ++++++++++++++++++++------------- src/Simplex/Chat/Controller.hs | 8 ++ src/Simplex/Chat/Types.hs | 6 +- tests/ChatTests/Files.hs | 1 - 6 files changed, 153 insertions(+), 90 deletions(-) diff --git a/cabal.project b/cabal.project index de525ee718..609618858c 100644 --- a/cabal.project +++ b/cabal.project @@ -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 diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index 6321740ae9..2262c38a6d 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -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"; diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index e5b4af670a..1f096b310f 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -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 diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index cdecfa3159..c482825e18 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -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 diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index c340130f8a..0a35a83edd 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -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 diff --git a/tests/ChatTests/Files.hs b/tests/ChatTests/Files.hs index 725717436d..3aa345773e 100644 --- a/tests/ChatTests/Files.hs +++ b/tests/ChatTests/Files.hs @@ -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)