diff --git a/apps/ios/SimpleXChat/APITypes.swift b/apps/ios/SimpleXChat/APITypes.swift index e5de52828d..3dc9138774 100644 --- a/apps/ios/SimpleXChat/APITypes.swift +++ b/apps/ios/SimpleXChat/APITypes.swift @@ -1848,7 +1848,6 @@ public enum ChatErrorType: Decodable, Hashable { case inlineFileProhibited(fileId: Int64) case invalidQuote case invalidForward - case forwardNoFile case invalidChatItemUpdate case invalidChatItemDelete case hasCurrentCall diff --git a/apps/simplex-bot-advanced/Main.hs b/apps/simplex-bot-advanced/Main.hs index 50d7005e34..4733dafb79 100644 --- a/apps/simplex-bot-advanced/Main.hs +++ b/apps/simplex-bot-advanced/Main.hs @@ -46,7 +46,7 @@ mySquaringBot _user cc = do CRContactConnected _ contact _ -> do contactConnected contact sendMessage cc contact welcomeMessage - CRNewChatItem _ (AChatItem _ SMDRcv (DirectChat contact) ChatItem {content = mc@CIRcvMsgContent {}}) -> do + CRNewChatItems {chatItems = (AChatItem _ SMDRcv (DirectChat contact) ChatItem {content = mc@CIRcvMsgContent {}}) : _} -> do let msg = T.unpack $ ciContentToText mc number_ = readMaybe msg :: Maybe Integer sendMessage cc contact $ case number_ of diff --git a/apps/simplex-broadcast-bot/src/Broadcast/Bot.hs b/apps/simplex-broadcast-bot/src/Broadcast/Bot.hs index 5fa3fff0a7..da021ee0b5 100644 --- a/apps/simplex-broadcast-bot/src/Broadcast/Bot.hs +++ b/apps/simplex-broadcast-bot/src/Broadcast/Bot.hs @@ -40,7 +40,7 @@ broadcastBot BroadcastBotOpts {publishers, welcomeMessage, prohibitedMessage} _u CRContactConnected _ ct _ -> do contactConnected ct sendMessage cc ct welcomeMessage - CRNewChatItem _ (AChatItem _ SMDRcv (DirectChat ct) ci@ChatItem {content = CIRcvMsgContent mc}) + CRNewChatItems {chatItems = (AChatItem _ SMDRcv (DirectChat ct) ci@ChatItem {content = CIRcvMsgContent mc}) : _} | publisher `elem` publishers -> if allowContent mc then do diff --git a/apps/simplex-directory-service/src/Directory/Events.hs b/apps/simplex-directory-service/src/Directory/Events.hs index 33b43a239b..64e6acf1d8 100644 --- a/apps/simplex-directory-service/src/Directory/Events.hs +++ b/apps/simplex-directory-service/src/Directory/Events.hs @@ -73,7 +73,7 @@ crDirectoryEvent = \case CRGroupDeleted {groupInfo} -> Just $ DEGroupDeleted groupInfo CRChatItemUpdated {chatItem = AChatItem _ SMDRcv (DirectChat ct) _} -> Just $ DEItemEditIgnored ct CRChatItemsDeleted {chatItemDeletions = ((ChatItemDeletion (AChatItem _ SMDRcv (DirectChat ct) _) _) : _), byUser = False} -> Just $ DEItemDeleteIgnored ct - CRNewChatItem {chatItem = AChatItem _ SMDRcv (DirectChat ct) ci@ChatItem {content = CIRcvMsgContent mc, meta = CIMeta {itemLive}}} -> + CRNewChatItems {chatItems = (AChatItem _ SMDRcv (DirectChat ct) ci@ChatItem {content = CIRcvMsgContent mc, meta = CIMeta {itemLive}}) : _} -> Just $ case (mc, itemLive) of (MCText t, Nothing) -> DEContactCommand ct ciId $ fromRight err $ A.parseOnly (directoryCmdP <* A.endOfInput) $ T.dropWhileEnd isSpace t _ -> DEUnsupportedMessage ct ciId diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 5899be6445..54a7f1ef0b 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -38,10 +38,11 @@ import Data.Char import Data.Constraint (Dict (..)) import Data.Either (fromRight, lefts, partitionEithers, rights) import Data.Fixed (div') +import Data.Foldable (foldr') import Data.Functor (($>)) import Data.Functor.Identity import Data.Int (Int64) -import Data.List (find, foldl', isSuffixOf, mapAccumL, partition, sortOn) +import Data.List (find, foldl', isSuffixOf, mapAccumL, partition, sortOn, zipWith4) import Data.List.NonEmpty (NonEmpty (..), nonEmpty, toList, (<|)) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) @@ -763,18 +764,18 @@ processChatCommand' vr = \case Just (CIFFGroup _ _ (Just gId) (Just fwdItemId)) -> Just <$> withFastStore (\db -> getAChatItem db vr user (ChatRef CTGroup gId) fwdItemId) _ -> pure Nothing - APISendMessage (ChatRef cType chatId) live itemTTL cm -> withUser $ \user -> case cType of + APISendMessages (ChatRef cType chatId) live itemTTL cms -> withUser $ \user -> case cType of CTDirect -> withContactLock "sendMessage" chatId $ - sendContactContentMessage user chatId live itemTTL cm Nothing + sendContactContentMessages user chatId live itemTTL (L.map (,Nothing) cms) CTGroup -> withGroupLock "sendMessage" chatId $ - sendGroupContentMessage user chatId live itemTTL cm Nothing + sendGroupContentMessages user chatId live itemTTL (L.map (,Nothing) cms) CTLocal -> pure $ chatCmdError (Just user) "not supported" CTContactRequest -> pure $ chatCmdError (Just user) "not supported" CTContactConnection -> pure $ chatCmdError (Just user) "not supported" - APICreateChatItem folderId cm -> withUser $ \user -> - createNoteFolderContentItem user folderId cm Nothing + APICreateChatItems folderId cms -> withUser $ \user -> + createNoteFolderContentItems user folderId (L.map (,Nothing) cms) APIUpdateChatItem (ChatRef cType chatId) itemId live mc -> withUser $ \user -> case cType of CTDirect -> withContactLock "updateChatItem" chatId $ do ct@Contact {contactId} <- withFastStore $ \db -> getContact db vr user chatId @@ -813,7 +814,7 @@ processChatCommand' vr = \case let changed = mc /= oldMC if changed || fromMaybe False itemLive then do - (SndMessage {msgId}, _) <- sendGroupMessage user gInfo ms (XMsgUpdate itemSharedMId mc (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive)) + SndMessage {msgId} <- sendGroupMessage user gInfo ms (XMsgUpdate itemSharedMId mc (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive)) ci' <- withFastStore' $ \db -> do currentTs <- liftIO getCurrentTime when changed $ @@ -959,7 +960,7 @@ processChatCommand' vr = \case let GroupMember {memberId = itemMemberId} = chatItemMember g ci rs <- withFastStore' $ \db -> getGroupReactions db g membership itemMemberId itemSharedMId True checkReactionAllowed rs - (SndMessage {msgId}, _) <- sendGroupMessage user g ms (XMsgReact itemSharedMId (Just itemMemberId) reaction add) + SndMessage {msgId} <- sendGroupMessage user g ms (XMsgReact itemSharedMId (Just itemMemberId) reaction add) createdAt <- liftIO getCurrentTime reactions <- withFastStore' $ \db -> do setGroupReaction db g membership itemMemberId itemSharedMId True reaction add msgId createdAt @@ -977,55 +978,83 @@ processChatCommand' vr = \case throwChatError (CECommandError $ "reaction already " <> if add then "added" else "removed") when (add && length rs >= maxMsgReactions) $ throwChatError (CECommandError "too many reactions") - APIForwardChatItem (ChatRef toCType toChatId) (ChatRef fromCType fromChatId) itemId itemTTL -> withUser $ \user -> case toCType of + APIForwardChatItems (ChatRef toCType toChatId) (ChatRef fromCType fromChatId) itemIds itemTTL -> withUser $ \user -> case toCType of CTDirect -> do - (cm, ciff) <- prepareForward user - withContactLock "forwardChatItem, to contact" toChatId $ - sendContactContentMessage user toChatId False itemTTL cm ciff + 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" CTGroup -> do - (cm, ciff) <- prepareForward user - withGroupLock "forwardChatItem, to group" toChatId $ - sendGroupContentMessage user toChatId False itemTTL cm ciff + 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" CTLocal -> do - (cm, ciff) <- prepareForward user - createNoteFolderContentItem user toChatId cm ciff + cmrs <- prepareForward user + case L.nonEmpty cmrs of + Just cmrs' -> + createNoteFolderContentItems user toChatId cmrs' + Nothing -> throwChatError $ CEInternalError "no chat items to forward" CTContactRequest -> pure $ chatCmdError (Just user) "not supported" CTContactConnection -> pure $ chatCmdError (Just user) "not supported" where - prepareForward :: User -> CM (ComposedMessage, Maybe CIForwardedFrom) + prepareForward :: User -> CM [ComposeMessageReq] prepareForward user = case fromCType of CTDirect -> withContactLock "forwardChatItem, from contact" fromChatId $ do - (ct, CChatItem _ ci) <- withFastStore $ \db -> do - ct <- getContact db vr user fromChatId - cci <- getDirectChatItem db user fromChatId itemId - pure (ct, cci) - (mc, mDir) <- forwardMC ci - file <- forwardCryptoFile ci - let ciff = forwardCIFF ci $ Just (CIFFContact (forwardName ct) mDir (Just fromChatId) (Just itemId)) - pure (ComposedMessage file Nothing mc, ciff) + 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 where - forwardName :: Contact -> ContactName - forwardName Contact {profile = LocalProfile {displayName, localAlias}} - | localAlias /= "" = localAlias - | otherwise = displayName + 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 + let itemId = chatItemId' ci + ciff = forwardCIFF ci $ Just (CIFFContact (forwardName ct) mDir (Just fromChatId) (Just itemId)) + pure (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, CChatItem _ ci) <- withFastStore $ \db -> do - gInfo <- getGroupInfo db vr user fromChatId - cci <- getGroupChatItem db user fromChatId itemId - pure (gInfo, cci) - (mc, mDir) <- forwardMC ci - file <- forwardCryptoFile ci - let ciff = forwardCIFF ci $ Just (CIFFGroup (forwardName gInfo) mDir (Just fromChatId) (Just itemId)) - pure (ComposedMessage file Nothing mc, ciff) + 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 where - forwardName :: GroupInfo -> ContactName - forwardName GroupInfo {groupProfile = GroupProfile {displayName}} = displayName + 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 + let itemId = chatItemId' ci + ciff = forwardCIFF ci $ Just (CIFFGroup (forwardName gInfo) mDir (Just fromChatId) (Just itemId)) + pure (ComposedMessage file Nothing mc, ciff) + where + forwardName :: GroupInfo -> ContactName + forwardName GroupInfo {groupProfile = GroupProfile {displayName}} = displayName CTLocal -> do - (CChatItem _ ci) <- withFastStore $ \db -> getLocalChatItem db user fromChatId itemId - (mc, _) <- forwardMC ci - file <- forwardCryptoFile ci - let ciff = forwardCIFF ci Nothing - pure (ComposedMessage file Nothing mc, ciff) + (errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getLocalCI db) (L.toList itemIds)) + unless (null errs) $ toView $ CRChatErrors (Just user) errs + 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 _ ci) = do + (mc, _) <- forwardMC ci + file <- forwardCryptoFile ci + let ciff = forwardCIFF ci Nothing + pure (ComposedMessage file Nothing mc, ciff) CTContactRequest -> throwChatError $ CECommandError "not supported" CTContactConnection -> throwChatError $ CECommandError "not supported" where @@ -1042,27 +1071,26 @@ processChatCommand' vr = \case forwardCryptoFile :: ChatItem c d -> CM (Maybe CryptoFile) forwardCryptoFile ChatItem {file = Nothing} = pure Nothing forwardCryptoFile ChatItem {file = Just ciFile} = case ciFile of - CIFile {fileName, fileStatus, fileSource = Just fromCF@CryptoFile {filePath}} - | ciFileLoaded fileStatus -> - chatReadVar filesFolder >>= \case - Nothing -> - ifM (doesFileExist filePath) (pure $ Just fromCF) (throwChatError CEForwardNoFile) - 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) - ) - (throwChatError CEForwardNoFile) - _ -> throwChatError CEForwardNoFile + 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 @@ -1271,7 +1299,7 @@ processChatCommand' vr = \case let call' = Call {contactId, callId, chatItemId = chatItemId' ci, callState, callTs = chatItemTs' ci} call_ <- atomically $ TM.lookupInsert contactId call' calls forM_ call_ $ \call -> updateCallItemStatus user ct call WCSDisconnected Nothing - toView $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci) + toView $ CRNewChatItems user [AChatItem SCTDirect SMDSnd (DirectChat ct) ci] ok user else pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (chatFeatureNameText CFCalls)) SendCallInvitation cName callType -> withUser $ \user -> do @@ -1784,17 +1812,17 @@ processChatCommand' vr = \case contactId <- withFastStore $ \db -> getContactIdByName db user fromContactName forwardedItemId <- withFastStore $ \db -> getDirectChatItemIdByText' db user contactId forwardedMsg toChatRef <- getChatRef user toChatName - processChatCommand $ APIForwardChatItem toChatRef (ChatRef CTDirect contactId) forwardedItemId Nothing + processChatCommand $ APIForwardChatItems toChatRef (ChatRef CTDirect contactId) (forwardedItemId :| []) Nothing 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 $ APIForwardChatItem toChatRef (ChatRef CTGroup groupId) forwardedItemId Nothing + processChatCommand $ APIForwardChatItems toChatRef (ChatRef CTGroup groupId) (forwardedItemId :| []) Nothing ForwardLocalMessage toChatName forwardedMsg -> withUser $ \user -> do folderId <- withFastStore (`getUserNoteFolderId` user) forwardedItemId <- withFastStore $ \db -> getLocalChatItemIdByText' db user folderId forwardedMsg toChatRef <- getChatRef user toChatName - processChatCommand $ APIForwardChatItem toChatRef (ChatRef CTLocal folderId) forwardedItemId Nothing + processChatCommand $ APIForwardChatItems toChatRef (ChatRef CTLocal folderId) (forwardedItemId :| []) Nothing SendMessage (ChatName cType name) msg -> withUser $ \user -> do let mc = MCText msg case cType of @@ -1802,7 +1830,7 @@ processChatCommand' vr = \case withFastStore' (\db -> runExceptT $ getContactIdByName db user name) >>= \case Right ctId -> do let chatRef = ChatRef CTDirect ctId - processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage Nothing Nothing mc + processChatCommand $ APISendMessages chatRef False Nothing (ComposedMessage Nothing Nothing mc :| []) Left _ -> withFastStore' (\db -> runExceptT $ getActiveMembersByName db vr user name) >>= \case Right [(gInfo, member)] -> do @@ -1816,11 +1844,11 @@ processChatCommand' vr = \case CTGroup -> do gId <- withFastStore $ \db -> getGroupIdByName db user name let chatRef = ChatRef CTGroup gId - processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage Nothing Nothing mc + processChatCommand $ APISendMessages chatRef False Nothing (ComposedMessage Nothing Nothing mc :| []) CTLocal | name == "" -> do folderId <- withFastStore (`getUserNoteFolderId` user) - processChatCommand . APICreateChatItem folderId $ ComposedMessage Nothing Nothing mc + processChatCommand $ APICreateChatItems folderId (ComposedMessage Nothing Nothing mc :| []) | otherwise -> throwChatError $ CECommandError "not supported" _ -> throwChatError $ CECommandError "not supported" SendMemberContactMessage gName mName msg -> withUser $ \user -> do @@ -1839,11 +1867,11 @@ processChatCommand' vr = \case cr -> pure cr Just ctId -> do let chatRef = ChatRef CTDirect ctId - processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage Nothing Nothing mc + processChatCommand $ APISendMessages chatRef False Nothing (ComposedMessage Nothing Nothing mc :| []) SendLiveMessage chatName msg -> withUser $ \user -> do chatRef <- getChatRef user chatName let mc = MCText msg - processChatCommand . APISendMessage chatRef True Nothing $ ComposedMessage Nothing Nothing mc + processChatCommand $ APISendMessages chatRef True Nothing (ComposedMessage Nothing Nothing mc :| []) SendMessageBroadcast msg -> withUser $ \user -> do contacts <- withFastStore' $ \db -> getUserContacts db vr user withChatLock "sendMessageBroadcast" . procCmd $ do @@ -1884,7 +1912,7 @@ processChatCommand' vr = \case contactId <- withFastStore $ \db -> getContactIdByName db user cName quotedItemId <- withFastStore $ \db -> getDirectChatItemIdByText db userId contactId msgDir quotedMsg let mc = MCText msg - processChatCommand . APISendMessage (ChatRef CTDirect contactId) False Nothing $ ComposedMessage Nothing (Just quotedItemId) mc + processChatCommand $ APISendMessages (ChatRef CTDirect contactId) False Nothing (ComposedMessage Nothing (Just quotedItemId) mc :| []) DeleteMessage chatName deletedMsg -> withUser $ \user -> do chatRef <- getChatRef user chatName deletedItemId <- getSentChatItemIdByText user chatRef deletedMsg @@ -1995,9 +2023,9 @@ processChatCommand' vr = \case (Just ct, Just cReq) -> sendGrpInvitation user ct gInfo (m :: GroupMember) {memberRole = memRole} cReq _ -> throwChatError $ CEGroupCantResendInvitation gInfo cName _ -> do - (msg, _) <- sendGroupMessage user gInfo members $ XGrpMemRole mId memRole + msg <- sendGroupMessage user gInfo members $ XGrpMemRole mId memRole ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent gEvent) - toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci) + toView $ CRNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci] pure CRMemberRoleUser {user, groupInfo = gInfo, member = m {memberRole = memRole}, fromRole = mRole, toRole = memRole} APIBlockMemberForAll groupId memberId blocked -> withUser $ \user -> do Group gInfo@GroupInfo {membership} members <- withFastStore $ \db -> getGroup db vr user groupId @@ -2014,7 +2042,7 @@ processChatCommand' vr = \case msg <- sendGroupMessage' user gInfo remainingMembers event let ciContent = CISndGroupEvent $ SGEMemberBlocked memberId (fromLocalProfile bmp) blocked ci <- saveSndChatItem user (CDGroupSnd gInfo) msg ciContent - toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci) + toView $ CRNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci] bm' <- withFastStore $ \db -> do liftIO $ updateGroupMemberBlocked db user groupId memberId mrs getGroupMember db vr user groupId memberId @@ -2036,9 +2064,9 @@ processChatCommand' vr = \case deleteMemberConnection user m withFastStore' $ \db -> deleteGroupMember db user m _ -> do - (msg, _) <- sendGroupMessage user gInfo members $ XGrpMemDel mId + msg <- sendGroupMessage user gInfo members $ XGrpMemDel mId ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent $ SGEMemberDeleted memberId (fromLocalProfile memberProfile)) - toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci) + toView $ CRNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci] deleteMemberConnection' user m True -- undeleted "member connected" chat item will prevent deletion of member record deleteOrUpdateMemberRecord user m @@ -2050,7 +2078,7 @@ processChatCommand' vr = \case 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) + toView $ CRNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci] -- TODO delete direct connections that were unused deleteGroupLinkIfExists user gInfo -- member records are not deleted to keep history @@ -2149,7 +2177,7 @@ processChatCommand' vr = \case let ct' = ct {contactGrpInvSent = True} forM_ msgContent_ $ \mc -> do ci <- saveSndChatItem user (CDDirectSnd ct') sndMsg (CISndMsgContent mc) - toView $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct') ci) + toView $ CRNewChatItems user [AChatItem SCTDirect SMDSnd (DirectChat ct') ci] pure $ CRNewMemberContactSentInv user ct' g m _ -> throwChatError CEGroupMemberNotActive CreateGroupLink gName mRole -> withUser $ \user -> do @@ -2168,7 +2196,7 @@ processChatCommand' vr = \case groupId <- withFastStore $ \db -> getGroupIdByName db user gName quotedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user groupId cName quotedMsg let mc = MCText msg - processChatCommand . APISendMessage (ChatRef CTGroup groupId) False Nothing $ ComposedMessage Nothing (Just quotedItemId) mc + processChatCommand $ APISendMessages (ChatRef CTGroup groupId) False Nothing (ComposedMessage Nothing (Just quotedItemId) mc :| []) ClearNoteFolder -> withUser $ \user -> do folderId <- withFastStore (`getUserNoteFolderId` user) processChatCommand $ APIClearChat (ChatRef CTLocal folderId) @@ -2208,8 +2236,8 @@ processChatCommand' vr = \case SendFile chatName f -> withUser $ \user -> do chatRef <- getChatRef user chatName case chatRef of - ChatRef CTLocal folderId -> processChatCommand . APICreateChatItem folderId $ ComposedMessage (Just f) Nothing (MCFile "") - _ -> processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage (Just f) Nothing (MCFile "") + ChatRef CTLocal folderId -> processChatCommand $ APICreateChatItems folderId (ComposedMessage (Just f) Nothing (MCFile "") :| []) + _ -> processChatCommand $ APISendMessages chatRef False Nothing (ComposedMessage (Just f) Nothing (MCFile "") :| []) SendImage chatName f@(CryptoFile fPath _) -> withUser $ \user -> do chatRef <- getChatRef user chatName filePath <- lift $ toFSFilePath fPath @@ -2217,7 +2245,7 @@ processChatCommand' vr = \case fileSize <- getFileSize filePath unless (fileSize <= maxImageSize) $ throwChatError CEFileImageSize {filePath} -- TODO include file description for preview - processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage (Just f) Nothing (MCImage "" fixedImagePreview) + processChatCommand $ APISendMessages chatRef False Nothing (ComposedMessage (Just f) Nothing (MCImage "" fixedImagePreview) :| []) ForwardFile chatName fileId -> forwardFile chatName fileId SendFile ForwardImage chatName fileId -> forwardFile chatName fileId SendImage SendFileDescription _chatName _f -> pure $ chatCmdError Nothing "TODO" @@ -2626,11 +2654,11 @@ processChatCommand' vr = \case assertUserGroupRole g GROwner when (n /= n') $ checkValidName n' g' <- withStore $ \db -> updateGroupProfile db user g p' - (msg, _) <- sendGroupMessage user g' ms (XGrpInfo p') + msg <- sendGroupMessage user g' ms (XGrpInfo p') let cd = CDGroupSnd g' unless (sameGroupProfileInfo p p') $ do ci <- saveSndChatItem user cd msg (CISndGroupEvent $ SGEGroupUpdated p') - toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat g') ci) + toView $ CRNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat g') ci] createGroupFeatureChangedItems user cd CISndGroupFeature g g' pure $ CRGroupUpdated user g g' Nothing checkValidName :: GroupName -> CM () @@ -2712,7 +2740,7 @@ processChatCommand' vr = \case let content = CISndGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole timed_ <- contactCITimed ct ci <- saveSndChatItem' user (CDDirectSnd ct) msg content Nothing Nothing Nothing timed_ False - toView $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci) + toView $ CRNewChatItems user [AChatItem SCTDirect SMDSnd (DirectChat ct) ci] forM_ (timed_ >>= timedDeleteAt') $ startProximateTimedItemThread user (ChatRef CTDirect contactId, chatItemId' ci) drgRandomBytes :: Int -> CM ByteString @@ -2858,77 +2886,154 @@ processChatCommand' vr = \case forM_ (timed_ >>= timedDeleteAt') $ startProximateTimedItemThread user (ChatRef CTDirect contactId, itemId) _ -> pure () -- prohibited - sendContactContentMessage :: User -> ContactId -> Bool -> Maybe Int -> ComposedMessage -> Maybe CIForwardedFrom -> CM ChatResponse - sendContactContentMessage user contactId live itemTTL (ComposedMessage file_ quotedItemId_ mc) itemForwarded = do + sendContactContentMessages :: User -> ContactId -> Bool -> Maybe Int -> NonEmpty ComposeMessageReq -> CM ChatResponse + sendContactContentMessages user contactId live itemTTL cmrs = do + assertMultiSendable live cmrs ct@Contact {contactUsed} <- withFastStore $ \db -> getContact db vr user contactId assertDirectAllowed user MDSnd ct XMsgNew_ + assertVoiceAllowed ct unless contactUsed $ withFastStore' $ \db -> updateContactUsed db user ct - if isVoice mc && not (featureAllowed SCFVoice forUser ct) - then pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (chatFeatureNameText CFVoice)) - else do - (fInv_, ciFile_) <- L.unzip <$> setupSndFileTransfer ct - timed_ <- sndContactCITimed live ct itemTTL - (msgContainer, quotedItem_) <- prepareMsg fInv_ timed_ - (msg, _) <- sendDirectContactMessage user ct (XMsgNew msgContainer) - ci <- saveSndChatItem' user (CDDirectSnd ct) msg (CISndMsgContent mc) ciFile_ quotedItem_ itemForwarded timed_ live - forM_ (timed_ >>= timedDeleteAt') $ - startProximateTimedItemThread user (ChatRef CTDirect contactId, chatItemId' ci) - pure $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci) + processComposedMessages ct where - setupSndFileTransfer :: Contact -> CM (Maybe (FileInvitation, CIFile 'MDSnd)) - setupSndFileTransfer ct = forM file_ $ \file -> do - fileSize <- checkSndFile file - xftpSndFileTransfer user file fileSize 1 $ CGContact ct - prepareMsg :: Maybe FileInvitation -> Maybe CITimed -> CM (MsgContainer, Maybe (CIQuote 'CTDirect)) - prepareMsg fInv_ timed_ = case (quotedItemId_, itemForwarded) of - (Nothing, Nothing) -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) - (Nothing, Just _) -> pure (MCForward (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) - (Just quotedItemId, Nothing) -> do - CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <- - withFastStore $ \db -> getDirectChatItem db user contactId quotedItemId - (origQmc, qd, sent) <- quoteData qci - let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Nothing} - qmc = quoteContent mc origQmc file - quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText} - pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem) - (Just _, Just _) -> throwChatError CEInvalidQuote + assertVoiceAllowed :: Contact -> CM () + assertVoiceAllowed ct = + when (not (featureAllowed SCFVoice forUser ct) && any (\(ComposedMessage {msgContent}, _) -> isVoice msgContent) cmrs) $ + throwChatError (CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFVoice)) + processComposedMessages :: Contact -> CM ChatResponse + processComposedMessages ct = do + (fInvs_, ciFiles_) <- L.unzip <$> setupSndFileTransfers + timed_ <- sndContactCITimed live ct itemTTL + (msgContainers, quotedItems_) <- L.unzip <$> prepareMsgs (L.zip cmrs fInvs_) timed_ + msgs_ <- sendDirectContactMessages user ct $ L.map XMsgNew msgContainers + let itemsData = prepareSndItemsData msgs_ cmrs ciFiles_ quotedItems_ + (errs, cis) <- partitionEithers <$> saveSndChatItems user (CDDirectSnd ct) itemsData timed_ live + unless (null errs) $ toView $ CRChatErrors (Just user) errs + forM_ (timed_ >>= timedDeleteAt') $ \deleteAt -> + forM_ cis $ \ci -> + startProximateTimedItemThread user (ChatRef CTDirect contactId, chatItemId' ci) deleteAt + pure $ CRNewChatItems user (map (AChatItem SCTDirect SMDSnd (DirectChat ct)) cis) where - quoteData :: ChatItem c d -> CM (MsgContent, CIQDirection 'CTDirect, Bool) - quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} = throwChatError CEInvalidQuote - quoteData ChatItem {content = CISndMsgContent qmc} = pure (qmc, CIQDirectSnd, True) - quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False) - quoteData _ = throwChatError CEInvalidQuote - sendGroupContentMessage :: User -> GroupId -> Bool -> Maybe Int -> ComposedMessage -> Maybe CIForwardedFrom -> CM ChatResponse - sendGroupContentMessage user groupId live itemTTL (ComposedMessage file_ quotedItemId_ mc) itemForwarded = do + setupSndFileTransfers :: CM (NonEmpty (Maybe FileInvitation, Maybe (CIFile 'MDSnd))) + setupSndFileTransfers = + forM cmrs $ \(ComposedMessage {fileSource = file_}, _) -> case file_ of + Just file -> do + fileSize <- checkSndFile file + (fInv, ciFile) <- xftpSndFileTransfer user file fileSize 1 $ CGContact ct + pure (Just fInv, Just ciFile) + Nothing -> pure (Nothing, Nothing) + prepareMsgs :: NonEmpty (ComposeMessageReq, Maybe FileInvitation) -> Maybe CITimed -> CM (NonEmpty (MsgContainer, Maybe (CIQuote 'CTDirect))) + prepareMsgs cmsFileInvs timed_ = + forM cmsFileInvs $ \((ComposedMessage {quotedItemId, msgContent = mc}, itemForwarded), fInv_) -> + case (quotedItemId, itemForwarded) of + (Nothing, Nothing) -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) + (Nothing, Just _) -> pure (MCForward (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) + (Just qiId, Nothing) -> do + CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <- + withFastStore $ \db -> getDirectChatItem db user contactId qiId + (origQmc, qd, sent) <- quoteData qci + let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Nothing} + qmc = quoteContent mc origQmc file + quotedItem = CIQuote {chatDir = qd, itemId = Just qiId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText} + pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem) + (Just _, Just _) -> throwChatError CEInvalidQuote + where + quoteData :: ChatItem c d -> CM (MsgContent, CIQDirection 'CTDirect, Bool) + quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} = throwChatError CEInvalidQuote + quoteData ChatItem {content = CISndMsgContent qmc} = pure (qmc, CIQDirectSnd, True) + quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False) + quoteData _ = throwChatError CEInvalidQuote + sendGroupContentMessages :: User -> GroupId -> Bool -> Maybe Int -> NonEmpty ComposeMessageReq -> CM ChatResponse + sendGroupContentMessages user groupId live itemTTL cmrs = do + assertMultiSendable live cmrs g@(Group gInfo _) <- withFastStore $ \db -> getGroup db vr user groupId assertUserGroupRole gInfo GRAuthor - send g + assertGroupContentAllowed gInfo + processComposedMessages g where - send g@(Group gInfo@GroupInfo {membership} ms) = - case prohibitedGroupContent gInfo membership mc file_ of - Just f -> notAllowedError f - Nothing -> do - (fInv_, ciFile_) <- L.unzip <$> setupSndFileTransfer g (length $ filter memberCurrent ms) - timed_ <- sndGroupCITimed live gInfo itemTTL - (msgContainer, quotedItem_) <- prepareGroupMsg user gInfo mc quotedItemId_ itemForwarded fInv_ timed_ live - (msg, r) <- sendGroupMessage user gInfo ms (XMsgNew msgContainer) - ci <- saveSndChatItem' user (CDGroupSnd gInfo) msg (CISndMsgContent mc) ciFile_ quotedItem_ itemForwarded timed_ live + assertGroupContentAllowed :: GroupInfo -> CM () + assertGroupContentAllowed gInfo@GroupInfo {membership} = + case findProhibited (L.toList cmrs) of + Just f -> throwChatError (CECommandError $ "feature not allowed " <> T.unpack (groupFeatureNameText f)) + Nothing -> pure () + where + findProhibited :: [ComposeMessageReq] -> Maybe GroupFeature + findProhibited = + foldr' + (\(ComposedMessage {fileSource, msgContent = mc}, _) acc -> prohibitedGroupContent gInfo membership mc fileSource <|> acc) + Nothing + processComposedMessages :: Group -> CM ChatResponse + processComposedMessages g@(Group gInfo ms) = do + (fInvs_, ciFiles_) <- L.unzip <$> setupSndFileTransfers (length $ filter memberCurrent ms) + timed_ <- sndGroupCITimed live gInfo itemTTL + (msgContainers, quotedItems_) <- L.unzip <$> prepareMsgs (L.zip cmrs fInvs_) timed_ + (msgs_, gsr) <- sendGroupMessages user gInfo ms $ L.map XMsgNew msgContainers + let itemsData = prepareSndItemsData (L.toList msgs_) cmrs ciFiles_ quotedItems_ + cis_ <- saveSndChatItems user (CDGroupSnd gInfo) itemsData timed_ live + createMemberSndStatuses cis_ msgs_ gsr + let (errs, cis) = partitionEithers cis_ + unless (null errs) $ toView $ CRChatErrors (Just user) errs + forM_ (timed_ >>= timedDeleteAt') $ \deleteAt -> + forM_ cis $ \ci -> + startProximateTimedItemThread user (ChatRef CTGroup groupId, chatItemId' ci) deleteAt + pure $ CRNewChatItems user (map (AChatItem SCTGroup SMDSnd (GroupChat gInfo)) cis) + where + setupSndFileTransfers :: Int -> CM (NonEmpty (Maybe FileInvitation, Maybe (CIFile 'MDSnd))) + setupSndFileTransfers n = + forM cmrs $ \(ComposedMessage {fileSource = file_}, _) -> case file_ of + Just file -> do + fileSize <- checkSndFile file + (fInv, ciFile) <- xftpSndFileTransfer user file fileSize n $ CGGroup g + pure (Just fInv, Just ciFile) + Nothing -> pure (Nothing, Nothing) + prepareMsgs :: NonEmpty (ComposeMessageReq, Maybe FileInvitation) -> Maybe CITimed -> CM (NonEmpty (MsgContainer, Maybe (CIQuote 'CTGroup))) + prepareMsgs cmsFileInvs timed_ = + forM cmsFileInvs $ \((ComposedMessage {quotedItemId, msgContent = mc}, itemForwarded), fInv_) -> + prepareGroupMsg user gInfo mc quotedItemId itemForwarded fInv_ timed_ live + createMemberSndStatuses :: + [Either ChatError (ChatItem 'CTGroup 'MDSnd)] -> + NonEmpty (Either ChatError SndMessage) -> + GroupSndResult -> + CM () + createMemberSndStatuses cis_ msgs_ GroupSndResult {sentTo, pending, forwarded} = do + let msgToItem = mapMsgToItem withFastStore' $ \db -> do - let GroupSndResult {sentTo, pending, forwarded} = mkGroupSndResult r - createMemberSndStatuses db ci sentTo GSSNew - createMemberSndStatuses db ci forwarded GSSForwarded - createMemberSndStatuses db ci pending GSSInactive - forM_ (timed_ >>= timedDeleteAt') $ - startProximateTimedItemThread user (ChatRef CTGroup groupId, chatItemId' ci) - pure $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci) + forM_ sentTo (processSentTo db msgToItem) + forM_ forwarded (processForwarded db) + forM_ pending (processPending db msgToItem) where - createMemberSndStatuses db ci ms' gss = - forM_ ms' $ \GroupMember {groupMemberId} -> createGroupSndStatus db (chatItemId' ci) groupMemberId gss - notAllowedError f = pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (groupFeatureNameText f)) - setupSndFileTransfer :: Group -> Int -> CM (Maybe (FileInvitation, CIFile 'MDSnd)) - setupSndFileTransfer g n = forM file_ $ \file -> do - fileSize <- checkSndFile file - xftpSndFileTransfer user file fileSize n $ CGGroup g + mapMsgToItem :: Map MessageId ChatItemId + mapMsgToItem = foldr' addItem M.empty (zip (L.toList msgs_) cis_) + where + addItem (Right SndMessage {msgId}, Right ci) m = M.insert msgId (chatItemId' ci) m + addItem _ m = m + processSentTo :: DB.Connection -> Map MessageId ChatItemId -> (GroupMemberId, Either ChatError [MessageId], Either ChatError ([Int64], PQEncryption)) -> IO () + processSentTo db msgToItem (mId, msgIds_, deliveryResult) = forM_ msgIds_ $ \msgIds -> do + let ciIds = mapMaybe (`M.lookup` msgToItem) msgIds + status = case deliveryResult of + Right _ -> GSSNew + Left e -> GSSError $ SndErrOther $ tshow e + forM_ ciIds $ \ciId -> createGroupSndStatus db ciId mId status + processForwarded :: DB.Connection -> GroupMember -> IO () + processForwarded db GroupMember {groupMemberId} = + forM_ cis_ $ \ci_ -> + forM_ ci_ $ \ci -> createGroupSndStatus db (chatItemId' ci) groupMemberId GSSForwarded + processPending :: DB.Connection -> Map MessageId ChatItemId -> (GroupMemberId, Either ChatError MessageId, Either ChatError ()) -> IO () + processPending db msgToItem (mId, msgId_, pendingResult) = forM_ msgId_ $ \msgId -> do + let ciId_ = M.lookup msgId msgToItem + status = case pendingResult of + Right _ -> GSSInactive + Left e -> GSSError $ SndErrOther $ tshow e + forM_ ciId_ $ \ciId -> createGroupSndStatus db ciId mId status + assertMultiSendable :: Bool -> NonEmpty ComposeMessageReq -> CM () + assertMultiSendable live cmrs + | length cmrs == 1 = pure () + | otherwise = + -- When sending multiple messages only single quote is allowed. + -- This is to support case of sending multiple attachments while also quoting another message. + -- UI doesn't allow composing with multiple quotes, so api prohibits it as well, and doesn't bother + -- batching retrieval of quoted messages (prepareMsgs). + when (live || length (L.filter (\(ComposedMessage {quotedItemId}, _) -> isJust quotedItemId) cmrs) > 1) $ + throwChatError (CECommandError "invalid multi send: live and more than one quote not supported") xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> ContactOrGroup -> CM (FileInvitation, CIFile 'MDSnd) xftpSndFileTransfer user file fileSize n contactOrGroup = do (fInv, ciFile, ft) <- xftpSndFileTransfer_ user file fileSize n $ Just contactOrGroup @@ -2944,27 +3049,58 @@ processChatCommand' vr = \case \db -> createSndFTDescrXFTP db user (Just m) conn ft dummyFileDescr saveMemberFD _ = pure () pure (fInv, ciFile) - createNoteFolderContentItem :: User -> NoteFolderId -> ComposedMessage -> Maybe CIForwardedFrom -> CM ChatResponse - createNoteFolderContentItem user folderId (ComposedMessage file_ quotedItemId_ mc) itemForwarded = do - forM_ quotedItemId_ $ \_ -> throwError $ ChatError $ CECommandError "not supported" + prepareSndItemsData :: + [Either ChatError SndMessage] -> + NonEmpty ComposeMessageReq -> + NonEmpty (Maybe (CIFile 'MDSnd)) -> + NonEmpty (Maybe (CIQuote c)) -> + [Either ChatError (NewSndChatItemData c)] + prepareSndItemsData msgs_ cmrs' ciFiles_ quotedItems_ = + [ ( case msg_ of + Right msg -> Right $ NewSndChatItemData msg (CISndMsgContent msgContent) f q itemForwarded + Left e -> Left e -- step over original error + ) + | (msg_, (ComposedMessage {msgContent}, itemForwarded), f, q) <- + zipWith4 (,,,) msgs_ (L.toList cmrs') (L.toList ciFiles_) (L.toList quotedItems_) + ] + createNoteFolderContentItems :: User -> NoteFolderId -> NonEmpty ComposeMessageReq -> CM ChatResponse + createNoteFolderContentItems user folderId cmrs = do + assertNoQuotes nf <- withFastStore $ \db -> getNoteFolder db user folderId createdAt <- liftIO getCurrentTime - let content = CISndMsgContent mc - let cd = CDLocalSnd nf - ciId <- createLocalChatItem user cd content itemForwarded createdAt - ciFile_ <- forM file_ $ \cf@CryptoFile {filePath, cryptoArgs} -> do - fsFilePath <- lift $ toFSFilePath filePath - fileSize <- liftIO $ CF.getFileContentsSize $ CryptoFile fsFilePath cryptoArgs - chunkSize <- asks $ fileChunkSize . config - withFastStore' $ \db -> do - fileId <- createLocalFile CIFSSndStored db user nf ciId createdAt cf fileSize chunkSize - pure CIFile {fileId, fileName = takeFileName filePath, fileSize, fileSource = Just cf, fileStatus = CIFSSndStored, fileProtocol = FPLocal} - let ci = mkChatItem cd ciId content ciFile_ Nothing Nothing itemForwarded Nothing False createdAt Nothing createdAt - pure . CRNewChatItem user $ AChatItem SCTLocal SMDSnd (LocalChat nf) ci + ciFiles_ <- createLocalFiles nf createdAt + let itemsData = prepareLocalItemsData cmrs ciFiles_ + cis <- createLocalChatItems user (CDLocalSnd nf) itemsData createdAt + pure $ CRNewChatItems user (map (AChatItem SCTLocal SMDSnd (LocalChat nf)) cis) + where + assertNoQuotes :: CM () + assertNoQuotes = + when (any (\(ComposedMessage {quotedItemId}, _) -> isJust quotedItemId) cmrs) $ + throwChatError (CECommandError "createNoteFolderContentItems: quotes not supported") + createLocalFiles :: NoteFolder -> UTCTime -> CM (NonEmpty (Maybe (CIFile 'MDSnd))) + createLocalFiles nf createdAt = + forM cmrs $ \(ComposedMessage {fileSource = file_}, _) -> + forM file_ $ \cf@CryptoFile {filePath, cryptoArgs} -> do + fsFilePath <- lift $ toFSFilePath filePath + fileSize <- liftIO $ CF.getFileContentsSize $ CryptoFile fsFilePath cryptoArgs + chunkSize <- asks $ fileChunkSize . config + withFastStore' $ \db -> do + fileId <- createLocalFile CIFSSndStored db user nf createdAt cf fileSize chunkSize + pure CIFile {fileId, fileName = takeFileName filePath, fileSize, fileSource = Just cf, fileStatus = CIFSSndStored, fileProtocol = FPLocal} + prepareLocalItemsData :: + NonEmpty ComposeMessageReq -> + NonEmpty (Maybe (CIFile 'MDSnd)) -> + [(CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom)] + prepareLocalItemsData cmrs' ciFiles_ = + [ (CISndMsgContent mc, f, itemForwarded) + | ((ComposedMessage {msgContent = mc}, itemForwarded), f) <- zip (L.toList cmrs') (L.toList ciFiles_) + ] getConnQueueInfo user Connection {connId, agentConnId = AgentConnId acId} = do msgInfo <- withFastStore' (`getLastRcvMsgInfo` connId) CRQueueInfo user msgInfo <$> withAgent (`getConnectionQueueInfo` acId) +type ComposeMessageReq = (ComposedMessage, Maybe CIForwardedFrom) + contactCITimed :: Contact -> CM (Maybe CITimed) contactCITimed ct = sndContactCITimed False ct Nothing @@ -4398,7 +4534,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = Just AutoAccept {autoReply = Just mc} -> do (msg, _) <- sendDirectContactMessage user ct (XMsgNew $ MCSimple (extMsgContent mc Nothing)) ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc) - toView $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci) + toView $ CRNewChatItems user [AChatItem SCTDirect SMDSnd (DirectChat ct) ci] _ -> pure () processGroupMessage :: AEvent e -> ConnectionEntity -> Connection -> GroupInfo -> GroupMember -> CM () @@ -4732,7 +4868,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = let GroupMember {memberId} = m ms = forwardedToGroupMembers (introducedMembers <> invitedMembers) forwardedMsgs' events = L.map (\cm -> XGrpMsgForward memberId cm brokerTs) forwardedMsgs' - unless (null ms) $ sendGroupMessages user gInfo ms events + unless (null ms) $ void $ sendGroupMessages user gInfo ms events RCVD msgMeta msgRcpt -> withAckMessage' "group rcvd" agentConnId msgMeta $ groupMsgReceived gInfo m conn msgMeta msgRcpt @@ -5240,7 +5376,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = newChatItem ciContent ciFile_ timed_ live = do ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs ciContent ciFile_ timed_ live reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getDirectCIReactions db ct sharedMsgId) sharedMsgId_ - toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci {reactions}) + toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci {reactions}] autoAcceptFile :: Maybe (RcvFileTransfer, CIFile 'MDRcv) -> CM () autoAcceptFile = mapM_ $ \(ft, CIFile {fileSize}) -> do @@ -5544,7 +5680,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol} ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs (CIRcvMsgContent $ MCFile "") ciFile Nothing False - toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci) + toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci] where brokerTs = metaBrokerTs msgMeta @@ -5711,7 +5847,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = groupMsgToView :: forall d. MsgDirectionI d => GroupInfo -> ChatItem 'CTGroup d -> CM () groupMsgToView gInfo ci = - toView $ CRNewChatItem user (AChatItem SCTGroup (msgDirection @d) (GroupChat gInfo) ci) + toView $ CRNewChatItems user [AChatItem SCTGroup (msgDirection @d) (GroupChat gInfo) ci] processGroupInvitation :: Contact -> GroupInvitation -> RcvMessage -> MsgMeta -> CM () processGroupInvitation ct inv msg msgMeta = do @@ -5738,7 +5874,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = let content = CIRcvGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole ci <- saveRcvChatItem user (CDDirectRcv ct) msg brokerTs content withStore' $ \db -> setGroupInvitationChatItemId db user groupId (chatItemId' ci) - toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci) + toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci] toView $ CRReceivedGroupInvitation {user, groupInfo = gInfo, contact = ct, fromMemberRole = fromRole, memberRole = memRole} where brokerTs = metaBrokerTs msgMeta @@ -5765,7 +5901,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = activeConn' <- forM (contactConn ct') $ \conn -> pure conn {connStatus = ConnDeleted} let ct'' = ct' {activeConn = activeConn'} :: Contact ci <- saveRcvChatItem user (CDDirectRcv ct'') msg brokerTs (CIRcvDirectEvent RDEContactDeleted) - toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct'') ci) + toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct'') ci] toView $ CRContactDeletedByContact user ct'' else do contactConns <- withStore' $ \db -> getContactConnections db vr userId c @@ -5966,14 +6102,14 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = call_ <- atomically (TM.lookupInsert contactId call' calls) forM_ call_ $ \call -> updateCallItemStatus user ct call WCSDisconnected Nothing toView $ CRCallInvitation RcvCallInvitation {user, contact = ct, callType, sharedKey, callTs = chatItemTs' ci} - toView $ CRNewChatItem user $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci + toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci] else featureRejected CFCalls where brokerTs = metaBrokerTs msgMeta saveCallItem status = saveRcvChatItem user (CDDirectRcv ct) msg brokerTs (CIRcvCall status 0) featureRejected f = do ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs (CIRcvChatFeatureRejected f) Nothing Nothing False - toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci) + toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci] -- to party initiating call xCallOffer :: Contact -> CallId -> CallOffer -> RcvMessage -> CM () @@ -6426,7 +6562,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = toView $ CRNewMemberContactReceivedInv user mCt' g m' forM_ mContent_ $ \mc -> do ci <- saveRcvChatItem user (CDDirectRcv mCt') msg brokerTs (CIRcvMsgContent mc) - toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat mCt') ci) + toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat mCt') ci] securityCodeChanged :: Contact -> CM () securityCodeChanged ct = do @@ -6813,21 +6949,23 @@ deleteOrUpdateMemberRecord user@User {userId} member = Just _ -> updateGroupMemberStatus db userId member GSMemRemoved Nothing -> deleteGroupMember db user member -sendDirectContactMessages :: MsgEncodingI e => User -> Contact -> NonEmpty (ChatMsgEvent e) -> CM () +sendDirectContactMessages :: MsgEncodingI e => User -> Contact -> NonEmpty (ChatMsgEvent e) -> CM [Either ChatError SndMessage] sendDirectContactMessages user ct events = do Connection {connChatVersion = v} <- liftEither $ contactSendConn_ ct if v >= batchSend2Version then sendDirectContactMessages' user ct events - else mapM_ (void . sendDirectContactMessage user ct) events + else forM (L.toList events) $ \evt -> + (Right . fst <$> sendDirectContactMessage user ct evt) `catchChatError` \e -> pure (Left e) -sendDirectContactMessages' :: MsgEncodingI e => User -> Contact -> NonEmpty (ChatMsgEvent e) -> CM () +sendDirectContactMessages' :: MsgEncodingI e => User -> Contact -> NonEmpty (ChatMsgEvent e) -> CM [Either ChatError SndMessage] sendDirectContactMessages' user ct events = do conn@Connection {connId} <- liftEither $ contactSendConn_ ct let idsEvts = L.map (ConnectionId connId,) events msgFlags = MsgFlags {notification = any (hasNotification . toCMEventTag) events} - (errs, msgs) <- lift $ partitionEithers . L.toList <$> createSndMessages idsEvts - unless (null errs) $ toView $ CRChatErrors (Just user) errs - mapM_ (batchSendConnMessages user conn msgFlags) (L.nonEmpty msgs) + sndMsgs_ <- lift $ createSndMessages idsEvts + (sndMsgs', pqEnc_) <- batchSendConnMessagesB user conn msgFlags sndMsgs_ + forM_ pqEnc_ $ \pqEnc' -> void $ createContactPQSndItem user ct conn pqEnc' + pure sndMsgs' sendDirectContactMessage :: MsgEncodingI e => User -> Contact -> ChatMsgEvent e -> CM (SndMessage, Int64) sendDirectContactMessage user ct chatMsgEvent = do @@ -6887,17 +7025,30 @@ sendGroupMemberMessages user conn events groupId = do forM_ (L.nonEmpty msgs) $ \msgs' -> batchSendConnMessages user conn MsgFlags {notification = True} msgs' -batchSendConnMessages :: User -> Connection -> MsgFlags -> NonEmpty SndMessage -> CM () -batchSendConnMessages user conn msgFlags msgs = do - let batched = batchSndMessagesJSON msgs - let (errs', msgBatches) = partitionEithers batched - -- shouldn't happen, as large messages would have caused createNewSndMessage to throw SELargeMsg - unless (null errs') $ toView $ CRChatErrors (Just user) errs' - forM_ (L.nonEmpty msgBatches) $ \msgBatches' -> do - let msgReq = L.map (msgBatchReq conn msgFlags) msgBatches' - void $ deliverMessages msgReq +batchSendConnMessages :: User -> Connection -> MsgFlags -> NonEmpty SndMessage -> CM ([Either ChatError SndMessage], Maybe PQEncryption) +batchSendConnMessages user conn msgFlags msgs = + batchSendConnMessagesB user conn msgFlags $ L.map Right msgs -batchSndMessagesJSON :: NonEmpty SndMessage -> [Either ChatError MsgBatch] +batchSendConnMessagesB :: User -> Connection -> MsgFlags -> NonEmpty (Either ChatError SndMessage) -> CM ([Either ChatError SndMessage], Maybe PQEncryption) +batchSendConnMessagesB _user conn msgFlags msgs_ = do + let batched_ = batchSndMessagesJSON msgs_ + case L.nonEmpty batched_ of + Just batched' -> do + let msgReqs = L.map (fmap (msgBatchReq conn msgFlags)) batched' + delivered <- deliverMessagesB msgReqs + let msgs' = concat $ L.zipWith flattenMsgs batched' delivered + pqEnc = findLastPQEnc delivered + pure (msgs', pqEnc) + Nothing -> pure ([], Nothing) + where + flattenMsgs :: Either ChatError MsgBatch -> Either ChatError ([Int64], PQEncryption) -> [Either ChatError SndMessage] + flattenMsgs (Right (MsgBatch _ sndMsgs)) (Right _) = map Right sndMsgs + flattenMsgs (Right (MsgBatch _ sndMsgs)) (Left ce) = replicate (length sndMsgs) (Left ce) + flattenMsgs (Left ce) _ = [Left ce] -- restore original ChatError + findLastPQEnc :: NonEmpty (Either ChatError ([Int64], PQEncryption)) -> Maybe PQEncryption + findLastPQEnc = foldr' (\x acc -> case x of Right (_, pqEnc) -> Just pqEnc; Left _ -> acc) Nothing + +batchSndMessagesJSON :: NonEmpty (Either ChatError SndMessage) -> [Either ChatError MsgBatch] batchSndMessagesJSON = batchMessages maxEncodedMsgLength . L.toList msgBatchReq :: Connection -> MsgFlags -> MsgBatch -> ChatMsgReq @@ -6949,7 +7100,7 @@ deliverMessagesB msgReqs = do lift . withStoreBatch $ \db -> L.map (bindRight $ createDelivery db) sent where compressBodies = - forME msgReqs $ \mr@(conn@Connection {pqSupport, connChatVersion = v}, msgFlags, msgBody, msgId) -> + forME msgReqs $ \mr@(conn@Connection {pqSupport, connChatVersion = v}, msgFlags, msgBody, msgIds) -> runExceptT $ case pqSupport of -- we only compress messages when: -- 1) PQ support is enabled @@ -6958,7 +7109,7 @@ deliverMessagesB msgReqs = do PQSupportOn | v >= pqEncryptionCompressionVersion && B.length msgBody > maxCompressedMsgLength -> do let msgBody' = compressedBatchMsgBody_ msgBody when (B.length msgBody' > maxCompressedMsgLength) $ throwError $ ChatError $ CEException "large compressed message" - pure (conn, msgFlags, msgBody', msgId) + pure (conn, msgFlags, msgBody', msgIds) _ -> pure mr toAgent prev = \case Right (conn@Connection {connId, pqEncryption}, msgFlags, msgBody, _msgIds) -> @@ -6982,13 +7133,23 @@ deliverMessagesB msgReqs = do where updatePQ = updateConnPQSndEnabled db connId pqSndEnabled' --- TODO combine profile update and message into one batch --- Take into account that it may not fit, and that we currently don't support sending multiple messages to the same connection in one call. -sendGroupMessage :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> CM (SndMessage, GroupSndResultData) +sendGroupMessage :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> CM SndMessage sendGroupMessage user gInfo members chatMsgEvent = do + sendGroupMessages user gInfo members (chatMsgEvent :| []) >>= \case + ((Right msg) :| [], _) -> pure msg + _ -> throwChatError $ CEInternalError "sendGroupMessage: expected 1 message" + +sendGroupMessage' :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> CM SndMessage +sendGroupMessage' user gInfo members chatMsgEvent = + sendGroupMessages_ user gInfo members (chatMsgEvent :| []) >>= \case + ((Right msg) :| [], _) -> pure msg + _ -> throwChatError $ CEInternalError "sendGroupMessage': expected 1 message" + +sendGroupMessages :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult) +sendGroupMessages user gInfo members events = do when shouldSendProfileUpdate $ sendProfileUpdate `catchChatError` (toView . CRChatError (Just user)) - sendGroupMessage_ user gInfo members chatMsgEvent + sendGroupMessages_ user gInfo members events where User {profile = p, userMemberProfileUpdatedAt} = user GroupInfo {userMemberProfileSentAt} = gInfo @@ -7006,59 +7167,33 @@ sendGroupMessage user gInfo members chatMsgEvent = do currentTs <- liftIO getCurrentTime withStore' $ \db -> updateUserMemberProfileSentAt db user gInfo currentTs -type GroupSndResultData = (([Either ChatError ([Int64], PQEncryption)], [(GroupMember, Connection)]), ([Either ChatError ()], [GroupMember]), [GroupMember]) - data GroupSndResult = GroupSndResult - { sentTo :: [GroupMember], - pending :: [GroupMember], + { sentTo :: [(GroupMemberId, Either ChatError [MessageId], Either ChatError ([Int64], PQEncryption))], + pending :: [(GroupMemberId, Either ChatError MessageId, Either ChatError ())], forwarded :: [GroupMember] } -sendGroupMessage' :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> CM SndMessage -sendGroupMessage' user gInfo members chatMsgEvent = fst <$> sendGroupMessage_ user gInfo members chatMsgEvent - -sendGroupMessage_ :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> CM (SndMessage, GroupSndResultData) -sendGroupMessage_ user gInfo members chatMsgEvent = - sendGroupMessages_ user gInfo members (chatMsgEvent :| []) >>= \case - (msg :| [], r) -> pure (msg, r) - _ -> throwChatError $ CEInternalError "sendGroupMessage': expected 1 message" - -sendGroupMessages :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> NonEmpty (ChatMsgEvent e) -> CM () -sendGroupMessages user gInfo members events = void $ sendGroupMessages_ user gInfo members events - -mkGroupSndResult :: GroupSndResultData -> GroupSndResult -mkGroupSndResult ((delivered, sentTo), (stored, pending), forwarded) = - GroupSndResult - { sentTo = filterSent' delivered sentTo fst, - pending = filterSent' stored pending id, - forwarded - } - where - -- TODO in theory this could deduplicate members and keep results only when ... some sent? or all sent? - -- This is not important, as it is not used in batch calls - filterSent' :: [Either ChatError a] -> [mem] -> (mem -> GroupMember) -> [GroupMember] - filterSent' rs ms mem = [mem m | (Right _, m) <- zip rs ms] - -sendGroupMessages_ :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty SndMessage, GroupSndResultData) -sendGroupMessages_ user gInfo@GroupInfo {groupId} members events = do +sendGroupMessages_ :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult) +sendGroupMessages_ _user gInfo@GroupInfo {groupId} members events = do let idsEvts = L.map (GroupId groupId,) events - (errs, msgs) <- lift $ partitionEithers . L.toList <$> createSndMessages idsEvts - unless (null errs) $ toView $ CRChatErrors (Just user) errs - case L.nonEmpty msgs of - Nothing -> throwChatError $ CEInternalError "sendGroupMessages: no messages created" - Just msgs' -> do - recipientMembers <- liftIO $ shuffleMembers (filter memberCurrent members) - let msgFlags = MsgFlags {notification = any (hasNotification . toCMEventTag) events} - (toSendSeparate, toSendBatched, pending, forwarded, _, dups) = - foldr addMember ([], [], [], [], S.empty, 0 :: Int) recipientMembers - when (dups /= 0) $ logError $ "sendGroupMessage: " <> tshow dups <> " duplicate members" - -- TODO PQ either somehow ensure that group members connections cannot have pqSupport/pqEncryption or pass Off's here - let msgReqs = prepareMsgReqs msgFlags msgs' toSendSeparate toSendBatched - delivered <- maybe (pure []) (fmap L.toList . deliverMessages) $ L.nonEmpty msgReqs - let errors = lefts delivered - unless (null errors) $ toView $ CRChatErrors (Just user) errors - stored <- lift . withStoreBatch' $ \db -> map (\m -> createPendingMsgs db m msgs') pending - pure (msgs', ((delivered, toSendSeparate <> toSendBatched), (stored, pending), forwarded)) + sndMsgs_ <- lift $ createSndMessages idsEvts + recipientMembers <- liftIO $ shuffleMembers (filter memberCurrent members) + let msgFlags = MsgFlags {notification = any (hasNotification . toCMEventTag) events} + (toSendSeparate, toSendBatched, toPending, forwarded, _, dups) = + foldr' addMember ([], [], [], [], S.empty, 0 :: Int) recipientMembers + when (dups /= 0) $ logError $ "sendGroupMessages_: " <> tshow dups <> " duplicate members" + -- TODO PQ either somehow ensure that group members connections cannot have pqSupport/pqEncryption or pass Off's here + -- Deliver to toSend members + let (sendToMemIds, msgReqs) = prepareMsgReqs msgFlags sndMsgs_ toSendSeparate toSendBatched + delivered <- maybe (pure []) (fmap L.toList . deliverMessagesB) $ L.nonEmpty msgReqs + when (length delivered /= length sendToMemIds) $ logError "sendGroupMessages_: sendToMemIds and delivered length mismatch" + -- Save as pending for toPending members + let (pendingMemIds, pendingReqs) = preparePending sndMsgs_ toPending + stored <- lift $ withStoreBatch (\db -> map (bindRight $ createPendingMsg db) pendingReqs) + -- Zip for easier access to results + let sentTo = zipWith3 (\mId mReq r -> (mId, fmap (\(_, _, _, msgIds) -> msgIds) mReq, r)) sendToMemIds msgReqs delivered + pending = zipWith3 (\mId pReq r -> (mId, fmap snd pReq, r)) pendingMemIds pendingReqs stored + pure (sndMsgs_, GroupSndResult {sentTo, pending, forwarded}) where shuffleMembers :: [GroupMember] -> IO [GroupMember] shuffleMembers ms = do @@ -7079,22 +7214,38 @@ sendGroupMessages_ user gInfo@GroupInfo {groupId} members events = do where mId = groupMemberId' m mIds' = S.insert mId mIds - prepareMsgReqs :: MsgFlags -> NonEmpty SndMessage -> [(GroupMember, Connection)] -> [(GroupMember, Connection)] -> [ChatMsgReq] - prepareMsgReqs msgFlags msgs toSendSeparate toSendBatched = do - let msgReqsSeparate = foldr (\(_, conn) reqs -> foldr (\msg -> (sndMessageReq conn msg :)) reqs msgs) [] toSendSeparate - batched = batchSndMessagesJSON msgs - -- _errs shouldn't happen, as large messages would have caused createNewSndMessage to throw SELargeMsg - (_errs, msgBatches) = partitionEithers batched - case L.nonEmpty msgBatches of - Just msgBatches' -> do - let msgReqsBatched = foldr (\(_, conn) reqs -> foldr (\batch -> (msgBatchReq conn msgFlags batch :)) reqs msgBatches') [] toSendBatched - msgReqsSeparate <> msgReqsBatched - Nothing -> msgReqsSeparate + prepareMsgReqs :: MsgFlags -> NonEmpty (Either ChatError SndMessage) -> [(GroupMember, Connection)] -> [(GroupMember, Connection)] -> ([GroupMemberId], [Either ChatError ChatMsgReq]) + prepareMsgReqs msgFlags msgs_ toSendSeparate toSendBatched = do + let batched_ = batchSndMessagesJSON msgs_ + case L.nonEmpty batched_ of + Just batched' -> do + let (memsSep, mreqsSep) = foldr' foldMsgs ([], []) toSendSeparate + (memsBtch, mreqsBtch) = foldr' (foldBatches batched') ([], []) toSendBatched + (memsSep <> memsBtch, mreqsSep <> mreqsBtch) + Nothing -> ([], []) where - sndMessageReq :: Connection -> SndMessage -> ChatMsgReq - sndMessageReq conn SndMessage {msgId, msgBody} = (conn, msgFlags, msgBody, [msgId]) - createPendingMsgs :: DB.Connection -> GroupMember -> NonEmpty SndMessage -> IO () - createPendingMsgs db m = mapM_ (\SndMessage {msgId} -> createPendingGroupMessage db (groupMemberId' m) msgId Nothing) + foldMsgs :: (GroupMember, Connection) -> ([GroupMemberId], [Either ChatError ChatMsgReq]) -> ([GroupMemberId], [Either ChatError ChatMsgReq]) + foldMsgs (GroupMember {groupMemberId}, conn) memIdsReqs = + foldr' (\msg_ (memIds, reqs) -> (groupMemberId : memIds, fmap sndMessageReq msg_ : reqs)) memIdsReqs msgs_ + where + sndMessageReq :: SndMessage -> ChatMsgReq + sndMessageReq SndMessage {msgId, msgBody} = (conn, msgFlags, msgBody, [msgId]) + foldBatches :: NonEmpty (Either ChatError MsgBatch) -> (GroupMember, Connection) -> ([GroupMemberId], [Either ChatError ChatMsgReq]) -> ([GroupMemberId], [Either ChatError ChatMsgReq]) + foldBatches batched' (GroupMember {groupMemberId}, conn) memIdsReqs = + foldr' (\batch_ (memIds, reqs) -> (groupMemberId : memIds, fmap (msgBatchReq conn msgFlags) batch_ : reqs)) memIdsReqs batched' + preparePending :: NonEmpty (Either ChatError SndMessage) -> [GroupMember] -> ([GroupMemberId], [Either ChatError (GroupMemberId, MessageId)]) + preparePending msgs_ = + foldr' foldMsgs ([], []) + where + foldMsgs :: GroupMember -> ([GroupMemberId], [Either ChatError (GroupMemberId, MessageId)]) -> ([GroupMemberId], [Either ChatError (GroupMemberId, MessageId)]) + foldMsgs GroupMember {groupMemberId} memIdsReqs = + foldr' (\msg_ (memIds, reqs) -> (groupMemberId : memIds, fmap pendingReq msg_ : reqs)) memIdsReqs msgs_ + where + pendingReq :: SndMessage -> (GroupMemberId, MessageId) + pendingReq SndMessage {msgId} = (groupMemberId, msgId) + createPendingMsg :: DB.Connection -> (GroupMemberId, MessageId) -> IO (Either ChatError ()) + createPendingMsg db (groupMemberId, msgId) = + createPendingGroupMessage db groupMemberId msgId Nothing $> Right () data MemberSendAction = MSASend Connection | MSASendBatched Connection | MSAPending | MSAForwarded @@ -7155,7 +7306,7 @@ sendPendingGroupMessages user GroupMember {groupMemberId} conn = do pgms <- withStore' $ \db -> getPendingGroupMessages db groupMemberId forM_ (L.nonEmpty pgms) $ \pgms' -> do let msgs = L.map (\(sndMsg, _, _) -> sndMsg) pgms' - batchSendConnMessages user conn MsgFlags {notification = True} msgs + void $ batchSendConnMessages user conn MsgFlags {notification = True} msgs lift . void . withStoreBatch' $ \db -> L.map (\SndMessage {msgId} -> deletePendingGroupMessage db groupMemberId msgId) msgs lift . void . withStoreBatch' $ \db -> L.map (\(_, tag, introId_) -> updateIntro_ db tag introId_) pgms' where @@ -7212,14 +7363,39 @@ saveSndChatItem :: ChatTypeI c => User -> ChatDirection c 'MDSnd -> SndMessage - saveSndChatItem user cd msg content = saveSndChatItem' user cd msg content Nothing Nothing Nothing Nothing False saveSndChatItem' :: ChatTypeI c => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIFile 'MDSnd) -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> CM (ChatItem c 'MDSnd) -saveSndChatItem' user cd msg@SndMessage {sharedMsgId} content ciFile quotedItem itemForwarded itemTimed live = do +saveSndChatItem' user cd msg content ciFile quotedItem itemForwarded itemTimed live = + saveSndChatItems user cd [Right NewSndChatItemData {msg, content, ciFile, quotedItem, itemForwarded}] itemTimed live >>= \case + [Right ci] -> pure ci + _ -> throwChatError $ CEInternalError "saveSndChatItem': expected 1 item" + +data NewSndChatItemData c = NewSndChatItemData + { msg :: SndMessage, + content :: CIContent 'MDSnd, + ciFile :: Maybe (CIFile 'MDSnd), + quotedItem :: Maybe (CIQuote c), + itemForwarded :: Maybe CIForwardedFrom + } + +saveSndChatItems :: + forall c. + ChatTypeI c => + User -> + ChatDirection c 'MDSnd -> + [Either ChatError (NewSndChatItemData c)] -> + Maybe CITimed -> + Bool -> + CM [Either ChatError (ChatItem c 'MDSnd)] +saveSndChatItems user cd itemsData itemTimed live = do createdAt <- liftIO getCurrentTime - ciId <- withStore' $ \db -> do - when (ciRequiresAttention content || contactChatDeleted cd) $ updateChatTs db user cd createdAt - ciId <- createNewSndChatItem db user cd msg content quotedItem itemForwarded itemTimed live createdAt - forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt - pure ciId - pure $ mkChatItem cd ciId content ciFile quotedItem (Just sharedMsgId) itemForwarded itemTimed live createdAt Nothing createdAt + when (contactChatDeleted cd || any (\NewSndChatItemData {content} -> ciRequiresAttention content) (rights itemsData)) $ + withStore' (\db -> updateChatTs db user cd createdAt) + lift $ withStoreBatch (\db -> map (bindRight $ createItem db createdAt) itemsData) + where + createItem :: DB.Connection -> UTCTime -> NewSndChatItemData c -> IO (Either ChatError (ChatItem c 'MDSnd)) + createItem db createdAt NewSndChatItemData {msg = msg@SndMessage {sharedMsgId}, content, ciFile, quotedItem, itemForwarded} = do + ciId <- createNewSndChatItem db user cd msg content quotedItem itemForwarded itemTimed live createdAt + forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt + pure $ Right $ mkChatItem cd ciId content ciFile quotedItem (Just sharedMsgId) itemForwarded itemTimed live createdAt Nothing createdAt saveRcvChatItem :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> UTCTime -> CIContent 'MDRcv -> CM (ChatItem c 'MDRcv) saveRcvChatItem user cd msg@RcvMessage {sharedMsgId_} brokerTs content = @@ -7472,7 +7648,7 @@ createContactsFeatureItems user cts chatDir ciFeature ciOffer getPref = do let dirsCIContents = map contactChangedFeatures cts (errs, acis) <- partitionEithers <$> createInternalItemsForChats user Nothing dirsCIContents unless (null errs) $ toView' $ CRChatErrors (Just user) errs - forM_ acis $ \aci -> toView' $ CRNewChatItem user aci + toView' $ CRNewChatItems user acis where contactChangedFeatures :: (Contact, Contact) -> (ChatDirection 'CTDirect d, [CIContent d]) contactChangedFeatures (Contact {mergedPreferences = cups}, ct'@Contact {mergedPreferences = cups'}) = do @@ -7510,7 +7686,7 @@ sameGroupProfileInfo p p' = p {groupPreferences = Nothing} == p' {groupPreferenc createInternalChatItem :: (ChatTypeI c, MsgDirectionI d) => User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM () createInternalChatItem user cd content itemTs_ = lift (createInternalItemsForChats user itemTs_ [(cd, [content])]) >>= \case - [Right aci] -> toView $ CRNewChatItem user aci + [Right aci] -> toView $ CRNewChatItems user [aci] [Left e] -> throwError e rs -> throwChatError $ CEInternalError $ "createInternalChatItem: expected 1 result, got " <> show (length rs) @@ -7537,14 +7713,23 @@ createInternalItemsForChats user itemTs_ dirsCIContents = do let ci = mkChatItem cd ciId content Nothing Nothing Nothing Nothing Nothing False itemTs Nothing createdAt pure $ AChatItem (chatTypeI @c) (msgDirection @d) (toChatInfo cd) ci -createLocalChatItem :: MsgDirectionI d => User -> ChatDirection 'CTLocal d -> CIContent d -> Maybe CIForwardedFrom -> UTCTime -> CM ChatItemId -createLocalChatItem user cd content itemForwarded createdAt = do - gVar <- asks random - withStore $ \db -> do - liftIO $ updateChatTs db user cd createdAt - createWithRandomId gVar $ \sharedMsgId -> - let smi_ = Just (SharedMsgId sharedMsgId) - in createNewChatItem_ db user cd Nothing smi_ content (Nothing, Nothing, Nothing, Nothing, Nothing) itemForwarded Nothing False createdAt Nothing createdAt +createLocalChatItems :: + User -> + ChatDirection 'CTLocal 'MDSnd -> + [(CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom)] -> + UTCTime -> + CM [ChatItem 'CTLocal 'MDSnd] +createLocalChatItems user cd itemsData createdAt = do + withStore' $ \db -> updateChatTs db user cd createdAt + (errs, items) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (createItem db) itemsData) + unless (null errs) $ toView $ CRChatErrors (Just user) errs + pure items + where + createItem :: DB.Connection -> (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom) -> IO (ChatItem 'CTLocal 'MDSnd) + createItem db (content, ciFile, itemForwarded) = do + ciId <- createNewChatItem_ db user cd Nothing Nothing content (Nothing, Nothing, Nothing, Nothing, Nothing) itemForwarded Nothing False createdAt Nothing createdAt + forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt + pure $ mkChatItem cd ciId content ciFile Nothing Nothing itemForwarded Nothing False createdAt Nothing createdAt withUser' :: (User -> CM ChatResponse) -> CM ChatResponse withUser' action = @@ -7670,13 +7855,13 @@ chatCommandP = "/_get chat " *> (APIGetChat <$> chatRefP <* A.space <*> chatPaginationP <*> optional (" search=" *> stringP)), "/_get items " *> (APIGetChatItems <$> chatPaginationP <*> optional (" search=" *> stringP)), "/_get item info " *> (APIGetChatItemInfo <$> chatRefP <* A.space <*> A.decimal), - "/_send " *> (APISendMessage <$> chatRefP <*> liveMessageP <*> sendMessageTTLP <*> (" json " *> jsonP <|> " text " *> (ComposedMessage Nothing Nothing <$> mcTextP))), - "/_create *" *> (APICreateChatItem <$> A.decimal <*> (" json " *> jsonP <|> " text " *> (ComposedMessage Nothing Nothing <$> mcTextP))), + "/_send " *> (APISendMessages <$> chatRefP <*> liveMessageP <*> sendMessageTTLP <*> (" json " *> jsonP <|> " text " *> composedMessagesTextP)), + "/_create *" *> (APICreateChatItems <$> A.decimal <*> (" json " *> jsonP <|> " text " *> composedMessagesTextP)), "/_update item " *> (APIUpdateChatItem <$> chatRefP <* A.space <*> A.decimal <*> liveMessageP <* A.space <*> msgContentP), "/_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 " *> (APIForwardChatItem <$> chatRefP <* A.space <*> chatRefP <* A.space <*> A.decimal <*> sendMessageTTLP), + "/_forward " *> (APIForwardChatItems <$> chatRefP <* A.space <*> chatRefP <*> _strP <*> sendMessageTTLP), "/_read user " *> (APIUserRead <$> A.decimal), "/read user" $> UserRead, "/_read chat " *> (APIChatRead <$> chatRefP <*> optional (A.space *> ((,) <$> ("from=" *> A.decimal) <* A.space <*> ("to=" *> A.decimal)))), @@ -7974,6 +8159,9 @@ chatCommandP = '*' -> head "❤️" '^' -> '🚀' c -> c + composedMessagesTextP = do + text <- mcTextP + pure $ (ComposedMessage Nothing Nothing text) :| [] liveMessageP = " live=" *> onOffP <|> pure False sendMessageTTLP = " ttl=" *> ((Just <$> A.decimal) <|> ("default" $> Nothing)) <|> pure Nothing receiptSettings = do diff --git a/src/Simplex/Chat/Bot.hs b/src/Simplex/Chat/Bot.hs index f3de92e1f2..66479c0ee6 100644 --- a/src/Simplex/Chat/Bot.hs +++ b/src/Simplex/Chat/Bot.hs @@ -11,6 +11,7 @@ import Control.Concurrent.Async import Control.Concurrent.STM import Control.Monad import qualified Data.ByteString.Char8 as B +import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Text as T import Simplex.Chat.Controller import Simplex.Chat.Core @@ -31,7 +32,7 @@ chatBotRepl welcome answer _user cc = do CRContactConnected _ contact _ -> do contactConnected contact void $ sendMessage cc contact welcome - CRNewChatItem _ (AChatItem _ SMDRcv (DirectChat contact) ChatItem {content = mc@CIRcvMsgContent {}}) -> do + CRNewChatItems {chatItems = (AChatItem _ SMDRcv (DirectChat contact) ChatItem {content = mc@CIRcvMsgContent {}}) : _} -> do let msg = T.unpack $ ciContentToText mc void $ sendMessage cc contact =<< answer contact msg _ -> pure () @@ -68,8 +69,8 @@ sendComposedMessage cc = sendComposedMessage' cc . contactId' sendComposedMessage' :: ChatController -> ContactId -> Maybe ChatItemId -> MsgContent -> IO () sendComposedMessage' cc ctId quotedItemId msgContent = do let cm = ComposedMessage {fileSource = Nothing, quotedItemId, msgContent} - sendChatCmd cc (APISendMessage (ChatRef CTDirect ctId) False Nothing cm) >>= \case - CRNewChatItem {} -> printLog cc CLLInfo $ "sent message to contact ID " <> show ctId + sendChatCmd cc (APISendMessages (ChatRef CTDirect ctId) False Nothing (cm :| [])) >>= \case + CRNewChatItems {} -> printLog cc CLLInfo $ "sent message to contact ID " <> show ctId r -> putStrLn $ "unexpected send message response: " <> show r deleteMessage :: ChatController -> Contact -> ChatItemId -> IO () diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index c4f056c778..9d92ee8193 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -292,13 +292,13 @@ data ChatCommand | APIGetChat ChatRef ChatPagination (Maybe String) | APIGetChatItems ChatPagination (Maybe String) | APIGetChatItemInfo ChatRef ChatItemId - | APISendMessage {chatRef :: ChatRef, liveMessage :: Bool, ttl :: Maybe Int, composedMessage :: ComposedMessage} - | APICreateChatItem {noteFolderId :: NoteFolderId, composedMessage :: ComposedMessage} + | APISendMessages {chatRef :: ChatRef, liveMessage :: Bool, ttl :: Maybe Int, composedMessages :: NonEmpty ComposedMessage} + | APICreateChatItems {noteFolderId :: NoteFolderId, composedMessages :: NonEmpty ComposedMessage} | APIUpdateChatItem {chatRef :: ChatRef, chatItemId :: ChatItemId, liveMessage :: Bool, msgContent :: MsgContent} | APIDeleteChatItem ChatRef (NonEmpty ChatItemId) CIDeleteMode | APIDeleteMemberChatItem GroupId (NonEmpty ChatItemId) | APIChatItemReaction {chatRef :: ChatRef, chatItemId :: ChatItemId, add :: Bool, reaction :: MsgReaction} - | APIForwardChatItem {toChatRef :: ChatRef, fromChatRef :: ChatRef, chatItemId :: ChatItemId, ttl :: Maybe Int} + | APIForwardChatItems {toChatRef :: ChatRef, fromChatRef :: ChatRef, chatItemIds :: NonEmpty ChatItemId, ttl :: Maybe Int} | APIUserRead UserId | UserRead | APIChatRead ChatRef (Maybe (ChatItemId, ChatItemId)) @@ -597,7 +597,7 @@ data ChatResponse | CRContactCode {user :: User, contact :: Contact, connectionCode :: Text} | CRGroupMemberCode {user :: User, groupInfo :: GroupInfo, member :: GroupMember, connectionCode :: Text} | CRConnectionVerified {user :: User, verified :: Bool, expectedCode :: Text} - | CRNewChatItem {user :: User, chatItem :: AChatItem} + | CRNewChatItems {user :: User, chatItems :: [AChatItem]} | CRChatItemStatusUpdated {user :: User, chatItem :: AChatItem} | CRChatItemUpdated {user :: User, chatItem :: AChatItem} | CRChatItemNotChanged {user :: User, chatItem :: AChatItem} @@ -1178,7 +1178,6 @@ data ChatErrorType | CEInlineFileProhibited {fileId :: FileTransferId} | CEInvalidQuote | CEInvalidForward - | CEForwardNoFile | CEInvalidChatItemUpdate | CEInvalidChatItemDelete | CEHasCurrentCall diff --git a/src/Simplex/Chat/Messages/Batch.hs b/src/Simplex/Chat/Messages/Batch.hs index 690ae5828f..c1c45d7b0a 100644 --- a/src/Simplex/Chat/Messages/Batch.hs +++ b/src/Simplex/Chat/Messages/Batch.hs @@ -17,16 +17,18 @@ import Simplex.Chat.Messages data MsgBatch = MsgBatch ByteString [SndMessage] --- | Batches [SndMessage] into batches of ByteStrings in form of JSON arrays. +-- | Batches SndMessages in [Either ChatError SndMessage] into batches of ByteStrings in form of JSON arrays. +-- Preserves original errors in the list. -- Does not check if the resulting batch is a valid JSON. -- If a single element is passed, it is returned as is (a JSON string). -- If an element exceeds maxLen, it is returned as ChatError. -batchMessages :: Int -> [SndMessage] -> [Either ChatError MsgBatch] +batchMessages :: Int -> [Either ChatError SndMessage] -> [Either ChatError MsgBatch] batchMessages maxLen = addBatch . foldr addToBatch ([], [], 0, 0) where msgBatch batch = Right (MsgBatch (encodeMessages batch) batch) - addToBatch :: SndMessage -> ([Either ChatError MsgBatch], [SndMessage], Int, Int) -> ([Either ChatError MsgBatch], [SndMessage], Int, Int) - addToBatch msg@SndMessage {msgBody} acc@(batches, batch, len, n) + addToBatch :: Either ChatError SndMessage -> ([Either ChatError MsgBatch], [SndMessage], Int, Int) -> ([Either ChatError MsgBatch], [SndMessage], Int, Int) + addToBatch (Left err) acc = (Left err : addBatch acc, [], 0, 0) -- step over original error + addToBatch (Right msg@SndMessage {msgBody}) acc@(batches, batch, len, n) | batchLen <= maxLen = (batches, msg : batch, len', n + 1) | msgLen <= maxLen = (addBatch acc, [msg], msgLen, 1) | otherwise = (errLarge msg : addBatch acc, [], 0, 0) diff --git a/src/Simplex/Chat/Store/Files.hs b/src/Simplex/Chat/Store/Files.hs index d1da081cee..2c02d872b1 100644 --- a/src/Simplex/Chat/Store/Files.hs +++ b/src/Simplex/Chat/Store/Files.hs @@ -966,20 +966,20 @@ lookupFileTransferRedirectMeta db User {userId} fileId = do redirects <- DB.query db "SELECT file_id FROM files WHERE user_id = ? AND redirect_file_id = ?" (userId, fileId) rights <$> mapM (runExceptT . getFileTransferMeta_ db userId . fromOnly) redirects -createLocalFile :: ToField (CIFileStatus d) => CIFileStatus d -> DB.Connection -> User -> NoteFolder -> ChatItemId -> UTCTime -> CryptoFile -> Integer -> Integer -> IO Int64 -createLocalFile fileStatus db User {userId} NoteFolder {noteFolderId} chatItemId itemTs CryptoFile {filePath, cryptoArgs} fileSize fileChunkSize = do +createLocalFile :: ToField (CIFileStatus d) => CIFileStatus d -> DB.Connection -> User -> NoteFolder -> UTCTime -> CryptoFile -> Integer -> Integer -> IO Int64 +createLocalFile fileStatus db User {userId} NoteFolder {noteFolderId} itemTs CryptoFile {filePath, cryptoArgs} fileSize fileChunkSize = do DB.execute db [sql| INSERT INTO files - ( user_id, note_folder_id, chat_item_id, + ( user_id, note_folder_id, file_name, file_path, file_size, file_crypto_key, file_crypto_nonce, chunk_size, file_inline, ci_file_status, protocol, created_at, updated_at ) - VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?) |] - ( (userId, noteFolderId, chatItemId) + ( (userId, noteFolderId) :. (takeFileName filePath, filePath, fileSize) :. maybe (Nothing, Nothing) (\(CFArgs key nonce) -> (Just key, Just nonce)) cryptoArgs :. (fileChunkSize, Nothing :: Maybe InlineFileMode, fileStatus, FPLocal, itemTs, itemTs) diff --git a/src/Simplex/Chat/Terminal/Input.hs b/src/Simplex/Chat/Terminal/Input.hs index 2d1039e585..4f6d66d2c1 100644 --- a/src/Simplex/Chat/Terminal/Input.hs +++ b/src/Simplex/Chat/Terminal/Input.hs @@ -69,7 +69,7 @@ runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do Nothing -> setActive ct "" Just rhId -> updateRemoteUser ct u rhId CRChatItems u chatName_ _ -> whenCurrUser cc u $ mapM_ (setActive ct . chatActiveTo) chatName_ - CRNewChatItem u (AChatItem _ SMDSnd cInfo _) -> whenCurrUser cc u $ setActiveChat ct cInfo + CRNewChatItems u ((AChatItem _ SMDSnd cInfo _) : _) -> whenCurrUser cc u $ setActiveChat ct cInfo CRChatItemUpdated u (AChatItem _ SMDSnd cInfo _) -> whenCurrUser cc u $ setActiveChat ct cInfo CRChatItemsDeleted u ((ChatItemDeletion (AChatItem _ _ cInfo _) _) : _) _ _ -> whenCurrUser cc u $ setActiveChat ct cInfo CRContactDeleted u c -> whenCurrUser cc u $ unsetActiveContact ct c @@ -93,7 +93,7 @@ runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do Right SendMessageBroadcast {} -> True _ -> False startLiveMessage :: Either a ChatCommand -> ChatResponse -> IO () - startLiveMessage (Right (SendLiveMessage chatName msg)) (CRNewChatItem _ (AChatItem cType SMDSnd _ ChatItem {meta = CIMeta {itemId}})) = do + startLiveMessage (Right (SendLiveMessage chatName msg)) (CRNewChatItems {chatItems = [AChatItem cType SMDSnd _ ChatItem {meta = CIMeta {itemId}}]}) = do whenM (isNothing <$> readTVarIO liveMessageState) $ do let s = T.unpack msg int = case cType of SCTGroup -> 5000000; _ -> 3000000 :: Int diff --git a/src/Simplex/Chat/Terminal/Main.hs b/src/Simplex/Chat/Terminal/Main.hs index a946ba3483..64703a3a92 100644 --- a/src/Simplex/Chat/Terminal/Main.hs +++ b/src/Simplex/Chat/Terminal/Main.hs @@ -44,7 +44,7 @@ simplexChatCLI' cfg opts@ChatOpts {chatCmd, chatCmdLog, chatCmdDelay, chatServer when (chatCmdLog /= CCLNone) . void . forkIO . forever $ do (_, _, r') <- atomically . readTBQueue $ outputQ cc case r' of - CRNewChatItem {} -> printResponse r' + CRNewChatItems {} -> printResponse r' _ -> when (chatCmdLog == CCLAll) $ printResponse r' sendChatCmdStr cc chatCmd >>= printResponse threadDelay $ chatCmdDelay * 1000000 diff --git a/src/Simplex/Chat/Terminal/Output.hs b/src/Simplex/Chat/Terminal/Output.hs index 40f14a10de..0ead850b86 100644 --- a/src/Simplex/Chat/Terminal/Output.hs +++ b/src/Simplex/Chat/Terminal/Output.hs @@ -147,7 +147,7 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} Cha forever $ do (_, outputRH, r) <- atomically $ readTBQueue outputQ case r of - CRNewChatItem u ci -> when markRead $ markChatItemRead u ci + CRNewChatItems u (ci : _) -> when markRead $ markChatItemRead u ci -- At the moment of writing received items are created one at a time CRChatItemUpdated u ci -> when markRead $ markChatItemRead u ci CRRemoteHostConnected {remoteHost = RemoteHostInfo {remoteHostId}} -> getRemoteUser remoteHostId CRRemoteHostStopped {remoteHostId_} -> mapM_ removeRemoteUser remoteHostId_ @@ -175,7 +175,8 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} Cha responseNotification :: ChatTerminal -> ChatController -> ChatResponse -> IO () responseNotification t@ChatTerminal {sendNotification} cc = \case - CRNewChatItem u (AChatItem _ SMDRcv cInfo ci@ChatItem {chatDir, content = CIRcvMsgContent mc, formattedText}) -> + -- At the moment of writing received items are created one at a time + CRNewChatItems u ((AChatItem _ SMDRcv cInfo ci@ChatItem {chatDir, content = CIRcvMsgContent mc, formattedText}) : _) -> when (chatDirNtf u cInfo chatDir $ isMention ci) $ do whenCurrUser cc u $ setActiveChat t cInfo case (cInfo, chatDir) of diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index e154b5b902..dd2bf94467 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -120,7 +120,10 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe CRConnectionVerified u verified code -> ttyUser u [plain $ if verified then "connection verified" else "connection not verified, current code is " <> code] CRContactCode u ct code -> ttyUser u $ viewContactCode ct code testView CRGroupMemberCode u g m code -> ttyUser u $ viewGroupMemberCode g m code testView - CRNewChatItem u (AChatItem _ _ chat item) -> ttyUser u $ unmuted u chat item $ viewChatItem chat item False ts tz <> viewItemReactions item + CRNewChatItems u chatItems -> + concatMap + (\(AChatItem _ _ chat item) -> ttyUser u $ unmuted u chat item $ viewChatItem chat item False ts tz <> viewItemReactions item) + chatItems CRChatItems u _ chatItems -> ttyUser u $ concatMap (\(AChatItem _ _ chat item) -> viewChatItem chat item True ts tz <> viewItemReactions item) chatItems CRChatItemInfo u ci ciInfo -> ttyUser u $ viewChatItemInfo ci ciInfo tz CRChatItemId u itemId -> ttyUser u [plain $ maybe "no item" show itemId] @@ -2025,7 +2028,6 @@ viewChatError isCmd logLevel testView = \case 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"] - CEForwardNoFile -> ["cannot forward this message, file not found"] CEInvalidChatItemUpdate -> ["cannot update this item"] CEInvalidChatItemDelete -> ["cannot delete this item"] CEHasCurrentCall -> ["call already in progress"] diff --git a/tests/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs index 09b2d7d51c..86c51f6aaa 100644 --- a/tests/ChatTests/Direct.hs +++ b/tests/ChatTests/Direct.hs @@ -52,6 +52,7 @@ chatDirectTests = do it "repeat AUTH errors disable contact" testRepeatAuthErrorsDisableContact it "should send multiline message" testMultilineMessage it "send large message" testLargeMessage + it "send multiple messages api" testSendMulti describe "duplicate contacts" $ do it "duplicate contacts are separate (contacts don't merge)" testDuplicateContactsSeparate it "new contact is separate with multiple duplicate contacts (contacts don't merge)" testDuplicateContactsMultipleSeparate @@ -839,6 +840,18 @@ testLargeMessage = bob <## "contact alice changed to alice2" bob <## "use @alice2 to send messages" +testSendMulti :: HasCallStack => FilePath -> IO () +testSendMulti = + testChat2 aliceProfile bobProfile $ + \alice bob -> do + connectUsers alice bob + + alice ##> "/_send @2 json [{\"msgContent\": {\"type\": \"text\", \"text\": \"test 1\"}}, {\"msgContent\": {\"type\": \"text\", \"text\": \"test 2\"}}]" + alice <# "@bob test 1" + alice <# "@bob test 2" + bob <# "alice> test 1" + bob <# "alice> test 2" + testGetSetSMPServers :: HasCallStack => FilePath -> IO () testGetSetSMPServers = testChat2 aliceProfile bobProfile $ @@ -2162,7 +2175,7 @@ testSetChatItemTTL = -- chat item with file alice #$> ("/_files_folder ./tests/tmp/app_files", id, "ok") copyFile "./tests/fixtures/test.jpg" "./tests/tmp/app_files/test.jpg" - alice ##> "/_send @2 json {\"filePath\": \"test.jpg\", \"msgContent\": {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}" + alice ##> "/_send @2 json [{\"filePath\": \"test.jpg\", \"msgContent\": {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}]" alice <# "/f @bob test.jpg" alice <## "use /fc 1 to cancel sending" bob <# "alice> sends file test.jpg (136.5 KiB / 139737 bytes)" @@ -2410,7 +2423,7 @@ setupDesynchronizedRatchet tmp alice = do (bob "/tail @alice 1" bob <# "alice> decryption error, possibly due to the device change (header, 3 messages)" - bob ##> "@alice 1" + bob `send` "@alice 1" bob <## "error: command is prohibited, sendMessagesB: send prohibited" (alice FilePath -> IO () runTestMessageWithFile = testChat2 aliceProfile bobProfile $ \alice bob -> withXFTPServer $ do connectUsers alice bob - alice ##> "/_send @2 json {\"filePath\": \"./tests/fixtures/test.jpg\", \"msgContent\": {\"type\": \"text\", \"text\": \"hi, sending a file\"}}" + alice ##> "/_send @2 json [{\"filePath\": \"./tests/fixtures/test.jpg\", \"msgContent\": {\"type\": \"text\", \"text\": \"hi, sending a file\"}}]" alice <# "@bob hi, sending a file" alice <# "/f @bob ./tests/fixtures/test.jpg" alice <## "use /fc 1 to cancel sending" @@ -91,7 +91,7 @@ testSendImage = testChat2 aliceProfile bobProfile $ \alice bob -> withXFTPServer $ do connectUsers alice bob - alice ##> "/_send @2 json {\"filePath\": \"./tests/fixtures/test.jpg\", \"msgContent\": {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}" + alice ##> "/_send @2 json [{\"filePath\": \"./tests/fixtures/test.jpg\", \"msgContent\": {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}]" alice <# "/f @bob ./tests/fixtures/test.jpg" alice <## "use /fc 1 to cancel sending" bob <# "alice> sends file test.jpg (136.5 KiB / 139737 bytes)" @@ -122,7 +122,7 @@ testSenderMarkItemDeleted = testChat2 aliceProfile bobProfile $ \alice bob -> withXFTPServer $ do connectUsers alice bob - alice ##> "/_send @2 json {\"filePath\": \"./tests/fixtures/test_1MB.pdf\", \"msgContent\": {\"type\": \"text\", \"text\": \"hi, sending a file\"}}" + alice ##> "/_send @2 json [{\"filePath\": \"./tests/fixtures/test_1MB.pdf\", \"msgContent\": {\"type\": \"text\", \"text\": \"hi, sending a file\"}}]" alice <# "@bob hi, sending a file" alice <# "/f @bob ./tests/fixtures/test_1MB.pdf" alice <## "use /fc 1 to cancel sending" @@ -147,7 +147,7 @@ testFilesFoldersSendImage = connectUsers alice bob alice #$> ("/_files_folder ./tests/fixtures", id, "ok") bob #$> ("/_files_folder ./tests/tmp/app_files", id, "ok") - alice ##> "/_send @2 json {\"filePath\": \"test.jpg\", \"msgContent\": {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}" + alice ##> "/_send @2 json [{\"filePath\": \"test.jpg\", \"msgContent\": {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}]" alice <# "/f @bob test.jpg" alice <## "use /fc 1 to cancel sending" bob <# "alice> sends file test.jpg (136.5 KiB / 139737 bytes)" @@ -180,7 +180,7 @@ testFilesFoldersImageSndDelete = alice #$> ("/_files_folder ./tests/tmp/alice_app_files", id, "ok") copyFile "./tests/fixtures/test_1MB.pdf" "./tests/tmp/alice_app_files/test_1MB.pdf" bob #$> ("/_files_folder ./tests/tmp/bob_app_files", id, "ok") - alice ##> "/_send @2 json {\"filePath\": \"test_1MB.pdf\", \"msgContent\": {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}" + alice ##> "/_send @2 json [{\"filePath\": \"test_1MB.pdf\", \"msgContent\": {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}]" alice <# "/f @bob test_1MB.pdf" alice <## "use /fc 1 to cancel sending" bob <# "alice> sends file test_1MB.pdf (1017.7 KiB / 1042157 bytes)" @@ -212,7 +212,7 @@ testFilesFoldersImageRcvDelete = connectUsers alice bob alice #$> ("/_files_folder ./tests/fixtures", id, "ok") bob #$> ("/_files_folder ./tests/tmp/app_files", id, "ok") - alice ##> "/_send @2 json {\"filePath\": \"test.jpg\", \"msgContent\": {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}" + alice ##> "/_send @2 json [{\"filePath\": \"test.jpg\", \"msgContent\": {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}]" alice <# "/f @bob test.jpg" alice <## "use /fc 1 to cancel sending" bob <# "alice> sends file test.jpg (136.5 KiB / 139737 bytes)" @@ -239,7 +239,7 @@ testSendImageWithTextAndQuote = connectUsers alice bob bob #> "@alice hi alice" alice <# "bob> hi alice" - alice ##> ("/_send @2 json {\"filePath\": \"./tests/fixtures/test.jpg\", \"quotedItemId\": " <> itemId 1 <> ", \"msgContent\": {\"text\":\"hey bob\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}") + alice ##> ("/_send @2 json [{\"filePath\": \"./tests/fixtures/test.jpg\", \"quotedItemId\": " <> itemId 1 <> ", \"msgContent\": {\"text\":\"hey bob\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}]") alice <# "@bob > hi alice" alice <## " hey bob" alice <# "/f @bob ./tests/fixtures/test.jpg" @@ -265,7 +265,7 @@ testSendImageWithTextAndQuote = bob @@@ [("@alice", "hey bob")] -- quoting (file + text) with file uses quoted text - bob ##> ("/_send @2 json {\"filePath\": \"./tests/fixtures/test.pdf\", \"quotedItemId\": " <> itemId 2 <> ", \"msgContent\": {\"text\":\"\",\"type\":\"file\"}}") + bob ##> ("/_send @2 json [{\"filePath\": \"./tests/fixtures/test.pdf\", \"quotedItemId\": " <> itemId 2 <> ", \"msgContent\": {\"text\":\"\",\"type\":\"file\"}}]") bob <# "@alice > hey bob" bob <## " test.pdf" bob <# "/f @alice ./tests/fixtures/test.pdf" @@ -287,7 +287,7 @@ testSendImageWithTextAndQuote = B.readFile "./tests/tmp/test.pdf" `shouldReturn` txtSrc -- quoting (file without text) with file uses file name - alice ##> ("/_send @2 json {\"filePath\": \"./tests/fixtures/test.jpg\", \"quotedItemId\": " <> itemId 3 <> ", \"msgContent\": {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}") + alice ##> ("/_send @2 json [{\"filePath\": \"./tests/fixtures/test.jpg\", \"quotedItemId\": " <> itemId 3 <> ", \"msgContent\": {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}]") alice <# "@bob > test.pdf" alice <## " test.jpg" alice <# "/f @bob ./tests/fixtures/test.jpg" @@ -313,7 +313,7 @@ testGroupSendImage = \alice bob cath -> withXFTPServer $ do createGroup3 "team" alice bob cath threadDelay 1000000 - alice ##> "/_send #1 json {\"filePath\": \"./tests/fixtures/test.jpg\", \"msgContent\": {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}" + alice ##> "/_send #1 json [{\"filePath\": \"./tests/fixtures/test.jpg\", \"msgContent\": {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}]" alice <# "/f #team ./tests/fixtures/test.jpg" alice <## "use /fc 1 to cancel sending" concurrentlyN_ @@ -361,7 +361,7 @@ testGroupSendImageWithTextAndQuote = (cath <# "#team bob> hi team") threadDelay 1000000 msgItemId <- lastItemId alice - alice ##> ("/_send #1 json {\"filePath\": \"./tests/fixtures/test.jpg\", \"quotedItemId\": " <> msgItemId <> ", \"msgContent\": {\"text\":\"hey bob\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}") + alice ##> ("/_send #1 json [{\"filePath\": \"./tests/fixtures/test.jpg\", \"quotedItemId\": " <> msgItemId <> ", \"msgContent\": {\"text\":\"hey bob\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}]") alice <# "#team > bob hi team" alice <## " hey bob" alice <# "/f #team ./tests/fixtures/test.jpg" @@ -460,7 +460,7 @@ testXFTPFileTransferEncrypted = let fileJSON = LB.unpack $ J.encode $ CryptoFile srcPath $ Just cfArgs withXFTPServer $ do connectUsers alice bob - alice ##> ("/_send @2 json {\"msgContent\":{\"type\":\"file\", \"text\":\"\"}, \"fileSource\": " <> fileJSON <> "}") + alice ##> ("/_send @2 json [{\"msgContent\":{\"type\":\"file\", \"text\":\"\"}, \"fileSource\": " <> fileJSON <> "}]") alice <# "/f @bob ./tests/tmp/alice/test.pdf" alice <## "use /fc 1 to cancel sending" bob <# "alice> sends file test.pdf (266.0 KiB / 272376 bytes)" diff --git a/tests/ChatTests/Forward.hs b/tests/ChatTests/Forward.hs index d49c6df955..221a2426b1 100644 --- a/tests/ChatTests/Forward.hs +++ b/tests/ChatTests/Forward.hs @@ -33,6 +33,8 @@ chatForwardTests = do it "with relative paths: from contact to contact" testForwardFileContactToContact it "with relative paths: from group to notes" testForwardFileGroupToNotes it "with relative paths: from notes to group" testForwardFileNotesToGroup + describe "multi forward api" $ do + it "from contact to contact" testForwardContactToContactMulti testForwardContactToContact :: HasCallStack => FilePath -> IO () testForwardContactToContact = @@ -384,7 +386,7 @@ testForwardFileNoFilesFolder = connectUsers bob cath -- send original file - alice ##> "/_send @2 json {\"filePath\": \"./tests/fixtures/test.pdf\", \"msgContent\": {\"type\": \"text\", \"text\": \"hi\"}}" + alice ##> "/_send @2 json [{\"filePath\": \"./tests/fixtures/test.pdf\", \"msgContent\": {\"type\": \"text\", \"text\": \"hi\"}}]" alice <# "@bob hi" alice <# "/f @bob ./tests/fixtures/test.pdf" alice <## "use /fc 1 to cancel sending" @@ -441,7 +443,7 @@ testForwardFileContactToContact = connectUsers bob cath -- send original file - alice ##> "/_send @2 json {\"filePath\": \"test.pdf\", \"msgContent\": {\"type\": \"text\", \"text\": \"hi\"}}" + alice ##> "/_send @2 json [{\"filePath\": \"test.pdf\", \"msgContent\": {\"type\": \"text\", \"text\": \"hi\"}}]" alice <# "@bob hi" alice <# "/f @bob test.pdf" alice <## "use /fc 1 to cancel sending" @@ -506,7 +508,7 @@ testForwardFileGroupToNotes = createCCNoteFolder cath -- send original file - alice ##> "/_send #1 json {\"filePath\": \"test.pdf\", \"msgContent\": {\"type\": \"text\", \"text\": \"hi\"}}" + alice ##> "/_send #1 json [{\"filePath\": \"test.pdf\", \"msgContent\": {\"type\": \"text\", \"text\": \"hi\"}}]" alice <# "#team hi" alice <# "/f #team test.pdf" alice <## "use /fc 1 to cancel sending" @@ -555,7 +557,7 @@ testForwardFileNotesToGroup = createGroup2 "team" alice cath -- create original file - alice ##> "/_create *1 json {\"filePath\": \"test.pdf\", \"msgContent\": {\"type\": \"text\", \"text\": \"hi\"}}" + alice ##> "/_create *1 json [{\"filePath\": \"test.pdf\", \"msgContent\": {\"type\": \"text\", \"text\": \"hi\"}}]" alice <# "* hi" alice <# "* file 1 (test.pdf)" @@ -590,3 +592,31 @@ testForwardFileNotesToGroup = alice <## "notes: all messages are removed" fwdFileExists <- doesFileExist "./tests/tmp/alice_files/test_1.pdf" fwdFileExists `shouldBe` True + +testForwardContactToContactMulti :: HasCallStack => FilePath -> IO () +testForwardContactToContactMulti = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + connectUsers alice bob + connectUsers alice cath + connectUsers bob cath + + alice #> "@bob hi" + bob <# "alice> hi" + msgId1 <- lastItemId alice + + threadDelay 1000000 + + bob #> "@alice hey" + alice <# "bob> hey" + msgId2 <- lastItemId alice + + alice ##> ("/_forward @3 @2 " <> msgId1 <> "," <> msgId2) + alice <# "@cath <- you @bob" + alice <## " hi" + alice <# "@cath <- @bob" + alice <## " hey" + cath <# "alice> -> forwarded" + cath <## " hi" + cath <# "alice> -> forwarded" + cath <## " hey" diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index d6849d3074..1ff01a911c 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -64,6 +64,7 @@ chatGroupTests = do it "moderate message of another group member (full delete)" testGroupModerateFullDelete it "moderate message that arrives after the event of moderation" testGroupDelayedModeration it "moderate message that arrives after the event of moderation (full delete)" testGroupDelayedModerationFullDelete + it "send multiple messages api" testSendMulti describe "async group connections" $ do xit "create and join group when clients go offline" testGroupAsync describe "group links" $ do @@ -1818,6 +1819,18 @@ testGroupDelayedModerationFullDelete tmp = do where cfg = testCfgCreateGroupDirect +testSendMulti :: HasCallStack => FilePath -> IO () +testSendMulti = + testChat2 aliceProfile bobProfile $ + \alice bob -> do + createGroup2 "team" alice bob + + alice ##> "/_send #1 json [{\"msgContent\": {\"type\": \"text\", \"text\": \"test 1\"}}, {\"msgContent\": {\"type\": \"text\", \"text\": \"test 2\"}}]" + alice <# "#team test 1" + alice <# "#team test 2" + bob <# "#team alice> test 1" + bob <# "#team alice> test 2" + testGroupAsync :: HasCallStack => FilePath -> IO () testGroupAsync tmp = do withNewTestChat tmp "alice" aliceProfile $ \alice -> do @@ -3468,7 +3481,8 @@ testGroupSyncRatchet tmp = bob <## "1 contacts connected (use /cs for the list)" bob <## "#team: connected to server(s)" bob `send` "#team 1" - bob <## "error: command is prohibited, sendMessagesB: send prohibited" -- silence? + -- "send prohibited" error is not printed in group as SndMessage is created, + -- but it should be displayed in per member snd statuses bob <# "#team 1" (alice "/_send #1 json {\"filePath\": \"./tests/tmp/testfile\", \"msgContent\": {\"text\":\"hello\",\"type\":\"file\"}}" + bob ##> "/_send #1 json [{\"filePath\": \"./tests/tmp/testfile\", \"msgContent\": {\"text\":\"hello\",\"type\":\"file\"}}]" bob <# "#team hello" bob <# "/f #team ./tests/tmp/testfile" bob <## "use /fc 1 to cancel sending" @@ -4969,7 +4983,7 @@ testGroupHistoryMultipleFiles = threadDelay 1000000 - bob ##> "/_send #1 json {\"filePath\": \"./tests/tmp/testfile_bob\", \"msgContent\": {\"text\":\"hi alice\",\"type\":\"file\"}}" + bob ##> "/_send #1 json [{\"filePath\": \"./tests/tmp/testfile_bob\", \"msgContent\": {\"text\":\"hi alice\",\"type\":\"file\"}}]" bob <# "#team hi alice" bob <# "/f #team ./tests/tmp/testfile_bob" bob <## "use /fc 1 to cancel sending" @@ -4981,7 +4995,7 @@ testGroupHistoryMultipleFiles = threadDelay 1000000 - alice ##> "/_send #1 json {\"filePath\": \"./tests/tmp/testfile_alice\", \"msgContent\": {\"text\":\"hey bob\",\"type\":\"file\"}}" + alice ##> "/_send #1 json [{\"filePath\": \"./tests/tmp/testfile_alice\", \"msgContent\": {\"text\":\"hey bob\",\"type\":\"file\"}}]" alice <# "#team hey bob" alice <# "/f #team ./tests/tmp/testfile_alice" alice <## "use /fc 2 to cancel sending" @@ -5047,7 +5061,7 @@ testGroupHistoryFileCancel = createGroup2 "team" alice bob - bob ##> "/_send #1 json {\"filePath\": \"./tests/tmp/testfile_bob\", \"msgContent\": {\"text\":\"hi alice\",\"type\":\"file\"}}" + bob ##> "/_send #1 json [{\"filePath\": \"./tests/tmp/testfile_bob\", \"msgContent\": {\"text\":\"hi alice\",\"type\":\"file\"}}]" bob <# "#team hi alice" bob <# "/f #team ./tests/tmp/testfile_bob" bob <## "use /fc 1 to cancel sending" @@ -5063,7 +5077,7 @@ testGroupHistoryFileCancel = threadDelay 1000000 - alice ##> "/_send #1 json {\"filePath\": \"./tests/tmp/testfile_alice\", \"msgContent\": {\"text\":\"hey bob\",\"type\":\"file\"}}" + alice ##> "/_send #1 json [{\"filePath\": \"./tests/tmp/testfile_alice\", \"msgContent\": {\"text\":\"hey bob\",\"type\":\"file\"}}]" alice <# "#team hey bob" alice <# "/f #team ./tests/tmp/testfile_alice" alice <## "use /fc 2 to cancel sending" diff --git a/tests/ChatTests/Local.hs b/tests/ChatTests/Local.hs index 5562d517ac..f097edbc0c 100644 --- a/tests/ChatTests/Local.hs +++ b/tests/ChatTests/Local.hs @@ -17,6 +17,7 @@ chatLocalChatsTests :: SpecWith FilePath chatLocalChatsTests = do describe "note folders" $ do it "create folders, add notes, read, search" testNotes + it "create multiple messages api" testCreateMulti it "switch users" testUserNotes it "preview pagination for notes" testPreviewsPagination it "chat pagination" testChatPagination @@ -52,6 +53,14 @@ testNotes tmp = withNewTestChat tmp "alice" aliceProfile $ \alice -> do alice ##> "/tail *" alice <# "* Greetings." +testCreateMulti :: FilePath -> IO () +testCreateMulti tmp = withNewTestChat tmp "alice" aliceProfile $ \alice -> do + createCCNoteFolder alice + + alice ##> "/_create *1 json [{\"msgContent\": {\"type\": \"text\", \"text\": \"test 1\"}}, {\"msgContent\": {\"type\": \"text\", \"text\": \"test 2\"}}]" + alice <# "* test 1" + alice <# "* test 2" + testUserNotes :: FilePath -> IO () testUserNotes tmp = withNewTestChat tmp "alice" aliceProfile $ \alice -> do createCCNoteFolder alice @@ -120,7 +129,7 @@ testFiles tmp = withNewTestChat tmp "alice" aliceProfile $ \alice -> do let source = "./tests/fixtures/test.jpg" let stored = files "test.jpg" copyFile source stored - alice ##> "/_create *1 json {\"filePath\": \"test.jpg\", \"msgContent\": {\"text\":\"hi myself\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}" + alice ##> "/_create *1 json [{\"filePath\": \"test.jpg\", \"msgContent\": {\"text\":\"hi myself\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}]" alice <# "* hi myself" alice <# "* file 1 (test.jpg)" @@ -141,7 +150,7 @@ testFiles tmp = withNewTestChat tmp "alice" aliceProfile $ \alice -> do -- one more file let stored2 = files "another_test.jpg" copyFile source stored2 - alice ##> "/_create *1 json {\"filePath\": \"another_test.jpg\", \"msgContent\": {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}" + alice ##> "/_create *1 json [{\"filePath\": \"another_test.jpg\", \"msgContent\": {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}]" alice <# "* file 2 (another_test.jpg)" alice ##> "/_delete item *1 2 internal" @@ -173,8 +182,8 @@ testOtherFiles = bob ##> "/fr 1" bob <### [ "saving file 1 from alice to test.jpg", - "started receiving file 1 (test.jpg) from alice" - ] + "started receiving file 1 (test.jpg) from alice" + ] bob <## "completed receiving file 1 (test.jpg) from alice" bob /* "test" diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index 43ad5ba841..878546ba21 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -1721,7 +1721,7 @@ testSetContactPrefs = testChat2 aliceProfile bobProfile $ let startFeatures = [(0, e2eeInfoPQStr), (0, "Disappearing messages: allowed"), (0, "Full deletion: off"), (0, "Message reactions: enabled"), (0, "Voice messages: off"), (0, "Audio/video calls: enabled")] alice #$> ("/_get chat @2 count=100", chat, startFeatures) bob #$> ("/_get chat @2 count=100", chat, startFeatures) - let sendVoice = "/_send @2 json {\"filePath\": \"test.txt\", \"msgContent\": {\"type\": \"voice\", \"text\": \"\", \"duration\": 10}}" + let sendVoice = "/_send @2 json [{\"filePath\": \"test.txt\", \"msgContent\": {\"type\": \"voice\", \"text\": \"\", \"duration\": 10}}]" voiceNotAllowed = "bad chat command: feature not allowed Voice messages" alice ##> sendVoice alice <## voiceNotAllowed @@ -2227,7 +2227,7 @@ testGroupPrefsSimplexLinksForRole = testChat3 aliceProfile bobProfile cathProfil inv <- getInvitation bob bob ##> ("#team \"" <> inv <> "\\ntest\"") bob <## "bad chat command: feature not allowed SimpleX links" - bob ##> ("/_send #1 json {\"msgContent\": {\"type\": \"text\", \"text\": \"" <> inv <> "\\ntest\"}}") + bob ##> ("/_send #1 json [{\"msgContent\": {\"type\": \"text\", \"text\": \"" <> inv <> "\\ntest\"}}]") bob <## "bad chat command: feature not allowed SimpleX links" (alice [SndMessage] -> [ChatError] -> [ByteString] -> IO () runBatcherTest' maxLen msgs expectedErrors expectedBatches = do - let (errors, batches) = partitionEithers $ batchMessages maxLen msgs + let (errors, batches) = partitionEithers $ batchMessages maxLen (map Right msgs) batchedStrs = map (\(MsgBatch batchBody _) -> batchBody) batches testErrors errors `shouldBe` testErrors expectedErrors batchedStrs `shouldBe` expectedBatches diff --git a/tests/RemoteTests.hs b/tests/RemoteTests.hs index 3f1bad613a..e51a938252 100644 --- a/tests/RemoteTests.hs +++ b/tests/RemoteTests.hs @@ -238,7 +238,7 @@ remoteStoreFileTest = desktop ##> "/get remote file 1 {\"userId\": 1, \"fileId\": 1, \"sent\": true, \"fileSource\": {\"filePath\": \"test_1.pdf\"}}" hostError desktop "SEFileNotFound" -- send file not encrypted locally on mobile host - desktop ##> "/_send @2 json {\"filePath\": \"test_1.pdf\", \"msgContent\": {\"type\": \"file\", \"text\": \"sending a file\"}}" + desktop ##> "/_send @2 json [{\"filePath\": \"test_1.pdf\", \"msgContent\": {\"type\": \"file\", \"text\": \"sending a file\"}}]" desktop <# "@bob sending a file" desktop <# "/f @bob test_1.pdf" desktop <## "use /fc 1 to cancel sending" @@ -268,7 +268,7 @@ remoteStoreFileTest = B.readFile (desktopHostStore "test_1.pdf") `shouldReturn` src -- send file encrypted locally on mobile host - desktop ##> ("/_send @2 json {\"fileSource\": {\"filePath\":\"test_2.pdf\", \"cryptoArgs\": " <> LB.unpack (J.encode cfArgs) <> "}, \"msgContent\": {\"type\": \"file\", \"text\": \"\"}}") + desktop ##> ("/_send @2 json [{\"fileSource\": {\"filePath\":\"test_2.pdf\", \"cryptoArgs\": " <> LB.unpack (J.encode cfArgs) <> "}, \"msgContent\": {\"type\": \"file\", \"text\": \"\"}}]") desktop <# "/f @bob test_2.pdf" desktop <## "use /fc 2 to cancel sending" bob <# "alice> sends file test_2.pdf (266.0 KiB / 272376 bytes)"