2025-04-05 11:25:45 +00:00
{- # LANGUAGE BangPatterns # -}
2025-01-10 15:27:29 +04:00
{- # LANGUAGE CPP # -}
2023-06-18 10:20:11 +01:00
{- # LANGUAGE DataKinds # -}
{- # LANGUAGE DuplicateRecordFields # -}
{- # LANGUAGE GADTs # -}
2023-12-11 15:50:32 +02:00
{- # LANGUAGE KindSignatures # -}
2023-06-18 10:20:11 +01:00
{- # LANGUAGE LambdaCase # -}
2024-11-14 08:34:25 +00:00
{- # LANGUAGE MultiWayIf # -}
2023-06-18 10:20:11 +01:00
{- # LANGUAGE NamedFieldPuns # -}
{- # LANGUAGE OverloadedStrings # -}
2023-10-11 19:10:38 +01:00
{- # LANGUAGE PatternSynonyms # -}
2023-06-18 10:20:11 +01:00
{- # LANGUAGE QuasiQuotes # -}
{- # LANGUAGE ScopedTypeVariables # -}
2025-04-05 11:25:45 +00:00
{- # LANGUAGE StandaloneDeriving # -}
2023-06-18 10:20:11 +01:00
{- # LANGUAGE TupleSections # -}
{- # LANGUAGE TypeApplications # -}
{- # LANGUAGE TypeOperators # -}
2023-08-25 04:56:37 +08:00
{- # OPTIONS_GHC - fno - warn - ambiguous - fields # -}
2023-06-18 10:20:11 +01:00
module Simplex.Chat.Store.Messages
( getContactConnIds_ ,
2023-06-22 20:38:09 +04:00
2023-06-18 10:20:11 +01:00
-- * Message and chat item functions
deleteContactCIs ,
getGroupFileInfo ,
2025-03-07 07:47:32 +00:00
getGroupMemberFileInfo ,
2024-07-30 22:59:47 +01:00
deleteGroupChatItemsMessages ,
2023-06-18 10:20:11 +01:00
createNewSndMessage ,
createSndMsgDelivery ,
createNewMessageAndRcvMsgDelivery ,
2024-05-31 12:45:58 +01:00
getLastRcvMsgInfo ,
2023-11-18 21:52:01 +04:00
createNewRcvMessage ,
2023-12-23 17:07:23 +04:00
updateSndMsgDeliveryStatus ,
2023-06-18 10:20:11 +01:00
createPendingGroupMessage ,
getPendingGroupMessages ,
deletePendingGroupMessage ,
deleteOldMessages ,
2025-04-05 11:25:45 +00:00
MemberAttention ( .. ) ,
updateChatTsStats ,
2025-04-21 15:17:21 +00:00
setSupportChatTs ,
2023-06-18 10:20:11 +01:00
createNewSndChatItem ,
createNewRcvChatItem ,
createNewChatItemNoMsg ,
2024-01-11 19:01:44 +02:00
createNewChatItem_ ,
2023-06-18 10:20:11 +01:00
getChatPreviews ,
getDirectChat ,
getGroupChat ,
2025-04-02 07:57:18 +00:00
getGroupChatScopeInfoForItem ,
2024-01-11 19:01:44 +02:00
getLocalChat ,
2024-02-19 15:17:14 +04:00
getDirectChatItemLast ,
2023-06-18 10:20:11 +01:00
getAllChatItems ,
getAChatItem ,
2024-03-29 18:30:17 +00:00
getAChatItemBySharedMsgId ,
2023-06-18 10:20:11 +01:00
updateDirectChatItem ,
updateDirectChatItem' ,
addInitialAndNewCIVersions ,
createChatItemVersion ,
deleteDirectChatItem ,
markDirectChatItemDeleted ,
2023-07-26 14:49:35 +04:00
updateGroupChatItemStatus ,
2023-06-18 10:20:11 +01:00
updateGroupChatItem ,
2025-01-29 13:04:48 +00:00
createGroupCIMentions ,
updateGroupCIMentions ,
2023-06-18 10:20:11 +01:00
deleteGroupChatItem ,
updateGroupChatItemModerated ,
2025-03-07 07:47:32 +00:00
updateMemberCIsModerated ,
2024-01-19 17:57:04 +04:00
updateGroupCIBlockedByAdmin ,
2023-06-18 10:20:11 +01:00
markGroupChatItemDeleted ,
2025-03-07 07:47:32 +00:00
markMemberCIsDeleted ,
2023-10-11 19:10:38 +01:00
markGroupChatItemBlocked ,
2024-01-19 17:57:04 +04:00
markGroupCIBlockedByAdmin ,
2025-01-08 09:42:26 +00:00
markMessageReportsDeleted ,
2025-02-09 19:16:30 +00:00
markReceivedGroupReportsDeleted ,
2024-01-11 19:01:44 +02:00
deleteLocalChatItem ,
2023-06-18 10:20:11 +01:00
updateDirectChatItemsRead ,
getDirectUnreadTimedItems ,
2024-09-07 19:40:10 +01:00
updateDirectChatItemsReadList ,
2024-12-01 13:11:30 +00:00
setDirectChatItemRead ,
2024-09-07 19:40:10 +01:00
setDirectChatItemsDeleteAt ,
2023-06-18 10:20:11 +01:00
updateGroupChatItemsRead ,
getGroupUnreadTimedItems ,
2024-09-07 19:40:10 +01:00
updateGroupChatItemsReadList ,
2025-05-20 16:18:23 +00:00
updateGroupScopeUnreadStats ,
2024-09-07 19:40:10 +01:00
setGroupChatItemsDeleteAt ,
2024-01-11 19:01:44 +02:00
updateLocalChatItemsRead ,
2023-06-18 10:20:11 +01:00
getChatRefViaItemId ,
getChatItemVersions ,
getDirectCIReactions ,
getDirectReactions ,
setDirectReaction ,
getGroupCIReactions ,
getGroupReactions ,
setGroupReaction ,
2024-11-28 11:24:29 +04:00
getReactionMembers ,
2024-09-17 23:50:26 +04:00
getChatItemIdsByAgentMsgId ,
2023-06-18 10:20:11 +01:00
getDirectChatItem ,
2023-10-18 10:19:24 +01:00
getDirectCIWithReactions ,
2023-06-18 10:20:11 +01:00
getDirectChatItemBySharedMsgId ,
2024-09-17 23:50:26 +04:00
getDirectChatItemsByAgentMsgId ,
2023-06-18 10:20:11 +01:00
getGroupChatItem ,
2023-10-18 10:19:24 +01:00
getGroupCIWithReactions ,
2023-06-18 10:20:11 +01:00
getGroupChatItemBySharedMsgId ,
getGroupMemberCIBySharedMsgId ,
2024-09-17 23:50:26 +04:00
getGroupChatItemsByAgentMsgId ,
2023-06-18 10:20:11 +01:00
getGroupMemberChatItemLast ,
2024-01-11 19:01:44 +02:00
getLocalChatItem ,
updateLocalChatItem' ,
2023-06-18 10:20:11 +01:00
getDirectChatItemIdByText ,
getDirectChatItemIdByText' ,
getGroupChatItemIdByText ,
getGroupChatItemIdByText' ,
2024-01-11 19:01:44 +02:00
getLocalChatItemIdByText ,
getLocalChatItemIdByText' ,
2023-06-18 10:20:11 +01:00
getChatItemByFileId ,
2024-02-19 12:21:32 +02:00
lookupChatItemByFileId ,
2023-06-18 10:20:11 +01:00
getChatItemByGroupId ,
updateDirectChatItemStatus ,
2024-05-15 15:30:05 +04:00
setDirectSndChatItemViaProxy ,
2023-06-18 10:20:11 +01:00
getTimedItems ,
getChatItemTTL ,
setChatItemTTL ,
2025-01-20 18:06:00 +00:00
getChatTTLCount ,
2023-06-18 10:20:11 +01:00
getContactExpiredFileInfo ,
deleteContactExpiredCIs ,
getGroupExpiredFileInfo ,
deleteGroupExpiredCIs ,
2023-06-22 20:38:09 +04:00
createCIModeration ,
getCIModeration ,
deleteCIModeration ,
2023-07-26 14:49:35 +04:00
createGroupSndStatus ,
getGroupSndStatus ,
updateGroupSndStatus ,
2024-05-15 15:30:05 +04:00
setGroupSndViaProxy ,
2023-07-26 14:49:35 +04:00
getGroupSndStatuses ,
getGroupSndStatusCounts ,
2023-12-23 17:07:23 +04:00
getGroupHistoryItems ,
2023-06-18 10:20:11 +01:00
)
where
2025-02-03 08:55:46 +00:00
import qualified Control.Exception as E
2023-08-25 04:56:37 +08:00
import Control.Monad
2023-06-18 10:20:11 +01:00
import Control.Monad.Except
2023-08-25 04:56:37 +08:00
import Control.Monad.IO.Class
2023-06-18 10:20:11 +01:00
import Crypto.Random ( ChaChaDRG )
import Data.Bifunctor ( first )
import Data.ByteString.Char8 ( ByteString )
import Data.Either ( fromRight , rights )
import Data.Int ( Int64 )
2025-04-05 11:25:45 +00:00
import Data.List ( foldl' , sortBy )
2024-09-07 19:40:10 +01:00
import Data.List.NonEmpty ( NonEmpty )
import qualified Data.List.NonEmpty as L
2025-01-29 13:04:48 +00:00
import Data.Map.Strict ( Map )
import qualified Data.Map.Strict as M
2025-05-13 16:29:47 +00:00
import Data.Maybe ( catMaybes , fromMaybe , isJust , isNothing , mapMaybe )
2023-12-11 15:50:32 +02:00
import Data.Ord ( Down ( .. ) , comparing )
2023-06-18 10:20:11 +01:00
import Data.Text ( Text )
2024-02-19 15:17:14 +04:00
import qualified Data.Text as T
2023-06-18 10:20:11 +01:00
import Data.Time ( addUTCTime )
import Data.Time.Clock ( UTCTime ( .. ) , getCurrentTime )
2025-01-10 19:41:01 +00:00
import Simplex.Chat.Controller ( ChatListQuery ( .. ) , ChatPagination ( .. ) , PaginationByTime ( .. ) )
2023-06-18 10:20:11 +01:00
import Simplex.Chat.Markdown
import Simplex.Chat.Messages
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Protocol
import Simplex.Chat.Store.Direct
import Simplex.Chat.Store.Groups
2024-01-11 19:01:44 +02:00
import Simplex.Chat.Store.NoteFolders
2023-06-18 10:20:11 +01:00
import Simplex.Chat.Store.Shared
import Simplex.Chat.Types
2025-01-29 13:04:48 +00:00
import Simplex.Chat.Types.Shared
2025-04-14 21:25:32 +01:00
import Simplex.Messaging.Agent.Protocol ( AgentMsgId , ConnId , ConnShortLink , ConnectionMode ( .. ) , MsgMeta ( .. ) , UserId )
2024-12-28 12:35:34 +00:00
import Simplex.Messaging.Agent.Store.AgentStore ( firstRow , firstRow' , maybeFirstRow )
2025-01-08 09:42:26 +00:00
import Simplex.Messaging.Agent.Store.DB ( BoolInt ( .. ) )
import qualified Simplex.Messaging.Agent.Store.DB as DB
2023-09-01 19:43:27 +01:00
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File ( CryptoFile ( .. ) , CryptoFileArgs ( .. ) )
2023-06-18 10:20:11 +01:00
import Simplex.Messaging.Util ( eitherToMaybe )
import UnliftIO.STM
2025-01-10 15:27:29 +04:00
# if defined ( dbPostgres )
2025-06-08 18:27:42 +01:00
import Database.PostgreSQL.Simple ( FromRow , In ( .. ) , Only ( .. ) , Query , ToRow , ( :. ) ( .. ) )
2025-01-10 15:27:29 +04:00
import Database.PostgreSQL.Simple.SqlQQ ( sql )
# else
import Database.SQLite.Simple ( FromRow , Only ( .. ) , Query , ToRow , ( :. ) ( .. ) )
import Database.SQLite.Simple.QQ ( sql )
# endif
2023-06-18 10:20:11 +01:00
deleteContactCIs :: DB . Connection -> User -> Contact -> IO ()
deleteContactCIs db user @ User { userId } ct @ Contact { contactId } = do
connIds <- getContactConnIds_ db user ct
forM_ connIds $ \ connId ->
DB . execute db " DELETE FROM messages WHERE connection_id = ? " ( Only connId )
DB . execute db " DELETE FROM chat_item_reactions WHERE contact_id = ? " ( Only contactId )
DB . execute db " DELETE FROM chat_items WHERE user_id = ? AND contact_id = ? " ( userId , contactId )
getContactConnIds_ :: DB . Connection -> User -> Contact -> IO [ Int64 ]
getContactConnIds_ db User { userId } Contact { contactId } =
map fromOnly
<$> DB . query db " SELECT connection_id FROM connections WHERE user_id = ? AND contact_id = ? " ( userId , contactId )
getGroupFileInfo :: DB . Connection -> User -> GroupInfo -> IO [ CIFileInfo ]
getGroupFileInfo db User { userId } GroupInfo { groupId } =
map toFileInfo
<$> DB . query db ( fileInfoQuery <> " WHERE i.user_id = ? AND i.group_id = ? " ) ( userId , groupId )
2025-03-07 07:47:32 +00:00
getGroupMemberFileInfo :: DB . Connection -> User -> GroupInfo -> GroupMember -> IO [ CIFileInfo ]
getGroupMemberFileInfo db User { userId } GroupInfo { groupId } GroupMember { groupMemberId } =
map toFileInfo
<$> DB . query db ( fileInfoQuery <> " WHERE i.user_id = ? AND i.group_id = ? AND i.group_member_id = ? " ) ( userId , groupId , groupMemberId )
2024-07-30 22:59:47 +01:00
deleteGroupChatItemsMessages :: DB . Connection -> User -> GroupInfo -> IO ()
deleteGroupChatItemsMessages db User { userId } GroupInfo { groupId } = do
2023-06-18 10:20:11 +01:00
DB . execute db " DELETE FROM messages WHERE group_id = ? " ( Only groupId )
DB . execute db " DELETE FROM chat_item_reactions WHERE group_id = ? " ( Only groupId )
DB . execute db " DELETE FROM chat_items WHERE user_id = ? AND group_id = ? " ( userId , groupId )
2023-12-23 17:07:23 +04:00
createNewSndMessage :: MsgEncodingI e => DB . Connection -> TVar ChaChaDRG -> ConnOrGroupId -> ChatMsgEvent e -> ( SharedMsgId -> EncodedChatMessage ) -> ExceptT StoreError IO SndMessage
createNewSndMessage db gVar connOrGroupId chatMsgEvent encodeMessage =
createWithRandomId' gVar $ \ sharedMsgId ->
case encodeMessage ( SharedMsgId sharedMsgId ) of
ECMLarge -> pure $ Left SELargeMsg
ECMEncoded msgBody -> do
createdAt <- getCurrentTime
DB . execute
db
[ sql |
INSERT INTO messages (
msg_sent , chat_msg_event , msg_body , connection_id , group_id ,
shared_msg_id , shared_msg_id_user , created_at , updated_at
) VALUES ( ? , ? , ? , ? , ? , ? , ? , ? , ? )
| ]
2025-01-10 15:27:29 +04:00
( MDSnd , toCMEventTag chatMsgEvent , DB . Binary msgBody , connId_ , groupId_ , DB . Binary sharedMsgId , Just ( BI True ) , createdAt , createdAt )
2023-12-23 17:07:23 +04:00
msgId <- insertedRowId db
pure $ Right SndMessage { msgId , sharedMsgId = SharedMsgId sharedMsgId , msgBody }
2023-06-18 10:20:11 +01:00
where
( connId_ , groupId_ ) = case connOrGroupId of
ConnectionId connId -> ( Just connId , Nothing )
GroupId groupId -> ( Nothing , Just groupId )
createSndMsgDelivery :: DB . Connection -> SndMsgDelivery -> MessageId -> IO Int64
2023-12-23 17:07:23 +04:00
createSndMsgDelivery db SndMsgDelivery { connId , agentMsgId } messageId = do
2023-06-18 10:20:11 +01:00
currentTs <- getCurrentTime
2023-12-23 17:07:23 +04:00
DB . execute
db
[ sql |
INSERT INTO msg_deliveries
( message_id , connection_id , agent_msg_id , chat_ts , created_at , updated_at , delivery_status )
VALUES ( ? , ? , ? , ? , ? , ? , ? )
| ]
( messageId , connId , agentMsgId , currentTs , currentTs , currentTs , MDSSndAgent )
insertedRowId db
2023-06-18 10:20:11 +01:00
2023-12-23 17:07:23 +04:00
createNewMessageAndRcvMsgDelivery :: forall e . MsgEncodingI e => DB . Connection -> ConnOrGroupId -> NewRcvMessage e -> Maybe SharedMsgId -> RcvMsgDelivery -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage
2024-03-28 19:52:06 +04:00
createNewMessageAndRcvMsgDelivery db connOrGroupId newMessage sharedMsgId_ RcvMsgDelivery { connId , agentMsgId , agentMsgMeta } authorGroupMemberId_ = do
2023-11-18 21:52:01 +04:00
msg @ RcvMessage { msgId } <- createNewRcvMessage db connOrGroupId newMessage sharedMsgId_ authorGroupMemberId_ Nothing
liftIO $ do
currentTs <- getCurrentTime
DB . execute
db
2023-12-23 17:07:23 +04:00
[ sql |
INSERT INTO msg_deliveries
2024-03-28 19:52:06 +04:00
( message_id , connection_id , agent_msg_id , agent_msg_meta , chat_ts , created_at , updated_at , delivery_status )
VALUES ( ? , ? , ? , ? , ? , ? , ? , ? )
2023-12-23 17:07:23 +04:00
| ]
2024-03-28 19:52:06 +04:00
( msgId , connId , agentMsgId , msgMetaJson agentMsgMeta , snd $ broker agentMsgMeta , currentTs , currentTs , MDSRcvAgent )
2023-11-18 21:52:01 +04:00
pure msg
2024-05-31 12:45:58 +01:00
getLastRcvMsgInfo :: DB . Connection -> Int64 -> IO ( Maybe RcvMsgInfo )
getLastRcvMsgInfo db connId =
maybeFirstRow rcvMsgInfo $
DB . query
db
[ sql |
SELECT message_id , msg_delivery_id , delivery_status , agent_msg_id , agent_msg_meta
FROM msg_deliveries
WHERE connection_id = ? AND delivery_status IN ( ? , ? )
ORDER BY created_at DESC , msg_delivery_id DESC
LIMIT 1
| ]
( connId , MDSRcvAgent , MDSRcvAcknowledged )
where
rcvMsgInfo ( msgId , msgDeliveryId , msgDeliveryStatus , agentMsgId , agentMsgMeta ) =
RcvMsgInfo { msgId , msgDeliveryId , msgDeliveryStatus , agentMsgId , agentMsgMeta }
2023-12-23 17:07:23 +04:00
createNewRcvMessage :: forall e . MsgEncodingI e => DB . Connection -> ConnOrGroupId -> NewRcvMessage e -> Maybe SharedMsgId -> Maybe GroupMemberId -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage
createNewRcvMessage db connOrGroupId NewRcvMessage { chatMsgEvent , msgBody } sharedMsgId_ authorMember forwardedByMember =
2023-11-18 21:52:01 +04:00
case connOrGroupId of
ConnectionId connId -> liftIO $ insertRcvMsg ( Just connId ) Nothing
GroupId groupId -> case sharedMsgId_ of
2023-11-26 18:16:37 +00:00
Just sharedMsgId ->
liftIO ( duplicateGroupMsgMemberIds groupId sharedMsgId ) >>= \ case
Just ( duplAuthorId , duplFwdMemberId ) ->
throwError $ SEDuplicateGroupMessage groupId sharedMsgId duplAuthorId duplFwdMemberId
Nothing -> liftIO $ insertRcvMsg Nothing $ Just groupId
2023-11-18 21:52:01 +04:00
Nothing -> liftIO $ insertRcvMsg Nothing $ Just groupId
2023-11-26 18:16:37 +00:00
where
duplicateGroupMsgMemberIds :: Int64 -> SharedMsgId -> IO ( Maybe ( Maybe GroupMemberId , Maybe GroupMemberId ) )
duplicateGroupMsgMemberIds groupId sharedMsgId =
maybeFirstRow id $
DB . query
db
[ sql |
SELECT author_group_member_id , forwarded_by_group_member_id
FROM messages
WHERE group_id = ? AND shared_msg_id = ? LIMIT 1
| ]
( groupId , sharedMsgId )
insertRcvMsg connId_ groupId_ = do
currentTs <- getCurrentTime
DB . execute
2023-11-18 21:52:01 +04:00
db
[ sql |
2023-11-26 18:16:37 +00:00
INSERT INTO messages
( msg_sent , chat_msg_event , msg_body , created_at , updated_at , connection_id , group_id , shared_msg_id , author_group_member_id , forwarded_by_group_member_id )
VALUES ( ? , ? , ? , ? , ? , ? , ? , ? , ? , ? )
2023-11-18 21:52:01 +04:00
| ]
2025-01-10 15:27:29 +04:00
( MDRcv , toCMEventTag chatMsgEvent , DB . Binary msgBody , currentTs , currentTs , connId_ , groupId_ , sharedMsgId_ , authorMember , forwardedByMember )
2023-11-26 18:16:37 +00:00
msgId <- insertedRowId db
pure RcvMessage { msgId , chatMsgEvent = ACME ( encoding @ e ) chatMsgEvent , sharedMsgId_ , msgBody , authorMember , forwardedByMember }
2023-06-18 10:20:11 +01:00
2023-12-23 17:07:23 +04:00
updateSndMsgDeliveryStatus :: DB . Connection -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> IO ()
updateSndMsgDeliveryStatus db connId agentMsgId sndMsgDeliveryStatus = do
currentTs <- getCurrentTime
2023-06-18 10:20:11 +01:00
DB . execute
db
[ sql |
2023-12-23 17:07:23 +04:00
UPDATE msg_deliveries
SET delivery_status = ? , updated_at = ?
WHERE connection_id = ? AND agent_msg_id = ?
2023-06-18 10:20:11 +01:00
| ]
2023-12-23 17:07:23 +04:00
( sndMsgDeliveryStatus , currentTs , connId , agentMsgId )
2023-06-18 10:20:11 +01:00
createPendingGroupMessage :: DB . Connection -> Int64 -> MessageId -> Maybe Int64 -> IO ()
createPendingGroupMessage db groupMemberId messageId introId_ = do
currentTs <- getCurrentTime
DB . execute
db
[ sql |
INSERT INTO pending_group_messages
( group_member_id , message_id , group_member_intro_id , created_at , updated_at ) VALUES ( ? , ? , ? , ? , ? )
| ]
( groupMemberId , messageId , introId_ , currentTs , currentTs )
2024-05-28 18:32:29 +04:00
getPendingGroupMessages :: DB . Connection -> Int64 -> IO [ ( SndMessage , ACMEventTag , Maybe Int64 ) ]
2023-06-18 10:20:11 +01:00
getPendingGroupMessages db groupMemberId =
map pendingGroupMessage
<$> DB . query
db
[ sql |
2024-05-28 18:32:29 +04:00
SELECT pgm . message_id , m . shared_msg_id , m . msg_body , m . chat_msg_event , pgm . group_member_intro_id
2023-06-18 10:20:11 +01:00
FROM pending_group_messages pgm
JOIN messages m USING ( message_id )
WHERE pgm . group_member_id = ?
2024-05-28 16:42:07 +04:00
ORDER BY pgm . created_at ASC , pgm . message_id ASC
2023-06-18 10:20:11 +01:00
| ]
( Only groupMemberId )
where
2024-05-28 18:32:29 +04:00
pendingGroupMessage ( msgId , sharedMsgId , msgBody , cmEventTag , introId_ ) =
( SndMessage { msgId , sharedMsgId , msgBody } , cmEventTag , introId_ )
2023-06-18 10:20:11 +01:00
deletePendingGroupMessage :: DB . Connection -> Int64 -> MessageId -> IO ()
deletePendingGroupMessage db groupMemberId messageId =
DB . execute db " DELETE FROM pending_group_messages WHERE group_member_id = ? AND message_id = ? " ( groupMemberId , messageId )
deleteOldMessages :: DB . Connection -> UTCTime -> IO ()
deleteOldMessages db createdAtCutoff = do
DB . execute db " DELETE FROM messages WHERE created_at <= ? " ( Only createdAtCutoff )
type NewQuoteRow = ( Maybe SharedMsgId , Maybe UTCTime , Maybe MsgContent , Maybe Bool , Maybe MemberId )
2025-05-12 12:19:20 +00:00
-- For support chats with members we track unanswered count - number of messages from the member
-- that weren't followed up by a message from any of moderators.
data MemberAttention
-- Message was received from member, increase unanswered counter and set support_chat_last_msg_from_member_ts.
-- `MAInc 0 Nothing` is used in two cases:
-- - when message from moderator is older than the last message from member (support_chat_last_msg_from_member_ts);
-- - for user's chat with moderators, where unanswered count is not tracked.
= MAInc Int ( Maybe UTCTime )
-- Message was received from moderator, reset unanswered counter.
| MAReset
2025-04-05 11:25:45 +00:00
deriving ( Show )
2025-05-09 15:36:06 +00:00
updateChatTsStats :: DB . Connection -> VersionRangeChat -> User -> ChatDirection c d -> UTCTime -> Maybe ( Int , MemberAttention , Int ) -> IO ( ChatInfo c )
updateChatTsStats db vr user @ User { userId } chatDirection chatTs chatStats_ = case toChatInfo chatDirection of
DirectChat ct @ Contact { contactId } -> do
2023-06-18 10:20:11 +01:00
DB . execute
db
2024-05-13 16:51:54 +04:00
" UPDATE contacts SET chat_ts = ?, chat_deleted = 0 WHERE user_id = ? AND contact_id = ? "
2023-06-18 10:20:11 +01:00
( chatTs , userId , contactId )
2025-05-09 15:36:06 +00:00
pure $ DirectChat ct { chatTs = Just chatTs }
GroupChat g @ GroupInfo { groupId } Nothing -> do
2023-06-18 10:20:11 +01:00
DB . execute
db
" UPDATE groups SET chat_ts = ? WHERE user_id = ? AND group_id = ? "
( chatTs , userId , groupId )
2025-05-09 15:36:06 +00:00
pure $ GroupChat g { chatTs = Just chatTs } Nothing
GroupChat g @ GroupInfo { groupId , membership , membersRequireAttention } ( Just GCSIMemberSupport { groupMember_ } ) ->
case groupMember_ of
Nothing -> do
membership' <- updateGMStats membership
DB . execute
db
" UPDATE groups SET chat_ts = ? WHERE user_id = ? AND group_id = ? "
( chatTs , userId , groupId )
pure $ GroupChat g { membership = membership' , chatTs = Just chatTs } ( Just $ GCSIMemberSupport Nothing )
Just member -> do
member' <- updateGMStats member
let didRequire = gmRequiresAttention member
nowRequires = gmRequiresAttention member'
if
| nowRequires && not didRequire -> do
DB . execute
db
[ sql |
UPDATE groups
SET chat_ts = ? ,
members_require_attention = members_require_attention + 1
WHERE user_id = ? AND group_id = ?
| ]
( chatTs , userId , groupId )
pure $ GroupChat g { membersRequireAttention = membersRequireAttention + 1 , chatTs = Just chatTs } ( Just $ GCSIMemberSupport ( Just member' ) )
| not nowRequires && didRequire -> do
DB . execute
db
[ sql |
UPDATE groups
SET chat_ts = ? ,
members_require_attention = members_require_attention - 1
WHERE user_id = ? AND group_id = ?
| ]
( chatTs , userId , groupId )
pure $ GroupChat g { membersRequireAttention = membersRequireAttention - 1 , chatTs = Just chatTs } ( Just $ GCSIMemberSupport ( Just member' ) )
| otherwise -> do
DB . execute
db
" UPDATE groups SET chat_ts = ? WHERE user_id = ? AND group_id = ? "
( chatTs , userId , groupId )
pure $ GroupChat g { chatTs = Just chatTs } ( Just $ GCSIMemberSupport ( Just member' ) )
where
updateGMStats m @ GroupMember { groupMemberId } = do
case chatStats_ of
Nothing ->
DB . execute
db
" UPDATE group_members SET support_chat_ts = ? WHERE group_member_id = ? "
( chatTs , groupMemberId )
2025-05-12 12:19:20 +00:00
Just ( unread , MAInc unanswered Nothing , mentions ) ->
2025-05-09 15:36:06 +00:00
DB . execute
db
[ sql |
UPDATE group_members
SET support_chat_ts = ? ,
support_chat_items_unread = support_chat_items_unread + ? ,
support_chat_items_member_attention = support_chat_items_member_attention + ? ,
support_chat_items_mentions = support_chat_items_mentions + ?
WHERE group_member_id = ?
| ]
( chatTs , unread , unanswered , mentions , groupMemberId )
2025-05-12 12:19:20 +00:00
Just ( unread , MAInc unanswered ( Just lastMsgFromMemberTs ) , mentions ) ->
DB . execute
db
[ sql |
UPDATE group_members
SET support_chat_ts = ? ,
support_chat_items_unread = support_chat_items_unread + ? ,
support_chat_items_member_attention = support_chat_items_member_attention + ? ,
support_chat_items_mentions = support_chat_items_mentions + ? ,
support_chat_last_msg_from_member_ts = ?
WHERE group_member_id = ?
| ]
( chatTs , unread , unanswered , mentions , lastMsgFromMemberTs , groupMemberId )
2025-05-09 15:36:06 +00:00
Just ( unread , MAReset , mentions ) ->
DB . execute
db
[ sql |
UPDATE group_members
SET support_chat_ts = ? ,
support_chat_items_unread = support_chat_items_unread + ? ,
support_chat_items_member_attention = 0 ,
support_chat_items_mentions = support_chat_items_mentions + ?
WHERE group_member_id = ?
| ]
( chatTs , unread , mentions , groupMemberId )
m_ <- runExceptT $ getGroupMemberById db vr user groupMemberId
pure $ either ( const m ) id m_ -- Left shouldn't happen, but types require it
LocalChat nf @ NoteFolder { noteFolderId } -> do
2024-01-11 19:01:44 +02:00
DB . execute
db
" UPDATE note_folders SET chat_ts = ? WHERE user_id = ? AND note_folder_id = ? "
( chatTs , userId , noteFolderId )
2025-05-09 15:36:06 +00:00
pure $ LocalChat nf { chatTs = chatTs }
cInfo -> pure cInfo
2023-06-18 10:20:11 +01:00
2025-04-21 15:17:21 +00:00
setSupportChatTs :: DB . Connection -> GroupMemberId -> UTCTime -> IO ()
setSupportChatTs db groupMemberId chatTs =
DB . execute db " UPDATE group_members SET support_chat_ts = ? WHERE group_member_id = ? " ( chatTs , groupMemberId )
2025-04-02 07:57:18 +00:00
createNewSndChatItem :: DB . Connection -> User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe ( CIQuote c ) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> UTCTime -> IO ChatItemId
createNewSndChatItem db user chatDirection SndMessage { msgId , sharedMsgId } ciContent quotedItem itemForwarded timed live createdAt =
2025-06-23 14:42:00 +01:00
createNewChatItem_ db user chatDirection False createdByMsgId ( Just sharedMsgId ) ciContent quoteRow itemForwarded timed live False createdAt Nothing createdAt
2023-06-18 10:20:11 +01:00
where
createdByMsgId = if msgId == 0 then Nothing else Just msgId
quoteRow :: NewQuoteRow
quoteRow = case quotedItem of
Nothing -> ( Nothing , Nothing , Nothing , Nothing , Nothing )
Just CIQuote { chatDir , sharedMsgId = quotedSharedMsgId , sentAt , content } ->
uncurry ( quotedSharedMsgId , Just sentAt , Just content , , ) $ case chatDir of
CIQDirectSnd -> ( Just True , Nothing )
CIQDirectRcv -> ( Just False , Nothing )
CIQGroupSnd -> ( Just True , Nothing )
CIQGroupRcv ( Just GroupMember { memberId } ) -> ( Just False , Just memberId )
CIQGroupRcv Nothing -> ( Just False , Nothing )
2025-04-02 07:57:18 +00:00
createNewRcvChatItem :: ChatTypeQuotable c => DB . Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> Bool -> UTCTime -> UTCTime -> IO ( ChatItemId , Maybe ( CIQuote c ) , Maybe CIForwardedFrom )
createNewRcvChatItem db user chatDirection RcvMessage { msgId , chatMsgEvent , forwardedByMember } sharedMsgId_ ciContent timed live userMention itemTs createdAt = do
2025-06-23 14:42:00 +01:00
ciId <- createNewChatItem_ db user chatDirection False ( Just msgId ) sharedMsgId_ ciContent quoteRow itemForwarded timed live userMention itemTs forwardedByMember createdAt
2023-06-18 10:20:11 +01:00
quotedItem <- mapM ( getChatItemQuote_ db user chatDirection ) quotedMsg
2024-04-09 13:02:59 +01:00
pure ( ciId , quotedItem , itemForwarded )
2023-06-18 10:20:11 +01:00
where
2024-04-09 13:02:59 +01:00
itemForwarded = cmForwardedFrom chatMsgEvent
2023-06-18 10:20:11 +01:00
quotedMsg = cmToQuotedMsg chatMsgEvent
quoteRow :: NewQuoteRow
quoteRow = case quotedMsg of
Nothing -> ( Nothing , Nothing , Nothing , Nothing , Nothing )
Just QuotedMsg { msgRef = MsgRef { msgId = sharedMsgId , sentAt , sent , memberId } , content } ->
uncurry ( sharedMsgId , Just sentAt , Just content , , ) $ case chatDirection of
CDDirectRcv _ -> ( Just $ not sent , Nothing )
2025-04-02 07:57:18 +00:00
CDGroupRcv GroupInfo { membership = GroupMember { memberId = userMemberId } } _ _ ->
2023-06-18 10:20:11 +01:00
( Just $ Just userMemberId == memberId , memberId )
2025-06-25 16:59:32 +01:00
createNewChatItemNoMsg :: forall c d . MsgDirectionI d => DB . Connection -> User -> ChatDirection c d -> ShowGroupAsSender -> CIContent d -> Maybe SharedMsgId -> UTCTime -> UTCTime -> IO ChatItemId
createNewChatItemNoMsg db user chatDirection showGroupAsSender ciContent sharedMsgId_ itemTs =
createNewChatItem_ db user chatDirection showGroupAsSender Nothing sharedMsgId_ ciContent quoteRow Nothing Nothing False False itemTs Nothing
2023-06-18 10:20:11 +01:00
where
quoteRow :: NewQuoteRow
quoteRow = ( Nothing , Nothing , Nothing , Nothing , Nothing )
2025-06-23 14:42:00 +01:00
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 -> UTCTime -> Maybe GroupMemberId -> UTCTime -> IO ChatItemId
createNewChatItem_ db User { userId } chatDirection showGroupAsSender msgId_ sharedMsgId ciContent quoteRow itemForwarded timed live userMention itemTs forwardedByMember createdAt = do
2023-06-18 10:20:11 +01:00
DB . execute
db
[ sql |
INSERT INTO chat_items (
-- user and IDs
2025-04-02 07:57:18 +00:00
user_id , created_by_msg_id , contact_id , group_id , group_member_id , note_folder_id , group_scope_tag , group_scope_group_member_id ,
2023-06-18 10:20:11 +01:00
-- meta
2025-01-04 18:33:27 +00:00
item_sent , item_ts , item_content , item_content_tag , item_text , item_status , msg_content_tag , shared_msg_id ,
2025-06-23 14:42:00 +01:00
forwarded_by_group_member_id , include_in_history , created_at , updated_at , item_live , user_mention , show_group_as_sender , timed_ttl , timed_delete_at ,
2023-06-18 10:20:11 +01:00
-- quote
2024-04-09 13:02:59 +01:00
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
2025-06-23 14:42:00 +01:00
) VALUES ( ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? )
2023-06-18 10:20:11 +01:00
| ]
2025-04-02 07:57:18 +00:00
( ( userId , msgId_ ) :. idsRow :. groupScopeRow :. itemRow :. quoteRow' :. forwardedFromRow )
2023-06-18 10:20:11 +01:00
ciId <- insertedRowId db
forM_ msgId_ $ \ msgId -> insertChatItemMessage_ db ciId msgId createdAt
pure ciId
where
2025-06-23 14:42:00 +01:00
itemRow :: ( SMsgDirection d , UTCTime , CIContent d , Text , Text , CIStatus d , Maybe MsgContentTag , Maybe SharedMsgId , Maybe GroupMemberId , BoolInt ) :. ( UTCTime , UTCTime , Maybe BoolInt , BoolInt , BoolInt ) :. ( Maybe Int , Maybe UTCTime )
itemRow = ( msgDirection @ d , itemTs , ciContent , toCIContentTag ciContent , ciContentToText ciContent , ciCreateStatus ciContent , msgContentTag <$> ciMsgContent ciContent , sharedMsgId , forwardedByMember , BI includeInHistory ) :. ( createdAt , createdAt , BI <$> ( justTrue live ) , BI userMention , BI showGroupAsSender ) :. ciTimedRow timed
2025-01-10 15:27:29 +04:00
quoteRow' = let ( a , b , c , d , e ) = quoteRow in ( a , b , c , BI <$> d , e )
2025-04-02 07:57:18 +00:00
idsRow :: ( Maybe ContactId , Maybe GroupId , Maybe GroupMemberId , Maybe NoteFolderId )
2023-06-18 10:20:11 +01:00
idsRow = case chatDirection of
2024-01-11 19:01:44 +02:00
CDDirectRcv Contact { contactId } -> ( Just contactId , Nothing , Nothing , Nothing )
CDDirectSnd Contact { contactId } -> ( Just contactId , Nothing , Nothing , Nothing )
2025-04-02 07:57:18 +00:00
CDGroupRcv GroupInfo { groupId } _ GroupMember { groupMemberId } -> ( Nothing , Just groupId , Just groupMemberId , Nothing )
CDGroupSnd GroupInfo { groupId } _ -> ( Nothing , Just groupId , Nothing , Nothing )
2024-01-11 19:01:44 +02:00
CDLocalRcv NoteFolder { noteFolderId } -> ( Nothing , Nothing , Nothing , Just noteFolderId )
CDLocalSnd NoteFolder { noteFolderId } -> ( Nothing , Nothing , Nothing , Just noteFolderId )
2025-04-02 07:57:18 +00:00
groupScope :: Maybe ( Maybe GroupChatScopeInfo )
groupScope = case chatDirection of
CDGroupRcv _ scope _ -> Just scope
CDGroupSnd _ scope -> Just scope
_ -> Nothing
groupScopeRow :: ( Maybe GroupChatScopeTag , Maybe GroupMemberId )
groupScopeRow = case groupScope of
Just ( Just GCSIMemberSupport { groupMember_ } ) -> ( Just GCSTMemberSupport_ , groupMemberId' <$> groupMember_ )
_ -> ( Nothing , Nothing )
2025-01-22 23:33:54 +04:00
includeInHistory :: Bool
2025-04-02 07:57:18 +00:00
includeInHistory = case groupScope of
Just Nothing -> isJust ( ciMsgContent ciContent ) && ( ( msgContentTag <$> ciMsgContent ciContent ) /= Just MCReport_ )
_ -> False
2024-04-09 13:02:59 +01:00
forwardedFromRow :: ( Maybe CIForwardedFromTag , Maybe Text , Maybe MsgDirection , Maybe Int64 , Maybe Int64 , Maybe Int64 )
forwardedFromRow = case itemForwarded of
Nothing ->
( Nothing , Nothing , Nothing , Nothing , Nothing , Nothing )
Just CIFFUnknown ->
( Just CIFFUnknown_ , Nothing , Nothing , Nothing , Nothing , Nothing )
Just CIFFContact { chatName , msgDir , contactId , chatItemId } ->
( Just CIFFContact_ , Just chatName , Just msgDir , contactId , Nothing , chatItemId )
Just CIFFGroup { chatName , msgDir , groupId , chatItemId } ->
2024-04-13 14:52:39 +04:00
( Just CIFFGroup_ , Just chatName , Just msgDir , Nothing , groupId , chatItemId )
2023-06-18 10:20:11 +01:00
ciTimedRow :: Maybe CITimed -> ( Maybe Int , Maybe UTCTime )
ciTimedRow ( Just CITimed { ttl , deleteAt } ) = ( Just ttl , deleteAt )
ciTimedRow _ = ( Nothing , Nothing )
insertChatItemMessage_ :: DB . Connection -> ChatItemId -> MessageId -> UTCTime -> IO ()
insertChatItemMessage_ db ciId msgId ts = DB . execute db " INSERT INTO chat_item_messages (chat_item_id, message_id, created_at, updated_at) VALUES (?,?,?,?) " ( ciId , msgId , ts , ts )
2024-01-11 19:01:44 +02:00
getChatItemQuote_ :: ChatTypeQuotable c => DB . Connection -> User -> ChatDirection c 'MDRcv -> QuotedMsg -> IO ( CIQuote c )
2023-06-18 10:20:11 +01:00
getChatItemQuote_ db User { userId , userContactId } chatDirection QuotedMsg { msgRef = MsgRef { msgId , sentAt , sent , memberId } , content } =
case chatDirection of
CDDirectRcv Contact { contactId } -> getDirectChatItemQuote_ contactId ( not sent )
2025-04-02 07:57:18 +00:00
CDGroupRcv GroupInfo { groupId , membership = GroupMember { memberId = userMemberId } } _s sender @ GroupMember { groupMemberId = senderGMId , memberId = senderMemberId } ->
2023-06-18 10:20:11 +01:00
case memberId of
Just mId
| mId == userMemberId -> ( ` ciQuote ` CIQGroupSnd ) <$> getUserGroupChatItemId_ groupId
2025-01-10 15:27:29 +04:00
| mId == senderMemberId -> ( ` ciQuote ` CIQGroupRcv ( Just sender ) ) <$> getGroupChatItemId_ groupId senderGMId
2023-06-18 10:20:11 +01:00
| otherwise -> getGroupChatItemQuote_ groupId mId
_ -> pure . ciQuote Nothing $ CIQGroupRcv Nothing
where
ciQuote :: Maybe ChatItemId -> CIQDirection c -> CIQuote c
ciQuote itemId dir = CIQuote dir itemId msgId sentAt content . parseMaybeMarkdownList $ msgContentText content
getDirectChatItemQuote_ :: Int64 -> Bool -> IO ( CIQuote 'CTDirect )
getDirectChatItemQuote_ contactId userSent = do
fmap ciQuoteDirect . maybeFirstRow fromOnly $
DB . query
db
" SELECT chat_item_id FROM chat_items WHERE user_id = ? AND contact_id = ? AND shared_msg_id = ? AND item_sent = ? "
2025-01-10 15:27:29 +04:00
( userId , contactId , msgId , BI userSent )
2023-06-18 10:20:11 +01:00
where
ciQuoteDirect :: Maybe ChatItemId -> CIQuote 'CTDirect
ciQuoteDirect = ( ` ciQuote ` if userSent then CIQDirectSnd else CIQDirectRcv )
getUserGroupChatItemId_ :: Int64 -> IO ( Maybe ChatItemId )
getUserGroupChatItemId_ groupId =
maybeFirstRow fromOnly $
DB . query
db
" SELECT chat_item_id FROM chat_items WHERE user_id = ? AND group_id = ? AND shared_msg_id = ? AND item_sent = ? AND group_member_id IS NULL "
( userId , groupId , msgId , MDSnd )
2025-01-10 15:27:29 +04:00
getGroupChatItemId_ :: Int64 -> GroupMemberId -> IO ( Maybe ChatItemId )
getGroupChatItemId_ groupId groupMemberId =
2023-06-18 10:20:11 +01:00
maybeFirstRow fromOnly $
DB . query
db
" SELECT chat_item_id FROM chat_items WHERE user_id = ? AND group_id = ? AND shared_msg_id = ? AND item_sent = ? AND group_member_id = ? "
2025-01-10 15:27:29 +04:00
( userId , groupId , msgId , MDRcv , groupMemberId )
2023-06-18 10:20:11 +01:00
getGroupChatItemQuote_ :: Int64 -> MemberId -> IO ( CIQuote 'CTGroup )
getGroupChatItemQuote_ groupId mId = do
ciQuoteGroup
2025-01-10 15:27:29 +04:00
<$> DB . query
2023-06-18 10:20:11 +01:00
db
[ sql |
2023-12-11 15:50:32 +02:00
SELECT i . chat_item_id ,
2023-06-18 10:20:11 +01:00
-- GroupMember
2023-11-18 21:52:01 +04:00
m . group_member_id , m . group_id , m . member_id , m . peer_chat_min_version , m . peer_chat_max_version , m . member_role , m . member_category ,
2024-01-19 17:57:04 +04:00
m . member_status , m . show_messages , m . member_restriction , m . invited_by , m . invited_by_group_member_id , m . local_display_name , m . contact_id , m . contact_profile_id , p . contact_profile_id ,
2025-02-25 09:24:30 +00:00
p . display_name , p . full_name , p . image , p . contact_link , p . local_alias , p . preferences ,
2025-04-05 11:25:45 +00:00
m . created_at , m . updated_at ,
2025-05-12 12:19:20 +00:00
m . support_chat_ts , m . support_chat_items_unread , m . support_chat_items_member_attention , m . support_chat_items_mentions , m . support_chat_last_msg_from_member_ts
2023-06-18 10:20:11 +01:00
FROM group_members m
JOIN contact_profiles p ON p . contact_profile_id = COALESCE ( m . member_profile_id , m . contact_profile_id )
LEFT JOIN contacts c ON m . contact_id = c . contact_id
2024-03-12 16:51:02 +04:00
LEFT JOIN chat_items i ON i . user_id = m . user_id
AND i . group_id = m . group_id
2023-06-18 10:20:11 +01:00
AND m . group_member_id = i . group_member_id
2025-01-10 15:27:29 +04:00
AND i . shared_msg_id = ?
WHERE m . user_id = ? AND m . group_id = ? AND m . member_id = ?
2023-06-18 10:20:11 +01:00
| ]
2025-01-10 15:27:29 +04:00
( msgId , userId , groupId , mId )
2023-06-18 10:20:11 +01:00
where
ciQuoteGroup :: [ Only ( Maybe ChatItemId ) :. GroupMemberRow ] -> CIQuote 'CTGroup
ciQuoteGroup [] = ciQuote Nothing $ CIQGroupRcv Nothing
ciQuoteGroup ( ( Only itemId :. memberRow ) : _ ) = ciQuote itemId . CIQGroupRcv . Just $ toGroupMember userContactId memberRow
2024-04-22 20:46:48 +04:00
getChatPreviews :: DB . Connection -> VersionRangeChat -> User -> Bool -> PaginationByTime -> ChatListQuery -> IO [ Either StoreError AChat ]
2023-12-24 13:27:51 +00:00
getChatPreviews db vr user withPCC pagination query = do
2023-12-11 15:50:32 +02:00
directChats <- findDirectChatPreviews_ db user pagination query
groupChats <- findGroupChatPreviews_ db user pagination query
2024-01-11 19:01:44 +02:00
localChats <- findLocalChatPreviews_ db user pagination query
2023-12-11 15:50:32 +02:00
cReqChats <- getContactRequestChatPreviews_ db user pagination query
connChats <- if withPCC then getContactConnectionChatPreviews_ db user pagination query else pure []
2024-01-11 19:01:44 +02:00
let refs = sortTake $ concat [ directChats , groupChats , localChats , cReqChats , connChats ]
2023-12-11 15:50:32 +02:00
mapM ( runExceptT <$> getChatPreview ) refs
2023-06-18 10:20:11 +01:00
where
2023-12-11 15:50:32 +02:00
ts :: AChatPreviewData -> UTCTime
ts ( ACPD _ cpd ) = case cpd of
2023-12-13 15:32:23 +04:00
( DirectChatPD t _ _ _ ) -> t
( GroupChatPD t _ _ _ ) -> t
2024-01-11 19:01:44 +02:00
( LocalChatPD t _ _ _ ) -> t
2023-12-11 15:50:32 +02:00
( ContactRequestPD t _ ) -> t
( ContactConnectionPD t _ ) -> t
sortTake = case pagination of
PTLast count -> take count . sortBy ( comparing $ Down . ts )
PTAfter _ count -> reverse . take count . sortBy ( comparing ts )
PTBefore _ count -> take count . sortBy ( comparing $ Down . ts )
getChatPreview :: AChatPreviewData -> ExceptT StoreError IO AChat
getChatPreview ( ACPD cType cpd ) = case cType of
2024-03-10 20:52:29 +00:00
SCTDirect -> getDirectChatPreview_ db vr user cpd
2023-12-24 13:27:51 +00:00
SCTGroup -> getGroupChatPreview_ db vr user cpd
2024-01-11 19:01:44 +02:00
SCTLocal -> getLocalChatPreview_ db user cpd
2023-12-11 15:50:32 +02:00
SCTContactRequest -> let ( ContactRequestPD _ chat ) = cpd in pure chat
SCTContactConnection -> let ( ContactConnectionPD _ chat ) = cpd in pure chat
data ChatPreviewData ( c :: ChatType ) where
2023-12-13 15:32:23 +04:00
DirectChatPD :: UTCTime -> ContactId -> Maybe ChatItemId -> ChatStats -> ChatPreviewData 'CTDirect
GroupChatPD :: UTCTime -> GroupId -> Maybe ChatItemId -> ChatStats -> ChatPreviewData 'CTGroup
2024-01-11 19:01:44 +02:00
LocalChatPD :: UTCTime -> NoteFolderId -> Maybe ChatItemId -> ChatStats -> ChatPreviewData 'CTLocal
2023-12-11 15:50:32 +02:00
ContactRequestPD :: UTCTime -> AChat -> ChatPreviewData 'CTContactRequest
ContactConnectionPD :: UTCTime -> AChat -> ChatPreviewData 'CTContactConnection
data AChatPreviewData = forall c . ChatTypeI c => ACPD ( SChatType c ) ( ChatPreviewData c )
2025-04-23 14:15:17 +00:00
type ChatStatsRow = ( Int , ChatItemId , BoolInt )
2023-12-11 15:50:32 +02:00
2023-12-13 15:32:23 +04:00
toChatStats :: ChatStatsRow -> ChatStats
2025-04-23 14:15:17 +00:00
toChatStats ( unreadCount , minUnreadItemId , BI unreadChat ) =
2025-05-09 15:36:06 +00:00
ChatStats { unreadCount , unreadMentions = 0 , reportsCount = 0 , minUnreadItemId , unreadChat }
2025-01-30 17:59:21 +00:00
2025-05-09 15:36:06 +00:00
type GroupStatsRow = ( Int , Int , Int , ChatItemId , BoolInt )
2025-01-30 17:59:21 +00:00
toGroupStats :: GroupStatsRow -> ChatStats
2025-05-09 15:36:06 +00:00
toGroupStats ( unreadCount , unreadMentions , reportsCount , minUnreadItemId , BI unreadChat ) =
ChatStats { unreadCount , unreadMentions , reportsCount , minUnreadItemId , unreadChat }
2023-12-11 15:50:32 +02:00
findDirectChatPreviews_ :: DB . Connection -> User -> PaginationByTime -> ChatListQuery -> IO [ AChatPreviewData ]
findDirectChatPreviews_ db User { userId } pagination clq =
map toPreview <$> getPreviews
where
2023-12-13 15:32:23 +04:00
toPreview :: ( ContactId , UTCTime , Maybe ChatItemId ) :. ChatStatsRow -> AChatPreviewData
toPreview ( ( contactId , ts , lastItemId_ ) :. statsRow ) =
ACPD SCTDirect $ DirectChatPD ts contactId lastItemId_ ( toChatStats statsRow )
baseQuery =
[ sql |
2025-01-10 15:27:29 +04:00
SELECT
ct . contact_id ,
ct . chat_ts ,
(
SELECT chat_item_id
FROM chat_items ci
WHERE ci . user_id = ? AND ci . contact_id = ct . contact_id
ORDER BY ci . created_at DESC
LIMIT 1
) AS chat_item_id ,
COALESCE ( ChatStats . UnreadCount , 0 ) ,
COALESCE ( ChatStats . MinUnread , 0 ) ,
ct . unread_chat
2023-12-13 15:32:23 +04:00
FROM contacts ct
LEFT JOIN (
SELECT contact_id , COUNT ( 1 ) AS UnreadCount , MIN ( chat_item_id ) AS MinUnread
FROM chat_items
2025-01-08 09:42:26 +00:00
WHERE user_id = ? AND contact_id IS NOT NULL AND item_status = ?
2023-12-13 15:32:23 +04:00
GROUP BY contact_id
) ChatStats ON ChatStats . contact_id = ct . contact_id
| ]
2025-01-08 09:42:26 +00:00
baseParams = ( userId , userId , CISRcvNew )
2023-12-11 15:50:32 +02:00
getPreviews = case clq of
2025-01-08 09:42:26 +00:00
CLQFilters { favorite = False , unread = False } -> do
2025-01-10 15:27:29 +04:00
let q = baseQuery <> " WHERE ct.user_id = ? AND ct.is_user = 0 AND ct.deleted = 0 AND ct.contact_used = 1 "
2025-01-08 09:42:26 +00:00
p = baseParams :. Only userId
2025-01-10 15:27:29 +04:00
queryWithPagination q p
2025-01-08 09:42:26 +00:00
CLQFilters { favorite = True , unread = False } -> do
let q =
baseQuery
2025-01-10 15:27:29 +04:00
<> " "
2025-01-08 09:42:26 +00:00
<> [ sql |
2025-01-10 15:27:29 +04:00
WHERE ct . user_id = ? AND ct . is_user = 0 AND ct . deleted = 0 AND ct . contact_used = 1
2025-01-08 09:42:26 +00:00
AND ct . favorite = 1
2025-01-10 15:27:29 +04:00
| ]
2025-01-08 09:42:26 +00:00
p = baseParams :. Only userId
2025-01-10 15:27:29 +04:00
queryWithPagination q p
2025-01-08 09:42:26 +00:00
CLQFilters { favorite = False , unread = True } -> do
let q =
baseQuery
2025-01-10 15:27:29 +04:00
<> " "
2025-01-08 09:42:26 +00:00
<> [ sql |
2025-01-10 15:27:29 +04:00
WHERE ct . user_id = ? AND ct . is_user = 0 AND ct . deleted = 0 AND ct . contact_used = 1
2025-01-08 09:42:26 +00:00
AND ( ct . unread_chat = 1 OR ChatStats . UnreadCount > 0 )
2025-01-10 15:27:29 +04:00
| ]
2025-01-08 09:42:26 +00:00
p = baseParams :. Only userId
2025-01-10 15:27:29 +04:00
queryWithPagination q p
2025-01-08 09:42:26 +00:00
CLQFilters { favorite = True , unread = True } -> do
let q =
baseQuery
2025-01-10 15:27:29 +04:00
<> " "
2025-01-08 09:42:26 +00:00
<> [ sql |
2025-01-10 15:27:29 +04:00
WHERE ct . user_id = ? AND ct . is_user = 0 AND ct . deleted = 0 AND ct . contact_used = 1
2025-01-08 09:42:26 +00:00
AND ( ct . favorite = 1
OR ct . unread_chat = 1 OR ChatStats . UnreadCount > 0 )
2025-01-10 15:27:29 +04:00
| ]
2025-01-08 09:42:26 +00:00
p = baseParams :. Only userId
2025-01-10 15:27:29 +04:00
queryWithPagination q p
2025-01-08 09:42:26 +00:00
CLQSearch { search } -> do
let q =
baseQuery
2025-01-10 15:27:29 +04:00
<> " "
2025-01-08 09:42:26 +00:00
<> [ sql |
JOIN contact_profiles cp ON ct . contact_profile_id = cp . contact_profile_id
2025-01-10 15:27:29 +04:00
WHERE ct . user_id = ? AND ct . is_user = 0 AND ct . deleted = 0 AND ct . contact_used = 1
2025-01-08 09:42:26 +00:00
AND (
2025-01-10 15:27:29 +04:00
LOWER ( ct . local_display_name ) LIKE '%' || LOWER ( ? ) || '%'
OR LOWER ( cp . display_name ) LIKE '%' || LOWER ( ? ) || '%'
OR LOWER ( cp . full_name ) LIKE '%' || LOWER ( ? ) || '%'
OR LOWER ( cp . local_alias ) LIKE '%' || LOWER ( ? ) || '%'
2025-01-08 09:42:26 +00:00
)
2025-01-10 15:27:29 +04:00
| ]
2025-01-08 09:42:26 +00:00
p = baseParams :. ( userId , search , search , search , search )
2025-01-10 15:27:29 +04:00
queryWithPagination q p
queryWithPagination :: ToRow p => Query -> p -> IO [ ( ContactId , UTCTime , Maybe ChatItemId ) :. ChatStatsRow ]
queryWithPagination query params = case pagination of
PTLast count -> DB . query db ( query <> " ORDER BY ct.chat_ts DESC LIMIT ? " ) ( params :. Only count )
PTAfter ts count -> DB . query db ( query <> " AND ct.chat_ts > ? ORDER BY ct.chat_ts ASC LIMIT ? " ) ( params :. ( ts , count ) )
PTBefore ts count -> DB . query db ( query <> " AND ct.chat_ts < ? ORDER BY ct.chat_ts DESC LIMIT ? " ) ( params :. ( ts , count ) )
2023-12-11 15:50:32 +02:00
2024-04-22 20:46:48 +04:00
getDirectChatPreview_ :: DB . Connection -> VersionRangeChat -> User -> ChatPreviewData 'CTDirect -> ExceptT StoreError IO AChat
2024-03-10 20:52:29 +00:00
getDirectChatPreview_ db vr user ( DirectChatPD _ contactId lastItemId_ stats ) = do
contact <- getContact db vr user contactId
2023-12-13 15:32:23 +04:00
lastItem <- case lastItemId_ of
Just lastItemId -> ( : [] ) <$> getDirectChatItem db user contactId lastItemId
Nothing -> pure []
2023-12-11 15:50:32 +02:00
pure $ AChat SCTDirect ( Chat ( DirectChat contact ) lastItem stats )
findGroupChatPreviews_ :: DB . Connection -> User -> PaginationByTime -> ChatListQuery -> IO [ AChatPreviewData ]
findGroupChatPreviews_ db User { userId } pagination clq =
map toPreview <$> getPreviews
2023-06-18 10:20:11 +01:00
where
2025-01-30 17:59:21 +00:00
toPreview :: ( GroupId , UTCTime , Maybe ChatItemId ) :. GroupStatsRow -> AChatPreviewData
2023-12-13 15:32:23 +04:00
toPreview ( ( groupId , ts , lastItemId_ ) :. statsRow ) =
2025-01-30 17:59:21 +00:00
ACPD SCTGroup $ GroupChatPD ts groupId lastItemId_ ( toGroupStats statsRow )
2023-12-13 15:32:23 +04:00
baseQuery =
[ sql |
2025-01-10 15:27:29 +04:00
SELECT
g . group_id ,
g . chat_ts ,
(
SELECT chat_item_id
FROM chat_items ci
2025-04-21 15:17:21 +00:00
WHERE ci . user_id = ? AND ci . group_id = g . group_id AND ci . group_scope_tag IS NULL
2025-01-10 15:27:29 +04:00
ORDER BY ci . item_ts DESC
LIMIT 1
) AS chat_item_id ,
COALESCE ( ChatStats . UnreadCount , 0 ) ,
2025-01-30 17:59:21 +00:00
COALESCE ( ChatStats . UnreadMentions , 0 ) ,
2025-01-10 15:27:29 +04:00
COALESCE ( ReportCount . Count , 0 ) ,
COALESCE ( ChatStats . MinUnread , 0 ) ,
g . unread_chat
2023-12-13 15:32:23 +04:00
FROM groups g
LEFT JOIN (
2025-01-30 17:59:21 +00:00
SELECT group_id , COUNT ( 1 ) AS UnreadCount , SUM ( user_mention ) as UnreadMentions , MIN ( chat_item_id ) AS MinUnread
2023-12-13 15:32:23 +04:00
FROM chat_items
2025-04-23 14:15:17 +00:00
WHERE user_id = ? AND group_id IS NOT NULL AND group_scope_tag IS NULL AND item_status = ?
2023-12-13 15:32:23 +04:00
GROUP BY group_id
) ChatStats ON ChatStats . group_id = g . group_id
2025-01-08 09:42:26 +00:00
LEFT JOIN (
SELECT group_id , COUNT ( 1 ) AS Count
FROM chat_items
WHERE user_id = ? AND group_id IS NOT NULL
AND msg_content_tag = ? AND item_deleted = ? AND item_sent = 0
GROUP BY group_id
) ReportCount ON ReportCount . group_id = g . group_id
2023-12-13 15:32:23 +04:00
| ]
2025-05-09 15:36:06 +00:00
baseParams = ( userId , userId , CISRcvNew , userId , MCReport_ , BI False )
2023-12-11 15:50:32 +02:00
getPreviews = case clq of
2025-01-08 09:42:26 +00:00
CLQFilters { favorite = False , unread = False } -> do
let q = baseQuery <> " WHERE g.user_id = ? "
p = baseParams :. Only userId
2025-01-10 15:27:29 +04:00
queryWithPagination q p
2025-01-08 09:42:26 +00:00
CLQFilters { favorite = True , unread = False } -> do
let q =
baseQuery
2025-01-10 15:27:29 +04:00
<> " "
2025-01-08 09:42:26 +00:00
<> [ sql |
WHERE g . user_id = ?
AND g . favorite = 1
2025-01-10 15:27:29 +04:00
| ]
2025-01-08 09:42:26 +00:00
p = baseParams :. Only userId
2025-01-10 15:27:29 +04:00
queryWithPagination q p
2025-01-08 09:42:26 +00:00
CLQFilters { favorite = False , unread = True } -> do
let q =
baseQuery
2025-01-10 15:27:29 +04:00
<> " "
2025-01-08 09:42:26 +00:00
<> [ sql |
WHERE g . user_id = ?
AND ( g . unread_chat = 1 OR ChatStats . UnreadCount > 0 )
2025-01-10 15:27:29 +04:00
| ]
2025-01-08 09:42:26 +00:00
p = baseParams :. Only userId
2025-01-10 15:27:29 +04:00
queryWithPagination q p
2025-01-08 09:42:26 +00:00
CLQFilters { favorite = True , unread = True } -> do
let q =
baseQuery
2025-01-10 15:27:29 +04:00
<> " "
2025-01-08 09:42:26 +00:00
<> [ sql |
WHERE g . user_id = ?
AND ( g . favorite = 1
OR g . unread_chat = 1 OR ChatStats . UnreadCount > 0 )
2025-01-10 15:27:29 +04:00
| ]
2025-01-08 09:42:26 +00:00
p = baseParams :. Only userId
2025-01-10 15:27:29 +04:00
queryWithPagination q p
2025-01-08 09:42:26 +00:00
CLQSearch { search } -> do
let q =
baseQuery
2025-01-10 15:27:29 +04:00
<> " "
2025-01-08 09:42:26 +00:00
<> [ sql |
JOIN group_profiles gp ON gp . group_profile_id = g . group_profile_id
WHERE g . user_id = ?
AND (
2025-01-10 15:27:29 +04:00
LOWER ( g . local_display_name ) LIKE '%' || LOWER ( ? ) || '%'
OR LOWER ( gp . display_name ) LIKE '%' || LOWER ( ? ) || '%'
OR LOWER ( gp . full_name ) LIKE '%' || LOWER ( ? ) || '%'
OR LOWER ( gp . description ) LIKE '%' || LOWER ( ? ) || '%'
2025-01-08 09:42:26 +00:00
)
2025-01-10 15:27:29 +04:00
| ]
2025-01-08 09:42:26 +00:00
p = baseParams :. ( userId , search , search , search , search )
2025-01-10 15:27:29 +04:00
queryWithPagination q p
2025-01-30 17:59:21 +00:00
queryWithPagination :: ToRow p => Query -> p -> IO [ ( GroupId , UTCTime , Maybe ChatItemId ) :. GroupStatsRow ]
2025-01-10 15:27:29 +04:00
queryWithPagination query params = case pagination of
PTLast count -> DB . query db ( query <> " ORDER BY g.chat_ts DESC LIMIT ? " ) ( params :. Only count )
PTAfter ts count -> DB . query db ( query <> " AND g.chat_ts > ? ORDER BY g.chat_ts ASC LIMIT ? " ) ( params :. ( ts , count ) )
PTBefore ts count -> DB . query db ( query <> " AND g.chat_ts < ? ORDER BY g.chat_ts DESC LIMIT ? " ) ( params :. ( ts , count ) )
2023-12-11 15:50:32 +02:00
2024-04-22 20:46:48 +04:00
getGroupChatPreview_ :: DB . Connection -> VersionRangeChat -> User -> ChatPreviewData 'CTGroup -> ExceptT StoreError IO AChat
2023-12-24 13:27:51 +00:00
getGroupChatPreview_ db vr user ( GroupChatPD _ groupId lastItemId_ stats ) = do
groupInfo <- getGroupInfo db vr user groupId
2023-12-13 15:32:23 +04:00
lastItem <- case lastItemId_ of
2025-01-29 13:04:48 +00:00
Just lastItemId -> ( : [] ) <$> getGroupCIWithReactions db user groupInfo lastItemId
2023-12-13 15:32:23 +04:00
Nothing -> pure []
2025-04-02 07:57:18 +00:00
pure $ AChat SCTGroup ( Chat ( GroupChat groupInfo Nothing ) lastItem stats )
2023-12-11 15:50:32 +02:00
2024-01-11 19:01:44 +02:00
findLocalChatPreviews_ :: DB . Connection -> User -> PaginationByTime -> ChatListQuery -> IO [ AChatPreviewData ]
findLocalChatPreviews_ db User { userId } pagination clq =
map toPreview <$> getPreviews
where
toPreview :: ( NoteFolderId , UTCTime , Maybe ChatItemId ) :. ChatStatsRow -> AChatPreviewData
toPreview ( ( noteFolderId , ts , lastItemId_ ) :. statsRow ) =
ACPD SCTLocal $ LocalChatPD ts noteFolderId lastItemId_ ( toChatStats statsRow )
baseQuery =
[ sql |
2025-01-10 15:27:29 +04:00
SELECT
nf . note_folder_id ,
nf . chat_ts ,
(
SELECT chat_item_id
FROM chat_items ci
WHERE ci . user_id = ? AND ci . note_folder_id = nf . note_folder_id
ORDER BY ci . created_at DESC
LIMIT 1
) AS chat_item_id ,
COALESCE ( ChatStats . UnreadCount , 0 ) ,
COALESCE ( ChatStats . MinUnread , 0 ) ,
nf . unread_chat
2024-01-11 19:01:44 +02:00
FROM note_folders nf
LEFT JOIN (
SELECT note_folder_id , COUNT ( 1 ) AS UnreadCount , MIN ( chat_item_id ) AS MinUnread
FROM chat_items
2025-01-08 09:42:26 +00:00
WHERE user_id = ? AND note_folder_id IS NOT NULL AND item_status = ?
2024-01-11 19:01:44 +02:00
GROUP BY note_folder_id
) ChatStats ON ChatStats . note_folder_id = nf . note_folder_id
| ]
2025-01-08 09:42:26 +00:00
baseParams = ( userId , userId , CISRcvNew )
2024-01-11 19:01:44 +02:00
getPreviews = case clq of
2025-01-08 09:42:26 +00:00
CLQFilters { favorite = False , unread = False } -> do
let q = baseQuery <> " WHERE nf.user_id = ? "
p = baseParams :. Only userId
2025-01-10 15:27:29 +04:00
queryWithPagination q p
2025-01-08 09:42:26 +00:00
CLQFilters { favorite = True , unread = False } -> do
let q =
baseQuery
2025-01-10 15:27:29 +04:00
<> " "
2025-01-08 09:42:26 +00:00
<> [ sql |
WHERE nf . user_id = ?
AND nf . favorite = 1
2025-01-10 15:27:29 +04:00
| ]
2025-01-08 09:42:26 +00:00
p = baseParams :. Only userId
2025-01-10 15:27:29 +04:00
queryWithPagination q p
2025-01-08 09:42:26 +00:00
CLQFilters { favorite = False , unread = True } -> do
let q =
baseQuery
2025-01-10 15:27:29 +04:00
<> " "
2025-01-08 09:42:26 +00:00
<> [ sql |
WHERE nf . user_id = ?
AND ( nf . unread_chat = 1 OR ChatStats . UnreadCount > 0 )
2025-01-10 15:27:29 +04:00
| ]
2025-01-08 09:42:26 +00:00
p = baseParams :. Only userId
2025-01-10 15:27:29 +04:00
queryWithPagination q p
2025-01-08 09:42:26 +00:00
CLQFilters { favorite = True , unread = True } -> do
let q =
baseQuery
2025-01-10 15:27:29 +04:00
<> " "
2025-01-08 09:42:26 +00:00
<> [ sql |
WHERE nf . user_id = ?
AND ( nf . favorite = 1
OR nf . unread_chat = 1 OR ChatStats . UnreadCount > 0 )
2025-01-10 15:27:29 +04:00
| ]
2025-01-08 09:42:26 +00:00
p = baseParams :. Only userId
2025-01-10 15:27:29 +04:00
queryWithPagination q p
2024-01-11 19:01:44 +02:00
CLQSearch { } -> pure []
2025-01-10 15:27:29 +04:00
queryWithPagination :: ToRow p => Query -> p -> IO [ ( NoteFolderId , UTCTime , Maybe ChatItemId ) :. ChatStatsRow ]
queryWithPagination query params = case pagination of
PTLast count -> DB . query db ( query <> " ORDER BY nf.chat_ts DESC LIMIT ? " ) ( params :. Only count )
PTAfter ts count -> DB . query db ( query <> " AND nf.chat_ts > ? ORDER BY nf.chat_ts ASC LIMIT ? " ) ( params :. ( ts , count ) )
PTBefore ts count -> DB . query db ( query <> " AND nf.chat_ts < ? ORDER BY nf.chat_ts DESC LIMIT ? " ) ( params :. ( ts , count ) )
2024-01-11 19:01:44 +02:00
getLocalChatPreview_ :: DB . Connection -> User -> ChatPreviewData 'CTLocal -> ExceptT StoreError IO AChat
getLocalChatPreview_ db user ( LocalChatPD _ noteFolderId lastItemId_ stats ) = do
nf <- getNoteFolder db user noteFolderId
lastItem <- case lastItemId_ of
Just lastItemId -> ( : [] ) <$> getLocalChatItem db user noteFolderId lastItemId
Nothing -> pure []
pure $ AChat SCTLocal ( Chat ( LocalChat nf ) lastItem stats )
-- this function can be changed so it never fails, not only avoid failure on invalid json
toLocalChatItem :: UTCTime -> ChatItemRow -> Either StoreError ( CChatItem 'CTLocal )
2025-01-29 13:04:48 +00:00
toLocalChatItem currentTs ( ( itemId , itemTs , AMsgDirection msgDir , itemContentText , itemText , itemStatus , sentViaProxy , sharedMsgId ) :. ( itemDeleted , deletedTs , itemEdited , createdAt , updatedAt ) :. forwardedFromRow :. ( timedTTL , timedDeleteAt , itemLive , BI userMention ) :. ( fileId_ , fileName_ , fileSize_ , filePath , fileKey , fileNonce , fileStatus_ , fileProtocol_ ) ) =
2024-01-11 19:01:44 +02:00
chatItem $ fromRight invalid $ dbParseACIContent itemContentText
where
invalid = ACIContent msgDir $ CIInvalidJSON itemContentText
chatItem itemContent = case ( itemContent , itemStatus , fileStatus_ ) of
( ACIContent SMDSnd ciContent , ACIStatus SMDSnd ciStatus , Just ( AFS SMDSnd fileStatus ) ) ->
Right $ cItem SMDSnd CILocalSnd ciStatus ciContent ( maybeCIFile fileStatus )
( ACIContent SMDSnd ciContent , ACIStatus SMDSnd ciStatus , Nothing ) ->
Right $ cItem SMDSnd CILocalSnd ciStatus ciContent Nothing
( ACIContent SMDRcv ciContent , ACIStatus SMDRcv ciStatus , Just ( AFS SMDRcv fileStatus ) ) ->
Right $ cItem SMDRcv CILocalRcv ciStatus ciContent ( maybeCIFile fileStatus )
( ACIContent SMDRcv ciContent , ACIStatus SMDRcv ciStatus , Nothing ) ->
Right $ cItem SMDRcv CILocalRcv ciStatus ciContent Nothing
_ -> badItem
maybeCIFile :: CIFileStatus d -> Maybe ( CIFile d )
maybeCIFile fileStatus =
case ( fileId_ , fileName_ , fileSize_ , fileProtocol_ ) of
( Just fileId , Just fileName , Just fileSize , Just fileProtocol ) ->
let cfArgs = CFArgs <$> fileKey <*> fileNonce
fileSource = ( ` CryptoFile ` cfArgs ) <$> filePath
in Just CIFile { fileId , fileName , fileSize , fileSource , fileStatus , fileProtocol }
_ -> Nothing
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTLocal d -> CIStatus d -> CIContent d -> Maybe ( CIFile d ) -> CChatItem 'CTLocal
cItem d chatDir ciStatus content file =
2025-01-29 13:04:48 +00:00
CChatItem d ChatItem { chatDir , meta = ciMeta content ciStatus , content , mentions = M . empty , formattedText = parseMaybeMarkdownList itemText , quotedItem = Nothing , reactions = [] , file }
2024-02-19 15:17:14 +04:00
badItem = Left $ SEBadChatItem itemId ( Just itemTs )
2024-01-11 19:01:44 +02:00
ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTLocal d
ciMeta content status =
let itemDeleted' = case itemDeleted of
DBCINotDeleted -> Nothing
2024-05-24 21:09:21 +01:00
_ -> Just ( CIDeleted @ 'CTLocal deletedTs )
2025-01-10 15:27:29 +04:00
itemEdited' = maybe False unBI itemEdited
2024-04-09 13:02:59 +01:00
itemForwarded = toCIForwardedFrom forwardedFromRow
2025-06-23 14:42:00 +01:00
in mkCIMeta itemId content itemText status ( unBI <$> sentViaProxy ) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed ( unBI <$> itemLive ) userMention currentTs itemTs Nothing False createdAt updatedAt
2024-01-11 19:01:44 +02:00
ciTimed :: Maybe CITimed
ciTimed = timedTTL >>= \ ttl -> Just CITimed { ttl , deleteAt = timedDeleteAt }
2023-12-11 15:50:32 +02:00
getContactRequestChatPreviews_ :: DB . Connection -> User -> PaginationByTime -> ChatListQuery -> IO [ AChatPreviewData ]
getContactRequestChatPreviews_ db User { userId } pagination clq = case clq of
2025-01-08 09:42:26 +00:00
CLQFilters { favorite = False , unread = False } -> map toPreview <$> getPreviews " "
2023-12-11 15:50:32 +02:00
CLQFilters { favorite = True , unread = False } -> pure []
2025-01-08 09:42:26 +00:00
CLQFilters { favorite = False , unread = True } -> map toPreview <$> getPreviews " "
CLQFilters { favorite = True , unread = True } -> map toPreview <$> getPreviews " "
CLQSearch { search } -> map toPreview <$> getPreviews search
2023-06-18 10:20:11 +01:00
where
2025-01-08 09:42:26 +00:00
query =
[ sql |
SELECT
cr . contact_request_id , cr . local_display_name , cr . agent_invitation_id , cr . contact_id , cr . user_contact_link_id ,
c . agent_conn_id , cr . contact_profile_id , p . display_name , p . full_name , p . image , p . contact_link , cr . xcontact_id , cr . pq_support , p . preferences ,
2025-01-10 15:27:29 +04:00
cr . created_at , cr . updated_at ,
2025-01-08 09:42:26 +00:00
cr . peer_chat_min_version , cr . peer_chat_max_version
FROM contact_requests cr
JOIN connections c ON c . user_contact_link_id = cr . user_contact_link_id
JOIN contact_profiles p ON p . contact_profile_id = cr . contact_profile_id
JOIN user_contact_links uc ON uc . user_contact_link_id = cr . user_contact_link_id
WHERE cr . user_id = ?
AND uc . user_id = ?
AND uc . local_display_name = ' '
AND uc . group_id IS NULL
2025-06-09 16:18:01 +00:00
AND cr . contact_id IS NULL
2025-01-08 09:42:26 +00:00
AND (
2025-01-10 15:27:29 +04:00
LOWER ( cr . local_display_name ) LIKE '%' || LOWER ( ? ) || '%'
OR LOWER ( p . display_name ) LIKE '%' || LOWER ( ? ) || '%'
OR LOWER ( p . full_name ) LIKE '%' || LOWER ( ? ) || '%'
2023-12-11 15:50:32 +02:00
)
2025-01-08 09:42:26 +00:00
| ]
params search = ( userId , userId , search , search , search )
getPreviews search = case pagination of
2025-01-10 15:27:29 +04:00
PTLast count -> DB . query db ( query <> " ORDER BY cr.updated_at DESC LIMIT ? " ) ( params search :. Only count )
PTAfter ts count -> DB . query db ( query <> " AND cr.updated_at > ? ORDER BY cr.updated_at ASC LIMIT ? " ) ( params search :. ( ts , count ) )
PTBefore ts count -> DB . query db ( query <> " AND cr.updated_at < ? ORDER BY cr.updated_at DESC LIMIT ? " ) ( params search :. ( ts , count ) )
2023-12-11 15:50:32 +02:00
toPreview :: ContactRequestRow -> AChatPreviewData
toPreview cReqRow =
let cReq @ UserContactRequest { updatedAt } = toContactRequest cReqRow
2025-01-08 09:42:26 +00:00
aChat = AChat SCTContactRequest $ Chat ( ContactRequest cReq ) [] emptyChatStats
2023-12-11 15:50:32 +02:00
in ACPD SCTContactRequest $ ContactRequestPD updatedAt aChat
getContactConnectionChatPreviews_ :: DB . Connection -> User -> PaginationByTime -> ChatListQuery -> IO [ AChatPreviewData ]
getContactConnectionChatPreviews_ db User { userId } pagination clq = case clq of
2025-01-08 09:42:26 +00:00
CLQFilters { favorite = False , unread = False } -> map toPreview <$> getPreviews " "
2023-12-11 15:50:32 +02:00
CLQFilters { favorite = True , unread = False } -> pure []
CLQFilters { favorite = False , unread = True } -> pure []
CLQFilters { favorite = True , unread = True } -> pure []
2025-01-08 09:42:26 +00:00
CLQSearch { search } -> map toPreview <$> getPreviews search
2023-06-18 10:20:11 +01:00
where
2025-01-08 09:42:26 +00:00
query =
[ sql |
SELECT
connection_id , agent_conn_id , conn_status , via_contact_uri_hash , via_user_contact_link , group_link_id ,
2025-04-14 21:25:32 +01:00
custom_user_profile_id , conn_req_inv , short_link_inv , local_alias , created_at , updated_at
2025-01-08 09:42:26 +00:00
FROM connections
WHERE user_id = ?
AND conn_type = ?
AND conn_status != ?
AND contact_id IS NULL
AND conn_level = 0
AND via_contact IS NULL
2025-01-10 15:27:29 +04:00
AND ( via_group_link = 0 OR ( via_group_link = 1 AND group_link_id IS NOT NULL ) )
AND LOWER ( local_alias ) LIKE '%' || LOWER ( ? ) || '%'
2025-01-08 09:42:26 +00:00
| ]
params search = ( userId , ConnContact , ConnPrepared , search )
getPreviews search = case pagination of
2025-01-10 15:27:29 +04:00
PTLast count -> DB . query db ( query <> " ORDER BY updated_at DESC LIMIT ? " ) ( params search :. Only count )
PTAfter ts count -> DB . query db ( query <> " AND updated_at > ? ORDER BY updated_at ASC LIMIT ? " ) ( params search :. ( ts , count ) )
PTBefore ts count -> DB . query db ( query <> " AND updated_at < ? ORDER BY updated_at DESC LIMIT ? " ) ( params search :. ( ts , count ) )
2025-04-14 21:25:32 +01:00
toPreview :: ( Int64 , ConnId , ConnStatus , Maybe ByteString , Maybe Int64 , Maybe GroupLinkId , Maybe Int64 , Maybe ConnReqInvitation , Maybe ( ConnShortLink 'CMInvitation ) , LocalAlias , UTCTime , UTCTime ) -> AChatPreviewData
2023-12-11 15:50:32 +02:00
toPreview connRow =
let conn @ PendingContactConnection { updatedAt } = toPendingContactConnection connRow
2025-01-08 09:42:26 +00:00
aChat = AChat SCTContactConnection $ Chat ( ContactConnection conn ) [] emptyChatStats
2023-12-11 15:50:32 +02:00
in ACPD SCTContactConnection $ ContactConnectionPD updatedAt aChat
2023-06-18 10:20:11 +01:00
2024-11-14 08:34:25 +00:00
getDirectChat :: DB . Connection -> VersionRangeChat -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO ( Chat 'CTDirect , Maybe NavigationInfo )
2024-03-10 20:52:29 +00:00
getDirectChat db vr user contactId pagination search_ = do
2023-06-18 10:20:11 +01:00
let search = fromMaybe " " search_
2024-03-10 20:52:29 +00:00
ct <- getContact db vr user contactId
2024-11-14 08:34:25 +00:00
case pagination of
CPLast count -> liftIO $ ( , Nothing ) <$> getDirectChatLast_ db user ct count search
CPAfter afterId count -> ( , Nothing ) <$> getDirectChatAfter_ db user ct afterId count search
CPBefore beforeId count -> ( , Nothing ) <$> getDirectChatBefore_ db user ct beforeId count search
CPAround aroundId count -> getDirectChatAround_ db user ct aroundId count search
CPInitial count -> do
unless ( null search ) $ throwError $ SEInternalError " initial chat pagination doesn't support search "
getDirectChatInitial_ db user ct count
2023-06-18 10:20:11 +01:00
-- the last items in reverse order (the last item in the conversation is the first in the returned list)
2024-02-19 15:17:14 +04:00
getDirectChatLast_ :: DB . Connection -> User -> Contact -> Int -> String -> IO ( Chat 'CTDirect )
2024-11-14 08:34:25 +00:00
getDirectChatLast_ db user ct count search = do
ciIds <- getDirectChatItemIdsLast_ db user ct count search
ts <- getCurrentTime
cis <- mapM ( safeGetDirectItem db user ct ts ) ciIds
2025-01-08 09:42:26 +00:00
pure $ Chat ( DirectChat ct ) ( reverse cis ) emptyChatStats
2024-11-14 08:34:25 +00:00
getDirectChatItemIdsLast_ :: DB . Connection -> User -> Contact -> Int -> String -> IO [ ChatItemId ]
getDirectChatItemIdsLast_ db User { userId } Contact { contactId } count search =
map fromOnly
<$> DB . query
db
[ sql |
SELECT chat_item_id
FROM chat_items
2025-01-10 15:27:29 +04:00
WHERE user_id = ? AND contact_id = ? AND LOWER ( item_text ) LIKE '%' || LOWER ( ? ) || '%'
2024-11-14 08:34:25 +00:00
ORDER BY created_at DESC , chat_item_id DESC
LIMIT ?
| ]
( userId , contactId , search , count )
2024-02-19 15:17:14 +04:00
safeGetDirectItem :: DB . Connection -> User -> Contact -> UTCTime -> ChatItemId -> IO ( CChatItem 'CTDirect )
safeGetDirectItem db user ct currentTs itemId =
runExceptT ( getDirectCIWithReactions db user ct itemId )
>>= pure <$> safeToDirectItem currentTs itemId
safeToDirectItem :: UTCTime -> ChatItemId -> Either StoreError ( CChatItem 'CTDirect ) -> CChatItem 'CTDirect
safeToDirectItem currentTs itemId = \ case
Right ci -> ci
Left e @ ( SEBadChatItem _ ( Just itemTs ) ) -> badDirectItem itemTs e
Left e -> badDirectItem currentTs e
where
badDirectItem :: UTCTime -> StoreError -> CChatItem 'CTDirect
badDirectItem ts e =
let errorText = T . pack $ show e
in CChatItem
SMDSnd
ChatItem
{ chatDir = CIDirectSnd ,
meta = dummyMeta itemId ts errorText ,
content = CIInvalidJSON errorText ,
2025-01-29 13:04:48 +00:00
mentions = M . empty ,
2024-02-19 15:17:14 +04:00
formattedText = Nothing ,
quotedItem = Nothing ,
reactions = [] ,
file = Nothing
}
getDirectChatItemLast :: DB . Connection -> User -> ContactId -> ExceptT StoreError IO ( CChatItem 'CTDirect )
getDirectChatItemLast db user @ User { userId } contactId = do
chatItemId <-
ExceptT . firstRow fromOnly ( SEChatItemNotFoundByContactId contactId ) $
DB . query
db
[ sql |
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND contact_id = ?
ORDER BY created_at DESC , chat_item_id DESC
LIMIT 1
| ]
( userId , contactId )
getDirectChatItem db user contactId chatItemId
2023-06-18 10:20:11 +01:00
2024-11-14 08:34:25 +00:00
getDirectChatAfter_ :: DB . Connection -> User -> Contact -> ChatItemId -> Int -> String -> ExceptT StoreError IO ( Chat 'CTDirect )
getDirectChatAfter_ db user ct @ Contact { contactId } afterId count search = do
afterCI <- getDirectChatItem db user contactId afterId
ciIds <- liftIO $ getDirectCIsAfter_ db user ct afterCI count search
ts <- liftIO getCurrentTime
cis <- liftIO $ mapM ( safeGetDirectItem db user ct ts ) ciIds
2025-01-08 09:42:26 +00:00
pure $ Chat ( DirectChat ct ) cis emptyChatStats
2024-11-14 08:34:25 +00:00
getDirectCIsAfter_ :: DB . Connection -> User -> Contact -> CChatItem 'CTDirect -> Int -> String -> IO [ ChatItemId ]
getDirectCIsAfter_ db User { userId } Contact { contactId } afterCI count search =
map fromOnly
<$> DB . query
db
[ sql |
SELECT chat_item_id
FROM chat_items
2025-01-10 15:27:29 +04:00
WHERE user_id = ? AND contact_id = ? AND LOWER ( item_text ) LIKE '%' || LOWER ( ? ) || '%'
2024-11-14 08:34:25 +00:00
AND ( created_at > ? OR ( created_at = ? AND chat_item_id > ? ) )
ORDER BY created_at ASC , chat_item_id ASC
LIMIT ?
| ]
( userId , contactId , search , ciCreatedAt afterCI , ciCreatedAt afterCI , cChatItemId afterCI , count )
getDirectChatBefore_ :: DB . Connection -> User -> Contact -> ChatItemId -> Int -> String -> ExceptT StoreError IO ( Chat 'CTDirect )
getDirectChatBefore_ db user ct @ Contact { contactId } beforeId count search = do
beforeCI <- getDirectChatItem db user contactId beforeId
ciIds <- liftIO $ getDirectCIsBefore_ db user ct beforeCI count search
ts <- liftIO getCurrentTime
cis <- liftIO $ mapM ( safeGetDirectItem db user ct ts ) ciIds
2025-01-08 09:42:26 +00:00
pure $ Chat ( DirectChat ct ) ( reverse cis ) emptyChatStats
2024-11-14 08:34:25 +00:00
getDirectCIsBefore_ :: DB . Connection -> User -> Contact -> CChatItem 'CTDirect -> Int -> String -> IO [ ChatItemId ]
getDirectCIsBefore_ db User { userId } Contact { contactId } beforeCI count search =
map fromOnly
<$> DB . query
db
[ sql |
SELECT chat_item_id
FROM chat_items
2025-01-10 15:27:29 +04:00
WHERE user_id = ? AND contact_id = ? AND LOWER ( item_text ) LIKE '%' || LOWER ( ? ) || '%'
2024-11-14 08:34:25 +00:00
AND ( created_at < ? OR ( created_at = ? AND chat_item_id < ? ) )
ORDER BY created_at DESC , chat_item_id DESC
LIMIT ?
| ]
( userId , contactId , search , ciCreatedAt beforeCI , ciCreatedAt beforeCI , cChatItemId beforeCI , count )
getDirectChatAround_ :: DB . Connection -> User -> Contact -> ChatItemId -> Int -> String -> ExceptT StoreError IO ( Chat 'CTDirect , Maybe NavigationInfo )
getDirectChatAround_ db user ct aroundId count search = do
stats <- liftIO $ getContactStats_ db user ct
getDirectChatAround' db user ct aroundId count search stats
getDirectChatAround' :: DB . Connection -> User -> Contact -> ChatItemId -> Int -> String -> ChatStats -> ExceptT StoreError IO ( Chat 'CTDirect , Maybe NavigationInfo )
getDirectChatAround' db user ct @ Contact { contactId } aroundId count search stats = do
aroundCI <- getDirectChatItem db user contactId aroundId
beforeIds <- liftIO $ getDirectCIsBefore_ db user ct aroundCI count search
afterIds <- liftIO $ getDirectCIsAfter_ db user ct aroundCI count search
ts <- liftIO getCurrentTime
beforeCIs <- liftIO $ mapM ( safeGetDirectItem db user ct ts ) beforeIds
afterCIs <- liftIO $ mapM ( safeGetDirectItem db user ct ts ) afterIds
let cis = reverse beforeCIs <> [ aroundCI ] <> afterCIs
navInfo <- liftIO $ getNavInfo cis
pure ( Chat ( DirectChat ct ) cis stats , Just navInfo )
2023-06-18 10:20:11 +01:00
where
2024-11-14 08:34:25 +00:00
getNavInfo cis_ = case cis_ of
[] -> pure $ NavigationInfo 0 0
cis -> getContactNavInfo_ db user ct ( last cis )
getDirectChatInitial_ :: DB . Connection -> User -> Contact -> Int -> ExceptT StoreError IO ( Chat 'CTDirect , Maybe NavigationInfo )
getDirectChatInitial_ db user ct count = do
liftIO ( getContactMinUnreadId_ db user ct ) >>= \ case
Just minUnreadItemId -> do
unreadCount <- liftIO $ getContactUnreadCount_ db user ct
2025-01-08 09:42:26 +00:00
let stats = emptyChatStats { unreadCount , minUnreadItemId }
2024-11-14 08:34:25 +00:00
getDirectChatAround' db user ct minUnreadItemId count " " stats
Nothing -> liftIO $ ( , Just $ NavigationInfo 0 0 ) <$> getDirectChatLast_ db user ct count " "
getContactStats_ :: DB . Connection -> User -> Contact -> IO ChatStats
getContactStats_ db user ct = do
minUnreadItemId <- fromMaybe 0 <$> getContactMinUnreadId_ db user ct
unreadCount <- getContactUnreadCount_ db user ct
2025-01-08 09:42:26 +00:00
pure emptyChatStats { unreadCount , minUnreadItemId }
2024-11-14 08:34:25 +00:00
getContactMinUnreadId_ :: DB . Connection -> User -> Contact -> IO ( Maybe ChatItemId )
getContactMinUnreadId_ db User { userId } Contact { contactId } =
fmap join . maybeFirstRow fromOnly $
DB . query
db
[ sql |
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND contact_id = ? AND item_status = ?
ORDER BY created_at ASC , chat_item_id ASC
LIMIT 1
| ]
( userId , contactId , CISRcvNew )
getContactUnreadCount_ :: DB . Connection -> User -> Contact -> IO Int
getContactUnreadCount_ db User { userId } Contact { contactId } =
fromOnly . head
<$> DB . query
db
[ sql |
SELECT COUNT ( 1 )
FROM chat_items
WHERE user_id = ? AND contact_id = ? AND item_status = ?
| ]
( userId , contactId , CISRcvNew )
getContactNavInfo_ :: DB . Connection -> User -> Contact -> CChatItem 'CTDirect -> IO NavigationInfo
getContactNavInfo_ db User { userId } Contact { contactId } afterCI = do
afterUnread <- getAfterUnreadCount
afterTotal <- getAfterTotalCount
pure NavigationInfo { afterUnread , afterTotal }
where
getAfterUnreadCount :: IO Int
getAfterUnreadCount =
fromOnly . head
2025-01-08 09:42:26 +00:00
<$> DB . query
2023-06-18 10:20:11 +01:00
db
[ sql |
2024-11-14 08:34:25 +00:00
SELECT COUNT ( 1 )
2024-11-25 18:51:49 +04:00
FROM (
SELECT 1
FROM chat_items
2025-01-08 09:42:26 +00:00
WHERE user_id = ? AND contact_id = ? AND item_status = ?
AND created_at > ?
2024-11-25 18:51:49 +04:00
UNION ALL
SELECT 1
FROM chat_items
2025-01-08 09:42:26 +00:00
WHERE user_id = ? AND contact_id = ? AND item_status = ?
AND created_at = ? AND chat_item_id > ?
2025-01-10 15:27:29 +04:00
) ci
2023-06-18 10:20:11 +01:00
| ]
2025-01-08 09:42:26 +00:00
( ( userId , contactId , CISRcvNew , ciCreatedAt afterCI )
:. ( userId , contactId , CISRcvNew , ciCreatedAt afterCI , cChatItemId afterCI )
)
2024-11-14 08:34:25 +00:00
getAfterTotalCount :: IO Int
getAfterTotalCount =
fromOnly . head
2025-01-08 09:42:26 +00:00
<$> DB . query
2023-06-18 10:20:11 +01:00
db
[ sql |
2024-11-14 08:34:25 +00:00
SELECT COUNT ( 1 )
2024-11-25 18:51:49 +04:00
FROM (
SELECT 1
FROM chat_items
2025-01-08 09:42:26 +00:00
WHERE user_id = ? AND contact_id = ?
AND created_at > ?
2024-11-25 18:51:49 +04:00
UNION ALL
SELECT 1
FROM chat_items
2025-01-08 09:42:26 +00:00
WHERE user_id = ? AND contact_id = ?
AND created_at = ? AND chat_item_id > ?
2025-01-10 15:27:29 +04:00
) ci
2023-06-18 10:20:11 +01:00
| ]
2025-01-08 09:42:26 +00:00
( ( userId , contactId , ciCreatedAt afterCI )
:. ( userId , contactId , ciCreatedAt afterCI , cChatItemId afterCI )
)
2025-04-02 07:57:18 +00:00
getGroupChat :: DB . Connection -> VersionRangeChat -> User -> Int64 -> Maybe GroupChatScope -> Maybe MsgContentTag -> ChatPagination -> Maybe String -> ExceptT StoreError IO ( Chat 'CTGroup , Maybe NavigationInfo )
getGroupChat db vr user groupId scope_ contentFilter pagination search_ = do
2023-06-18 10:20:11 +01:00
let search = fromMaybe " " search_
2023-12-24 13:27:51 +00:00
g <- getGroupInfo db vr user groupId
2025-05-13 16:29:47 +00:00
scopeInfo <- mapM ( getCreateGroupChatScopeInfo db vr user g ) scope_
2023-10-18 10:19:24 +01:00
case pagination of
2025-04-02 07:57:18 +00:00
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
2024-11-14 08:34:25 +00:00
CPInitial count -> do
unless ( null search ) $ throwError $ SEInternalError " initial chat pagination doesn't support search "
2025-04-02 07:57:18 +00:00
getGroupChatInitial_ db user g scopeInfo contentFilter count
2025-05-13 16:29:47 +00:00
getCreateGroupChatScopeInfo :: DB . Connection -> VersionRangeChat -> User -> GroupInfo -> GroupChatScope -> ExceptT StoreError IO GroupChatScopeInfo
getCreateGroupChatScopeInfo db vr user GroupInfo { membership } = \ case
GCSMemberSupport Nothing -> do
when ( isNothing $ supportChat membership ) $ do
ts <- liftIO getCurrentTime
liftIO $ setSupportChatTs db ( groupMemberId' membership ) ts
pure $ GCSIMemberSupport { groupMember_ = Nothing }
GCSMemberSupport ( Just gmId ) -> do
m <- getGroupMemberById db vr user gmId
when ( isNothing $ supportChat m ) $ do
ts <- liftIO getCurrentTime
liftIO $ setSupportChatTs db gmId ts
pure GCSIMemberSupport { groupMember_ = Just m }
getGroupChatScopeInfoForItem :: DB . Connection -> VersionRangeChat -> User -> GroupInfo -> ChatItemId -> ExceptT StoreError IO ( Maybe GroupChatScopeInfo )
getGroupChatScopeInfoForItem db vr user g itemId =
getGroupChatScopeForItem_ db itemId >>= mapM ( getGroupChatScopeInfo db vr user g )
2025-04-02 07:57:18 +00:00
getGroupChatScopeInfo :: DB . Connection -> VersionRangeChat -> User -> GroupInfo -> GroupChatScope -> ExceptT StoreError IO GroupChatScopeInfo
2025-04-05 11:25:45 +00:00
getGroupChatScopeInfo db vr user GroupInfo { membership } = \ case
GCSMemberSupport Nothing -> case supportChat membership of
2025-04-02 07:57:18 +00:00
Nothing -> throwError $ SEInternalError " no moderators support chat "
2025-04-05 11:25:45 +00:00
Just _supportChat -> pure $ GCSIMemberSupport { groupMember_ = Nothing }
2025-04-02 07:57:18 +00:00
GCSMemberSupport ( Just gmId ) -> do
m <- getGroupMemberById db vr user gmId
case supportChat m of
Nothing -> throwError $ SEInternalError " no support chat "
Just _supportChat -> pure GCSIMemberSupport { groupMember_ = Just m }
getGroupChatScopeForItem_ :: DB . Connection -> ChatItemId -> ExceptT StoreError IO ( Maybe GroupChatScope )
getGroupChatScopeForItem_ db itemId =
ExceptT . firstRow toScope ( SEChatItemNotFound itemId ) $
DB . query
db
[ sql |
SELECT group_scope_tag , group_scope_group_member_id
FROM chat_items
WHERE chat_item_id = ?
| ]
( Only itemId )
where
toScope ( scopeTag , scopeMemberId ) =
case ( scopeTag , scopeMemberId ) of
( Just GCSTMemberSupport_ , Just gmId ) -> Just $ GCSMemberSupport gmId
( Just GCSTMemberSupport_ , Nothing ) -> Just $ GCSMemberSupport Nothing
( Nothing , Nothing ) -> Nothing
( Nothing , Just _ ) -> Nothing -- shouldn't happen
getGroupChatLast_ :: DB . Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe MsgContentTag -> Int -> String -> ChatStats -> ExceptT StoreError IO ( Chat 'CTGroup )
getGroupChatLast_ db user g scopeInfo_ contentFilter count search stats = do
ciIds <- getGroupChatItemIDs db user g scopeInfo_ contentFilter GRLast count search
ts <- liftIO getCurrentTime
cis <- mapM ( liftIO . safeGetGroupItem db user g ts ) ciIds
pure $ Chat ( GroupChat g scopeInfo_ ) ( reverse cis ) stats
2024-11-14 08:34:25 +00:00
2025-01-08 09:42:26 +00:00
data GroupItemIDsRange = GRLast | GRAfter UTCTime ChatItemId | GRBefore UTCTime ChatItemId
2025-04-02 07:57:18 +00:00
getGroupChatItemIDs :: DB . Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe MsgContentTag -> GroupItemIDsRange -> Int -> String -> ExceptT StoreError IO [ ChatItemId ]
getGroupChatItemIDs db User { userId } GroupInfo { groupId } scopeInfo_ contentFilter range count search = case ( scopeInfo_ , contentFilter ) of
( Nothing , Nothing ) ->
liftIO $
idsQuery
( baseCond <> " AND group_scope_tag IS NULL AND group_scope_group_member_id IS NULL " )
( userId , groupId )
( Nothing , Just mcTag ) ->
liftIO $
idsQuery
( baseCond <> " AND msg_content_tag = ? " )
( userId , groupId , mcTag )
( Just GCSIMemberSupport { groupMember_ = Just m } , Nothing ) ->
liftIO $
idsQuery
( baseCond <> " AND group_scope_tag = ? AND group_scope_group_member_id = ? " )
( userId , groupId , GCSTMemberSupport_ , groupMemberId' m )
( Just GCSIMemberSupport { groupMember_ = Nothing } , Nothing ) ->
liftIO $
idsQuery
( baseCond <> " AND group_scope_tag = ? AND group_scope_group_member_id IS NULL " )
( userId , groupId , GCSTMemberSupport_ )
( Just _scope , Just _mcTag ) ->
throwError $ SEInternalError " group scope and content filter are not supported together "
2025-01-08 09:42:26 +00:00
where
baseQuery = " SELECT chat_item_id FROM chat_items WHERE "
baseCond = " user_id = ? AND group_id = ? "
idsQuery :: ToRow p => Query -> p -> IO [ ChatItemId ]
idsQuery c p = case range of
GRLast -> rangeQuery c p " ORDER BY item_ts DESC, chat_item_id DESC "
GRAfter ts itemId ->
rangeQuery
( " item_ts > ? " ` orCond ` " item_ts = ? AND chat_item_id > ? " )
( orParams ts itemId )
" ORDER BY item_ts ASC, chat_item_id ASC "
GRBefore ts itemId ->
rangeQuery
( " item_ts < ? " ` orCond ` " item_ts = ? AND chat_item_id < ? " )
( orParams ts itemId )
" ORDER BY item_ts DESC, chat_item_id DESC "
where
2025-02-27 07:38:40 +00:00
orCond c1 c2 = " (( " <> c <> " AND " <> c1 <> " ) OR ( " <> c <> " AND " <> c2 <> " )) "
2025-01-08 09:42:26 +00:00
orParams ts itemId = ( p :. ( Only ts ) :. p :. ( ts , itemId ) )
rangeQuery :: ToRow p => Query -> p -> Query -> IO [ ChatItemId ]
rangeQuery c p ob
| null search = searchQuery " " ()
2025-01-10 15:27:29 +04:00
| otherwise = searchQuery " AND LOWER(item_text) LIKE '%' || LOWER(?) || '%' " ( Only search )
2025-01-08 09:42:26 +00:00
where
searchQuery :: ToRow p' => Query -> p' -> IO [ ChatItemId ]
searchQuery c' p' =
map fromOnly <$> DB . query db ( baseQuery <> c <> c' <> ob <> " LIMIT ? " ) ( p :. p' :. Only count )
2023-06-18 10:20:11 +01:00
2024-02-19 15:17:14 +04:00
safeGetGroupItem :: DB . Connection -> User -> GroupInfo -> UTCTime -> ChatItemId -> IO ( CChatItem 'CTGroup )
safeGetGroupItem db user g currentTs itemId =
runExceptT ( getGroupCIWithReactions db user g itemId )
>>= pure <$> safeToGroupItem currentTs itemId
safeToGroupItem :: UTCTime -> ChatItemId -> Either StoreError ( CChatItem 'CTGroup ) -> CChatItem 'CTGroup
safeToGroupItem currentTs itemId = \ case
Right ci -> ci
Left e @ ( SEBadChatItem _ ( Just itemTs ) ) -> badGroupItem itemTs e
Left e -> badGroupItem currentTs e
where
badGroupItem :: UTCTime -> StoreError -> CChatItem 'CTGroup
badGroupItem ts e =
let errorText = T . pack $ show e
in CChatItem
SMDSnd
ChatItem
{ chatDir = CIGroupSnd ,
meta = dummyMeta itemId ts errorText ,
content = CIInvalidJSON errorText ,
2025-01-29 13:04:48 +00:00
mentions = M . empty ,
2024-02-19 15:17:14 +04:00
formattedText = Nothing ,
quotedItem = Nothing ,
reactions = [] ,
file = Nothing
}
2023-06-18 10:20:11 +01:00
getGroupMemberChatItemLast :: DB . Connection -> User -> GroupId -> GroupMemberId -> ExceptT StoreError IO ( CChatItem 'CTGroup )
getGroupMemberChatItemLast db user @ User { userId } groupId groupMemberId = do
chatItemId <-
ExceptT . firstRow fromOnly ( SEChatItemNotFoundByGroupId groupId ) $
DB . query
db
[ sql |
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND group_id = ? AND group_member_id = ?
ORDER BY item_ts DESC , chat_item_id DESC
LIMIT 1
| ]
( userId , groupId , groupMemberId )
getGroupChatItem db user groupId chatItemId
2025-04-02 07:57:18 +00:00
getGroupChatAfter_ :: DB . Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe MsgContentTag -> ChatItemId -> Int -> String -> ExceptT StoreError IO ( Chat 'CTGroup )
getGroupChatAfter_ db user g @ GroupInfo { groupId } scopeInfo contentFilter afterId count search = do
2024-11-14 08:34:25 +00:00
afterCI <- getGroupChatItem db user groupId afterId
2025-01-08 09:42:26 +00:00
let range = GRAfter ( chatItemTs afterCI ) ( cChatItemId afterCI )
2025-04-02 07:57:18 +00:00
ciIds <- getGroupChatItemIDs db user g scopeInfo contentFilter range count search
2024-11-14 08:34:25 +00:00
ts <- liftIO getCurrentTime
cis <- liftIO $ mapM ( safeGetGroupItem db user g ts ) ciIds
2025-04-02 07:57:18 +00:00
pure $ Chat ( GroupChat g scopeInfo ) cis emptyChatStats
2024-11-14 08:34:25 +00:00
2025-04-02 07:57:18 +00:00
getGroupChatBefore_ :: DB . Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe MsgContentTag -> ChatItemId -> Int -> String -> ExceptT StoreError IO ( Chat 'CTGroup )
getGroupChatBefore_ db user g @ GroupInfo { groupId } scopeInfo contentFilter beforeId count search = do
2024-11-14 08:34:25 +00:00
beforeCI <- getGroupChatItem db user groupId beforeId
2025-01-08 09:42:26 +00:00
let range = GRBefore ( chatItemTs beforeCI ) ( cChatItemId beforeCI )
2025-04-02 07:57:18 +00:00
ciIds <- getGroupChatItemIDs db user g scopeInfo contentFilter range count search
2024-11-14 08:34:25 +00:00
ts <- liftIO getCurrentTime
cis <- liftIO $ mapM ( safeGetGroupItem db user g ts ) ciIds
2025-04-02 07:57:18 +00:00
pure $ Chat ( GroupChat g scopeInfo ) ( reverse cis ) emptyChatStats
2024-11-14 08:34:25 +00:00
2025-04-02 07:57:18 +00:00
getGroupChatAround_ :: DB . Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe MsgContentTag -> ChatItemId -> Int -> String -> ExceptT StoreError IO ( Chat 'CTGroup , Maybe NavigationInfo )
getGroupChatAround_ db user g scopeInfo contentFilter aroundId count search = do
stats <- getGroupStats_ db user g scopeInfo
getGroupChatAround' db user g scopeInfo contentFilter aroundId count search stats
2024-11-14 08:34:25 +00:00
2025-04-02 07:57:18 +00:00
getGroupChatAround' :: DB . Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe MsgContentTag -> ChatItemId -> Int -> String -> ChatStats -> ExceptT StoreError IO ( Chat 'CTGroup , Maybe NavigationInfo )
getGroupChatAround' db user g scopeInfo contentFilter aroundId count search stats = do
2025-02-03 08:55:46 +00:00
aroundCI <- getGroupCIWithReactions db user g aroundId
2025-01-08 09:42:26 +00:00
let beforeRange = GRBefore ( chatItemTs aroundCI ) ( cChatItemId aroundCI )
afterRange = GRAfter ( chatItemTs aroundCI ) ( cChatItemId aroundCI )
2025-04-02 07:57:18 +00:00
beforeIds <- getGroupChatItemIDs db user g scopeInfo contentFilter beforeRange count search
afterIds <- getGroupChatItemIDs db user g scopeInfo contentFilter afterRange count search
2024-11-14 08:34:25 +00:00
ts <- liftIO getCurrentTime
beforeCIs <- liftIO $ mapM ( safeGetGroupItem db user g ts ) beforeIds
afterCIs <- liftIO $ mapM ( safeGetGroupItem db user g ts ) afterIds
let cis = reverse beforeCIs <> [ aroundCI ] <> afterCIs
navInfo <- liftIO $ getNavInfo cis
2025-04-02 07:57:18 +00:00
pure ( Chat ( GroupChat g scopeInfo ) cis stats , Just navInfo )
2023-06-18 10:20:11 +01:00
where
2024-11-14 08:34:25 +00:00
getNavInfo cis_ = case cis_ of
[] -> pure $ NavigationInfo 0 0
cis -> getGroupNavInfo_ db user g ( last cis )
2025-04-02 07:57:18 +00:00
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
2024-11-14 08:34:25 +00:00
Just minUnreadItemId -> do
2025-04-02 07:57:18 +00:00
unreadCounts <- getGroupUnreadCount_ db user g scopeInfo_ Nothing
stats <- liftIO $ getStats minUnreadItemId unreadCounts
getGroupChatAround' db user g scopeInfo_ contentFilter minUnreadItemId count " " stats
Nothing -> do
stats <- liftIO $ getStats 0 ( 0 , 0 )
( , Just $ NavigationInfo 0 0 ) <$> getGroupChatLast_ db user g scopeInfo_ contentFilter count " " stats
2025-01-10 19:41:01 +00:00
where
2025-01-30 17:59:21 +00:00
getStats minUnreadItemId ( unreadCount , unreadMentions ) = do
2025-01-10 19:41:01 +00:00
reportsCount <- getGroupReportsCount_ db user g False
2025-05-09 15:36:06 +00:00
pure ChatStats { unreadCount , unreadMentions , reportsCount , minUnreadItemId , unreadChat = False }
2024-11-14 08:34:25 +00:00
2025-04-02 07:57:18 +00:00
getGroupStats_ :: DB . Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> ExceptT StoreError IO ChatStats
getGroupStats_ db user g scopeInfo_ = do
minUnreadItemId <- fromMaybe 0 <$> getGroupMinUnreadId_ db user g scopeInfo_ Nothing
( unreadCount , unreadMentions ) <- getGroupUnreadCount_ db user g scopeInfo_ Nothing
reportsCount <- liftIO $ getGroupReportsCount_ db user g False
2025-05-09 15:36:06 +00:00
pure ChatStats { unreadCount , unreadMentions , reportsCount , minUnreadItemId , unreadChat = False }
2025-01-08 09:42:26 +00:00
2025-04-02 07:57:18 +00:00
getGroupMinUnreadId_ :: DB . Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe MsgContentTag -> ExceptT StoreError IO ( Maybe ChatItemId )
getGroupMinUnreadId_ db user g scopeInfo_ contentFilter =
2024-11-14 08:34:25 +00:00
fmap join . maybeFirstRow fromOnly $
2025-04-02 07:57:18 +00:00
queryUnreadGroupItems db user g scopeInfo_ contentFilter baseQuery orderLimit
2025-01-08 09:42:26 +00:00
where
baseQuery = " SELECT chat_item_id FROM chat_items WHERE user_id = ? AND group_id = ? "
2025-01-10 15:27:29 +04:00
orderLimit = " ORDER BY item_ts ASC, chat_item_id ASC LIMIT 1 "
2025-01-08 09:42:26 +00:00
2025-04-02 07:57:18 +00:00
getGroupUnreadCount_ :: DB . Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe MsgContentTag -> ExceptT StoreError IO ( Int , Int )
getGroupUnreadCount_ db user g scopeInfo_ contentFilter =
head <$> queryUnreadGroupItems db user g scopeInfo_ contentFilter baseQuery " "
2025-01-08 09:42:26 +00:00
where
2025-04-23 14:15:17 +00:00
baseQuery = " SELECT COUNT(1), COALESCE(SUM(user_mention), 0) FROM chat_items WHERE user_id = ? AND group_id = ? AND group_scope_tag IS NULL "
2024-11-14 08:34:25 +00:00
2025-01-08 09:42:26 +00:00
getGroupReportsCount_ :: DB . Connection -> User -> GroupInfo -> Bool -> IO Int
getGroupReportsCount_ db User { userId } GroupInfo { groupId } archived =
2024-11-14 08:34:25 +00:00
fromOnly . head
<$> DB . query
db
2025-01-08 09:42:26 +00:00
" SELECT COUNT(1) FROM chat_items WHERE user_id = ? AND group_id = ? AND msg_content_tag = ? AND item_deleted = ? AND item_sent = 0 "
( userId , groupId , MCReport_ , BI archived )
2025-04-02 07:57:18 +00:00
queryUnreadGroupItems :: FromRow r => DB . Connection -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe MsgContentTag -> Query -> Query -> ExceptT StoreError IO [ r ]
queryUnreadGroupItems db User { userId } GroupInfo { groupId } scopeInfo_ contentFilter baseQuery orderLimit =
case ( scopeInfo_ , contentFilter ) of
( Nothing , Nothing ) ->
liftIO $
DB . query
db
( baseQuery <> " AND group_scope_tag IS NULL AND group_scope_group_member_id IS NULL AND item_status = ? " <> orderLimit )
( userId , groupId , CISRcvNew )
( Nothing , Just mcTag ) ->
liftIO $
DB . query
db
( baseQuery <> " AND msg_content_tag = ? AND item_status = ? " <> orderLimit )
( userId , groupId , mcTag , CISRcvNew )
( Just GCSIMemberSupport { groupMember_ = Just m } , Nothing ) ->
liftIO $
DB . query
db
( baseQuery <> " AND group_scope_tag = ? AND group_scope_group_member_id = ? AND item_status = ? " <> orderLimit )
( userId , groupId , GCSTMemberSupport_ , groupMemberId' m , CISRcvNew )
( Just GCSIMemberSupport { groupMember_ = Nothing } , Nothing ) ->
liftIO $
DB . query
db
( baseQuery <> " AND group_scope_tag = ? AND group_scope_group_member_id IS NULL AND item_status = ? " <> orderLimit )
( userId , groupId , GCSTMemberSupport_ , CISRcvNew )
( Just _scope , Just _mcTag ) ->
throwError $ SEInternalError " group scope and content filter are not supported together "
2024-11-14 08:34:25 +00:00
getGroupNavInfo_ :: DB . Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> IO NavigationInfo
getGroupNavInfo_ db User { userId } GroupInfo { groupId } afterCI = do
afterUnread <- getAfterUnreadCount
afterTotal <- getAfterTotalCount
pure NavigationInfo { afterUnread , afterTotal }
where
getAfterUnreadCount :: IO Int
getAfterUnreadCount =
fromOnly . head
2025-01-08 09:42:26 +00:00
<$> DB . query
2023-06-18 10:20:11 +01:00
db
[ sql |
2024-11-14 08:34:25 +00:00
SELECT COUNT ( 1 )
2024-11-25 18:51:49 +04:00
FROM (
SELECT 1
FROM chat_items
2025-01-08 09:42:26 +00:00
WHERE user_id = ? AND group_id = ? AND item_status = ?
AND item_ts > ?
2024-11-25 18:51:49 +04:00
UNION ALL
SELECT 1
FROM chat_items
2025-01-08 09:42:26 +00:00
WHERE user_id = ? AND group_id = ? AND item_status = ?
AND item_ts = ? AND chat_item_id > ?
2025-01-10 15:27:29 +04:00
) ci
2023-06-18 10:20:11 +01:00
| ]
2025-01-08 09:42:26 +00:00
( ( userId , groupId , CISRcvNew , chatItemTs afterCI )
:. ( userId , groupId , CISRcvNew , chatItemTs afterCI , cChatItemId afterCI )
)
2024-11-14 08:34:25 +00:00
getAfterTotalCount :: IO Int
getAfterTotalCount =
fromOnly . head
2025-01-08 09:42:26 +00:00
<$> DB . query
2023-06-18 10:20:11 +01:00
db
[ sql |
2024-11-14 08:34:25 +00:00
SELECT COUNT ( 1 )
2024-11-25 18:51:49 +04:00
FROM (
SELECT 1
FROM chat_items
2025-01-08 09:42:26 +00:00
WHERE user_id = ? AND group_id = ?
AND item_ts > ?
2024-11-25 18:51:49 +04:00
UNION ALL
SELECT 1
FROM chat_items
2025-01-08 09:42:26 +00:00
WHERE user_id = ? AND group_id = ?
AND item_ts = ? AND chat_item_id > ?
2025-01-10 15:27:29 +04:00
) ci
2023-06-18 10:20:11 +01:00
| ]
2025-01-08 09:42:26 +00:00
( ( userId , groupId , chatItemTs afterCI )
:. ( userId , groupId , chatItemTs afterCI , cChatItemId afterCI )
)
2023-06-18 10:20:11 +01:00
2024-11-14 08:34:25 +00:00
getLocalChat :: DB . Connection -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO ( Chat 'CTLocal , Maybe NavigationInfo )
2024-01-11 19:01:44 +02:00
getLocalChat db user folderId pagination search_ = do
let search = fromMaybe " " search_
nf <- getNoteFolder db user folderId
2024-11-14 08:34:25 +00:00
case pagination of
CPLast count -> liftIO $ ( , Nothing ) <$> getLocalChatLast_ db user nf count search
CPAfter afterId count -> ( , Nothing ) <$> getLocalChatAfter_ db user nf afterId count search
CPBefore beforeId count -> ( , Nothing ) <$> getLocalChatBefore_ db user nf beforeId count search
CPAround aroundId count -> getLocalChatAround_ db user nf aroundId count search
CPInitial count -> do
unless ( null search ) $ throwError $ SEInternalError " initial chat pagination doesn't support search "
getLocalChatInitial_ db user nf count
2024-01-11 19:01:44 +02:00
2024-02-19 15:17:14 +04:00
getLocalChatLast_ :: DB . Connection -> User -> NoteFolder -> Int -> String -> IO ( Chat 'CTLocal )
2024-11-14 08:34:25 +00:00
getLocalChatLast_ db user nf count search = do
ciIds <- getLocalChatItemIdsLast_ db user nf count search
ts <- getCurrentTime
cis <- mapM ( safeGetLocalItem db user nf ts ) ciIds
2025-01-08 09:42:26 +00:00
pure $ Chat ( LocalChat nf ) ( reverse cis ) emptyChatStats
2024-11-14 08:34:25 +00:00
getLocalChatItemIdsLast_ :: DB . Connection -> User -> NoteFolder -> Int -> String -> IO [ ChatItemId ]
getLocalChatItemIdsLast_ db User { userId } NoteFolder { noteFolderId } count search =
map fromOnly
<$> DB . query
db
[ sql |
SELECT chat_item_id
FROM chat_items
2025-01-10 15:27:29 +04:00
WHERE user_id = ? AND note_folder_id = ? AND LOWER ( item_text ) LIKE '%' || LOWER ( ? ) || '%'
2024-11-14 08:34:25 +00:00
ORDER BY created_at DESC , chat_item_id DESC
LIMIT ?
| ]
( userId , noteFolderId , search , count )
2024-01-11 19:01:44 +02:00
2024-02-19 15:17:14 +04:00
safeGetLocalItem :: DB . Connection -> User -> NoteFolder -> UTCTime -> ChatItemId -> IO ( CChatItem 'CTLocal )
safeGetLocalItem db user NoteFolder { noteFolderId } currentTs itemId =
runExceptT ( getLocalChatItem db user noteFolderId itemId )
>>= pure <$> safeToLocalItem currentTs itemId
safeToLocalItem :: UTCTime -> ChatItemId -> Either StoreError ( CChatItem 'CTLocal ) -> CChatItem 'CTLocal
safeToLocalItem currentTs itemId = \ case
Right ci -> ci
Left e @ ( SEBadChatItem _ ( Just itemTs ) ) -> badLocalItem itemTs e
Left e -> badLocalItem currentTs e
where
badLocalItem :: UTCTime -> StoreError -> CChatItem 'CTLocal
badLocalItem ts e =
let errorText = T . pack $ show e
in CChatItem
SMDSnd
ChatItem
{ chatDir = CILocalSnd ,
meta = dummyMeta itemId ts errorText ,
content = CIInvalidJSON errorText ,
2025-01-29 13:04:48 +00:00
mentions = M . empty ,
2024-02-19 15:17:14 +04:00
formattedText = Nothing ,
quotedItem = Nothing ,
reactions = [] ,
file = Nothing
}
2024-11-14 08:34:25 +00:00
getLocalChatAfter_ :: DB . Connection -> User -> NoteFolder -> ChatItemId -> Int -> String -> ExceptT StoreError IO ( Chat 'CTLocal )
getLocalChatAfter_ db user nf @ NoteFolder { noteFolderId } afterId count search = do
afterCI <- getLocalChatItem db user noteFolderId afterId
ciIds <- liftIO $ getLocalCIsAfter_ db user nf afterCI count search
ts <- liftIO getCurrentTime
cis <- liftIO $ mapM ( safeGetLocalItem db user nf ts ) ciIds
2025-01-08 09:42:26 +00:00
pure $ Chat ( LocalChat nf ) cis emptyChatStats
2024-11-14 08:34:25 +00:00
getLocalCIsAfter_ :: DB . Connection -> User -> NoteFolder -> CChatItem 'CTLocal -> Int -> String -> IO [ ChatItemId ]
getLocalCIsAfter_ db User { userId } NoteFolder { noteFolderId } afterCI count search =
map fromOnly
<$> DB . query
db
[ sql |
SELECT chat_item_id
FROM chat_items
2025-01-10 15:27:29 +04:00
WHERE user_id = ? AND note_folder_id = ? AND LOWER ( item_text ) LIKE '%' || LOWER ( ? ) || '%'
2024-11-14 08:34:25 +00:00
AND ( created_at > ? OR ( created_at = ? AND chat_item_id > ? ) )
ORDER BY created_at ASC , chat_item_id ASC
LIMIT ?
| ]
( userId , noteFolderId , search , ciCreatedAt afterCI , ciCreatedAt afterCI , cChatItemId afterCI , count )
getLocalChatBefore_ :: DB . Connection -> User -> NoteFolder -> ChatItemId -> Int -> String -> ExceptT StoreError IO ( Chat 'CTLocal )
getLocalChatBefore_ db user nf @ NoteFolder { noteFolderId } beforeId count search = do
beforeCI <- getLocalChatItem db user noteFolderId beforeId
ciIds <- liftIO $ getLocalCIsBefore_ db user nf beforeCI count search
ts <- liftIO getCurrentTime
cis <- liftIO $ mapM ( safeGetLocalItem db user nf ts ) ciIds
2025-01-08 09:42:26 +00:00
pure $ Chat ( LocalChat nf ) ( reverse cis ) emptyChatStats
2024-11-14 08:34:25 +00:00
getLocalCIsBefore_ :: DB . Connection -> User -> NoteFolder -> CChatItem 'CTLocal -> Int -> String -> IO [ ChatItemId ]
getLocalCIsBefore_ db User { userId } NoteFolder { noteFolderId } beforeCI count search =
map fromOnly
<$> DB . query
db
[ sql |
SELECT chat_item_id
FROM chat_items
2025-01-10 15:27:29 +04:00
WHERE user_id = ? AND note_folder_id = ? AND LOWER ( item_text ) LIKE '%' || LOWER ( ? ) || '%'
2024-11-14 08:34:25 +00:00
AND ( created_at < ? OR ( created_at = ? AND chat_item_id < ? ) )
ORDER BY created_at DESC , chat_item_id DESC
LIMIT ?
| ]
( userId , noteFolderId , search , ciCreatedAt beforeCI , ciCreatedAt beforeCI , cChatItemId beforeCI , count )
getLocalChatAround_ :: DB . Connection -> User -> NoteFolder -> ChatItemId -> Int -> String -> ExceptT StoreError IO ( Chat 'CTLocal , Maybe NavigationInfo )
getLocalChatAround_ db user nf aroundId count search = do
stats <- liftIO $ getLocalStats_ db user nf
getLocalChatAround' db user nf aroundId count search stats
getLocalChatAround' :: DB . Connection -> User -> NoteFolder -> ChatItemId -> Int -> String -> ChatStats -> ExceptT StoreError IO ( Chat 'CTLocal , Maybe NavigationInfo )
getLocalChatAround' db user nf @ NoteFolder { noteFolderId } aroundId count search stats = do
aroundCI <- getLocalChatItem db user noteFolderId aroundId
beforeIds <- liftIO $ getLocalCIsBefore_ db user nf aroundCI count search
afterIds <- liftIO $ getLocalCIsAfter_ db user nf aroundCI count search
ts <- liftIO getCurrentTime
beforeCIs <- liftIO $ mapM ( safeGetLocalItem db user nf ts ) beforeIds
afterCIs <- liftIO $ mapM ( safeGetLocalItem db user nf ts ) afterIds
let cis = reverse beforeCIs <> [ aroundCI ] <> afterCIs
navInfo <- liftIO $ getNavInfo cis
pure ( Chat ( LocalChat nf ) cis stats , Just navInfo )
2024-01-11 19:01:44 +02:00
where
2024-11-14 08:34:25 +00:00
getNavInfo cis_ = case cis_ of
[] -> pure $ NavigationInfo 0 0
cis -> getLocalNavInfo_ db user nf ( last cis )
getLocalChatInitial_ :: DB . Connection -> User -> NoteFolder -> Int -> ExceptT StoreError IO ( Chat 'CTLocal , Maybe NavigationInfo )
getLocalChatInitial_ db user nf count = do
liftIO ( getLocalMinUnreadId_ db user nf ) >>= \ case
Just minUnreadItemId -> do
unreadCount <- liftIO $ getLocalUnreadCount_ db user nf
2025-01-08 09:42:26 +00:00
let stats = emptyChatStats { unreadCount , minUnreadItemId }
2024-11-14 08:34:25 +00:00
getLocalChatAround' db user nf minUnreadItemId count " " stats
Nothing -> liftIO $ ( , Just $ NavigationInfo 0 0 ) <$> getLocalChatLast_ db user nf count " "
getLocalStats_ :: DB . Connection -> User -> NoteFolder -> IO ChatStats
getLocalStats_ db user nf = do
minUnreadItemId <- fromMaybe 0 <$> getLocalMinUnreadId_ db user nf
unreadCount <- getLocalUnreadCount_ db user nf
2025-01-08 09:42:26 +00:00
pure emptyChatStats { unreadCount , minUnreadItemId }
2024-11-14 08:34:25 +00:00
getLocalMinUnreadId_ :: DB . Connection -> User -> NoteFolder -> IO ( Maybe ChatItemId )
getLocalMinUnreadId_ db User { userId } NoteFolder { noteFolderId } =
fmap join . maybeFirstRow fromOnly $
DB . query
db
[ sql |
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND note_folder_id = ? AND item_status = ?
ORDER BY created_at ASC , chat_item_id ASC
LIMIT 1
| ]
( userId , noteFolderId , CISRcvNew )
getLocalUnreadCount_ :: DB . Connection -> User -> NoteFolder -> IO Int
getLocalUnreadCount_ db User { userId } NoteFolder { noteFolderId } =
fromOnly . head
<$> DB . query
db
[ sql |
SELECT COUNT ( 1 )
FROM chat_items
WHERE user_id = ? AND note_folder_id = ? AND item_status = ?
| ]
( userId , noteFolderId , CISRcvNew )
getLocalNavInfo_ :: DB . Connection -> User -> NoteFolder -> CChatItem 'CTLocal -> IO NavigationInfo
getLocalNavInfo_ db User { userId } NoteFolder { noteFolderId } afterCI = do
afterUnread <- getAfterUnreadCount
afterTotal <- getAfterTotalCount
pure NavigationInfo { afterUnread , afterTotal }
where
getAfterUnreadCount :: IO Int
getAfterUnreadCount =
fromOnly . head
2025-01-08 09:42:26 +00:00
<$> DB . query
2024-01-11 19:01:44 +02:00
db
[ sql |
2024-11-14 08:34:25 +00:00
SELECT COUNT ( 1 )
2024-11-25 18:51:49 +04:00
FROM (
SELECT 1
FROM chat_items
2025-01-08 09:42:26 +00:00
WHERE user_id = ? AND note_folder_id = ? AND item_status = ?
AND created_at > ?
2024-11-25 18:51:49 +04:00
UNION ALL
SELECT 1
FROM chat_items
2025-01-08 09:42:26 +00:00
WHERE user_id = ? AND note_folder_id = ? AND item_status = ?
AND created_at = ? AND chat_item_id > ?
2025-01-10 15:27:29 +04:00
) ci
2024-01-11 19:01:44 +02:00
| ]
2025-01-08 09:42:26 +00:00
( ( userId , noteFolderId , CISRcvNew , ciCreatedAt afterCI )
:. ( userId , noteFolderId , CISRcvNew , ciCreatedAt afterCI , cChatItemId afterCI )
)
2024-11-14 08:34:25 +00:00
getAfterTotalCount :: IO Int
getAfterTotalCount =
fromOnly . head
2025-01-08 09:42:26 +00:00
<$> DB . query
2024-01-11 19:01:44 +02:00
db
[ sql |
2024-11-14 08:34:25 +00:00
SELECT COUNT ( 1 )
2024-11-25 18:51:49 +04:00
FROM (
SELECT 1
FROM chat_items
2025-01-08 09:42:26 +00:00
WHERE user_id = ? AND note_folder_id = ?
AND created_at > ?
2024-11-25 18:51:49 +04:00
UNION ALL
SELECT 1
FROM chat_items
2025-01-08 09:42:26 +00:00
WHERE user_id = ? AND note_folder_id = ?
AND created_at = ? AND chat_item_id > ?
2025-01-10 15:27:29 +04:00
) ci
2024-01-11 19:01:44 +02:00
| ]
2025-01-08 09:42:26 +00:00
( ( userId , noteFolderId , ciCreatedAt afterCI )
:. ( userId , noteFolderId , ciCreatedAt afterCI , cChatItemId afterCI )
)
2024-01-11 19:01:44 +02:00
2025-04-21 15:17:21 +00:00
toChatItemRef ::
( ChatItemId , Maybe ContactId , Maybe GroupId , Maybe GroupChatScopeTag , Maybe GroupMemberId , Maybe NoteFolderId ) ->
Either StoreError ( ChatRef , ChatItemId )
2023-06-18 10:20:11 +01:00
toChatItemRef = \ case
2025-04-21 15:17:21 +00:00
( itemId , Just contactId , Nothing , Nothing , Nothing , Nothing ) ->
Right ( ChatRef CTDirect contactId Nothing , itemId )
( itemId , Nothing , Just groupId , Nothing , Nothing , Nothing ) ->
Right ( ChatRef CTGroup groupId Nothing , itemId )
( itemId , Nothing , Just groupId , Just GCSTMemberSupport_ , Nothing , Nothing ) ->
Right ( ChatRef CTGroup groupId ( Just ( GCSMemberSupport Nothing ) ) , itemId )
( itemId , Nothing , Just groupId , Just GCSTMemberSupport_ , Just scopeGMId , Nothing ) ->
Right ( ChatRef CTGroup groupId ( Just ( GCSMemberSupport $ Just scopeGMId ) ) , itemId )
( itemId , Nothing , Nothing , Nothing , Nothing , Just folderId ) ->
Right ( ChatRef CTLocal folderId Nothing , itemId )
( itemId , _ , _ , _ , _ , _ ) ->
Left $ SEBadChatItem itemId Nothing
2023-06-18 10:20:11 +01:00
2024-12-01 13:11:30 +00:00
updateDirectChatItemsRead :: DB . Connection -> User -> ContactId -> IO ()
updateDirectChatItemsRead db User { userId } contactId = do
2023-06-18 10:20:11 +01:00
currentTs <- getCurrentTime
2024-12-01 13:11:30 +00:00
DB . execute
db
[ sql |
UPDATE chat_items SET item_status = ? , updated_at = ?
WHERE user_id = ? AND contact_id = ? AND item_status = ?
| ]
( CISRcvRead , currentTs , userId , contactId , CISRcvNew )
2023-06-18 10:20:11 +01:00
2024-12-01 13:11:30 +00:00
getDirectUnreadTimedItems :: DB . Connection -> User -> ContactId -> IO [ ( ChatItemId , Int ) ]
getDirectUnreadTimedItems db User { userId } contactId =
DB . query
db
[ sql |
SELECT chat_item_id , timed_ttl
FROM chat_items
WHERE user_id = ? AND contact_id = ? AND item_status = ? AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL
| ]
( userId , contactId , CISRcvNew )
2023-06-18 10:20:11 +01:00
2024-09-07 19:40:10 +01:00
updateDirectChatItemsReadList :: DB . Connection -> User -> ContactId -> NonEmpty ChatItemId -> IO [ ( ChatItemId , Int ) ]
2024-12-01 13:11:30 +00:00
updateDirectChatItemsReadList db user @ User { userId } contactId itemIds = do
currentTs <- getCurrentTime
catMaybes . L . toList <$> mapM ( getUpdateDirectItem currentTs ) itemIds
2024-09-07 19:40:10 +01:00
where
2024-12-01 13:11:30 +00:00
getUpdateDirectItem currentTs itemId = do
ttl_ <- maybeFirstRow fromOnly getUnreadTimedItem
setDirectChatItemRead_ db user contactId itemId currentTs
pure $ ( itemId , ) <$> ttl_
where
getUnreadTimedItem =
DB . query
db
[ sql |
SELECT timed_ttl
FROM chat_items
WHERE user_id = ? AND contact_id = ? AND item_status = ? AND chat_item_id = ? AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL
| ]
( userId , contactId , CISRcvNew , itemId )
setDirectChatItemRead :: DB . Connection -> User -> ContactId -> ChatItemId -> IO ()
setDirectChatItemRead db user contactId itemId =
setDirectChatItemRead_ db user contactId itemId =<< getCurrentTime
setDirectChatItemRead_ :: DB . Connection -> User -> ContactId -> ChatItemId -> UTCTime -> IO ()
setDirectChatItemRead_ db User { userId } contactId itemId currentTs =
DB . execute
db
[ sql |
UPDATE chat_items SET item_status = ? , updated_at = ?
WHERE user_id = ? AND contact_id = ? AND item_status = ? AND chat_item_id = ?
| ]
( CISRcvRead , currentTs , userId , contactId , CISRcvNew , itemId )
2024-09-07 19:40:10 +01:00
setDirectChatItemsDeleteAt :: DB . Connection -> User -> ContactId -> [ ( ChatItemId , Int ) ] -> UTCTime -> IO [ ( ChatItemId , UTCTime ) ]
setDirectChatItemsDeleteAt db User { userId } contactId itemIds currentTs = forM itemIds $ \ ( chatItemId , ttl ) -> do
let deleteAt = addUTCTime ( realToFrac ttl ) currentTs
2023-06-18 10:20:11 +01:00
DB . execute
db
" UPDATE chat_items SET timed_delete_at = ? WHERE user_id = ? AND contact_id = ? AND chat_item_id = ? "
( deleteAt , userId , contactId , chatItemId )
2024-09-07 19:40:10 +01:00
pure ( chatItemId , deleteAt )
2023-06-18 10:20:11 +01:00
2025-04-05 11:25:45 +00:00
updateGroupChatItemsRead :: DB . Connection -> User -> GroupInfo -> Maybe GroupChatScope -> IO ()
updateGroupChatItemsRead db User { userId } GroupInfo { groupId , membership } scope = do
2023-06-18 10:20:11 +01:00
currentTs <- getCurrentTime
2024-12-01 13:11:30 +00:00
DB . execute
db
[ sql |
UPDATE chat_items SET item_status = ? , updated_at = ?
WHERE user_id = ? AND group_id = ? AND item_status = ?
| ]
( CISRcvRead , currentTs , userId , groupId , CISRcvNew )
2025-04-05 11:25:45 +00:00
case scope of
Nothing -> pure ()
Just GCSMemberSupport { groupMemberId_ } -> do
let gmId = fromMaybe ( groupMemberId' membership ) groupMemberId_
DB . execute
db
[ sql |
UPDATE group_members
SET support_chat_items_unread = 0 ,
support_chat_items_member_attention = 0 ,
support_chat_items_mentions = 0
WHERE group_member_id = ?
| ]
( Only gmId )
2023-06-18 10:20:11 +01:00
2024-12-01 13:11:30 +00:00
getGroupUnreadTimedItems :: DB . Connection -> User -> GroupId -> IO [ ( ChatItemId , Int ) ]
getGroupUnreadTimedItems db User { userId } groupId =
DB . query
db
[ sql |
SELECT chat_item_id , timed_ttl
FROM chat_items
WHERE user_id = ? AND group_id = ? AND item_status = ? AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL
| ]
( userId , groupId , CISRcvNew )
2023-06-18 10:20:11 +01:00
2025-05-20 16:18:23 +00:00
updateGroupChatItemsReadList :: DB . Connection -> VersionRangeChat -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> NonEmpty ChatItemId -> ExceptT StoreError IO ( [ ( ChatItemId , Int ) ] , GroupInfo )
updateGroupChatItemsReadList db vr user @ User { userId } g @ GroupInfo { groupId } scopeInfo_ itemIds = do
2025-05-09 15:36:06 +00:00
currentTs <- liftIO getCurrentTime
2025-04-05 11:25:45 +00:00
-- Possible improvement is to differentiate retrieval queries for each scope,
-- but we rely on UI to not pass item IDs from incorrect scope.
2025-05-09 15:36:06 +00:00
readItemsData <- liftIO $ catMaybes . L . toList <$> mapM ( getUpdateGroupItem currentTs ) itemIds
2025-05-20 16:18:23 +00:00
g' <- case scopeInfo_ of
Nothing -> pure g
Just scopeInfo @ GCSIMemberSupport { groupMember_ } -> do
let decStats = countReadItems groupMember_ readItemsData
liftIO $ updateGroupScopeUnreadStats db vr user g scopeInfo decStats
2025-05-09 15:36:06 +00:00
pure ( timedItems readItemsData , g' )
2024-09-07 19:40:10 +01:00
where
2025-04-05 11:25:45 +00:00
getUpdateGroupItem :: UTCTime -> ChatItemId -> IO ( Maybe ( ChatItemId , Maybe Int , Maybe UTCTime , Maybe GroupMemberId , Maybe BoolInt ) )
getUpdateGroupItem currentTs itemId =
maybeFirstRow id $
DB . query
db
[ sql |
UPDATE chat_items SET item_status = ? , updated_at = ?
WHERE user_id = ? AND group_id = ? AND item_status = ? AND chat_item_id = ?
RETURNING chat_item_id , timed_ttl , timed_delete_at , group_member_id , user_mention
| ]
( CISRcvRead , currentTs , userId , groupId , CISRcvNew , itemId )
2025-05-20 16:18:23 +00:00
countReadItems :: Maybe GroupMember -> [ ( ChatItemId , Maybe Int , Maybe UTCTime , Maybe GroupMemberId , Maybe BoolInt ) ] -> ( Int , Int , Int )
countReadItems scopeMember_ readItemsData =
let unread = length readItemsData
( unanswered , mentions ) = foldl' countItem ( 0 , 0 ) readItemsData
in ( unread , unanswered , mentions )
where
countItem :: ( Int , Int ) -> ( ChatItemId , Maybe Int , Maybe UTCTime , Maybe GroupMemberId , Maybe BoolInt ) -> ( Int , Int )
countItem ( ! unanswered , ! mentions ) ( _ , _ , _ , itemGMId_ , userMention_ ) =
let unanswered' = case ( scopeMember_ , itemGMId_ ) of
( Just scopeMember , Just itemGMId ) | itemGMId == groupMemberId' scopeMember -> unanswered + 1
_ -> unanswered
mentions' = case userMention_ of
Just ( BI True ) -> mentions + 1
_ -> mentions
in ( unanswered' , mentions' )
2025-04-05 11:25:45 +00:00
timedItems :: [ ( ChatItemId , Maybe Int , Maybe UTCTime , Maybe GroupMemberId , Maybe BoolInt ) ] -> [ ( ChatItemId , Int ) ]
timedItems = foldl' addTimedItem []
2024-12-01 13:11:30 +00:00
where
2025-04-05 11:25:45 +00:00
addTimedItem acc ( itemId , Just ttl , Nothing , _ , _ ) = ( itemId , ttl ) : acc
addTimedItem acc _ = acc
2025-05-20 16:18:23 +00:00
updateGroupScopeUnreadStats :: DB . Connection -> VersionRangeChat -> User -> GroupInfo -> GroupChatScopeInfo -> ( Int , Int , Int ) -> IO GroupInfo
updateGroupScopeUnreadStats db vr user g @ GroupInfo { membership } scopeInfo ( unread , unanswered , mentions ) =
case scopeInfo of
GCSIMemberSupport { groupMember_ } -> case groupMember_ of
Nothing -> do
membership' <- updateGMStats membership
pure g { membership = membership' }
Just member -> do
member' <- updateGMStats member
let didRequire = gmRequiresAttention member
nowRequires = gmRequiresAttention member'
if ( not nowRequires && didRequire )
then decreaseGroupMembersRequireAttention db user g
else pure g
where
updateGMStats m @ GroupMember { groupMemberId } = do
currentTs <- getCurrentTime
DB . execute
db
[ sql |
UPDATE group_members
SET support_chat_items_unread = support_chat_items_unread - ? ,
support_chat_items_member_attention = support_chat_items_member_attention - ? ,
support_chat_items_mentions = support_chat_items_mentions - ? ,
updated_at = ?
WHERE group_member_id = ?
| ]
( unread , unanswered , mentions , currentTs , groupMemberId )
m_ <- runExceptT $ getGroupMemberById db vr user groupMemberId
pure $ either ( const m ) id m_ -- Left shouldn't happen, but types require it
2025-04-05 11:25:45 +00:00
deriving instance Show BoolInt
2024-09-07 19:40:10 +01:00
setGroupChatItemsDeleteAt :: DB . Connection -> User -> GroupId -> [ ( ChatItemId , Int ) ] -> UTCTime -> IO [ ( ChatItemId , UTCTime ) ]
setGroupChatItemsDeleteAt db User { userId } groupId itemIds currentTs = forM itemIds $ \ ( chatItemId , ttl ) -> do
let deleteAt = addUTCTime ( realToFrac ttl ) currentTs
2023-06-18 10:20:11 +01:00
DB . execute
db
" UPDATE chat_items SET timed_delete_at = ? WHERE user_id = ? AND group_id = ? AND chat_item_id = ? "
( deleteAt , userId , groupId , chatItemId )
2024-09-07 19:40:10 +01:00
pure ( chatItemId , deleteAt )
2023-06-18 10:20:11 +01:00
2024-12-01 13:11:30 +00:00
updateLocalChatItemsRead :: DB . Connection -> User -> NoteFolderId -> IO ()
updateLocalChatItemsRead db User { userId } noteFolderId = do
2024-01-11 19:01:44 +02:00
currentTs <- getCurrentTime
2024-12-01 13:11:30 +00:00
DB . execute
db
[ sql |
UPDATE chat_items SET item_status = ? , updated_at = ?
WHERE user_id = ? AND note_folder_id = ? AND item_status = ?
| ]
( CISRcvRead , currentTs , userId , noteFolderId , CISRcvNew )
2024-01-11 19:01:44 +02:00
2023-09-01 19:43:27 +01:00
type MaybeCIFIleRow = ( Maybe Int64 , Maybe String , Maybe Integer , Maybe FilePath , Maybe C . SbKey , Maybe C . CbNonce , Maybe ACIFileStatus , Maybe FileProtocol )
2023-06-18 10:20:11 +01:00
2025-01-29 13:04:48 +00:00
type ChatItemModeRow = ( Maybe Int , Maybe UTCTime , Maybe BoolInt , BoolInt )
2023-06-18 10:20:11 +01:00
2024-04-09 13:02:59 +01:00
type ChatItemForwardedFromRow = ( Maybe CIForwardedFromTag , Maybe Text , Maybe MsgDirection , Maybe Int64 , Maybe Int64 , Maybe Int64 )
type ChatItemRow =
2025-01-10 15:27:29 +04:00
( Int64 , ChatItemTs , AMsgDirection , Text , Text , ACIStatus , Maybe BoolInt , Maybe SharedMsgId )
:. ( Int , Maybe UTCTime , Maybe BoolInt , UTCTime , UTCTime )
2024-04-09 13:02:59 +01:00
:. ChatItemForwardedFromRow
:. ChatItemModeRow
:. MaybeCIFIleRow
2023-06-18 10:20:11 +01:00
2025-01-10 15:27:29 +04:00
type QuoteRow = ( Maybe ChatItemId , Maybe SharedMsgId , Maybe UTCTime , Maybe MsgContent , Maybe BoolInt )
2023-06-18 10:20:11 +01:00
toDirectQuote :: QuoteRow -> Maybe ( CIQuote 'CTDirect )
2025-01-10 15:27:29 +04:00
toDirectQuote qr @ ( _ , _ , _ , _ , quotedSent ) = toQuote qr $ direction . unBI <$> quotedSent
2023-06-18 10:20:11 +01:00
where
direction sent = if sent then CIQDirectSnd else CIQDirectRcv
toQuote :: QuoteRow -> Maybe ( CIQDirection c ) -> Maybe ( CIQuote c )
toQuote ( quotedItemId , quotedSharedMsgId , quotedSentAt , quotedMsgContent , _ ) dir =
CIQuote <$> dir <*> pure quotedItemId <*> pure quotedSharedMsgId <*> quotedSentAt <*> quotedMsgContent <*> ( parseMaybeMarkdownList . msgContentText <$> quotedMsgContent )
-- this function can be changed so it never fails, not only avoid failure on invalid json
toDirectChatItem :: UTCTime -> ChatItemRow :. QuoteRow -> Either StoreError ( CChatItem 'CTDirect )
2025-01-29 13:04:48 +00:00
toDirectChatItem currentTs ( ( ( itemId , itemTs , AMsgDirection msgDir , itemContentText , itemText , itemStatus , sentViaProxy , sharedMsgId ) :. ( itemDeleted , deletedTs , itemEdited , createdAt , updatedAt ) :. forwardedFromRow :. ( timedTTL , timedDeleteAt , itemLive , BI userMention ) :. ( fileId_ , fileName_ , fileSize_ , filePath , fileKey , fileNonce , fileStatus_ , fileProtocol_ ) ) :. quoteRow ) =
2023-06-18 10:20:11 +01:00
chatItem $ fromRight invalid $ dbParseACIContent itemContentText
where
invalid = ACIContent msgDir $ CIInvalidJSON itemContentText
chatItem itemContent = case ( itemContent , itemStatus , fileStatus_ ) of
( ACIContent SMDSnd ciContent , ACIStatus SMDSnd ciStatus , Just ( AFS SMDSnd fileStatus ) ) ->
Right $ cItem SMDSnd CIDirectSnd ciStatus ciContent ( maybeCIFile fileStatus )
( ACIContent SMDSnd ciContent , ACIStatus SMDSnd ciStatus , Nothing ) ->
Right $ cItem SMDSnd CIDirectSnd ciStatus ciContent Nothing
( ACIContent SMDRcv ciContent , ACIStatus SMDRcv ciStatus , Just ( AFS SMDRcv fileStatus ) ) ->
Right $ cItem SMDRcv CIDirectRcv ciStatus ciContent ( maybeCIFile fileStatus )
( ACIContent SMDRcv ciContent , ACIStatus SMDRcv ciStatus , Nothing ) ->
Right $ cItem SMDRcv CIDirectRcv ciStatus ciContent Nothing
_ -> badItem
maybeCIFile :: CIFileStatus d -> Maybe ( CIFile d )
maybeCIFile fileStatus =
case ( fileId_ , fileName_ , fileSize_ , fileProtocol_ ) of
2023-09-01 19:43:27 +01:00
( Just fileId , Just fileName , Just fileSize , Just fileProtocol ) ->
let cfArgs = CFArgs <$> fileKey <*> fileNonce
fileSource = ( ` CryptoFile ` cfArgs ) <$> filePath
in Just CIFile { fileId , fileName , fileSize , fileSource , fileStatus , fileProtocol }
2023-06-18 10:20:11 +01:00
_ -> Nothing
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTDirect d -> CIStatus d -> CIContent d -> Maybe ( CIFile d ) -> CChatItem 'CTDirect
cItem d chatDir ciStatus content file =
2025-01-29 13:04:48 +00:00
CChatItem d ChatItem { chatDir , meta = ciMeta content ciStatus , content , mentions = M . empty , formattedText = parseMaybeMarkdownList itemText , quotedItem = toDirectQuote quoteRow , reactions = [] , file }
2024-02-19 15:17:14 +04:00
badItem = Left $ SEBadChatItem itemId ( Just itemTs )
2023-06-18 10:20:11 +01:00
ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTDirect d
ciMeta content status =
2023-10-11 19:10:38 +01:00
let itemDeleted' = case itemDeleted of
DBCINotDeleted -> Nothing
2024-05-24 21:09:21 +01:00
_ -> Just ( CIDeleted @ 'CTDirect deletedTs )
2025-01-10 15:27:29 +04:00
itemEdited' = maybe False unBI itemEdited
2024-04-09 13:02:59 +01:00
itemForwarded = toCIForwardedFrom forwardedFromRow
2025-06-23 14:42:00 +01:00
in mkCIMeta itemId content itemText status ( unBI <$> sentViaProxy ) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed ( unBI <$> itemLive ) userMention currentTs itemTs Nothing False createdAt updatedAt
2023-06-18 10:20:11 +01:00
ciTimed :: Maybe CITimed
ciTimed = timedTTL >>= \ ttl -> Just CITimed { ttl , deleteAt = timedDeleteAt }
2024-04-09 13:02:59 +01:00
toCIForwardedFrom :: ChatItemForwardedFromRow -> Maybe CIForwardedFrom
toCIForwardedFrom ( fwdFromTag , fwdFromChatName , fwdFromMsgDir , fwdFromContactId , fwdFromGroupId , fwdFromChatItemId ) =
case ( fwdFromTag , fwdFromChatName , fwdFromMsgDir , fwdFromContactId , fwdFromGroupId , fwdFromChatItemId ) of
( Just CIFFUnknown_ , Nothing , Nothing , Nothing , Nothing , Nothing ) -> Just CIFFUnknown
2024-04-13 14:52:39 +04:00
( Just CIFFContact_ , Just chatName , Just msgDir , contactId , Nothing , ciId ) -> Just $ CIFFContact chatName msgDir contactId ciId
( Just CIFFGroup_ , Just chatName , Just msgDir , Nothing , groupId , ciId ) -> Just $ CIFFGroup chatName msgDir groupId ciId
2024-04-09 13:02:59 +01:00
_ -> Nothing
2023-06-18 10:20:11 +01:00
type GroupQuoteRow = QuoteRow :. MaybeGroupMemberRow
toGroupQuote :: QuoteRow -> Maybe GroupMember -> Maybe ( CIQuote 'CTGroup )
toGroupQuote qr @ ( _ , _ , _ , _ , quotedSent ) quotedMember_ = toQuote qr $ direction quotedSent quotedMember_
where
2025-01-10 15:27:29 +04:00
direction ( Just ( BI True ) ) _ = Just CIQGroupSnd
direction ( Just ( BI False ) ) ( Just member ) = Just . CIQGroupRcv $ Just member
direction ( Just ( BI False ) ) Nothing = Just $ CIQGroupRcv Nothing
2023-06-18 10:20:11 +01:00
direction _ _ = Nothing
-- this function can be changed so it never fails, not only avoid failure on invalid json
2025-04-02 07:57:18 +00:00
toGroupChatItem ::
UTCTime ->
Int64 ->
ChatItemRow
2025-06-23 14:42:00 +01:00
:. ( Maybe GroupMemberId , BoolInt )
2025-04-02 07:57:18 +00:00
:. MaybeGroupMemberRow
:. GroupQuoteRow
:. MaybeGroupMemberRow ->
Either StoreError ( CChatItem 'CTGroup )
toGroupChatItem
currentTs
userContactId
( ( ( itemId , itemTs , AMsgDirection msgDir , itemContentText , itemText , itemStatus , sentViaProxy , sharedMsgId )
:. ( itemDeleted , deletedTs , itemEdited , createdAt , updatedAt )
:. forwardedFromRow
:. ( timedTTL , timedDeleteAt , itemLive , BI userMention )
:. ( fileId_ , fileName_ , fileSize_ , filePath , fileKey , fileNonce , fileStatus_ , fileProtocol_ )
)
2025-06-23 14:42:00 +01:00
:. ( forwardedByMember , BI showGroupAsSender )
2025-04-02 07:57:18 +00:00
:. memberRow_
:. ( quoteRow :. quotedMemberRow_ )
:. deletedByGroupMemberRow_
) = do
chatItem $ fromRight invalid $ dbParseACIContent itemContentText
where
member_ = toMaybeGroupMember userContactId memberRow_
quotedMember_ = toMaybeGroupMember userContactId quotedMemberRow_
deletedByGroupMember_ = toMaybeGroupMember userContactId deletedByGroupMemberRow_
invalid = ACIContent msgDir $ CIInvalidJSON itemContentText
chatItem itemContent = case ( itemContent , itemStatus , member_ , fileStatus_ ) of
( ACIContent SMDSnd ciContent , ACIStatus SMDSnd ciStatus , _ , Just ( AFS SMDSnd fileStatus ) ) ->
Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent ( maybeCIFile fileStatus )
( ACIContent SMDSnd ciContent , ACIStatus SMDSnd ciStatus , _ , Nothing ) ->
Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent Nothing
( ACIContent SMDRcv ciContent , ACIStatus SMDRcv ciStatus , Just member , Just ( AFS SMDRcv fileStatus ) ) ->
Right $ cItem SMDRcv ( CIGroupRcv member ) ciStatus ciContent ( maybeCIFile fileStatus )
( ACIContent SMDRcv ciContent , ACIStatus SMDRcv ciStatus , Just member , Nothing ) ->
Right $ cItem SMDRcv ( CIGroupRcv member ) ciStatus ciContent Nothing
_ -> badItem
maybeCIFile :: CIFileStatus d -> Maybe ( CIFile d )
maybeCIFile fileStatus =
case ( fileId_ , fileName_ , fileSize_ , fileProtocol_ ) of
( Just fileId , Just fileName , Just fileSize , Just fileProtocol ) ->
let cfArgs = CFArgs <$> fileKey <*> fileNonce
fileSource = ( ` CryptoFile ` cfArgs ) <$> filePath
in Just CIFile { fileId , fileName , fileSize , fileSource , fileStatus , fileProtocol }
_ -> Nothing
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTGroup d -> CIStatus d -> CIContent d -> Maybe ( CIFile d ) -> CChatItem 'CTGroup
cItem d chatDir ciStatus content file =
CChatItem d ChatItem { chatDir , meta = ciMeta content ciStatus , content , mentions = M . empty , formattedText = parseMaybeMarkdownList itemText , quotedItem = toGroupQuote quoteRow quotedMember_ , reactions = [] , file }
badItem = Left $ SEBadChatItem itemId ( Just itemTs )
ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTGroup d
ciMeta content status =
let itemDeleted' = case itemDeleted of
DBCINotDeleted -> Nothing
DBCIBlocked -> Just ( CIBlocked deletedTs )
DBCIBlockedByAdmin -> Just ( CIBlockedByAdmin deletedTs )
_ -> Just ( maybe ( CIDeleted @ 'CTGroup deletedTs ) ( CIModerated deletedTs ) deletedByGroupMember_ )
itemEdited' = maybe False unBI itemEdited
itemForwarded = toCIForwardedFrom forwardedFromRow
2025-06-23 14:42:00 +01:00
in mkCIMeta itemId content itemText status ( unBI <$> sentViaProxy ) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed ( unBI <$> itemLive ) userMention currentTs itemTs forwardedByMember showGroupAsSender createdAt updatedAt
2025-04-02 07:57:18 +00:00
ciTimed :: Maybe CITimed
ciTimed = timedTTL >>= \ ttl -> Just CITimed { ttl , deleteAt = timedDeleteAt }
2023-06-18 10:20:11 +01:00
2024-04-22 20:46:48 +04:00
getAllChatItems :: DB . Connection -> VersionRangeChat -> User -> ChatPagination -> Maybe String -> ExceptT StoreError IO [ AChatItem ]
2023-12-24 13:27:51 +00:00
getAllChatItems db vr user @ User { userId } pagination search_ = do
2023-06-18 10:20:11 +01:00
itemRefs <-
rights . map toChatItemRef <$> case pagination of
CPLast count -> liftIO $ getAllChatItemsLast_ count
CPAfter afterId count -> liftIO . getAllChatItemsAfter_ afterId count . aChatItemTs =<< getAChatItem_ afterId
CPBefore beforeId count -> liftIO . getAllChatItemsBefore_ beforeId count . aChatItemTs =<< getAChatItem_ beforeId
2024-11-14 08:34:25 +00:00
CPAround aroundId count -> liftIO . getAllChatItemsAround_ aroundId count . aChatItemTs =<< getAChatItem_ aroundId
CPInitial count -> do
unless ( null search ) $ throwError $ SEInternalError " initial chat pagination doesn't support search "
liftIO getFirstUnreadItemId_ >>= \ case
Just itemId -> liftIO . getAllChatItemsAround_ itemId count . aChatItemTs =<< getAChatItem_ itemId
Nothing -> liftIO $ getAllChatItemsLast_ count
2024-09-25 14:16:32 +04:00
mapM ( uncurry ( getAChatItem db vr user ) ) itemRefs
2023-06-18 10:20:11 +01:00
where
search = fromMaybe " " search_
getAChatItem_ itemId = do
chatRef <- getChatRefViaItemId db user itemId
2023-12-24 13:27:51 +00:00
getAChatItem db vr user chatRef itemId
2023-06-18 10:20:11 +01:00
getAllChatItemsLast_ count =
reverse
<$> DB . query
db
[ sql |
2025-04-21 15:17:21 +00:00
SELECT chat_item_id , contact_id , group_id , group_scope_tag , group_scope_group_member_id , note_folder_id
2023-06-18 10:20:11 +01:00
FROM chat_items
2025-01-10 15:27:29 +04:00
WHERE user_id = ? AND LOWER ( item_text ) LIKE '%' || LOWER ( ? ) || '%'
2023-06-18 10:20:11 +01:00
ORDER BY item_ts DESC , chat_item_id DESC
LIMIT ?
| ]
( userId , search , count )
getAllChatItemsAfter_ afterId count afterTs =
DB . query
db
[ sql |
2025-04-21 15:17:21 +00:00
SELECT chat_item_id , contact_id , group_id , group_scope_tag , group_scope_group_member_id , note_folder_id
2023-06-18 10:20:11 +01:00
FROM chat_items
2025-01-10 15:27:29 +04:00
WHERE user_id = ? AND LOWER ( item_text ) LIKE '%' || LOWER ( ? ) || '%'
2023-06-18 10:20:11 +01:00
AND ( item_ts > ? OR ( item_ts = ? AND chat_item_id > ? ) )
ORDER BY item_ts ASC , chat_item_id ASC
LIMIT ?
| ]
( userId , search , afterTs , afterTs , afterId , count )
getAllChatItemsBefore_ beforeId count beforeTs =
reverse
<$> DB . query
db
[ sql |
2025-04-21 15:17:21 +00:00
SELECT chat_item_id , contact_id , group_id , group_scope_tag , group_scope_group_member_id , note_folder_id
2023-06-18 10:20:11 +01:00
FROM chat_items
2025-01-10 15:27:29 +04:00
WHERE user_id = ? AND LOWER ( item_text ) LIKE '%' || LOWER ( ? ) || '%'
2023-06-18 10:20:11 +01:00
AND ( item_ts < ? OR ( item_ts = ? AND chat_item_id < ? ) )
ORDER BY item_ts DESC , chat_item_id DESC
LIMIT ?
| ]
( userId , search , beforeTs , beforeTs , beforeId , count )
2024-11-14 08:34:25 +00:00
getChatItem chatId =
DB . query
db
[ sql |
2025-04-21 15:17:21 +00:00
SELECT chat_item_id , contact_id , group_id , group_scope_tag , group_scope_group_member_id , note_folder_id
2024-11-14 08:34:25 +00:00
FROM chat_items
WHERE chat_item_id = ?
| ]
( Only chatId )
getAllChatItemsAround_ aroundId count aroundTs = do
itemsBefore <- getAllChatItemsBefore_ aroundId count aroundTs
item <- getChatItem aroundId
itemsAfter <- getAllChatItemsAfter_ aroundId count aroundTs
pure $ itemsBefore <> item <> itemsAfter
getFirstUnreadItemId_ =
fmap join . maybeFirstRow fromOnly $
DB . query
db
[ sql |
SELECT MIN ( chat_item_id )
FROM chat_items
WHERE user_id = ? AND item_status = ?
| ]
( userId , CISRcvNew )
2023-06-18 10:20:11 +01:00
2024-09-17 23:50:26 +04:00
getChatItemIdsByAgentMsgId :: DB . Connection -> Int64 -> AgentMsgId -> IO [ ChatItemId ]
getChatItemIdsByAgentMsgId db connId msgId =
map fromOnly
<$> DB . query
2023-06-18 10:20:11 +01:00
db
[ sql |
SELECT chat_item_id
FROM chat_item_messages
2024-09-17 23:50:26 +04:00
WHERE message_id IN (
2023-06-18 10:20:11 +01:00
SELECT message_id
FROM msg_deliveries
WHERE connection_id = ? AND agent_msg_id = ?
)
| ]
( connId , msgId )
2023-10-18 10:19:24 +01:00
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
2023-06-18 10:20:11 +01:00
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 } }
2024-05-15 15:30:05 +04:00
setDirectSndChatItemViaProxy :: DB . Connection -> User -> Contact -> ChatItem 'CTDirect 'MDSnd -> Bool -> IO ( ChatItem 'CTDirect 'MDSnd )
setDirectSndChatItemViaProxy db User { userId } Contact { contactId } ci viaProxy = do
2025-01-10 15:27:29 +04:00
DB . execute db " UPDATE chat_items SET via_proxy = ? WHERE user_id = ? AND contact_id = ? AND chat_item_id = ? " ( BI viaProxy , userId , contactId , chatItemId' ci )
2024-05-15 15:30:05 +04:00
pure ci { meta = ( meta ci ) { sentViaProxy = Just viaProxy } }
2024-04-25 12:37:05 +04:00
updateDirectChatItem :: MsgDirectionI d => DB . Connection -> User -> Contact -> ChatItemId -> CIContent d -> Bool -> Bool -> Maybe CITimed -> Maybe MessageId -> ExceptT StoreError IO ( ChatItem 'CTDirect d )
updateDirectChatItem db user ct @ Contact { contactId } itemId newContent edited live timed_ msgId_ = do
2023-10-18 10:19:24 +01:00
ci <- liftEither . correctDir =<< getDirectCIWithReactions db user ct itemId
2024-04-25 12:37:05 +04:00
liftIO $ updateDirectChatItem' db user contactId ci newContent edited live timed_ msgId_
2023-10-18 10:19:24 +01:00
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
2023-06-18 10:20:11 +01:00
2024-04-25 12:37:05 +04:00
updateDirectChatItem' :: forall d . MsgDirectionI d => DB . Connection -> User -> Int64 -> ChatItem 'CTDirect d -> CIContent d -> Bool -> Bool -> Maybe CITimed -> Maybe MessageId -> IO ( ChatItem 'CTDirect d )
updateDirectChatItem' db User { userId } contactId ci newContent edited live timed_ msgId_ = do
2023-06-18 10:20:11 +01:00
currentTs <- liftIO getCurrentTime
2024-04-25 12:37:05 +04:00
let ci' = updatedChatItem ci newContent edited live timed_ currentTs
2023-06-18 10:20:11 +01:00
liftIO $ updateDirectChatItem_ db userId contactId ci' msgId_
pure ci'
2024-04-25 12:37:05 +04:00
updatedChatItem :: ChatItem c d -> CIContent d -> Bool -> Bool -> Maybe CITimed -> UTCTime -> ChatItem c d
updatedChatItem ci @ ChatItem { meta = meta @ CIMeta { itemStatus , itemEdited , itemTimed , itemLive } } newContent edited live timed_ currentTs =
2023-06-18 10:20:11 +01:00
let newText = ciContentToText newContent
2024-04-25 12:37:05 +04:00
edited' = itemEdited || edited
2023-06-18 10:20:11 +01:00
live' = ( live && ) <$> itemLive
2024-04-25 12:37:05 +04:00
timed' = case timed_ of
Just timed -> Just timed
Nothing -> case ( itemStatus , itemTimed , itemLive , live ) of
( CISRcvNew , _ , _ , _ ) -> itemTimed
( _ , Just CITimed { ttl , deleteAt = Nothing } , Just True , False ) ->
-- timed item, sent or read, not set for deletion, was live, now not live
let deleteAt' = addUTCTime ( realToFrac ttl ) currentTs
in Just CITimed { ttl , deleteAt = Just deleteAt' }
_ -> itemTimed
2023-06-18 10:20:11 +01:00
in ci { content = newContent , meta = meta { itemText = newText , itemEdited = edited' , itemTimed = timed' , itemLive = live' } , formattedText = parseMaybeMarkdownList newText }
-- this function assumes that direct item with correct chat direction already exists,
-- it should be checked before calling it
updateDirectChatItem_ :: forall d . MsgDirectionI d => DB . Connection -> UserId -> Int64 -> ChatItem 'CTDirect d -> Maybe MessageId -> IO ()
updateDirectChatItem_ db userId contactId ChatItem { meta , content } msgId_ = do
let CIMeta { itemId , itemText , itemStatus , itemDeleted , itemEdited , itemTimed , itemLive , updatedAt } = meta
itemDeleted' = isJust itemDeleted
itemDeletedTs' = itemDeletedTs =<< itemDeleted
DB . execute
db
[ sql |
UPDATE chat_items
SET item_content = ? , item_text = ? , item_status = ? , item_deleted = ? , item_deleted_ts = ? , item_edited = ? , item_live = ? , updated_at = ? , timed_ttl = ? , timed_delete_at = ?
WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?
| ]
2025-01-10 15:27:29 +04:00
( ( content , itemText , itemStatus , BI itemDeleted' , itemDeletedTs' , BI itemEdited , BI <$> itemLive , updatedAt ) :. ciTimedRow itemTimed :. ( userId , contactId , itemId ) )
2023-06-18 10:20:11 +01:00
forM_ msgId_ $ \ msgId -> liftIO $ insertChatItemMessage_ db itemId msgId updatedAt
addInitialAndNewCIVersions :: DB . Connection -> ChatItemId -> ( UTCTime , MsgContent ) -> ( UTCTime , MsgContent ) -> IO ()
addInitialAndNewCIVersions db itemId ( initialTs , initialMC ) ( newTs , newMC ) = do
versionsCount <- getChatItemVersionsCount db itemId
when ( versionsCount == 0 ) $
createChatItemVersion db itemId initialTs initialMC
createChatItemVersion db itemId newTs newMC
getChatItemVersionsCount :: DB . Connection -> ChatItemId -> IO Int
getChatItemVersionsCount db itemId = do
count <-
maybeFirstRow fromOnly $
DB . query db " SELECT COUNT(1) FROM chat_item_versions WHERE chat_item_id = ? " ( Only itemId )
pure $ fromMaybe 0 count
createChatItemVersion :: DB . Connection -> ChatItemId -> UTCTime -> MsgContent -> IO ()
createChatItemVersion db itemId itemVersionTs msgContent =
DB . execute
db
[ sql |
INSERT INTO chat_item_versions ( chat_item_id , msg_content , item_version_ts )
VALUES ( ? , ? , ? )
| ]
2025-01-08 09:42:26 +00:00
( itemId , MCText $ msgContentText msgContent , itemVersionTs )
2023-06-18 10:20:11 +01:00
2023-10-11 19:10:38 +01:00
deleteDirectChatItem :: DB . Connection -> User -> Contact -> ChatItem 'CTDirect d -> IO ()
deleteDirectChatItem db User { userId } Contact { contactId } ci = do
2023-06-18 10:20:11 +01:00
let itemId = chatItemId' ci
deleteChatItemMessages_ db itemId
deleteChatItemVersions_ db itemId
deleteDirectCIReactions_ db contactId ci
DB . execute
db
[ sql |
DELETE FROM chat_items
WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?
| ]
( userId , contactId , itemId )
deleteChatItemMessages_ :: DB . Connection -> ChatItemId -> IO ()
2025-03-07 07:47:32 +00:00
deleteChatItemMessages_ db itemId = DB . execute db deleteChatItemMessagesQuery ( Only itemId )
deleteChatItemMessagesQuery :: Query
deleteChatItemMessagesQuery =
[ sql |
DELETE FROM messages
WHERE message_id IN (
SELECT message_id
FROM chat_item_messages
WHERE chat_item_id = ?
)
| ]
2023-06-18 10:20:11 +01:00
deleteChatItemVersions_ :: DB . Connection -> ChatItemId -> IO ()
deleteChatItemVersions_ db itemId =
DB . execute db " DELETE FROM chat_item_versions WHERE chat_item_id = ? " ( Only itemId )
2024-07-30 22:59:47 +01:00
markDirectChatItemDeleted :: DB . Connection -> User -> Contact -> ChatItem 'CTDirect d -> UTCTime -> IO ( ChatItem 'CTDirect d )
markDirectChatItemDeleted db User { userId } Contact { contactId } ci @ ChatItem { meta } deletedTs = do
2023-06-18 10:20:11 +01:00
currentTs <- liftIO getCurrentTime
let itemId = chatItemId' ci
DB . execute
db
[ sql |
UPDATE chat_items
2023-10-11 19:10:38 +01:00
SET item_deleted = ? , item_deleted_ts = ? , updated_at = ?
2023-06-18 10:20:11 +01:00
WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?
| ]
2023-10-11 19:10:38 +01:00
( DBCIDeleted , deletedTs , currentTs , userId , contactId , itemId )
2024-08-01 18:56:41 +04:00
pure ci { meta = meta { itemDeleted = Just $ CIDeleted $ Just deletedTs , editable = False , deletable = False } }
2023-06-18 10:20:11 +01:00
getDirectChatItemBySharedMsgId :: DB . Connection -> User -> ContactId -> SharedMsgId -> ExceptT StoreError IO ( CChatItem 'CTDirect )
getDirectChatItemBySharedMsgId db user @ User { userId } contactId sharedMsgId = do
itemId <- getDirectChatItemIdBySharedMsgId_ db userId contactId sharedMsgId
getDirectChatItem db user contactId itemId
2024-09-17 23:50:26 +04:00
getDirectChatItemsByAgentMsgId :: DB . Connection -> User -> ContactId -> Int64 -> AgentMsgId -> IO [ CChatItem 'CTDirect ]
getDirectChatItemsByAgentMsgId db user contactId connId msgId = do
itemIds <- getChatItemIdsByAgentMsgId db connId msgId
catMaybes <$> mapM ( fmap eitherToMaybe . runExceptT . getDirectChatItem db user contactId ) itemIds
2023-06-18 10:20:11 +01:00
getDirectChatItemIdBySharedMsgId_ :: DB . Connection -> UserId -> Int64 -> SharedMsgId -> ExceptT StoreError IO Int64
getDirectChatItemIdBySharedMsgId_ db userId contactId sharedMsgId =
ExceptT . firstRow fromOnly ( SEChatItemSharedMsgIdNotFound sharedMsgId ) $
DB . query
db
[ sql |
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND contact_id = ? AND shared_msg_id = ?
ORDER BY chat_item_id DESC
LIMIT 1
| ]
( userId , contactId , sharedMsgId )
getDirectChatItem :: DB . Connection -> User -> Int64 -> ChatItemId -> ExceptT StoreError IO ( CChatItem 'CTDirect )
getDirectChatItem db User { userId } contactId itemId = ExceptT $ do
currentTs <- getCurrentTime
2023-10-18 10:19:24 +01:00
firstRow' ( toDirectChatItem currentTs ) ( SEChatItemNotFound itemId ) getItem
2023-06-18 10:20:11 +01:00
where
getItem =
DB . query
db
[ sql |
SELECT
-- ChatItem
2024-05-15 15:30:05 +04:00
i . chat_item_id , i . item_ts , i . item_sent , i . item_content , i . item_text , i . item_status , i . via_proxy , i . shared_msg_id ,
2024-04-09 13:02:59 +01:00
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 ,
2025-01-29 13:04:48 +00:00
i . timed_ttl , i . timed_delete_at , i . item_live , i . user_mention ,
2023-06-18 10:20:11 +01:00
-- CIFile
2023-09-01 19:43:27 +01:00
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 ,
2023-06-18 10:20:11 +01:00
-- DirectQuote
ri . chat_item_id , i . quoted_shared_msg_id , i . quoted_sent_at , i . quoted_content , i . quoted_sent
FROM chat_items i
LEFT JOIN files f ON f . chat_item_id = i . chat_item_id
LEFT JOIN chat_items ri ON ri . user_id = i . user_id AND ri . contact_id = i . contact_id AND ri . shared_msg_id = i . quoted_shared_msg_id
WHERE i . user_id = ? AND i . contact_id = ? AND i . chat_item_id = ?
| ]
( userId , contactId , itemId )
getDirectChatItemIdByText :: DB . Connection -> UserId -> Int64 -> SMsgDirection d -> Text -> ExceptT StoreError IO ChatItemId
getDirectChatItemIdByText db userId contactId msgDir quotedMsg =
ExceptT . firstRow fromOnly ( SEChatItemNotFoundByText quotedMsg ) $
DB . query
db
[ sql |
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND contact_id = ? AND item_sent = ? AND item_text LIKE ?
ORDER BY chat_item_id DESC
LIMIT 1
| ]
( userId , contactId , msgDir , quotedMsg <> " % " )
getDirectChatItemIdByText' :: DB . Connection -> User -> ContactId -> Text -> ExceptT StoreError IO ChatItemId
getDirectChatItemIdByText' db User { userId } contactId msg =
ExceptT . firstRow fromOnly ( SEChatItemNotFoundByText msg ) $
DB . query
db
[ sql |
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND contact_id = ? AND item_text LIKE ?
ORDER BY chat_item_id DESC
LIMIT 1
| ]
( userId , contactId , msg <> " % " )
2023-10-18 10:19:24 +01:00
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
2023-07-26 14:49:35 +04:00
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 } }
2023-10-18 10:19:24 +01:00
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 )
2025-01-29 13:04:48 +00:00
groupCIWithReactions db g cci @ ( CChatItem md ci @ ChatItem { meta = CIMeta { itemId , itemSharedMsgId } } ) = do
mentions <- getGroupCIMentions db itemId
case itemSharedMsgId of
Just sharedMsgId -> do
let GroupMember { memberId } = chatItemMember g ci
reactions <- getGroupCIReactions db g memberId sharedMsgId
pure $ CChatItem md ci { reactions , mentions }
Nothing -> pure $ if null mentions then cci else CChatItem md ci { mentions }
2023-10-18 10:19:24 +01:00
2024-04-25 12:37:05 +04:00
updateGroupChatItem :: MsgDirectionI d => DB . Connection -> User -> Int64 -> ChatItem 'CTGroup d -> CIContent d -> Bool -> Bool -> Maybe MessageId -> IO ( ChatItem 'CTGroup d )
updateGroupChatItem db user groupId ci newContent edited live msgId_ = do
2023-06-18 10:20:11 +01:00
currentTs <- liftIO getCurrentTime
2024-04-25 12:37:05 +04:00
let ci' = updatedChatItem ci newContent edited live Nothing currentTs
2023-06-18 10:20:11 +01:00
liftIO $ updateGroupChatItem_ db user groupId ci' msgId_
pure ci'
-- this function assumes that the group item with correct chat direction already exists,
-- it should be checked before calling it
2023-10-18 10:19:24 +01:00
updateGroupChatItem_ :: MsgDirectionI d => DB . Connection -> User -> Int64 -> ChatItem 'CTGroup d -> Maybe MessageId -> IO ()
2023-06-18 10:20:11 +01:00
updateGroupChatItem_ db User { userId } groupId ChatItem { content , meta } msgId_ = do
let CIMeta { itemId , itemText , itemStatus , itemDeleted , itemEdited , itemTimed , itemLive , updatedAt } = meta
itemDeleted' = isJust itemDeleted
itemDeletedTs' = itemDeletedTs =<< itemDeleted
DB . execute
db
[ sql |
UPDATE chat_items
SET item_content = ? , item_text = ? , item_status = ? , item_deleted = ? , item_deleted_ts = ? , item_edited = ? , item_live = ? , updated_at = ? , timed_ttl = ? , timed_delete_at = ?
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
| ]
2025-01-10 15:27:29 +04:00
( ( content , itemText , itemStatus , BI itemDeleted' , itemDeletedTs' , BI itemEdited , BI <$> itemLive , updatedAt ) :. ciTimedRow itemTimed :. ( userId , groupId , itemId ) )
2023-06-18 10:20:11 +01:00
forM_ msgId_ $ \ msgId -> insertChatItemMessage_ db itemId msgId updatedAt
2025-01-30 10:06:26 +00:00
createGroupCIMentions :: forall d . DB . Connection -> GroupInfo -> ChatItem 'CTGroup d -> Map MemberName CIMention -> IO ( ChatItem 'CTGroup d )
2025-01-29 13:04:48 +00:00
createGroupCIMentions db GroupInfo { groupId } ci mentions = do
DB . executeMany db " INSERT INTO chat_item_mentions (chat_item_id, group_id, member_id, display_name) VALUES (?, ?, ?, ?) " rows
pure ( ci :: ChatItem 'CTGroup d ) { mentions }
where
2025-01-30 10:06:26 +00:00
rows = map ( \ ( name , CIMention { memberId } ) -> ( ciId , groupId , memberId , name ) ) $ M . assocs mentions
2025-01-29 13:04:48 +00:00
ciId = chatItemId' ci
2025-01-30 10:06:26 +00:00
updateGroupCIMentions :: DB . Connection -> GroupInfo -> ChatItem 'CTGroup d -> Map MemberName CIMention -> IO ( ChatItem 'CTGroup d )
2025-01-29 13:04:48 +00:00
updateGroupCIMentions db g ci @ ChatItem { mentions } mentions'
| mentions' == mentions = pure ci
| otherwise = do
unless ( null mentions ) $ deleteMentions
if null mentions'
then pure ci
2025-03-03 18:57:29 +00:00
else -- This is a fallback for the error that should not happen in practice.
2025-02-03 08:55:46 +00:00
-- In theory, it may happen in item mentions in database are different from item record.
2025-03-03 18:57:29 +00:00
createMentions ` E . catch ` \ e -> if constraintError e then deleteMentions >> createMentions else E . throwIO e
2025-01-29 13:04:48 +00:00
where
deleteMentions = DB . execute db " DELETE FROM chat_item_mentions WHERE chat_item_id = ? " ( Only $ chatItemId' ci )
2025-02-03 08:55:46 +00:00
createMentions = createGroupCIMentions db g ci mentions'
2025-01-29 13:04:48 +00:00
2023-10-11 19:10:38 +01:00
deleteGroupChatItem :: DB . Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> IO ()
deleteGroupChatItem db User { userId } g @ GroupInfo { groupId } ci = do
2023-06-18 10:20:11 +01:00
let itemId = chatItemId' ci
deleteChatItemMessages_ db itemId
deleteChatItemVersions_ db itemId
deleteGroupCIReactions_ db g ci
DB . execute
db
[ sql |
DELETE FROM chat_items
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
| ]
( userId , groupId , itemId )
2023-10-11 19:10:38 +01:00
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
2023-06-18 10:20:11 +01:00
currentTs <- getCurrentTime
2023-10-11 19:10:38 +01:00
let toContent = msgDirToModeratedContent_ $ msgDirection @ d
2023-06-18 10:20:11 +01:00
toText = ciModeratedText
itemId = chatItemId' ci
deleteChatItemMessages_ db itemId
deleteChatItemVersions_ db itemId
liftIO $
DB . execute
db
[ sql |
UPDATE chat_items
SET item_deleted = 1 , item_deleted_ts = ? , item_deleted_by_group_member_id = ? , item_content = ? , item_text = ? , updated_at = ?
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
| ]
( deletedTs , groupMemberId , toContent , toText , currentTs , userId , groupId , itemId )
2024-07-30 22:59:47 +01:00
pure ci { content = toContent , meta = ( meta ci ) { itemText = toText , itemDeleted = Just ( CIModerated ( Just deletedTs ) m ) , editable = False , deletable = False } , formattedText = Nothing }
2024-01-19 17:57:04 +04:00
2025-03-07 07:47:32 +00:00
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
itemIds <- updateCIs =<< getCurrentTime
2025-06-08 18:27:42 +01:00
# if defined ( dbPostgres )
let inItemIds = Only $ In ( map fromOnly itemIds )
DB . execute db " DELETE FROM messages WHERE message_id IN (SELECT message_id FROM chat_item_messages WHERE chat_item_id IN ?) " inItemIds
DB . execute db " DELETE FROM chat_item_versions WHERE chat_item_id IN ? " inItemIds
# else
2025-03-07 07:47:32 +00:00
DB . executeMany db deleteChatItemMessagesQuery itemIds
DB . executeMany db " DELETE FROM chat_item_versions WHERE chat_item_id = ? " itemIds
2025-06-08 18:27:42 +01:00
# endif
2025-03-07 07:47:32 +00:00
where
memId = groupMemberId' member
updateQuery =
[ sql |
UPDATE chat_items
SET item_deleted = 1 , item_deleted_ts = ? , item_deleted_by_group_member_id = ? , item_content = ? , item_text = ? , updated_at = ?
WHERE user_id = ? AND group_id = ?
| ]
updateCIs :: UTCTime -> IO [ Only Int64 ]
updateCIs currentTs
| memId == groupMemberId' membership =
DB . query
db
( updateQuery <> " AND group_member_id IS NULL AND item_sent = 1 RETURNING chat_item_id " )
( columns :. ( userId , groupId ) )
| otherwise =
DB . query
db
( updateQuery <> " AND group_member_id = ? RETURNING chat_item_id " )
( columns :. ( userId , groupId , memId ) )
where
columns = ( deletedTs , groupMemberId' byGroupMember , msgDirToModeratedContent_ md , ciModeratedText , currentTs )
2024-01-19 17:57:04 +04:00
updateGroupCIBlockedByAdmin :: DB . Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> UTCTime -> IO ( ChatItem 'CTGroup d )
updateGroupCIBlockedByAdmin db User { userId } GroupInfo { groupId } ci deletedTs = do
currentTs <- getCurrentTime
let itemId = chatItemId' ci
deleteChatItemMessages_ db itemId
deleteChatItemVersions_ db itemId
liftIO $
DB . execute
db
[ sql |
UPDATE chat_items
SET item_deleted = ? , item_deleted_ts = ? , updated_at = ?
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
| ]
( DBCIBlockedByAdmin , deletedTs , currentTs , userId , groupId , itemId )
2024-04-12 12:55:04 +04:00
pure $ ci { meta = ( meta ci ) { itemDeleted = Just ( CIBlockedByAdmin $ Just deletedTs ) , editable = False , deletable = False } , formattedText = Nothing }
2023-06-18 10:20:11 +01:00
2023-10-11 19:10:38 +01:00
pattern DBCINotDeleted :: Int
pattern DBCINotDeleted = 0
pattern DBCIDeleted :: Int
pattern DBCIDeleted = 1
pattern DBCIBlocked :: Int
pattern DBCIBlocked = 2
2024-01-19 17:57:04 +04:00
pattern DBCIBlockedByAdmin :: Int
pattern DBCIBlockedByAdmin = 3
2024-07-30 22:59:47 +01:00
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
2023-06-18 10:20:11 +01:00
currentTs <- liftIO getCurrentTime
let itemId = chatItemId' ci
2023-10-11 19:10:38 +01:00
( deletedByGroupMemberId , itemDeleted ) = case byGroupMember_ of
Just m @ GroupMember { groupMemberId } -> ( Just groupMemberId , Just $ CIModerated ( Just deletedTs ) m )
2024-05-24 21:09:21 +01:00
_ -> ( Nothing , Just $ CIDeleted @ 'CTGroup ( Just deletedTs ) )
2023-06-18 10:20:11 +01:00
DB . execute
db
[ sql |
UPDATE chat_items
2023-10-11 19:10:38 +01:00
SET item_deleted = ? , item_deleted_ts = ? , item_deleted_by_group_member_id = ? , updated_at = ?
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
| ]
( DBCIDeleted , deletedTs , deletedByGroupMemberId , currentTs , userId , groupId , itemId )
2024-08-01 18:56:41 +04:00
pure ci { meta = meta { itemDeleted , editable = False , deletable = False } }
2023-10-11 19:10:38 +01:00
2025-03-07 07:47:32 +00:00
markMemberCIsDeleted :: DB . Connection -> User -> GroupInfo -> GroupMember -> GroupMember -> UTCTime -> IO ()
markMemberCIsDeleted db User { userId } GroupInfo { groupId , membership } member byGroupMember deletedTs =
updateCIs =<< getCurrentTime
where
memId = groupMemberId' member
updateQuery =
[ sql |
UPDATE chat_items
SET item_deleted = ? , item_deleted_ts = ? , item_deleted_by_group_member_id = ? , updated_at = ?
WHERE user_id = ? AND group_id = ?
| ]
updateCIs currentTs
| memId == groupMemberId' membership =
DB . execute
db
( updateQuery <> " AND group_member_id IS NULL AND item_sent = 1 " )
( columns :. ( userId , groupId ) )
| otherwise =
DB . execute
db
( updateQuery <> " AND group_member_id = ? " )
( columns :. ( userId , groupId , memId ) )
where
columns = ( DBCIDeleted , deletedTs , groupMemberId' byGroupMember , currentTs )
2023-10-11 19:10:38 +01:00
markGroupChatItemBlocked :: DB . Connection -> User -> GroupInfo -> ChatItem 'CTGroup 'MDRcv -> IO ( ChatItem 'CTGroup 'MDRcv )
markGroupChatItemBlocked db User { userId } GroupInfo { groupId } ci @ ChatItem { meta } = do
deletedTs <- getCurrentTime
DB . execute
db
[ sql |
UPDATE chat_items
SET item_deleted = ? , item_deleted_ts = ? , updated_at = ?
2023-06-18 10:20:11 +01:00
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
| ]
2023-10-11 19:10:38 +01:00
( DBCIBlocked , deletedTs , deletedTs , userId , groupId , chatItemId' ci )
2024-08-01 18:56:41 +04:00
pure ci { meta = meta { itemDeleted = Just $ CIBlocked $ Just deletedTs , editable = False , deletable = False } }
2023-06-18 10:20:11 +01:00
2024-01-19 17:57:04 +04:00
markGroupCIBlockedByAdmin :: DB . Connection -> User -> GroupInfo -> ChatItem 'CTGroup 'MDRcv -> IO ( ChatItem 'CTGroup 'MDRcv )
markGroupCIBlockedByAdmin db User { userId } GroupInfo { groupId } ci @ ChatItem { meta } = do
deletedTs <- getCurrentTime
DB . execute
db
[ sql |
UPDATE chat_items
SET item_deleted = ? , item_deleted_ts = ? , updated_at = ?
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
| ]
( DBCIBlockedByAdmin , deletedTs , deletedTs , userId , groupId , chatItemId' ci )
2024-08-01 18:56:41 +04:00
pure ci { meta = meta { itemDeleted = Just $ CIBlockedByAdmin $ Just deletedTs , editable = False , deletable = False } }
2024-01-19 17:57:04 +04:00
2025-01-08 09:42:26 +00:00
markMessageReportsDeleted :: DB . Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> GroupMember -> UTCTime -> IO [ ChatItemId ]
markMessageReportsDeleted db User { userId } GroupInfo { groupId } ChatItem { meta = CIMeta { itemSharedMsgId } } GroupMember { groupMemberId } deletedTs = do
currentTs <- liftIO getCurrentTime
map fromOnly
<$> DB . query
db
[ sql |
UPDATE chat_items
SET item_deleted = ? , item_deleted_ts = ? , item_deleted_by_group_member_id = ? , updated_at = ?
2025-02-09 19:16:30 +00:00
WHERE user_id = ? AND group_id = ? AND msg_content_tag = ? AND quoted_shared_msg_id = ? AND item_deleted = ?
2025-01-08 09:42:26 +00:00
RETURNING chat_item_id ;
| ]
2025-02-09 19:16:30 +00:00
( DBCIDeleted , deletedTs , groupMemberId , currentTs , userId , groupId , MCReport_ , itemSharedMsgId , DBCINotDeleted )
markReceivedGroupReportsDeleted :: DB . Connection -> User -> GroupInfo -> UTCTime -> IO [ ChatItemId ]
markReceivedGroupReportsDeleted db User { userId } GroupInfo { groupId , membership } deletedTs = do
currentTs <- liftIO getCurrentTime
map fromOnly
<$> DB . query
db
[ sql |
UPDATE chat_items
SET item_deleted = ? , item_deleted_ts = ? , item_deleted_by_group_member_id = ? , updated_at = ?
2025-02-10 09:06:16 +00:00
WHERE user_id = ? AND group_id = ? AND msg_content_tag = ? AND item_deleted = ? AND item_sent = 0
2025-02-09 19:16:30 +00:00
RETURNING chat_item_id
| ]
2025-02-10 09:06:16 +00:00
( DBCIDeleted , deletedTs , groupMemberId' membership , currentTs , userId , groupId , MCReport_ , DBCINotDeleted )
2025-01-08 09:42:26 +00:00
2025-02-03 08:55:46 +00:00
getGroupChatItemBySharedMsgId :: DB . Connection -> User -> GroupInfo -> GroupMemberId -> SharedMsgId -> ExceptT StoreError IO ( CChatItem 'CTGroup )
getGroupChatItemBySharedMsgId db user @ User { userId } g @ GroupInfo { groupId } groupMemberId sharedMsgId = do
2023-06-18 10:20:11 +01:00
itemId <-
ExceptT . firstRow fromOnly ( SEChatItemSharedMsgIdNotFound sharedMsgId ) $
DB . query
db
[ sql |
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND group_id = ? AND group_member_id = ? AND shared_msg_id = ?
ORDER BY chat_item_id DESC
LIMIT 1
| ]
( userId , groupId , groupMemberId , sharedMsgId )
2025-02-03 08:55:46 +00:00
getGroupCIWithReactions db user g itemId
2023-06-18 10:20:11 +01:00
2025-02-09 12:39:48 +00:00
getGroupMemberCIBySharedMsgId :: DB . Connection -> User -> GroupInfo -> MemberId -> SharedMsgId -> ExceptT StoreError IO ( CChatItem 'CTGroup )
getGroupMemberCIBySharedMsgId db user @ User { userId } g @ GroupInfo { groupId } memberId sharedMsgId = do
2023-06-18 10:20:11 +01:00
itemId <-
ExceptT . firstRow fromOnly ( SEChatItemSharedMsgIdNotFound sharedMsgId ) $
DB . query
db
[ sql |
SELECT i . chat_item_id
FROM chat_items i
JOIN group_members m ON m . group_id = i . group_id
AND ( ( i . group_member_id IS NULL AND m . member_category = ? )
OR i . group_member_id = m . group_member_id )
WHERE i . user_id = ? AND i . group_id = ? AND m . member_id = ? AND i . shared_msg_id = ?
ORDER BY i . chat_item_id DESC
LIMIT 1
| ]
( GCUserMember , userId , groupId , memberId , sharedMsgId )
2025-02-09 12:39:48 +00:00
getGroupCIWithReactions db user g itemId
2023-06-18 10:20:11 +01:00
2024-09-17 23:50:26 +04:00
getGroupChatItemsByAgentMsgId :: DB . Connection -> User -> GroupId -> Int64 -> AgentMsgId -> IO [ CChatItem 'CTGroup ]
getGroupChatItemsByAgentMsgId db user groupId connId msgId = do
itemIds <- getChatItemIdsByAgentMsgId db connId msgId
catMaybes <$> mapM ( fmap eitherToMaybe . runExceptT . getGroupChatItem db user groupId ) itemIds
2023-07-26 14:49:35 +04:00
2023-06-18 10:20:11 +01:00
getGroupChatItem :: DB . Connection -> User -> Int64 -> ChatItemId -> ExceptT StoreError IO ( CChatItem 'CTGroup )
getGroupChatItem db User { userId , userContactId } groupId itemId = ExceptT $ do
currentTs <- getCurrentTime
2023-10-18 10:19:24 +01:00
firstRow' ( toGroupChatItem currentTs userContactId ) ( SEChatItemNotFound itemId ) getItem
2023-06-18 10:20:11 +01:00
where
getItem =
DB . query
db
[ sql |
SELECT
-- ChatItem
2024-05-15 15:30:05 +04:00
i . chat_item_id , i . item_ts , i . item_sent , i . item_content , i . item_text , i . item_status , i . via_proxy , i . shared_msg_id ,
2024-04-09 13:02:59 +01:00
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 ,
2025-01-29 13:04:48 +00:00
i . timed_ttl , i . timed_delete_at , i . item_live , i . user_mention ,
2023-06-18 10:20:11 +01:00
-- CIFile
2023-09-01 19:43:27 +01:00
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 ,
2025-06-23 14:42:00 +01:00
-- CIMeta forwardedByMember, showGroupAsSender
i . forwarded_by_group_member_id , i . show_group_as_sender ,
2023-06-18 10:20:11 +01:00
-- GroupMember
2023-11-18 21:52:01 +04:00
m . group_member_id , m . group_id , m . member_id , m . peer_chat_min_version , m . peer_chat_max_version , m . member_role , m . member_category ,
2024-01-19 17:57:04 +04:00
m . member_status , m . show_messages , m . member_restriction , m . invited_by , m . invited_by_group_member_id , m . local_display_name , m . contact_id , m . contact_profile_id , p . contact_profile_id ,
2023-06-18 10:20:11 +01:00
p . display_name , p . full_name , p . image , p . contact_link , p . local_alias , p . preferences ,
2025-04-05 11:25:45 +00:00
m . created_at , m . updated_at ,
2025-05-12 12:19:20 +00:00
m . support_chat_ts , m . support_chat_items_unread , m . support_chat_items_member_attention , m . support_chat_items_mentions , m . support_chat_last_msg_from_member_ts ,
2023-06-18 10:20:11 +01:00
-- quoted ChatItem
ri . chat_item_id , i . quoted_shared_msg_id , i . quoted_sent_at , i . quoted_content , i . quoted_sent ,
-- quoted GroupMember
2023-11-18 21:52:01 +04:00
rm . group_member_id , rm . group_id , rm . member_id , rm . peer_chat_min_version , rm . peer_chat_max_version , rm . member_role , rm . member_category ,
2024-01-19 17:57:04 +04:00
rm . member_status , rm . show_messages , rm . member_restriction , rm . invited_by , rm . invited_by_group_member_id , rm . local_display_name , rm . contact_id , rm . contact_profile_id , rp . contact_profile_id ,
2023-06-18 10:20:11 +01:00
rp . display_name , rp . full_name , rp . image , rp . contact_link , rp . local_alias , rp . preferences ,
2025-04-05 11:25:45 +00:00
rm . created_at , rm . updated_at ,
2025-05-12 12:19:20 +00:00
rm . support_chat_ts , rm . support_chat_items_unread , rm . support_chat_items_member_attention , rm . support_chat_items_mentions , rm . support_chat_last_msg_from_member_ts ,
2023-06-18 10:20:11 +01:00
-- deleted by GroupMember
2023-11-18 21:52:01 +04:00
dbm . group_member_id , dbm . group_id , dbm . member_id , dbm . peer_chat_min_version , dbm . peer_chat_max_version , dbm . member_role , dbm . member_category ,
2024-01-19 17:57:04 +04:00
dbm . member_status , dbm . show_messages , dbm . member_restriction , dbm . invited_by , dbm . invited_by_group_member_id , dbm . local_display_name , dbm . contact_id , dbm . contact_profile_id , dbp . contact_profile_id ,
2025-02-25 09:24:30 +00:00
dbp . display_name , dbp . full_name , dbp . image , dbp . contact_link , dbp . local_alias , dbp . preferences ,
2025-04-05 11:25:45 +00:00
dbm . created_at , dbm . updated_at ,
2025-05-12 12:19:20 +00:00
dbm . support_chat_ts , dbm . support_chat_items_unread , dbm . support_chat_items_member_attention , dbm . support_chat_items_mentions , dbm . support_chat_last_msg_from_member_ts
2023-06-18 10:20:11 +01:00
FROM chat_items i
LEFT JOIN files f ON f . chat_item_id = i . chat_item_id
2025-04-02 07:57:18 +00:00
LEFT JOIN group_members gsm ON gsm . group_member_id = i . group_scope_group_member_id
LEFT JOIN contact_profiles gsp ON gsp . contact_profile_id = COALESCE ( gsm . member_profile_id , gsm . contact_profile_id )
2023-06-18 10:20:11 +01:00
LEFT JOIN group_members m ON m . group_member_id = i . group_member_id
LEFT JOIN contact_profiles p ON p . contact_profile_id = COALESCE ( m . member_profile_id , m . contact_profile_id )
LEFT JOIN chat_items ri ON ri . shared_msg_id = i . quoted_shared_msg_id AND ri . group_id = i . group_id
LEFT JOIN group_members rm ON rm . group_member_id = ri . group_member_id
LEFT JOIN contact_profiles rp ON rp . contact_profile_id = COALESCE ( rm . member_profile_id , rm . contact_profile_id )
LEFT JOIN group_members dbm ON dbm . group_member_id = i . item_deleted_by_group_member_id
LEFT JOIN contact_profiles dbp ON dbp . contact_profile_id = COALESCE ( dbm . member_profile_id , dbm . contact_profile_id )
WHERE i . user_id = ? AND i . group_id = ? AND i . chat_item_id = ?
| ]
( userId , groupId , itemId )
getGroupChatItemIdByText :: DB . Connection -> User -> GroupId -> Maybe ContactName -> Text -> ExceptT StoreError IO ChatItemId
getGroupChatItemIdByText db User { userId , localDisplayName = userName } groupId contactName_ quotedMsg =
ExceptT . firstRow fromOnly ( SEChatItemNotFoundByText quotedMsg ) $ case contactName_ of
Nothing -> anyMemberChatItem_
Just cName
| userName == cName -> userChatItem_
| otherwise -> memberChatItem_ cName
where
anyMemberChatItem_ =
DB . query
db
[ sql |
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND group_id = ? AND item_text like ?
ORDER BY chat_item_id DESC
LIMIT 1
| ]
( userId , groupId , quotedMsg <> " % " )
userChatItem_ =
DB . query
db
[ sql |
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND group_id = ? AND group_member_id IS NULL AND item_text like ?
ORDER BY chat_item_id DESC
LIMIT 1
| ]
( userId , groupId , quotedMsg <> " % " )
memberChatItem_ cName =
DB . query
db
[ sql |
SELECT i . chat_item_id
FROM chat_items i
JOIN group_members m ON m . group_member_id = i . group_member_id
2025-01-31 10:32:07 +04:00
WHERE i . user_id = ? AND i . group_id = ? AND m . local_display_name = ? AND i . item_text like ?
2023-06-18 10:20:11 +01:00
ORDER BY i . chat_item_id DESC
LIMIT 1
| ]
( userId , groupId , cName , quotedMsg <> " % " )
getGroupChatItemIdByText' :: DB . Connection -> User -> GroupId -> Text -> ExceptT StoreError IO ChatItemId
getGroupChatItemIdByText' db User { userId } groupId msg =
ExceptT . firstRow fromOnly ( SEChatItemNotFoundByText msg ) $
DB . query
db
[ sql |
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND group_id = ? AND item_text like ?
ORDER BY chat_item_id DESC
LIMIT 1
| ]
( userId , groupId , msg <> " % " )
2024-01-11 19:01:44 +02:00
getLocalChatItem :: DB . Connection -> User -> Int64 -> ChatItemId -> ExceptT StoreError IO ( CChatItem 'CTLocal )
getLocalChatItem db User { userId } folderId itemId = ExceptT $ do
currentTs <- getCurrentTime
firstRow' ( toLocalChatItem currentTs ) ( SEChatItemNotFound itemId ) getItem
where
getItem =
DB . query
db
[ sql |
SELECT
-- ChatItem
2024-05-15 15:30:05 +04:00
i . chat_item_id , i . item_ts , i . item_sent , i . item_content , i . item_text , i . item_status , i . via_proxy , i . shared_msg_id ,
2024-04-09 13:02:59 +01:00
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 ,
2025-01-29 13:04:48 +00:00
i . timed_ttl , i . timed_delete_at , i . item_live , i . user_mention ,
2024-01-11 19:01:44 +02:00
-- 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
LEFT JOIN files f ON f . chat_item_id = i . chat_item_id
WHERE i . user_id = ? AND i . note_folder_id = ? AND i . chat_item_id = ?
| ]
( userId , folderId , itemId )
getLocalChatItemIdByText :: DB . Connection -> User -> NoteFolderId -> SMsgDirection d -> Text -> ExceptT StoreError IO ChatItemId
getLocalChatItemIdByText db User { userId } noteFolderId msgDir quotedMsg =
ExceptT . firstRow fromOnly ( SEChatItemNotFoundByText quotedMsg ) $
DB . query
db
[ sql |
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND note_folder_id = ? AND item_sent = ? AND item_text LIKE ?
ORDER BY chat_item_id DESC
LIMIT 1
| ]
( userId , noteFolderId , msgDir , quotedMsg <> " % " )
getLocalChatItemIdByText' :: DB . Connection -> User -> NoteFolderId -> Text -> ExceptT StoreError IO ChatItemId
getLocalChatItemIdByText' db User { userId } noteFolderId msg =
ExceptT . firstRow fromOnly ( SEChatItemNotFoundByText msg ) $
DB . query
db
[ sql |
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND note_folder_id = ? AND item_text LIKE ?
ORDER BY chat_item_id DESC
LIMIT 1
| ]
( userId , noteFolderId , msg <> " % " )
2024-04-25 12:37:05 +04:00
updateLocalChatItem' :: forall d . MsgDirectionI d => DB . Connection -> User -> NoteFolderId -> ChatItem 'CTLocal d -> CIContent d -> Bool -> IO ( ChatItem 'CTLocal d )
updateLocalChatItem' db User { userId } noteFolderId ci newContent edited = do
2024-01-11 19:01:44 +02:00
currentTs <- liftIO getCurrentTime
2024-04-25 12:37:05 +04:00
let ci' = updatedChatItem ci newContent edited False Nothing currentTs
2024-01-11 19:01:44 +02:00
liftIO $ updateLocalChatItem_ db userId noteFolderId ci'
pure ci'
-- this function assumes that local item with correct chat direction already exists,
-- it should be checked before calling it
updateLocalChatItem_ :: forall d . MsgDirectionI d => DB . Connection -> UserId -> NoteFolderId -> ChatItem 'CTLocal d -> IO ()
updateLocalChatItem_ db userId noteFolderId ChatItem { meta , content } = do
let CIMeta { itemId , itemText , itemStatus , itemDeleted , itemEdited , updatedAt } = meta
itemDeleted' = isJust itemDeleted
itemDeletedTs' = itemDeletedTs =<< itemDeleted
DB . execute
db
[ sql |
UPDATE chat_items
SET item_content = ? , item_text = ? , item_status = ? , item_deleted = ? , item_deleted_ts = ? , item_edited = ? , updated_at = ?
WHERE user_id = ? AND note_folder_id = ? AND chat_item_id = ?
| ]
2025-01-10 15:27:29 +04:00
( ( content , itemText , itemStatus , BI itemDeleted' , itemDeletedTs' , BI itemEdited , updatedAt ) :. ( userId , noteFolderId , itemId ) )
2024-01-11 19:01:44 +02:00
deleteLocalChatItem :: DB . Connection -> User -> NoteFolder -> ChatItem 'CTLocal d -> IO ()
deleteLocalChatItem db User { userId } NoteFolder { noteFolderId } ci = do
let itemId = chatItemId' ci
deleteChatItemVersions_ db itemId
DB . execute
db
[ sql |
DELETE FROM chat_items
WHERE user_id = ? AND note_folder_id = ? AND chat_item_id = ?
| ]
( userId , noteFolderId , itemId )
2024-04-22 20:46:48 +04:00
getChatItemByFileId :: DB . Connection -> VersionRangeChat -> User -> Int64 -> ExceptT StoreError IO AChatItem
2023-12-24 13:27:51 +00:00
getChatItemByFileId db vr user @ User { userId } fileId = do
2023-06-18 10:20:11 +01:00
( chatRef , itemId ) <-
ExceptT . firstRow' toChatItemRef ( SEChatItemNotFoundByFileId fileId ) $
DB . query
db
[ sql |
2025-04-21 15:17:21 +00:00
SELECT i . chat_item_id , i . contact_id , i . group_id , i . group_scope_tag , i . group_scope_group_member_id , i . note_folder_id
2023-06-18 10:20:11 +01:00
FROM chat_items i
JOIN files f ON f . chat_item_id = i . chat_item_id
WHERE f . user_id = ? AND f . file_id = ?
LIMIT 1
| ]
( userId , fileId )
2023-12-24 13:27:51 +00:00
getAChatItem db vr user chatRef itemId
2023-06-18 10:20:11 +01:00
2024-04-22 20:46:48 +04:00
lookupChatItemByFileId :: DB . Connection -> VersionRangeChat -> User -> Int64 -> ExceptT StoreError IO ( Maybe AChatItem )
2024-02-19 12:21:32 +02:00
lookupChatItemByFileId db vr user fileId = do
fmap Just ( getChatItemByFileId db vr user fileId ) ` catchError ` \ case
SEChatItemNotFoundByFileId { } -> pure Nothing
e -> throwError e
2024-04-22 20:46:48 +04:00
getChatItemByGroupId :: DB . Connection -> VersionRangeChat -> User -> GroupId -> ExceptT StoreError IO AChatItem
2023-12-24 13:27:51 +00:00
getChatItemByGroupId db vr user @ User { userId } groupId = do
2023-06-18 10:20:11 +01:00
( chatRef , itemId ) <-
ExceptT . firstRow' toChatItemRef ( SEChatItemNotFoundByGroupId groupId ) $
DB . query
db
[ sql |
2025-04-21 15:17:21 +00:00
SELECT i . chat_item_id , i . contact_id , i . group_id , i . group_scope_tag , i . group_scope_group_member_id , i . note_folder_id
2023-06-18 10:20:11 +01:00
FROM chat_items i
JOIN groups g ON g . chat_item_id = i . chat_item_id
WHERE g . user_id = ? AND g . group_id = ?
LIMIT 1
| ]
( userId , groupId )
2023-12-24 13:27:51 +00:00
getAChatItem db vr user chatRef itemId
2023-06-18 10:20:11 +01:00
getChatRefViaItemId :: DB . Connection -> User -> ChatItemId -> ExceptT StoreError IO ChatRef
getChatRefViaItemId db User { userId } itemId = do
ExceptT . firstRow' toChatRef ( SEChatItemNotFound itemId ) $
DB . query db " SELECT contact_id, group_id FROM chat_items WHERE user_id = ? AND chat_item_id = ? " ( userId , itemId )
where
toChatRef = \ case
2025-04-02 07:57:18 +00:00
( Just contactId , Nothing ) -> Right $ ChatRef CTDirect contactId Nothing
-- Only used in CLI and unused APIs
( Nothing , Just groupId ) -> Right $ ChatRef CTGroup groupId Nothing
2024-02-19 15:17:14 +04:00
( _ , _ ) -> Left $ SEBadChatItem itemId Nothing
2023-06-18 10:20:11 +01:00
2024-04-22 20:46:48 +04:00
getAChatItem :: DB . Connection -> VersionRangeChat -> User -> ChatRef -> ChatItemId -> ExceptT StoreError IO AChatItem
2025-04-02 07:57:18 +00:00
getAChatItem db vr user ( ChatRef cType chatId scope ) itemId = do
aci <- case cType of
CTDirect -> do
ct <- getContact db vr user chatId
( CChatItem msgDir ci ) <- getDirectChatItem db user chatId itemId
2024-09-25 14:16:32 +04:00
pure $ AChatItem SCTDirect msgDir ( DirectChat ct ) ci
2025-04-02 07:57:18 +00:00
CTGroup -> do
gInfo <- getGroupInfo db vr user chatId
( CChatItem msgDir ci ) <- getGroupChatItem db user chatId itemId
scopeInfo <- mapM ( getGroupChatScopeInfo db vr user gInfo ) scope
pure $ AChatItem SCTGroup msgDir ( GroupChat gInfo scopeInfo ) ci
CTLocal -> do
nf <- getNoteFolder db user chatId
CChatItem msgDir ci <- getLocalChatItem db user chatId itemId
2024-09-25 14:16:32 +04:00
pure $ AChatItem SCTLocal msgDir ( LocalChat nf ) ci
_ -> throwError $ SEChatItemNotFound itemId
liftIO $ getACIReactions db aci
2023-06-18 10:20:11 +01:00
2024-03-29 18:30:17 +00:00
getAChatItemBySharedMsgId :: ChatTypeQuotable c => DB . Connection -> User -> ChatDirection c 'MDRcv -> SharedMsgId -> ExceptT StoreError IO AChatItem
getAChatItemBySharedMsgId db user cd sharedMsgId = case cd of
CDDirectRcv ct @ Contact { contactId } -> do
( CChatItem msgDir ci ) <- getDirectChatItemBySharedMsgId db user contactId sharedMsgId
pure $ AChatItem SCTDirect msgDir ( DirectChat ct ) ci
2025-04-02 07:57:18 +00:00
CDGroupRcv g scopeInfo GroupMember { groupMemberId } -> do
2025-02-03 08:55:46 +00:00
( CChatItem msgDir ci ) <- getGroupChatItemBySharedMsgId db user g groupMemberId sharedMsgId
2025-04-02 07:57:18 +00:00
pure $ AChatItem SCTGroup msgDir ( GroupChat g scopeInfo ) ci
2024-03-29 18:30:17 +00:00
2023-06-18 10:20:11 +01:00
getChatItemVersions :: DB . Connection -> ChatItemId -> IO [ ChatItemVersion ]
getChatItemVersions db itemId = do
map toChatItemVersion
<$> DB . query
db
[ sql |
SELECT chat_item_version_id , msg_content , item_version_ts , created_at
FROM chat_item_versions
WHERE chat_item_id = ?
ORDER BY chat_item_version_id DESC
| ]
( Only itemId )
where
toChatItemVersion :: ( Int64 , MsgContent , UTCTime , UTCTime ) -> ChatItemVersion
toChatItemVersion ( chatItemVersionId , msgContent , itemVersionTs , createdAt ) =
let formattedText = parseMaybeMarkdownList $ msgContentText msgContent
in ChatItemVersion { chatItemVersionId , msgContent , formattedText , itemVersionTs , createdAt }
2023-10-18 10:19:24 +01:00
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
2023-06-18 10:20:11 +01:00
pure $ CChatItem md ci { reactions }
2023-10-18 10:19:24 +01:00
Nothing -> pure cci
2023-06-18 10:20:11 +01:00
getDirectCIReactions :: DB . Connection -> Contact -> SharedMsgId -> IO [ CIReactionCount ]
getDirectCIReactions db Contact { contactId } itemSharedMsgId =
map toCIReaction
<$> DB . query
db
[ sql |
SELECT reaction , MAX ( reaction_sent ) , COUNT ( chat_item_reaction_id )
FROM chat_item_reactions
WHERE contact_id = ? AND shared_msg_id = ?
GROUP BY reaction
| ]
( contactId , itemSharedMsgId )
getGroupCIReactions :: DB . Connection -> GroupInfo -> MemberId -> SharedMsgId -> IO [ CIReactionCount ]
getGroupCIReactions db GroupInfo { groupId } itemMemberId itemSharedMsgId =
map toCIReaction
<$> DB . query
db
[ sql |
SELECT reaction , MAX ( reaction_sent ) , COUNT ( chat_item_reaction_id )
FROM chat_item_reactions
WHERE group_id = ? AND item_member_id = ? AND shared_msg_id = ?
GROUP BY reaction
| ]
( groupId , itemMemberId , itemSharedMsgId )
2025-01-30 10:06:26 +00:00
getGroupCIMentions :: DB . Connection -> ChatItemId -> IO ( Map MemberName CIMention )
2025-01-29 13:04:48 +00:00
getGroupCIMentions db ciId =
M . fromList . map mentionedMember
<$> DB . query
db
[ sql |
SELECT r . display_name , r . member_id , m . group_member_id , m . member_role , p . display_name , p . local_alias
FROM chat_item_mentions r
LEFT JOIN group_members m ON r . group_id = m . group_id AND r . member_id = m . member_id
2025-06-08 18:27:42 +01:00
LEFT JOIN contact_profiles p ON p . contact_profile_id = COALESCE ( m . member_profile_id , m . contact_profile_id )
2025-01-29 13:04:48 +00:00
WHERE r . chat_item_id = ?
| ]
( Only ciId )
where
2025-01-30 10:06:26 +00:00
mentionedMember :: ( ContactName , MemberId , Maybe GroupMemberId , Maybe GroupMemberRole , Maybe Text , Maybe Text ) -> ( ContactName , CIMention )
2025-01-29 13:04:48 +00:00
mentionedMember ( name , memberId , gmId_ , mRole_ , displayName_ , localAlias ) =
let memberRef = case ( gmId_ , mRole_ , displayName_ ) of
( Just groupMemberId , Just memberRole , Just displayName ) ->
2025-01-30 10:06:26 +00:00
Just CIMentionMember { groupMemberId , displayName , localAlias , memberRole }
2025-01-29 13:04:48 +00:00
_ -> Nothing
2025-01-30 10:06:26 +00:00
in ( name , CIMention { memberId , memberRef } )
2025-01-29 13:04:48 +00:00
2023-06-18 10:20:11 +01:00
getACIReactions :: DB . Connection -> AChatItem -> IO AChatItem
getACIReactions db aci @ ( AChatItem _ md chat ci @ ChatItem { meta = CIMeta { itemSharedMsgId } } ) = case itemSharedMsgId of
Just itemSharedMId -> case chat of
DirectChat ct -> do
reactions <- getDirectCIReactions db ct itemSharedMId
pure $ AChatItem SCTDirect md chat ci { reactions }
2025-04-02 07:57:18 +00:00
GroupChat g _s -> do
2023-06-18 10:20:11 +01:00
let GroupMember { memberId } = chatItemMember g ci
reactions <- getGroupCIReactions db g memberId itemSharedMId
pure $ AChatItem SCTGroup md chat ci { reactions }
_ -> pure aci
_ -> pure aci
deleteDirectCIReactions_ :: DB . Connection -> ContactId -> ChatItem 'CTDirect d -> IO ()
deleteDirectCIReactions_ db contactId ChatItem { meta = CIMeta { itemSharedMsgId } } =
forM_ itemSharedMsgId $ \ itemSharedMId ->
DB . execute db " DELETE FROM chat_item_reactions WHERE contact_id = ? AND shared_msg_id = ? " ( contactId , itemSharedMId )
deleteGroupCIReactions_ :: DB . Connection -> GroupInfo -> ChatItem 'CTGroup d -> IO ()
deleteGroupCIReactions_ db g @ GroupInfo { groupId } ci @ ChatItem { meta = CIMeta { itemSharedMsgId } } =
forM_ itemSharedMsgId $ \ itemSharedMId -> do
let GroupMember { memberId } = chatItemMember g ci
DB . execute
db
" DELETE FROM chat_item_reactions WHERE group_id = ? AND shared_msg_id = ? AND item_member_id = ? "
( groupId , itemSharedMId , memberId )
2025-01-10 15:27:29 +04:00
toCIReaction :: ( MsgReaction , BoolInt , Int ) -> CIReactionCount
toCIReaction ( reaction , BI userReacted , totalReacted ) = CIReactionCount { reaction , userReacted , totalReacted }
2023-06-18 10:20:11 +01:00
getDirectReactions :: DB . Connection -> Contact -> SharedMsgId -> Bool -> IO [ MsgReaction ]
getDirectReactions db ct itemSharedMId sent =
map fromOnly
<$> DB . query
db
[ sql |
SELECT reaction
FROM chat_item_reactions
WHERE contact_id = ? AND shared_msg_id = ? AND reaction_sent = ?
| ]
2025-01-10 15:27:29 +04:00
( contactId' ct , itemSharedMId , BI sent )
2023-06-18 10:20:11 +01:00
setDirectReaction :: DB . Connection -> Contact -> SharedMsgId -> Bool -> MsgReaction -> Bool -> MessageId -> UTCTime -> IO ()
setDirectReaction db ct itemSharedMId sent reaction add msgId reactionTs
| add =
2023-11-26 18:16:37 +00:00
DB . execute
db
[ sql |
INSERT INTO chat_item_reactions
( contact_id , shared_msg_id , reaction_sent , reaction , created_by_msg_id , reaction_ts )
VALUES ( ? , ? , ? , ? , ? , ? )
| ]
2025-01-10 15:27:29 +04:00
( contactId' ct , itemSharedMId , BI sent , reaction , msgId , reactionTs )
2023-06-18 10:20:11 +01:00
| otherwise =
2023-11-26 18:16:37 +00:00
DB . execute
db
[ sql |
DELETE FROM chat_item_reactions
WHERE contact_id = ? AND shared_msg_id = ? AND reaction_sent = ? AND reaction = ?
| ]
2025-01-10 15:27:29 +04:00
( contactId' ct , itemSharedMId , BI sent , reaction )
2023-06-18 10:20:11 +01:00
getGroupReactions :: DB . Connection -> GroupInfo -> GroupMember -> MemberId -> SharedMsgId -> Bool -> IO [ MsgReaction ]
getGroupReactions db GroupInfo { groupId } m itemMemberId itemSharedMId sent =
map fromOnly
<$> DB . query
db
[ sql |
SELECT reaction
FROM chat_item_reactions
WHERE group_id = ? AND group_member_id = ? AND item_member_id = ? AND shared_msg_id = ? AND reaction_sent = ?
| ]
2025-01-10 15:27:29 +04:00
( groupId , groupMemberId' m , itemMemberId , itemSharedMId , BI sent )
2023-06-18 10:20:11 +01:00
setGroupReaction :: DB . Connection -> GroupInfo -> GroupMember -> MemberId -> SharedMsgId -> Bool -> MsgReaction -> Bool -> MessageId -> UTCTime -> IO ()
setGroupReaction db GroupInfo { groupId } m itemMemberId itemSharedMId sent reaction add msgId reactionTs
| add =
2023-11-26 18:16:37 +00:00
DB . execute
db
[ sql |
INSERT INTO chat_item_reactions
( group_id , group_member_id , item_member_id , shared_msg_id , reaction_sent , reaction , created_by_msg_id , reaction_ts )
VALUES ( ? , ? , ? , ? , ? , ? , ? , ? )
| ]
2025-01-10 15:27:29 +04:00
( groupId , groupMemberId' m , itemMemberId , itemSharedMId , BI sent , reaction , msgId , reactionTs )
2023-06-18 10:20:11 +01:00
| otherwise =
2023-11-26 18:16:37 +00:00
DB . execute
db
[ sql |
DELETE FROM chat_item_reactions
WHERE group_id = ? AND group_member_id = ? AND shared_msg_id = ? AND item_member_id = ? AND reaction_sent = ? AND reaction = ?
| ]
2025-01-10 15:27:29 +04:00
( groupId , groupMemberId' m , itemSharedMId , itemMemberId , BI sent , reaction )
2023-06-18 10:20:11 +01:00
2024-11-28 13:49:20 +04:00
getReactionMembers :: DB . Connection -> VersionRangeChat -> User -> GroupId -> SharedMsgId -> MsgReaction -> IO [ MemberReaction ]
getReactionMembers db vr user groupId itemSharedMId reaction = do
reactions <-
DB . query
2024-11-28 11:24:29 +04:00
db
[ sql |
SELECT group_member_id , reaction_ts
FROM chat_item_reactions
WHERE group_id = ? AND shared_msg_id = ? AND reaction = ?
| ]
( groupId , itemSharedMId , reaction )
2024-11-28 13:49:20 +04:00
rights <$> mapM ( runExceptT . toMemberReaction ) reactions
2024-11-28 11:24:29 +04:00
where
2024-11-28 13:49:20 +04:00
toMemberReaction :: ( GroupMemberId , UTCTime ) -> ExceptT StoreError IO MemberReaction
toMemberReaction ( groupMemberId , reactionTs ) = do
groupMember <- getGroupMemberById db vr user groupMemberId
pure MemberReaction { groupMember , reactionTs }
2024-11-28 11:24:29 +04:00
2023-06-18 10:20:11 +01:00
getTimedItems :: DB . Connection -> User -> UTCTime -> IO [ ( ( ChatRef , ChatItemId ) , UTCTime ) ]
getTimedItems db User { userId } startTimedThreadCutoff =
mapMaybe toCIRefDeleteAt
<$> DB . query
db
[ sql |
2025-04-02 07:57:18 +00:00
SELECT chat_item_id , contact_id , group_id , group_scope_tag , group_scope_group_member_id , timed_delete_at
2023-06-18 10:20:11 +01:00
FROM chat_items
WHERE user_id = ? AND timed_delete_at IS NOT NULL AND timed_delete_at <= ?
| ]
( userId , startTimedThreadCutoff )
where
2025-04-02 07:57:18 +00:00
toCIRefDeleteAt :: ( ChatItemId , Maybe ContactId , Maybe GroupId , Maybe GroupChatScopeTag , Maybe GroupMemberId , UTCTime ) -> Maybe ( ( ChatRef , ChatItemId ) , UTCTime )
2023-06-18 10:20:11 +01:00
toCIRefDeleteAt = \ case
2025-04-02 07:57:18 +00:00
( itemId , Just contactId , Nothing , Nothing , Nothing , deleteAt ) ->
Just ( ( ChatRef CTDirect contactId Nothing , itemId ) , deleteAt )
( itemId , Nothing , Just groupId , scopeTag_ , scopeGMId_ , deleteAt ) ->
let scope = case ( scopeTag_ , scopeGMId_ ) of
( Nothing , Nothing ) -> Nothing
( Just GCSTMemberSupport_ , Just groupMemberId ) -> Just $ GCSMemberSupport ( Just groupMemberId )
( Just GCSTMemberSupport_ , Nothing ) -> Just $ GCSMemberSupport Nothing
( Nothing , Just _ ) -> Nothing -- should not happen
in Just ( ( ChatRef CTGroup groupId scope , itemId ) , deleteAt )
2023-06-18 10:20:11 +01:00
_ -> Nothing
2025-01-20 18:06:00 +00:00
getChatItemTTL :: DB . Connection -> User -> IO Int64
2023-06-18 10:20:11 +01:00
getChatItemTTL db User { userId } =
2025-01-20 18:06:00 +00:00
fmap ( fromMaybe 0 . join ) . maybeFirstRow fromOnly $
DB . query db " SELECT chat_item_ttl FROM settings WHERE user_id = ? LIMIT 1 " ( Only userId )
2023-06-18 10:20:11 +01:00
2025-01-20 18:06:00 +00:00
setChatItemTTL :: DB . Connection -> User -> Int64 -> IO ()
2023-06-18 10:20:11 +01:00
setChatItemTTL db User { userId } chatItemTTL = do
currentTs <- getCurrentTime
r :: ( Maybe Int64 ) <- maybeFirstRow fromOnly $ DB . query db " SELECT 1 FROM settings WHERE user_id = ? LIMIT 1 " ( Only userId )
case r of
Just _ -> do
DB . execute
db
" UPDATE settings SET chat_item_ttl = ?, updated_at = ? WHERE user_id = ? "
( chatItemTTL , currentTs , userId )
Nothing -> do
DB . execute
db
" INSERT INTO settings (user_id, chat_item_ttl, created_at, updated_at) VALUES (?,?,?,?) "
( userId , chatItemTTL , currentTs , currentTs )
2025-01-20 18:06:00 +00:00
getChatTTLCount :: DB . Connection -> User -> IO Int
getChatTTLCount db User { userId } = do
contactCount <- getCount " SELECT COUNT(1) FROM contacts WHERE user_id = ? AND chat_item_ttl > 0 "
groupCount <- getCount " SELECT COUNT(1) FROM groups WHERE user_id = ? AND chat_item_ttl > 0 "
pure $ contactCount + groupCount
where
getCount q = fromOnly . head <$> DB . query db q ( Only userId )
2023-06-18 10:20:11 +01:00
getContactExpiredFileInfo :: DB . Connection -> User -> Contact -> UTCTime -> IO [ CIFileInfo ]
getContactExpiredFileInfo db User { userId } Contact { contactId } expirationDate =
map toFileInfo
<$> DB . query
db
( fileInfoQuery <> " WHERE i.user_id = ? AND i.contact_id = ? AND i.created_at <= ? " )
( userId , contactId , expirationDate )
deleteContactExpiredCIs :: DB . Connection -> User -> Contact -> UTCTime -> IO ()
deleteContactExpiredCIs db user @ User { userId } ct @ Contact { contactId } expirationDate = do
connIds <- getContactConnIds_ db user ct
forM_ connIds $ \ connId ->
DB . execute db " DELETE FROM messages WHERE connection_id = ? AND created_at <= ? " ( connId , expirationDate )
DB . execute db " DELETE FROM chat_item_reactions WHERE contact_id = ? AND created_at <= ? " ( contactId , expirationDate )
DB . execute db " DELETE FROM chat_items WHERE user_id = ? AND contact_id = ? AND created_at <= ? " ( userId , contactId , expirationDate )
getGroupExpiredFileInfo :: DB . Connection -> User -> GroupInfo -> UTCTime -> UTCTime -> IO [ CIFileInfo ]
getGroupExpiredFileInfo db User { userId } GroupInfo { groupId } expirationDate createdAtCutoff =
map toFileInfo
<$> DB . query
db
( fileInfoQuery <> " WHERE i.user_id = ? AND i.group_id = ? AND i.item_ts <= ? AND i.created_at <= ? " )
( userId , groupId , expirationDate , createdAtCutoff )
deleteGroupExpiredCIs :: DB . Connection -> User -> GroupInfo -> UTCTime -> UTCTime -> IO ()
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 )
DB . execute db " DELETE FROM chat_items WHERE user_id = ? AND group_id = ? AND item_ts <= ? AND created_at <= ? " ( userId , groupId , expirationDate , createdAtCutoff )
2023-06-22 20:38:09 +04:00
createCIModeration :: DB . Connection -> GroupInfo -> GroupMember -> MemberId -> SharedMsgId -> MessageId -> UTCTime -> IO ()
createCIModeration db GroupInfo { groupId } moderatorMember itemMemberId itemSharedMId msgId moderatedAtTs =
DB . execute
db
[ sql |
INSERT INTO chat_item_moderations
( group_id , moderator_member_id , item_member_id , shared_msg_id , created_by_msg_id , moderated_at )
VALUES ( ? , ? , ? , ? , ? , ? )
| ]
( groupId , groupMemberId' moderatorMember , itemMemberId , itemSharedMId , msgId , moderatedAtTs )
2024-04-22 20:46:48 +04:00
getCIModeration :: DB . Connection -> VersionRangeChat -> User -> GroupInfo -> MemberId -> Maybe SharedMsgId -> IO ( Maybe CIModeration )
2024-03-10 20:52:29 +00:00
getCIModeration _ _ _ _ _ Nothing = pure Nothing
getCIModeration db vr user GroupInfo { groupId } itemMemberId ( Just sharedMsgId ) = do
2023-06-22 20:38:09 +04:00
r_ <-
maybeFirstRow id $
DB . query
db
[ sql |
SELECT chat_item_moderation_id , moderator_member_id , created_by_msg_id , moderated_at
FROM chat_item_moderations
WHERE group_id = ? AND item_member_id = ? AND shared_msg_id = ?
LIMIT 1
| ]
( groupId , itemMemberId , sharedMsgId )
case r_ of
Just ( moderationId , moderatorId , createdByMsgId , moderatedAt ) -> do
2024-03-10 20:52:29 +00:00
runExceptT ( getGroupMember db vr user groupId moderatorId ) >>= \ case
2023-06-22 20:38:09 +04:00
Right moderatorMember -> pure ( Just CIModeration { moderationId , moderatorMember , createdByMsgId , moderatedAt } )
_ -> pure Nothing
_ -> pure Nothing
deleteCIModeration :: DB . Connection -> GroupInfo -> MemberId -> Maybe SharedMsgId -> IO ()
deleteCIModeration _ _ _ Nothing = pure ()
deleteCIModeration db GroupInfo { groupId } itemMemberId ( Just sharedMsgId ) =
DB . execute
db
" DELETE FROM chat_item_moderations WHERE group_id = ? AND item_member_id = ? AND shared_msg_id = ? "
( groupId , itemMemberId , sharedMsgId )
2023-07-26 14:49:35 +04:00
2024-07-09 21:29:36 +04:00
createGroupSndStatus :: DB . Connection -> ChatItemId -> GroupMemberId -> GroupSndStatus -> IO ()
2023-07-26 14:49:35 +04:00
createGroupSndStatus db itemId memberId status =
DB . execute
db
" INSERT INTO group_snd_item_statuses (chat_item_id, group_member_id, group_snd_item_status) VALUES (?,?,?) "
( itemId , memberId , status )
2024-07-09 21:29:36 +04:00
getGroupSndStatus :: DB . Connection -> ChatItemId -> GroupMemberId -> ExceptT StoreError IO GroupSndStatus
2023-07-26 14:49:35 +04:00
getGroupSndStatus db itemId memberId =
ExceptT . firstRow fromOnly ( SENoGroupSndStatus itemId memberId ) $
DB . query
db
[ sql |
SELECT group_snd_item_status
FROM group_snd_item_statuses
WHERE chat_item_id = ? AND group_member_id = ?
LIMIT 1
| ]
( itemId , memberId )
2024-07-09 21:29:36 +04:00
updateGroupSndStatus :: DB . Connection -> ChatItemId -> GroupMemberId -> GroupSndStatus -> IO ()
2023-07-26 14:49:35 +04:00
updateGroupSndStatus db itemId memberId status = do
currentTs <- liftIO getCurrentTime
DB . execute
db
[ sql |
UPDATE group_snd_item_statuses
SET group_snd_item_status = ? , updated_at = ?
WHERE chat_item_id = ? AND group_member_id = ?
| ]
( status , currentTs , itemId , memberId )
2024-05-15 15:30:05 +04:00
setGroupSndViaProxy :: DB . Connection -> ChatItemId -> GroupMemberId -> Bool -> IO ()
setGroupSndViaProxy db itemId memberId viaProxy =
DB . execute
2023-07-26 14:49:35 +04:00
db
[ sql |
2024-05-15 15:30:05 +04:00
UPDATE group_snd_item_statuses
SET via_proxy = ?
WHERE chat_item_id = ? AND group_member_id = ?
2023-07-26 14:49:35 +04:00
| ]
2025-01-10 15:27:29 +04:00
( BI viaProxy , itemId , memberId )
2024-05-15 15:30:05 +04:00
getGroupSndStatuses :: DB . Connection -> ChatItemId -> IO [ MemberDeliveryStatus ]
getGroupSndStatuses db itemId =
map memStatus
<$> DB . query
db
[ sql |
SELECT group_member_id , group_snd_item_status , via_proxy
FROM group_snd_item_statuses
WHERE chat_item_id = ?
| ]
( Only itemId )
where
memStatus ( groupMemberId , memberDeliveryStatus , sentViaProxy ) =
2025-01-10 15:27:29 +04:00
MemberDeliveryStatus { groupMemberId , memberDeliveryStatus , sentViaProxy = unBI <$> sentViaProxy }
2023-07-26 14:49:35 +04:00
2024-07-09 21:29:36 +04:00
getGroupSndStatusCounts :: DB . Connection -> ChatItemId -> IO [ ( GroupSndStatus , Int ) ]
2023-07-26 14:49:35 +04:00
getGroupSndStatusCounts db itemId =
DB . query
db
[ sql |
SELECT group_snd_item_status , COUNT ( 1 )
FROM group_snd_item_statuses
WHERE chat_item_id = ?
GROUP BY group_snd_item_status
| ]
( Only itemId )
2023-12-23 17:07:23 +04:00
2024-12-04 16:32:01 +00:00
getGroupHistoryItems :: DB . Connection -> User -> GroupInfo -> GroupMember -> Int -> IO [ Either StoreError ( CChatItem 'CTGroup ) ]
2025-01-30 17:59:21 +00:00
getGroupHistoryItems db user @ User { userId } g @ GroupInfo { groupId } m count = do
2024-11-14 08:34:25 +00:00
ciIds <- getLastItemIds_
2025-01-30 17:59:21 +00:00
reverse <$> mapM ( runExceptT . getGroupCIWithReactions db user g ) ciIds
2023-12-23 17:07:23 +04:00
where
getLastItemIds_ :: IO [ ChatItemId ]
getLastItemIds_ =
map fromOnly
<$> DB . query
db
[ sql |
2024-12-04 16:32:01 +00:00
SELECT i . chat_item_id
FROM chat_items i
LEFT JOIN group_snd_item_statuses s ON s . chat_item_id = i . chat_item_id AND s . group_member_id = ?
2025-01-22 23:33:54 +04:00
WHERE s . group_snd_item_status_id IS NULL
AND i . user_id = ? AND i . group_id = ?
AND i . include_in_history = 1
2024-12-04 16:32:01 +00:00
AND i . item_deleted = 0
ORDER BY i . item_ts DESC , i . chat_item_id DESC
2023-12-23 17:07:23 +04:00
LIMIT ?
| ]
2025-01-22 23:33:54 +04:00
( groupMemberId' m , userId , groupId , count )