mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-06-04 03:51:48 +00:00
wip
This commit is contained in:
spaced4ndy
@@ -324,6 +324,8 @@ data ChatCommand
|
||||
| APIGetChatItems {chatPagination :: ChatPagination, search :: Maybe Text}
|
||||
| APIGetChatItemInfo {chatRef :: ChatRef, chatItemId :: ChatItemId}
|
||||
| APISendMessages {sendRef :: SendRef, liveMessage :: Bool, ttl :: Maybe Int, composedMessages :: NonEmpty ComposedMessage}
|
||||
| APISendComment {groupId :: GroupId, parentChatItemId :: ChatItemId, liveMessage :: Bool, ttl :: Maybe Int, composedMessages :: NonEmpty ComposedMessage}
|
||||
| APISetCommentsDisabled {groupId :: GroupId, parentChatItemId :: ChatItemId, disabled :: Bool}
|
||||
| APICreateChatTag ChatTagData
|
||||
| APISetChatTags ChatRef (Maybe (NonEmpty ChatTagId))
|
||||
| APIDeleteChatTag ChatTagId
|
||||
|
||||
@@ -563,7 +563,7 @@ processChatCommand vr nm = \case
|
||||
(directChat, navInfo) <- withFastStore (\db -> getDirectChat db vr user cId contentFilter pagination search)
|
||||
pure $ CRApiChat user (AChat SCTDirect directChat) navInfo
|
||||
CTGroup -> do
|
||||
(groupChat, navInfo) <- withFastStore (\db -> getGroupChat db vr user cId scope_ contentFilter pagination search)
|
||||
(groupChat, navInfo) <- withFastStore (\db -> getGroupChat db vr user cId scope_ Nothing contentFilter pagination search)
|
||||
groupChat' <- checkSupportChatAttention user groupChat
|
||||
pure $ CRApiChat user (AChat SCTGroup groupChat') navInfo
|
||||
CTLocal -> do
|
||||
@@ -627,6 +627,31 @@ processChatCommand vr nm = \case
|
||||
g <- getGroupInfo db vr user chatId
|
||||
(g,) <$> mapM (composedMessageReqMentions db user g) cms
|
||||
sendGroupContentMessages user gInfo gsScope asGroup live itemTTL cmrs
|
||||
APISendComment groupId parentItemId live itemTTL cms -> withUser $ \user -> do
|
||||
mapM_ assertAllowedContent' cms
|
||||
withGroupLock "sendComment" groupId $ do
|
||||
gInfo <- withFastStore $ \db -> getGroupInfo db vr user groupId
|
||||
unless (useRelays' gInfo) $ throwCmdError "comments are only supported in channel groups"
|
||||
(channelMsgInfo, cmrs) <- withFastStore $ \db -> do
|
||||
cmi <- getChannelMsgInfo db user groupId parentItemId
|
||||
cmrs' <- mapM (composedMessageReqMentions db user gInfo) cms
|
||||
pure (cmi, cmrs')
|
||||
assertMultiSendable live cmrs
|
||||
recipients <- getGroupRecipients vr user gInfo Nothing groupKnockingVersion
|
||||
sendGroupContentMessages_ user gInfo Nothing False Nothing (Just channelMsgInfo) recipients live itemTTL cmrs
|
||||
APISetCommentsDisabled groupId parentItemId disabled -> withUser $ \user ->
|
||||
withGroupLock "setCommentsDisabled" groupId $ do
|
||||
gInfo <- withFastStore $ \db -> getGroupInfo db vr user groupId
|
||||
unless (useRelays' gInfo) $ throwCmdError "comments are only supported in channel groups"
|
||||
channelMsgInfo <- withFastStore $ \db -> getChannelMsgInfo db user groupId parentItemId
|
||||
let GroupInfo {membership = GroupMember {memberRole = userRole}} = gInfo
|
||||
when (userRole < GRModerator) $ throwCmdError "user is not allowed to disable comments"
|
||||
withFastStore' $ \db -> setChannelMsgCommentsDisabled db parentItemId disabled
|
||||
let ChannelMsgInfo {channelMsgSharedId} = channelMsgInfo
|
||||
chatMsgEvent = XMsgPrefs {msgId = channelMsgSharedId, comments = MsgCommentsPref {disabled}}
|
||||
recipients <- getGroupRecipients vr user gInfo Nothing groupKnockingVersion
|
||||
void $ sendGroupMessages user gInfo Nothing False recipients (chatMsgEvent :| [])
|
||||
ok user
|
||||
APICreateChatTag (ChatTagData emoji text) -> withUser $ \user -> withFastStore' $ \db -> do
|
||||
_ <- createChatTag db user emoji text
|
||||
CRChatTags user <$> getUserChatTags db user
|
||||
@@ -1281,7 +1306,7 @@ processChatCommand vr nm = \case
|
||||
Just smId ->
|
||||
void $ sendDirectContactMessage user ct $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing Nothing
|
||||
Nothing -> do
|
||||
(msg, _) <- sendDirectContactMessage user ct $ XMsgNew $ MCSimple $ extMsgContent mc Nothing
|
||||
(msg, _) <- sendDirectContactMessage user ct $ XMsgNew $ mcSimple mc
|
||||
ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc)
|
||||
toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDSnd (DirectChat ct) ci]
|
||||
APIRejectContact connReqId -> withUser $ \user -> do
|
||||
@@ -2026,7 +2051,7 @@ processChatCommand vr nm = \case
|
||||
-- create changed feature items (connecting incognito sends default preferences, instead of user preferences)
|
||||
lift . when incognito $ createContactChangedFeatureItems user ct ct'
|
||||
forM_ msgContent_ $ \mc -> do
|
||||
let evt = XMsgNew $ MCSimple (extMsgContent mc Nothing)
|
||||
let evt = XMsgNew $ mcSimple mc
|
||||
(msg, _) <- sendDirectContactMessage user ct' evt
|
||||
ci <- saveSndChatItem user (CDDirectSnd ct') msg (CISndMsgContent mc)
|
||||
toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDSnd (DirectChat ct') ci]
|
||||
@@ -2374,7 +2399,7 @@ processChatCommand vr nm = \case
|
||||
Right conn | directOrUsed ct -> (ct, conn) : ctConns
|
||||
_ -> ctConns
|
||||
ctSndEvent :: (Contact, Connection) -> (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json)
|
||||
ctSndEvent (_, Connection {connId}) = (ConnectionId connId, Nothing, XMsgNew $ MCSimple (extMsgContent mc Nothing))
|
||||
ctSndEvent (_, Connection {connId}) = (ConnectionId connId, Nothing, XMsgNew $ mcSimple mc)
|
||||
ctMsgReq :: (Contact, Connection) -> SndMessage -> ChatMsgReq
|
||||
ctMsgReq (_, conn) SndMessage {msgId, msgBody} = (conn, MsgFlags {notification = hasNotification XMsgNew_}, (vrValue msgBody, [msgId]))
|
||||
combineResults :: (Contact, Connection) -> Either ChatError SndMessage -> Either ChatError ([Int64], PQEncryption) -> Either ChatError (Contact, SndMessage)
|
||||
@@ -2383,7 +2408,7 @@ processChatCommand vr nm = \case
|
||||
combineResults _ _ (Left e) = Left e
|
||||
createCI :: DB.Connection -> User -> Bool -> UTCTime -> (Contact, SndMessage) -> IO ()
|
||||
createCI db user hasLink createdAt (ct, sndMsg) =
|
||||
void $ createNewSndChatItem db user (CDDirectSnd ct) False sndMsg (CISndMsgContent mc) Nothing Nothing Nothing False hasLink createdAt
|
||||
void $ createNewSndChatItem db user (CDDirectSnd ct) False sndMsg (CISndMsgContent mc) Nothing Nothing Nothing Nothing False hasLink createdAt
|
||||
SendMessageQuote cName (AMsgDirection msgDir) quotedMsg msg -> withUser $ \user@User {userId} -> do
|
||||
contactId <- withFastStore $ \db -> getContactIdByName db user cName
|
||||
quotedItemId <- withFastStore $ \db -> getDirectChatItemIdByText db userId contactId msgDir quotedMsg
|
||||
@@ -2445,7 +2470,16 @@ processChatCommand vr nm = \case
|
||||
-- generate owner key, OwnerAuth signed by root key
|
||||
memberId <- MemberId <$> liftIO (encodedRandomBytes gVar 12)
|
||||
(memberPrivKey, ownerAuth) <- liftIO $ SL.newOwnerAuth gVar (unMemberId memberId) rootPrivKey
|
||||
let groupProfile' = (groupProfile :: GroupProfile) {publicGroup = Just PublicGroupProfile {groupType = GTChannel, groupLink = sLnk, publicGroupId = B64UrlByteString entityId}}
|
||||
let GroupProfile {groupPreferences = basePrefs_} = groupProfile
|
||||
basePrefs = fromMaybe emptyGroupPrefs basePrefs_
|
||||
GroupPreferences {comments = commentsPref_} = basePrefs
|
||||
commentsPref = fromMaybe (CommentsGroupPreference {enable = FEOn, closeAfter = Nothing}) commentsPref_
|
||||
channelPrefs = (basePrefs :: GroupPreferences) {comments = Just commentsPref}
|
||||
groupProfile' =
|
||||
(groupProfile :: GroupProfile)
|
||||
{ publicGroup = Just PublicGroupProfile {groupType = GTChannel, groupLink = sLnk, publicGroupId = B64UrlByteString entityId},
|
||||
groupPreferences = Just channelPrefs
|
||||
}
|
||||
userData = encodeShortLinkData $ GroupShortLinkData {groupProfile = groupProfile', publicGroupData = Just (PublicGroupData 1)}
|
||||
userLinkData = UserContactLinkData UserContactData {direct = False, owners = [ownerAuth], relays = [], userData}
|
||||
-- create connection with prepared link (single network call)
|
||||
@@ -2570,7 +2604,7 @@ processChatCommand vr nm = \case
|
||||
void $ sendGroupMessage user gInfo scope ([m] <> rcpModMs') msg
|
||||
when (maxVersion (memberChatVRange m) < groupKnockingVersion) $
|
||||
forM_ (memberConn m) $ \mConn -> do
|
||||
let msg2 = XMsgNew $ MCSimple $ extMsgContent (MCText acceptedToGroupMessage) Nothing
|
||||
let msg2 = XMsgNew $ mcSimple (MCText acceptedToGroupMessage)
|
||||
void $ sendDirectMemberMessage mConn msg2 groupId
|
||||
when (memberCategory m == GCInviteeMember) $ do
|
||||
introduceToRemaining vr user gInfo m {memberRole = role}
|
||||
@@ -2658,7 +2692,7 @@ processChatCommand vr nm = \case
|
||||
(msgs_, _gsr) <- sendGroupMessages user gInfo Nothing False recipients events
|
||||
let signed = any (either (const False) (isJust . signedMsg_)) msgs_
|
||||
itemsData = zipWith (fmap . sndItemData) memsToChange (L.toList msgs_)
|
||||
cis_ <- saveSndChatItems user (CDGroupSnd gInfo Nothing) False itemsData Nothing False
|
||||
cis_ <- saveSndChatItems user (CDGroupSnd gInfo Nothing) False itemsData Nothing Nothing False
|
||||
when (length cis_ /= length memsToChange) $ logError "changeRoleCurrentMems: memsToChange and cis_ length mismatch"
|
||||
(errs, changed) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (updMember db) memsToChange)
|
||||
let acis = map (AChatItem SCTGroup SMDSnd (GroupChat gInfo Nothing)) $ rights cis_
|
||||
@@ -2706,7 +2740,7 @@ processChatCommand vr nm = \case
|
||||
(msgs_, _gsr) <- sendGroupMessages_ user gInfo recipients events
|
||||
let msgSigned = any (either (const False) (isJust . signedMsg_)) msgs_
|
||||
itemsData = zipWith (fmap . sndItemData) blockMems (L.toList msgs_)
|
||||
cis_ <- saveSndChatItems user (CDGroupSnd gInfo Nothing) False itemsData Nothing False
|
||||
cis_ <- saveSndChatItems user (CDGroupSnd gInfo Nothing) False itemsData Nothing Nothing False
|
||||
when (length cis_ /= length blockMems) $ logError "blockMembers: blockMems and cis_ length mismatch"
|
||||
let acis = map (AChatItem SCTGroup SMDSnd (GroupChat gInfo Nothing)) $ rights cis_
|
||||
unless (null acis) $ toView $ CEvtNewChatItems user acis
|
||||
@@ -2795,7 +2829,7 @@ processChatCommand vr nm = \case
|
||||
Right (Just a) -> Just $ Right a
|
||||
Left e -> Just $ Left e
|
||||
itemsData = mapMaybe skipUnwantedItem itemsData_
|
||||
cis_ <- saveSndChatItems user (CDGroupSnd gInfo chatScopeInfo) False itemsData Nothing False
|
||||
cis_ <- saveSndChatItems user (CDGroupSnd gInfo chatScopeInfo) False itemsData Nothing Nothing False
|
||||
deleteMembersConnections' user memsToDelete True
|
||||
(errs, deleted) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (delMember db) memsToDelete)
|
||||
let acis = map (AChatItem SCTGroup SMDSnd (GroupChat gInfo chatScopeInfo)) $ rights cis_
|
||||
@@ -4116,7 +4150,7 @@ processChatCommand vr nm = \case
|
||||
msgs_ <- sendDirectContactMessages user ct $ L.map XMsgNew msgContainers
|
||||
let itemsData = prepareSndItemsData (L.toList cmrs) (L.toList ciFiles_) (L.toList quotedItems_) msgs_
|
||||
when (length itemsData /= length cmrs) $ logError "sendContactContentMessages: cmrs and itemsData length mismatch"
|
||||
r@(_, cis) <- partitionEithers <$> saveSndChatItems user (CDDirectSnd ct) False itemsData timed_ live
|
||||
r@(_, cis) <- partitionEithers <$> saveSndChatItems user (CDDirectSnd ct) False itemsData Nothing timed_ live
|
||||
processSendErrs r
|
||||
forM_ (timed_ >>= timedDeleteAt') $ \deleteAt ->
|
||||
forM_ cis $ \ci ->
|
||||
@@ -4134,9 +4168,10 @@ processChatCommand vr nm = \case
|
||||
prepareMsgs :: NonEmpty (ComposedMessageReq, Maybe FileInvitation) -> Maybe CITimed -> CM (NonEmpty (MsgContainer, Maybe (CIQuote 'CTDirect)))
|
||||
prepareMsgs cmsFileInvs timed_ = withFastStore $ \db ->
|
||||
forM cmsFileInvs $ \((ComposedMessage {quotedItemId, msgContent = mc}, itemForwarded, _, _), fInv_) -> do
|
||||
let base = (mcSimple mc) {file = fInv_, ttl = ttl' <$> timed_, live = justTrue live}
|
||||
case (quotedItemId, itemForwarded) of
|
||||
(Nothing, Nothing) -> pure (MCSimple (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live) Nothing Nothing), Nothing)
|
||||
(Nothing, Just _) -> pure (MCForward (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live) Nothing Nothing), Nothing)
|
||||
(Nothing, Nothing) -> pure (base, Nothing)
|
||||
(Nothing, Just _) -> pure (base {forward = Just True}, Nothing)
|
||||
(Just qiId, Nothing) -> do
|
||||
CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <-
|
||||
getDirectChatItem db user contactId qiId
|
||||
@@ -4144,7 +4179,7 @@ processChatCommand vr nm = \case
|
||||
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 M.empty fInv_ (ttl' <$> timed_) (justTrue live) Nothing Nothing), Just quotedItem)
|
||||
pure (base {quote = Just QuotedMsg {msgRef, content = qmc}}, Just quotedItem)
|
||||
(Just _, Just _) -> throwError SEInvalidQuote
|
||||
where
|
||||
quoteData :: ChatItem c d -> ExceptT StoreError IO (MsgContent, CIQDirection 'CTDirect, Bool)
|
||||
@@ -4157,23 +4192,26 @@ processChatCommand vr nm = \case
|
||||
assertMultiSendable live cmrs
|
||||
chatScopeInfo <- mapM (getChatScopeInfo vr user) scope
|
||||
recipients <- getGroupRecipients vr user gInfo chatScopeInfo modsCompatVersion
|
||||
sendGroupContentMessages_ user gInfo scope showGroupAsSender chatScopeInfo recipients live itemTTL cmrs
|
||||
sendGroupContentMessages_ user gInfo scope showGroupAsSender chatScopeInfo Nothing recipients live itemTTL cmrs
|
||||
where
|
||||
hasReport = any (\(ComposedMessage {msgContent}, _, _, _) -> isReport msgContent) cmrs
|
||||
modsCompatVersion = if hasReport then contentReportsVersion else groupKnockingVersion
|
||||
sendGroupContentMessages_ :: User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> Maybe GroupChatScopeInfo -> [GroupMember] -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse
|
||||
sendGroupContentMessages_ user gInfo@GroupInfo {groupId, membership} scope showGroupAsSender chatScopeInfo recipients live itemTTL cmrs = do
|
||||
sendGroupContentMessages_ :: User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> Maybe GroupChatScopeInfo -> Maybe ChannelMsgInfo -> [GroupMember] -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse
|
||||
sendGroupContentMessages_ user gInfo@GroupInfo {groupId, membership} scope showGroupAsSender chatScopeInfo channelMsgInfo_ recipients live itemTTL cmrs = do
|
||||
forM_ allowedRole $ assertUserGroupRole gInfo
|
||||
assertGroupContentAllowed
|
||||
assertCommentsOpen
|
||||
processComposedMessages
|
||||
where
|
||||
allowedRole :: Maybe GroupMemberRole
|
||||
allowedRole = case scope of
|
||||
Nothing -> Just GRAuthor
|
||||
Just (GCSMemberSupport Nothing)
|
||||
allowedRole = case (scope, channelMsgInfo_) of
|
||||
(Nothing, Nothing) -> Just GRAuthor
|
||||
(Just (GCSMemberSupport Nothing), Nothing)
|
||||
| memberPending membership -> Nothing
|
||||
| otherwise -> Just GRObserver
|
||||
Just (GCSMemberSupport (Just _gmId)) -> Just GRModerator
|
||||
(Just (GCSMemberSupport (Just _gmId)), Nothing) -> Just GRModerator
|
||||
(Nothing, Just _) -> Just GRCommenter
|
||||
_ -> Nothing
|
||||
assertGroupContentAllowed :: CM ()
|
||||
assertGroupContentAllowed =
|
||||
case findProhibited (L.toList cmrs) of
|
||||
@@ -4183,8 +4221,19 @@ processChatCommand vr nm = \case
|
||||
findProhibited :: [ComposedMessageReq] -> Maybe GroupFeature
|
||||
findProhibited =
|
||||
foldr'
|
||||
(\(ComposedMessage {fileSource, msgContent = mc}, _, (_, ft), _) acc -> prohibitedGroupContent gInfo membership chatScopeInfo mc ft fileSource True <|> acc)
|
||||
(\(ComposedMessage {fileSource, msgContent = mc}, _, (_, ft), _) acc -> prohibitedGroupContent gInfo membership chatScopeInfo channelMsgInfo_ mc ft fileSource True <|> acc)
|
||||
Nothing
|
||||
assertCommentsOpen :: CM ()
|
||||
assertCommentsOpen = case channelMsgInfo_ of
|
||||
Just _ -> do
|
||||
now <- liftIO getCurrentTime
|
||||
when (commentsClosed gInfo channelMsgInfo_ now) $
|
||||
throwCmdError "channel post comments are closed"
|
||||
Nothing -> pure ()
|
||||
parentChatItemId_ :: Maybe ChatItemId
|
||||
parentChatItemId_ = (\ChannelMsgInfo {channelMsgItem} -> cChatItemId channelMsgItem) <$> channelMsgInfo_
|
||||
parentRef_ :: Maybe MsgRef
|
||||
parentRef_ = channelMsgRef <$> channelMsgInfo_
|
||||
processComposedMessages :: CM ChatResponse
|
||||
processComposedMessages = do
|
||||
-- TODO [relays] single description for all recipients
|
||||
@@ -4193,7 +4242,7 @@ processChatCommand vr nm = \case
|
||||
(chatMsgEvents, quotedItems_) <- L.unzip <$> prepareMsgs (L.zip cmrs fInvs_) timed_
|
||||
(msgs_, gsr) <- sendGroupMessages user gInfo Nothing showGroupAsSender recipients chatMsgEvents
|
||||
let itemsData = prepareSndItemsData (L.toList cmrs) (L.toList ciFiles_) (L.toList quotedItems_) (L.toList msgs_)
|
||||
cis_ <- saveSndChatItems user (CDGroupSnd gInfo chatScopeInfo) showGroupAsSender itemsData timed_ live
|
||||
cis_ <- saveSndChatItems user (CDGroupSnd gInfo chatScopeInfo) showGroupAsSender itemsData parentChatItemId_ timed_ live
|
||||
when (length cis_ /= length cmrs) $ logError "sendGroupContentMessages: cmrs and cis_ length mismatch"
|
||||
createMemberSndStatuses cis_ msgs_ gsr
|
||||
let r@(_, cis) = partitionEithers cis_
|
||||
@@ -4216,7 +4265,7 @@ processChatCommand vr nm = \case
|
||||
forM cmsFileInvs $ \((ComposedMessage {quotedItemId, msgContent = mc}, itemForwarded, _, ciMentions), fInv_) ->
|
||||
let msgScope = toMsgScope gInfo <$> chatScopeInfo
|
||||
mentions = M.map (\CIMention {memberId} -> MsgMention {memberId}) ciMentions
|
||||
in prepareGroupMsg db user gInfo msgScope showGroupAsSender mc mentions quotedItemId itemForwarded fInv_ timed_ live
|
||||
in prepareGroupMsg db user gInfo msgScope parentRef_ showGroupAsSender mc mentions quotedItemId itemForwarded fInv_ timed_ live
|
||||
createMemberSndStatuses ::
|
||||
[Either ChatError (ChatItem 'CTGroup 'MDSnd)] ->
|
||||
NonEmpty (Either ChatError SndMessage) ->
|
||||
@@ -4754,6 +4803,8 @@ chatCommandP =
|
||||
"/_get items " *> (APIGetChatItems <$> chatPaginationP <*> optional (" search=" *> textP)),
|
||||
"/_get item info " *> (APIGetChatItemInfo <$> chatRefP <* A.space <*> A.decimal),
|
||||
"/_send " *> (APISendMessages <$> sendRefP <*> liveMessageP <*> sendMessageTTLP <*> (" json " *> jsonP <|> " text " *> composedMessagesTextP)),
|
||||
"/_comment #" *> (APISendComment <$> A.decimal <* A.space <*> A.decimal <*> liveMessageP <*> sendMessageTTLP <*> (" json " *> jsonP <|> " text " *> composedMessagesTextP)),
|
||||
"/_comments_disabled #" *> (APISetCommentsDisabled <$> A.decimal <* A.space <*> A.decimal <* A.space <*> onOffP),
|
||||
"/_create tag " *> (APICreateChatTag <$> jsonP),
|
||||
"/_tags " *> (APISetChatTags <$> chatRefP <*> optional _strP),
|
||||
"/_delete tag " *> (APIDeleteChatTag <$> A.decimal),
|
||||
|
||||
@@ -201,25 +201,23 @@ toggleNtf m ntfOn =
|
||||
forM_ (memberConnId m) $ \connId ->
|
||||
withAgent (\a -> toggleConnectionNtfs a connId ntfOn) `catchAllErrors` eToView
|
||||
|
||||
prepareGroupMsg :: DB.Connection -> User -> GroupInfo -> Maybe MsgScope -> ShowGroupAsSender -> MsgContent -> Map MemberName MsgMention -> Maybe ChatItemId -> Maybe CIForwardedFrom -> Maybe FileInvitation -> Maybe CITimed -> Bool -> ExceptT StoreError IO (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup))
|
||||
prepareGroupMsg db user g@GroupInfo {membership} msgScope showGroupAsSender mc mentions quotedItemId_ itemForwarded fInv_ timed_ live = case (quotedItemId_, itemForwarded) of
|
||||
(Nothing, Nothing) ->
|
||||
let mc' = MCSimple $ ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live) msgScope (justTrue showGroupAsSender)
|
||||
in pure (XMsgNew mc', Nothing)
|
||||
(Nothing, Just _) ->
|
||||
let mc' = MCForward $ ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live) msgScope (justTrue showGroupAsSender)
|
||||
in pure (XMsgNew mc', Nothing)
|
||||
(Just quotedItemId, Nothing) -> do
|
||||
CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, mentions = quoteMentions, file} <-
|
||||
getGroupCIWithReactions db user g quotedItemId
|
||||
(origQmc, qd, sent, member_) <- quoteData qci membership
|
||||
let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = memberId' <$> member_}
|
||||
qmc = quoteContent mc origQmc file
|
||||
(qmc', ft', _) = updatedMentionNames qmc formattedText quoteMentions
|
||||
quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc', formattedText = ft'}
|
||||
mc' = MCQuote QuotedMsg {msgRef, content = qmc'} (ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live) msgScope (justTrue showGroupAsSender))
|
||||
pure (XMsgNew mc', Just quotedItem)
|
||||
(Just _, Just _) -> throwError SEInvalidQuote
|
||||
prepareGroupMsg :: DB.Connection -> User -> GroupInfo -> Maybe MsgScope -> Maybe MsgRef -> ShowGroupAsSender -> MsgContent -> Map MemberName MsgMention -> Maybe ChatItemId -> Maybe CIForwardedFrom -> Maybe FileInvitation -> Maybe CITimed -> Bool -> ExceptT StoreError IO (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup))
|
||||
prepareGroupMsg db user g@GroupInfo {membership} msgScope parentRef_ showGroupAsSender mc mentions quotedItemId_ itemForwarded fInv_ timed_ live = do
|
||||
let base = (mcSimple mc) {mentions, file = fInv_, ttl = ttl' <$> timed_, live = justTrue live, scope = msgScope, asGroup = justTrue showGroupAsSender, parent = parentRef_}
|
||||
case (quotedItemId_, itemForwarded) of
|
||||
(Nothing, Nothing) -> pure (XMsgNew base, Nothing)
|
||||
(Nothing, Just _) -> pure (XMsgNew base {forward = Just True}, Nothing)
|
||||
(Just quotedItemId, Nothing) -> do
|
||||
CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, mentions = quoteMentions, file} <-
|
||||
getGroupCIWithReactions db user g quotedItemId
|
||||
(origQmc, qd, sent, member_) <- quoteData qci membership
|
||||
let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = memberId' <$> member_}
|
||||
qmc = quoteContent mc origQmc file
|
||||
(qmc', ft', _) = updatedMentionNames qmc formattedText quoteMentions
|
||||
quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc', formattedText = ft'}
|
||||
mc' = base {quote = Just QuotedMsg {msgRef, content = qmc'}}
|
||||
pure (XMsgNew mc', Just quotedItem)
|
||||
(Just _, Just _) -> throwError SEInvalidQuote
|
||||
where
|
||||
quoteData :: ChatItem c d -> GroupMember -> ExceptT StoreError IO (MsgContent, CIQDirection 'CTGroup, Bool, Maybe GroupMember)
|
||||
quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} _ = throwError SEInvalidQuote
|
||||
@@ -338,13 +336,20 @@ quoteContent mc qmc ciFile_
|
||||
qFileName = maybe qText (T.pack . getFileName) ciFile_
|
||||
qTextOrFile = if T.null qText then qFileName else qText
|
||||
|
||||
prohibitedGroupContent :: GroupInfo -> GroupMember -> Maybe GroupChatScopeInfo -> MsgContent -> Maybe MarkdownList -> Maybe f -> Bool -> Maybe GroupFeature
|
||||
prohibitedGroupContent gInfo@GroupInfo {membership = mem@GroupMember {memberRole = userRole}} m scopeInfo mc ft file_ sent
|
||||
prohibitedGroupContent :: GroupInfo -> GroupMember -> Maybe GroupChatScopeInfo -> Maybe ChannelMsgInfo -> MsgContent -> Maybe MarkdownList -> Maybe f -> Bool -> Maybe GroupFeature
|
||||
prohibitedGroupContent gInfo@GroupInfo {membership = mem@GroupMember {memberRole = userRole}} m scopeInfo channelMsgInfo mc ft file_ sent
|
||||
| isVoice mc && not (groupFeatureMemberAllowed SGFVoice m gInfo) && not hostApprovalVoice = Just GFVoice
|
||||
| isNothing scopeInfo && not (isVoice mc) && isJust file_ && not (groupFeatureMemberAllowed SGFFiles m gInfo) = Just GFFiles
|
||||
| isNothing scopeInfo && isReport mc && (badReportUser || not (groupFeatureAllowed SGFReports gInfo)) = Just GFReports
|
||||
| isNothing scopeInfo && prohibitedSimplexLinks gInfo m ft = Just GFSimplexLinks
|
||||
| otherwise = Nothing
|
||||
| otherwise = case channelMsgInfo of
|
||||
Just ChannelMsgInfo {channelMsgItem = CChatItem _ ChatItem {meta = CIMeta {itemDeleted, commentsDisabled}}}
|
||||
| not (useRelays' gInfo) -> Just GFComments
|
||||
| not (groupFeatureAllowed SGFComments gInfo) -> Just GFComments
|
||||
| isJust itemDeleted -> Just GFComments
|
||||
| commentsDisabled -> Just GFComments
|
||||
| otherwise -> Nothing
|
||||
Nothing -> Nothing
|
||||
where
|
||||
hostApprovalVoice
|
||||
| sent = userRole >= GRAdmin && sendApprovalPhase
|
||||
@@ -360,6 +365,19 @@ prohibitedGroupContent gInfo@GroupInfo {membership = mem@GroupMember {memberRole
|
||||
| sent = userRole >= GRModerator
|
||||
| otherwise = userRole < GRModerator
|
||||
|
||||
-- True iff the channel post's commenting window has expired.
|
||||
-- The group preference `comments.closeAfter` is the duration in seconds
|
||||
-- since post creation; `Nothing` means the window never closes.
|
||||
commentsClosed :: GroupInfo -> Maybe ChannelMsgInfo -> UTCTime -> Bool
|
||||
commentsClosed
|
||||
GroupInfo {fullGroupPreferences = FullGroupPreferences {comments = CommentsGroupPreference {closeAfter}}}
|
||||
(Just ChannelMsgInfo {channelMsgItem = CChatItem _ ChatItem {meta = CIMeta {itemTs}}})
|
||||
now =
|
||||
case closeAfter of
|
||||
Just secs -> diffUTCTime now itemTs > fromIntegral secs
|
||||
Nothing -> False
|
||||
commentsClosed _ Nothing _ = False
|
||||
|
||||
prohibitedSimplexLinks :: GroupInfo -> GroupMember -> Maybe MarkdownList -> Bool
|
||||
prohibitedSimplexLinks gInfo m ft =
|
||||
not (groupFeatureMemberAllowed SGFSimplexLinks m gInfo)
|
||||
@@ -1062,7 +1080,7 @@ introduceToModerators vr user gInfo@GroupInfo {groupId} m@GroupMember {memberRol
|
||||
let msg =
|
||||
if maxVersion (memberChatVRange m) >= groupKnockingVersion
|
||||
then XGrpLinkAcpt GAPendingReview memberRole memberId
|
||||
else XMsgNew $ MCSimple $ extMsgContent (MCText pendingReviewMessage) Nothing
|
||||
else XMsgNew $ mcSimple (MCText pendingReviewMessage)
|
||||
void $ sendDirectMemberMessage mConn msg groupId
|
||||
modMs <- withStore' $ \db -> getGroupModerators db vr user gInfo
|
||||
let rcpModMs = filter shouldIntroduceToMod modMs
|
||||
@@ -1197,7 +1215,7 @@ sendHistory user gInfo@GroupInfo {membership} m@GroupMember {activeConn = Just c
|
||||
descrEvent_
|
||||
| m `supportsVersion` groupHistoryIncludeWelcomeVersion = do
|
||||
let GroupInfo {groupProfile = GroupProfile {description}} = gInfo
|
||||
fmap (\descr -> XMsgNew $ MCSimple $ extMsgContent (MCText descr) Nothing) description
|
||||
fmap (\descr -> XMsgNew $ mcSimple (MCText descr)) description
|
||||
| otherwise = Nothing
|
||||
itemForwardEvents :: CChatItem 'CTGroup -> CM [ChatMsgEvent 'Json]
|
||||
itemForwardEvents cci = case cci of
|
||||
@@ -1254,7 +1272,7 @@ sendHistory user gInfo@GroupInfo {membership} m@GroupMember {activeConn = Just c
|
||||
mentions'' = M.map (\CIMention {memberId} -> MsgMention {memberId}) mentions'
|
||||
asGroup = isNothing sender_
|
||||
-- TODO [knocking] send history to other scopes too?
|
||||
(chatMsgEvent, _) <- withStore $ \db -> prepareGroupMsg db user gInfo Nothing asGroup mc' mentions'' quotedItemId_ Nothing fInv_ itemTimed False
|
||||
(chatMsgEvent, _) <- withStore $ \db -> prepareGroupMsg db user gInfo Nothing Nothing asGroup mc' mentions'' quotedItemId_ Nothing fInv_ itemTimed False
|
||||
-- for channel messages default chat version range to membership range
|
||||
let senderVRange = maybe (memberChatVRange' membership) memberChatVRange' sender_
|
||||
xMsgNewChatMsg = ChatMessage {chatVRange = senderVRange, msgId = itemSharedMsgId, chatMsgEvent}
|
||||
@@ -2286,7 +2304,7 @@ saveSndChatItem user cd msg content = saveSndChatItem' user cd msg content Nothi
|
||||
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 content ciFile quotedItem itemForwarded itemTimed live = do
|
||||
let itemTexts = ciContentTexts content
|
||||
saveSndChatItems user cd False [Right NewSndChatItemData {msg, content, itemTexts, itemMentions = M.empty, ciFile, quotedItem, itemForwarded}] itemTimed live >>= \case
|
||||
saveSndChatItems user cd False [Right NewSndChatItemData {msg, content, itemTexts, itemMentions = M.empty, ciFile, quotedItem, itemForwarded}] Nothing itemTimed live >>= \case
|
||||
[Right ci] -> pure ci
|
||||
_ -> throwChatError $ CEInternalError "saveSndChatItem': expected 1 item"
|
||||
|
||||
@@ -2307,10 +2325,11 @@ saveSndChatItems ::
|
||||
ChatDirection c 'MDSnd ->
|
||||
ShowGroupAsSender ->
|
||||
[Either ChatError (NewSndChatItemData c)] ->
|
||||
Maybe ChatItemId ->
|
||||
Maybe CITimed ->
|
||||
Bool ->
|
||||
CM [Either ChatError (ChatItem c 'MDSnd)]
|
||||
saveSndChatItems user cd showGroupAsSender itemsData itemTimed live = do
|
||||
saveSndChatItems user cd showGroupAsSender itemsData parentChatItemId_ itemTimed live = do
|
||||
createdAt <- liftIO getCurrentTime
|
||||
vr <- chatVersionRange
|
||||
when (contactChatDeleted cd || any (\NewSndChatItemData {content} -> ciRequiresAttention content) (rights itemsData)) $
|
||||
@@ -2320,9 +2339,9 @@ saveSndChatItems user cd showGroupAsSender itemsData itemTimed live = do
|
||||
createItem :: DB.Connection -> UTCTime -> NewSndChatItemData c -> IO (Either ChatError (ChatItem c 'MDSnd))
|
||||
createItem db createdAt NewSndChatItemData {msg = msg@SndMessage {sharedMsgId, signedMsg_}, content, itemTexts, itemMentions, ciFile, quotedItem, itemForwarded} = do
|
||||
let hasLink_ = ciContentHasLink content (snd itemTexts)
|
||||
ciId <- createNewSndChatItem db user cd showGroupAsSender msg content quotedItem itemForwarded itemTimed live hasLink_ createdAt
|
||||
ciId <- createNewSndChatItem db user cd showGroupAsSender msg content quotedItem itemForwarded parentChatItemId_ itemTimed live hasLink_ createdAt
|
||||
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt
|
||||
let ci = mkChatItem_ cd showGroupAsSender ciId content itemTexts ciFile quotedItem (Just sharedMsgId) itemForwarded itemTimed live False hasLink_ createdAt Nothing (MSSVerified <$ signedMsg_) createdAt
|
||||
let ci = mkChatItem_ cd showGroupAsSender ciId content itemTexts ciFile quotedItem (Just sharedMsgId) itemForwarded parentChatItemId_ itemTimed live False hasLink_ createdAt Nothing (MSSVerified <$ signedMsg_) createdAt
|
||||
Right <$> case cd of
|
||||
CDGroupSnd g _scope | not (null itemMentions) -> createGroupCIMentions db g ci itemMentions
|
||||
_ -> pure ci
|
||||
@@ -2332,13 +2351,13 @@ saveRcvChatItemNoParse user cd msg brokerTs = saveRcvChatItem user cd msg broker
|
||||
|
||||
saveRcvChatItem :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> UTCTime -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)) -> CM (ChatItem c 'MDRcv, ChatInfo c)
|
||||
saveRcvChatItem user cd msg@RcvMessage {sharedMsgId_} brokerTs content =
|
||||
saveRcvChatItem' user cd msg sharedMsgId_ brokerTs content Nothing Nothing False M.empty
|
||||
saveRcvChatItem' user cd msg sharedMsgId_ brokerTs content Nothing Nothing Nothing False M.empty
|
||||
|
||||
ciContentNoParse :: CIContent 'MDRcv -> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
|
||||
ciContentNoParse content = (content, (ciContentToText content, Nothing))
|
||||
|
||||
saveRcvChatItem' :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> UTCTime -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)) -> Maybe (CIFile 'MDRcv) -> Maybe CITimed -> Bool -> Map MemberName MsgMention -> CM (ChatItem c 'MDRcv, ChatInfo c)
|
||||
saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, msgSigned, forwardedByMember} sharedMsgId_ brokerTs (content, (t, ft_)) ciFile itemTimed live mentions = do
|
||||
saveRcvChatItem' :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> UTCTime -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)) -> Maybe (CIFile 'MDRcv) -> Maybe ChatItemId -> Maybe CITimed -> Bool -> Map MemberName MsgMention -> CM (ChatItem c 'MDRcv, ChatInfo c)
|
||||
saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, msgSigned, forwardedByMember} sharedMsgId_ brokerTs (content, (t, ft_)) ciFile parentChatItemId_ itemTimed live mentions = do
|
||||
createdAt <- liftIO getCurrentTime
|
||||
vr <- chatVersionRange
|
||||
withStore' $ \db -> do
|
||||
@@ -2351,9 +2370,9 @@ saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, msgSigned, forwardedByMem
|
||||
else pure $ toChatInfo cd
|
||||
let showAsGroup = case cd of CDChannelRcv {} -> True; _ -> False
|
||||
hasLink_ = ciContentHasLink content ft_
|
||||
(ciId, quotedItem, itemForwarded) <- createNewRcvChatItem db user cd msg sharedMsgId_ content itemTimed live userMention hasLink_ brokerTs createdAt
|
||||
(ciId, quotedItem, itemForwarded) <- createNewRcvChatItem db user cd msg sharedMsgId_ content parentChatItemId_ itemTimed live userMention hasLink_ brokerTs createdAt
|
||||
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt
|
||||
let ci = mkChatItem_ cd showAsGroup ciId content (t, ft_) ciFile quotedItem sharedMsgId_ itemForwarded itemTimed live userMention hasLink_ brokerTs forwardedByMember msgSigned createdAt
|
||||
let ci = mkChatItem_ cd showAsGroup ciId content (t, ft_) ciFile quotedItem sharedMsgId_ itemForwarded parentChatItemId_ itemTimed live userMention hasLink_ brokerTs forwardedByMember msgSigned createdAt
|
||||
ci' <- case toChatInfo cd of
|
||||
GroupChat g _ | not (null mentions') -> createGroupCIMentions db g ci mentions'
|
||||
_ -> pure ci
|
||||
@@ -2377,16 +2396,16 @@ saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, msgSigned, forwardedByMem
|
||||
_ -> Nothing
|
||||
|
||||
-- TODO [mentions] optimize by avoiding unnecessary parsing
|
||||
mkChatItem :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> ChatItem c d
|
||||
mkChatItem cd showGroupAsSender ciId content file quotedItem sharedMsgId itemForwarded itemTimed live userMention itemTs forwardedByMember currentTs =
|
||||
mkChatItem :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe ChatItemId -> Maybe CITimed -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> ChatItem c d
|
||||
mkChatItem cd showGroupAsSender ciId content file quotedItem sharedMsgId itemForwarded parentChatItemId_ itemTimed live userMention itemTs forwardedByMember currentTs =
|
||||
let ts@(_, ft_) = ciContentTexts content
|
||||
hasLink_ = ciContentHasLink content ft_
|
||||
in mkChatItem_ cd showGroupAsSender ciId content ts file quotedItem sharedMsgId itemForwarded itemTimed live userMention hasLink_ itemTs forwardedByMember Nothing currentTs
|
||||
in mkChatItem_ cd showGroupAsSender ciId content ts file quotedItem sharedMsgId itemForwarded parentChatItemId_ itemTimed live userMention hasLink_ itemTs forwardedByMember Nothing currentTs
|
||||
|
||||
mkChatItem_ :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> (Text, Maybe MarkdownList) -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> Maybe MsgSigStatus -> UTCTime -> ChatItem c d
|
||||
mkChatItem_ cd showGroupAsSender ciId content (itemText, formattedText) file quotedItem sharedMsgId itemForwarded itemTimed live userMention hasLink_ itemTs forwardedByMember msgSigned currentTs =
|
||||
mkChatItem_ :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> (Text, Maybe MarkdownList) -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe ChatItemId -> Maybe CITimed -> Bool -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> Maybe MsgSigStatus -> UTCTime -> ChatItem c d
|
||||
mkChatItem_ cd showGroupAsSender ciId content (itemText, formattedText) file quotedItem sharedMsgId itemForwarded parentChatItemId_ itemTimed live userMention hasLink_ itemTs forwardedByMember msgSigned currentTs =
|
||||
let itemStatus = ciCreateStatus content
|
||||
meta = mkCIMeta ciId content itemText itemStatus Nothing sharedMsgId itemForwarded Nothing False itemTimed (justTrue live) userMention hasLink_ currentTs itemTs forwardedByMember showGroupAsSender msgSigned currentTs currentTs
|
||||
meta = mkCIMeta ciId content itemText itemStatus Nothing sharedMsgId itemForwarded Nothing False itemTimed (justTrue live) userMention hasLink_ currentTs itemTs forwardedByMember showGroupAsSender msgSigned parentChatItemId_ 0 False currentTs currentTs
|
||||
in ChatItem {chatDir = toCIDirection cd, meta, content, mentions = M.empty, formattedText, quotedItem, reactions = [], file}
|
||||
|
||||
ciContentHasLink :: CIContent d -> Maybe MarkdownList -> Bool
|
||||
@@ -2661,7 +2680,7 @@ createChatItems user itemTs_ dirsCIContents = do
|
||||
createACI (content, sharedMsgId) = do
|
||||
let hasLink_ = ciContentHasLink content Nothing
|
||||
ciId <- createNewChatItemNoMsg db user cd showGroupAsSender content sharedMsgId hasLink_ itemTs createdAt
|
||||
let ci = mkChatItem cd showGroupAsSender ciId content Nothing Nothing Nothing Nothing Nothing False False itemTs Nothing createdAt
|
||||
let ci = mkChatItem cd showGroupAsSender ciId content Nothing Nothing Nothing Nothing Nothing Nothing False False itemTs Nothing createdAt
|
||||
pure $ AChatItem (chatTypeI @c) (msgDirection @d) (toChatInfo cd) ci
|
||||
|
||||
-- rcvMem_ Nothing means message from channel - treated same as message from moderator,
|
||||
@@ -2694,9 +2713,9 @@ createLocalChatItems user cd itemsData createdAt = do
|
||||
createItem :: DB.Connection -> (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom, (Text, Maybe MarkdownList)) -> IO (ChatItem 'CTLocal 'MDSnd)
|
||||
createItem db (content, ciFile, itemForwarded, ts@(_, ft_)) = do
|
||||
let hasLink_ = ciContentHasLink content ft_
|
||||
ciId <- createNewChatItem_ db user cd False Nothing Nothing content (Nothing, Nothing, Nothing, Nothing, Nothing) itemForwarded Nothing False False hasLink_ createdAt Nothing Nothing createdAt
|
||||
ciId <- createNewChatItem_ db user cd False Nothing Nothing content (Nothing, Nothing, Nothing, Nothing, Nothing) itemForwarded Nothing Nothing False False hasLink_ createdAt Nothing Nothing createdAt
|
||||
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt
|
||||
pure $ mkChatItem_ cd False ciId content ts ciFile Nothing Nothing itemForwarded Nothing False False hasLink_ createdAt Nothing Nothing createdAt
|
||||
pure $ mkChatItem_ cd False ciId content ts ciFile Nothing Nothing itemForwarded Nothing Nothing False False hasLink_ createdAt Nothing Nothing createdAt
|
||||
|
||||
withUser' :: (User -> CM ChatResponse) -> CM ChatResponse
|
||||
withUser' action =
|
||||
|
||||
@@ -697,7 +697,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
Just UserContactRequest {welcomeSharedMsgId = Just smId} ->
|
||||
void $ sendDirectContactMessage user ct $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing Nothing
|
||||
_ -> do
|
||||
(msg, _) <- sendDirectContactMessage user ct $ XMsgNew $ MCSimple $ extMsgContent mc Nothing
|
||||
(msg, _) <- sendDirectContactMessage user ct $ XMsgNew $ mcSimple mc
|
||||
ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc)
|
||||
toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDSnd (DirectChat ct) ci]
|
||||
|
||||
@@ -979,7 +979,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
checkSendAsGroup asGroup $
|
||||
memberCanSend (Just m'') scope $ newGroupContentMessage gInfo' (Just m'') mc msg brokerTs False
|
||||
where
|
||||
ExtMsgContent {scope, asGroup} = mcExtMsgContent mc
|
||||
MsgContainer {scope, asGroup} = mc
|
||||
-- file description is always allowed, to allow sending files to support scope
|
||||
XMsgFileDescr sharedMsgId fileDescr -> groupMessageFileDescription gInfo' (Just m'') sharedMsgId fileDescr
|
||||
XMsgUpdate sharedMsgId mContent mentions ttl live msgScope asGroup_ ->
|
||||
@@ -1009,6 +1009,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
XGrpDel -> Just (DeliveryTaskContext (DJSGroup {jobSpec = DJRelayRemoved}) False) <$ xGrpDel gInfo' m'' msg brokerTs
|
||||
XGrpInfo p' -> fmap ctx <$> xGrpInfo gInfo' m'' p' msg brokerTs
|
||||
XGrpPrefs ps' -> fmap ctx <$> xGrpPrefs gInfo' m'' ps' msg
|
||||
XMsgPrefs {msgId = parentSharedMsgId, comments} -> fmap ctx <$> xMsgPrefs gInfo' (Just m'') parentSharedMsgId comments
|
||||
-- TODO [knocking] why don't we forward these messages?
|
||||
XGrpDirectInv connReq mContent_ msgScope -> memberCanSend (Just m'') msgScope $ Nothing <$ xGrpDirectInv gInfo' m'' conn' connReq mContent_ msg brokerTs
|
||||
XGrpMsgForward fwd msg' -> Nothing <$ xGrpMsgForward gInfo' Nothing m'' fwd (ParsedMsg Nothing Nothing msg') brokerTs
|
||||
@@ -1203,7 +1204,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
Just UserContactRequest {welcomeSharedMsgId = Just smId} ->
|
||||
void $ sendGroupMessage' user gInfo [m] $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing Nothing
|
||||
_ -> do
|
||||
msg <- sendGroupMessage' user gInfo [m] $ XMsgNew $ MCSimple $ extMsgContent mc Nothing
|
||||
msg <- sendGroupMessage' user gInfo [m] $ XMsgNew $ mcSimple mc
|
||||
ci <- saveSndChatItem user (CDGroupSnd gInfo Nothing) msg (CISndMsgContent mc)
|
||||
withStore' $ \db -> createGroupSndStatus db (chatItemId' ci) (groupMemberId' m) GSSNew
|
||||
toView $ CEvtNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo Nothing) ci]
|
||||
@@ -1519,7 +1520,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
memberCanSend (Just m@GroupMember {memberRole}) msgScope a = case msgScope of
|
||||
Just MSMember {} -> a
|
||||
Nothing
|
||||
| memberRole > GRObserver || memberPending m -> a
|
||||
| memberRole >= GRAuthor || memberPending m -> a
|
||||
| otherwise -> messageError "member is not allowed to send messages" $> Nothing
|
||||
|
||||
processConnMERR :: ConnectionEntity -> Connection -> AgentErrorType -> CM ()
|
||||
@@ -1712,7 +1713,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
|
||||
newContentMessage :: Contact -> MsgContainer -> RcvMessage -> MsgMeta -> CM ()
|
||||
newContentMessage ct mc msg@RcvMessage {sharedMsgId_} msgMeta = do
|
||||
let ExtMsgContent content _ fInv_ _ _ _ _ = mcExtMsgContent mc
|
||||
let MsgContainer {content, file = fInv_, ttl = itemTTL, live = live_} = mc
|
||||
-- Uncomment to test stuck delivery on errors - see test testDirectMessageDelete
|
||||
-- case content of
|
||||
-- MCText "hello 111" ->
|
||||
@@ -1723,8 +1724,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
then do
|
||||
void $ newChatItem (ciContentNoParse $ CIRcvChatFeatureRejected CFVoice) Nothing Nothing False
|
||||
else do
|
||||
let ExtMsgContent _ _ _ itemTTL live_ _ _ = mcExtMsgContent mc
|
||||
timed_ = rcvContactCITimed ct itemTTL
|
||||
let timed_ = rcvContactCITimed ct itemTTL
|
||||
live = fromMaybe False live_
|
||||
file_ <- processFileInvitation fInv_ content $ \db -> createRcvFileTransfer db userId ct
|
||||
newChatItem (CIRcvMsgContent content, msgContentTexts content) (snd <$> file_) timed_ live
|
||||
@@ -1732,7 +1732,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
where
|
||||
brokerTs = metaBrokerTs msgMeta
|
||||
newChatItem content ciFile_ timed_ live = do
|
||||
(ci, cInfo) <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content ciFile_ timed_ live M.empty
|
||||
(ci, cInfo) <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content ciFile_ Nothing timed_ live M.empty
|
||||
reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getDirectCIReactions db ct sharedMsgId) sharedMsgId_
|
||||
toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDRcv cInfo ci {reactions}]
|
||||
|
||||
@@ -1812,7 +1812,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
-- Chat item and update message which created it will have different sharedMsgId in this case...
|
||||
let timed_ = rcvContactCITimed ct ttl
|
||||
ts = ciContentTexts content
|
||||
(ci, cInfo) <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) brokerTs (content, ts) Nothing timed_ live M.empty
|
||||
(ci, cInfo) <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) brokerTs (content, ts) Nothing Nothing timed_ live M.empty
|
||||
ci' <- withStore' $ \db -> do
|
||||
createChatItemVersion db (chatItemId' ci) brokerTs mc
|
||||
updateDirectChatItem' db user contactId ci content True live Nothing Nothing
|
||||
@@ -1943,40 +1943,56 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
newGroupContentMessage :: GroupInfo -> Maybe GroupMember -> MsgContainer -> RcvMessage -> UTCTime -> Bool -> CM (Maybe DeliveryTaskContext)
|
||||
newGroupContentMessage gInfo m_ mc msg@RcvMessage {sharedMsgId_} brokerTs forwarded = case m_ of
|
||||
Nothing -> do
|
||||
createContentItem gInfo Nothing Nothing
|
||||
createContentItem gInfo Nothing Nothing Nothing
|
||||
-- no delivery task - message already forwarded by relay
|
||||
pure Nothing
|
||||
Just m@GroupMember {memberId} -> do
|
||||
(gInfo', m', scopeInfo) <- mkGetMessageChatScope vr user gInfo m content msgScope_
|
||||
channelMsgInfo_ <- resolveCommentParent gInfo' parent_
|
||||
if blockedByAdmin m'
|
||||
then createBlockedByAdmin gInfo' (Just m') scopeInfo $> Nothing
|
||||
else case prohibitedGroupContent gInfo' m' scopeInfo content ft_ fInv_ False of
|
||||
else case prohibitedGroupContent gInfo' m' scopeInfo channelMsgInfo_ content ft_ fInv_ False of
|
||||
Just f -> rejected gInfo' (Just m') scopeInfo f $> Nothing
|
||||
Nothing ->
|
||||
withStore' (\db -> getCIModeration db vr user gInfo' memberId sharedMsgId_) >>= \case
|
||||
Just ciModeration -> do
|
||||
applyModeration gInfo' m' scopeInfo ciModeration
|
||||
withStore' $ \db -> deleteCIModeration db gInfo' memberId sharedMsgId_
|
||||
pure Nothing
|
||||
Nothing -> do
|
||||
createContentItem gInfo' (Just m') scopeInfo
|
||||
pure $ Just $ infoToDeliveryContext gInfo' scopeInfo sentAsGroup
|
||||
Nothing -> do
|
||||
now <- liftIO getCurrentTime
|
||||
if commentsClosed gInfo' channelMsgInfo_ now
|
||||
then messageError "channel post comments are closed" $> Nothing
|
||||
else
|
||||
withStore' (\db -> getCIModeration db vr user gInfo' memberId sharedMsgId_) >>= \case
|
||||
Just ciModeration -> do
|
||||
applyModeration gInfo' m' scopeInfo ciModeration
|
||||
withStore' $ \db -> deleteCIModeration db gInfo' memberId sharedMsgId_
|
||||
pure Nothing
|
||||
Nothing -> do
|
||||
createContentItem gInfo' (Just m') scopeInfo channelMsgInfo_
|
||||
pure $ Just $ infoToDeliveryContext gInfo' scopeInfo sentAsGroup
|
||||
where
|
||||
rejected gInfo' m' scopeInfo f = newChatItem gInfo' m' scopeInfo (ciContentNoParse $ CIRcvGroupFeatureRejected f) Nothing Nothing False
|
||||
rejected gInfo' m' scopeInfo f = newChatItem gInfo' m' scopeInfo Nothing (ciContentNoParse $ CIRcvGroupFeatureRejected f) Nothing Nothing False
|
||||
timed_ gInfo' = if forwarded then rcvCITimed_ (Just Nothing) itemTTL else rcvGroupCITimed gInfo' itemTTL
|
||||
live' = fromMaybe False live_
|
||||
ExtMsgContent content mentions fInv_ itemTTL live_ msgScope_ asGroup_ = mcExtMsgContent mc
|
||||
MsgContainer {content, mentions, file = fInv_, ttl = itemTTL, live = live_, scope = msgScope_, asGroup = asGroup_, parent = parent_} = mc
|
||||
sentAsGroup = asGroup_ == Just True
|
||||
ts@(_, ft_) = msgContentTexts content
|
||||
-- Resolve the parent post (if any) referenced by this message's container.
|
||||
-- Returns Nothing for plain main-channel messages, throws messageError on
|
||||
-- malformed or unknown parent references so the message is dropped.
|
||||
resolveCommentParent :: GroupInfo -> Maybe MsgRef -> CM (Maybe ChannelMsgInfo)
|
||||
resolveCommentParent _ Nothing = pure Nothing
|
||||
resolveCommentParent _ (Just MsgRef {msgId = Nothing}) =
|
||||
messageError "channel comment parent missing shared msg id" $> Nothing
|
||||
resolveCommentParent gInfo' (Just MsgRef {msgId = Just parentSharedId}) =
|
||||
(Just <$> withStore (\db -> getChannelMsgInfoBySharedMsgId db user gInfo' parentSharedId))
|
||||
`catchAllErrors` \_ -> messageError "channel comment parent not found" $> Nothing
|
||||
-- m' is Maybe GroupMember
|
||||
saveRcvCI gInfo' m' scopeInfo =
|
||||
saveRcvCI gInfo' m' scopeInfo channelMsgInfo'_ ciContent ciFile =
|
||||
let itemMember_ = if sentAsGroup then Nothing else m'
|
||||
chatDir = maybe (CDChannelRcv gInfo' scopeInfo) (CDGroupRcv gInfo' scopeInfo) itemMember_
|
||||
in saveRcvChatItem' user chatDir msg sharedMsgId_ brokerTs
|
||||
parentItemId_ = (\ChannelMsgInfo {channelMsgItem} -> cChatItemId channelMsgItem) <$> channelMsgInfo'_
|
||||
in saveRcvChatItem' user chatDir msg sharedMsgId_ brokerTs ciContent ciFile parentItemId_
|
||||
createBlockedByAdmin gInfo' m' scopeInfo
|
||||
| groupFeatureAllowed SGFFullDelete gInfo' = do
|
||||
-- ignores member role when blocked by admin
|
||||
(ci, cInfo) <- saveRcvCI gInfo' m' scopeInfo (ciContentNoParse CIRcvBlocked) Nothing (timed_ gInfo') False M.empty
|
||||
(ci, cInfo) <- saveRcvCI gInfo' m' scopeInfo Nothing (ciContentNoParse CIRcvBlocked) Nothing (timed_ gInfo') False M.empty
|
||||
ci' <- withStore' $ \db -> updateGroupCIBlockedByAdmin db user gInfo' ci brokerTs
|
||||
groupMsgToView cInfo ci'
|
||||
| otherwise = do
|
||||
@@ -1986,9 +2002,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
groupMsgToView cInfo ci'
|
||||
applyModeration gInfo' m'@GroupMember {memberRole} scopeInfo CIModeration {moderatorMember = moderator@GroupMember {memberRole = moderatorRole}, moderatedAt}
|
||||
| moderatorRole < GRModerator || moderatorRole < memberRole =
|
||||
createContentItem gInfo' (Just m') scopeInfo
|
||||
createContentItem gInfo' (Just m') scopeInfo Nothing
|
||||
| groupFeatureMemberAllowed SGFFullDelete moderator gInfo' = do
|
||||
(ci, cInfo) <- saveRcvCI gInfo' (Just m') scopeInfo (ciContentNoParse CIRcvModerated) Nothing (timed_ gInfo') False M.empty
|
||||
(ci, cInfo) <- saveRcvCI gInfo' (Just m') scopeInfo Nothing (ciContentNoParse CIRcvModerated) Nothing (timed_ gInfo') False M.empty
|
||||
ci' <- withStore' $ \db -> updateGroupChatItemModerated db user gInfo' ci moderator moderatedAt
|
||||
groupMsgToView cInfo ci'
|
||||
| otherwise = do
|
||||
@@ -1998,17 +2014,17 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
toView $ CEvtChatItemsDeleted user deletions False False
|
||||
-- m' is Maybe GroupMember
|
||||
createNonLive gInfo' m' scopeInfo file_ = do
|
||||
saveRcvCI gInfo' m' scopeInfo (CIRcvMsgContent content, ts) (snd <$> file_) (timed_ gInfo') False mentions
|
||||
createContentItem gInfo' m' scopeInfo = do
|
||||
saveRcvCI gInfo' m' scopeInfo Nothing (CIRcvMsgContent content, ts) (snd <$> file_) (timed_ gInfo') False mentions
|
||||
createContentItem gInfo' m' scopeInfo channelMsgInfo'_ = do
|
||||
file_ <- processFileInv gInfo' m'
|
||||
newChatItem gInfo' m' scopeInfo (CIRcvMsgContent content, ts) (snd <$> file_) (timed_ gInfo') live'
|
||||
newChatItem gInfo' m' scopeInfo channelMsgInfo'_ (CIRcvMsgContent content, ts) (snd <$> file_) (timed_ gInfo') live'
|
||||
unless (maybe False memberBlocked m') $ autoAcceptFile file_
|
||||
processFileInv gInfo' m' =
|
||||
let fileMember_ = if sentAsGroup then Nothing else m'
|
||||
in processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId gInfo' fileMember_
|
||||
newChatItem gInfo' m' scopeInfo ciContent ciFile_ timed live = do
|
||||
newChatItem gInfo' m' scopeInfo channelMsgInfo'_ ciContent ciFile_ timed live = do
|
||||
let mentions' = if maybe False memberBlocked m' then [] else mentions
|
||||
(ci, cInfo) <- saveRcvCI gInfo' m' scopeInfo ciContent ciFile_ timed live mentions'
|
||||
(ci, cInfo) <- saveRcvCI gInfo' m' scopeInfo channelMsgInfo'_ ciContent ciFile_ timed live mentions'
|
||||
ci' <- maybe (pure ci) (\m -> blockedMemberCI gInfo' m ci) m'
|
||||
let memberId_ = memberId' <$> m'
|
||||
reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getGroupCIReactions db gInfo' memberId_ sharedMsgId) sharedMsgId_
|
||||
@@ -2037,7 +2053,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
(gInfo', m', scopeInfo) <- mkGetMessageChatScope vr user gInfo m mc msgScope_
|
||||
pure (gInfo', CDGroupRcv gInfo' scopeInfo m', mentions', scopeInfo)
|
||||
Nothing -> pure (gInfo, CDChannelRcv gInfo Nothing, mentions, Nothing)
|
||||
(ci, cInfo) <- saveRcvChatItem' user chatDir msg (Just sharedMsgId) brokerTs (content, ts) Nothing timed_ live mentions'
|
||||
(ci, cInfo) <- saveRcvChatItem' user chatDir msg (Just sharedMsgId) brokerTs (content, ts) Nothing Nothing timed_ live mentions'
|
||||
ci' <- withStore' $ \db -> do
|
||||
createChatItemVersion db (chatItemId' ci) brokerTs mc
|
||||
updateGroupChatItem db user groupId ci content True live Nothing
|
||||
@@ -2191,7 +2207,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}
|
||||
content = ciContentNoParse $ CIRcvMsgContent $ MCFile ""
|
||||
(ci, cInfo) <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content ciFile Nothing False M.empty
|
||||
(ci, cInfo) <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content ciFile Nothing Nothing False M.empty
|
||||
toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDRcv cInfo ci]
|
||||
where
|
||||
brokerTs = metaBrokerTs msgMeta
|
||||
@@ -2205,7 +2221,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}
|
||||
content = ciContentNoParse $ CIRcvMsgContent $ MCFile ""
|
||||
(ci, cInfo) <- saveRcvChatItem' user (CDGroupRcv gInfo Nothing m) msg sharedMsgId_ brokerTs content ciFile Nothing False M.empty
|
||||
(ci, cInfo) <- saveRcvChatItem' user (CDGroupRcv gInfo Nothing m) msg sharedMsgId_ brokerTs content ciFile Nothing Nothing False M.empty
|
||||
ci' <- blockedMemberCI gInfo m ci
|
||||
groupMsgToView cInfo ci'
|
||||
|
||||
@@ -2680,7 +2696,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
saveCallItem status = saveRcvChatItemNoParse user (CDDirectRcv ct) msg brokerTs (CIRcvCall status 0)
|
||||
featureRejected f = do
|
||||
let content = ciContentNoParse $ CIRcvChatFeatureRejected f
|
||||
(ci, cInfo) <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content Nothing Nothing False M.empty
|
||||
(ci, cInfo) <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content Nothing Nothing Nothing False M.empty
|
||||
toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDRcv cInfo ci]
|
||||
|
||||
-- to party initiating call
|
||||
@@ -3147,6 +3163,21 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
| memberRole < GROwner = messageError "x.grp.prefs with insufficient member permissions" $> Nothing
|
||||
| otherwise = updateGroupPrefs_ msgSigned g m ps' $> Just DJSGroup {jobSpec = DJDeliveryJob {includePending = True}}
|
||||
|
||||
xMsgPrefs :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> MsgCommentsPref -> CM (Maybe DeliveryJobScope)
|
||||
xMsgPrefs g author_ parentSharedMsgId MsgCommentsPref {disabled}
|
||||
| not (useRelays' g) = messageError "x.msg.prefs not allowed in p2p groups" $> Nothing
|
||||
| maybe False (\GroupMember {memberRole} -> memberRole < GRModerator) author_ =
|
||||
messageError "x.msg.prefs with insufficient member permissions" $> Nothing
|
||||
| otherwise = do
|
||||
parent_ <-
|
||||
(Just <$> withStore (\db -> getGroupChatItemBySharedMsgId db user g Nothing parentSharedMsgId))
|
||||
`catchAllErrors` \_ -> messageError "x.msg.prefs: parent chat item not found" $> Nothing
|
||||
case parent_ of
|
||||
Just parentCI -> do
|
||||
withStore' $ \db -> setChannelMsgCommentsDisabled db (cChatItemId parentCI) disabled
|
||||
pure $ Just DJSGroup {jobSpec = DJDeliveryJob {includePending = True}}
|
||||
Nothing -> pure Nothing
|
||||
|
||||
updateGroupPrefs_ :: Maybe MsgSigStatus -> GroupInfo -> GroupMember -> GroupPreferences -> CM ()
|
||||
updateGroupPrefs_ msgSigned g@GroupInfo {groupProfile = p} m ps' =
|
||||
unless (groupPreferences p == Just ps') $ do
|
||||
@@ -3268,7 +3299,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
XMsgNew mc ->
|
||||
void $ memberCanSend author_ scope $ newGroupContentMessage gInfo author_ mc rcvMsg msgTs True
|
||||
where
|
||||
ExtMsgContent {scope} = mcExtMsgContent mc
|
||||
MsgContainer {scope} = mc
|
||||
-- file description is always allowed, to allow sending files to support scope
|
||||
XMsgFileDescr sharedMsgId fileDescr -> void $ groupMessageFileDescription gInfo author_ sharedMsgId fileDescr
|
||||
XMsgUpdate sharedMsgId mContent mentions ttl live msgScope asGroup_ ->
|
||||
@@ -3285,6 +3316,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
XGrpDel -> withAuthor XGrpDel_ $ \author -> void $ xGrpDel gInfo author rcvMsg msgTs
|
||||
XGrpInfo p' -> withAuthor XGrpInfo_ $ \author -> void $ xGrpInfo gInfo author p' rcvMsg msgTs
|
||||
XGrpPrefs ps' -> withAuthor XGrpPrefs_ $ \author -> void $ xGrpPrefs gInfo author ps' rcvMsg
|
||||
XMsgPrefs {msgId = parentSharedMsgId, comments} -> void $ xMsgPrefs gInfo author_ parentSharedMsgId comments
|
||||
_ -> messageError $ "x.grp.msg.forward: unsupported forwarded event " <> T.pack (show $ toCMEventTag event)
|
||||
where
|
||||
withAuthor :: CMEventTag e -> (GroupMember -> CM ()) -> CM ()
|
||||
|
||||
@@ -342,6 +342,27 @@ data CChatItem c = forall d. MsgDirectionI d => CChatItem (SMsgDirection d) (Cha
|
||||
|
||||
deriving instance Show (CChatItem c)
|
||||
|
||||
-- | Resolved parent post for a channel comments thread.
|
||||
-- Threaded through the send/receive paths so the wire-side MsgRef and
|
||||
-- the DB-side parent_chat_item_id are derived from a single resolution.
|
||||
data ChannelMsgInfo = ChannelMsgInfo
|
||||
{ channelMsgItem :: CChatItem 'CTGroup,
|
||||
channelMsgSharedId :: SharedMsgId
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- Build a MsgRef pointing at a channel post for the wire-side `parent` field
|
||||
-- of a comment message. Channel posts have no member identity, so memberId
|
||||
-- is Nothing for both subscriber-received (CIChannelRcv) and owner-sent
|
||||
-- (CIGroupSnd with showGroupAsSender = True) cases.
|
||||
channelMsgRef :: ChannelMsgInfo -> MsgRef
|
||||
channelMsgRef ChannelMsgInfo {channelMsgItem = CChatItem _ ChatItem {chatDir, meta = CIMeta {itemTs}}, channelMsgSharedId} =
|
||||
MsgRef {msgId = Just channelMsgSharedId, sentAt = itemTs, sent = isSnd, memberId = Nothing}
|
||||
where
|
||||
isSnd = case chatDir of
|
||||
CIGroupSnd -> True
|
||||
_ -> False
|
||||
|
||||
cChatItemId :: CChatItem c -> ChatItemId
|
||||
cChatItemId (CChatItem _ ci) = chatItemId' ci
|
||||
|
||||
@@ -1324,7 +1345,7 @@ data CIForwardedFrom
|
||||
|
||||
cmForwardedFrom :: AChatMsgEvent -> Maybe CIForwardedFrom
|
||||
cmForwardedFrom = \case
|
||||
ACME _ (XMsgNew (MCForward _)) -> Just CIFFUnknown
|
||||
ACME _ (XMsgNew mc) | isMCForward mc -> Just CIFFUnknown
|
||||
_ -> Nothing
|
||||
|
||||
data CIForwardedFromTag
|
||||
|
||||
@@ -493,9 +493,8 @@ deriving instance Show AChatMsgEvent
|
||||
-- actual filtering on forwarding is done in processEvent
|
||||
isForwardedGroupMsg :: ChatMsgEvent e -> Bool
|
||||
isForwardedGroupMsg ev = case ev of
|
||||
XMsgNew mc -> case mcExtMsgContent mc of
|
||||
ExtMsgContent {file = Just FileInvitation {fileInline = Just _}} -> False
|
||||
_ -> True
|
||||
XMsgNew MsgContainer {file = Just FileInvitation {fileInline = Just _}} -> False
|
||||
XMsgNew _ -> True
|
||||
XMsgFileDescr _ _ -> True
|
||||
XMsgUpdate {} -> True
|
||||
XMsgDel {} -> True
|
||||
@@ -510,6 +509,7 @@ isForwardedGroupMsg ev = case ev of
|
||||
XGrpDel -> True
|
||||
XGrpInfo _ -> True
|
||||
XGrpPrefs _ -> True
|
||||
XMsgPrefs {} -> True
|
||||
_ -> False
|
||||
|
||||
data MsgReaction = MREmoji {emoji :: MREmojiChar} | MRUnknown {tag :: Text, json :: J.Object}
|
||||
@@ -598,7 +598,7 @@ data QuotedMsg = QuotedMsg {msgRef :: MsgRef, content :: MsgContent}
|
||||
|
||||
cmToQuotedMsg :: AChatMsgEvent -> Maybe QuotedMsg
|
||||
cmToQuotedMsg = \case
|
||||
ACME _ (XMsgNew (MCQuote quotedMsg _)) -> Just quotedMsg
|
||||
ACME _ (XMsgNew MsgContainer {quote = Just quotedMsg}) -> Just quotedMsg
|
||||
_ -> Nothing
|
||||
|
||||
data MsgContentTag
|
||||
@@ -670,8 +670,10 @@ data MsgContainer = MsgContainer
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- Base value used by the smart constructors and for record-update on send sites.
|
||||
mc :: MsgContainer
|
||||
mc =
|
||||
-- Named mcEmpty (not mc) to avoid shadowing the conventional local variable name
|
||||
-- `mc` used at MsgContainer pattern-match sites across the codebase.
|
||||
mcEmpty :: MsgContainer
|
||||
mcEmpty =
|
||||
MsgContainer
|
||||
{ content = MCText "",
|
||||
mentions = M.empty,
|
||||
@@ -686,16 +688,16 @@ mc =
|
||||
}
|
||||
|
||||
mcSimple :: MsgContent -> MsgContainer
|
||||
mcSimple c = mc {content = c}
|
||||
mcSimple c = mcEmpty {content = c}
|
||||
|
||||
mcQuote :: QuotedMsg -> MsgContent -> MsgContainer
|
||||
mcQuote q c = mc {content = c, quote = Just q}
|
||||
mcQuote q c = mcEmpty {content = c, quote = Just q}
|
||||
|
||||
mcComment :: MsgRef -> MsgContent -> MsgContainer
|
||||
mcComment p c = mc {content = c, parent = Just p}
|
||||
mcComment p c = mcEmpty {content = c, parent = Just p}
|
||||
|
||||
mcForward :: MsgContent -> MsgContainer
|
||||
mcForward c = mc {content = c, forward = Just True}
|
||||
mcForward c = mcEmpty {content = c, forward = Just True}
|
||||
|
||||
isMCForward :: MsgContainer -> Bool
|
||||
isMCForward MsgContainer {forward} = forward == Just True
|
||||
@@ -748,7 +750,7 @@ msgContentHasText :: MsgContent -> Bool
|
||||
msgContentHasText =
|
||||
not . T.null . \case
|
||||
MCVoice {text} -> text
|
||||
mc -> msgContentText mc
|
||||
c -> msgContentText c
|
||||
|
||||
isVoice :: MsgContent -> Bool
|
||||
isVoice = \case
|
||||
@@ -868,24 +870,26 @@ markCompressedBatch = B.cons 'X'
|
||||
{-# INLINE markCompressedBatch #-}
|
||||
|
||||
parseMsgContainer :: J.Object -> JT.Parser MsgContainer
|
||||
parseMsgContainer v =
|
||||
MCQuote <$> v .: "quote" <*> mc
|
||||
<|> MCComment <$> v .: "parent" <*> mc
|
||||
<|> (v .: "forward" >>= \f -> (if f then MCForward else MCSimple) <$> mc)
|
||||
-- The support for arbitrary object in "forward" property is added to allow
|
||||
-- forward compatibility with forwards that include public group links.
|
||||
<|> (MCForward <$> ((v .: "forward" :: JT.Parser J.Object) *> mc))
|
||||
<|> MCSimple <$> mc
|
||||
parseMsgContainer v = do
|
||||
content <- v .: "content"
|
||||
file <- v .:? "file"
|
||||
ttl <- v .:? "ttl"
|
||||
live <- v .:? "live"
|
||||
mentions <- fromMaybe M.empty <$> (v .:? "mentions")
|
||||
scope <- v .:? "scope"
|
||||
asGroup <- v .:? "asGroup"
|
||||
quote <- v .:? "quote"
|
||||
parent <- v .:? "parent"
|
||||
forward <- (v .:? "forward") >>= parseForward
|
||||
pure MsgContainer {content, mentions, file, ttl, live, scope, asGroup, quote, parent, forward}
|
||||
where
|
||||
mc = do
|
||||
content <- v .: "content"
|
||||
file <- v .:? "file"
|
||||
ttl <- v .:? "ttl"
|
||||
live <- v .:? "live"
|
||||
mentions <- fromMaybe M.empty <$> (v .:? "mentions")
|
||||
scope <- v .:? "scope"
|
||||
asGroup <- v .:? "asGroup"
|
||||
pure ExtMsgContent {content, mentions, file, ttl, live, scope, asGroup}
|
||||
-- Backward compatibility: legacy clients encode forward either as a Bool or as an
|
||||
-- object (the latter is used by public group links). Any present form → Just True.
|
||||
parseForward :: Maybe J.Value -> JT.Parser (Maybe Bool)
|
||||
parseForward Nothing = pure Nothing
|
||||
parseForward (Just (J.Bool b)) = pure (justTrue b)
|
||||
parseForward (Just (J.Object _)) = pure (Just True)
|
||||
parseForward (Just _) = fail "invalid forward field"
|
||||
|
||||
justTrue :: Bool -> Maybe Bool
|
||||
justTrue True = Just True
|
||||
@@ -931,15 +935,15 @@ unknownMsgType :: Text
|
||||
unknownMsgType = "unknown message type"
|
||||
|
||||
msgContainerJSON :: MsgContainer -> J.Object
|
||||
msgContainerJSON = \case
|
||||
MCQuote qm mc -> o $ ("quote" .= qm) : msgContent mc
|
||||
MCComment ref mc -> o $ ("parent" .= ref) : msgContent mc
|
||||
MCForward mc -> o $ ("forward" .= True) : msgContent mc
|
||||
MCSimple mc -> o $ msgContent mc
|
||||
msgContainerJSON MsgContainer {content, mentions, file, ttl, live, scope, asGroup, quote, parent, forward} =
|
||||
JM.fromList $
|
||||
discriminators
|
||||
<> ("file" .=? file) (("ttl" .=? ttl) (("live" .=? live) (("mentions" .=? nonEmptyMap mentions) (("scope" .=? scope) (("asGroup" .=? asGroup) ["content" .= content])))))
|
||||
where
|
||||
o = JM.fromList
|
||||
msgContent ExtMsgContent {content, mentions, file, ttl, live, scope, asGroup} =
|
||||
("file" .=? file) $ ("ttl" .=? ttl) $ ("live" .=? live) $ ("mentions" .=? nonEmptyMap mentions) $ ("scope" .=? scope) $ ("asGroup" .=? asGroup) ["content" .= content]
|
||||
discriminators =
|
||||
["quote" .= q | Just q <- [quote]]
|
||||
<> ["parent" .= p | Just p <- [parent]]
|
||||
<> ["forward" .= True | forward == Just True]
|
||||
|
||||
nonEmptyMap :: Map k v -> Maybe (Map k v)
|
||||
nonEmptyMap m = if M.null m then Nothing else Just m
|
||||
@@ -1342,6 +1346,7 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do
|
||||
XGrpDel_ -> pure XGrpDel
|
||||
XGrpInfo_ -> XGrpInfo <$> p "groupProfile"
|
||||
XGrpPrefs_ -> XGrpPrefs <$> p "groupPreferences"
|
||||
XMsgPrefs_ -> XMsgPrefs <$> p "msgId" <*> p "comments"
|
||||
XGrpDirectInv_ -> XGrpDirectInv <$> p "connReq" <*> opt "content" <*> opt "scope"
|
||||
XGrpMsgForward_ -> do
|
||||
fwdSender <- opt "memberId" >>= \case
|
||||
@@ -1412,6 +1417,7 @@ chatToAppMessage chatMsg@ChatMessage {chatVRange, msgId, chatMsgEvent} = case en
|
||||
XGrpDel -> JM.empty
|
||||
XGrpInfo p -> o ["groupProfile" .= p]
|
||||
XGrpPrefs p -> o ["groupPreferences" .= p]
|
||||
XMsgPrefs {msgId = msgId', comments} -> o ["msgId" .= msgId', "comments" .= comments]
|
||||
XGrpDirectInv connReq content scope -> o $ ("content" .=? content) $ ("scope" .=? scope) ["connReq" .= connReq]
|
||||
XGrpMsgForward GrpMsgForward {fwdSender, fwdBrokerTs} msg -> o $ encodeFwdSender fwdSender ["msg" .= msg, "msgTs" .= fwdBrokerTs]
|
||||
where
|
||||
|
||||
@@ -2057,6 +2057,24 @@ checkGroupMemberHasItems db User {userId} GroupMember {groupMemberId, groupId} =
|
||||
deleteGroupMember :: DB.Connection -> User -> GroupMember -> IO ()
|
||||
deleteGroupMember db user@User {userId} m@GroupMember {groupMemberId, groupId, memberProfile} = do
|
||||
deleteGroupMemberConnection db user m
|
||||
-- Decrement parent comment counts for this member's live comments BEFORE the bulk DELETE.
|
||||
-- Decrements of parents that themselves belong to this member are harmless no-ops
|
||||
-- (the row vanishes immediately after).
|
||||
decrements <-
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT parent_chat_item_id, COUNT(*) FROM chat_items
|
||||
WHERE user_id = ? AND group_id = ? AND group_member_id = ?
|
||||
AND parent_chat_item_id IS NOT NULL AND item_deleted = 0
|
||||
GROUP BY parent_chat_item_id
|
||||
|]
|
||||
(userId, groupId, groupMemberId)
|
||||
forM_ (decrements :: [(ChatItemId, Int)]) $ \(pId, n) ->
|
||||
DB.execute
|
||||
db
|
||||
"UPDATE chat_items SET comments_total = MAX(0, comments_total + ?) WHERE chat_item_id = ?"
|
||||
(negate n, pId)
|
||||
DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND group_id = ? AND group_member_id = ?" (userId, groupId, groupMemberId)
|
||||
DB.execute db "DELETE FROM group_members WHERE user_id = ? AND group_member_id = ?" (userId, groupMemberId)
|
||||
cleanupMemberProfileAndName_ db user m
|
||||
|
||||
@@ -48,6 +48,10 @@ module Simplex.Chat.Store.Messages
|
||||
getChatContentTypes,
|
||||
getDirectChat,
|
||||
getGroupChat,
|
||||
getChannelMsgInfo,
|
||||
getChannelMsgInfoBySharedMsgId,
|
||||
adjustChannelMsgCommentCount,
|
||||
setChannelMsgCommentsDisabled,
|
||||
getGroupChatScopeInfoForItem,
|
||||
getLocalChat,
|
||||
getDirectChatItemLast,
|
||||
@@ -535,9 +539,9 @@ setSupportChatMemberAttention db vr user g m memberAttention = do
|
||||
m_ <- runExceptT $ getGroupMemberById db vr user (groupMemberId' m)
|
||||
pure $ either (const m) id m_ -- Left shouldn't happen, but types require it
|
||||
|
||||
createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> ShowGroupAsSender -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> UTCTime -> IO ChatItemId
|
||||
createNewSndChatItem db user chatDirection showGroupAsSender SndMessage {msgId, sharedMsgId, signedMsg_} ciContent quotedItem itemForwarded timed live hasLink createdAt =
|
||||
createNewChatItem_ db user chatDirection showGroupAsSender createdByMsgId (Just sharedMsgId) ciContent quoteRow itemForwarded timed live False hasLink createdAt Nothing (MSSVerified <$ signedMsg_) createdAt
|
||||
createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> ShowGroupAsSender -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe ChatItemId -> Maybe CITimed -> Bool -> Bool -> UTCTime -> IO ChatItemId
|
||||
createNewSndChatItem db user chatDirection showGroupAsSender SndMessage {msgId, sharedMsgId, signedMsg_} ciContent quotedItem itemForwarded parentChatItemId_ timed live hasLink createdAt =
|
||||
createNewChatItem_ db user chatDirection showGroupAsSender createdByMsgId (Just sharedMsgId) ciContent quoteRow itemForwarded parentChatItemId_ timed live False hasLink createdAt Nothing (MSSVerified <$ signedMsg_) createdAt
|
||||
where
|
||||
createdByMsgId = if msgId == 0 then Nothing else Just msgId
|
||||
quoteRow :: NewQuoteRow
|
||||
@@ -551,10 +555,10 @@ createNewSndChatItem db user chatDirection showGroupAsSender SndMessage {msgId,
|
||||
CIQGroupRcv (Just GroupMember {memberId}) -> (Just False, Just memberId)
|
||||
CIQGroupRcv Nothing -> (Just False, Nothing)
|
||||
|
||||
createNewRcvChatItem :: ChatTypeQuotable c => DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> Bool -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c), Maybe CIForwardedFrom)
|
||||
createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, msgSigned, forwardedByMember} sharedMsgId_ ciContent timed live userMention hasLink itemTs createdAt = do
|
||||
createNewRcvChatItem :: ChatTypeQuotable c => DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe ChatItemId -> Maybe CITimed -> Bool -> Bool -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c), Maybe CIForwardedFrom)
|
||||
createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, msgSigned, forwardedByMember} sharedMsgId_ ciContent parentChatItemId_ timed live userMention hasLink itemTs createdAt = do
|
||||
let showAsGroup = case chatDirection of CDChannelRcv {} -> True; _ -> False
|
||||
ciId <- createNewChatItem_ db user chatDirection showAsGroup (Just msgId) sharedMsgId_ ciContent quoteRow itemForwarded timed live userMention hasLink itemTs forwardedByMember msgSigned createdAt
|
||||
ciId <- createNewChatItem_ db user chatDirection showAsGroup (Just msgId) sharedMsgId_ ciContent quoteRow itemForwarded parentChatItemId_ timed live userMention hasLink itemTs forwardedByMember msgSigned createdAt
|
||||
quotedItem <- mapM (getChatItemQuote_ db user chatDirection) quotedMsg
|
||||
pure (ciId, quotedItem, itemForwarded)
|
||||
where
|
||||
@@ -573,19 +577,19 @@ createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, msgS
|
||||
|
||||
createNewChatItemNoMsg :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> ShowGroupAsSender -> CIContent d -> Maybe SharedMsgId -> Bool -> UTCTime -> UTCTime -> IO ChatItemId
|
||||
createNewChatItemNoMsg db user chatDirection showGroupAsSender ciContent sharedMsgId_ hasLink itemTs =
|
||||
createNewChatItem_ db user chatDirection showGroupAsSender Nothing sharedMsgId_ ciContent quoteRow Nothing Nothing False False hasLink itemTs Nothing Nothing
|
||||
createNewChatItem_ db user chatDirection showGroupAsSender Nothing sharedMsgId_ ciContent quoteRow Nothing Nothing Nothing False False hasLink itemTs Nothing Nothing
|
||||
where
|
||||
quoteRow :: NewQuoteRow
|
||||
quoteRow = (Nothing, Nothing, Nothing, Nothing, Nothing)
|
||||
|
||||
createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> ShowGroupAsSender -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> Bool -> UTCTime -> Maybe GroupMemberId -> Maybe MsgSigStatus -> UTCTime -> IO ChatItemId
|
||||
createNewChatItem_ db User {userId} chatDirection showGroupAsSender msgId_ sharedMsgId ciContent quoteRow itemForwarded timed live userMention hasLink itemTs forwardedByMember msgSigned createdAt = do
|
||||
createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> ShowGroupAsSender -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CIForwardedFrom -> Maybe ChatItemId -> Maybe CITimed -> Bool -> Bool -> Bool -> UTCTime -> Maybe GroupMemberId -> Maybe MsgSigStatus -> UTCTime -> IO ChatItemId
|
||||
createNewChatItem_ db User {userId} chatDirection showGroupAsSender msgId_ sharedMsgId ciContent quoteRow itemForwarded parentChatItemId_ timed live userMention hasLink itemTs forwardedByMember msgSigned createdAt = do
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO chat_items (
|
||||
-- user and IDs
|
||||
user_id, created_by_msg_id, contact_id, group_id, group_member_id, note_folder_id, group_scope_tag, group_scope_group_member_id,
|
||||
user_id, created_by_msg_id, contact_id, group_id, group_member_id, note_folder_id, group_scope_tag, group_scope_group_member_id, parent_chat_item_id,
|
||||
-- meta
|
||||
item_sent, item_ts, item_content, item_content_tag, item_text, item_status, msg_content_tag, shared_msg_id,
|
||||
forwarded_by_group_member_id, include_in_history, created_at, updated_at, item_live, user_mention, has_link, item_viewed, show_group_as_sender, msg_signed, timed_ttl, timed_delete_at,
|
||||
@@ -593,11 +597,12 @@ createNewChatItem_ db User {userId} chatDirection showGroupAsSender msgId_ share
|
||||
quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id,
|
||||
-- forwarded from
|
||||
fwd_from_tag, fwd_from_chat_name, fwd_from_msg_dir, fwd_from_contact_id, fwd_from_group_id, fwd_from_chat_item_id
|
||||
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
((userId, msgId_) :. idsRow :. groupScopeRow :. itemRow :. quoteRow' :. forwardedFromRow)
|
||||
((userId, msgId_) :. idsRow :. groupScopeRow :. Only parentChatItemId_ :. itemRow :. quoteRow' :. forwardedFromRow)
|
||||
ciId <- insertedRowId db
|
||||
forM_ msgId_ $ \msgId -> insertChatItemMessage_ db ciId msgId createdAt
|
||||
forM_ parentChatItemId_ $ \pId -> adjustChannelMsgCommentCount db pId 1
|
||||
pure ciId
|
||||
where
|
||||
itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, Text, CIStatus d, Maybe MsgContentTag, Maybe SharedMsgId, Maybe GroupMemberId, BoolInt) :. (UTCTime, UTCTime, Maybe BoolInt, BoolInt, BoolInt, BoolInt, BoolInt, Maybe MsgSigStatus) :. (Maybe Int, Maybe UTCTime)
|
||||
@@ -623,8 +628,9 @@ createNewChatItem_ db User {userId} chatDirection showGroupAsSender msgId_ share
|
||||
Just (Just GCSIMemberSupport {groupMember_}) -> (Just GCSTMemberSupport_, groupMemberId' <$> groupMember_)
|
||||
_ -> (Nothing, Nothing)
|
||||
includeInHistory :: Bool
|
||||
includeInHistory = case groupScope of
|
||||
Just Nothing -> isJust mcTag_ && mcTag_ /= Just MCReport_
|
||||
includeInHistory = case (groupScope, parentChatItemId_) of
|
||||
(_, Just _) -> isJust mcTag_ && mcTag_ /= Just MCReport_
|
||||
(Just Nothing, Nothing) -> isJust mcTag_ && mcTag_ /= Just MCReport_
|
||||
_ -> False
|
||||
itemViewed :: Bool
|
||||
itemViewed = case msgDirection @d of
|
||||
@@ -888,7 +894,7 @@ findGroupChatPreviews_ db User {userId} pagination clq =
|
||||
(
|
||||
SELECT chat_item_id
|
||||
FROM chat_items ci
|
||||
WHERE ci.user_id = ? AND ci.group_id = g.group_id AND ci.group_scope_tag IS NULL AND ci.group_scope_group_member_id IS NULL
|
||||
WHERE ci.user_id = ? AND ci.group_id = g.group_id AND ci.group_scope_tag IS NULL AND ci.group_scope_group_member_id IS NULL AND ci.parent_chat_item_id IS NULL
|
||||
ORDER BY ci.item_ts DESC
|
||||
LIMIT 1
|
||||
) AS chat_item_id,
|
||||
@@ -901,13 +907,13 @@ findGroupChatPreviews_ db User {userId} pagination clq =
|
||||
LEFT JOIN (
|
||||
SELECT group_id, COUNT(1) AS UnreadCount, SUM(user_mention) as UnreadMentions, MIN(chat_item_id) AS MinUnread
|
||||
FROM chat_items
|
||||
WHERE user_id = ? AND group_id IS NOT NULL AND group_scope_tag IS NULL AND group_scope_group_member_id IS NULL AND item_status = ?
|
||||
WHERE user_id = ? AND group_id IS NOT NULL AND group_scope_tag IS NULL AND group_scope_group_member_id IS NULL AND parent_chat_item_id IS NULL AND item_status = ?
|
||||
GROUP BY group_id
|
||||
) ChatStats ON ChatStats.group_id = g.group_id
|
||||
LEFT JOIN (
|
||||
SELECT group_id, COUNT(1) AS Count
|
||||
FROM chat_items
|
||||
WHERE user_id = ? AND group_id IS NOT NULL
|
||||
WHERE user_id = ? AND group_id IS NOT NULL AND parent_chat_item_id IS NULL
|
||||
AND msg_content_tag = ? AND item_deleted = ? AND item_sent = 0
|
||||
GROUP BY group_id
|
||||
) ReportCount ON ReportCount.group_id = g.group_id
|
||||
@@ -1071,7 +1077,7 @@ getLocalChatPreview_ db user (LocalChatPD _ noteFolderId lastItemId_ stats) = do
|
||||
|
||||
-- this function can be changed so it never fails, not only avoid failure on invalid json
|
||||
toLocalChatItem :: UTCTime -> ChatItemRow -> Either StoreError (CChatItem 'CTLocal)
|
||||
toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, msgSigned) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) =
|
||||
toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, msgSigned) :. (parentChatItemId, commentsTotal, BI commentsDisabled) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) =
|
||||
chatItem $ fromRight invalid $ dbParseACIContent itemContentText
|
||||
where
|
||||
invalid = ACIContent msgDir $ CIInvalidJSON itemContentText
|
||||
@@ -1104,7 +1110,7 @@ toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentTex
|
||||
_ -> Just (CIDeleted @'CTLocal deletedTs)
|
||||
itemEdited' = maybe False unBI itemEdited
|
||||
itemForwarded = toCIForwardedFrom forwardedFromRow
|
||||
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs Nothing False msgSigned createdAt updatedAt
|
||||
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs Nothing False msgSigned parentChatItemId commentsTotal commentsDisabled createdAt updatedAt
|
||||
ciTimed :: Maybe CITimed
|
||||
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
|
||||
|
||||
@@ -1199,7 +1205,7 @@ getChatContentTypes db User {userId} (ChatRef cType chatId chatScope_) = case cT
|
||||
CTDirect -> getTypes " contact_id = ? " ()
|
||||
CTLocal -> getTypes " note_folder_id = ? " ()
|
||||
CTGroup -> case chatScope_ of
|
||||
Nothing -> getTypes " group_id = ? AND group_scope_tag IS NULL AND group_scope_group_member_id IS NULL " ()
|
||||
Nothing -> getTypes " group_id = ? AND group_scope_tag IS NULL AND group_scope_group_member_id IS NULL AND parent_chat_item_id IS NULL " ()
|
||||
Just (GCSMemberSupport mId_) -> getTypes " group_id = ? AND group_scope_tag = ? AND group_scope_group_member_id IS NOT DISTINCT FROM ? " (GCSTMemberSupport_, mId_)
|
||||
_ -> throwError $ SEInternalError "unsupported chat type"
|
||||
where
|
||||
@@ -1228,7 +1234,7 @@ getDirectChat db vr user contactId contentFilter pagination search_ = do
|
||||
getDirectChatLast_ :: DB.Connection -> User -> Contact -> Maybe MsgContentTag -> Int -> Text -> ExceptT StoreError IO (Chat 'CTDirect)
|
||||
getDirectChatLast_ db user ct contentFilter count search = do
|
||||
let cInfo = DirectChat ct
|
||||
ciIds <- getChatItemIDs db user cInfo contentFilter CRLast count search
|
||||
ciIds <- getChatItemIDs db user cInfo Nothing contentFilter CRLast count search
|
||||
ts <- liftIO getCurrentTime
|
||||
cis <- liftIO $ mapM (safeGetDirectItem db user ct ts) ciIds
|
||||
pure $ Chat cInfo (reverse cis) emptyChatStats
|
||||
@@ -1285,7 +1291,7 @@ getDirectChatAfter_ db user ct@Contact {contactId} contentFilter afterId count s
|
||||
afterCI <- getDirectChatItem db user contactId afterId
|
||||
let cInfo = DirectChat ct
|
||||
range = CRAfter (ciCreatedAt afterCI) (cChatItemId afterCI)
|
||||
ciIds <- getChatItemIDs db user cInfo contentFilter range count search
|
||||
ciIds <- getChatItemIDs db user cInfo Nothing contentFilter range count search
|
||||
ts <- liftIO getCurrentTime
|
||||
cis <- liftIO $ mapM (safeGetDirectItem db user ct ts) ciIds
|
||||
pure $ Chat cInfo cis emptyChatStats
|
||||
@@ -1295,7 +1301,7 @@ getDirectChatBefore_ db user ct@Contact {contactId} contentFilter beforeId count
|
||||
beforeCI <- getDirectChatItem db user contactId beforeId
|
||||
let cInfo = DirectChat ct
|
||||
range = CRBefore (ciCreatedAt beforeCI) (cChatItemId beforeCI)
|
||||
ciIds <- getChatItemIDs db user cInfo contentFilter range count search
|
||||
ciIds <- getChatItemIDs db user cInfo Nothing contentFilter range count search
|
||||
ts <- liftIO getCurrentTime
|
||||
cis <- liftIO $ mapM (safeGetDirectItem db user ct ts) ciIds
|
||||
pure $ Chat cInfo (reverse cis) emptyChatStats
|
||||
@@ -1310,8 +1316,8 @@ getDirectChatAround' db user ct@Contact {contactId} contentFilter aroundId count
|
||||
aroundCI <- getDirectChatItem db user contactId aroundId
|
||||
let cInfo = DirectChat ct
|
||||
range r = r (ciCreatedAt aroundCI) (cChatItemId aroundCI)
|
||||
beforeIds <- getChatItemIDs db user cInfo contentFilter (range CRBefore) count search
|
||||
afterIds <- getChatItemIDs db user cInfo contentFilter (range CRAfter) count search
|
||||
beforeIds <- getChatItemIDs db user cInfo Nothing contentFilter (range CRBefore) count search
|
||||
afterIds <- getChatItemIDs db user cInfo Nothing contentFilter (range CRAfter) count search
|
||||
ts <- liftIO getCurrentTime
|
||||
beforeCIs <- liftIO $ mapM (safeGetDirectItem db user ct ts) beforeIds
|
||||
afterCIs <- liftIO $ mapM (safeGetDirectItem db user ct ts) afterIds
|
||||
@@ -1431,19 +1437,93 @@ getContactNavInfo_ db User {userId} Contact {contactId} afterCI = do
|
||||
:. (userId, contactId, ciCreatedAt afterCI, cChatItemId afterCI)
|
||||
)
|
||||
|
||||
getGroupChat :: DB.Connection -> VersionRangeChat -> User -> Int64 -> Maybe GroupChatScope -> Maybe MsgContentTag -> ChatPagination -> Maybe Text -> ExceptT StoreError IO (Chat 'CTGroup, Maybe NavigationInfo)
|
||||
getGroupChat db vr user groupId scope_ contentFilter pagination search_ = do
|
||||
getGroupChat :: DB.Connection -> VersionRangeChat -> User -> Int64 -> Maybe GroupChatScope -> Maybe ChatItemId -> Maybe MsgContentTag -> ChatPagination -> Maybe Text -> ExceptT StoreError IO (Chat 'CTGroup, Maybe NavigationInfo)
|
||||
getGroupChat db vr user groupId scope_ parentChatItemId_ contentFilter pagination search_ = do
|
||||
when (isJust scope_ && isJust parentChatItemId_) $
|
||||
throwError $ SEInternalError "group chat scope and parent chat item are mutually exclusive"
|
||||
let search = fromMaybe "" search_
|
||||
g <- getGroupInfo db vr user groupId
|
||||
scopeInfo <- mapM (getCreateGroupChatScopeInfo db vr user g) scope_
|
||||
-- Validate parent post if comments thread is requested.
|
||||
forM_ parentChatItemId_ $ \pId -> void $ getChannelMsgInfo db user groupId pId
|
||||
case pagination of
|
||||
CPLast count -> (,Nothing) <$> getGroupChatLast_ db user g scopeInfo contentFilter count search emptyChatStats
|
||||
CPAfter afterId count -> (,Nothing) <$> getGroupChatAfter_ db user g scopeInfo contentFilter afterId count search
|
||||
CPBefore beforeId count -> (,Nothing) <$> getGroupChatBefore_ db user g scopeInfo contentFilter beforeId count search
|
||||
CPAround aroundId count -> getGroupChatAround_ db user g scopeInfo contentFilter aroundId count search
|
||||
CPLast count -> (,Nothing) <$> getGroupChatLast_ db user g scopeInfo parentChatItemId_ contentFilter count search emptyChatStats
|
||||
CPAfter afterId count -> (,Nothing) <$> getGroupChatAfter_ db user g scopeInfo parentChatItemId_ contentFilter afterId count search
|
||||
CPBefore beforeId count -> (,Nothing) <$> getGroupChatBefore_ db user g scopeInfo parentChatItemId_ contentFilter beforeId count search
|
||||
CPAround aroundId count -> getGroupChatAround_ db user g scopeInfo parentChatItemId_ contentFilter aroundId count search
|
||||
CPInitial count -> do
|
||||
unless (T.null search) $ throwError $ SEInternalError "initial chat pagination doesn't support search"
|
||||
getGroupChatInitial_ db user g scopeInfo contentFilter count
|
||||
getGroupChatInitial_ db user g scopeInfo parentChatItemId_ contentFilter count
|
||||
|
||||
-- | Resolve a channel post by its local ChatItemId, returning both the post
|
||||
-- itself and its SharedMsgId. Used by the send and receive paths to derive
|
||||
-- the wire-side MsgRef while keeping the DB-side parent_chat_item_id linkage.
|
||||
getChannelMsgInfo :: DB.Connection -> User -> GroupId -> ChatItemId -> ExceptT StoreError IO ChannelMsgInfo
|
||||
getChannelMsgInfo db user groupId parentChatItemId = do
|
||||
parent@(CChatItem _ ChatItem {meta = CIMeta {itemSharedMsgId}}) <-
|
||||
getGroupChatItem db user groupId parentChatItemId
|
||||
case itemSharedMsgId of
|
||||
Just sId -> pure ChannelMsgInfo {channelMsgItem = parent, channelMsgSharedId = sId}
|
||||
Nothing -> throwError $ SEChatItemNotFound parentChatItemId
|
||||
|
||||
-- | Resolve a channel post by its wire SharedMsgId, returning both the post
|
||||
-- itself and its SharedMsgId. Used by the receive path to look up the parent
|
||||
-- post referenced by an incoming comment's MsgContainer.parent.
|
||||
getChannelMsgInfoBySharedMsgId :: DB.Connection -> User -> GroupInfo -> SharedMsgId -> ExceptT StoreError IO ChannelMsgInfo
|
||||
getChannelMsgInfoBySharedMsgId db user g sharedMsgId = do
|
||||
parent <- getGroupChatItemBySharedMsgId db user g Nothing sharedMsgId
|
||||
pure ChannelMsgInfo {channelMsgItem = parent, channelMsgSharedId = sharedMsgId}
|
||||
|
||||
-- | Increment or decrement the live comment count of a channel post.
|
||||
-- Clamped at 0 to guard against transient negative counts under concurrent deletes.
|
||||
adjustChannelMsgCommentCount :: DB.Connection -> ChatItemId -> Int -> IO ()
|
||||
adjustChannelMsgCommentCount db parentChatItemId delta =
|
||||
DB.execute
|
||||
db
|
||||
"UPDATE chat_items SET comments_total = MAX(0, comments_total + ?) WHERE chat_item_id = ?"
|
||||
(delta, parentChatItemId)
|
||||
|
||||
-- | Persist the per-post comments-disabled flag.
|
||||
setChannelMsgCommentsDisabled :: DB.Connection -> ChatItemId -> Bool -> IO ()
|
||||
setChannelMsgCommentsDisabled db parentChatItemId disabled =
|
||||
DB.execute
|
||||
db
|
||||
"UPDATE chat_items SET comments_disabled = ? WHERE chat_item_id = ?"
|
||||
(BI disabled, parentChatItemId)
|
||||
|
||||
-- | Decrement parent comment counts for live comments by a given group member.
|
||||
-- Used by batch member-removal paths (markMemberCIsDeleted, updateMemberCIsModerated)
|
||||
-- before they bulk-mark items deleted, so comments_total stays accurate.
|
||||
-- When member is the user's own membership, queries by item_sent = 1 AND group_member_id IS NULL.
|
||||
-- Otherwise queries by group_member_id = ?.
|
||||
-- Already-deleted comments are excluded so no double-decrement occurs.
|
||||
decrementMemberCommentCounts_ :: DB.Connection -> UserId -> Int64 -> Bool -> GroupMemberId -> IO ()
|
||||
decrementMemberCommentCounts_ db userId groupId isMembership memId = do
|
||||
decrements <-
|
||||
if isMembership
|
||||
then
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT parent_chat_item_id, COUNT(*) FROM chat_items
|
||||
WHERE user_id = ? AND group_id = ?
|
||||
AND group_member_id IS NULL AND item_sent = 1
|
||||
AND parent_chat_item_id IS NOT NULL AND item_deleted = 0
|
||||
GROUP BY parent_chat_item_id
|
||||
|]
|
||||
(userId, groupId)
|
||||
else
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT parent_chat_item_id, COUNT(*) FROM chat_items
|
||||
WHERE user_id = ? AND group_id = ? AND group_member_id = ?
|
||||
AND parent_chat_item_id IS NOT NULL AND item_deleted = 0
|
||||
GROUP BY parent_chat_item_id
|
||||
|]
|
||||
(userId, groupId, memId)
|
||||
forM_ (decrements :: [(ChatItemId, Int)]) $ \(pId, n) ->
|
||||
adjustChannelMsgCommentCount db pId (negate n)
|
||||
|
||||
getCreateGroupChatScopeInfo :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> GroupChatScope -> ExceptT StoreError IO GroupChatScopeInfo
|
||||
getCreateGroupChatScopeInfo db vr user GroupInfo {membership} = \case
|
||||
@@ -1493,45 +1573,55 @@ getGroupChatScopeForItem_ db itemId =
|
||||
(Nothing, Nothing) -> Nothing
|
||||
(Nothing, Just _) -> Nothing -- shouldn't happen
|
||||
|
||||
getGroupChatLast_ :: DB.Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe MsgContentTag -> Int -> Text -> ChatStats -> ExceptT StoreError IO (Chat 'CTGroup)
|
||||
getGroupChatLast_ db user g scopeInfo_ contentFilter count search stats = do
|
||||
getGroupChatLast_ :: DB.Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe ChatItemId -> Maybe MsgContentTag -> Int -> Text -> ChatStats -> ExceptT StoreError IO (Chat 'CTGroup)
|
||||
getGroupChatLast_ db user g scopeInfo_ parentChatItemId_ contentFilter count search stats = do
|
||||
let cInfo = GroupChat g scopeInfo_
|
||||
ciIds <- getChatItemIDs db user cInfo contentFilter CRLast count search
|
||||
ciIds <- getChatItemIDs db user cInfo parentChatItemId_ contentFilter CRLast count search
|
||||
ts <- liftIO getCurrentTime
|
||||
cis <- mapM (liftIO . safeGetGroupItem db user g ts) ciIds
|
||||
pure $ Chat cInfo (reverse cis) stats
|
||||
|
||||
data ChatItemIDsRange = CRLast | CRAfter UTCTime ChatItemId | CRBefore UTCTime ChatItemId
|
||||
|
||||
getChatItemIDs :: DB.Connection -> User -> ChatInfo c -> Maybe MsgContentTag -> ChatItemIDsRange -> Int -> Text -> ExceptT StoreError IO [ChatItemId]
|
||||
getChatItemIDs db User {userId} cInfo contentFilter range count search = case cInfo of
|
||||
GroupChat GroupInfo {groupId} scopeInfo_ -> case (scopeInfo_, contentFilter) of
|
||||
(Nothing, Nothing) ->
|
||||
getChatItemIDs :: DB.Connection -> User -> ChatInfo c -> Maybe ChatItemId -> Maybe MsgContentTag -> ChatItemIDsRange -> Int -> Text -> ExceptT StoreError IO [ChatItemId]
|
||||
getChatItemIDs db User {userId} cInfo parentChatItemId_ contentFilter range count search = case cInfo of
|
||||
GroupChat GroupInfo {groupId} scopeInfo_ -> case (scopeInfo_, parentChatItemId_, contentFilter) of
|
||||
(Nothing, Nothing, Nothing) ->
|
||||
liftIO $
|
||||
idsQuery
|
||||
(grCond <> " AND group_scope_tag IS NULL AND group_scope_group_member_id IS NULL ")
|
||||
(grCond <> " AND group_scope_tag IS NULL AND group_scope_group_member_id IS NULL AND parent_chat_item_id IS NULL ")
|
||||
(userId, groupId)
|
||||
"item_ts"
|
||||
(Nothing, Just MCLink_) ->
|
||||
(Nothing, Nothing, Just MCLink_) ->
|
||||
liftIO $
|
||||
idsQuery
|
||||
(grCond <> " AND has_link = 1 ")
|
||||
(grCond <> " AND has_link = 1 AND parent_chat_item_id IS NULL ")
|
||||
(userId, groupId)
|
||||
"item_ts"
|
||||
(Nothing, Just mcTag) ->
|
||||
(Nothing, Nothing, Just mcTag) ->
|
||||
liftIO $
|
||||
idsQuery
|
||||
(grCond <> " AND msg_content_tag = ? ")
|
||||
(grCond <> " AND msg_content_tag = ? AND parent_chat_item_id IS NULL ")
|
||||
(userId, groupId, mcTag)
|
||||
"item_ts"
|
||||
(Just GCSIMemberSupport {groupMember_ = m}, Nothing) ->
|
||||
(Just GCSIMemberSupport {groupMember_ = m}, Nothing, Nothing) ->
|
||||
liftIO $
|
||||
idsQuery
|
||||
(grCond <> " AND group_scope_tag = ? AND group_scope_group_member_id IS NOT DISTINCT FROM ? ")
|
||||
(userId, groupId, GCSTMemberSupport_, groupMemberId' <$> m)
|
||||
"item_ts"
|
||||
(Just _scope, Just _mcTag) ->
|
||||
(Nothing, Just parentId, Nothing) ->
|
||||
liftIO $
|
||||
idsQuery
|
||||
(grCond <> " AND parent_chat_item_id = ? ")
|
||||
(userId, groupId, parentId)
|
||||
"item_ts"
|
||||
(Just _scope, _, Just _mcTag) ->
|
||||
throwError $ SEInternalError "group scope and content filter are not supported together"
|
||||
(Just _scope, Just _, _) ->
|
||||
throwError $ SEInternalError "group scope and parent chat item are mutually exclusive"
|
||||
(Nothing, Just _, Just _) ->
|
||||
throwError $ SEInternalError "channel comments thread and content filter are not supported together"
|
||||
where
|
||||
grCond = " user_id = ? AND group_id = ? "
|
||||
DirectChat Contact {contactId} -> liftIO $ case contentFilter of
|
||||
@@ -1626,38 +1716,38 @@ getGroupMemberChatItemLast db user@User {userId} groupId groupMemberId = do
|
||||
(userId, groupId, groupMemberId)
|
||||
getGroupChatItem db user groupId chatItemId
|
||||
|
||||
getGroupChatAfter_ :: DB.Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe MsgContentTag -> ChatItemId -> Int -> Text -> ExceptT StoreError IO (Chat 'CTGroup)
|
||||
getGroupChatAfter_ db user g@GroupInfo {groupId} scopeInfo contentFilter afterId count search = do
|
||||
getGroupChatAfter_ :: DB.Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe ChatItemId -> Maybe MsgContentTag -> ChatItemId -> Int -> Text -> ExceptT StoreError IO (Chat 'CTGroup)
|
||||
getGroupChatAfter_ db user g@GroupInfo {groupId} scopeInfo parentChatItemId_ contentFilter afterId count search = do
|
||||
afterCI <- getGroupChatItem db user groupId afterId
|
||||
let cInfo = GroupChat g scopeInfo
|
||||
range = CRAfter (chatItemTs afterCI) (cChatItemId afterCI)
|
||||
ciIds <- getChatItemIDs db user cInfo contentFilter range count search
|
||||
ciIds <- getChatItemIDs db user cInfo parentChatItemId_ contentFilter range count search
|
||||
ts <- liftIO getCurrentTime
|
||||
cis <- liftIO $ mapM (safeGetGroupItem db user g ts) ciIds
|
||||
pure $ Chat cInfo cis emptyChatStats
|
||||
|
||||
getGroupChatBefore_ :: DB.Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe MsgContentTag -> ChatItemId -> Int -> Text -> ExceptT StoreError IO (Chat 'CTGroup)
|
||||
getGroupChatBefore_ db user g@GroupInfo {groupId} scopeInfo contentFilter beforeId count search = do
|
||||
getGroupChatBefore_ :: DB.Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe ChatItemId -> Maybe MsgContentTag -> ChatItemId -> Int -> Text -> ExceptT StoreError IO (Chat 'CTGroup)
|
||||
getGroupChatBefore_ db user g@GroupInfo {groupId} scopeInfo parentChatItemId_ contentFilter beforeId count search = do
|
||||
beforeCI <- getGroupChatItem db user groupId beforeId
|
||||
let cInfo = GroupChat g scopeInfo
|
||||
range = CRBefore (chatItemTs beforeCI) (cChatItemId beforeCI)
|
||||
ciIds <- getChatItemIDs db user cInfo contentFilter range count search
|
||||
ciIds <- getChatItemIDs db user cInfo parentChatItemId_ contentFilter range count search
|
||||
ts <- liftIO getCurrentTime
|
||||
cis <- liftIO $ mapM (safeGetGroupItem db user g ts) ciIds
|
||||
pure $ Chat cInfo (reverse cis) emptyChatStats
|
||||
|
||||
getGroupChatAround_ :: DB.Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe MsgContentTag -> ChatItemId -> Int -> Text -> ExceptT StoreError IO (Chat 'CTGroup, Maybe NavigationInfo)
|
||||
getGroupChatAround_ db user g scopeInfo contentFilter aroundId count search = do
|
||||
getGroupChatAround_ :: DB.Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe ChatItemId -> Maybe MsgContentTag -> ChatItemId -> Int -> Text -> ExceptT StoreError IO (Chat 'CTGroup, Maybe NavigationInfo)
|
||||
getGroupChatAround_ db user g scopeInfo parentChatItemId_ contentFilter aroundId count search = do
|
||||
stats <- getGroupStats_ db user g scopeInfo
|
||||
getGroupChatAround' db user g scopeInfo contentFilter aroundId count search stats
|
||||
getGroupChatAround' db user g scopeInfo parentChatItemId_ contentFilter aroundId count search stats
|
||||
|
||||
getGroupChatAround' :: DB.Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe MsgContentTag -> ChatItemId -> Int -> Text -> ChatStats -> ExceptT StoreError IO (Chat 'CTGroup, Maybe NavigationInfo)
|
||||
getGroupChatAround' db user g scopeInfo contentFilter aroundId count search stats = do
|
||||
getGroupChatAround' :: DB.Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe ChatItemId -> Maybe MsgContentTag -> ChatItemId -> Int -> Text -> ChatStats -> ExceptT StoreError IO (Chat 'CTGroup, Maybe NavigationInfo)
|
||||
getGroupChatAround' db user g scopeInfo parentChatItemId_ contentFilter aroundId count search stats = do
|
||||
aroundCI <- getGroupCIWithReactions db user g aroundId
|
||||
let cInfo = GroupChat g scopeInfo
|
||||
range r = r (chatItemTs aroundCI) (cChatItemId aroundCI)
|
||||
beforeIds <- getChatItemIDs db user cInfo contentFilter (range CRBefore) count search
|
||||
afterIds <- getChatItemIDs db user cInfo contentFilter (range CRAfter) count search
|
||||
beforeIds <- getChatItemIDs db user cInfo parentChatItemId_ contentFilter (range CRBefore) count search
|
||||
afterIds <- getChatItemIDs db user cInfo parentChatItemId_ contentFilter (range CRAfter) count search
|
||||
ts <- liftIO getCurrentTime
|
||||
beforeCIs <- liftIO $ mapM (safeGetGroupItem db user g ts) beforeIds
|
||||
afterCIs <- liftIO $ mapM (safeGetGroupItem db user g ts) afterIds
|
||||
@@ -1669,17 +1759,23 @@ getGroupChatAround' db user g scopeInfo contentFilter aroundId count search stat
|
||||
[] -> pure $ NavigationInfo 0 0
|
||||
cis -> getGroupNavInfo_ db user g (last cis)
|
||||
|
||||
getGroupChatInitial_ :: DB.Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe MsgContentTag -> Int -> ExceptT StoreError IO (Chat 'CTGroup, Maybe NavigationInfo)
|
||||
getGroupChatInitial_ db user g scopeInfo_ contentFilter count = do
|
||||
getGroupMinUnreadId_ db user g scopeInfo_ contentFilter >>= \case
|
||||
Just minUnreadItemId -> do
|
||||
unreadCounts <- getGroupUnreadCount_ db user g scopeInfo_ Nothing
|
||||
stats <- liftIO $ getStats minUnreadItemId unreadCounts
|
||||
pivotId <- fromMaybe minUnreadItemId <$> getGroupMaxViewedItemId_ db user g scopeInfo_ contentFilter
|
||||
getGroupChatAround' db user g scopeInfo_ contentFilter pivotId count "" stats
|
||||
Nothing -> do
|
||||
getGroupChatInitial_ :: DB.Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe ChatItemId -> Maybe MsgContentTag -> Int -> ExceptT StoreError IO (Chat 'CTGroup, Maybe NavigationInfo)
|
||||
getGroupChatInitial_ db user g scopeInfo_ parentChatItemId_ contentFilter count = do
|
||||
-- Comments threads have no unread tracking; fall through to a "last" page directly.
|
||||
case parentChatItemId_ of
|
||||
Just _ -> do
|
||||
stats <- liftIO $ getStats 0 (0, 0)
|
||||
(,Just $ NavigationInfo 0 0) <$> getGroupChatLast_ db user g scopeInfo_ contentFilter count "" stats
|
||||
(,Just $ NavigationInfo 0 0) <$> getGroupChatLast_ db user g scopeInfo_ parentChatItemId_ contentFilter count "" stats
|
||||
Nothing ->
|
||||
getGroupMinUnreadId_ db user g scopeInfo_ contentFilter >>= \case
|
||||
Just minUnreadItemId -> do
|
||||
unreadCounts <- getGroupUnreadCount_ db user g scopeInfo_ Nothing
|
||||
stats <- liftIO $ getStats minUnreadItemId unreadCounts
|
||||
pivotId <- fromMaybe minUnreadItemId <$> getGroupMaxViewedItemId_ db user g scopeInfo_ contentFilter
|
||||
getGroupChatAround' db user g scopeInfo_ parentChatItemId_ contentFilter pivotId count "" stats
|
||||
Nothing -> do
|
||||
stats <- liftIO $ getStats 0 (0, 0)
|
||||
(,Just $ NavigationInfo 0 0) <$> getGroupChatLast_ db user g scopeInfo_ parentChatItemId_ contentFilter count "" stats
|
||||
where
|
||||
getStats minUnreadItemId (unreadCount, unreadMentions) = do
|
||||
reportsCount <- getGroupReportsCount_ db user g False
|
||||
@@ -1720,7 +1816,7 @@ getGroupReportsCount_ db User {userId} GroupInfo {groupId} archived =
|
||||
fromOnly . head
|
||||
<$> DB.query
|
||||
db
|
||||
"SELECT COUNT(1) FROM chat_items WHERE user_id = ? AND group_id = ? AND msg_content_tag = ? AND item_deleted = ? AND item_sent = 0"
|
||||
"SELECT COUNT(1) FROM chat_items WHERE user_id = ? AND group_id = ? AND parent_chat_item_id IS NULL AND msg_content_tag = ? AND item_deleted = ? AND item_sent = 0"
|
||||
(userId, groupId, MCReport_, BI archived)
|
||||
|
||||
queryUnreadGroupItems :: (ToField p, FromRow r) => DB.Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe MsgContentTag -> Query -> p -> Query -> Query -> ExceptT StoreError IO [r]
|
||||
@@ -1730,13 +1826,13 @@ queryUnreadGroupItems db User {userId} GroupInfo {groupId} scopeInfo_ contentFil
|
||||
liftIO $
|
||||
DB.query
|
||||
db
|
||||
(baseQuery <> " AND group_scope_tag IS NULL AND group_scope_group_member_id IS NULL AND " <> statusCond <> orderLimit)
|
||||
(baseQuery <> " AND group_scope_tag IS NULL AND group_scope_group_member_id IS NULL AND parent_chat_item_id IS NULL AND " <> statusCond <> orderLimit)
|
||||
(userId, groupId, statusParam)
|
||||
(Nothing, Just mcTag) ->
|
||||
liftIO $
|
||||
DB.query
|
||||
db
|
||||
(baseQuery <> " AND msg_content_tag = ? AND " <> statusCond <> orderLimit)
|
||||
(baseQuery <> " AND parent_chat_item_id IS NULL AND msg_content_tag = ? AND " <> statusCond <> orderLimit)
|
||||
(userId, groupId, mcTag, statusParam)
|
||||
(Just GCSIMemberSupport {groupMember_ = m}, Nothing) ->
|
||||
liftIO $
|
||||
@@ -1814,7 +1910,7 @@ getLocalChat db user folderId contentFilter pagination search_ = do
|
||||
getLocalChatLast_ :: DB.Connection -> User -> NoteFolder -> Maybe MsgContentTag -> Int -> Text -> ExceptT StoreError IO (Chat 'CTLocal)
|
||||
getLocalChatLast_ db user nf contentFilter count search = do
|
||||
let cInfo = LocalChat nf
|
||||
ciIds <- getChatItemIDs db user cInfo contentFilter CRLast count search
|
||||
ciIds <- getChatItemIDs db user cInfo Nothing contentFilter CRLast count search
|
||||
ts <- liftIO getCurrentTime
|
||||
cis <- liftIO $ mapM (safeGetLocalItem db user nf ts) ciIds
|
||||
pure $ Chat cInfo (reverse cis) emptyChatStats
|
||||
@@ -1851,7 +1947,7 @@ getLocalChatAfter_ db user nf@NoteFolder {noteFolderId} contentFilter afterId co
|
||||
afterCI <- getLocalChatItem db user noteFolderId afterId
|
||||
let cInfo = LocalChat nf
|
||||
range = CRAfter (ciCreatedAt afterCI) (cChatItemId afterCI)
|
||||
ciIds <- getChatItemIDs db user cInfo contentFilter range count search
|
||||
ciIds <- getChatItemIDs db user cInfo Nothing contentFilter range count search
|
||||
ts <- liftIO getCurrentTime
|
||||
cis <- liftIO $ mapM (safeGetLocalItem db user nf ts) ciIds
|
||||
pure $ Chat cInfo cis emptyChatStats
|
||||
@@ -1861,7 +1957,7 @@ getLocalChatBefore_ db user nf@NoteFolder {noteFolderId} contentFilter beforeId
|
||||
beforeCI <- getLocalChatItem db user noteFolderId beforeId
|
||||
let cInfo = LocalChat nf
|
||||
range = CRBefore (ciCreatedAt beforeCI) (cChatItemId beforeCI)
|
||||
ciIds <- getChatItemIDs db user cInfo contentFilter range count search
|
||||
ciIds <- getChatItemIDs db user cInfo Nothing contentFilter range count search
|
||||
ts <- liftIO getCurrentTime
|
||||
cis <- liftIO $ mapM (safeGetLocalItem db user nf ts) ciIds
|
||||
pure $ Chat cInfo (reverse cis) emptyChatStats
|
||||
@@ -1876,8 +1972,8 @@ getLocalChatAround' db user nf@NoteFolder {noteFolderId} contentFilter aroundId
|
||||
aroundCI <- getLocalChatItem db user noteFolderId aroundId
|
||||
let cInfo = LocalChat nf
|
||||
range r = r (ciCreatedAt aroundCI) (cChatItemId aroundCI)
|
||||
beforeIds <- getChatItemIDs db user cInfo contentFilter (range CRBefore) count search
|
||||
afterIds <- getChatItemIDs db user cInfo contentFilter (range CRAfter) count search
|
||||
beforeIds <- getChatItemIDs db user cInfo Nothing contentFilter (range CRBefore) count search
|
||||
afterIds <- getChatItemIDs db user cInfo Nothing contentFilter (range CRAfter) count search
|
||||
ts <- liftIO getCurrentTime
|
||||
beforeCIs <- liftIO $ mapM (safeGetLocalItem db user nf ts) beforeIds
|
||||
afterCIs <- liftIO $ mapM (safeGetLocalItem db user nf ts) afterIds
|
||||
@@ -2071,6 +2167,7 @@ updateGroupChatItemsRead db User {userId} GroupInfo {groupId} = do
|
||||
[sql|
|
||||
UPDATE chat_items SET item_status = ?, item_viewed = 1, updated_at = ?
|
||||
WHERE user_id = ? AND group_id = ?
|
||||
AND parent_chat_item_id IS NULL
|
||||
AND item_status = ?
|
||||
|]
|
||||
(CISRcvRead, currentTs, userId, groupId, CISRcvNew)
|
||||
@@ -2127,6 +2224,7 @@ getGroupUnreadTimedItems db User {userId} groupId scope =
|
||||
SELECT chat_item_id, timed_ttl
|
||||
FROM chat_items
|
||||
WHERE user_id = ? AND group_id = ?
|
||||
AND parent_chat_item_id IS NULL
|
||||
AND item_status = ? AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL
|
||||
|]
|
||||
(userId, groupId, CISRcvNew)
|
||||
@@ -2260,6 +2358,7 @@ type ChatItemRow =
|
||||
:. (Int, Maybe UTCTime, Maybe BoolInt, UTCTime, UTCTime)
|
||||
:. ChatItemForwardedFromRow
|
||||
:. ChatItemModeRow
|
||||
:. (Maybe ChatItemId, Int, BoolInt)
|
||||
:. MaybeCIFIleRow
|
||||
|
||||
type QuoteRow = (Maybe ChatItemId, Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe BoolInt)
|
||||
@@ -2275,7 +2374,7 @@ toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _) dir
|
||||
|
||||
-- this function can be changed so it never fails, not only avoid failure on invalid json
|
||||
toDirectChatItem :: UTCTime -> ChatItemRow :. QuoteRow -> Either StoreError (CChatItem 'CTDirect)
|
||||
toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, msgSigned) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. quoteRow) =
|
||||
toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, msgSigned) :. (parentChatItemId, commentsTotal, BI commentsDisabled) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. quoteRow) =
|
||||
chatItem $ fromRight invalid $ dbParseACIContent itemContentText
|
||||
where
|
||||
invalid = ACIContent msgDir $ CIInvalidJSON itemContentText
|
||||
@@ -2308,7 +2407,7 @@ toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentT
|
||||
_ -> Just (CIDeleted @'CTDirect deletedTs)
|
||||
itemEdited' = maybe False unBI itemEdited
|
||||
itemForwarded = toCIForwardedFrom forwardedFromRow
|
||||
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs Nothing False msgSigned createdAt updatedAt
|
||||
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs Nothing False msgSigned parentChatItemId commentsTotal commentsDisabled createdAt updatedAt
|
||||
ciTimed :: Maybe CITimed
|
||||
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
|
||||
|
||||
@@ -2347,6 +2446,7 @@ toGroupChatItem
|
||||
:. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt)
|
||||
:. forwardedFromRow
|
||||
:. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, msgSigned)
|
||||
:. (parentChatItemId, commentsTotal, BI commentsDisabled)
|
||||
:. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)
|
||||
)
|
||||
:. (forwardedByMember, BI showGroupAsSender)
|
||||
@@ -2397,7 +2497,7 @@ toGroupChatItem
|
||||
_ -> Just (maybe (CIDeleted @'CTGroup deletedTs) (CIModerated deletedTs) deletedByGroupMember_)
|
||||
itemEdited' = maybe False unBI itemEdited
|
||||
itemForwarded = toCIForwardedFrom forwardedFromRow
|
||||
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs forwardedByMember showGroupAsSender msgSigned createdAt updatedAt
|
||||
in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs forwardedByMember showGroupAsSender msgSigned parentChatItemId commentsTotal commentsDisabled createdAt updatedAt
|
||||
ciTimed :: Maybe CITimed
|
||||
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
|
||||
|
||||
@@ -2671,6 +2771,8 @@ getDirectChatItem db User {userId} contactId itemId = ExceptT $ do
|
||||
i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at,
|
||||
i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id,
|
||||
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed,
|
||||
-- ChannelComments
|
||||
i.parent_chat_item_id, i.comments_total, i.comments_disabled,
|
||||
-- CIFile
|
||||
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol,
|
||||
-- DirectQuote
|
||||
@@ -2780,8 +2882,9 @@ updateGroupCIMentions db g ci@ChatItem {mentions} mentions'
|
||||
createMentions = createGroupCIMentions db g ci mentions'
|
||||
|
||||
deleteGroupChatItem :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> IO ()
|
||||
deleteGroupChatItem db User {userId} g@GroupInfo {groupId} ci = do
|
||||
let itemId = chatItemId' ci
|
||||
deleteGroupChatItem db User {userId} g@GroupInfo {groupId} ci@ChatItem {meta} = do
|
||||
let CIMeta {parentChatItemId, itemDeleted} = meta
|
||||
itemId = chatItemId' ci
|
||||
deleteChatItemMessages_ db itemId
|
||||
deleteChatItemVersions_ db itemId
|
||||
deleteGroupCIReactions_ db g ci
|
||||
@@ -2792,11 +2895,16 @@ deleteGroupChatItem db User {userId} g@GroupInfo {groupId} ci = do
|
||||
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
|
||||
|]
|
||||
(userId, groupId, itemId)
|
||||
-- Decrement parent's live comment count when a non-deleted comment is hard-deleted.
|
||||
-- Already-soft-deleted comments were decremented at soft-delete time.
|
||||
forM_ parentChatItemId $ \pId ->
|
||||
when (isNothing itemDeleted) $ adjustChannelMsgCommentCount db pId (-1)
|
||||
|
||||
updateGroupChatItemModerated :: forall d. MsgDirectionI d => DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> GroupMember -> UTCTime -> IO (ChatItem 'CTGroup d)
|
||||
updateGroupChatItemModerated db User {userId} GroupInfo {groupId} ci m@GroupMember {groupMemberId} deletedTs = do
|
||||
updateGroupChatItemModerated db User {userId} GroupInfo {groupId} ci@ChatItem {meta} m@GroupMember {groupMemberId} deletedTs = do
|
||||
currentTs <- getCurrentTime
|
||||
let toContent = msgDirToModeratedContent_ $ msgDirection @d
|
||||
let CIMeta {parentChatItemId, itemDeleted = wasDeleted} = meta
|
||||
toContent = msgDirToModeratedContent_ $ msgDirection @d
|
||||
toText = ciModeratedText
|
||||
itemId = chatItemId' ci
|
||||
deleteChatItemMessages_ db itemId
|
||||
@@ -2810,10 +2918,16 @@ updateGroupChatItemModerated db User {userId} GroupInfo {groupId} ci m@GroupMemb
|
||||
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
|
||||
|]
|
||||
(deletedTs, groupMemberId, toContent, toText, currentTs, userId, groupId, itemId)
|
||||
pure ci {content = toContent, meta = (meta ci) {itemText = toText, itemDeleted = Just (CIModerated (Just deletedTs) m), editable = False, deletable = False}, formattedText = Nothing}
|
||||
-- Decrement parent's live comment count when a moderator soft-deletes a comment.
|
||||
-- Already-deleted comments were decremented at first soft-delete time.
|
||||
forM_ parentChatItemId $ \pId ->
|
||||
when (isNothing wasDeleted) $ adjustChannelMsgCommentCount db pId (-1)
|
||||
pure ci {content = toContent, meta = meta {itemText = toText, itemDeleted = Just (CIModerated (Just deletedTs) m), editable = False, deletable = False}, formattedText = Nothing}
|
||||
|
||||
updateMemberCIsModerated :: MsgDirectionI d => DB.Connection -> User -> GroupInfo -> GroupMember -> GroupMember -> SMsgDirection d -> UTCTime -> IO ()
|
||||
updateMemberCIsModerated db User {userId} GroupInfo {groupId, membership} member byGroupMember md deletedTs = do
|
||||
-- Decrement parent comment counts BEFORE the bulk UPDATE marks comments deleted.
|
||||
decrementMemberCommentCounts_ db userId groupId (memId == groupMemberId' membership) memId
|
||||
itemIds <- updateCIs =<< getCurrentTime
|
||||
#if defined(dbPostgres)
|
||||
let inItemIds = Only $ In (map fromOnly itemIds)
|
||||
@@ -2847,9 +2961,10 @@ updateMemberCIsModerated db User {userId} GroupInfo {groupId, membership} member
|
||||
columns = (deletedTs, groupMemberId' byGroupMember, msgDirToModeratedContent_ md, ciModeratedText, currentTs)
|
||||
|
||||
updateGroupCIBlockedByAdmin :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> UTCTime -> IO (ChatItem 'CTGroup d)
|
||||
updateGroupCIBlockedByAdmin db User {userId} GroupInfo {groupId} ci deletedTs = do
|
||||
updateGroupCIBlockedByAdmin db User {userId} GroupInfo {groupId} ci@ChatItem {meta} deletedTs = do
|
||||
currentTs <- getCurrentTime
|
||||
let itemId = chatItemId' ci
|
||||
let CIMeta {parentChatItemId, itemDeleted = wasDeleted} = meta
|
||||
itemId = chatItemId' ci
|
||||
deleteChatItemMessages_ db itemId
|
||||
deleteChatItemVersions_ db itemId
|
||||
liftIO $
|
||||
@@ -2861,7 +2976,10 @@ updateGroupCIBlockedByAdmin db User {userId} GroupInfo {groupId} ci deletedTs =
|
||||
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
|
||||
|]
|
||||
(DBCIBlockedByAdmin, deletedTs, currentTs, userId, groupId, itemId)
|
||||
pure $ ci {meta = (meta ci) {itemDeleted = Just (CIBlockedByAdmin $ Just deletedTs), editable = False, deletable = False}, formattedText = Nothing}
|
||||
-- Decrement parent's live comment count when a comment is blocked by admin.
|
||||
forM_ parentChatItemId $ \pId ->
|
||||
when (isNothing wasDeleted) $ adjustChannelMsgCommentCount db pId (-1)
|
||||
pure $ ci {meta = meta {itemDeleted = Just (CIBlockedByAdmin $ Just deletedTs), editable = False, deletable = False}, formattedText = Nothing}
|
||||
|
||||
pattern DBCINotDeleted :: Int
|
||||
pattern DBCINotDeleted = 0
|
||||
@@ -2878,7 +2996,8 @@ pattern DBCIBlockedByAdmin = 3
|
||||
markGroupChatItemDeleted :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> Maybe GroupMember -> UTCTime -> IO (ChatItem 'CTGroup d)
|
||||
markGroupChatItemDeleted db User {userId} GroupInfo {groupId} ci@ChatItem {meta} byGroupMember_ deletedTs = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
let itemId = chatItemId' ci
|
||||
let CIMeta {parentChatItemId, itemDeleted = wasDeleted} = meta
|
||||
itemId = chatItemId' ci
|
||||
(deletedByGroupMemberId, itemDeleted) = case byGroupMember_ of
|
||||
Just m@GroupMember {groupMemberId} -> (Just groupMemberId, Just $ CIModerated (Just deletedTs) m)
|
||||
_ -> (Nothing, Just $ CIDeleted @'CTGroup (Just deletedTs))
|
||||
@@ -2890,10 +3009,15 @@ markGroupChatItemDeleted db User {userId} GroupInfo {groupId} ci@ChatItem {meta}
|
||||
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
|
||||
|]
|
||||
(DBCIDeleted, deletedTs, deletedByGroupMemberId, currentTs, userId, groupId, itemId)
|
||||
-- Decrement parent's live comment count on first soft-delete of a comment.
|
||||
forM_ parentChatItemId $ \pId ->
|
||||
when (isNothing wasDeleted) $ adjustChannelMsgCommentCount db pId (-1)
|
||||
pure ci {meta = meta {itemDeleted, editable = False, deletable = False}}
|
||||
|
||||
markMemberCIsDeleted :: DB.Connection -> User -> GroupInfo -> GroupMember -> GroupMember -> UTCTime -> IO ()
|
||||
markMemberCIsDeleted db User {userId} GroupInfo {groupId, membership} member byGroupMember deletedTs =
|
||||
markMemberCIsDeleted db User {userId} GroupInfo {groupId, membership} member byGroupMember deletedTs = do
|
||||
-- Decrement parent comment counts BEFORE the bulk UPDATE marks comments deleted.
|
||||
decrementMemberCommentCounts_ db userId groupId (memId == groupMemberId' membership) memId
|
||||
updateCIs =<< getCurrentTime
|
||||
where
|
||||
memId = groupMemberId' member
|
||||
@@ -2920,6 +3044,7 @@ markMemberCIsDeleted db User {userId} GroupInfo {groupId, membership} member byG
|
||||
markGroupChatItemBlocked :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup 'MDRcv -> IO (ChatItem 'CTGroup 'MDRcv)
|
||||
markGroupChatItemBlocked db User {userId} GroupInfo {groupId} ci@ChatItem {meta} = do
|
||||
deletedTs <- getCurrentTime
|
||||
let CIMeta {parentChatItemId, itemDeleted = wasDeleted} = meta
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
@@ -2928,11 +3053,15 @@ markGroupChatItemBlocked db User {userId} GroupInfo {groupId} ci@ChatItem {meta}
|
||||
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
|
||||
|]
|
||||
(DBCIBlocked, deletedTs, deletedTs, userId, groupId, chatItemId' ci)
|
||||
-- Decrement parent's live comment count when a comment is locally blocked.
|
||||
forM_ parentChatItemId $ \pId ->
|
||||
when (isNothing wasDeleted) $ adjustChannelMsgCommentCount db pId (-1)
|
||||
pure ci {meta = meta {itemDeleted = Just $ CIBlocked $ Just deletedTs, editable = False, deletable = False}}
|
||||
|
||||
markGroupCIBlockedByAdmin :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup 'MDRcv -> IO (ChatItem 'CTGroup 'MDRcv)
|
||||
markGroupCIBlockedByAdmin db User {userId} GroupInfo {groupId} ci@ChatItem {meta} = do
|
||||
deletedTs <- getCurrentTime
|
||||
let CIMeta {parentChatItemId, itemDeleted = wasDeleted} = meta
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
@@ -2941,6 +3070,9 @@ markGroupCIBlockedByAdmin db User {userId} GroupInfo {groupId} ci@ChatItem {meta
|
||||
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
|
||||
|]
|
||||
(DBCIBlockedByAdmin, deletedTs, deletedTs, userId, groupId, chatItemId' ci)
|
||||
-- Decrement parent's live comment count when a comment is blocked by admin.
|
||||
forM_ parentChatItemId $ \pId ->
|
||||
when (isNothing wasDeleted) $ adjustChannelMsgCommentCount db pId (-1)
|
||||
pure ci {meta = meta {itemDeleted = Just $ CIBlockedByAdmin $ Just deletedTs, editable = False, deletable = False}}
|
||||
|
||||
markMessageReportsDeleted :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> GroupMember -> UTCTime -> IO [ChatItemId]
|
||||
@@ -3026,6 +3158,8 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
|
||||
i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at,
|
||||
i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id,
|
||||
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed,
|
||||
-- ChannelComments
|
||||
i.parent_chat_item_id, i.comments_total, i.comments_disabled,
|
||||
-- CIFile
|
||||
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol,
|
||||
-- CIMeta forwardedByMember, showGroupAsSender
|
||||
@@ -3135,6 +3269,8 @@ getLocalChatItem db User {userId} folderId itemId = ExceptT $ do
|
||||
i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at,
|
||||
i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id,
|
||||
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed,
|
||||
-- ChannelComments
|
||||
i.parent_chat_item_id, i.comments_total, i.comments_disabled,
|
||||
-- CIFile
|
||||
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol
|
||||
FROM chat_items i
|
||||
@@ -3541,6 +3677,22 @@ deleteGroupExpiredCIs :: DB.Connection -> User -> GroupInfo -> UTCTime -> UTCTim
|
||||
deleteGroupExpiredCIs db User {userId} GroupInfo {groupId} expirationDate createdAtCutoff = do
|
||||
DB.execute db "DELETE FROM messages WHERE group_id = ? AND created_at <= ?" (groupId, min expirationDate createdAtCutoff)
|
||||
DB.execute db "DELETE FROM chat_item_reactions WHERE group_id = ? AND reaction_ts <= ? AND created_at <= ?" (groupId, expirationDate, createdAtCutoff)
|
||||
-- Decrement parent comment counts for expiring live comments BEFORE the bulk DELETE.
|
||||
-- Decrements of parents that are themselves being deleted are harmless no-ops
|
||||
-- (the row vanishes immediately after).
|
||||
decrements <-
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT parent_chat_item_id, COUNT(*) FROM chat_items
|
||||
WHERE user_id = ? AND group_id = ?
|
||||
AND parent_chat_item_id IS NOT NULL AND item_deleted = 0
|
||||
AND item_ts <= ? AND created_at <= ?
|
||||
GROUP BY parent_chat_item_id
|
||||
|]
|
||||
(userId, groupId, expirationDate, createdAtCutoff)
|
||||
forM_ (decrements :: [(ChatItemId, Int)]) $ \(pId, n) ->
|
||||
adjustChannelMsgCommentCount db pId (negate n)
|
||||
DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND group_id = ? AND item_ts <= ? AND created_at <= ? AND item_content_tag != 'chatBanner'" (userId, groupId, expirationDate, createdAtCutoff)
|
||||
|
||||
createCIModeration :: DB.Connection -> GroupInfo -> GroupMember -> MemberId -> SharedMsgId -> MessageId -> UTCTime -> IO ()
|
||||
|
||||
Reference in New Issue
Block a user