diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index c140025648..8f9d985efe 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -980,47 +980,70 @@ processChatCommand' vr = \case throwChatError (CECommandError $ "reaction already " <> if add then "added" else "removed") when (add && length rs >= maxMsgReactions) $ throwChatError (CECommandError "too many reactions") - APIForwardChatItems (ChatRef toCType toChatId) (ChatRef fromCType fromChatId) itemIds itemTTL -> withUser $ \user -> case toCType of + APIForwardChatItems (ChatRef toCType toChatId) (ChatRef fromCType fromChatId) itemIds itemTTL ignoreMissingFiles -> withUser $ \user -> case toCType of CTDirect -> do - cmrs <- prepareForward user - case L.nonEmpty cmrs of - Just cmrs' -> - withContactLock "forwardChatItem, to contact" toChatId $ - sendContactContentMessages user toChatId False itemTTL cmrs' - Nothing -> throwChatError $ CEInternalError "no chat items to forward" + cmrs <- prepareForwardOrFail user + withContactLock "forwardChatItem, to contact" toChatId $ + sendContactContentMessages user toChatId False itemTTL cmrs CTGroup -> do - cmrs <- prepareForward user - case L.nonEmpty cmrs of - Just cmrs' -> - withGroupLock "forwardChatItem, to group" toChatId $ - sendGroupContentMessages user toChatId False itemTTL cmrs' - Nothing -> throwChatError $ CEInternalError "no chat items to forward" + cmrs <- prepareForwardOrFail user + withGroupLock "forwardChatItem, to group" toChatId $ + sendGroupContentMessages user toChatId False itemTTL cmrs CTLocal -> do - cmrs <- prepareForward user - case L.nonEmpty cmrs of - Just cmrs' -> - createNoteFolderContentItems user toChatId cmrs' - Nothing -> throwChatError $ CEInternalError "no chat items to forward" + cmrs <- prepareForwardOrFail user + createNoteFolderContentItems user toChatId cmrs CTContactRequest -> pure $ chatCmdError (Just user) "not supported" CTContactConnection -> pure $ chatCmdError (Just user) "not supported" where - prepareForward :: User -> CM [ComposeMessageReq] + prepareForwardOrFail :: User -> CM (NonEmpty ComposeMessageReq) + prepareForwardOrFail user = do + (errs, cmrs) <- partitionEithers . L.toList <$> prepareForward user + case sortOn fst errs of + [] -> case L.nonEmpty (catMaybes cmrs) of + Nothing -> throwChatError $ CEInternalError "no chat items to forward" + Just cmrs' -> do + -- copy forwarded files, in case originals are deleted + withFilesFolder $ \filesFolder -> do + let toFolder cf@CryptoFile {filePath} = cf {filePath = filesFolder filePath} :: CryptoFile + forM_ cmrs' $ \case + (_, Just (fromCF, toCF)) -> + liftIOEither $ runExceptT $ withExceptT (ChatError . CEInternalError . show) $ + copyCryptoFile (toFolder fromCF) (toFolder toCF) + _ -> pure () + pure $ L.map fst cmrs' + errs'@((err, _) : _) -> do + -- cleanup files + withFilesFolder $ \filesFolder -> + forM_ cmrs $ \case + Just (_, Just (_, CryptoFile {filePath = toFPath})) -> do + let fsToPath = filesFolder toFPath + removeFile fsToPath `catchChatError` \e -> + logError ("prepareForwardOrFail: failed to clean up " <> tshow fsToPath <> ": " <> tshow e) + _ -> pure () + throwChatError $ case err of + FFENotAccepted _ -> CEForwardFilesNotAccepted files msgCount + FFEInProgress -> CEForwardFilesInProgress filesCount msgCount + FFEMissing -> CEForwardFilesMissing filesCount msgCount + FFEFailed -> CEForwardFilesFailed filesCount msgCount + where + msgCount = foldl' (\cnt (_, hasContent) -> if hasContent then cnt + 1 else cnt) 0 errs' + filesCount = foldl' (\cnt (e, _) -> if err == e then cnt + 1 else cnt) 0 errs' + files = foldl' (\ftIds -> \case (FFENotAccepted ftId, _) -> ftId : ftIds; _ -> ftIds) [] errs' + prepareForward :: User -> CM (NonEmpty (Either (ForwardFileError, Bool) (Maybe (ComposeMessageReq, Maybe (CryptoFile, CryptoFile))))) prepareForward user = case fromCType of CTDirect -> withContactLock "forwardChatItem, from contact" fromChatId $ do ct <- withFastStore $ \db -> getContact db vr user fromChatId - (errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getDirectCI db) (L.toList itemIds)) - unless (null errs) $ toView $ CRChatErrors (Just user) errs + items <- withFastStore $ \db -> mapM (getDirectChatItem db user fromChatId) itemIds mapM (ciComposeMsgReq ct) items where - getDirectCI :: DB.Connection -> ChatItemId -> IO (Either ChatError (CChatItem 'CTDirect)) - getDirectCI db itemId = runExceptT . withExceptT ChatErrorStore $ getDirectChatItem db user fromChatId itemId - ciComposeMsgReq :: Contact -> CChatItem 'CTDirect -> CM ComposeMessageReq + ciComposeMsgReq :: Contact -> CChatItem 'CTDirect -> CM (Either (ForwardFileError, Bool) (Maybe (ComposeMessageReq, Maybe (CryptoFile, CryptoFile)))) ciComposeMsgReq ct (CChatItem _ ci) = do (mc, mDir) <- forwardMC ci - file <- forwardCryptoFile ci - let itemId = chatItemId' ci - ciff = forwardCIFF ci $ Just (CIFFContact (forwardName ct) mDir (Just fromChatId) (Just itemId)) - pure (ComposedMessage file Nothing mc, ciff) + fc <- forwardContent ci mc + forM fc $ \mcFile -> forM mcFile $ \(mc'', file_) -> do + let itemId = chatItemId' ci + ciff = forwardCIFF ci $ Just (CIFFContact (forwardName ct) mDir (Just fromChatId) (Just itemId)) + pure ((ComposedMessage (snd <$> file_) Nothing mc'', ciff), file_) where forwardName :: Contact -> ContactName forwardName Contact {profile = LocalProfile {displayName, localAlias}} @@ -1028,35 +1051,31 @@ processChatCommand' vr = \case | otherwise = displayName CTGroup -> withGroupLock "forwardChatItem, from group" fromChatId $ do gInfo <- withFastStore $ \db -> getGroupInfo db vr user fromChatId - (errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getGroupCI db) (L.toList itemIds)) - unless (null errs) $ toView $ CRChatErrors (Just user) errs + items <- withFastStore $ \db -> mapM (getGroupChatItem db user fromChatId) itemIds mapM (ciComposeMsgReq gInfo) items where - getGroupCI :: DB.Connection -> ChatItemId -> IO (Either ChatError (CChatItem 'CTGroup)) - getGroupCI db itemId = runExceptT . withExceptT ChatErrorStore $ getGroupChatItem db user fromChatId itemId - ciComposeMsgReq :: GroupInfo -> CChatItem 'CTGroup -> CM ComposeMessageReq + ciComposeMsgReq :: GroupInfo -> CChatItem 'CTGroup -> CM (Either (ForwardFileError, Bool) (Maybe (ComposeMessageReq, Maybe (CryptoFile, CryptoFile)))) ciComposeMsgReq gInfo (CChatItem _ ci) = do (mc, mDir) <- forwardMC ci - file <- forwardCryptoFile ci - let itemId = chatItemId' ci - ciff = forwardCIFF ci $ Just (CIFFGroup (forwardName gInfo) mDir (Just fromChatId) (Just itemId)) - pure (ComposedMessage file Nothing mc, ciff) + fc <- forwardContent ci mc + forM fc $ \mcFile -> forM mcFile $ \(mc'', file_) -> do + let itemId = chatItemId' ci + ciff = forwardCIFF ci $ Just (CIFFGroup (forwardName gInfo) mDir (Just fromChatId) (Just itemId)) + pure ((ComposedMessage (snd <$> file_) Nothing mc'', ciff), file_) where forwardName :: GroupInfo -> ContactName forwardName GroupInfo {groupProfile = GroupProfile {displayName}} = displayName CTLocal -> do - (errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getLocalCI db) (L.toList itemIds)) - unless (null errs) $ toView $ CRChatErrors (Just user) errs + items <- withFastStore $ \db -> mapM (getLocalChatItem db user fromChatId) itemIds mapM ciComposeMsgReq items where - getLocalCI :: DB.Connection -> ChatItemId -> IO (Either ChatError (CChatItem 'CTLocal)) - getLocalCI db itemId = runExceptT . withExceptT ChatErrorStore $ getLocalChatItem db user fromChatId itemId - ciComposeMsgReq :: CChatItem 'CTLocal -> CM ComposeMessageReq + ciComposeMsgReq :: CChatItem 'CTLocal -> CM (Either (ForwardFileError, Bool) (Maybe (ComposeMessageReq, Maybe (CryptoFile, CryptoFile)))) ciComposeMsgReq (CChatItem _ ci) = do (mc, _) <- forwardMC ci - file <- forwardCryptoFile ci - let ciff = forwardCIFF ci Nothing - pure (ComposedMessage file Nothing mc, ciff) + fc <- forwardContent ci mc + forM fc $ \mcFile -> forM mcFile $ \(mc'', file_) -> do + let ciff = forwardCIFF ci Nothing + pure ((ComposedMessage (snd <$> file_) Nothing mc'', ciff), file_) CTContactRequest -> throwChatError $ CECommandError "not supported" CTContactConnection -> throwChatError $ CECommandError "not supported" where @@ -1070,48 +1089,53 @@ processChatCommand' vr = \case Nothing -> ciff Just CIFFUnknown -> ciff Just prevCIFF -> Just prevCIFF - forwardCryptoFile :: ChatItem c d -> CM (Maybe CryptoFile) - forwardCryptoFile ChatItem {file = Nothing} = pure Nothing - forwardCryptoFile ChatItem {file = Just ciFile} = case ciFile of - CIFile {fileName, fileSource = Just fromCF@CryptoFile {filePath}} -> - chatReadVar filesFolder >>= \case - Nothing -> - ifM (doesFileExist filePath) (pure $ Just fromCF) (pure Nothing) - Just filesFolder -> do - let fsFromPath = filesFolder filePath - ifM - (doesFileExist fsFromPath) - ( do - fsNewPath <- liftIO $ filesFolder `uniqueCombine` fileName - liftIO $ B.writeFile fsNewPath "" -- create empty file - encrypt <- chatReadVar encryptLocalFiles - cfArgs <- if encrypt then Just <$> (atomically . CF.randomArgs =<< asks random) else pure Nothing - let toCF = CryptoFile fsNewPath cfArgs - -- to keep forwarded file in case original is deleted - liftIOEither $ runExceptT $ withExceptT (ChatError . CEInternalError . show) $ copyCryptoFile (fromCF {filePath = fsFromPath} :: CryptoFile) toCF - pure $ Just (toCF {filePath = takeFileName fsNewPath} :: CryptoFile) - ) - (pure Nothing) - _ -> pure Nothing - copyCryptoFile :: CryptoFile -> CryptoFile -> ExceptT CF.FTCryptoError IO () - copyCryptoFile fromCF@CryptoFile {filePath = fsFromPath, cryptoArgs = fromArgs} toCF@CryptoFile {cryptoArgs = toArgs} = do - fromSizeFull <- getFileSize fsFromPath - let fromSize = fromSizeFull - maybe 0 (const $ toInteger C.authTagSize) fromArgs - CF.withFile fromCF ReadMode $ \fromH -> - CF.withFile toCF WriteMode $ \toH -> do - copyChunks fromH toH fromSize - forM_ fromArgs $ \_ -> CF.hGetTag fromH - forM_ toArgs $ \_ -> liftIO $ CF.hPutTag toH + forwardContent :: ChatItem c d -> MsgContent -> CM (Either (ForwardFileError, Bool) (Maybe (MsgContent, Maybe (CryptoFile, CryptoFile)))) + forwardContent ChatItem {file = Nothing} mc = pure $ Right $ Just (mc, Nothing) + forwardContent ChatItem {file = Just ciFile} mc = case ciFile of + CIFile {fileId, fileName, fileStatus, fileSource = Just fromCF@CryptoFile {filePath}} -> case ciFileForwardError fileId fileStatus of + Just e -> pure $ ignoreOrError e + Nothing -> + chatReadVar filesFolder >>= \case + Nothing -> + ifM (doesFileExist filePath) (pure $ Right $ Just (mc, Just (fromCF, fromCF))) (pure $ ignoreOrError FFEMissing) + Just filesFolder -> + ifM (doesFileExist $ filesFolder filePath) forwardedFile (pure $ ignoreOrError FFEMissing) + where + forwardedFile = do + fsNewPath <- liftIO $ filesFolder `uniqueCombine` fileName + liftIO $ B.writeFile fsNewPath "" -- create empty file + encrypt <- chatReadVar encryptLocalFiles + cfArgs <- if encrypt then Just <$> (atomically . CF.randomArgs =<< asks random) else pure Nothing + let toCF = CryptoFile fsNewPath cfArgs + pure $ Right $ Just (mc, Just (fromCF, toCF {filePath = takeFileName fsNewPath} :: CryptoFile)) + _ -> pure $ ignoreOrError FFEMissing where - copyChunks :: CF.CryptoFileHandle -> CF.CryptoFileHandle -> Integer -> ExceptT CF.FTCryptoError IO () - copyChunks r w size = do - let chSize = min size U.chunkSize - chSize' = fromIntegral chSize - size' = size - chSize - ch <- liftIO $ CF.hGet r chSize' - when (B.length ch /= chSize') $ throwError $ CF.FTCEFileIOError "encrypting file: unexpected EOF" - liftIO . CF.hPut w $ LB.fromStrict ch - when (size' > 0) $ copyChunks r w size' + ignoreOrError err = if ignoreMissingFiles then Right (newContent mc) else Left (err, hasContent mc) + where + newContent mc' = case mc' of + MCImage {} -> Just (mc', Nothing) + _ | msgContentText mc' /= "" -> Just (MCText $ msgContentText mc', Nothing) + _ -> Nothing + hasContent mc' = isJust $ newContent mc' + copyCryptoFile :: CryptoFile -> CryptoFile -> ExceptT CF.FTCryptoError IO () + copyCryptoFile fromCF@CryptoFile {filePath = fsFromPath, cryptoArgs = fromArgs} toCF@CryptoFile {cryptoArgs = toArgs} = do + fromSizeFull <- getFileSize fsFromPath + let fromSize = fromSizeFull - maybe 0 (const $ toInteger C.authTagSize) fromArgs + CF.withFile fromCF ReadMode $ \fromH -> + CF.withFile toCF WriteMode $ \toH -> do + copyChunks fromH toH fromSize + forM_ fromArgs $ \_ -> CF.hGetTag fromH + forM_ toArgs $ \_ -> liftIO $ CF.hPutTag toH + where + copyChunks :: CF.CryptoFileHandle -> CF.CryptoFileHandle -> Integer -> ExceptT CF.FTCryptoError IO () + copyChunks r w size = do + let chSize = min size U.chunkSize + chSize' = fromIntegral chSize + size' = size - chSize + ch <- liftIO $ CF.hGet r chSize' + when (B.length ch /= chSize') $ throwError $ CF.FTCEFileIOError "encrypting file: unexpected EOF" + liftIO . CF.hPut w $ LB.fromStrict ch + when (size' > 0) $ copyChunks r w size' APIUserRead userId -> withUserId userId $ \user -> withFastStore' (`setUserChatsRead` user) >> ok user UserRead -> withUser $ \User {userId} -> processChatCommand $ APIUserRead userId APIChatRead chatRef@(ChatRef cType chatId) fromToIds -> withUser $ \_ -> case cType of @@ -1831,17 +1855,17 @@ processChatCommand' vr = \case contactId <- withFastStore $ \db -> getContactIdByName db user fromContactName forwardedItemId <- withFastStore $ \db -> getDirectChatItemIdByText' db user contactId forwardedMsg toChatRef <- getChatRef user toChatName - processChatCommand $ APIForwardChatItems toChatRef (ChatRef CTDirect contactId) (forwardedItemId :| []) Nothing + processChatCommand $ APIForwardChatItems toChatRef (ChatRef CTDirect contactId) (forwardedItemId :| []) Nothing True ForwardGroupMessage toChatName fromGroupName fromMemberName_ forwardedMsg -> withUser $ \user -> do groupId <- withFastStore $ \db -> getGroupIdByName db user fromGroupName forwardedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user groupId fromMemberName_ forwardedMsg toChatRef <- getChatRef user toChatName - processChatCommand $ APIForwardChatItems toChatRef (ChatRef CTGroup groupId) (forwardedItemId :| []) Nothing + processChatCommand $ APIForwardChatItems toChatRef (ChatRef CTGroup groupId) (forwardedItemId :| []) Nothing True ForwardLocalMessage toChatName forwardedMsg -> withUser $ \user -> do folderId <- withFastStore (`getUserNoteFolderId` user) forwardedItemId <- withFastStore $ \db -> getLocalChatItemIdByText' db user folderId forwardedMsg toChatRef <- getChatRef user toChatName - processChatCommand $ APIForwardChatItems toChatRef (ChatRef CTLocal folderId) (forwardedItemId :| []) Nothing + processChatCommand $ APIForwardChatItems toChatRef (ChatRef CTLocal folderId) (forwardedItemId :| []) Nothing True SendMessage (ChatName cType name) msg -> withUser $ \user -> do let mc = MCText msg case cType of @@ -3332,9 +3356,10 @@ deleteFilesLocally files = delete fPath = removeFile fPath `catchAll` \_ -> removePathForcibly fPath `catchAll_` pure () - -- perform an action only if filesFolder is set (i.e. on mobile devices) - withFilesFolder :: (FilePath -> CM ()) -> CM () - withFilesFolder action = asks filesFolder >>= readTVarIO >>= mapM_ action + +-- perform an action only if filesFolder is set (i.e. on mobile devices) +withFilesFolder :: (FilePath -> CM ()) -> CM () +withFilesFolder action = asks filesFolder >>= readTVarIO >>= mapM_ action updateCallItemStatus :: User -> Contact -> Call -> WebRTCCallStatus -> Maybe MessageId -> CM () updateCallItemStatus user ct@Contact {contactId} Call {chatItemId} receivedStatus msgId_ = do @@ -7888,7 +7913,7 @@ chatCommandP = "/_delete item " *> (APIDeleteChatItem <$> chatRefP <*> _strP <* A.space <*> ciDeleteMode), "/_delete member item #" *> (APIDeleteMemberChatItem <$> A.decimal <*> _strP), "/_reaction " *> (APIChatItemReaction <$> chatRefP <* A.space <*> A.decimal <* A.space <*> onOffP <* A.space <*> jsonP), - "/_forward " *> (APIForwardChatItems <$> chatRefP <* A.space <*> chatRefP <*> _strP <*> sendMessageTTLP), + "/_forward " *> (APIForwardChatItems <$> chatRefP <* A.space <*> chatRefP <*> _strP <*> sendMessageTTLP <*> (" ignore_files=" *> onOffP <|> pure False)), "/_read user " *> (APIUserRead <$> A.decimal), "/read user" $> UserRead, "/_read chat " *> (APIChatRead <$> chatRefP <*> optional (A.space *> ((,) <$> ("from=" *> A.decimal) <* A.space <*> ("to=" *> A.decimal)))), diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 7268d0734a..7c49e9e7e4 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -298,7 +298,7 @@ data ChatCommand | APIDeleteChatItem ChatRef (NonEmpty ChatItemId) CIDeleteMode | APIDeleteMemberChatItem GroupId (NonEmpty ChatItemId) | APIChatItemReaction {chatRef :: ChatRef, chatItemId :: ChatItemId, add :: Bool, reaction :: MsgReaction} - | APIForwardChatItems {toChatRef :: ChatRef, fromChatRef :: ChatRef, chatItemIds :: NonEmpty ChatItemId, ttl :: Maybe Int} + | APIForwardChatItems {toChatRef :: ChatRef, fromChatRef :: ChatRef, chatItemIds :: NonEmpty ChatItemId, ttl :: Maybe Int, ignoreMissingFiles :: Bool} | APIUserRead UserId | UserRead | APIChatRead ChatRef (Maybe (ChatItemId, ChatItemId)) @@ -1178,6 +1178,10 @@ data ChatErrorType | CEFallbackToSMPProhibited {fileId :: FileTransferId} | CEInlineFileProhibited {fileId :: FileTransferId} | CEInvalidQuote + | CEForwardFilesNotAccepted {files :: [FileTransferId], msgCount :: Int} -- contentCount is the count of messages if files are ignored + | CEForwardFilesInProgress {filesCount :: Int, msgCount :: Int} + | CEForwardFilesMissing {filesCount :: Int, msgCount :: Int} + | CEForwardFilesFailed {filesCount :: Int, msgCount :: Int} | CEInvalidForward | CEInvalidChatItemUpdate | CEInvalidChatItemDelete diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index f6c59cbcb5..0e4edbd685 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -35,7 +35,7 @@ import Data.Maybe (fromMaybe, isJust, isNothing) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1, encodeUtf8) -import Data.Time.Clock (UTCTime, diffUTCTime, nominalDay, NominalDiffTime) +import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, nominalDay) import Data.Type.Equality import Data.Typeable (Typeable) import Database.SQLite.Simple.FromField (FromField (..)) @@ -577,23 +577,26 @@ ciFileEnded = \case CIFSRcvWarning {} -> False CIFSInvalid {} -> True -ciFileLoaded :: CIFileStatus d -> Bool -ciFileLoaded = \case - CIFSSndStored -> True - CIFSSndTransfer {} -> True - CIFSSndComplete -> True - CIFSSndCancelled -> True - CIFSSndError {} -> True - CIFSSndWarning {} -> True - CIFSRcvInvitation -> False - CIFSRcvAccepted -> False - CIFSRcvTransfer {} -> False - CIFSRcvAborted -> False - CIFSRcvCancelled -> False - CIFSRcvComplete -> True - CIFSRcvError {} -> False - CIFSRcvWarning {} -> False - CIFSInvalid {} -> False +data ForwardFileError = FFENotAccepted FileTransferId | FFEInProgress | FFEFailed | FFEMissing + deriving (Eq, Ord) + +ciFileForwardError :: FileTransferId -> CIFileStatus d -> Maybe ForwardFileError +ciFileForwardError fId = \case + CIFSSndStored -> Nothing + CIFSSndTransfer {} -> Nothing + CIFSSndComplete -> Nothing + CIFSSndCancelled -> Nothing + CIFSSndError {} -> Nothing + CIFSSndWarning {} -> Nothing + CIFSRcvInvitation -> Just $ FFENotAccepted fId + CIFSRcvAccepted -> Just FFEInProgress + CIFSRcvTransfer {} -> Just FFEInProgress + CIFSRcvAborted -> Just $ FFENotAccepted fId + CIFSRcvCancelled -> Just FFEFailed -- ? + CIFSRcvComplete -> Nothing + CIFSRcvError {} -> Just FFEFailed + CIFSRcvWarning {} -> Just FFEFailed + CIFSInvalid {} -> Just FFEFailed -- ? data ACIFileStatus = forall d. MsgDirectionI d => AFS (SMsgDirection d) (CIFileStatus d) diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 2158599c4b..e8814fb32d 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -2034,7 +2034,11 @@ viewChatError isCmd logLevel testView = \case CEFallbackToSMPProhibited fileId -> ["recipient tried to accept file " <> sShow fileId <> " via old protocol, prohibited"] CEInlineFileProhibited _ -> ["A small file sent without acceptance - you can enable receiving such files with -f option."] CEInvalidQuote -> ["cannot reply to this message"] - CEInvalidForward -> ["cannot forward this message"] + CEInvalidForward -> ["cannot forward message(s)"] + CEForwardFilesNotAccepted files msgCount -> [plain $ "Some files are not accepted: " <> intercalate ", " (map show files), showForwardMsgCount msgCount] + CEForwardFilesInProgress cnt msgCount -> [plain $ "Still receiving " <> show cnt <> " file(s)", showForwardMsgCount msgCount] + CEForwardFilesMissing cnt msgCount -> [plain $ show cnt <> " file(s) are missing", showForwardMsgCount msgCount] + CEForwardFilesFailed cnt msgCount -> [plain $ show cnt <> " file(s) failed", showForwardMsgCount msgCount] CEInvalidChatItemUpdate -> ["cannot update this item"] CEInvalidChatItemDelete -> ["cannot delete this item"] CEHasCurrentCall -> ["call already in progress"] @@ -2053,6 +2057,9 @@ viewChatError isCmd logLevel testView = \case CEPeerChatVRangeIncompatible -> ["peer chat protocol version range incompatible"] CEInternalError e -> ["internal chat error: " <> plain e] CEException e -> ["exception: " <> plain e] + where + showForwardMsgCount 0 = "No other messages to forward" + showForwardMsgCount msgCount = plain $ "Use ignore_files to forward " <> show msgCount <> " message(s)" -- e -> ["chat error: " <> sShow e] ChatErrorStore err -> case err of SEDuplicateName -> ["this display name is already used by user, contact or group"] diff --git a/tests/ChatTests/Forward.hs b/tests/ChatTests/Forward.hs index b339053abf..1897cddef5 100644 --- a/tests/ChatTests/Forward.hs +++ b/tests/ChatTests/Forward.hs @@ -671,6 +671,8 @@ testMultiForwardFiles = \alice bob cath -> withXFTPServer $ do setRelativePaths alice "./tests/tmp/alice_app_files" "./tests/tmp/alice_xftp" copyFile "./tests/fixtures/test.jpg" "./tests/tmp/alice_app_files/test.jpg" + copyFile "./tests/fixtures/test.jpg" "./tests/tmp/alice_app_files/test_3.jpg" + copyFile "./tests/fixtures/test.jpg" "./tests/tmp/alice_app_files/test_4.jpg" copyFile "./tests/fixtures/test.pdf" "./tests/tmp/alice_app_files/test.pdf" setRelativePaths bob "./tests/tmp/bob_app_files" "./tests/tmp/bob_xftp" setRelativePaths cath "./tests/tmp/cath_app_files" "./tests/tmp/cath_xftp" @@ -688,7 +690,10 @@ testMultiForwardFiles = let cm1 = "{\"msgContent\": {\"type\": \"text\", \"text\": \"message without file\"}}" cm2 = "{\"filePath\": \"test.jpg\", \"msgContent\": {\"type\": \"text\", \"text\": \"sending file 1\"}}" cm3 = "{\"filePath\": \"test.pdf\", \"msgContent\": {\"type\": \"text\", \"text\": \"sending file 2\"}}" - alice ##> ("/_send @2 json [" <> cm1 <> "," <> cm2 <> "," <> cm3 <> "]") + cm4 = "{\"filePath\": \"test_4.jpg\", \"msgContent\": {\"type\": \"text\", \"text\": \"sending file 3\"}}" + cm5 = "{\"filePath\": \"test_3.jpg\", \"msgContent\": {\"text\":\"\",\"type\":\"file\"}}" + + alice ##> ("/_send @2 json [" <> cm1 <> "," <> cm2 <> "," <> cm3 <> "," <> cm4 <> "," <> cm5 <> "]") alice <# "@bob message without file" @@ -700,6 +705,13 @@ testMultiForwardFiles = alice <# "/f @bob test.pdf" alice <## "use /fc 2 to cancel sending" + alice <# "@bob sending file 3" + alice <# "/f @bob test_4.jpg" + alice <## "use /fc 3 to cancel sending" + + alice <# "/f @bob test_3.jpg" + alice <## "use /fc 4 to cancel sending" + bob <# "alice> message without file" bob <# "alice> sending file 1" @@ -710,8 +722,17 @@ testMultiForwardFiles = bob <# "alice> sends file test.pdf (266.0 KiB / 272376 bytes)" bob <## "use /fr 2 [/ | ] to receive it" + bob <# "alice> sending file 3" + bob <# "alice> sends file test_4.jpg (136.5 KiB / 139737 bytes)" + bob <## "use /fr 3 [/ | ] to receive it" + + bob <# "alice> sends file test_3.jpg (136.5 KiB / 139737 bytes)" + bob <## "use /fr 4 [/ | ] to receive it" + alice <## "completed uploading file 1 (test.jpg) for bob" alice <## "completed uploading file 2 (test.pdf) for bob" + alice <## "completed uploading file 3 (test_4.jpg) for bob" + alice <## "completed uploading file 4 (test_3.jpg) for bob" bob ##> "/fr 1" bob @@ -720,6 +741,11 @@ testMultiForwardFiles = ] bob <## "completed receiving file 1 (test.jpg) from alice" + -- try to forward file without receiving 2nd file + let msgId1 = (read msgIdZero :: Int) + 1 + bob ##> ("/_forward @3 @2 " <> show msgId1 <> "," <> show (msgId1 + 1) <> "," <> show (msgId1 + 2) <> "," <> show (msgId1 + 3) <> "," <> show (msgId1 + 4) <> "," <> show (msgId1 + 5)) + bob <### ["3 file(s) are missing", "Use ignore_files to forward 2 message(s)"] + bob ##> "/fr 2" bob <### [ "saving file 2 from alice to test.pdf", @@ -736,8 +762,7 @@ testMultiForwardFiles = dest2 `shouldBe` src2 -- forward file - let msgId1 = (read msgIdZero :: Int) + 1 - bob ##> ("/_forward @3 @2 " <> show msgId1 <> "," <> show (msgId1 + 1) <> "," <> show (msgId1 + 2) <> "," <> show (msgId1 + 3)) + bob ##> ("/_forward @3 @2 " <> show msgId1 <> "," <> show (msgId1 + 1) <> "," <> show (msgId1 + 2) <> "," <> show (msgId1 + 3) <> "," <> show (msgId1 + 4) <> "," <> show (msgId1 + 5) <> " ignore_files=on") -- messages printed for bob bob <# "@cath <- you @alice" @@ -749,12 +774,15 @@ testMultiForwardFiles = bob <# "@cath <- @alice" bob <## " sending file 1" bob <# "/f @cath test_1.jpg" - bob <## "use /fc 3 to cancel sending" + bob <## "use /fc 5 to cancel sending" bob <# "@cath <- @alice" bob <## " sending file 2" bob <# "/f @cath test_1.pdf" - bob <## "use /fc 4 to cancel sending" + bob <## "use /fc 6 to cancel sending" + + bob <# "@cath <- @alice" + bob <## " sending file 3" -- messages printed for cath cath <# "bob> -> forwarded" @@ -773,9 +801,12 @@ testMultiForwardFiles = cath <# "bob> sends file test_1.pdf (266.0 KiB / 272376 bytes)" cath <## "use /fr 2 [/ | ] to receive it" + cath <# "bob> -> forwarded" + cath <## " sending file 3" -- No file sent here + -- file transfer - bob <## "completed uploading file 3 (test_1.jpg) for cath" - bob <## "completed uploading file 4 (test_1.pdf) for cath" + bob <## "completed uploading file 5 (test_1.jpg) for cath" + bob <## "completed uploading file 6 (test_1.pdf) for cath" cath ##> "/fr 1" cath