Merge branch 'master' into master-ghc8107

This commit is contained in:
Evgeny Poberezkin
2023-10-18 22:44:27 +01:00
41 changed files with 703 additions and 305 deletions
+14 -13
View File
@@ -580,11 +580,11 @@ processChatCommand = \case
timed_ <- sndContactCITimed live ct itemTTL
(msgContainer, quotedItem_) <- prepareMsg fInv_ timed_
(msg@SndMessage {sharedMsgId}, _) <- sendDirectContactMessage ct (XMsgNew msgContainer)
ci <- saveSndChatItem' user (CDDirectSnd ct) msg (CISndMsgContent mc) ciFile_ quotedItem_ timed_ live
case ft_ of
Just ft@FileTransferMeta {fileInline = Just IFMSent} ->
sendDirectFileInline ct ft sharedMsgId
_ -> pure ()
ci <- saveSndChatItem' user (CDDirectSnd ct) msg (CISndMsgContent mc) ciFile_ quotedItem_ timed_ live
forM_ (timed_ >>= timedDeleteAt') $
startProximateTimedItemThread user (ChatRef CTDirect contactId, chatItemId' ci)
pure $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci)
@@ -645,11 +645,11 @@ processChatCommand = \case
timed_ <- sndGroupCITimed live gInfo itemTTL
(msgContainer, quotedItem_) <- prepareMsg fInv_ timed_ membership
(msg@SndMessage {sharedMsgId}, sentToMembers) <- sendGroupMessage user gInfo ms (XMsgNew msgContainer)
mapM_ (sendGroupFileInline ms sharedMsgId) ft_
ci <- saveSndChatItem' user (CDGroupSnd gInfo) msg (CISndMsgContent mc) ciFile_ quotedItem_ timed_ live
withStore' $ \db ->
forM_ sentToMembers $ \GroupMember {groupMemberId} ->
createGroupSndStatus db (chatItemId' ci) groupMemberId CISSndNew
mapM_ (sendGroupFileInline ms sharedMsgId) ft_
forM_ (timed_ >>= timedDeleteAt') $
startProximateTimedItemThread user (ChatRef CTGroup groupId, chatItemId' ci)
pure $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci)
@@ -754,8 +754,9 @@ processChatCommand = \case
unzipMaybe3 _ = (Nothing, Nothing, Nothing)
APIUpdateChatItem (ChatRef cType chatId) itemId live mc -> withUser $ \user -> withChatLock "updateChatItem" $ case cType of
CTDirect -> do
(ct@Contact {contactId}, cci) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId
ct@Contact {contactId} <- withStore $ \db -> getContact db user chatId
assertDirectAllowed user MDSnd ct XMsgUpdate_
cci <- withStore $ \db -> getDirectCIWithReactions db user ct itemId
case cci of
CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive, editable}, content = ciContent} -> do
case (ciContent, itemSharedMsgId, editable) of
@@ -777,7 +778,7 @@ processChatCommand = \case
CTGroup -> do
Group gInfo@GroupInfo {groupId} ms <- withStore $ \db -> getGroup db user chatId
assertUserGroupRole gInfo GRAuthor
cci <- withStore $ \db -> getGroupChatItem db user chatId itemId
cci <- withStore $ \db -> getGroupCIWithReactions db user gInfo itemId
case cci of
CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive, editable}, content = ciContent} -> do
case (ciContent, itemSharedMsgId, editable) of
@@ -2384,8 +2385,8 @@ updateCallItemStatus user ct Call {chatItemId} receivedStatus msgId_ = do
forM_ aciContent_ $ \aciContent -> updateDirectChatItemView user ct chatItemId aciContent False msgId_
updateDirectChatItemView :: ChatMonad m => User -> Contact -> ChatItemId -> ACIContent -> Bool -> Maybe MessageId -> m ()
updateDirectChatItemView user ct@Contact {contactId} chatItemId (ACIContent msgDir ciContent) live msgId_ = do
ci' <- withStore $ \db -> updateDirectChatItem db user contactId chatItemId ciContent live msgId_
updateDirectChatItemView user ct chatItemId (ACIContent msgDir ciContent) live msgId_ = do
ci' <- withStore $ \db -> updateDirectChatItem db user ct chatItemId ciContent live msgId_
toView $ CRChatItemUpdated user (AChatItem SCTDirect msgDir (DirectChat ct) ci')
callStatusItemContent :: ChatMonad m => User -> Contact -> ChatItemId -> WebRTCCallStatus -> m (Maybe ACIContent)
@@ -3989,7 +3990,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ci' <- withStore' $ \db -> do
when changed $
addInitialAndNewCIVersions db (chatItemId' ci) (chatItemTs' ci, oldMC) (brokerTs, mc)
updateDirectChatItem' db user contactId ci content live $ Just msgId
reactions <- getDirectCIReactions db ct sharedMsgId
updateDirectChatItem' db user contactId ci {reactions} content live $ Just msgId
toView $ CRChatItemUpdated user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci')
startUpdatedTimedItemThread user (ChatRef CTDirect contactId) ci ci'
else toView $ CRChatItemNotChanged user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci)
@@ -4127,7 +4129,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ci' <- withStore' $ \db -> do
when changed $
addInitialAndNewCIVersions db (chatItemId' ci) (chatItemTs' ci, oldMC) (brokerTs, mc)
updateGroupChatItem db user groupId ci content live $ Just msgId
reactions <- getGroupCIReactions db gInfo memberId sharedMsgId
updateGroupChatItem db user groupId ci {reactions} content live $ Just msgId
toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci')
startUpdatedTimedItemThread user (ChatRef CTGroup groupId) ci ci'
else toView $ CRChatItemNotChanged user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci)
@@ -4932,7 +4935,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
Just (CChatItem SMDSnd ChatItem {meta = CIMeta {itemId, itemStatus}})
| itemStatus == newStatus -> pure ()
| otherwise -> do
chatItem <- withStore $ \db -> updateDirectChatItemStatus db user contactId itemId newStatus
chatItem <- withStore $ \db -> updateDirectChatItemStatus db user ct itemId newStatus
toView $ CRChatItemStatusUpdated user (AChatItem SCTDirect SMDSnd (DirectChat ct) chatItem)
_ -> pure ()
@@ -4955,7 +4958,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
memStatusCounts <- withStore' (`getGroupSndStatusCounts` itemId)
let newStatus = membersGroupItemStatus memStatusCounts
when (newStatus /= itemStatus) $ do
chatItem <- withStore $ \db -> updateGroupChatItemStatus db user groupId itemId newStatus
chatItem <- withStore $ \db -> updateGroupChatItemStatus db user gInfo itemId newStatus
toView $ CRChatItemStatusUpdated user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) chatItem)
_ -> pure ()
@@ -5198,9 +5201,7 @@ deliverMessage conn@Connection {connId} cmEventTag msgBody msgId = do
let msgFlags = MsgFlags {notification = hasNotification cmEventTag}
agentMsgId <- withAgent $ \a -> sendMessage a (aConnId conn) msgFlags msgBody
let sndMsgDelivery = SndMsgDelivery {connId, agentMsgId}
withStoreCtx'
(Just $ "createSndMsgDelivery, sndMsgDelivery: " <> show sndMsgDelivery <> ", msgId: " <> show msgId <> ", cmEventTag: " <> show cmEventTag <> ", msgDeliveryStatus: MDSSndAgent")
$ \db -> createSndMsgDelivery db sndMsgDelivery msgId
withStore' $ \db -> createSndMsgDelivery db sndMsgDelivery msgId
sendGroupMessage :: (MsgEncodingI e, ChatMonad m) => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> m (SndMessage, [GroupMember])
sendGroupMessage user GroupInfo {groupId} members chatMsgEvent =
+2 -2
View File
@@ -930,7 +930,7 @@ instance ToJSON (CIDeleted d) where
data JSONCIDeleted
= JCIDDeleted {deletedTs :: Maybe UTCTime}
| JCIBlocked {deletedTs :: Maybe UTCTime}
| JCIDBlocked {deletedTs :: Maybe UTCTime}
| JCIDModerated {deletedTs :: Maybe UTCTime, byGroupMember :: GroupMember}
deriving (Show, Generic)
@@ -941,7 +941,7 @@ instance ToJSON JSONCIDeleted where
jsonCIDeleted :: CIDeleted d -> JSONCIDeleted
jsonCIDeleted = \case
CIDeleted ts -> JCIDDeleted ts
CIBlocked ts -> JCIBlocked ts
CIBlocked ts -> JCIDBlocked ts
CIModerated ts m -> JCIDModerated ts m
itemDeletedTs :: CIDeleted d -> Maybe UTCTime
+44 -36
View File
@@ -13,7 +13,6 @@
module Simplex.Chat.Store.Messages
( getContactConnIds_,
getDirectChatReactions_,
-- * Message and chat item functions
deleteContactCIs,
@@ -66,9 +65,11 @@ module Simplex.Chat.Store.Messages
setGroupReaction,
getChatItemIdByAgentMsgId,
getDirectChatItem,
getDirectCIWithReactions,
getDirectChatItemBySharedMsgId,
getDirectChatItemByAgentMsgId,
getGroupChatItem,
getGroupCIWithReactions,
getGroupChatItemBySharedMsgId,
getGroupMemberCIBySharedMsgId,
getGroupChatItemByAgentMsgId,
@@ -751,7 +752,7 @@ getGroupChat :: DB.Connection -> User -> Int64 -> ChatPagination -> Maybe String
getGroupChat db user groupId pagination search_ = do
let search = fromMaybe "" search_
g <- getGroupInfo db user groupId
liftIO . getGroupChatReactions_ db g =<< case pagination of
case pagination of
CPLast count -> getGroupChatLast_ db user g count search
CPAfter afterId count -> getGroupChatAfter_ db user g afterId count search
CPBefore beforeId count -> getGroupChatBefore_ db user g beforeId count search
@@ -760,7 +761,7 @@ getGroupChatLast_ :: DB.Connection -> User -> GroupInfo -> Int -> String -> Exce
getGroupChatLast_ db user@User {userId} g@GroupInfo {groupId} count search = do
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
chatItemIds <- liftIO getGroupChatItemIdsLast_
chatItems <- mapM (getGroupChatItem db user groupId) chatItemIds
chatItems <- mapM (getGroupCIWithReactions db user g) chatItemIds
pure $ Chat (GroupChat g) (reverse chatItems) stats
where
getGroupChatItemIdsLast_ :: IO [ChatItemId]
@@ -798,7 +799,7 @@ getGroupChatAfter_ db user@User {userId} g@GroupInfo {groupId} afterChatItemId c
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
afterChatItem <- getGroupChatItem db user groupId afterChatItemId
chatItemIds <- liftIO $ getGroupChatItemIdsAfter_ (chatItemTs afterChatItem)
chatItems <- mapM (getGroupChatItem db user groupId) chatItemIds
chatItems <- mapM (getGroupCIWithReactions db user g) chatItemIds
pure $ Chat (GroupChat g) chatItems stats
where
getGroupChatItemIdsAfter_ :: UTCTime -> IO [ChatItemId]
@@ -821,7 +822,7 @@ getGroupChatBefore_ db user@User {userId} g@GroupInfo {groupId} beforeChatItemId
let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False}
beforeChatItem <- getGroupChatItem db user groupId beforeChatItemId
chatItemIds <- liftIO $ getGroupChatItemIdsBefore_ (chatItemTs beforeChatItem)
chatItems <- mapM (getGroupChatItem db user groupId) chatItemIds
chatItems <- mapM (getGroupCIWithReactions db user g) chatItemIds
pure $ Chat (GroupChat g) (reverse chatItems) stats
where
getGroupChatItemIdsBefore_ :: UTCTime -> IO [ChatItemId]
@@ -1145,23 +1146,24 @@ getChatItemIdByAgentMsgId db connId msgId =
|]
(connId, msgId)
updateDirectChatItemStatus :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItemId -> CIStatus d -> ExceptT StoreError IO (ChatItem 'CTDirect d)
updateDirectChatItemStatus db user@User {userId} contactId itemId itemStatus = do
ci <- liftEither . correctDir =<< getDirectChatItem db user contactId itemId
updateDirectChatItemStatus :: forall d. MsgDirectionI d => DB.Connection -> User -> Contact -> ChatItemId -> CIStatus d -> ExceptT StoreError IO (ChatItem 'CTDirect d)
updateDirectChatItemStatus db user@User {userId} ct@Contact {contactId} itemId itemStatus = do
ci <- liftEither . correctDir =<< getDirectCIWithReactions db user ct itemId
currentTs <- liftIO getCurrentTime
liftIO $ DB.execute db "UPDATE chat_items SET item_status = ?, updated_at = ? WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?" (itemStatus, currentTs, userId, contactId, itemId)
pure ci {meta = (meta ci) {itemStatus}}
where
correctDir :: CChatItem c -> Either StoreError (ChatItem c d)
correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci
updateDirectChatItem :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItemId -> CIContent d -> Bool -> Maybe MessageId -> ExceptT StoreError IO (ChatItem 'CTDirect d)
updateDirectChatItem db user contactId itemId newContent live msgId_ = do
ci <- liftEither . correctDir =<< getDirectChatItem db user contactId itemId
updateDirectChatItem :: MsgDirectionI d => DB.Connection -> User -> Contact -> ChatItemId -> CIContent d -> Bool -> Maybe MessageId -> ExceptT StoreError IO (ChatItem 'CTDirect d)
updateDirectChatItem db user ct@Contact {contactId} itemId newContent live msgId_ = do
ci <- liftEither . correctDir =<< getDirectCIWithReactions db user ct itemId
liftIO $ updateDirectChatItem' db user contactId ci newContent live msgId_
where
correctDir :: CChatItem c -> Either StoreError (ChatItem c d)
correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci
getDirectCIWithReactions :: DB.Connection -> User -> Contact -> ChatItemId -> ExceptT StoreError IO (CChatItem 'CTDirect)
getDirectCIWithReactions db user ct@Contact {contactId} itemId =
liftIO . directCIWithReactions db ct =<< getDirectChatItem db user contactId itemId
correctDir :: MsgDirectionI d => CChatItem c -> Either StoreError (ChatItem c d)
correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci
updateDirectChatItem' :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItem 'CTDirect d -> CIContent d -> Bool -> Maybe MessageId -> IO (ChatItem 'CTDirect d)
updateDirectChatItem' db User {userId} contactId ci newContent live msgId_ = do
@@ -1299,7 +1301,7 @@ getDirectChatItemIdBySharedMsgId_ db userId contactId sharedMsgId =
getDirectChatItem :: DB.Connection -> User -> Int64 -> ChatItemId -> ExceptT StoreError IO (CChatItem 'CTDirect)
getDirectChatItem db User {userId} contactId itemId = ExceptT $ do
currentTs <- getCurrentTime
join <$> firstRow (toDirectChatItem currentTs) (SEChatItemNotFound itemId) getItem
firstRow' (toDirectChatItem currentTs) (SEChatItemNotFound itemId) getItem
where
getItem =
DB.query
@@ -1347,17 +1349,26 @@ getDirectChatItemIdByText' db User {userId} contactId msg =
|]
(userId, contactId, msg <> "%")
updateGroupChatItemStatus :: forall d. MsgDirectionI d => DB.Connection -> User -> GroupId -> ChatItemId -> CIStatus d -> ExceptT StoreError IO (ChatItem 'CTGroup d)
updateGroupChatItemStatus db user@User {userId} groupId itemId itemStatus = do
ci <- liftEither . correctDir =<< getGroupChatItem db user groupId itemId
updateGroupChatItemStatus :: MsgDirectionI d => DB.Connection -> User -> GroupInfo -> ChatItemId -> CIStatus d -> ExceptT StoreError IO (ChatItem 'CTGroup d)
updateGroupChatItemStatus db user@User {userId} g@GroupInfo {groupId} itemId itemStatus = do
ci <- liftEither . correctDir =<< getGroupCIWithReactions db user g itemId
currentTs <- liftIO getCurrentTime
liftIO $ DB.execute db "UPDATE chat_items SET item_status = ?, updated_at = ? WHERE user_id = ? AND group_id = ? AND chat_item_id = ?" (itemStatus, currentTs, userId, groupId, itemId)
pure ci {meta = (meta ci) {itemStatus}}
where
correctDir :: CChatItem c -> Either StoreError (ChatItem c d)
correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci
updateGroupChatItem :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItem 'CTGroup d -> CIContent d -> Bool -> Maybe MessageId -> IO (ChatItem 'CTGroup d)
getGroupCIWithReactions :: DB.Connection -> User -> GroupInfo -> ChatItemId -> ExceptT StoreError IO (CChatItem 'CTGroup)
getGroupCIWithReactions db user g@GroupInfo {groupId} itemId = do
liftIO . groupCIWithReactions db g =<< getGroupChatItem db user groupId itemId
groupCIWithReactions :: DB.Connection -> GroupInfo -> CChatItem 'CTGroup -> IO (CChatItem 'CTGroup)
groupCIWithReactions db g cci@(CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId}}) = case itemSharedMsgId of
Just sharedMsgId -> do
let GroupMember {memberId} = chatItemMember g ci
reactions <- getGroupCIReactions db g memberId sharedMsgId
pure $ CChatItem md ci {reactions}
Nothing -> pure cci
updateGroupChatItem :: MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItem 'CTGroup d -> CIContent d -> Bool -> Maybe MessageId -> IO (ChatItem 'CTGroup d)
updateGroupChatItem db user groupId ci newContent live msgId_ = do
currentTs <- liftIO getCurrentTime
let ci' = updatedChatItem ci newContent live currentTs
@@ -1366,7 +1377,7 @@ updateGroupChatItem db user groupId ci newContent live msgId_ = do
-- this function assumes that the group item with correct chat direction already exists,
-- it should be checked before calling it
updateGroupChatItem_ :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItem 'CTGroup d -> Maybe MessageId -> IO ()
updateGroupChatItem_ :: MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItem 'CTGroup d -> Maybe MessageId -> IO ()
updateGroupChatItem_ db User {userId} groupId ChatItem {content, meta} msgId_ = do
let CIMeta {itemId, itemText, itemStatus, itemDeleted, itemEdited, itemTimed, itemLive, updatedAt} = meta
itemDeleted' = isJust itemDeleted
@@ -1497,7 +1508,7 @@ getGroupChatItemByAgentMsgId db user groupId connId msgId = do
getGroupChatItem :: DB.Connection -> User -> Int64 -> ChatItemId -> ExceptT StoreError IO (CChatItem 'CTGroup)
getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
currentTs <- getCurrentTime
join <$> firstRow (toGroupChatItem currentTs userContactId) (SEChatItemNotFound itemId) getItem
firstRow' (toGroupChatItem currentTs userContactId) (SEChatItemNotFound itemId) getItem
where
getItem =
DB.query
@@ -1667,18 +1678,15 @@ getChatItemVersions db itemId = do
getDirectChatReactions_ :: DB.Connection -> Contact -> Chat 'CTDirect -> IO (Chat 'CTDirect)
getDirectChatReactions_ db ct c@Chat {chatItems} = do
chatItems' <- forM chatItems $ \(CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId}}) -> do
reactions <- maybe (pure []) (getDirectCIReactions db ct) itemSharedMsgId
pure $ CChatItem md ci {reactions}
chatItems' <- mapM (directCIWithReactions db ct) chatItems
pure c {chatItems = chatItems'}
getGroupChatReactions_ :: DB.Connection -> GroupInfo -> Chat 'CTGroup -> IO (Chat 'CTGroup)
getGroupChatReactions_ db g c@Chat {chatItems} = do
chatItems' <- forM chatItems $ \(CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId}}) -> do
let GroupMember {memberId} = chatItemMember g ci
reactions <- maybe (pure []) (getGroupCIReactions db g memberId) itemSharedMsgId
directCIWithReactions :: DB.Connection -> Contact -> CChatItem 'CTDirect -> IO (CChatItem 'CTDirect)
directCIWithReactions db ct cci@(CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId}}) = case itemSharedMsgId of
Just sharedMsgId -> do
reactions <- getDirectCIReactions db ct sharedMsgId
pure $ CChatItem md ci {reactions}
pure c {chatItems = chatItems'}
Nothing -> pure cci
getDirectCIReactions :: DB.Connection -> Contact -> SharedMsgId -> IO [CIReactionCount]
getDirectCIReactions db Contact {contactId} itemSharedMsgId =