diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index c140025648..fb5c4b4962 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -843,9 +843,7 @@ processChatCommand' vr = \case CTContactConnection -> pure $ chatCmdError (Just user) "not supported" APIDeleteChatItem (ChatRef cType chatId) itemIds mode -> withUser $ \user -> case cType of CTDirect -> withContactLock "deleteChatItem" chatId $ do - ct <- withStore $ \db -> getContact db vr user chatId - (errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getDirectCI db) (L.toList itemIds)) - unless (null errs) $ toView $ CRChatErrors (Just user) errs + (ct, items) <- getCommandDirectChatItems user chatId itemIds case mode of CIDMInternal -> deleteDirectCIs user ct items True False CIDMBroadcast -> do @@ -858,13 +856,9 @@ processChatCommand' vr = \case if featureAllowed SCFFullDelete forUser ct then deleteDirectCIs user ct items True False else markDirectCIsDeleted user ct items True =<< liftIO getCurrentTime - where - getDirectCI :: DB.Connection -> ChatItemId -> IO (Either ChatError (CChatItem 'CTDirect)) - getDirectCI db itemId = runExceptT . withExceptT ChatErrorStore $ getDirectChatItem db user chatId itemId CTGroup -> withGroupLock "deleteChatItem" chatId $ do - Group gInfo ms <- withStore $ \db -> getGroup db vr user chatId - (errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getGroupCI db) (L.toList itemIds)) - unless (null errs) $ toView $ CRChatErrors (Just user) errs + (gInfo, items) <- getCommandGroupChatItems user chatId itemIds + ms <- withFastStore' $ \db -> getGroupMembers db vr user gInfo case mode of CIDMInternal -> deleteGroupCIs user gInfo items True False Nothing =<< liftIO getCurrentTime CIDMBroadcast -> do @@ -874,17 +868,9 @@ processChatCommand' vr = \case events = L.nonEmpty $ map (`XMsgDel` Nothing) msgIds mapM_ (sendGroupMessages user gInfo ms) events delGroupChatItems user gInfo items Nothing - where - getGroupCI :: DB.Connection -> ChatItemId -> IO (Either ChatError (CChatItem 'CTGroup)) - getGroupCI db itemId = runExceptT . withExceptT ChatErrorStore $ getGroupChatItem db user chatId itemId CTLocal -> do - nf <- withStore $ \db -> getNoteFolder db user chatId - (errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getLocalCI db) (L.toList itemIds)) - unless (null errs) $ toView $ CRChatErrors (Just user) errs + (nf, items) <- getCommandLocalChatItems user chatId itemIds deleteLocalCIs user nf items True False - where - getLocalCI :: DB.Connection -> ChatItemId -> IO (Either ChatError (CChatItem 'CTLocal)) - getLocalCI db itemId = runExceptT . withExceptT ChatErrorStore $ getLocalChatItem db user chatId itemId CTContactRequest -> pure $ chatCmdError (Just user) "not supported" CTContactConnection -> pure $ chatCmdError (Just user) "not supported" where @@ -902,9 +888,8 @@ processChatCommand' vr = \case itemsMsgIds :: [CChatItem c] -> [SharedMsgId] itemsMsgIds = mapMaybe (\(CChatItem _ ChatItem {meta = CIMeta {itemSharedMsgId}}) -> itemSharedMsgId) APIDeleteMemberChatItem gId itemIds -> withUser $ \user -> withGroupLock "deleteChatItem" gId $ do - Group gInfo@GroupInfo {membership} ms <- withStore $ \db -> getGroup db vr user gId - (errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getGroupCI db user) (L.toList itemIds)) - unless (null errs) $ toView $ CRChatErrors (Just user) errs + (gInfo@GroupInfo {membership}, items) <- getCommandGroupChatItems user gId itemIds + ms <- withFastStore' $ \db -> getGroupMembers db vr user gInfo assertDeletable gInfo items assertUserGroupRole gInfo GRAdmin let msgMemIds = itemsMsgMemIds gInfo items @@ -912,8 +897,6 @@ processChatCommand' vr = \case mapM_ (sendGroupMessages user gInfo ms) events delGroupChatItems user gInfo items (Just membership) where - getGroupCI :: DB.Connection -> User -> ChatItemId -> IO (Either ChatError (CChatItem 'CTGroup)) - getGroupCI db user itemId = runExceptT . withExceptT ChatErrorStore $ getGroupChatItem db user gId itemId assertDeletable :: GroupInfo -> [CChatItem 'CTGroup] -> CM () assertDeletable GroupInfo {membership = GroupMember {memberRole = membershipMemRole}} items = unless (all itemDeletable items) $ throwChatError CEInvalidChatItemDelete @@ -980,6 +963,51 @@ processChatCommand' vr = \case throwChatError (CECommandError $ "reaction already " <> if add then "added" else "removed") when (add && length rs >= maxMsgReactions) $ throwChatError (CECommandError "too many reactions") + APIPlanForwardChatItems (ChatRef fromCType fromChatId) itemIds -> withUser $ \user -> case fromCType of + CTDirect -> planForward user . snd =<< getCommandDirectChatItems user fromChatId itemIds + CTGroup -> planForward user . snd =<< getCommandGroupChatItems user fromChatId itemIds + CTLocal -> planForward user . snd =<< getCommandLocalChatItems user fromChatId itemIds + CTContactRequest -> pure $ chatCmdError (Just user) "not supported" + CTContactConnection -> pure $ chatCmdError (Just user) "not supported" + where + planForward :: User -> [CChatItem c] -> CM ChatResponse + planForward user items = do + (itemIds', forwardErrors) <- unzip <$> mapM planItemForward items + let forwardConfirmation = case catMaybes forwardErrors of + [] -> Nothing + errs -> Just $ case mainErr of + FFENotAccepted _ -> FCFilesNotAccepted fileIds + FFEInProgress -> FCFilesInProgress filesCount + FFEMissing -> FCFilesMissing filesCount + FFEFailed -> FCFilesFailed filesCount + where + mainErr = minimum errs + fileIds = catMaybes $ map (\case FFENotAccepted ftId -> Just ftId; _ -> Nothing) errs + filesCount = length $ filter (mainErr ==) errs + pure CRForwardPlan {user, itemsCount = length itemIds, chatItemIds = catMaybes itemIds', forwardConfirmation} + where + planItemForward :: CChatItem c -> CM (Maybe ChatItemId, Maybe ForwardFileError) + planItemForward (CChatItem _ ci) = forwardMsgContent ci >>= maybe (pure (Nothing, Nothing)) (forwardContentPlan ci) + forwardContentPlan :: ChatItem c d -> MsgContent -> CM (Maybe ChatItemId, Maybe ForwardFileError) + forwardContentPlan ChatItem {file, meta = CIMeta {itemId}} mc = case file of + Nothing -> pure (Just itemId, Nothing) + Just CIFile {fileId, fileStatus, fileSource} -> case ciFileForwardError fileId fileStatus of + Just err -> pure $ itemIdWithoutFile err + Nothing -> case fileSource of + Just CryptoFile {filePath} -> do + exists <- doesFileExist . maybe filePath ( filePath) =<< chatReadVar filesFolder + pure $ if exists then (Just itemId, Nothing) else itemIdWithoutFile FFEMissing + Nothing -> pure $ itemIdWithoutFile FFEMissing + where + itemIdWithoutFile err = (if hasContent then Just itemId else Nothing, Just err) + hasContent = case mc of + MCText _ -> True + MCLink {} -> True + MCImage {} -> True + MCVideo {text} -> text /= "" + MCVoice {text} -> text /= "" + MCFile t -> t /= "" + MCUnknown {} -> True APIForwardChatItems (ChatRef toCType toChatId) (ChatRef fromCType fromChatId) itemIds itemTTL -> withUser $ \user -> case toCType of CTDirect -> do cmrs <- prepareForward user @@ -987,96 +1015,76 @@ processChatCommand' vr = \case Just cmrs' -> withContactLock "forwardChatItem, to contact" toChatId $ sendContactContentMessages user toChatId False itemTTL cmrs' - Nothing -> throwChatError $ CEInternalError "no chat items to forward" + Nothing -> pure $ CRNewChatItems user [] 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" + Nothing -> pure $ CRNewChatItems user [] CTLocal -> do cmrs <- prepareForward user case L.nonEmpty cmrs of Just cmrs' -> createNoteFolderContentItems user toChatId cmrs' - Nothing -> throwChatError $ CEInternalError "no chat items to forward" + Nothing -> pure $ CRNewChatItems user [] CTContactRequest -> pure $ chatCmdError (Just user) "not supported" CTContactConnection -> pure $ chatCmdError (Just user) "not supported" where prepareForward :: User -> CM [ComposeMessageReq] 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 - mapM (ciComposeMsgReq ct) items + (ct, items) <- getCommandDirectChatItems user fromChatId itemIds + catMaybes <$> mapM (\ci -> ciComposeMsgReq ct ci <$$> prepareMsgReq ci) 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 ct (CChatItem _ ci) = do - (mc, mDir) <- forwardMC ci - file <- forwardCryptoFile ci + ciComposeMsgReq :: Contact -> CChatItem 'CTDirect -> (MsgContent, Maybe CryptoFile) -> ComposeMessageReq + ciComposeMsgReq ct (CChatItem md ci) (mc', file) = let itemId = chatItemId' ci - ciff = forwardCIFF ci $ Just (CIFFContact (forwardName ct) mDir (Just fromChatId) (Just itemId)) - pure (ComposedMessage file Nothing mc, ciff) + ciff = forwardCIFF ci $ Just (CIFFContact (forwardName ct) (toMsgDirection md) (Just fromChatId) (Just itemId)) + in (ComposedMessage file Nothing mc', ciff) where forwardName :: Contact -> ContactName forwardName Contact {profile = LocalProfile {displayName, localAlias}} | localAlias /= "" = localAlias | 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 - mapM (ciComposeMsgReq gInfo) items + (gInfo, items) <- getCommandGroupChatItems user fromChatId itemIds + catMaybes <$> mapM (\ci -> ciComposeMsgReq gInfo ci <$$> prepareMsgReq ci) 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 gInfo (CChatItem _ ci) = do - (mc, mDir) <- forwardMC ci - file <- forwardCryptoFile ci + ciComposeMsgReq :: GroupInfo -> CChatItem 'CTGroup -> (MsgContent, Maybe CryptoFile) -> ComposeMessageReq + ciComposeMsgReq gInfo (CChatItem md ci) (mc', file) = do let itemId = chatItemId' ci - ciff = forwardCIFF ci $ Just (CIFFGroup (forwardName gInfo) mDir (Just fromChatId) (Just itemId)) - pure (ComposedMessage file Nothing mc, ciff) + ciff = forwardCIFF ci $ Just (CIFFGroup (forwardName gInfo) (toMsgDirection md) (Just fromChatId) (Just itemId)) + in (ComposedMessage file Nothing mc', ciff) 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 - mapM ciComposeMsgReq items + (_, items) <- getCommandLocalChatItems user fromChatId itemIds + catMaybes <$> mapM (\ci -> ciComposeMsgReq ci <$$> prepareMsgReq ci) 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 _ ci) = do - (mc, _) <- forwardMC ci - file <- forwardCryptoFile ci + ciComposeMsgReq :: CChatItem 'CTLocal -> (MsgContent, Maybe CryptoFile) -> ComposeMessageReq + ciComposeMsgReq (CChatItem _ ci) (mc', file) = let ciff = forwardCIFF ci Nothing - pure (ComposedMessage file Nothing mc, ciff) + in (ComposedMessage file Nothing mc', ciff) CTContactRequest -> throwChatError $ CECommandError "not supported" CTContactConnection -> throwChatError $ CECommandError "not supported" where - forwardMC :: ChatItem c d -> CM (MsgContent, MsgDirection) - forwardMC ChatItem {meta = CIMeta {itemDeleted = Just _}} = throwChatError CEInvalidForward - forwardMC ChatItem {content = CISndMsgContent fmc} = pure (fmc, MDSnd) - forwardMC ChatItem {content = CIRcvMsgContent fmc} = pure (fmc, MDRcv) - forwardMC _ = throwChatError CEInvalidForward + prepareMsgReq :: CChatItem c -> CM (Maybe (MsgContent, Maybe CryptoFile)) + prepareMsgReq (CChatItem _ ci) = forwardMsgContent ci $>>= forwardContent ci forwardCIFF :: ChatItem c d -> Maybe CIForwardedFrom -> Maybe CIForwardedFrom forwardCIFF ChatItem {meta = CIMeta {itemForwarded}} ciff = case itemForwarded of 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 + forwardContent :: ChatItem c d -> MsgContent -> CM (Maybe (MsgContent, Maybe CryptoFile)) + forwardContent ChatItem {file = Nothing} mc = pure $ Just (mc, Nothing) + forwardContent ChatItem {file = Just ciFile} mc = case ciFile of CIFile {fileName, fileSource = Just fromCF@CryptoFile {filePath}} -> chatReadVar filesFolder >>= \case Nothing -> - ifM (doesFileExist filePath) (pure $ Just fromCF) (pure Nothing) + ifM (doesFileExist filePath) (pure $ Just (mc, Just fromCF)) (pure contentWithoutFile) Just filesFolder -> do let fsFromPath = filesFolder filePath ifM @@ -1089,10 +1097,17 @@ processChatCommand' vr = \case 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 $ Just (mc, Just (toCF {filePath = takeFileName fsNewPath} :: CryptoFile)) ) - (pure Nothing) - _ -> pure Nothing + (pure contentWithoutFile) + _ -> pure contentWithoutFile + where + contentWithoutFile = case mc of + MCImage {} -> Just (mc, Nothing) + MCLink {} -> Just (mc, Nothing) + _ | contentText /= "" -> Just (MCText contentText, Nothing) + _ -> Nothing + contentText = msgContentText mc copyCryptoFile :: CryptoFile -> CryptoFile -> ExceptT CF.FTCryptoError IO () copyCryptoFile fromCF@CryptoFile {filePath = fsFromPath, cryptoArgs = fromArgs} toCF@CryptoFile {cryptoArgs = toArgs} = do fromSizeFull <- getFileSize fsFromPath @@ -3087,6 +3102,38 @@ processChatCommand' vr = \case | (msg_, (ComposedMessage {msgContent}, itemForwarded), f, q) <- zipWith4 (,,,) msgs_ (L.toList cmrs') (L.toList ciFiles_) (L.toList quotedItems_) ] + getCommandDirectChatItems :: User -> Int64 -> NonEmpty ChatItemId -> CM (Contact, [CChatItem 'CTDirect]) + getCommandDirectChatItems user ctId itemIds = do + ct <- withFastStore $ \db -> getContact db vr user ctId + (errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getDirectCI db) (L.toList itemIds)) + unless (null errs) $ toView $ CRChatErrors (Just user) errs + pure (ct, items) + where + getDirectCI :: DB.Connection -> ChatItemId -> IO (Either ChatError (CChatItem 'CTDirect)) + getDirectCI db itemId = runExceptT . withExceptT ChatErrorStore $ getDirectChatItem db user ctId itemId + getCommandGroupChatItems :: User -> Int64 -> NonEmpty ChatItemId -> CM (GroupInfo, [CChatItem 'CTGroup]) + getCommandGroupChatItems user gId itemIds = do + gInfo <- withFastStore $ \db -> getGroupInfo db vr user gId + (errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getGroupCI db) (L.toList itemIds)) + unless (null errs) $ toView $ CRChatErrors (Just user) errs + pure (gInfo, items) + where + getGroupCI :: DB.Connection -> ChatItemId -> IO (Either ChatError (CChatItem 'CTGroup)) + getGroupCI db itemId = runExceptT . withExceptT ChatErrorStore $ getGroupChatItem db user gId itemId + getCommandLocalChatItems :: User -> Int64 -> NonEmpty ChatItemId -> CM (NoteFolder, [CChatItem 'CTLocal]) + getCommandLocalChatItems user nfId itemIds = do + nf <- withStore $ \db -> getNoteFolder db user nfId + (errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getLocalCI db) (L.toList itemIds)) + unless (null errs) $ toView $ CRChatErrors (Just user) errs + pure (nf, items) + where + getLocalCI :: DB.Connection -> ChatItemId -> IO (Either ChatError (CChatItem 'CTLocal)) + getLocalCI db itemId = runExceptT . withExceptT ChatErrorStore $ getLocalChatItem db user nfId itemId + forwardMsgContent :: ChatItem c d -> CM (Maybe MsgContent) + forwardMsgContent ChatItem {meta = CIMeta {itemDeleted = Just _}} = pure Nothing -- this can be deleted after selection + forwardMsgContent ChatItem {content = CISndMsgContent fmc} = pure $ Just fmc + forwardMsgContent ChatItem {content = CIRcvMsgContent fmc} = pure $ Just fmc + forwardMsgContent _ = throwChatError CEInvalidForward createNoteFolderContentItems :: User -> NoteFolderId -> NonEmpty ComposeMessageReq -> CM ChatResponse createNoteFolderContentItems user folderId cmrs = do assertNoQuotes @@ -7888,6 +7935,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 plan " *> (APIPlanForwardChatItems <$> chatRefP <*> _strP), "/_forward " *> (APIForwardChatItems <$> chatRefP <* A.space <*> chatRefP <*> _strP <*> sendMessageTTLP), "/_read user " *> (APIUserRead <$> A.decimal), "/read user" $> UserRead, diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 7268d0734a..99739cc6bf 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -298,6 +298,7 @@ data ChatCommand | APIDeleteChatItem ChatRef (NonEmpty ChatItemId) CIDeleteMode | APIDeleteMemberChatItem GroupId (NonEmpty ChatItemId) | APIChatItemReaction {chatRef :: ChatRef, chatItemId :: ChatItemId, add :: Bool, reaction :: MsgReaction} + | APIPlanForwardChatItems {fromChatRef :: ChatRef, chatItemIds :: NonEmpty ChatItemId} | APIForwardChatItems {toChatRef :: ChatRef, fromChatRef :: ChatRef, chatItemIds :: NonEmpty ChatItemId, ttl :: Maybe Int} | APIUserRead UserId | UserRead @@ -649,6 +650,7 @@ data ChatResponse | CRContactRequestAlreadyAccepted {user :: User, contact :: Contact} | CRLeftMemberUser {user :: User, groupInfo :: GroupInfo} | CRGroupDeletedUser {user :: User, groupInfo :: GroupInfo} + | CRForwardPlan {user :: User, itemsCount :: Int, chatItemIds :: [ChatItemId], forwardConfirmation :: Maybe ForwardConfirmation} | CRRcvFileDescrReady {user :: User, chatItem :: AChatItem, rcvFileTransfer :: RcvFileTransfer, rcvFileDescr :: RcvFileDescr} | CRRcvFileAccepted {user :: User, chatItem :: AChatItem} | CRRcvFileAcceptedSndCancelled {user :: User, rcvFileTransfer :: RcvFileTransfer} @@ -905,6 +907,13 @@ connectionPlanProceed = \case GLPConnectingConfirmReconnect -> True _ -> False +data ForwardConfirmation + = FCFilesNotAccepted {fileIds :: [FileTransferId]} + | FCFilesInProgress {filesCount :: Int} + | FCFilesMissing {filesCount :: Int} + | FCFilesFailed {filesCount :: Int} + deriving (Show) + newtype UserPwd = UserPwd {unUserPwd :: Text} deriving (Eq, Show) @@ -1463,6 +1472,8 @@ $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "GLP") ''GroupLinkPlan) $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CP") ''ConnectionPlan) +$(JQ.deriveJSON defaultJSON ''ForwardConfirmation) + $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CE") ''ChatErrorType) $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RHE") ''RemoteHostError) diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index f6c59cbcb5..2b21857408 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -595,6 +595,27 @@ ciFileLoaded = \case 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) deriving instance Show ACIFileStatus diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 2158599c4b..cb686ef2b0 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -203,6 +203,7 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe CRUnknownMemberBlocked u g byM um -> ttyUser u [ttyGroup' g <> ": " <> ttyMember byM <> " blocked an unknown member, creating unknown member record " <> ttyMember um] CRUnknownMemberAnnounced u g _ um m -> ttyUser u [ttyGroup' g <> ": unknown member " <> ttyMember um <> " updated to " <> ttyMember m] CRGroupDeletedUser u g -> ttyUser u [ttyGroup' g <> ": you deleted the group"] + CRForwardPlan u count itemIds fc -> ttyUser u $ viewForwardPlan count itemIds fc CRRcvFileDescrReady _ _ _ _ -> [] CRRcvFileProgressXFTP {} -> [] CRRcvFileAccepted u ci -> ttyUser u $ savingFile' ci @@ -930,6 +931,20 @@ viewUserContactLinkDeleted = "To create a new chat address use " <> highlight' "/ad" ] +viewForwardPlan :: Int -> [ChatItemId] -> Maybe ForwardConfirmation -> [StyledString] +viewForwardPlan count itemIds = maybe [forwardCount] $ \fc -> [confirmation fc, forwardCount] + where + confirmation = \case + FCFilesNotAccepted fileIds -> plain $ "Files can be received: " <> intercalate ", " (map show fileIds) + FCFilesInProgress cnt -> plain $ "Still receiving " <> show cnt <> " file(s)" + FCFilesMissing cnt -> plain $ show cnt <> " file(s) are missing" + FCFilesFailed cnt -> plain $ "Receiving " <> show cnt <> " file(s) failed" + forwardCount + | count == len = "all messages can be forwarded" + | len == 0 = "nothing to forward" + | otherwise = plain $ show len <> " message(s) out of " <> show count <> " can be forwarded" + len = length itemIds + connReqContact_ :: StyledString -> ConnReqContact -> [StyledString] connReqContact_ intro cReq = [ intro, @@ -2034,7 +2049,7 @@ 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)"] CEInvalidChatItemUpdate -> ["cannot update this item"] CEInvalidChatItemDelete -> ["cannot delete this item"] CEHasCurrentCall -> ["call already in progress"] diff --git a/tests/ChatTests/Forward.hs b/tests/ChatTests/Forward.hs index b339053abf..8f1595fd6c 100644 --- a/tests/ChatTests/Forward.hs +++ b/tests/ChatTests/Forward.hs @@ -7,7 +7,11 @@ import ChatClient import ChatTests.Utils import Control.Concurrent (threadDelay) import qualified Data.ByteString.Char8 as B -import System.Directory (copyFile, doesFileExist) +import Data.List (intercalate) +import qualified Data.Text as T +import System.Directory (copyFile, doesFileExist, removeFile) +import Simplex.Chat (fixedImagePreview) +import Simplex.Chat.Types (ImageData (..)) import Test.Hspec hiding (it) chatForwardTests :: SpecWith FilePath @@ -613,6 +617,8 @@ testForwardContactToContactMulti = alice <# "bob> hey" msgId2 <- lastItemId alice + alice ##> ("/_forward plan @2 " <> msgId1 <> "," <> msgId2) + alice <## "all messages can be forwarded" alice ##> ("/_forward @3 @2 " <> msgId1 <> "," <> msgId2) alice <# "@cath <- you @bob" alice <## " hi" @@ -642,6 +648,8 @@ testForwardGroupToGroupMulti = alice <# "#team bob> hey" msgId2 <- lastItemId alice + alice ##> ("/_forward plan #1 " <> msgId1 <> "," <> msgId2) + alice <## "all messages can be forwarded" alice ##> ("/_forward #2 #1 " <> msgId1 <> "," <> msgId2) alice <# "#club <- you #team" alice <## " hi" @@ -672,6 +680,7 @@ testMultiForwardFiles = 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.pdf" "./tests/tmp/alice_app_files/test.pdf" + copyFile "./tests/fixtures/test_1MB.pdf" "./tests/tmp/alice_app_files/test_1MB.pdf" setRelativePaths bob "./tests/tmp/bob_app_files" "./tests/tmp/bob_xftp" setRelativePaths cath "./tests/tmp/cath_app_files" "./tests/tmp/cath_xftp" connectUsers alice bob @@ -686,32 +695,46 @@ testMultiForwardFiles = -- send original files 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 <> "]") + ImageData img = fixedImagePreview + cm2 = "{\"filePath\": \"test.jpg\", \"msgContent\": {\"type\": \"image\", \"image\":\"" <> T.unpack img <> "\", \"text\": \"\"}}" + cm3 = "{\"filePath\": \"test.pdf\", \"msgContent\": {\"type\": \"file\", \"text\": \"\"}}" + cm4 = "{\"filePath\": \"test_1MB.pdf\", \"msgContent\": {\"type\": \"file\", \"text\": \"message with large file\"}}" + alice ##> ("/_send @2 json [" <> cm1 <> "," <> cm2 <> "," <> cm3 <> "," <> cm4 <> "]") alice <# "@bob message without file" - alice <# "@bob sending file 1" alice <# "/f @bob test.jpg" alice <## "use /fc 1 to cancel sending" - alice <# "@bob sending file 2" alice <# "/f @bob test.pdf" alice <## "use /fc 2 to cancel sending" + alice <# "@bob message with large file" + alice <# "/f @bob test_1MB.pdf" + alice <## "use /fc 3 to cancel sending" + bob <# "alice> message without file" - bob <# "alice> sending file 1" bob <# "alice> sends file test.jpg (136.5 KiB / 139737 bytes)" bob <## "use /fr 1 [/ | ] to receive it" - bob <# "alice> sending file 2" bob <# "alice> sends file test.pdf (266.0 KiB / 272376 bytes)" bob <## "use /fr 2 [/ | ] to receive it" + bob <# "alice> message with large file" + bob <# "alice> sends file test_1MB.pdf (1017.7 KiB / 1042157 bytes)" + bob <## "use /fr 3 [/ | ] 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_1MB.pdf) for bob" + + -- IDs to forward + let msgId1 = (read msgIdZero :: Int) + 1 + msgIds = intercalate "," $ map show [msgId1, msgId1 + 1, msgId1 + 2, msgId1 + 3, msgId1 + 4] + bob ##> ("/_forward plan @2 " <> msgIds) + bob <## "Files can be received: 1, 2, 3" + bob <## "4 message(s) out of 5 can be forwarded" bob ##> "/fr 1" bob @@ -720,6 +743,10 @@ testMultiForwardFiles = ] bob <## "completed receiving file 1 (test.jpg) from alice" + bob ##> ("/_forward plan @2 " <> msgIds) + bob <## "Files can be received: 2, 3" + bob <## "4 message(s) out of 5 can be forwarded" + bob ##> "/fr 2" bob <### [ "saving file 2 from alice to test.pdf", @@ -736,8 +763,10 @@ 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 plan @2 " <> msgIds) + bob <## "Files can be received: 3" + bob <## "all messages can be forwarded" + bob ##> ("/_forward @3 @2 " <> msgIds) -- messages printed for bob bob <# "@cath <- you @alice" @@ -747,14 +776,17 @@ testMultiForwardFiles = bob <## " message without file" bob <# "@cath <- @alice" - bob <## " sending file 1" + bob <## " test_1.jpg" bob <# "/f @cath test_1.jpg" - bob <## "use /fc 3 to cancel sending" + bob <## "use /fc 4 to cancel sending" bob <# "@cath <- @alice" - bob <## " sending file 2" + bob <## " test_1.pdf" bob <# "/f @cath test_1.pdf" - bob <## "use /fc 4 to cancel sending" + bob <## "use /fc 5 to cancel sending" + + bob <# "@cath <- @alice" + bob <## " message with large file" -- messages printed for cath cath <# "bob> -> forwarded" @@ -764,18 +796,21 @@ testMultiForwardFiles = cath <## " message without file" cath <# "bob> -> forwarded" - cath <## " sending file 1" + cath <## " test_1.jpg" cath <# "bob> sends file test_1.jpg (136.5 KiB / 139737 bytes)" cath <## "use /fr 1 [/ | ] to receive it" cath <# "bob> -> forwarded" - cath <## " sending file 2" + cath <## " test_1.pdf" cath <# "bob> sends file test_1.pdf (266.0 KiB / 272376 bytes)" cath <## "use /fr 2 [/ | ] to receive it" + cath <# "bob> -> forwarded" + cath <## " message with large file" + -- 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 4 (test_1.jpg) for cath" + bob <## "completed uploading file 5 (test_1.pdf) for cath" cath ##> "/fr 1" cath @@ -801,6 +836,26 @@ testMultiForwardFiles = dest2C <- B.readFile "./tests/tmp/cath_app_files/test_1.pdf" dest2C `shouldBe` src2B + bob ##> "/fr 3" + bob + <### [ "saving file 3 from alice to test_1MB.pdf", + "started receiving file 3 (test_1MB.pdf) from alice" + ] + bob <## "completed receiving file 3 (test_1MB.pdf) from alice" + + bob ##> ("/_forward plan @2 " <> msgIds) + bob <## "all messages can be forwarded" + + removeFile "./tests/tmp/bob_app_files/test_1MB.pdf" + bob ##> ("/_forward plan @2 " <> msgIds) + bob <## "1 file(s) are missing" + bob <## "all messages can be forwarded" + + removeFile "./tests/tmp/bob_app_files/test.pdf" + bob ##> ("/_forward plan @2 " <> msgIds) + bob <## "2 file(s) are missing" + bob <## "4 message(s) out of 5 can be forwarded" + -- deleting original file doesn't delete forwarded file checkActionDeletesFile "./tests/tmp/bob_app_files/test.jpg" $ do bob ##> "/clear alice"