From e1370e8f3c148f2e0dc357f1ad40834288fcecbb Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sun, 18 Jun 2023 10:20:11 +0100 Subject: [PATCH] core: split Store.hs to multiple files for faster re-compilation (#2589) * core: split Store.hs to multiple files for faster re-compilation * remove unused compiler pragmas --- simplex-chat.cabal | 8 + src/Simplex/Chat.hs | 7 + src/Simplex/Chat/Mobile.hs | 1 + src/Simplex/Chat/Store.hs | 5611 +------------------------ src/Simplex/Chat/Store/Connections.hs | 142 + src/Simplex/Chat/Store/Direct.hs | 689 +++ src/Simplex/Chat/Store/Files.hs | 868 ++++ src/Simplex/Chat/Store/Groups.hs | 1295 ++++++ src/Simplex/Chat/Store/Messages.hs | 1805 ++++++++ src/Simplex/Chat/Store/Migrations.hs | 151 + src/Simplex/Chat/Store/Profiles.hs | 537 +++ src/Simplex/Chat/Store/Shared.hs | 332 ++ tests/ChatClient.hs | 1 + tests/ChatTests/Utils.hs | 2 +- tests/MobileTests.hs | 1 + 15 files changed, 5843 insertions(+), 5607 deletions(-) create mode 100644 src/Simplex/Chat/Store/Connections.hs create mode 100644 src/Simplex/Chat/Store/Direct.hs create mode 100644 src/Simplex/Chat/Store/Files.hs create mode 100644 src/Simplex/Chat/Store/Groups.hs create mode 100644 src/Simplex/Chat/Store/Messages.hs create mode 100644 src/Simplex/Chat/Store/Migrations.hs create mode 100644 src/Simplex/Chat/Store/Profiles.hs create mode 100644 src/Simplex/Chat/Store/Shared.hs diff --git a/simplex-chat.cabal b/simplex-chat.cabal index abe3763a9..b2ba047ce 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -107,6 +107,14 @@ library Simplex.Chat.ProfileGenerator Simplex.Chat.Protocol Simplex.Chat.Store + Simplex.Chat.Store.Connections + Simplex.Chat.Store.Direct + Simplex.Chat.Store.Files + Simplex.Chat.Store.Groups + Simplex.Chat.Store.Messages + Simplex.Chat.Store.Migrations + Simplex.Chat.Store.Profiles + Simplex.Chat.Store.Shared Simplex.Chat.Styled Simplex.Chat.Terminal Simplex.Chat.Terminal.Input diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 705b61b04..c186c26d2 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -58,6 +58,13 @@ import Simplex.Chat.Options import Simplex.Chat.ProfileGenerator (generateRandomProfile) import Simplex.Chat.Protocol import Simplex.Chat.Store +import Simplex.Chat.Store.Connections +import Simplex.Chat.Store.Direct +import Simplex.Chat.Store.Files +import Simplex.Chat.Store.Groups +import Simplex.Chat.Store.Messages +import Simplex.Chat.Store.Profiles +import Simplex.Chat.Store.Shared import Simplex.Chat.Types import Simplex.FileTransfer.Client.Main (maxFileSize) import Simplex.FileTransfer.Client.Presets (defaultXFTPServers) diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index eab0cf4d6..85900a6d7 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/src/Simplex/Chat/Mobile.hs @@ -37,6 +37,7 @@ import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList) import Simplex.Chat.Mobile.WebRTC import Simplex.Chat.Options import Simplex.Chat.Store +import Simplex.Chat.Store.Profiles import Simplex.Chat.Types import Simplex.Messaging.Agent.Env.SQLite (createAgentStore) import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), MigrationError) diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 242cafd9f..4e3c4ab90 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -1,22 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - module Simplex.Chat.Store ( SQLiteStore, StoreError (..), @@ -26,5602 +7,20 @@ module Simplex.Chat.Store migrations, -- used in tests chatStoreFile, agentStoreFile, - createUserRecord, - createUserRecordAt, - getUsersInfo, - getUsers, - setActiveUser, - getSetActiveUser, - getUser, - getUserIdByName, - getUserByAConnId, - getUserByASndFileId, - getUserByARcvFileId, - getUserByContactId, - getUserByGroupId, - getUserByFileId, - getUserByContactRequestId, - getUserFileInfo, - deleteUserRecord, - updateUserPrivacy, - createDirectConnection, - createConnReqConnection, - getProfileById, - getConnReqContactXContactId, - createDirectContact, - deleteContactConnectionsAndFiles, - deleteContact, - deleteContactWithoutGroups, - setContactDeleted, - getDeletedContacts, - getContactByName, - getContact, - getContactIdByName, - updateUserProfile, - setUserProfileContactLink, - updateContactProfile, - updateContactUserPreferences, - updateContactAlias, - updateContactConnectionAlias, - updateContactUsed, - updateContactUnreadChat, - updateGroupUnreadChat, - setConnectionVerified, - incConnectionAuthErrCounter, - setConnectionAuthErrCounter, - getUserContacts, - getUserContactProfiles, - createUserContactLink, - getUserAddressConnections, - getUserContactLinks, - deleteUserAddress, - getUserAddress, - getUserContactLinkById, - updateUserAddressAutoAccept, - createGroupLink, - getGroupLinkConnection, - deleteGroupLink, - getGroupLink, - getGroupLinkId, - setGroupLinkMemberRole, - createOrUpdateContactRequest, - getContactRequest', - getContactRequest, - getContactRequestIdByName, - deleteContactRequest, - createAcceptedContact, - getLiveSndFileTransfers, - getLiveRcvFileTransfers, - getPendingSndChunks, - getPendingContactConnections, - getContactConnections, - getConnectionEntity, - getConnectionById, - getConnectionsContacts, - getGroupAndMember, - updateConnectionStatus, - createNewGroup, - createGroupInvitation, - setGroupInvitationChatItemId, - getGroup, - getGroupInfo, - updateGroupProfile, - getGroupIdByName, - getGroupMemberIdByName, - getGroupInfoByName, - getGroupMember, - getGroupMemberById, - getGroupMembers, - getGroupMembersForExpiration, - deleteGroupConnectionsAndFiles, - deleteGroupItemsAndMembers, - deleteGroup, - getUserGroups, - getUserGroupDetails, - getContactGroupPreferences, - checkContactHasGroups, - getGroupInvitation, - createNewContactMember, - createNewContactMemberAsync, - getContactViaMember, - setNewContactMemberConnRequest, - getMemberInvitation, - createMemberConnection, - createMemberConnectionAsync, - updateGroupMemberStatus, - updateGroupMemberStatusById, - createNewGroupMember, - checkGroupMemberHasItems, - deleteGroupMember, - deleteGroupMemberConnection, - updateGroupMemberRole, - createIntroductions, - updateIntroStatus, - saveIntroInvitation, - createIntroReMember, - createIntroToMemberContact, - saveMemberInvitation, - getViaGroupMember, - getViaGroupContact, - getMatchingContacts, - randomBytes, - createSentProbe, - createSentProbeHash, - deleteSentProbe, - matchReceivedProbe, - matchReceivedProbeHash, - matchSentProbe, - mergeContactRecords, - createSndDirectFileTransfer, - createSndDirectFTConnection, - createSndGroupFileTransfer, - createSndGroupFileTransferConnection, - createSndDirectInlineFT, - createSndGroupInlineFT, - updateSndDirectFTDelivery, - updateSndGroupFTDelivery, - getSndFTViaMsgDelivery, - createSndFileTransferXFTP, - createSndFTDescrXFTP, - setSndFTPrivateSndDescr, - updateSndFTDescrXFTP, - createExtraSndFTDescrs, - updateSndFTDeliveryXFTP, - setSndFTAgentDeleted, - getXFTPSndFileDBId, - getXFTPRcvFileDBId, - updateFileCancelled, - updateCIFileStatus, - getSharedMsgIdByFileId, - getFileIdBySharedMsgId, - getGroupFileIdBySharedMsgId, - getDirectFileIdBySharedMsgId, - getChatRefByFileId, - updateSndFileStatus, - createSndFileChunk, - updateSndFileChunkMsg, - updateSndFileChunkSent, - deleteSndFileChunks, - createRcvFileTransfer, - createRcvGroupFileTransfer, - appendRcvFD, - getRcvFileDescrByFileId, - updateRcvFileAgentId, - getRcvFileTransferById, - getRcvFileTransfer, - acceptRcvFileTransfer, - getContactByFileId, - acceptRcvInlineFT, - startRcvInlineFT, - xftpAcceptRcvFT, - setRcvFileToReceive, - getRcvFilesToReceive, - setRcvFTAgentDeleted, - updateRcvFileStatus, - createRcvFileChunk, - updatedRcvFileChunkStored, - deleteRcvFileChunks, - updateFileTransferChatItemId, - getFileTransfer, - getFileTransferProgress, - getFileTransferMeta, - getSndFileTransfer, - getSndFileTransfers, - getContactFileInfo, - deleteContactCIs, - getGroupFileInfo, - deleteGroupCIs, - createNewSndMessage, - createSndMsgDelivery, - createNewMessageAndRcvMsgDelivery, - createSndMsgDeliveryEvent, - createRcvMsgDeliveryEvent, - createPendingGroupMessage, - getPendingGroupMessages, - deletePendingGroupMessage, - deleteOldMessages, - updateChatTs, - createNewSndChatItem, - createNewRcvChatItem, - createNewChatItemNoMsg, - getChatPreviews, - getDirectChat, - getGroupChat, - getAllChatItems, - getAChatItem, - getChatRefViaItemId, - getChatItemVersions, - getDirectCIReactions, - getDirectReactions, - setDirectReaction, - getGroupCIReactions, - getGroupReactions, - setGroupReaction, - getChatItemIdByAgentMsgId, - getDirectChatItem, - getDirectChatItemBySharedMsgId, - getDirectChatItemByAgentMsgId, - getDirectChatItemsLast, - getGroupChatItem, - getGroupChatItemBySharedMsgId, - getGroupMemberCIBySharedMsgId, - getGroupMemberChatItemLast, - getDirectChatItemIdByText, - getDirectChatItemIdByText', - getGroupChatItemIdByText, - getGroupChatItemIdByText', - getChatItemByFileId, - getChatItemByGroupId, - updateDirectChatItemStatus, - updateDirectCIFileStatus, - updateDirectChatItem, - updateDirectChatItem', - addInitialAndNewCIVersions, - createChatItemVersion, - deleteDirectChatItem, - markDirectChatItemDeleted, - updateGroupChatItem, - deleteGroupChatItem, - updateGroupChatItemModerated, - markGroupChatItemDeleted, - updateDirectChatItemsRead, - getDirectUnreadTimedItems, - setDirectChatItemDeleteAt, - updateGroupChatItemsRead, - getGroupUnreadTimedItems, - setGroupChatItemDeleteAt, - getProtocolServers, - overwriteProtocolServers, - createCall, - deleteCalls, - getCalls, - createCommand, - setCommandConnId, - deleteCommand, - updateCommandStatus, - getCommandDataByCorrId, - setConnConnReqInv, - getXGrpMemIntroContDirect, - getXGrpMemIntroContGroup, - getTimedItems, - getChatItemTTL, - setChatItemTTL, - getContactExpiredFileInfo, - deleteContactExpiredCIs, - getGroupExpiredFileInfo, - deleteGroupExpiredCIs, - getPendingContactConnection, - deletePendingContactConnection, - updateContactSettings, - updateGroupSettings, withTransaction, ) where -import Control.Applicative ((<|>)) -import Control.Concurrent.STM (stateTVar) -import Control.Exception (Exception) -import qualified Control.Exception as E -import Control.Monad.Except -import Crypto.Random (ChaChaDRG, randomBytesGenerate) -import Data.Aeson (ToJSON) -import qualified Data.Aeson as J -import Data.Bifunctor (first) -import qualified Data.ByteString.Base64 as B64 -import Data.ByteString.Char8 (ByteString) -import Data.Either (fromRight, rights) -import Data.Functor (($>)) -import Data.Int (Int64) -import Data.List (sortOn) -import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as L -import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe, mapMaybe) -import Data.Ord (Down (..)) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Encoding (decodeLatin1, encodeUtf8) -import Data.Time (addUTCTime) -import Data.Time.Clock (UTCTime (..), getCurrentTime, nominalDay) -import Data.Type.Equality -import Database.SQLite.Simple (NamedParam (..), Only (..), Query (..), SQLError, (:.) (..)) -import qualified Database.SQLite.Simple as DB -import Database.SQLite.Simple.QQ (sql) -import GHC.Generics (Generic) -import Simplex.Chat.Call -import Simplex.Chat.Markdown -import Simplex.Chat.Messages -import Simplex.Chat.Messages.CIContent -import Simplex.Chat.Migrations.M20220101_initial -import Simplex.Chat.Migrations.M20220122_v1_1 -import Simplex.Chat.Migrations.M20220205_chat_item_status -import Simplex.Chat.Migrations.M20220210_deduplicate_contact_requests -import Simplex.Chat.Migrations.M20220224_messages_fks -import Simplex.Chat.Migrations.M20220301_smp_servers -import Simplex.Chat.Migrations.M20220302_profile_images -import Simplex.Chat.Migrations.M20220304_msg_quotes -import Simplex.Chat.Migrations.M20220321_chat_item_edited -import Simplex.Chat.Migrations.M20220404_files_status_fields -import Simplex.Chat.Migrations.M20220514_profiles_user_id -import Simplex.Chat.Migrations.M20220626_auto_reply -import Simplex.Chat.Migrations.M20220702_calls -import Simplex.Chat.Migrations.M20220715_groups_chat_item_id -import Simplex.Chat.Migrations.M20220811_chat_items_indices -import Simplex.Chat.Migrations.M20220812_incognito_profiles -import Simplex.Chat.Migrations.M20220818_chat_notifications -import Simplex.Chat.Migrations.M20220822_groups_host_conn_custom_user_profile_id -import Simplex.Chat.Migrations.M20220823_delete_broken_group_event_chat_items -import Simplex.Chat.Migrations.M20220824_profiles_local_alias -import Simplex.Chat.Migrations.M20220909_commands -import Simplex.Chat.Migrations.M20220926_connection_alias -import Simplex.Chat.Migrations.M20220928_settings -import Simplex.Chat.Migrations.M20221001_shared_msg_id_indices -import Simplex.Chat.Migrations.M20221003_delete_broken_integrity_error_chat_items -import Simplex.Chat.Migrations.M20221004_idx_msg_deliveries_message_id -import Simplex.Chat.Migrations.M20221011_user_contact_links_group_id -import Simplex.Chat.Migrations.M20221012_inline_files -import Simplex.Chat.Migrations.M20221019_unread_chat -import Simplex.Chat.Migrations.M20221021_auto_accept__group_links -import Simplex.Chat.Migrations.M20221024_contact_used -import Simplex.Chat.Migrations.M20221025_chat_settings -import Simplex.Chat.Migrations.M20221029_group_link_id -import Simplex.Chat.Migrations.M20221112_server_password -import Simplex.Chat.Migrations.M20221115_server_cfg -import Simplex.Chat.Migrations.M20221129_delete_group_feature_items -import Simplex.Chat.Migrations.M20221130_delete_item_deleted -import Simplex.Chat.Migrations.M20221209_verified_connection -import Simplex.Chat.Migrations.M20221210_idxs -import Simplex.Chat.Migrations.M20221211_group_description -import Simplex.Chat.Migrations.M20221212_chat_items_timed -import Simplex.Chat.Migrations.M20221214_live_message -import Simplex.Chat.Migrations.M20221222_chat_ts -import Simplex.Chat.Migrations.M20221223_idx_chat_items_item_status -import Simplex.Chat.Migrations.M20221230_idxs -import Simplex.Chat.Migrations.M20230107_connections_auth_err_counter -import Simplex.Chat.Migrations.M20230111_users_agent_user_id -import Simplex.Chat.Migrations.M20230117_fkey_indexes -import Simplex.Chat.Migrations.M20230118_recreate_smp_servers -import Simplex.Chat.Migrations.M20230129_drop_chat_items_group_idx -import Simplex.Chat.Migrations.M20230206_item_deleted_by_group_member_id -import Simplex.Chat.Migrations.M20230303_group_link_role -import Simplex.Chat.Migrations.M20230317_hidden_profiles -import Simplex.Chat.Migrations.M20230318_file_description -import Simplex.Chat.Migrations.M20230321_agent_file_deleted -import Simplex.Chat.Migrations.M20230328_files_protocol -import Simplex.Chat.Migrations.M20230402_protocol_servers -import Simplex.Chat.Migrations.M20230411_extra_xftp_file_descriptions -import Simplex.Chat.Migrations.M20230420_rcv_files_to_receive -import Simplex.Chat.Migrations.M20230422_profile_contact_links -import Simplex.Chat.Migrations.M20230504_recreate_msg_delivery_events_cleanup_messages -import Simplex.Chat.Migrations.M20230505_chat_item_versions -import Simplex.Chat.Migrations.M20230511_reactions -import Simplex.Chat.Migrations.M20230519_item_deleted_ts -import Simplex.Chat.Migrations.M20230526_indexes -import Simplex.Chat.Migrations.M20230529_indexes -import Simplex.Chat.Migrations.M20230608_deleted_contacts -import Simplex.Chat.Protocol -import Simplex.Chat.Types -import Simplex.Chat.Util (week) -import Simplex.Messaging.Agent.Protocol (ACorrId, AgentMsgId, ConnId, InvitationId, MsgMeta (..), UserId) -import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation, MigrationError, SQLiteStore (..), createSQLiteStore, firstRow, firstRow', maybeFirstRow, withTransaction) -import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..)) -import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON) -import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..)) -import Simplex.Messaging.Transport.Client (TransportHost) -import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8) -import UnliftIO.STM - -schemaMigrations :: [(String, Query, Maybe Query)] -schemaMigrations = - [ ("20220101_initial", m20220101_initial, Nothing), - ("20220122_v1_1", m20220122_v1_1, Nothing), - ("20220205_chat_item_status", m20220205_chat_item_status, Nothing), - ("20220210_deduplicate_contact_requests", m20220210_deduplicate_contact_requests, Nothing), - ("20220224_messages_fks", m20220224_messages_fks, Nothing), - ("20220301_smp_servers", m20220301_smp_servers, Nothing), - ("20220302_profile_images", m20220302_profile_images, Nothing), - ("20220304_msg_quotes", m20220304_msg_quotes, Nothing), - ("20220321_chat_item_edited", m20220321_chat_item_edited, Nothing), - ("20220404_files_status_fields", m20220404_files_status_fields, Nothing), - ("20220514_profiles_user_id", m20220514_profiles_user_id, Nothing), - ("20220626_auto_reply", m20220626_auto_reply, Nothing), - ("20220702_calls", m20220702_calls, Nothing), - ("20220715_groups_chat_item_id", m20220715_groups_chat_item_id, Nothing), - ("20220811_chat_items_indices", m20220811_chat_items_indices, Nothing), - ("20220812_incognito_profiles", m20220812_incognito_profiles, Nothing), - ("20220818_chat_notifications", m20220818_chat_notifications, Nothing), - ("20220822_groups_host_conn_custom_user_profile_id", m20220822_groups_host_conn_custom_user_profile_id, Nothing), - ("20220823_delete_broken_group_event_chat_items", m20220823_delete_broken_group_event_chat_items, Nothing), - ("20220824_profiles_local_alias", m20220824_profiles_local_alias, Nothing), - ("20220909_commands", m20220909_commands, Nothing), - ("20220926_connection_alias", m20220926_connection_alias, Nothing), - ("20220928_settings", m20220928_settings, Nothing), - ("20221001_shared_msg_id_indices", m20221001_shared_msg_id_indices, Nothing), - ("20221003_delete_broken_integrity_error_chat_items", m20221003_delete_broken_integrity_error_chat_items, Nothing), - ("20221004_idx_msg_deliveries_message_id", m20221004_idx_msg_deliveries_message_id, Nothing), - ("20221011_user_contact_links_group_id", m20221011_user_contact_links_group_id, Nothing), - ("20221012_inline_files", m20221012_inline_files, Nothing), - ("20221019_unread_chat", m20221019_unread_chat, Nothing), - ("20221021_auto_accept__group_links", m20221021_auto_accept__group_links, Nothing), - ("20221024_contact_used", m20221024_contact_used, Nothing), - ("20221025_chat_settings", m20221025_chat_settings, Nothing), - ("20221029_group_link_id", m20221029_group_link_id, Nothing), - ("20221112_server_password", m20221112_server_password, Nothing), - ("20221115_server_cfg", m20221115_server_cfg, Nothing), - ("20221129_delete_group_feature_items", m20221129_delete_group_feature_items, Nothing), - ("20221130_delete_item_deleted", m20221130_delete_item_deleted, Nothing), - ("20221209_verified_connection", m20221209_verified_connection, Nothing), - ("20221210_idxs", m20221210_idxs, Nothing), - ("20221211_group_description", m20221211_group_description, Nothing), - ("20221212_chat_items_timed", m20221212_chat_items_timed, Nothing), - ("20221214_live_message", m20221214_live_message, Nothing), - ("20221222_chat_ts", m20221222_chat_ts, Nothing), - ("20221223_idx_chat_items_item_status", m20221223_idx_chat_items_item_status, Nothing), - ("20221230_idxs", m20221230_idxs, Nothing), - ("20230107_connections_auth_err_counter", m20230107_connections_auth_err_counter, Nothing), - ("20230111_users_agent_user_id", m20230111_users_agent_user_id, Nothing), - ("20230117_fkey_indexes", m20230117_fkey_indexes, Nothing), - ("20230118_recreate_smp_servers", m20230118_recreate_smp_servers, Nothing), - ("20230129_drop_chat_items_group_idx", m20230129_drop_chat_items_group_idx, Nothing), - ("20230206_item_deleted_by_group_member_id", m20230206_item_deleted_by_group_member_id, Nothing), - ("20230303_group_link_role", m20230303_group_link_role, Nothing), - ("20230317_hidden_profiles", m20230317_hidden_profiles, Just down_m20230317_hidden_profiles), - ("20230318_file_description", m20230318_file_description, Just down_m20230318_file_description), - ("20230321_agent_file_deleted", m20230321_agent_file_deleted, Just down_m20230321_agent_file_deleted), - ("20230328_files_protocol", m20230328_files_protocol, Just down_m20230328_files_protocol), - ("20230402_protocol_servers", m20230402_protocol_servers, Just down_m20230402_protocol_servers), - ("20230411_extra_xftp_file_descriptions", m20230411_extra_xftp_file_descriptions, Just down_m20230411_extra_xftp_file_descriptions), - ("20230420_rcv_files_to_receive", m20230420_rcv_files_to_receive, Just down_m20230420_rcv_files_to_receive), - ("20230422_profile_contact_links", m20230422_profile_contact_links, Just down_m20230422_profile_contact_links), - ("20230504_recreate_msg_delivery_events_cleanup_messages", m20230504_recreate_msg_delivery_events_cleanup_messages, Just down_m20230504_recreate_msg_delivery_events_cleanup_messages), - ("20230505_chat_item_versions", m20230505_chat_item_versions, Just down_m20230505_chat_item_versions), - ("20230511_reactions", m20230511_reactions, Just down_m20230511_reactions), - ("20230519_item_deleted_ts", m20230519_item_deleted_ts, Just down_m20230519_item_deleted_ts), - ("20230526_indexes", m20230526_indexes, Just down_m20230526_indexes), - ("20230529_indexes", m20230529_indexes, Just down_m20230529_indexes), - ("20230608_deleted_contacts", m20230608_deleted_contacts, Just down_m20230608_deleted_contacts) - ] - --- | The list of migrations in ascending order by date -migrations :: [Migration] -migrations = sortOn name $ map migration schemaMigrations - where - migration (name, up, down) = Migration {name, up = fromQuery up, down = fromQuery <$> down} +import Simplex.Chat.Store.Migrations +import Simplex.Chat.Store.Profiles +import Simplex.Chat.Store.Shared +import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation, MigrationError, SQLiteStore (..), createSQLiteStore, withTransaction) createChatStore :: FilePath -> String -> MigrationConfirmation -> IO (Either MigrationError SQLiteStore) -createChatStore dbFilePath dbKey = createSQLiteStore dbFilePath dbKey migrations +createChatStore dbPath dbKey = createSQLiteStore dbPath dbKey migrations chatStoreFile :: FilePath -> FilePath chatStoreFile = (<> "_chat.db") agentStoreFile :: FilePath -> FilePath agentStoreFile = (<> "_agent.db") - -checkConstraint :: StoreError -> ExceptT StoreError IO a -> ExceptT StoreError IO a -checkConstraint err action = ExceptT $ runExceptT action `E.catch` (pure . Left . handleSQLError err) - -handleSQLError :: StoreError -> SQLError -> StoreError -handleSQLError err e - | DB.sqlError e == DB.ErrorConstraint = err - | otherwise = SEInternalError $ show e - -insertedRowId :: DB.Connection -> IO Int64 -insertedRowId db = fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid()" - -createUserRecord :: DB.Connection -> AgentUserId -> Profile -> Bool -> ExceptT StoreError IO User -createUserRecord db auId p activeUser = createUserRecordAt db auId p activeUser =<< liftIO getCurrentTime - -createUserRecordAt :: DB.Connection -> AgentUserId -> Profile -> Bool -> UTCTime -> ExceptT StoreError IO User -createUserRecordAt db (AgentUserId auId) Profile {displayName, fullName, image, preferences = userPreferences} activeUser currentTs = - checkConstraint SEDuplicateName . liftIO $ do - when activeUser $ DB.execute_ db "UPDATE users SET active_user = 0" - DB.execute - db - "INSERT INTO users (agent_user_id, local_display_name, active_user, contact_id, show_ntfs, created_at, updated_at) VALUES (?,?,?,0,?,?,?)" - (auId, displayName, activeUser, True, currentTs, currentTs) - userId <- insertedRowId db - DB.execute - db - "INSERT INTO display_names (local_display_name, ldn_base, user_id, created_at, updated_at) VALUES (?,?,?,?,?)" - (displayName, displayName, userId, currentTs, currentTs) - DB.execute - db - "INSERT INTO contact_profiles (display_name, full_name, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?)" - (displayName, fullName, image, userId, userPreferences, currentTs, currentTs) - profileId <- insertedRowId db - DB.execute - db - "INSERT INTO contacts (contact_profile_id, local_display_name, user_id, is_user, created_at, updated_at) VALUES (?,?,?,?,?,?)" - (profileId, displayName, userId, True, currentTs, currentTs) - contactId <- insertedRowId db - DB.execute db "UPDATE users SET contact_id = ? WHERE user_id = ?" (contactId, userId) - pure $ toUser $ (userId, auId, contactId, profileId, activeUser, displayName, fullName, image, Nothing, userPreferences, True) :. (Nothing, Nothing) - -getUsersInfo :: DB.Connection -> IO [UserInfo] -getUsersInfo db = getUsers db >>= mapM getUserInfo - where - getUserInfo :: User -> IO UserInfo - getUserInfo user@User {userId} = do - ctCount <- - maybeFirstRow fromOnly $ - DB.query - db - [sql| - SELECT COUNT(1) - FROM chat_items i - JOIN contacts ct USING (contact_id) - WHERE i.user_id = ? AND i.item_status = ? AND (ct.enable_ntfs = 1 OR ct.enable_ntfs IS NULL) AND ct.deleted = 0 - |] - (userId, CISRcvNew) - gCount <- - maybeFirstRow fromOnly $ - DB.query - db - [sql| - SELECT COUNT(1) - FROM chat_items i - JOIN groups g USING (group_id) - WHERE i.user_id = ? AND i.item_status = ? AND (g.enable_ntfs = 1 OR g.enable_ntfs IS NULL) - |] - (userId, CISRcvNew) - pure UserInfo {user, unreadCount = fromMaybe 0 ctCount + fromMaybe 0 gCount} - -getUsers :: DB.Connection -> IO [User] -getUsers db = - map toUser <$> DB.query_ db userQuery - -userQuery :: Query -userQuery = - [sql| - SELECT u.user_id, u.agent_user_id, u.contact_id, ucp.contact_profile_id, u.active_user, u.local_display_name, ucp.full_name, ucp.image, ucp.contact_link, ucp.preferences, u.show_ntfs, u.view_pwd_hash, u.view_pwd_salt - FROM users u - JOIN contacts uct ON uct.contact_id = u.contact_id - JOIN contact_profiles ucp ON ucp.contact_profile_id = uct.contact_profile_id - |] - -toUser :: (UserId, UserId, ContactId, ProfileId, Bool, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, Maybe Preferences, Bool) :. (Maybe B64UrlByteString, Maybe B64UrlByteString) -> User -toUser ((userId, auId, userContactId, profileId, activeUser, displayName, fullName, image, contactLink, userPreferences, showNtfs) :. (viewPwdHash_, viewPwdSalt_)) = - User {userId, agentUserId = AgentUserId auId, userContactId, localDisplayName = displayName, profile, activeUser, fullPreferences, showNtfs, viewPwdHash} - where - profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences = userPreferences, localAlias = ""} - fullPreferences = mergePreferences Nothing userPreferences - viewPwdHash = UserPwdHash <$> viewPwdHash_ <*> viewPwdSalt_ - -setActiveUser :: DB.Connection -> UserId -> IO () -setActiveUser db userId = do - DB.execute_ db "UPDATE users SET active_user = 0" - DB.execute db "UPDATE users SET active_user = 1 WHERE user_id = ?" (Only userId) - -getSetActiveUser :: DB.Connection -> UserId -> ExceptT StoreError IO User -getSetActiveUser db userId = do - liftIO $ setActiveUser db userId - getUser db userId - -getUser :: DB.Connection -> UserId -> ExceptT StoreError IO User -getUser db userId = - ExceptT . firstRow toUser (SEUserNotFound userId) $ - DB.query db (userQuery <> " WHERE u.user_id = ?") (Only userId) - -getUserIdByName :: DB.Connection -> UserName -> ExceptT StoreError IO Int64 -getUserIdByName db uName = - ExceptT . firstRow fromOnly (SEUserNotFoundByName uName) $ - DB.query db "SELECT user_id FROM users WHERE local_display_name = ?" (Only uName) - -getUserByAConnId :: DB.Connection -> AgentConnId -> IO (Maybe User) -getUserByAConnId db agentConnId = - maybeFirstRow toUser $ - DB.query db (userQuery <> " JOIN connections c ON c.user_id = u.user_id WHERE c.agent_conn_id = ?") (Only agentConnId) - -getUserByASndFileId :: DB.Connection -> AgentSndFileId -> IO (Maybe User) -getUserByASndFileId db aSndFileId = - maybeFirstRow toUser $ - DB.query db (userQuery <> " JOIN files f ON f.user_id = u.user_id WHERE f.agent_snd_file_id = ?") (Only aSndFileId) - -getUserByARcvFileId :: DB.Connection -> AgentRcvFileId -> IO (Maybe User) -getUserByARcvFileId db aRcvFileId = - maybeFirstRow toUser $ - DB.query db (userQuery <> " JOIN files f ON f.user_id = u.user_id JOIN rcv_files r ON r.file_id = f.file_id WHERE r.agent_rcv_file_id = ?") (Only aRcvFileId) - -getUserByContactId :: DB.Connection -> ContactId -> ExceptT StoreError IO User -getUserByContactId db contactId = - ExceptT . firstRow toUser (SEUserNotFoundByContactId contactId) $ - DB.query db (userQuery <> " JOIN contacts ct ON ct.user_id = u.user_id WHERE ct.contact_id = ? AND ct.deleted = 0") (Only contactId) - -getUserByGroupId :: DB.Connection -> GroupId -> ExceptT StoreError IO User -getUserByGroupId db groupId = - ExceptT . firstRow toUser (SEUserNotFoundByGroupId groupId) $ - DB.query db (userQuery <> " JOIN groups g ON g.user_id = u.user_id WHERE g.group_id = ?") (Only groupId) - -getUserByFileId :: DB.Connection -> FileTransferId -> ExceptT StoreError IO User -getUserByFileId db fileId = - ExceptT . firstRow toUser (SEUserNotFoundByFileId fileId) $ - DB.query db (userQuery <> " JOIN files f ON f.user_id = u.user_id WHERE f.file_id = ?") (Only fileId) - -getUserByContactRequestId :: DB.Connection -> Int64 -> ExceptT StoreError IO User -getUserByContactRequestId db contactRequestId = - ExceptT . firstRow toUser (SEUserNotFoundByContactRequestId contactRequestId) $ - DB.query db (userQuery <> " JOIN contact_requests cr ON cr.user_id = u.user_id WHERE cr.contact_request_id = ?") (Only contactRequestId) - -getUserFileInfo :: DB.Connection -> User -> IO [CIFileInfo] -getUserFileInfo db User {userId} = - map toFileInfo - <$> DB.query db (fileInfoQuery <> " WHERE i.user_id = ?") (Only userId) - -fileInfoQuery :: Query -fileInfoQuery = - [sql| - SELECT f.file_id, f.ci_file_status, f.file_path - FROM chat_items i - JOIN files f ON f.chat_item_id = i.chat_item_id - |] - -toFileInfo :: (Int64, Maybe ACIFileStatus, Maybe FilePath) -> CIFileInfo -toFileInfo (fileId, fileStatus, filePath) = CIFileInfo {fileId, fileStatus, filePath} - -deleteUserRecord :: DB.Connection -> User -> IO () -deleteUserRecord db User {userId} = - DB.execute db "DELETE FROM users WHERE user_id = ?" (Only userId) - -updateUserPrivacy :: DB.Connection -> User -> IO () -updateUserPrivacy db User {userId, showNtfs, viewPwdHash} = - DB.execute - db - [sql| - UPDATE users - SET view_pwd_hash = ?, view_pwd_salt = ?, show_ntfs = ? - WHERE user_id = ? - |] - (hashSalt viewPwdHash :. (showNtfs, userId)) - where - hashSalt = L.unzip . fmap (\UserPwdHash {hash, salt} -> (hash, salt)) - -createConnReqConnection :: DB.Connection -> UserId -> ConnId -> ConnReqUriHash -> XContactId -> Maybe Profile -> Maybe GroupLinkId -> IO PendingContactConnection -createConnReqConnection db userId acId cReqHash xContactId incognitoProfile groupLinkId = do - createdAt <- getCurrentTime - customUserProfileId <- mapM (createIncognitoProfile_ db userId createdAt) incognitoProfile - let pccConnStatus = ConnJoined - DB.execute - db - [sql| - INSERT INTO connections ( - user_id, agent_conn_id, conn_status, conn_type, - via_contact_uri_hash, xcontact_id, custom_user_profile_id, via_group_link, group_link_id, created_at, updated_at - ) VALUES (?,?,?,?,?,?,?,?,?,?,?) - |] - ((userId, acId, pccConnStatus, ConnContact, cReqHash, xContactId) :. (customUserProfileId, isJust groupLinkId, groupLinkId, createdAt, createdAt)) - pccConnId <- insertedRowId db - pure PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = True, viaUserContactLink = Nothing, groupLinkId, customUserProfileId, connReqInv = Nothing, localAlias = "", createdAt, updatedAt = createdAt} - -getConnReqContactXContactId :: DB.Connection -> User -> ConnReqUriHash -> IO (Maybe Contact, Maybe XContactId) -getConnReqContactXContactId db user@User {userId} cReqHash = do - getContact' >>= \case - c@(Just _) -> pure (c, Nothing) - Nothing -> (Nothing,) <$> getXContactId - where - getContact' :: IO (Maybe Contact) - getContact' = - maybeFirstRow (toContact user) $ - DB.query - db - [sql| - SELECT - -- Contact - ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, - cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, - -- Connection - c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias, - c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter - FROM contacts ct - JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id - JOIN connections c ON c.contact_id = ct.contact_id - WHERE ct.user_id = ? AND c.via_contact_uri_hash = ? AND ct.deleted = 0 - ORDER BY c.connection_id DESC - LIMIT 1 - |] - (userId, cReqHash) - getXContactId :: IO (Maybe XContactId) - getXContactId = - maybeFirstRow fromOnly $ - DB.query - db - "SELECT xcontact_id FROM connections WHERE user_id = ? AND via_contact_uri_hash = ? LIMIT 1" - (userId, cReqHash) - -createDirectConnection :: DB.Connection -> User -> ConnId -> ConnReqInvitation -> ConnStatus -> Maybe Profile -> IO PendingContactConnection -createDirectConnection db User {userId} acId cReq pccConnStatus incognitoProfile = do - createdAt <- getCurrentTime - customUserProfileId <- mapM (createIncognitoProfile_ db userId createdAt) incognitoProfile - DB.execute - db - [sql| - INSERT INTO connections - (user_id, agent_conn_id, conn_req_inv, conn_status, conn_type, custom_user_profile_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?) - |] - (userId, acId, cReq, pccConnStatus, ConnContact, customUserProfileId, createdAt, createdAt) - pccConnId <- insertedRowId db - pure PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = False, viaUserContactLink = Nothing, groupLinkId = Nothing, customUserProfileId, connReqInv = Just cReq, localAlias = "", createdAt, updatedAt = createdAt} - -createIncognitoProfile_ :: DB.Connection -> UserId -> UTCTime -> Profile -> IO Int64 -createIncognitoProfile_ db userId createdAt Profile {displayName, fullName, image} = do - DB.execute - db - [sql| - INSERT INTO contact_profiles (display_name, full_name, image, user_id, incognito, created_at, updated_at) - VALUES (?,?,?,?,?,?,?) - |] - (displayName, fullName, image, userId, Just True, createdAt, createdAt) - insertedRowId db - -getProfileById :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO LocalProfile -getProfileById db userId profileId = - ExceptT . firstRow toProfile (SEProfileNotFound profileId) $ - DB.query - db - [sql| - SELECT cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, cp.preferences -- , ct.user_preferences - FROM contact_profiles cp - WHERE cp.user_id = ? AND cp.contact_profile_id = ? - |] - (userId, profileId) - where - toProfile :: (ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Preferences) -> LocalProfile - toProfile (displayName, fullName, image, contactLink, localAlias, preferences) = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} - -createConnection_ :: DB.Connection -> UserId -> ConnType -> Maybe Int64 -> ConnId -> Maybe ContactId -> Maybe Int64 -> Maybe ProfileId -> Int -> UTCTime -> IO Connection -createConnection_ db userId connType entityId acId viaContact viaUserContactLink customUserProfileId connLevel currentTs = do - viaLinkGroupId :: Maybe Int64 <- fmap join . forM viaUserContactLink $ \ucLinkId -> - maybeFirstRow fromOnly $ DB.query db "SELECT group_id FROM user_contact_links WHERE user_id = ? AND user_contact_link_id = ? AND group_id IS NOT NULL" (userId, ucLinkId) - let viaGroupLink = isJust viaLinkGroupId - DB.execute - db - [sql| - INSERT INTO connections ( - user_id, agent_conn_id, conn_level, via_contact, via_user_contact_link, via_group_link, custom_user_profile_id, conn_status, conn_type, - contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at, updated_at - ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) - |] - ( (userId, acId, connLevel, viaContact, viaUserContactLink, viaGroupLink, customUserProfileId, ConnNew, connType) - :. (ent ConnContact, ent ConnMember, ent ConnSndFile, ent ConnRcvFile, ent ConnUserContact, currentTs, currentTs) - ) - connId <- insertedRowId db - pure Connection {connId, agentConnId = AgentConnId acId, connType, entityId, viaContact, viaUserContactLink, viaGroupLink, groupLinkId = Nothing, customUserProfileId, connLevel, connStatus = ConnNew, localAlias = "", createdAt = currentTs, connectionCode = Nothing, authErrCounter = 0} - where - ent ct = if connType == ct then entityId else Nothing - -createDirectContact :: DB.Connection -> User -> Connection -> Profile -> ExceptT StoreError IO Contact -createDirectContact db user@User {userId} activeConn@Connection {connId, localAlias} p@Profile {preferences} = do - createdAt <- liftIO getCurrentTime - (localDisplayName, contactId, profileId) <- createContact_ db userId connId p localAlias Nothing createdAt (Just createdAt) - let profile = toLocalProfile profileId p localAlias - userPreferences = emptyChatPrefs - mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn - pure $ Contact {contactId, localDisplayName, profile, activeConn, viaGroup = Nothing, contactUsed = False, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt, updatedAt = createdAt, chatTs = Just createdAt} - -createContact_ :: DB.Connection -> UserId -> Int64 -> Profile -> LocalAlias -> Maybe Int64 -> UTCTime -> Maybe UTCTime -> ExceptT StoreError IO (Text, ContactId, ProfileId) -createContact_ db userId connId Profile {displayName, fullName, image, contactLink, preferences} localAlias viaGroup currentTs chatTs = - ExceptT . withLocalDisplayName db userId displayName $ \ldn -> do - DB.execute - db - "INSERT INTO contact_profiles (display_name, full_name, image, contact_link, user_id, local_alias, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)" - (displayName, fullName, image, contactLink, userId, localAlias, preferences, currentTs, currentTs) - profileId <- insertedRowId db - DB.execute - db - "INSERT INTO contacts (contact_profile_id, local_display_name, user_id, via_group, created_at, updated_at, chat_ts) VALUES (?,?,?,?,?,?,?)" - (profileId, ldn, userId, viaGroup, currentTs, currentTs, chatTs) - contactId <- insertedRowId db - DB.execute db "UPDATE connections SET contact_id = ?, updated_at = ? WHERE connection_id = ?" (contactId, currentTs, connId) - pure $ Right (ldn, contactId, profileId) - -deleteContactConnectionsAndFiles :: DB.Connection -> UserId -> Contact -> IO () -deleteContactConnectionsAndFiles db userId Contact {contactId} = do - DB.execute - db - [sql| - DELETE FROM connections WHERE connection_id IN ( - SELECT connection_id - FROM connections c - JOIN contacts ct ON ct.contact_id = c.contact_id - WHERE ct.user_id = ? AND ct.contact_id = ? - ) - |] - (userId, contactId) - DB.execute db "DELETE FROM files WHERE user_id = ? AND contact_id = ?" (userId, contactId) - -deleteContact :: DB.Connection -> User -> Contact -> IO () -deleteContact db user@User {userId} Contact {contactId, localDisplayName, activeConn = Connection {customUserProfileId}} = do - DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND contact_id = ?" (userId, contactId) - ctMember :: (Maybe ContactId) <- maybeFirstRow fromOnly $ DB.query db "SELECT contact_id FROM group_members WHERE user_id = ? AND contact_id = ? LIMIT 1" (userId, contactId) - if isNothing ctMember - then do - deleteContactProfile_ db userId contactId - DB.execute db "DELETE FROM display_names WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName) - else do - currentTs <- getCurrentTime - DB.execute db "UPDATE group_members SET contact_id = NULL, updated_at = ? WHERE user_id = ? AND contact_id = ?" (currentTs, userId, contactId) - DB.execute db "DELETE FROM contacts WHERE user_id = ? AND contact_id = ?" (userId, contactId) - forM_ customUserProfileId $ \profileId -> deleteUnusedIncognitoProfileById_ db user profileId - --- should only be used if contact is not member of any groups -deleteContactWithoutGroups :: DB.Connection -> User -> Contact -> IO () -deleteContactWithoutGroups db user@User {userId} Contact {contactId, localDisplayName, activeConn = Connection {customUserProfileId}} = do - DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND contact_id = ?" (userId, contactId) - deleteContactProfile_ db userId contactId - DB.execute db "DELETE FROM display_names WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName) - DB.execute db "DELETE FROM contacts WHERE user_id = ? AND contact_id = ?" (userId, contactId) - forM_ customUserProfileId $ \profileId -> deleteUnusedIncognitoProfileById_ db user profileId - -setContactDeleted :: DB.Connection -> User -> Contact -> IO () -setContactDeleted db User {userId} Contact {contactId} = do - currentTs <- getCurrentTime - DB.execute db "UPDATE contacts SET deleted = 1, updated_at = ? WHERE user_id = ? AND contact_id = ?" (currentTs, userId, contactId) - -getDeletedContacts :: DB.Connection -> User -> IO [Contact] -getDeletedContacts db user@User {userId} = do - contactIds <- map fromOnly <$> DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND deleted = 1" (Only userId) - rights <$> mapM (runExceptT . getDeletedContact db user) contactIds - -getDeletedContact :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO Contact -getDeletedContact db user contactId = getContact_ db user contactId True - -deleteUnusedIncognitoProfileById_ :: DB.Connection -> User -> ProfileId -> IO () -deleteUnusedIncognitoProfileById_ db User {userId} profile_id = - DB.executeNamed - db - [sql| - DELETE FROM contact_profiles - WHERE user_id = :user_id AND contact_profile_id = :profile_id AND incognito = 1 - AND 1 NOT IN ( - SELECT 1 FROM connections - WHERE user_id = :user_id AND custom_user_profile_id = :profile_id LIMIT 1 - ) - AND 1 NOT IN ( - SELECT 1 FROM group_members - WHERE user_id = :user_id AND member_profile_id = :profile_id LIMIT 1 - ) - |] - [":user_id" := userId, ":profile_id" := profile_id] - -deleteContactProfile_ :: DB.Connection -> UserId -> ContactId -> IO () -deleteContactProfile_ db userId contactId = - DB.execute - db - [sql| - DELETE FROM contact_profiles - WHERE contact_profile_id in ( - SELECT contact_profile_id - FROM contacts - WHERE user_id = ? AND contact_id = ? - ) - |] - (userId, contactId) - -updateUserProfile :: DB.Connection -> User -> Profile -> ExceptT StoreError IO User -updateUserProfile db user p' - | displayName == newName = do - liftIO $ updateContactProfile_ db userId profileId p' - pure user {profile, fullPreferences} - | otherwise = - checkConstraint SEDuplicateName . liftIO $ do - currentTs <- getCurrentTime - DB.execute db "UPDATE users SET local_display_name = ?, updated_at = ? WHERE user_id = ?" (newName, currentTs, userId) - DB.execute - db - "INSERT INTO display_names (local_display_name, ldn_base, user_id, created_at, updated_at) VALUES (?,?,?,?,?)" - (newName, newName, userId, currentTs, currentTs) - updateContactProfile_' db userId profileId p' currentTs - updateContact_ db userId userContactId localDisplayName newName currentTs - pure user {localDisplayName = newName, profile, fullPreferences} - where - User {userId, userContactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}} = user - Profile {displayName = newName, preferences} = p' - profile = toLocalProfile profileId p' localAlias - fullPreferences = mergePreferences Nothing preferences - -setUserProfileContactLink :: DB.Connection -> User -> Maybe UserContactLink -> IO User -setUserProfileContactLink db user@User {userId, profile = p@LocalProfile {profileId}} ucl_ = do - ts <- getCurrentTime - DB.execute - db - [sql| - UPDATE contact_profiles - SET contact_link = ?, updated_at = ? - WHERE user_id = ? AND contact_profile_id = ? - |] - (connReqContact_, ts, userId, profileId) - pure (user :: User) {profile = p {contactLink = connReqContact_}} - where - connReqContact_ = case ucl_ of - Just UserContactLink {connReqContact} -> Just connReqContact - _ -> Nothing - -updateContactProfile :: DB.Connection -> User -> Contact -> Profile -> ExceptT StoreError IO Contact -updateContactProfile db user@User {userId} c p' - | displayName == newName = do - liftIO $ updateContactProfile_ db userId profileId p' - pure c {profile, mergedPreferences} - | otherwise = - ExceptT . withLocalDisplayName db userId newName $ \ldn -> do - currentTs <- getCurrentTime - updateContactProfile_' db userId profileId p' currentTs - updateContact_ db userId contactId localDisplayName ldn currentTs - pure $ Right c {localDisplayName = ldn, profile, mergedPreferences} - where - Contact {contactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}, activeConn, userPreferences} = c - Profile {displayName = newName, preferences} = p' - profile = toLocalProfile profileId p' localAlias - mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn - -updateContactUserPreferences :: DB.Connection -> User -> Contact -> Preferences -> IO Contact -updateContactUserPreferences db user@User {userId} c@Contact {contactId, activeConn} userPreferences = do - updatedAt <- getCurrentTime - DB.execute - db - "UPDATE contacts SET user_preferences = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?" - (userPreferences, updatedAt, userId, contactId) - let mergedPreferences = contactUserPreferences user userPreferences (preferences' c) $ connIncognito activeConn - pure $ c {mergedPreferences, userPreferences} - -updateContactAlias :: DB.Connection -> UserId -> Contact -> LocalAlias -> IO Contact -updateContactAlias db userId c@Contact {profile = lp@LocalProfile {profileId}} localAlias = do - updatedAt <- getCurrentTime - DB.execute - db - [sql| - UPDATE contact_profiles - SET local_alias = ?, updated_at = ? - WHERE user_id = ? AND contact_profile_id = ? - |] - (localAlias, updatedAt, userId, profileId) - pure $ (c :: Contact) {profile = lp {localAlias}} - -updateContactConnectionAlias :: DB.Connection -> UserId -> PendingContactConnection -> LocalAlias -> IO PendingContactConnection -updateContactConnectionAlias db userId conn localAlias = do - updatedAt <- getCurrentTime - DB.execute - db - [sql| - UPDATE connections - SET local_alias = ?, updated_at = ? - WHERE user_id = ? AND connection_id = ? - |] - (localAlias, updatedAt, userId, pccConnId conn) - pure (conn :: PendingContactConnection) {localAlias} - -updateContactUsed :: DB.Connection -> User -> Contact -> IO () -updateContactUsed db User {userId} Contact {contactId} = do - updatedAt <- getCurrentTime - DB.execute db "UPDATE contacts SET contact_used = 1, updated_at = ? WHERE user_id = ? AND contact_id = ?" (updatedAt, userId, contactId) - -updateContactUnreadChat :: DB.Connection -> User -> Contact -> Bool -> IO () -updateContactUnreadChat db User {userId} Contact {contactId} unreadChat = do - updatedAt <- getCurrentTime - DB.execute db "UPDATE contacts SET unread_chat = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?" (unreadChat, updatedAt, userId, contactId) - -updateGroupUnreadChat :: DB.Connection -> User -> GroupInfo -> Bool -> IO () -updateGroupUnreadChat db User {userId} GroupInfo {groupId} unreadChat = do - updatedAt <- getCurrentTime - DB.execute db "UPDATE groups SET unread_chat = ?, updated_at = ? WHERE user_id = ? AND group_id = ?" (unreadChat, updatedAt, userId, groupId) - -setConnectionVerified :: DB.Connection -> User -> Int64 -> Maybe Text -> IO () -setConnectionVerified db User {userId} connId code = do - updatedAt <- getCurrentTime - DB.execute db "UPDATE connections SET security_code = ?, security_code_verified_at = ?, updated_at = ? WHERE user_id = ? AND connection_id = ?" (code, code $> updatedAt, updatedAt, userId, connId) - -incConnectionAuthErrCounter :: DB.Connection -> User -> Connection -> IO Int -incConnectionAuthErrCounter db User {userId} Connection {connId, authErrCounter} = do - updatedAt <- getCurrentTime - (counter_ :: Maybe Int) <- maybeFirstRow fromOnly $ DB.query db "SELECT auth_err_counter FROM connections WHERE user_id = ? AND connection_id = ?" (userId, connId) - let counter' = fromMaybe authErrCounter counter_ + 1 - DB.execute db "UPDATE connections SET auth_err_counter = ?, updated_at = ? WHERE user_id = ? AND connection_id = ?" (counter', updatedAt, userId, connId) - pure counter' - -setConnectionAuthErrCounter :: DB.Connection -> User -> Connection -> Int -> IO () -setConnectionAuthErrCounter db User {userId} Connection {connId} counter = do - updatedAt <- getCurrentTime - DB.execute db "UPDATE connections SET auth_err_counter = ?, updated_at = ? WHERE user_id = ? AND connection_id = ?" (counter, updatedAt, userId, connId) - -updateContactProfile_ :: DB.Connection -> UserId -> ProfileId -> Profile -> IO () -updateContactProfile_ db userId profileId profile = do - currentTs <- getCurrentTime - updateContactProfile_' db userId profileId profile currentTs - -updateContactProfile_' :: DB.Connection -> UserId -> ProfileId -> Profile -> UTCTime -> IO () -updateContactProfile_' db userId profileId Profile {displayName, fullName, image, contactLink, preferences} updatedAt = do - DB.execute - db - [sql| - UPDATE contact_profiles - SET display_name = ?, full_name = ?, image = ?, contact_link = ?, preferences = ?, updated_at = ? - WHERE user_id = ? AND contact_profile_id = ? - |] - (displayName, fullName, image, contactLink, preferences, updatedAt, userId, profileId) - -updateContact_ :: DB.Connection -> UserId -> Int64 -> ContactName -> ContactName -> UTCTime -> IO () -updateContact_ db userId contactId displayName newName updatedAt = do - DB.execute - db - "UPDATE contacts SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?" - (newName, updatedAt, userId, contactId) - DB.execute - db - "UPDATE group_members SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?" - (newName, updatedAt, userId, contactId) - DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (displayName, userId) - -type ContactRow = (ContactId, ProfileId, ContactName, Maybe Int64, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Bool, Maybe Bool) :. (Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime) - -toContact :: User -> ContactRow :. ConnectionRow -> Contact -toContact user (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, enableNtfs_) :. (preferences, userPreferences, createdAt, updatedAt, chatTs)) :. connRow) = - let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} - activeConn = toConnection connRow - chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_} - mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn - in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs} - -toContactOrError :: User -> ContactRow :. MaybeConnectionRow -> Either StoreError Contact -toContactOrError user (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, enableNtfs_) :. (preferences, userPreferences, createdAt, updatedAt, chatTs)) :. connRow) = - let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} - chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_} - in case toMaybeConnection connRow of - Just activeConn -> - let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn - in Right Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs} - _ -> Left $ SEContactNotReady localDisplayName - -getContactByName :: DB.Connection -> User -> ContactName -> ExceptT StoreError IO Contact -getContactByName db user localDisplayName = do - cId <- getContactIdByName db user localDisplayName - getContact db user cId - -getUserContacts :: DB.Connection -> User -> IO [Contact] -getUserContacts db user@User {userId} = do - contactIds <- map fromOnly <$> DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND deleted = 0" (Only userId) - rights <$> mapM (runExceptT . getContact db user) contactIds - --- only used in tests -getUserContactProfiles :: DB.Connection -> User -> IO [Profile] -getUserContactProfiles db User {userId} = - map toContactProfile - <$> DB.query - db - [sql| - SELECT display_name, full_name, image, contact_link, preferences - FROM contact_profiles - WHERE user_id = ? - |] - (Only userId) - where - toContactProfile :: (ContactName, Text, Maybe ImageData, Maybe ConnReqContact, Maybe Preferences) -> (Profile) - toContactProfile (displayName, fullName, image, contactLink, preferences) = Profile {displayName, fullName, image, contactLink, preferences} - -createUserContactLink :: DB.Connection -> User -> ConnId -> ConnReqContact -> ExceptT StoreError IO () -createUserContactLink db User {userId} agentConnId cReq = - checkConstraint SEDuplicateContactLink . liftIO $ do - currentTs <- getCurrentTime - DB.execute - db - "INSERT INTO user_contact_links (user_id, conn_req_contact, created_at, updated_at) VALUES (?,?,?,?)" - (userId, cReq, currentTs, currentTs) - userContactLinkId <- insertedRowId db - void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId Nothing Nothing Nothing 0 currentTs - -getUserAddressConnections :: DB.Connection -> User -> ExceptT StoreError IO [Connection] -getUserAddressConnections db User {userId} = do - cs <- liftIO getUserAddressConnections_ - if null cs then throwError SEUserContactLinkNotFound else pure cs - where - getUserAddressConnections_ :: IO [Connection] - getUserAddressConnections_ = - map toConnection - <$> DB.query - db - [sql| - SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, - c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter - FROM connections c - JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id - WHERE c.user_id = ? AND uc.user_id = ? AND uc.local_display_name = '' AND uc.group_id IS NULL - |] - (userId, userId) - -getUserContactLinks :: DB.Connection -> User -> IO [(Connection, UserContact)] -getUserContactLinks db User {userId} = - map toUserContactConnection - <$> DB.query - db - [sql| - SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, - c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter, - uc.user_contact_link_id, uc.conn_req_contact, uc.group_id - FROM connections c - JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id - WHERE c.user_id = ? AND uc.user_id = ? - |] - (userId, userId) - where - toUserContactConnection :: (ConnectionRow :. (Int64, ConnReqContact, Maybe GroupId)) -> (Connection, UserContact) - toUserContactConnection (connRow :. (userContactLinkId, connReqContact, groupId)) = (toConnection connRow, UserContact {userContactLinkId, connReqContact, groupId}) - -deleteUserAddress :: DB.Connection -> User -> IO () -deleteUserAddress db user@User {userId} = do - DB.execute - db - [sql| - DELETE FROM connections WHERE connection_id IN ( - SELECT connection_id - FROM connections c - JOIN user_contact_links uc USING (user_contact_link_id) - WHERE uc.user_id = ? AND uc.local_display_name = '' AND uc.group_id IS NULL - ) - |] - (Only userId) - DB.executeNamed - db - [sql| - DELETE FROM display_names - WHERE user_id = :user_id - AND local_display_name in ( - SELECT cr.local_display_name - FROM contact_requests cr - JOIN user_contact_links uc USING (user_contact_link_id) - WHERE uc.user_id = :user_id AND uc.local_display_name = '' AND uc.group_id IS NULL - ) - |] - [":user_id" := userId] - DB.executeNamed - db - [sql| - DELETE FROM contact_profiles - WHERE contact_profile_id in ( - SELECT cr.contact_profile_id - FROM contact_requests cr - JOIN user_contact_links uc USING (user_contact_link_id) - WHERE uc.user_id = :user_id AND uc.local_display_name = '' AND uc.group_id IS NULL - ) - |] - [":user_id" := userId] - void $ setUserProfileContactLink db user Nothing - DB.execute db "DELETE FROM user_contact_links WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL" (Only userId) - -data UserContactLink = UserContactLink - { connReqContact :: ConnReqContact, - autoAccept :: Maybe AutoAccept - } - deriving (Show, Generic) - -instance ToJSON UserContactLink where toEncoding = J.genericToEncoding J.defaultOptions - -data AutoAccept = AutoAccept - { acceptIncognito :: Bool, - autoReply :: Maybe MsgContent - } - deriving (Show, Generic) - -instance ToJSON AutoAccept where toEncoding = J.genericToEncoding J.defaultOptions - -toUserContactLink :: (ConnReqContact, Bool, Bool, Maybe MsgContent) -> UserContactLink -toUserContactLink (connReq, autoAccept, acceptIncognito, autoReply) = - UserContactLink connReq $ - if autoAccept then Just AutoAccept {acceptIncognito, autoReply} else Nothing - -getUserAddress :: DB.Connection -> User -> ExceptT StoreError IO UserContactLink -getUserAddress db User {userId} = - ExceptT . firstRow toUserContactLink SEUserContactLinkNotFound $ - DB.query - db - [sql| - SELECT conn_req_contact, auto_accept, auto_accept_incognito, auto_reply_msg_content - FROM user_contact_links - WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL - |] - (Only userId) - -getUserContactLinkById :: DB.Connection -> UserId -> Int64 -> IO (Maybe (UserContactLink, Maybe GroupId, GroupMemberRole)) -getUserContactLinkById db userId userContactLinkId = - maybeFirstRow (\(ucl :. (groupId_, mRole_)) -> (toUserContactLink ucl, groupId_, fromMaybe GRMember mRole_)) $ - DB.query - db - [sql| - SELECT conn_req_contact, auto_accept, auto_accept_incognito, auto_reply_msg_content, group_id, group_link_member_role - FROM user_contact_links - WHERE user_id = ? - AND user_contact_link_id = ? - |] - (userId, userContactLinkId) - -updateUserAddressAutoAccept :: DB.Connection -> User -> Maybe AutoAccept -> ExceptT StoreError IO UserContactLink -updateUserAddressAutoAccept db user@User {userId} autoAccept = do - link <- getUserAddress db user - liftIO updateUserAddressAutoAccept_ $> link {autoAccept} - where - updateUserAddressAutoAccept_ = - DB.execute - db - [sql| - UPDATE user_contact_links - SET auto_accept = ?, auto_accept_incognito = ?, auto_reply_msg_content = ? - WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL - |] - (ucl :. Only userId) - ucl = case autoAccept of - Just AutoAccept {acceptIncognito, autoReply} -> (True, acceptIncognito, autoReply) - _ -> (False, False, Nothing) - -createGroupLink :: DB.Connection -> User -> GroupInfo -> ConnId -> ConnReqContact -> GroupLinkId -> GroupMemberRole -> ExceptT StoreError IO () -createGroupLink db User {userId} groupInfo@GroupInfo {groupId, localDisplayName} agentConnId cReq groupLinkId memberRole = - checkConstraint (SEDuplicateGroupLink groupInfo) . liftIO $ do - currentTs <- getCurrentTime - DB.execute - db - "INSERT INTO user_contact_links (user_id, group_id, group_link_id, local_display_name, conn_req_contact, group_link_member_role, auto_accept, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)" - (userId, groupId, groupLinkId, "group_link_" <> localDisplayName, cReq, memberRole, True, currentTs, currentTs) - userContactLinkId <- insertedRowId db - void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId Nothing Nothing Nothing 0 currentTs - -getGroupLinkConnection :: DB.Connection -> User -> GroupInfo -> ExceptT StoreError IO Connection -getGroupLinkConnection db User {userId} groupInfo@GroupInfo {groupId} = - ExceptT . firstRow toConnection (SEGroupLinkNotFound groupInfo) $ - DB.query - db - [sql| - SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, - c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter - FROM connections c - JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id - WHERE c.user_id = ? AND uc.user_id = ? AND uc.group_id = ? - |] - (userId, userId, groupId) - -deleteGroupLink :: DB.Connection -> User -> GroupInfo -> IO () -deleteGroupLink db User {userId} GroupInfo {groupId} = do - DB.execute - db - [sql| - DELETE FROM connections WHERE connection_id IN ( - SELECT connection_id - FROM connections c - JOIN user_contact_links uc USING (user_contact_link_id) - WHERE uc.user_id = ? AND uc.group_id = ? - ) - |] - (userId, groupId) - DB.execute - db - [sql| - DELETE FROM display_names - WHERE user_id = ? - AND local_display_name in ( - SELECT cr.local_display_name - FROM contact_requests cr - JOIN user_contact_links uc USING (user_contact_link_id) - WHERE uc.user_id = ? AND uc.group_id = ? - ) - |] - (userId, userId, groupId) - DB.execute - db - [sql| - DELETE FROM contact_profiles - WHERE contact_profile_id in ( - SELECT cr.contact_profile_id - FROM contact_requests cr - JOIN user_contact_links uc USING (user_contact_link_id) - WHERE uc.user_id = ? AND uc.group_id = ? - ) - |] - (userId, groupId) - DB.execute db "DELETE FROM user_contact_links WHERE user_id = ? AND group_id = ?" (userId, groupId) - -getGroupLink :: DB.Connection -> User -> GroupInfo -> ExceptT StoreError IO (Int64, ConnReqContact, GroupMemberRole) -getGroupLink db User {userId} gInfo@GroupInfo {groupId} = - ExceptT . firstRow groupLink (SEGroupLinkNotFound gInfo) $ - DB.query db "SELECT user_contact_link_id, conn_req_contact, group_link_member_role FROM user_contact_links WHERE user_id = ? AND group_id = ? LIMIT 1" (userId, groupId) - where - groupLink (linkId, cReq, mRole_) = (linkId, cReq, fromMaybe GRMember mRole_) - -getGroupLinkId :: DB.Connection -> User -> GroupInfo -> IO (Maybe GroupLinkId) -getGroupLinkId db User {userId} GroupInfo {groupId} = - fmap join . maybeFirstRow fromOnly $ - DB.query db "SELECT group_link_id FROM user_contact_links WHERE user_id = ? AND group_id = ? LIMIT 1" (userId, groupId) - -setGroupLinkMemberRole :: DB.Connection -> User -> Int64 -> GroupMemberRole -> IO () -setGroupLinkMemberRole db User {userId} userContactLinkId memberRole = - DB.execute db "UPDATE user_contact_links SET group_link_member_role = ? WHERE user_id = ? AND user_contact_link_id = ?" (memberRole, userId, userContactLinkId) - -createOrUpdateContactRequest :: DB.Connection -> User -> Int64 -> InvitationId -> Profile -> Maybe XContactId -> ExceptT StoreError IO ContactOrRequest -createOrUpdateContactRequest db user@User {userId} userContactLinkId invId Profile {displayName, fullName, image, contactLink, preferences} xContactId_ = - liftIO (maybeM getContact' xContactId_) >>= \case - Just contact -> pure $ CORContact contact - Nothing -> CORRequest <$> createOrUpdate_ - where - maybeM = maybe (pure Nothing) - createOrUpdate_ :: ExceptT StoreError IO UserContactRequest - createOrUpdate_ = do - cReqId <- - ExceptT $ - maybeM getContactRequestByXContactId xContactId_ >>= \case - Nothing -> createContactRequest - Just cr -> updateContactRequest cr $> Right (contactRequestId (cr :: UserContactRequest)) - getContactRequest db user cReqId - createContactRequest :: IO (Either StoreError Int64) - createContactRequest = do - currentTs <- getCurrentTime - withLocalDisplayName db userId displayName (fmap Right . createContactRequest_ currentTs) - where - createContactRequest_ currentTs ldn = do - DB.execute - db - "INSERT INTO contact_profiles (display_name, full_name, image, contact_link, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" - (displayName, fullName, image, contactLink, userId, preferences, currentTs, currentTs) - profileId <- insertedRowId db - DB.execute - db - [sql| - INSERT INTO contact_requests - (user_contact_link_id, agent_invitation_id, contact_profile_id, local_display_name, user_id, created_at, updated_at, xcontact_id) - VALUES (?,?,?,?,?,?,?,?) - |] - (userContactLinkId, invId, profileId, ldn, userId, currentTs, currentTs, xContactId_) - insertedRowId db - getContact' :: XContactId -> IO (Maybe Contact) - getContact' xContactId = - maybeFirstRow (toContact user) $ - DB.query - db - [sql| - SELECT - -- Contact - ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, - cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, - -- Connection - c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias, - c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter - FROM contacts ct - JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id - LEFT JOIN connections c ON c.contact_id = ct.contact_id - WHERE ct.user_id = ? AND ct.xcontact_id = ? AND ct.deleted = 0 - ORDER BY c.connection_id DESC - LIMIT 1 - |] - (userId, xContactId) - getContactRequestByXContactId :: XContactId -> IO (Maybe UserContactRequest) - getContactRequestByXContactId xContactId = - maybeFirstRow toContactRequest $ - DB.query - db - [sql| - SELECT - cr.contact_request_id, cr.local_display_name, cr.agent_invitation_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, p.preferences, cr.created_at, cr.updated_at - FROM contact_requests cr - JOIN connections c USING (user_contact_link_id) - JOIN contact_profiles p USING (contact_profile_id) - WHERE cr.user_id = ? - AND cr.xcontact_id = ? - LIMIT 1 - |] - (userId, xContactId) - updateContactRequest :: UserContactRequest -> IO (Either StoreError ()) - updateContactRequest UserContactRequest {contactRequestId = cReqId, localDisplayName = oldLdn, profile = Profile {displayName = oldDisplayName}} = do - currentTs <- liftIO getCurrentTime - updateProfile currentTs - if displayName == oldDisplayName - then Right <$> DB.execute db "UPDATE contact_requests SET agent_invitation_id = ?, updated_at = ? WHERE user_id = ? AND contact_request_id = ?" (invId, currentTs, userId, cReqId) - else withLocalDisplayName db userId displayName $ \ldn -> - Right <$> do - DB.execute db "UPDATE contact_requests SET agent_invitation_id = ?, local_display_name = ?, updated_at = ? WHERE user_id = ? AND contact_request_id = ?" (invId, ldn, currentTs, userId, cReqId) - DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (oldLdn, userId) - where - updateProfile currentTs = - DB.execute - db - [sql| - UPDATE contact_profiles - SET display_name = ?, - full_name = ?, - image = ?, - contact_link = ?, - updated_at = ? - WHERE contact_profile_id IN ( - SELECT contact_profile_id - FROM contact_requests - WHERE user_id = ? - AND contact_request_id = ? - ) - |] - (displayName, fullName, image, contactLink, currentTs, userId, cReqId) - -getContactRequest' :: DB.Connection -> Int64 -> ExceptT StoreError IO (User, UserContactRequest) -getContactRequest' db contactRequestId = do - user <- getUserByContactRequestId db contactRequestId - (user,) <$> getContactRequest db user contactRequestId - -getContactRequest :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO UserContactRequest -getContactRequest db User {userId} contactRequestId = - ExceptT . firstRow toContactRequest (SEContactRequestNotFound contactRequestId) $ - DB.query - db - [sql| - SELECT - cr.contact_request_id, cr.local_display_name, cr.agent_invitation_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, p.preferences, cr.created_at, cr.updated_at - FROM contact_requests cr - JOIN connections c USING (user_contact_link_id) - JOIN contact_profiles p USING (contact_profile_id) - WHERE cr.user_id = ? - AND cr.contact_request_id = ? - |] - (userId, contactRequestId) - -type ContactRequestRow = (Int64, ContactName, AgentInvId, Int64, AgentConnId, Int64, ContactName, Text, Maybe ImageData, Maybe ConnReqContact) :. (Maybe XContactId, Maybe Preferences, UTCTime, UTCTime) - -toContactRequest :: ContactRequestRow -> UserContactRequest -toContactRequest ((contactRequestId, localDisplayName, agentInvitationId, userContactLinkId, agentContactConnId, profileId, displayName, fullName, image, contactLink) :. (xContactId, preferences, createdAt, updatedAt)) = do - let profile = Profile {displayName, fullName, image, contactLink, preferences} - in UserContactRequest {contactRequestId, agentInvitationId, userContactLinkId, agentContactConnId, localDisplayName, profileId, profile, xContactId, createdAt, updatedAt} - -getContactRequestIdByName :: DB.Connection -> UserId -> ContactName -> ExceptT StoreError IO Int64 -getContactRequestIdByName db userId cName = - ExceptT . firstRow fromOnly (SEContactRequestNotFoundByName cName) $ - DB.query db "SELECT contact_request_id FROM contact_requests WHERE user_id = ? AND local_display_name = ?" (userId, cName) - -deleteContactRequest :: DB.Connection -> User -> Int64 -> IO () -deleteContactRequest db User {userId} contactRequestId = do - DB.execute - db - [sql| - DELETE FROM contact_profiles - WHERE contact_profile_id in ( - SELECT contact_profile_id - FROM contact_requests - WHERE user_id = ? AND contact_request_id = ? - ) - |] - (userId, contactRequestId) - DB.execute - db - [sql| - DELETE FROM display_names - WHERE user_id = ? AND local_display_name = ( - SELECT local_display_name FROM contact_requests - WHERE user_id = ? AND contact_request_id = ? - ) - |] - (userId, userId, contactRequestId) - DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND contact_request_id = ?" (userId, contactRequestId) - -createAcceptedContact :: DB.Connection -> User -> ConnId -> ContactName -> ProfileId -> Profile -> Int64 -> Maybe XContactId -> Maybe IncognitoProfile -> IO Contact -createAcceptedContact db user@User {userId, profile = LocalProfile {preferences}} agentConnId localDisplayName profileId profile userContactLinkId xContactId incognitoProfile = do - DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName) - createdAt <- getCurrentTime - customUserProfileId <- forM incognitoProfile $ \case - NewIncognito p -> createIncognitoProfile_ db userId createdAt p - ExistingIncognito LocalProfile {profileId = pId} -> pure pId - let userPreferences = fromMaybe emptyChatPrefs $ incognitoProfile >> preferences - DB.execute - db - "INSERT INTO contacts (user_id, local_display_name, contact_profile_id, enable_ntfs, user_preferences, created_at, updated_at, chat_ts, xcontact_id) VALUES (?,?,?,?,?,?,?,?,?)" - (userId, localDisplayName, profileId, True, userPreferences, createdAt, createdAt, createdAt, xContactId) - contactId <- insertedRowId db - activeConn <- createConnection_ db userId ConnContact (Just contactId) agentConnId Nothing (Just userContactLinkId) customUserProfileId 0 createdAt - let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn - pure $ Contact {contactId, localDisplayName, profile = toLocalProfile profileId profile "", activeConn, viaGroup = Nothing, contactUsed = False, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = createdAt, updatedAt = createdAt, chatTs = Just createdAt} - -getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer] -getLiveSndFileTransfers db User {userId} = do - cutoffTs <- addUTCTime (- week) <$> getCurrentTime - fileIds :: [Int64] <- - map fromOnly - <$> DB.query - db - [sql| - SELECT DISTINCT f.file_id - FROM files f - JOIN snd_files s USING (file_id) - WHERE f.user_id = ? - AND s.file_status IN (?, ?, ?) - AND s.file_descr_id IS NULL - AND s.file_inline IS NULL - AND s.created_at > ? - |] - (userId, FSNew, FSAccepted, FSConnected, cutoffTs) - concatMap (filter liveTransfer) . rights <$> mapM (getSndFileTransfers_ db userId) fileIds - where - liveTransfer :: SndFileTransfer -> Bool - liveTransfer SndFileTransfer {fileStatus} = fileStatus `elem` [FSNew, FSAccepted, FSConnected] - -getLiveRcvFileTransfers :: DB.Connection -> User -> IO [RcvFileTransfer] -getLiveRcvFileTransfers db user@User {userId} = do - cutoffTs <- addUTCTime (- week) <$> getCurrentTime - fileIds :: [Int64] <- - map fromOnly - <$> DB.query - db - [sql| - SELECT f.file_id - FROM files f - JOIN rcv_files r USING (file_id) - WHERE f.user_id = ? AND r.file_status IN (?, ?) - AND r.rcv_file_inline IS NULL - AND r.file_descr_id IS NULL - AND r.created_at > ? - |] - (userId, FSAccepted, FSConnected, cutoffTs) - rights <$> mapM (runExceptT . getRcvFileTransfer db user) fileIds - -getPendingSndChunks :: DB.Connection -> Int64 -> Int64 -> IO [Integer] -getPendingSndChunks db fileId connId = - map fromOnly - <$> DB.query - db - [sql| - SELECT chunk_number - FROM snd_file_chunks - WHERE file_id = ? AND connection_id = ? AND chunk_agent_msg_id IS NULL - ORDER BY chunk_number - |] - (fileId, connId) - -getPendingContactConnections :: DB.Connection -> User -> IO [PendingContactConnection] -getPendingContactConnections db User {userId} = do - map toPendingContactConnection - <$> DB.queryNamed - db - [sql| - SELECT connection_id, agent_conn_id, conn_status, via_contact_uri_hash, via_user_contact_link, group_link_id, custom_user_profile_id, conn_req_inv, local_alias, created_at, updated_at - FROM connections - WHERE user_id = :user_id - AND conn_type = :conn_type - AND contact_id IS NULL - |] - [":user_id" := userId, ":conn_type" := ConnContact] - -getContactConnections :: DB.Connection -> UserId -> Contact -> ExceptT StoreError IO [Connection] -getContactConnections db userId Contact {contactId} = - connections =<< liftIO getConnections_ - where - getConnections_ = - DB.query - db - [sql| - SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, - c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter - FROM connections c - JOIN contacts ct ON ct.contact_id = c.contact_id - WHERE c.user_id = ? AND ct.user_id = ? AND ct.contact_id = ? - |] - (userId, userId, contactId) - connections [] = throwError $ SEContactNotFound contactId - connections rows = pure $ map toConnection rows - -type EntityIdsRow = (Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64) - -type ConnectionRow = (Int64, ConnId, Int, Maybe Int64, Maybe Int64, Bool, Maybe GroupLinkId, Maybe Int64, ConnStatus, ConnType, LocalAlias) :. EntityIdsRow :. (UTCTime, Maybe Text, Maybe UTCTime, Int) - -type MaybeConnectionRow = (Maybe Int64, Maybe ConnId, Maybe Int, Maybe Int64, Maybe Int64, Maybe Bool, Maybe GroupLinkId, Maybe Int64, Maybe ConnStatus, Maybe ConnType, Maybe LocalAlias) :. EntityIdsRow :. (Maybe UTCTime, Maybe Text, Maybe UTCTime, Maybe Int) - -toConnection :: ConnectionRow -> Connection -toConnection ((connId, acId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (createdAt, code_, verifiedAt_, authErrCounter)) = - let entityId = entityId_ connType - connectionCode = SecurityCode <$> code_ <*> verifiedAt_ - in Connection {connId, agentConnId = AgentConnId acId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, localAlias, entityId, connectionCode, authErrCounter, createdAt} - where - entityId_ :: ConnType -> Maybe Int64 - entityId_ ConnContact = contactId - entityId_ ConnMember = groupMemberId - entityId_ ConnRcvFile = rcvFileId - entityId_ ConnSndFile = sndFileId - entityId_ ConnUserContact = userContactLinkId - -toMaybeConnection :: MaybeConnectionRow -> Maybe Connection -toMaybeConnection ((Just connId, Just agentConnId, Just connLevel, viaContact, viaUserContactLink, Just viaGroupLink, groupLinkId, customUserProfileId, Just connStatus, Just connType, Just localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (Just createdAt, code_, verifiedAt_, Just authErrCounter)) = - Just $ toConnection ((connId, agentConnId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (createdAt, code_, verifiedAt_, authErrCounter)) -toMaybeConnection _ = Nothing - -getMatchingContacts :: DB.Connection -> User -> Contact -> IO [Contact] -getMatchingContacts db user@User {userId} Contact {contactId, profile = LocalProfile {displayName, fullName, image}} = do - contactIds <- - map fromOnly - <$> DB.query - db - [sql| - SELECT ct.contact_id - FROM contacts ct - JOIN contact_profiles p ON ct.contact_profile_id = p.contact_profile_id - WHERE ct.user_id = ? AND ct.contact_id != ? - AND ct.deleted = 0 - AND p.display_name = ? AND p.full_name = ? - AND ((p.image IS NULL AND ? IS NULL) OR p.image = ?) - |] - (userId, contactId, displayName, fullName, image, image) - rights <$> mapM (runExceptT . getContact db user) contactIds - -createSentProbe :: DB.Connection -> TVar ChaChaDRG -> UserId -> Contact -> ExceptT StoreError IO (Probe, Int64) -createSentProbe db gVar userId _to@Contact {contactId} = - createWithRandomBytes 32 gVar $ \probe -> do - currentTs <- getCurrentTime - DB.execute - db - "INSERT INTO sent_probes (contact_id, probe, user_id, created_at, updated_at) VALUES (?,?,?,?,?)" - (contactId, probe, userId, currentTs, currentTs) - (Probe probe,) <$> insertedRowId db - -createSentProbeHash :: DB.Connection -> UserId -> Int64 -> Contact -> IO () -createSentProbeHash db userId probeId _to@Contact {contactId} = do - currentTs <- getCurrentTime - DB.execute - db - "INSERT INTO sent_probe_hashes (sent_probe_id, contact_id, user_id, created_at, updated_at) VALUES (?,?,?,?,?)" - (probeId, contactId, userId, currentTs, currentTs) - -deleteSentProbe :: DB.Connection -> UserId -> Int64 -> IO () -deleteSentProbe db userId probeId = - DB.execute - db - "DELETE FROM sent_probes WHERE user_id = ? AND sent_probe_id = ?" - (userId, probeId) - -matchReceivedProbe :: DB.Connection -> User -> Contact -> Probe -> IO (Maybe Contact) -matchReceivedProbe db user@User {userId} _from@Contact {contactId} (Probe probe) = do - let probeHash = C.sha256Hash probe - contactIds <- - map fromOnly - <$> DB.query - db - [sql| - SELECT c.contact_id - FROM contacts c - JOIN received_probes r ON r.contact_id = c.contact_id - WHERE c.user_id = ? AND c.deleted = 0 AND r.probe_hash = ? AND r.probe IS NULL - |] - (userId, probeHash) - currentTs <- getCurrentTime - DB.execute - db - "INSERT INTO received_probes (contact_id, probe, probe_hash, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" - (contactId, probe, probeHash, userId, currentTs, currentTs) - case contactIds of - [] -> pure Nothing - cId : _ -> eitherToMaybe <$> runExceptT (getContact db user cId) - -matchReceivedProbeHash :: DB.Connection -> User -> Contact -> ProbeHash -> IO (Maybe (Contact, Probe)) -matchReceivedProbeHash db user@User {userId} _from@Contact {contactId} (ProbeHash probeHash) = do - namesAndProbes <- - DB.query - db - [sql| - SELECT c.contact_id, r.probe - FROM contacts c - JOIN received_probes r ON r.contact_id = c.contact_id - WHERE c.user_id = ? AND c.deleted = 0 AND r.probe_hash = ? AND r.probe IS NOT NULL - |] - (userId, probeHash) - currentTs <- getCurrentTime - DB.execute - db - "INSERT INTO received_probes (contact_id, probe_hash, user_id, created_at, updated_at) VALUES (?,?,?,?,?)" - (contactId, probeHash, userId, currentTs, currentTs) - case namesAndProbes of - [] -> pure Nothing - (cId, probe) : _ -> - either (const Nothing) (Just . (,Probe probe)) - <$> runExceptT (getContact db user cId) - -matchSentProbe :: DB.Connection -> User -> Contact -> Probe -> IO (Maybe Contact) -matchSentProbe db user@User {userId} _from@Contact {contactId} (Probe probe) = do - contactIds <- - map fromOnly - <$> DB.query - db - [sql| - SELECT c.contact_id - FROM contacts c - JOIN sent_probes s ON s.contact_id = c.contact_id - JOIN sent_probe_hashes h ON h.sent_probe_id = s.sent_probe_id - WHERE c.user_id = ? AND c.deleted = 0 AND s.probe = ? AND h.contact_id = ? - |] - (userId, probe, contactId) - case contactIds of - [] -> pure Nothing - cId : _ -> eitherToMaybe <$> runExceptT (getContact db user cId) - -mergeContactRecords :: DB.Connection -> UserId -> Contact -> Contact -> IO () -mergeContactRecords db userId ct1 ct2 = do - let (toCt, fromCt) = toFromContacts ct1 ct2 - Contact {contactId = toContactId} = toCt - Contact {contactId = fromContactId, localDisplayName} = fromCt - currentTs <- getCurrentTime - -- TODO next query fixes incorrect unused contacts deletion; consider more thorough fix - when (contactDirect toCt && not (contactUsed toCt)) $ - DB.execute - db - "UPDATE contacts SET contact_used = 1, updated_at = ? WHERE user_id = ? AND contact_id = ?" - (currentTs, userId, toContactId) - DB.execute - db - "UPDATE connections SET contact_id = ?, updated_at = ? WHERE contact_id = ? AND user_id = ?" - (toContactId, currentTs, fromContactId, userId) - DB.execute - db - "UPDATE connections SET via_contact = ?, updated_at = ? WHERE via_contact = ? AND user_id = ?" - (toContactId, currentTs, fromContactId, userId) - DB.execute - db - "UPDATE group_members SET invited_by = ?, updated_at = ? WHERE invited_by = ? AND user_id = ?" - (toContactId, currentTs, fromContactId, userId) - DB.execute - db - "UPDATE chat_items SET contact_id = ?, updated_at = ? WHERE contact_id = ? AND user_id = ?" - (toContactId, currentTs, fromContactId, userId) - DB.executeNamed - db - [sql| - UPDATE group_members - SET contact_id = :to_contact_id, - local_display_name = (SELECT local_display_name FROM contacts WHERE contact_id = :to_contact_id), - contact_profile_id = (SELECT contact_profile_id FROM contacts WHERE contact_id = :to_contact_id), - updated_at = :updated_at - WHERE contact_id = :from_contact_id - AND user_id = :user_id - |] - [ ":to_contact_id" := toContactId, - ":from_contact_id" := fromContactId, - ":user_id" := userId, - ":updated_at" := currentTs - ] - deleteContactProfile_ db userId fromContactId - DB.execute db "DELETE FROM contacts WHERE contact_id = ? AND user_id = ?" (fromContactId, userId) - DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (localDisplayName, userId) - where - toFromContacts :: Contact -> Contact -> (Contact, Contact) - toFromContacts c1 c2 - | d1 && not d2 = (c1, c2) - | d2 && not d1 = (c2, c1) - | ctCreatedAt c1 <= ctCreatedAt c2 = (c1, c2) - | otherwise = (c2, c1) - where - d1 = directOrUsed c1 - d2 = directOrUsed c2 - ctCreatedAt Contact {createdAt} = createdAt - -getConnectionEntity :: DB.Connection -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity -getConnectionEntity db user@User {userId, userContactId} agentConnId = do - c@Connection {connType, entityId} <- getConnection_ - case entityId of - Nothing -> - if connType == ConnContact - then pure $ RcvDirectMsgConnection c Nothing - else throwError $ SEInternalError $ "connection " <> show connType <> " without entity" - Just entId -> - case connType of - ConnMember -> uncurry (RcvGroupMsgConnection c) <$> getGroupAndMember_ entId c - ConnContact -> RcvDirectMsgConnection c . Just <$> getContactRec_ entId c - ConnSndFile -> SndFileConnection c <$> getConnSndFileTransfer_ entId c - ConnRcvFile -> RcvFileConnection c <$> getRcvFileTransfer db user entId - ConnUserContact -> UserContactConnection c <$> getUserContact_ entId - where - getConnection_ :: ExceptT StoreError IO Connection - getConnection_ = ExceptT $ do - firstRow toConnection (SEConnectionNotFound agentConnId) $ - DB.query - db - [sql| - SELECT connection_id, agent_conn_id, conn_level, via_contact, via_user_contact_link, via_group_link, group_link_id, custom_user_profile_id, - conn_status, conn_type, local_alias, contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at, security_code, security_code_verified_at, auth_err_counter - FROM connections - WHERE user_id = ? AND agent_conn_id = ? - |] - (userId, agentConnId) - getContactRec_ :: Int64 -> Connection -> ExceptT StoreError IO Contact - getContactRec_ contactId c = ExceptT $ do - toContact' contactId c - <$> DB.query - db - [sql| - SELECT - c.contact_profile_id, c.local_display_name, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, c.via_group, c.contact_used, c.enable_ntfs, - p.preferences, c.user_preferences, c.created_at, c.updated_at, c.chat_ts - FROM contacts c - JOIN contact_profiles p ON c.contact_profile_id = p.contact_profile_id - WHERE c.user_id = ? AND c.contact_id = ? AND c.deleted = 0 - |] - (userId, contactId) - toContact' :: Int64 -> Connection -> [(ProfileId, ContactName, Text, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Int64, Bool, Maybe Bool) :. (Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime)] -> Either StoreError Contact - toContact' contactId activeConn [(profileId, localDisplayName, displayName, fullName, image, contactLink, localAlias, viaGroup, contactUsed, enableNtfs_) :. (preferences, userPreferences, createdAt, updatedAt, chatTs)] = - let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} - chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_} - mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn - in Right Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs} - toContact' _ _ _ = Left $ SEInternalError "referenced contact not found" - getGroupAndMember_ :: Int64 -> Connection -> ExceptT StoreError IO (GroupInfo, GroupMember) - getGroupAndMember_ groupMemberId c = ExceptT $ do - firstRow (toGroupAndMember c) (SEInternalError "referenced group member not found") $ - DB.query - db - [sql| - SELECT - -- GroupInfo - g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, - -- GroupInfo {membership} - mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, - mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, - -- GroupInfo {membership = GroupMember {memberProfile}} - pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences, - -- from GroupMember - m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, - m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences - FROM group_members m - JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) - JOIN groups g ON g.group_id = m.group_id - JOIN group_profiles gp USING (group_profile_id) - JOIN group_members mu ON g.group_id = mu.group_id - JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) - WHERE m.group_member_id = ? AND g.user_id = ? AND mu.contact_id = ? - |] - (groupMemberId, userId, userContactId) - toGroupAndMember :: Connection -> GroupInfoRow :. GroupMemberRow -> (GroupInfo, GroupMember) - toGroupAndMember c (groupInfoRow :. memberRow) = - let groupInfo = toGroupInfo userContactId groupInfoRow - member = toGroupMember userContactId memberRow - in (groupInfo, (member :: GroupMember) {activeConn = Just c}) - getConnSndFileTransfer_ :: Int64 -> Connection -> ExceptT StoreError IO SndFileTransfer - getConnSndFileTransfer_ fileId Connection {connId} = - ExceptT $ - firstRow' (sndFileTransfer_ fileId connId) (SESndFileNotFound fileId) $ - DB.query - db - [sql| - SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.file_descr_id, s.file_inline, s.group_member_id, cs.local_display_name, m.local_display_name - FROM snd_files s - JOIN files f USING (file_id) - LEFT JOIN contacts cs USING (contact_id) - LEFT JOIN group_members m USING (group_member_id) - WHERE f.user_id = ? AND f.file_id = ? AND s.connection_id = ? - |] - (userId, fileId, connId) - sndFileTransfer_ :: Int64 -> Int64 -> (FileStatus, String, Integer, Integer, FilePath, Maybe Int64, Maybe InlineFileMode, Maybe Int64, Maybe ContactName, Maybe ContactName) -> Either StoreError SndFileTransfer - sndFileTransfer_ fileId connId (fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, groupMemberId, contactName_, memberName_) = - case contactName_ <|> memberName_ of - Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, recipientDisplayName, connId, agentConnId, groupMemberId} - Nothing -> Left $ SESndFileInvalid fileId - getUserContact_ :: Int64 -> ExceptT StoreError IO UserContact - getUserContact_ userContactLinkId = ExceptT $ do - userContact_ - <$> DB.query - db - [sql| - SELECT conn_req_contact, group_id - FROM user_contact_links - WHERE user_id = ? AND user_contact_link_id = ? - |] - (userId, userContactLinkId) - where - userContact_ :: [(ConnReqContact, Maybe GroupId)] -> Either StoreError UserContact - userContact_ [(cReq, groupId)] = Right UserContact {userContactLinkId, connReqContact = cReq, groupId} - userContact_ _ = Left SEUserContactLinkNotFound - -getConnectionById :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO Connection -getConnectionById db User {userId} connId = ExceptT $ do - firstRow toConnection (SEConnectionNotFoundById connId) $ - DB.query - db - [sql| - SELECT connection_id, agent_conn_id, conn_level, via_contact, via_user_contact_link, via_group_link, group_link_id, custom_user_profile_id, - conn_status, conn_type, local_alias, contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at, security_code, security_code_verified_at, auth_err_counter - FROM connections - WHERE user_id = ? AND connection_id = ? - |] - (userId, connId) - -getConnectionsContacts :: DB.Connection -> [ConnId] -> IO [ContactRef] -getConnectionsContacts db agentConnIds = do - DB.execute_ db "DROP TABLE IF EXISTS temp.conn_ids" - DB.execute_ db "CREATE TABLE temp.conn_ids (conn_id BLOB)" - DB.executeMany db "INSERT INTO temp.conn_ids (conn_id) VALUES (?)" $ map Only agentConnIds - conns <- - map toContactRef - <$> DB.query - db - [sql| - SELECT ct.contact_id, c.connection_id, c.agent_conn_id, ct.local_display_name - FROM contacts ct - JOIN connections c ON c.contact_id = ct.contact_id - WHERE c.agent_conn_id IN (SELECT conn_id FROM temp.conn_ids) - AND c.conn_type = ? - AND ct.deleted = 0 - |] - (Only ConnContact) - DB.execute_ db "DROP TABLE temp.conn_ids" - pure conns - where - toContactRef :: (ContactId, Int64, ConnId, ContactName) -> ContactRef - toContactRef (contactId, connId, acId, localDisplayName) = ContactRef {contactId, connId, agentConnId = AgentConnId acId, localDisplayName} - -getGroupAndMember :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO (GroupInfo, GroupMember) -getGroupAndMember db User {userId, userContactId} groupMemberId = - ExceptT . firstRow toGroupAndMember (SEInternalError "referenced group member not found") $ - DB.query - db - [sql| - SELECT - -- GroupInfo - g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, - -- GroupInfo {membership} - mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, - mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, - -- GroupInfo {membership = GroupMember {memberProfile}} - pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences, - -- from GroupMember - m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, - m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, - c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, - c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter - FROM group_members m - JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) - JOIN groups g ON g.group_id = m.group_id - JOIN group_profiles gp USING (group_profile_id) - JOIN group_members mu ON g.group_id = mu.group_id - JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) - LEFT JOIN connections c ON c.connection_id = ( - SELECT max(cc.connection_id) - FROM connections cc - where cc.group_member_id = m.group_member_id - ) - WHERE m.group_member_id = ? AND g.user_id = ? AND mu.contact_id = ? - |] - (groupMemberId, userId, userContactId) - where - toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember) - toGroupAndMember (groupInfoRow :. memberRow :. connRow) = - let groupInfo = toGroupInfo userContactId groupInfoRow - member = toGroupMember userContactId memberRow - in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow}) - -updateConnectionStatus :: DB.Connection -> Connection -> ConnStatus -> IO () -updateConnectionStatus db Connection {connId} connStatus = do - currentTs <- getCurrentTime - DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ? WHERE connection_id = ?" (connStatus, currentTs, connId) - --- | creates completely new group with a single member - the current user -createNewGroup :: DB.Connection -> TVar ChaChaDRG -> User -> GroupProfile -> ExceptT StoreError IO GroupInfo -createNewGroup db gVar user@User {userId} groupProfile = ExceptT $ do - let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile - fullGroupPreferences = mergeGroupPreferences groupPreferences - currentTs <- getCurrentTime - withLocalDisplayName db userId displayName $ \ldn -> runExceptT $ do - groupId <- liftIO $ do - DB.execute - db - "INSERT INTO group_profiles (display_name, full_name, description, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" - (displayName, fullName, description, image, userId, groupPreferences, currentTs, currentTs) - profileId <- insertedRowId db - DB.execute - db - "INSERT INTO groups (local_display_name, user_id, group_profile_id, enable_ntfs, created_at, updated_at, chat_ts) VALUES (?,?,?,?,?,?,?)" - (ldn, userId, profileId, True, currentTs, currentTs, currentTs) - insertedRowId db - memberId <- liftIO $ encodedRandomBytes gVar 12 - membership <- createContactMemberInv_ db user groupId user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser Nothing currentTs - let chatSettings = ChatSettings {enableNtfs = True} - pure GroupInfo {groupId, localDisplayName = ldn, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId = Nothing, chatSettings, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs} - --- | creates a new group record for the group the current user was invited to, or returns an existing one -createGroupInvitation :: DB.Connection -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> ExceptT StoreError IO (GroupInfo, GroupMemberId) -createGroupInvitation db user@User {userId} contact@Contact {contactId, activeConn = Connection {customUserProfileId}} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile} incognitoProfileId = do - liftIO getInvitationGroupId_ >>= \case - Nothing -> createGroupInvitation_ - Just gId -> do - gInfo@GroupInfo {membership, groupProfile = p'} <- getGroupInfo db user gId - hostId <- getHostMemberId_ db user gId - let GroupMember {groupMemberId, memberId, memberRole} = membership - MemberIdRole {memberId = memberId', memberRole = memberRole'} = invitedMember - liftIO . when (memberId /= memberId' || memberRole /= memberRole') $ - DB.execute db "UPDATE group_members SET member_id = ?, member_role = ? WHERE group_member_id = ?" (memberId', memberRole', groupMemberId) - gInfo' <- - if p' == groupProfile - then pure gInfo - else updateGroupProfile db user gInfo groupProfile - pure (gInfo', hostId) - where - getInvitationGroupId_ :: IO (Maybe Int64) - getInvitationGroupId_ = - maybeFirstRow fromOnly $ - DB.query db "SELECT group_id FROM groups WHERE inv_queue_info = ? AND user_id = ? LIMIT 1" (connRequest, userId) - createGroupInvitation_ :: ExceptT StoreError IO (GroupInfo, GroupMemberId) - createGroupInvitation_ = do - let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile - fullGroupPreferences = mergeGroupPreferences groupPreferences - ExceptT $ - withLocalDisplayName db userId displayName $ \localDisplayName -> runExceptT $ do - currentTs <- liftIO getCurrentTime - groupId <- liftIO $ do - DB.execute - db - "INSERT INTO group_profiles (display_name, full_name, description, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" - (displayName, fullName, description, image, userId, groupPreferences, currentTs, currentTs) - profileId <- insertedRowId db - DB.execute - db - "INSERT INTO groups (group_profile_id, local_display_name, inv_queue_info, host_conn_custom_user_profile_id, user_id, enable_ntfs, created_at, updated_at, chat_ts) VALUES (?,?,?,?,?,?,?,?,?)" - (profileId, localDisplayName, connRequest, customUserProfileId, userId, True, currentTs, currentTs, currentTs) - insertedRowId db - GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId contact fromMember GCHostMember GSMemInvited IBUnknown Nothing currentTs - membership <- createContactMemberInv_ db user groupId user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfileId currentTs - let chatSettings = ChatSettings {enableNtfs = True} - pure (GroupInfo {groupId, localDisplayName, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId = customUserProfileId, chatSettings, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs}, groupMemberId) - -getHostMemberId_ :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO GroupMemberId -getHostMemberId_ db User {userId} groupId = - ExceptT . firstRow fromOnly (SEHostMemberIdNotFound groupId) $ - DB.query db "SELECT group_member_id FROM group_members WHERE user_id = ? AND group_id = ? AND member_category = ?" (userId, groupId, GCHostMember) - -createContactMemberInv_ :: IsContact a => DB.Connection -> User -> GroupId -> a -> MemberIdRole -> GroupMemberCategory -> GroupMemberStatus -> InvitedBy -> Maybe ProfileId -> UTCTime -> ExceptT StoreError IO GroupMember -createContactMemberInv_ db User {userId, userContactId} groupId userOrContact MemberIdRole {memberId, memberRole} memberCategory memberStatus invitedBy incognitoProfileId createdAt = do - incognitoProfile <- forM incognitoProfileId $ \profileId -> getProfileById db userId profileId - (localDisplayName, memberProfile) <- case (incognitoProfile, incognitoProfileId) of - (Just profile@LocalProfile {displayName}, Just profileId) -> - (,profile) <$> insertMemberIncognitoProfile_ displayName profileId - _ -> (,profile' userOrContact) <$> liftIO insertMember_ - groupMemberId <- liftIO $ insertedRowId db - pure - GroupMember - { groupMemberId, - groupId, - memberId, - memberRole, - memberCategory, - memberStatus, - invitedBy, - localDisplayName, - memberProfile, - memberContactId = Just $ contactId' userOrContact, - memberContactProfileId = localProfileId (profile' userOrContact), - activeConn = Nothing - } - where - insertMember_ :: IO ContactName - insertMember_ = do - let localDisplayName = localDisplayName' userOrContact - DB.execute - db - [sql| - INSERT INTO group_members - ( group_id, member_id, member_role, member_category, member_status, invited_by, - user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at) - VALUES (?,?,?,?,?,?,?,?,?,?,?,?) - |] - ( (groupId, memberId, memberRole, memberCategory, memberStatus, fromInvitedBy userContactId invitedBy) - :. (userId, localDisplayName' userOrContact, contactId' userOrContact, localProfileId $ profile' userOrContact, createdAt, createdAt) - ) - pure localDisplayName - insertMemberIncognitoProfile_ :: ContactName -> ProfileId -> ExceptT StoreError IO ContactName - insertMemberIncognitoProfile_ incognitoDisplayName customUserProfileId = ExceptT $ - withLocalDisplayName db userId incognitoDisplayName $ \incognitoLdn -> do - DB.execute - db - [sql| - INSERT INTO group_members - ( group_id, member_id, member_role, member_category, member_status, invited_by, - user_id, local_display_name, contact_id, contact_profile_id, member_profile_id, created_at, updated_at) - VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?) - |] - ( (groupId, memberId, memberRole, memberCategory, memberStatus, fromInvitedBy userContactId invitedBy) - :. (userId, incognitoLdn, contactId' userOrContact, localProfileId $ profile' userOrContact, customUserProfileId, createdAt, createdAt) - ) - pure $ Right incognitoLdn - -setGroupInvitationChatItemId :: DB.Connection -> User -> GroupId -> ChatItemId -> IO () -setGroupInvitationChatItemId db User {userId} groupId chatItemId = do - currentTs <- getCurrentTime - DB.execute db "UPDATE groups SET chat_item_id = ?, updated_at = ? WHERE user_id = ? AND group_id = ?" (chatItemId, currentTs, userId, groupId) - --- TODO return the last connection that is ready, not any last connection --- requires updating connection status -getGroup :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO Group -getGroup db user groupId = do - gInfo <- getGroupInfo db user groupId - members <- liftIO $ getGroupMembers db user gInfo - pure $ Group gInfo members - -deleteGroupConnectionsAndFiles :: DB.Connection -> User -> GroupInfo -> [GroupMember] -> IO () -deleteGroupConnectionsAndFiles db User {userId} GroupInfo {groupId} members = do - forM_ members $ \m -> DB.execute db "DELETE FROM connections WHERE user_id = ? AND group_member_id = ?" (userId, groupMemberId' m) - DB.execute db "DELETE FROM files WHERE user_id = ? AND group_id = ?" (userId, groupId) - -deleteGroupItemsAndMembers :: DB.Connection -> User -> GroupInfo -> [GroupMember] -> IO () -deleteGroupItemsAndMembers db user@User {userId} GroupInfo {groupId} members = do - DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND group_id = ?" (userId, groupId) - void $ runExceptT cleanupHostGroupLinkConn_ -- to allow repeat connection via the same group link if one was used - DB.execute db "DELETE FROM group_members WHERE user_id = ? AND group_id = ?" (userId, groupId) - forM_ members $ \m@GroupMember {memberProfile = LocalProfile {profileId}} -> do - cleanupMemberProfileAndName_ db user m - when (memberIncognito m) $ deleteUnusedIncognitoProfileById_ db user profileId - where - cleanupHostGroupLinkConn_ = do - hostId <- getHostMemberId_ db user groupId - liftIO $ - DB.execute - db - [sql| - UPDATE connections SET via_contact_uri_hash = NULL, xcontact_id = NULL - WHERE user_id = ? AND via_group_link = 1 AND contact_id IN ( - SELECT contact_id - FROM group_members - WHERE user_id = ? AND group_member_id = ? - ) - |] - (userId, userId, hostId) - -deleteGroup :: DB.Connection -> User -> GroupInfo -> IO () -deleteGroup db user@User {userId} GroupInfo {groupId, localDisplayName, membership = membership@GroupMember {memberProfile = LocalProfile {profileId}}} = do - deleteGroupProfile_ db userId groupId - DB.execute db "DELETE FROM groups WHERE user_id = ? AND group_id = ?" (userId, groupId) - DB.execute db "DELETE FROM display_names WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName) - when (memberIncognito membership) $ deleteUnusedIncognitoProfileById_ db user profileId - -deleteGroupProfile_ :: DB.Connection -> UserId -> GroupId -> IO () -deleteGroupProfile_ db userId groupId = - DB.execute - db - [sql| - DELETE FROM group_profiles - WHERE group_profile_id in ( - SELECT group_profile_id - FROM groups - WHERE user_id = ? AND group_id = ? - ) - |] - (userId, groupId) - -getUserGroups :: DB.Connection -> User -> IO [Group] -getUserGroups db user@User {userId} = do - groupIds <- map fromOnly <$> DB.query db "SELECT group_id FROM groups WHERE user_id = ?" (Only userId) - rights <$> mapM (runExceptT . getGroup db user) groupIds - -getUserGroupDetails :: DB.Connection -> User -> IO [GroupInfo] -getUserGroupDetails db User {userId, userContactId} = - map (toGroupInfo userContactId) - <$> DB.query - db - [sql| - SELECT g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, - mu.group_member_id, g.group_id, mu.member_id, mu.member_role, mu.member_category, mu.member_status, - mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences - FROM groups g - JOIN group_profiles gp USING (group_profile_id) - JOIN group_members mu USING (group_id) - JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) - WHERE g.user_id = ? AND mu.contact_id = ? - |] - (userId, userContactId) - -getContactGroupPreferences :: DB.Connection -> User -> Contact -> IO [FullGroupPreferences] -getContactGroupPreferences db User {userId} Contact {contactId} = do - map (mergeGroupPreferences . fromOnly) - <$> DB.query - db - [sql| - SELECT gp.preferences - FROM groups g - JOIN group_profiles gp USING (group_profile_id) - JOIN group_members m USING (group_id) - WHERE g.user_id = ? AND m.contact_id = ? - |] - (userId, contactId) - -checkContactHasGroups :: DB.Connection -> User -> Contact -> IO (Maybe GroupId) -checkContactHasGroups db User {userId} Contact {contactId} = - maybeFirstRow fromOnly $ DB.query db "SELECT group_id FROM group_members WHERE user_id = ? AND contact_id = ? LIMIT 1" (userId, contactId) - -getGroupInfoByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupInfo -getGroupInfoByName db user gName = do - gId <- getGroupIdByName db user gName - getGroupInfo db user gId - -type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe Text, Maybe ImageData, Maybe ProfileId, Maybe Bool, Maybe GroupPreferences, UTCTime, UTCTime, Maybe UTCTime) :. GroupMemberRow - -toGroupInfo :: Int64 -> GroupInfoRow -> GroupInfo -toGroupInfo userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, groupPreferences, createdAt, updatedAt, chatTs) :. userMemberRow) = - let membership = toGroupMember userContactId userMemberRow - chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_} - fullGroupPreferences = mergeGroupPreferences groupPreferences - groupProfile = GroupProfile {displayName, fullName, description, image, groupPreferences} - in GroupInfo {groupId, localDisplayName, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId, chatSettings, createdAt, updatedAt, chatTs} - -groupMemberQuery :: Query -groupMemberQuery = - [sql| - SELECT - m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, - m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, - c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, - c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter - FROM group_members m - JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) - LEFT JOIN connections c ON c.connection_id = ( - SELECT max(cc.connection_id) - FROM connections cc - where cc.group_member_id = m.group_member_id - ) - |] - -getGroupMember :: DB.Connection -> User -> GroupId -> GroupMemberId -> ExceptT StoreError IO GroupMember -getGroupMember db user@User {userId} groupId groupMemberId = - ExceptT . firstRow (toContactMember user) (SEGroupMemberNotFound groupMemberId) $ - DB.query - db - (groupMemberQuery <> " WHERE m.group_id = ? AND m.group_member_id = ? AND m.user_id = ?") - (groupId, groupMemberId, userId) - -getGroupMemberById :: DB.Connection -> User -> GroupMemberId -> ExceptT StoreError IO GroupMember -getGroupMemberById db user@User {userId} groupMemberId = - ExceptT . firstRow (toContactMember user) (SEGroupMemberNotFound groupMemberId) $ - DB.query - db - (groupMemberQuery <> " WHERE m.group_member_id = ? AND m.user_id = ?") - (groupMemberId, userId) - -getGroupMembers :: DB.Connection -> User -> GroupInfo -> IO [GroupMember] -getGroupMembers db user@User {userId, userContactId} GroupInfo {groupId} = do - map (toContactMember user) - <$> DB.query - db - (groupMemberQuery <> " WHERE m.group_id = ? AND m.user_id = ? AND (m.contact_id IS NULL OR m.contact_id != ?)") - (groupId, userId, userContactId) - -getGroupMembersForExpiration :: DB.Connection -> User -> GroupInfo -> IO [GroupMember] -getGroupMembersForExpiration db user@User {userId, userContactId} GroupInfo {groupId} = do - map (toContactMember user) - <$> DB.query - db - ( groupMemberQuery - <> [sql| - WHERE m.group_id = ? AND m.user_id = ? AND (m.contact_id IS NULL OR m.contact_id != ?) - AND m.member_status IN (?, ?, ?) - AND m.group_member_id NOT IN ( - SELECT DISTINCT group_member_id FROM chat_items - ) - |] - ) - (groupId, userId, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted) - -toContactMember :: User -> (GroupMemberRow :. MaybeConnectionRow) -> GroupMember -toContactMember User {userContactId} (memberRow :. connRow) = - (toGroupMember userContactId memberRow) {activeConn = toMaybeConnection connRow} - -getGroupInvitation :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO ReceivedGroupInvitation -getGroupInvitation db user groupId = - getConnRec_ user >>= \case - Just connRequest -> do - groupInfo@GroupInfo {membership} <- getGroupInfo db user groupId - when (memberStatus membership /= GSMemInvited) $ throwError SEGroupAlreadyJoined - hostId <- getHostMemberId_ db user groupId - fromMember <- getGroupMember db user groupId hostId - pure ReceivedGroupInvitation {fromMember, connRequest, groupInfo} - _ -> throwError SEGroupInvitationNotFound - where - getConnRec_ :: User -> ExceptT StoreError IO (Maybe ConnReqInvitation) - getConnRec_ User {userId} = ExceptT $ do - firstRow fromOnly (SEGroupNotFound groupId) $ - DB.query db "SELECT g.inv_queue_info FROM groups g WHERE g.group_id = ? AND g.user_id = ?" (groupId, userId) - -type GroupMemberRow = ((Int64, Int64, MemberId, GroupMemberRole, GroupMemberCategory, GroupMemberStatus) :. (Maybe Int64, ContactName, Maybe ContactId, ProfileId, ProfileId, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Preferences)) - -type MaybeGroupMemberRow = ((Maybe Int64, Maybe Int64, Maybe MemberId, Maybe GroupMemberRole, Maybe GroupMemberCategory, Maybe GroupMemberStatus) :. (Maybe Int64, Maybe ContactName, Maybe ContactId, Maybe ProfileId, Maybe ProfileId, Maybe ContactName, Maybe Text, Maybe ImageData, Maybe ConnReqContact, Maybe LocalAlias, Maybe Preferences)) - -toGroupMember :: Int64 -> GroupMemberRow -> GroupMember -toGroupMember userContactId ((groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus) :. (invitedById, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, preferences)) = - let memberProfile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} - invitedBy = toInvitedBy userContactId invitedById - activeConn = Nothing - in GroupMember {..} - -toMaybeGroupMember :: Int64 -> MaybeGroupMemberRow -> Maybe GroupMember -toMaybeGroupMember userContactId ((Just groupMemberId, Just groupId, Just memberId, Just memberRole, Just memberCategory, Just memberStatus) :. (invitedById, Just localDisplayName, memberContactId, Just memberContactProfileId, Just profileId, Just displayName, Just fullName, image, contactLink, Just localAlias, contactPreferences)) = - Just $ toGroupMember userContactId ((groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus) :. (invitedById, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, contactPreferences)) -toMaybeGroupMember _ _ = Nothing - -createNewContactMember :: DB.Connection -> TVar ChaChaDRG -> User -> GroupId -> Contact -> GroupMemberRole -> ConnId -> ConnReqInvitation -> ExceptT StoreError IO GroupMember -createNewContactMember db gVar User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile} memberRole agentConnId connRequest = - createWithRandomId gVar $ \memId -> do - createdAt <- liftIO getCurrentTime - member@GroupMember {groupMemberId} <- createMember_ (MemberId memId) createdAt - void $ createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 createdAt - pure member - where - createMember_ memberId createdAt = do - insertMember_ - groupMemberId <- liftIO $ insertedRowId db - pure - GroupMember - { groupMemberId, - groupId, - memberId, - memberRole, - memberCategory = GCInviteeMember, - memberStatus = GSMemInvited, - invitedBy = IBUser, - localDisplayName, - memberProfile = profile, - memberContactId = Just contactId, - memberContactProfileId = localProfileId profile, - activeConn = Nothing - } - where - insertMember_ = - DB.execute - db - [sql| - INSERT INTO group_members - ( group_id, member_id, member_role, member_category, member_status, invited_by, - user_id, local_display_name, contact_id, contact_profile_id, sent_inv_queue_info, created_at, updated_at) - VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?) - |] - ( (groupId, memberId, memberRole, GCInviteeMember, GSMemInvited, fromInvitedBy userContactId IBUser) - :. (userId, localDisplayName, contactId, localProfileId profile, connRequest, createdAt, createdAt) - ) - -createNewContactMemberAsync :: DB.Connection -> TVar ChaChaDRG -> User -> GroupId -> Contact -> GroupMemberRole -> (CommandId, ConnId) -> ExceptT StoreError IO () -createNewContactMemberAsync db gVar user@User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile} memberRole (cmdId, agentConnId) = - createWithRandomId gVar $ \memId -> do - createdAt <- liftIO getCurrentTime - insertMember_ (MemberId memId) createdAt - groupMemberId <- liftIO $ insertedRowId db - Connection {connId} <- createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 createdAt - setCommandConnId db user cmdId connId - where - insertMember_ memberId createdAt = - DB.execute - db - [sql| - INSERT INTO group_members - ( group_id, member_id, member_role, member_category, member_status, invited_by, - user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at) - VALUES (?,?,?,?,?,?,?,?,?,?,?,?) - |] - ( (groupId, memberId, memberRole, GCInviteeMember, GSMemInvited, fromInvitedBy userContactId IBUser) - :. (userId, localDisplayName, contactId, localProfileId profile, createdAt, createdAt) - ) - -getContactViaMember :: DB.Connection -> User -> GroupMember -> IO (Maybe Contact) -getContactViaMember db user@User {userId} GroupMember {groupMemberId} = - maybeFirstRow (toContact user) $ - DB.query - db - [sql| - SELECT - -- Contact - ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, - cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, - -- Connection - c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias, - c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter - FROM contacts ct - JOIN contact_profiles cp ON cp.contact_profile_id = ct.contact_profile_id - JOIN connections c ON c.connection_id = ( - SELECT max(cc.connection_id) - FROM connections cc - where cc.contact_id = ct.contact_id - ) - JOIN group_members m ON m.contact_id = ct.contact_id - WHERE ct.user_id = ? AND m.group_member_id = ? AND ct.deleted = 0 - |] - (userId, groupMemberId) - -setNewContactMemberConnRequest :: DB.Connection -> User -> GroupMember -> ConnReqInvitation -> IO () -setNewContactMemberConnRequest db User {userId} GroupMember {groupMemberId} connRequest = do - currentTs <- getCurrentTime - DB.execute db "UPDATE group_members SET sent_inv_queue_info = ?, updated_at = ? WHERE user_id = ? AND group_member_id = ?" (connRequest, currentTs, userId, groupMemberId) - -getMemberInvitation :: DB.Connection -> User -> Int64 -> IO (Maybe ConnReqInvitation) -getMemberInvitation db User {userId} groupMemberId = - fmap join . maybeFirstRow fromOnly $ - DB.query db "SELECT sent_inv_queue_info FROM group_members WHERE group_member_id = ? AND user_id = ?" (groupMemberId, userId) - -createMemberConnection :: DB.Connection -> UserId -> GroupMember -> ConnId -> IO () -createMemberConnection db userId GroupMember {groupMemberId} agentConnId = do - currentTs <- getCurrentTime - void $ createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 currentTs - -createMemberConnectionAsync :: DB.Connection -> User -> GroupMemberId -> (CommandId, ConnId) -> IO () -createMemberConnectionAsync db user@User {userId} groupMemberId (cmdId, agentConnId) = do - currentTs <- getCurrentTime - Connection {connId} <- createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 currentTs - setCommandConnId db user cmdId connId - -updateGroupMemberStatus :: DB.Connection -> UserId -> GroupMember -> GroupMemberStatus -> IO () -updateGroupMemberStatus db userId GroupMember {groupMemberId} = updateGroupMemberStatusById db userId groupMemberId - -updateGroupMemberStatusById :: DB.Connection -> UserId -> GroupMemberId -> GroupMemberStatus -> IO () -updateGroupMemberStatusById db userId groupMemberId memStatus = do - currentTs <- getCurrentTime - DB.execute - db - [sql| - UPDATE group_members - SET member_status = ?, updated_at = ? - WHERE user_id = ? AND group_member_id = ? - |] - (memStatus, currentTs, userId, groupMemberId) - --- | add new member with profile -createNewGroupMember :: DB.Connection -> User -> GroupInfo -> MemberInfo -> GroupMemberCategory -> GroupMemberStatus -> ExceptT StoreError IO GroupMember -createNewGroupMember db user@User {userId} gInfo memInfo@(MemberInfo _ _ Profile {displayName, fullName, image, contactLink, preferences}) memCategory memStatus = - ExceptT . withLocalDisplayName db userId displayName $ \localDisplayName -> do - currentTs <- getCurrentTime - DB.execute - db - "INSERT INTO contact_profiles (display_name, full_name, image, contact_link, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" - (displayName, fullName, image, contactLink, userId, preferences, currentTs, currentTs) - memProfileId <- insertedRowId db - let newMember = - NewGroupMember - { memInfo, - memCategory, - memStatus, - memInvitedBy = IBUnknown, - localDisplayName, - memContactId = Nothing, - memProfileId - } - Right <$> createNewMember_ db user gInfo newMember currentTs - -createNewMember_ :: DB.Connection -> User -> GroupInfo -> NewGroupMember -> UTCTime -> IO GroupMember -createNewMember_ - db - User {userId, userContactId} - GroupInfo {groupId} - NewGroupMember - { memInfo = MemberInfo memberId memberRole memberProfile, - memCategory = memberCategory, - memStatus = memberStatus, - memInvitedBy = invitedBy, - localDisplayName, - memContactId = memberContactId, - memProfileId = memberContactProfileId - } - createdAt = do - let invitedById = fromInvitedBy userContactId invitedBy - activeConn = Nothing - DB.execute - db - [sql| - INSERT INTO group_members - (group_id, member_id, member_role, member_category, member_status, - invited_by, user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at) - VALUES (?,?,?,?,?,?,?,?,?,?,?,?) - |] - (groupId, memberId, memberRole, memberCategory, memberStatus, invitedById, userId, localDisplayName, memberContactId, memberContactProfileId, createdAt, createdAt) - groupMemberId <- insertedRowId db - pure GroupMember {groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus, invitedBy, localDisplayName, memberProfile = toLocalProfile memberContactProfileId memberProfile "", memberContactId, memberContactProfileId, activeConn} - -checkGroupMemberHasItems :: DB.Connection -> User -> GroupMember -> IO (Maybe ChatItemId) -checkGroupMemberHasItems db User {userId} GroupMember {groupMemberId, groupId} = - maybeFirstRow fromOnly $ DB.query db "SELECT chat_item_id FROM chat_items WHERE user_id = ? AND group_id = ? AND group_member_id = ? LIMIT 1" (userId, groupId, groupMemberId) - -deleteGroupMember :: DB.Connection -> User -> GroupMember -> IO () -deleteGroupMember db user@User {userId} m@GroupMember {groupMemberId, groupId, memberProfile = LocalProfile {profileId}} = do - deleteGroupMemberConnection db user m - DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND group_id = ? AND group_member_id = ?" (userId, groupId, groupMemberId) - DB.execute db "DELETE FROM group_members WHERE user_id = ? AND group_member_id = ?" (userId, groupMemberId) - cleanupMemberProfileAndName_ db user m - when (memberIncognito m) $ deleteUnusedIncognitoProfileById_ db user profileId - -cleanupMemberProfileAndName_ :: DB.Connection -> User -> GroupMember -> IO () -cleanupMemberProfileAndName_ db User {userId} GroupMember {groupMemberId, memberContactId, memberContactProfileId, localDisplayName} = - -- check record has no memberContactId (contact_id) - it means contact has been deleted and doesn't use profile & ldn - when (isNothing memberContactId) $ do - -- check other group member records don't use profile & ldn - sameProfileMember :: (Maybe GroupMemberId) <- maybeFirstRow fromOnly $ DB.query db "SELECT group_member_id FROM group_members WHERE user_id = ? AND contact_profile_id = ? AND group_member_id != ? LIMIT 1" (userId, memberContactProfileId, groupMemberId) - when (isNothing sameProfileMember) $ do - DB.execute db "DELETE FROM contact_profiles WHERE user_id = ? AND contact_profile_id = ?" (userId, memberContactProfileId) - DB.execute db "DELETE FROM display_names WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName) - -deleteGroupMemberConnection :: DB.Connection -> User -> GroupMember -> IO () -deleteGroupMemberConnection db User {userId} GroupMember {groupMemberId} = - DB.execute db "DELETE FROM connections WHERE user_id = ? AND group_member_id = ?" (userId, groupMemberId) - -updateGroupMemberRole :: DB.Connection -> User -> GroupMember -> GroupMemberRole -> IO () -updateGroupMemberRole db User {userId} GroupMember {groupMemberId} memRole = - DB.execute db "UPDATE group_members SET member_role = ? WHERE user_id = ? AND group_member_id = ?" (memRole, userId, groupMemberId) - -createIntroductions :: DB.Connection -> [GroupMember] -> GroupMember -> IO [GroupMemberIntro] -createIntroductions db members toMember = do - let reMembers = filter (\m -> memberCurrent m && groupMemberId' m /= groupMemberId' toMember) members - if null reMembers - then pure [] - else do - currentTs <- getCurrentTime - mapM (insertIntro_ currentTs) reMembers - where - insertIntro_ :: UTCTime -> GroupMember -> IO GroupMemberIntro - insertIntro_ ts reMember = do - DB.execute - db - [sql| - INSERT INTO group_member_intros - (re_group_member_id, to_group_member_id, intro_status, created_at, updated_at) - VALUES (?,?,?,?,?) - |] - (groupMemberId' reMember, groupMemberId' toMember, GMIntroPending, ts, ts) - introId <- insertedRowId db - pure GroupMemberIntro {introId, reMember, toMember, introStatus = GMIntroPending, introInvitation = Nothing} - -updateIntroStatus :: DB.Connection -> Int64 -> GroupMemberIntroStatus -> IO () -updateIntroStatus db introId introStatus = do - currentTs <- getCurrentTime - DB.executeNamed - db - [sql| - UPDATE group_member_intros - SET intro_status = :intro_status, updated_at = :updated_at - WHERE group_member_intro_id = :intro_id - |] - [":intro_status" := introStatus, ":updated_at" := currentTs, ":intro_id" := introId] - -saveIntroInvitation :: DB.Connection -> GroupMember -> GroupMember -> IntroInvitation -> ExceptT StoreError IO GroupMemberIntro -saveIntroInvitation db reMember toMember introInv = do - intro <- getIntroduction_ db reMember toMember - liftIO $ do - currentTs <- getCurrentTime - DB.executeNamed - db - [sql| - UPDATE group_member_intros - SET intro_status = :intro_status, - group_queue_info = :group_queue_info, - direct_queue_info = :direct_queue_info, - updated_at = :updated_at - WHERE group_member_intro_id = :intro_id - |] - [ ":intro_status" := GMIntroInvReceived, - ":group_queue_info" := groupConnReq (introInv :: IntroInvitation), - ":direct_queue_info" := directConnReq introInv, - ":updated_at" := currentTs, - ":intro_id" := introId intro - ] - pure intro {introInvitation = Just introInv, introStatus = GMIntroInvReceived} - -saveMemberInvitation :: DB.Connection -> GroupMember -> IntroInvitation -> IO () -saveMemberInvitation db GroupMember {groupMemberId} IntroInvitation {groupConnReq, directConnReq} = do - currentTs <- getCurrentTime - DB.executeNamed - db - [sql| - UPDATE group_members - SET member_status = :member_status, - group_queue_info = :group_queue_info, - direct_queue_info = :direct_queue_info, - updated_at = :updated_at - WHERE group_member_id = :group_member_id - |] - [ ":member_status" := GSMemIntroInvited, - ":group_queue_info" := groupConnReq, - ":direct_queue_info" := directConnReq, - ":updated_at" := currentTs, - ":group_member_id" := groupMemberId - ] - -getIntroduction_ :: DB.Connection -> GroupMember -> GroupMember -> ExceptT StoreError IO GroupMemberIntro -getIntroduction_ db reMember toMember = ExceptT $ do - toIntro - <$> DB.query - db - [sql| - SELECT group_member_intro_id, group_queue_info, direct_queue_info, intro_status - FROM group_member_intros - WHERE re_group_member_id = ? AND to_group_member_id = ? - |] - (groupMemberId' reMember, groupMemberId' toMember) - where - toIntro :: [(Int64, Maybe ConnReqInvitation, Maybe ConnReqInvitation, GroupMemberIntroStatus)] -> Either StoreError GroupMemberIntro - toIntro [(introId, groupConnReq, directConnReq, introStatus)] = - let introInvitation = IntroInvitation <$> groupConnReq <*> directConnReq - in Right GroupMemberIntro {introId, reMember, toMember, introStatus, introInvitation} - toIntro _ = Left SEIntroNotFound - -createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> (CommandId, ConnId) -> (CommandId, ConnId) -> Maybe ProfileId -> ExceptT StoreError IO GroupMember -createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberProfile) (groupCmdId, groupAgentConnId) (directCmdId, directAgentConnId) customUserProfileId = do - let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn - currentTs <- liftIO getCurrentTime - Connection {connId = directConnId} <- liftIO $ createConnection_ db userId ConnContact Nothing directAgentConnId memberContactId Nothing customUserProfileId cLevel currentTs - liftIO $ setCommandConnId db user directCmdId directConnId - (localDisplayName, contactId, memProfileId) <- createContact_ db userId directConnId memberProfile "" (Just groupId) currentTs Nothing - liftIO $ do - let newMember = - NewGroupMember - { memInfo, - memCategory = GCPreMember, - memStatus = GSMemIntroduced, - memInvitedBy = IBUnknown, - localDisplayName, - memContactId = Just contactId, - memProfileId - } - member <- createNewMember_ db user gInfo newMember currentTs - conn@Connection {connId = groupConnId} <- createMemberConnection_ db userId (groupMemberId' member) groupAgentConnId memberContactId cLevel currentTs - liftIO $ setCommandConnId db user groupCmdId groupConnId - pure (member :: GroupMember) {activeConn = Just conn} - -createIntroToMemberContact :: DB.Connection -> User -> GroupMember -> GroupMember -> (CommandId, ConnId) -> (CommandId, ConnId) -> Maybe ProfileId -> IO () -createIntroToMemberContact db user@User {userId} GroupMember {memberContactId = viaContactId, activeConn} _to@GroupMember {groupMemberId, localDisplayName} (groupCmdId, groupAgentConnId) (directCmdId, directAgentConnId) customUserProfileId = do - let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn - currentTs <- getCurrentTime - Connection {connId = groupConnId} <- createMemberConnection_ db userId groupMemberId groupAgentConnId viaContactId cLevel currentTs - setCommandConnId db user groupCmdId groupConnId - Connection {connId = directConnId} <- createConnection_ db userId ConnContact Nothing directAgentConnId viaContactId Nothing customUserProfileId cLevel currentTs - setCommandConnId db user directCmdId directConnId - contactId <- createMemberContact_ directConnId currentTs - updateMember_ contactId currentTs - where - createMemberContact_ :: Int64 -> UTCTime -> IO Int64 - createMemberContact_ connId ts = do - DB.execute - db - [sql| - INSERT INTO contacts (contact_profile_id, via_group, local_display_name, user_id, created_at, updated_at) - SELECT contact_profile_id, group_id, ?, ?, ?, ? - FROM group_members - WHERE group_member_id = ? - |] - (localDisplayName, userId, ts, ts, groupMemberId) - contactId <- insertedRowId db - DB.execute db "UPDATE connections SET contact_id = ?, updated_at = ? WHERE connection_id = ?" (contactId, ts, connId) - pure contactId - updateMember_ :: Int64 -> UTCTime -> IO () - updateMember_ contactId ts = - DB.executeNamed - db - [sql| - UPDATE group_members - SET contact_id = :contact_id, updated_at = :updated_at - WHERE group_member_id = :group_member_id - |] - [":contact_id" := contactId, ":updated_at" := ts, ":group_member_id" := groupMemberId] - -createMemberConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> Maybe Int64 -> Int -> UTCTime -> IO Connection -createMemberConnection_ db userId groupMemberId agentConnId viaContact = createConnection_ db userId ConnMember (Just groupMemberId) agentConnId viaContact Nothing Nothing - -getViaGroupMember :: DB.Connection -> User -> Contact -> IO (Maybe (GroupInfo, GroupMember)) -getViaGroupMember db User {userId, userContactId} Contact {contactId} = - maybeFirstRow toGroupAndMember $ - DB.query - db - [sql| - SELECT - -- GroupInfo - g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, - -- GroupInfo {membership} - mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, - mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, - -- GroupInfo {membership = GroupMember {memberProfile}} - pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences, - -- via GroupMember - m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, - m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, - c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, - c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter - FROM group_members m - JOIN contacts ct ON ct.contact_id = m.contact_id - JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) - JOIN groups g ON g.group_id = m.group_id AND g.group_id = ct.via_group - JOIN group_profiles gp USING (group_profile_id) - JOIN group_members mu ON g.group_id = mu.group_id - JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) - LEFT JOIN connections c ON c.connection_id = ( - SELECT max(cc.connection_id) - FROM connections cc - where cc.group_member_id = m.group_member_id - ) - WHERE ct.user_id = ? AND ct.contact_id = ? AND mu.contact_id = ? AND ct.deleted = 0 - |] - (userId, contactId, userContactId) - where - toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember) - toGroupAndMember (groupInfoRow :. memberRow :. connRow) = - let groupInfo = toGroupInfo userContactId groupInfoRow - member = toGroupMember userContactId memberRow - in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow}) - -getViaGroupContact :: DB.Connection -> User -> GroupMember -> IO (Maybe Contact) -getViaGroupContact db user@User {userId} GroupMember {groupMemberId} = - maybeFirstRow toContact' $ - DB.query - db - [sql| - SELECT - ct.contact_id, ct.contact_profile_id, ct.local_display_name, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, ct.via_group, ct.contact_used, ct.enable_ntfs, - p.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, - c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, - c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter - FROM contacts ct - JOIN contact_profiles p ON ct.contact_profile_id = p.contact_profile_id - JOIN connections c ON c.connection_id = ( - SELECT max(cc.connection_id) - FROM connections cc - where cc.contact_id = ct.contact_id - ) - JOIN groups g ON g.group_id = ct.via_group - JOIN group_members m ON m.group_id = g.group_id AND m.contact_id = ct.contact_id - WHERE ct.user_id = ? AND m.group_member_id = ? AND ct.deleted = 0 - |] - (userId, groupMemberId) - where - toContact' :: ((ContactId, ProfileId, ContactName, Text, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Int64, Bool, Maybe Bool) :. (Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime)) :. ConnectionRow -> Contact - toContact' (((contactId, profileId, localDisplayName, displayName, fullName, image, contactLink, localAlias, viaGroup, contactUsed, enableNtfs_) :. (preferences, userPreferences, createdAt, updatedAt, chatTs)) :. connRow) = - let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} - chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_} - activeConn = toConnection connRow - mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn - in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs} - -createSndDirectFileTransfer :: DB.Connection -> UserId -> Contact -> FilePath -> FileInvitation -> Maybe ConnId -> Integer -> IO FileTransferMeta -createSndDirectFileTransfer db userId Contact {contactId} filePath FileInvitation {fileName, fileSize, fileInline} acId_ chunkSize = do - currentTs <- getCurrentTime - DB.execute - db - "INSERT INTO files (user_id, contact_id, file_name, file_path, file_size, chunk_size, file_inline, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?)" - ((userId, contactId, fileName, filePath, fileSize, chunkSize) :. (fileInline, CIFSSndStored, FPSMP, currentTs, currentTs)) - fileId <- insertedRowId db - forM_ acId_ $ \acId -> do - Connection {connId} <- createSndFileConnection_ db userId fileId acId - let fileStatus = FSNew - DB.execute - db - "INSERT INTO snd_files (file_id, file_status, file_inline, connection_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" - (fileId, fileStatus, fileInline, connId, currentTs, currentTs) - pure FileTransferMeta {fileId, xftpSndFile = Nothing, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False} - -createSndDirectFTConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> IO () -createSndDirectFTConnection db user@User {userId} fileId (cmdId, acId) = do - currentTs <- getCurrentTime - Connection {connId} <- createSndFileConnection_ db userId fileId acId - setCommandConnId db user cmdId connId - DB.execute - db - "INSERT INTO snd_files (file_id, file_status, connection_id, created_at, updated_at) VALUES (?,?,?,?,?)" - (fileId, FSAccepted, connId, currentTs, currentTs) - -createSndGroupFileTransfer :: DB.Connection -> UserId -> GroupInfo -> FilePath -> FileInvitation -> Integer -> IO FileTransferMeta -createSndGroupFileTransfer db userId GroupInfo {groupId} filePath FileInvitation {fileName, fileSize, fileInline} chunkSize = do - currentTs <- getCurrentTime - DB.execute - db - "INSERT INTO files (user_id, group_id, file_name, file_path, file_size, chunk_size, file_inline, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?)" - ((userId, groupId, fileName, filePath, fileSize, chunkSize) :. (fileInline, CIFSSndStored, FPSMP, currentTs, currentTs)) - fileId <- insertedRowId db - pure FileTransferMeta {fileId, xftpSndFile = Nothing, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False} - -createSndGroupFileTransferConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> GroupMember -> IO () -createSndGroupFileTransferConnection db user@User {userId} fileId (cmdId, acId) GroupMember {groupMemberId} = do - currentTs <- getCurrentTime - Connection {connId} <- createSndFileConnection_ db userId fileId acId - setCommandConnId db user cmdId connId - DB.execute - db - "INSERT INTO snd_files (file_id, file_status, connection_id, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" - (fileId, FSAccepted, connId, groupMemberId, currentTs, currentTs) - -createSndDirectInlineFT :: DB.Connection -> Contact -> FileTransferMeta -> IO SndFileTransfer -createSndDirectInlineFT db Contact {localDisplayName = n, activeConn = Connection {connId, agentConnId}} FileTransferMeta {fileId, fileName, filePath, fileSize, chunkSize, fileInline} = do - currentTs <- getCurrentTime - let fileStatus = FSConnected - fileInline' = Just $ fromMaybe IFMOffer fileInline - DB.execute - db - "INSERT INTO snd_files (file_id, file_status, file_inline, connection_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" - (fileId, fileStatus, fileInline', connId, currentTs, currentTs) - pure SndFileTransfer {fileId, fileName, filePath, fileSize, chunkSize, recipientDisplayName = n, connId, agentConnId, groupMemberId = Nothing, fileStatus, fileDescrId = Nothing, fileInline = fileInline'} - -createSndGroupInlineFT :: DB.Connection -> GroupMember -> Connection -> FileTransferMeta -> IO SndFileTransfer -createSndGroupInlineFT db GroupMember {groupMemberId, localDisplayName = n} Connection {connId, agentConnId} FileTransferMeta {fileId, fileName, filePath, fileSize, chunkSize, fileInline} = do - currentTs <- getCurrentTime - let fileStatus = FSConnected - fileInline' = Just $ fromMaybe IFMOffer fileInline - DB.execute - db - "INSERT INTO snd_files (file_id, file_status, file_inline, connection_id, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)" - (fileId, fileStatus, fileInline', connId, groupMemberId, currentTs, currentTs) - pure SndFileTransfer {fileId, fileName, filePath, fileSize, chunkSize, recipientDisplayName = n, connId, agentConnId, groupMemberId = Just groupMemberId, fileStatus, fileDescrId = Nothing, fileInline = fileInline'} - -updateSndDirectFTDelivery :: DB.Connection -> Contact -> FileTransferMeta -> Int64 -> IO () -updateSndDirectFTDelivery db Contact {activeConn = Connection {connId}} FileTransferMeta {fileId} msgDeliveryId = - DB.execute - db - "UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_inline IS NOT NULL" - (msgDeliveryId, connId, fileId) - -updateSndGroupFTDelivery :: DB.Connection -> GroupMember -> Connection -> FileTransferMeta -> Int64 -> IO () -updateSndGroupFTDelivery db GroupMember {groupMemberId} Connection {connId} FileTransferMeta {fileId} msgDeliveryId = - DB.execute - db - "UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE group_member_id = ? AND connection_id = ? AND file_id = ? AND file_inline IS NOT NULL" - (msgDeliveryId, groupMemberId, connId, fileId) - -getSndFTViaMsgDelivery :: DB.Connection -> User -> Connection -> AgentMsgId -> IO (Maybe SndFileTransfer) -getSndFTViaMsgDelivery db User {userId} Connection {connId, agentConnId} agentMsgId = do - (sndFileTransfer_ <=< listToMaybe) - <$> DB.query - db - [sql| - SELECT s.file_id, s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.file_descr_id, s.file_inline, s.group_member_id, c.local_display_name, m.local_display_name - FROM msg_deliveries d - JOIN snd_files s ON s.connection_id = d.connection_id AND s.last_inline_msg_delivery_id = d.msg_delivery_id - JOIN files f ON f.file_id = s.file_id - LEFT JOIN contacts c USING (contact_id) - LEFT JOIN group_members m USING (group_member_id) - WHERE d.connection_id = ? AND d.agent_msg_id = ? AND f.user_id = ? - AND (s.file_descr_id IS NOT NULL OR s.file_inline IS NOT NULL) - |] - (connId, agentMsgId, userId) - where - sndFileTransfer_ :: (Int64, FileStatus, String, Integer, Integer, FilePath, Maybe Int64, Maybe InlineFileMode, Maybe Int64, Maybe ContactName, Maybe ContactName) -> Maybe SndFileTransfer - sndFileTransfer_ (fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, groupMemberId, contactName_, memberName_) = - (\n -> SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, groupMemberId, recipientDisplayName = n, connId, agentConnId}) - <$> (contactName_ <|> memberName_) - -createSndFileTransferXFTP :: DB.Connection -> User -> ContactOrGroup -> FilePath -> FileInvitation -> AgentSndFileId -> Integer -> IO FileTransferMeta -createSndFileTransferXFTP db User {userId} contactOrGroup filePath FileInvitation {fileName, fileSize} agentSndFileId chunkSize = do - currentTs <- getCurrentTime - let xftpSndFile = Just XFTPSndFile {agentSndFileId, privateSndFileDescr = Nothing, agentSndFileDeleted = False} - DB.execute - db - "INSERT INTO files (contact_id, group_id, user_id, file_name, file_path, file_size, chunk_size, agent_snd_file_id, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)" - (contactAndGroupIds contactOrGroup :. (userId, fileName, filePath, fileSize, chunkSize, agentSndFileId, CIFSSndStored, FPXFTP, currentTs, currentTs)) - fileId <- insertedRowId db - pure FileTransferMeta {fileId, xftpSndFile, fileName, filePath, fileSize, fileInline = Nothing, chunkSize, cancelled = False} - -createSndFTDescrXFTP :: DB.Connection -> User -> Maybe GroupMember -> Connection -> FileTransferMeta -> FileDescr -> IO () -createSndFTDescrXFTP db User {userId} m Connection {connId} FileTransferMeta {fileId} FileDescr {fileDescrText, fileDescrPartNo, fileDescrComplete} = do - currentTs <- getCurrentTime - let fileStatus = FSNew - DB.execute - db - "INSERT INTO xftp_file_descriptions (user_id, file_descr_text, file_descr_part_no, file_descr_complete, created_at, updated_at) VALUES (?,?,?,?,?,?)" - (userId, fileDescrText, fileDescrPartNo, fileDescrComplete, currentTs, currentTs) - fileDescrId <- insertedRowId db - DB.execute - db - "INSERT INTO snd_files (file_id, file_status, file_descr_id, group_member_id, connection_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)" - (fileId, fileStatus, fileDescrId, groupMemberId' <$> m, connId, currentTs, currentTs) - -setSndFTPrivateSndDescr :: DB.Connection -> User -> FileTransferId -> Text -> IO () -setSndFTPrivateSndDescr db User {userId} fileId sfdText = do - currentTs <- getCurrentTime - DB.execute - db - "UPDATE files SET private_snd_file_descr = ?, updated_at = ? WHERE user_id = ? AND file_id = ?" - (sfdText, currentTs, userId, fileId) - -updateSndFTDescrXFTP :: DB.Connection -> User -> SndFileTransfer -> Text -> IO () -updateSndFTDescrXFTP db user@User {userId} sft@SndFileTransfer {fileId, fileDescrId} rfdText = do - currentTs <- getCurrentTime - DB.execute - db - [sql| - UPDATE xftp_file_descriptions - SET file_descr_text = ?, file_descr_part_no = ?, file_descr_complete = ?, updated_at = ? - WHERE user_id = ? AND file_descr_id = ? - |] - (rfdText, 1 :: Int, True, currentTs, userId, fileDescrId) - updateCIFileStatus db user fileId $ CIFSSndTransfer 1 1 - updateSndFileStatus db sft FSConnected - -createExtraSndFTDescrs :: DB.Connection -> User -> FileTransferId -> [Text] -> IO () -createExtraSndFTDescrs db User {userId} fileId rfdTexts = do - currentTs <- getCurrentTime - forM_ rfdTexts $ \rfdText -> - DB.execute - db - "INSERT INTO extra_xftp_file_descriptions (file_id, user_id, file_descr_text, created_at, updated_at) VALUES (?,?,?,?,?)" - (fileId, userId, rfdText, currentTs, currentTs) - -updateSndFTDeliveryXFTP :: DB.Connection -> SndFileTransfer -> Int64 -> IO () -updateSndFTDeliveryXFTP db SndFileTransfer {connId, fileId, fileDescrId} msgDeliveryId = - DB.execute - db - "UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_descr_id = ?" - (msgDeliveryId, connId, fileId, fileDescrId) - -setSndFTAgentDeleted :: DB.Connection -> User -> FileTransferId -> IO () -setSndFTAgentDeleted db User {userId} fileId = do - currentTs <- getCurrentTime - DB.execute - db - "UPDATE files SET agent_snd_file_deleted = 1, updated_at = ? WHERE user_id = ? AND file_id = ?" - (currentTs, userId, fileId) - -getXFTPSndFileDBId :: DB.Connection -> User -> AgentSndFileId -> ExceptT StoreError IO FileTransferId -getXFTPSndFileDBId db User {userId} aSndFileId = - ExceptT . firstRow fromOnly (SESndFileNotFoundXFTP aSndFileId) $ - DB.query db "SELECT file_id FROM files WHERE user_id = ? AND agent_snd_file_id = ?" (userId, aSndFileId) - -getXFTPRcvFileDBId :: DB.Connection -> AgentRcvFileId -> ExceptT StoreError IO FileTransferId -getXFTPRcvFileDBId db aRcvFileId = - ExceptT . firstRow fromOnly (SERcvFileNotFoundXFTP aRcvFileId) $ - DB.query db "SELECT file_id FROM rcv_files WHERE agent_rcv_file_id = ?" (Only aRcvFileId) - -updateFileCancelled :: MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> IO () -updateFileCancelled db User {userId} fileId ciFileStatus = do - currentTs <- getCurrentTime - DB.execute db "UPDATE files SET cancelled = 1, ci_file_status = ?, updated_at = ? WHERE user_id = ? AND file_id = ?" (ciFileStatus, currentTs, userId, fileId) - -updateCIFileStatus :: MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> IO () -updateCIFileStatus db User {userId} fileId ciFileStatus = do - currentTs <- getCurrentTime - DB.execute db "UPDATE files SET ci_file_status = ?, updated_at = ? WHERE user_id = ? AND file_id = ?" (ciFileStatus, currentTs, userId, fileId) - -getSharedMsgIdByFileId :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO SharedMsgId -getSharedMsgIdByFileId db userId fileId = - ExceptT . firstRow fromOnly (SESharedMsgIdNotFoundByFileId fileId) $ - DB.query - db - [sql| - SELECT i.shared_msg_id - FROM chat_items i - JOIN files f ON f.chat_item_id = i.chat_item_id - WHERE f.user_id = ? AND f.file_id = ? - |] - (userId, fileId) - -getFileIdBySharedMsgId :: DB.Connection -> UserId -> Int64 -> SharedMsgId -> ExceptT StoreError IO Int64 -getFileIdBySharedMsgId db userId contactId sharedMsgId = - ExceptT . firstRow fromOnly (SEFileIdNotFoundBySharedMsgId sharedMsgId) $ - DB.query - db - [sql| - SELECT f.file_id - FROM files f - JOIN chat_items i ON i.chat_item_id = f.chat_item_id - WHERE i.user_id = ? AND i.contact_id = ? AND i.shared_msg_id = ? - |] - (userId, contactId, sharedMsgId) - -getGroupFileIdBySharedMsgId :: DB.Connection -> UserId -> Int64 -> SharedMsgId -> ExceptT StoreError IO Int64 -getGroupFileIdBySharedMsgId db userId groupId sharedMsgId = - ExceptT . firstRow fromOnly (SEFileIdNotFoundBySharedMsgId sharedMsgId) $ - DB.query - db - [sql| - SELECT f.file_id - FROM files f - JOIN chat_items i ON i.chat_item_id = f.chat_item_id - WHERE i.user_id = ? AND i.group_id = ? AND i.shared_msg_id = ? - |] - (userId, groupId, sharedMsgId) - -getDirectFileIdBySharedMsgId :: DB.Connection -> User -> Contact -> SharedMsgId -> ExceptT StoreError IO Int64 -getDirectFileIdBySharedMsgId db User {userId} Contact {contactId} sharedMsgId = - ExceptT . firstRow fromOnly (SEFileIdNotFoundBySharedMsgId sharedMsgId) $ - DB.query - db - [sql| - SELECT f.file_id - FROM files f - JOIN chat_items i ON i.chat_item_id = f.chat_item_id - WHERE i.user_id = ? AND i.contact_id = ? AND i.shared_msg_id = ? - |] - (userId, contactId, sharedMsgId) - -getChatRefByFileId :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO ChatRef -getChatRefByFileId db User {userId} fileId = - liftIO getChatRef >>= \case - [(Just contactId, Nothing)] -> pure $ ChatRef CTDirect contactId - [(Nothing, Just groupId)] -> pure $ ChatRef CTGroup groupId - _ -> throwError $ SEInternalError "could not retrieve chat ref by file id" - where - getChatRef = - DB.query - db - [sql| - SELECT contact_id, group_id - FROM files - WHERE user_id = ? AND file_id = ? - LIMIT 1 - |] - (userId, fileId) - -createSndFileConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> IO Connection -createSndFileConnection_ db userId fileId agentConnId = do - currentTs <- getCurrentTime - createConnection_ db userId ConnSndFile (Just fileId) agentConnId Nothing Nothing Nothing 0 currentTs - -updateSndFileStatus :: DB.Connection -> SndFileTransfer -> FileStatus -> IO () -updateSndFileStatus db SndFileTransfer {fileId, connId} status = do - currentTs <- getCurrentTime - DB.execute db "UPDATE snd_files SET file_status = ?, updated_at = ? WHERE file_id = ? AND connection_id = ?" (status, currentTs, fileId, connId) - -createSndFileChunk :: DB.Connection -> SndFileTransfer -> IO (Maybe Integer) -createSndFileChunk db SndFileTransfer {fileId, connId, fileSize, chunkSize} = do - chunkNo <- getLastChunkNo - insertChunk chunkNo - pure chunkNo - where - getLastChunkNo = do - ns <- DB.query db "SELECT chunk_number FROM snd_file_chunks WHERE file_id = ? AND connection_id = ? AND chunk_sent = 1 ORDER BY chunk_number DESC LIMIT 1" (fileId, connId) - pure $ case map fromOnly ns of - [] -> Just 1 - n : _ -> if n * chunkSize >= fileSize then Nothing else Just (n + 1) - insertChunk chunkNo_ = forM_ chunkNo_ $ \chunkNo -> do - currentTs <- getCurrentTime - DB.execute - db - "INSERT OR REPLACE INTO snd_file_chunks (file_id, connection_id, chunk_number, created_at, updated_at) VALUES (?,?,?,?,?)" - (fileId, connId, chunkNo, currentTs, currentTs) - -updateSndFileChunkMsg :: DB.Connection -> SndFileTransfer -> Integer -> AgentMsgId -> IO () -updateSndFileChunkMsg db SndFileTransfer {fileId, connId} chunkNo msgId = do - currentTs <- getCurrentTime - DB.execute - db - [sql| - UPDATE snd_file_chunks - SET chunk_agent_msg_id = ?, updated_at = ? - WHERE file_id = ? AND connection_id = ? AND chunk_number = ? - |] - (msgId, currentTs, fileId, connId, chunkNo) - -updateSndFileChunkSent :: DB.Connection -> SndFileTransfer -> AgentMsgId -> IO () -updateSndFileChunkSent db SndFileTransfer {fileId, connId} msgId = do - currentTs <- getCurrentTime - DB.execute - db - [sql| - UPDATE snd_file_chunks - SET chunk_sent = 1, updated_at = ? - WHERE file_id = ? AND connection_id = ? AND chunk_agent_msg_id = ? - |] - (currentTs, fileId, connId, msgId) - -deleteSndFileChunks :: DB.Connection -> SndFileTransfer -> IO () -deleteSndFileChunks db SndFileTransfer {fileId, connId} = - DB.execute db "DELETE FROM snd_file_chunks WHERE file_id = ? AND connection_id = ?" (fileId, connId) - -createRcvFileTransfer :: DB.Connection -> UserId -> Contact -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer -createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do - currentTs <- liftIO getCurrentTime - rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr - let rfdId = (fileDescrId :: RcvFileDescr -> Int64) <$> rfd_ - xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False}) <$> rfd_ - fileProtocol = if isJust rfd_ then FPXFTP else FPSMP - fileId <- liftIO $ do - DB.execute - db - "INSERT INTO files (user_id, contact_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?)" - (userId, contactId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, fileProtocol, currentTs, currentTs) - insertedRowId db - liftIO $ - DB.execute - db - "INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, file_descr_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" - (fileId, FSNew, fileConnReq, fileInline, rcvFileInline, rfdId, currentTs, currentTs) - pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing} - -createRcvGroupFileTransfer :: DB.Connection -> UserId -> GroupMember -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer -createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do - currentTs <- liftIO getCurrentTime - rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr - let rfdId = (fileDescrId :: RcvFileDescr -> Int64) <$> rfd_ - xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False}) <$> rfd_ - fileProtocol = if isJust rfd_ then FPXFTP else FPSMP - fileId <- liftIO $ do - DB.execute - db - "INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?)" - (userId, groupId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, fileProtocol, currentTs, currentTs) - insertedRowId db - liftIO $ - DB.execute - db - "INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, group_member_id, file_descr_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)" - (fileId, FSNew, fileConnReq, fileInline, rcvFileInline, groupMemberId, rfdId, currentTs, currentTs) - pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Just groupMemberId} - -createRcvFD_ :: DB.Connection -> UserId -> UTCTime -> FileDescr -> ExceptT StoreError IO RcvFileDescr -createRcvFD_ db userId currentTs FileDescr {fileDescrText, fileDescrPartNo, fileDescrComplete} = do - when (fileDescrPartNo /= 0) $ throwError SERcvFileInvalidDescrPart - fileDescrId <- liftIO $ do - DB.execute - db - "INSERT INTO xftp_file_descriptions (user_id, file_descr_text, file_descr_part_no, file_descr_complete, created_at, updated_at) VALUES (?,?,?,?,?,?)" - (userId, fileDescrText, fileDescrPartNo, fileDescrComplete, currentTs, currentTs) - insertedRowId db - pure RcvFileDescr {fileDescrId, fileDescrPartNo, fileDescrText, fileDescrComplete} - -appendRcvFD :: DB.Connection -> UserId -> FileTransferId -> FileDescr -> ExceptT StoreError IO RcvFileDescr -appendRcvFD db userId fileId fd@FileDescr {fileDescrText, fileDescrPartNo, fileDescrComplete} = do - currentTs <- liftIO getCurrentTime - liftIO (getRcvFileDescrByFileId_ db fileId) >>= \case - Nothing -> do - rfd@RcvFileDescr {fileDescrId} <- createRcvFD_ db userId currentTs fd - liftIO $ - DB.execute - db - "UPDATE rcv_files SET file_descr_id = ?, updated_at = ? WHERE file_id = ?" - (fileDescrId, currentTs, fileId) - pure rfd - Just - RcvFileDescr - { fileDescrId, - fileDescrText = rfdText, - fileDescrPartNo = rfdPNo, - fileDescrComplete = rfdComplete - } -> do - when (fileDescrPartNo /= rfdPNo + 1 || rfdComplete) $ throwError SERcvFileInvalidDescrPart - let fileDescrText' = rfdText <> fileDescrText - liftIO $ - DB.execute - db - [sql| - UPDATE xftp_file_descriptions - SET file_descr_text = ?, file_descr_part_no = ?, file_descr_complete = ? - WHERE file_descr_id = ? - |] - (fileDescrText', fileDescrPartNo, fileDescrComplete, fileDescrId) - pure RcvFileDescr {fileDescrId, fileDescrText = fileDescrText', fileDescrPartNo, fileDescrComplete} - -getRcvFileDescrByFileId :: DB.Connection -> FileTransferId -> ExceptT StoreError IO RcvFileDescr -getRcvFileDescrByFileId db fileId = do - liftIO (getRcvFileDescrByFileId_ db fileId) >>= \case - Nothing -> throwError $ SERcvFileDescrNotFound fileId - Just rfd -> pure rfd - -getRcvFileDescrByFileId_ :: DB.Connection -> FileTransferId -> IO (Maybe RcvFileDescr) -getRcvFileDescrByFileId_ db fileId = - maybeFirstRow toRcvFileDescr $ - DB.query - db - [sql| - SELECT d.file_descr_id, d.file_descr_text, d.file_descr_part_no, d.file_descr_complete - FROM xftp_file_descriptions d - JOIN rcv_files f ON f.file_descr_id = d.file_descr_id - WHERE f.file_id = ? - LIMIT 1 - |] - (Only fileId) - where - toRcvFileDescr :: (Int64, Text, Int, Bool) -> RcvFileDescr - toRcvFileDescr (fileDescrId, fileDescrText, fileDescrPartNo, fileDescrComplete) = - RcvFileDescr {fileDescrId, fileDescrText, fileDescrPartNo, fileDescrComplete} - -updateRcvFileAgentId :: DB.Connection -> FileTransferId -> Maybe AgentRcvFileId -> IO () -updateRcvFileAgentId db fileId aFileId = do - currentTs <- getCurrentTime - DB.execute db "UPDATE rcv_files SET agent_rcv_file_id = ?, updated_at = ? WHERE file_id = ?" (aFileId, currentTs, fileId) - -getRcvFileTransferById :: DB.Connection -> FileTransferId -> ExceptT StoreError IO (User, RcvFileTransfer) -getRcvFileTransferById db fileId = do - user <- getUserByFileId db fileId - (user,) <$> getRcvFileTransfer db user fileId - -getRcvFileTransfer :: DB.Connection -> User -> FileTransferId -> ExceptT StoreError IO RcvFileTransfer -getRcvFileTransfer db User {userId} fileId = do - rftRow <- - ExceptT . firstRow id (SERcvFileNotFound fileId) $ - DB.query - db - [sql| - SELECT r.file_status, r.file_queue_info, r.group_member_id, f.file_name, - f.file_size, f.chunk_size, f.cancelled, cs.local_display_name, m.local_display_name, - f.file_path, r.file_inline, r.rcv_file_inline, r.agent_rcv_file_id, r.agent_rcv_file_deleted, c.connection_id, c.agent_conn_id - FROM rcv_files r - JOIN files f USING (file_id) - LEFT JOIN connections c ON r.file_id = c.rcv_file_id - LEFT JOIN contacts cs USING (contact_id) - LEFT JOIN group_members m USING (group_member_id) - WHERE f.user_id = ? AND f.file_id = ? - |] - (userId, fileId) - rfd_ <- liftIO $ getRcvFileDescrByFileId_ db fileId - rcvFileTransfer rfd_ rftRow - where - rcvFileTransfer :: - Maybe RcvFileDescr -> - (FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe Bool) :. (Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe InlineFileMode, Maybe InlineFileMode, Maybe AgentRcvFileId, Bool) :. (Maybe Int64, Maybe AgentConnId) -> - ExceptT StoreError IO RcvFileTransfer - rcvFileTransfer rfd_ ((fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_) :. (contactName_, memberName_, filePath_, fileInline, rcvFileInline, agentRcvFileId, agentRcvFileDeleted) :. (connId_, agentConnId_)) = - case contactName_ <|> memberName_ of - Nothing -> throwError $ SERcvFileInvalid fileId - Just name -> do - case fileStatus' of - FSNew -> pure $ ft name RFSNew - FSAccepted -> ft name . RFSAccepted <$> rfi - FSConnected -> ft name . RFSConnected <$> rfi - FSComplete -> ft name . RFSComplete <$> rfi - FSCancelled -> ft name . RFSCancelled <$> rfi_ - where - ft senderDisplayName fileStatus = - let fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq, fileInline, fileDescr = Nothing} - xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId, agentRcvFileDeleted}) <$> rfd_ - in RcvFileTransfer {fileId, xftpRcvFile, fileInvitation, fileStatus, rcvFileInline, senderDisplayName, chunkSize, cancelled, grpMemberId} - rfi = maybe (throwError $ SERcvFileInvalid fileId) pure =<< rfi_ - rfi_ = case (filePath_, connId_, agentConnId_) of - (Just filePath, connId, agentConnId) -> pure $ Just RcvFileInfo {filePath, connId, agentConnId} - _ -> pure Nothing - cancelled = fromMaybe False cancelled_ - -acceptRcvFileTransfer :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> ConnStatus -> FilePath -> ExceptT StoreError IO AChatItem -acceptRcvFileTransfer db user@User {userId} fileId (cmdId, acId) connStatus filePath = ExceptT $ do - currentTs <- getCurrentTime - acceptRcvFT_ db user fileId filePath Nothing currentTs - DB.execute - db - "INSERT INTO connections (agent_conn_id, conn_status, conn_type, rcv_file_id, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)" - (acId, connStatus, ConnRcvFile, fileId, userId, currentTs, currentTs) - connId <- insertedRowId db - setCommandConnId db user cmdId connId - runExceptT $ getChatItemByFileId db user fileId - -getContactByFileId :: DB.Connection -> User -> FileTransferId -> ExceptT StoreError IO Contact -getContactByFileId db user@User {userId} fileId = do - cId <- getContactIdByFileId - getContact db user cId - where - getContactIdByFileId = - ExceptT . firstRow fromOnly (SEContactNotFoundByFileId fileId) $ - DB.query db "SELECT contact_id FROM files WHERE user_id = ? AND file_id = ?" (userId, fileId) - -acceptRcvInlineFT :: DB.Connection -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem -acceptRcvInlineFT db user fileId filePath = do - liftIO $ acceptRcvFT_ db user fileId filePath (Just IFMOffer) =<< getCurrentTime - getChatItemByFileId db user fileId - -startRcvInlineFT :: DB.Connection -> User -> RcvFileTransfer -> FilePath -> Maybe InlineFileMode -> IO () -startRcvInlineFT db user RcvFileTransfer {fileId} filePath rcvFileInline = - acceptRcvFT_ db user fileId filePath rcvFileInline =<< getCurrentTime - -xftpAcceptRcvFT :: DB.Connection -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem -xftpAcceptRcvFT db user fileId filePath = do - liftIO $ acceptRcvFT_ db user fileId filePath Nothing =<< getCurrentTime - getChatItemByFileId db user fileId - -acceptRcvFT_ :: DB.Connection -> User -> FileTransferId -> FilePath -> Maybe InlineFileMode -> UTCTime -> IO () -acceptRcvFT_ db User {userId} fileId filePath rcvFileInline currentTs = do - DB.execute - db - "UPDATE files SET file_path = ?, ci_file_status = ?, updated_at = ? WHERE user_id = ? AND file_id = ?" - (filePath, CIFSRcvAccepted, currentTs, userId, fileId) - DB.execute - db - "UPDATE rcv_files SET rcv_file_inline = ?, file_status = ?, updated_at = ? WHERE file_id = ?" - (rcvFileInline, FSAccepted, currentTs, fileId) - -setRcvFileToReceive :: DB.Connection -> FileTransferId -> IO () -setRcvFileToReceive db fileId = do - currentTs <- getCurrentTime - DB.execute - db - "UPDATE rcv_files SET to_receive = 1, updated_at = ? WHERE file_id = ?" - (currentTs, fileId) - -getRcvFilesToReceive :: DB.Connection -> User -> IO [RcvFileTransfer] -getRcvFilesToReceive db user@User {userId} = do - cutoffTs <- addUTCTime (- (2 * nominalDay)) <$> getCurrentTime - fileIds :: [Int64] <- - map fromOnly - <$> DB.query - db - [sql| - SELECT r.file_id - FROM rcv_files r - JOIN files f ON f.file_id = r.file_id - WHERE f.user_id = ? AND r.file_status = ? - AND r.to_receive = 1 AND r.created_at > ? - |] - (userId, FSNew, cutoffTs) - rights <$> mapM (runExceptT . getRcvFileTransfer db user) fileIds - -setRcvFTAgentDeleted :: DB.Connection -> FileTransferId -> IO () -setRcvFTAgentDeleted db fileId = do - currentTs <- getCurrentTime - DB.execute - db - "UPDATE rcv_files SET agent_rcv_file_deleted = 1, updated_at = ? WHERE file_id = ?" - (currentTs, fileId) - -updateRcvFileStatus :: DB.Connection -> FileTransferId -> FileStatus -> IO () -updateRcvFileStatus db fileId status = do - currentTs <- getCurrentTime - DB.execute db "UPDATE rcv_files SET file_status = ?, updated_at = ? WHERE file_id = ?" (status, currentTs, fileId) - -createRcvFileChunk :: DB.Connection -> RcvFileTransfer -> Integer -> AgentMsgId -> IO RcvChunkStatus -createRcvFileChunk db RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileSize}, chunkSize} chunkNo msgId = do - status <- getLastChunkNo - unless (status == RcvChunkError) $ do - currentTs <- getCurrentTime - DB.execute - db - "INSERT OR REPLACE INTO rcv_file_chunks (file_id, chunk_number, chunk_agent_msg_id, created_at, updated_at) VALUES (?,?,?,?,?)" - (fileId, chunkNo, msgId, currentTs, currentTs) - pure status - where - getLastChunkNo = do - ns <- DB.query db "SELECT chunk_number FROM rcv_file_chunks WHERE file_id = ? ORDER BY chunk_number DESC LIMIT 1" (Only fileId) - pure $ case map fromOnly ns of - [] - | chunkNo == 1 -> - if chunkSize >= fileSize - then RcvChunkFinal - else RcvChunkOk - | otherwise -> RcvChunkError - n : _ - | chunkNo == n -> RcvChunkDuplicate - | chunkNo == n + 1 -> - let prevSize = n * chunkSize - in if prevSize >= fileSize - then RcvChunkError - else - if prevSize + chunkSize >= fileSize - then RcvChunkFinal - else RcvChunkOk - | otherwise -> RcvChunkError - -updatedRcvFileChunkStored :: DB.Connection -> RcvFileTransfer -> Integer -> IO () -updatedRcvFileChunkStored db RcvFileTransfer {fileId} chunkNo = do - currentTs <- getCurrentTime - DB.execute - db - [sql| - UPDATE rcv_file_chunks - SET chunk_stored = 1, updated_at = ? - WHERE file_id = ? AND chunk_number = ? - |] - (currentTs, fileId, chunkNo) - -deleteRcvFileChunks :: DB.Connection -> RcvFileTransfer -> IO () -deleteRcvFileChunks db RcvFileTransfer {fileId} = - DB.execute db "DELETE FROM rcv_file_chunks WHERE file_id = ?" (Only fileId) - -updateFileTransferChatItemId :: DB.Connection -> FileTransferId -> ChatItemId -> UTCTime -> IO () -updateFileTransferChatItemId db fileId ciId currentTs = - DB.execute db "UPDATE files SET chat_item_id = ?, updated_at = ? WHERE file_id = ?" (ciId, currentTs, fileId) - -getFileTransferProgress :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO (FileTransfer, [Integer]) -getFileTransferProgress db user fileId = do - ft <- getFileTransfer db user fileId - liftIO $ - (ft,) . map fromOnly <$> case ft of - FTSnd _ [] -> pure [Only 0] - FTSnd _ _ -> DB.query db "SELECT COUNT(*) FROM snd_file_chunks WHERE file_id = ? and chunk_sent = 1 GROUP BY connection_id" (Only fileId) - FTRcv _ -> DB.query db "SELECT COUNT(*) FROM rcv_file_chunks WHERE file_id = ? AND chunk_stored = 1" (Only fileId) - -getFileTransfer :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO FileTransfer -getFileTransfer db user@User {userId} fileId = - fileTransfer =<< liftIO getFileTransferRow - where - fileTransfer :: [(Maybe Int64, Maybe Int64)] -> ExceptT StoreError IO FileTransfer - fileTransfer [(Nothing, Just _)] = FTRcv <$> getRcvFileTransfer db user fileId - fileTransfer _ = do - (ftm, fts) <- getSndFileTransfer db user fileId - pure $ FTSnd {fileTransferMeta = ftm, sndFileTransfers = fts} - getFileTransferRow :: IO [(Maybe Int64, Maybe Int64)] - getFileTransferRow = - DB.query - db - [sql| - SELECT s.file_id, r.file_id - FROM files f - LEFT JOIN snd_files s ON s.file_id = f.file_id - LEFT JOIN rcv_files r ON r.file_id = f.file_id - WHERE user_id = ? AND f.file_id = ? - |] - (userId, fileId) - -getSndFileTransfer :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO (FileTransferMeta, [SndFileTransfer]) -getSndFileTransfer db user fileId = do - fileTransferMeta <- getFileTransferMeta db user fileId - sndFileTransfers <- getSndFileTransfers db user fileId - pure (fileTransferMeta, sndFileTransfers) - -getSndFileTransfers :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO [SndFileTransfer] -getSndFileTransfers db User {userId} fileId = ExceptT $ getSndFileTransfers_ db userId fileId - -getSndFileTransfers_ :: DB.Connection -> UserId -> Int64 -> IO (Either StoreError [SndFileTransfer]) -getSndFileTransfers_ db userId fileId = - mapM sndFileTransfer - <$> DB.query - db - [sql| - SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.file_descr_id, s.file_inline, s.connection_id, c.agent_conn_id, s.group_member_id, - cs.local_display_name, m.local_display_name - FROM snd_files s - JOIN files f USING (file_id) - JOIN connections c USING (connection_id) - LEFT JOIN contacts cs USING (contact_id) - LEFT JOIN group_members m USING (group_member_id) - WHERE f.user_id = ? AND f.file_id = ? - |] - (userId, fileId) - where - sndFileTransfer :: (FileStatus, String, Integer, Integer, FilePath) :. (Maybe Int64, Maybe InlineFileMode, Int64, AgentConnId, Maybe Int64, Maybe ContactName, Maybe ContactName) -> Either StoreError SndFileTransfer - sndFileTransfer ((fileStatus, fileName, fileSize, chunkSize, filePath) :. (fileDescrId, fileInline, connId, agentConnId, groupMemberId, contactName_, memberName_)) = - case contactName_ <|> memberName_ of - Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, recipientDisplayName, connId, agentConnId, groupMemberId} - Nothing -> Left $ SESndFileInvalid fileId - -getFileTransferMeta :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO FileTransferMeta -getFileTransferMeta db User {userId} fileId = - ExceptT . firstRow fileTransferMeta (SEFileNotFound fileId) $ - DB.query - db - [sql| - SELECT file_name, file_size, chunk_size, file_path, file_inline, agent_snd_file_id, agent_snd_file_deleted, private_snd_file_descr, cancelled - FROM files - WHERE user_id = ? AND file_id = ? - |] - (userId, fileId) - where - fileTransferMeta :: (String, Integer, Integer, FilePath, Maybe InlineFileMode, Maybe AgentSndFileId, Bool, Maybe Text, Maybe Bool) -> FileTransferMeta - fileTransferMeta (fileName, fileSize, chunkSize, filePath, fileInline, aSndFileId_, agentSndFileDeleted, privateSndFileDescr, cancelled_) = - let xftpSndFile = (\fId -> XFTPSndFile {agentSndFileId = fId, privateSndFileDescr, agentSndFileDeleted}) <$> aSndFileId_ - in FileTransferMeta {fileId, xftpSndFile, fileName, fileSize, chunkSize, filePath, fileInline, cancelled = fromMaybe False cancelled_} - -getContactFileInfo :: DB.Connection -> User -> Contact -> IO [CIFileInfo] -getContactFileInfo db User {userId} Contact {contactId} = - map toFileInfo - <$> DB.query db (fileInfoQuery <> " WHERE i.user_id = ? AND i.contact_id = ?") (userId, contactId) - -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) - -deleteGroupCIs :: DB.Connection -> User -> GroupInfo -> IO () -deleteGroupCIs db User {userId} GroupInfo {groupId} = do - 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) - -createNewSndMessage :: MsgEncodingI e => DB.Connection -> TVar ChaChaDRG -> ConnOrGroupId -> (SharedMsgId -> NewMessage e) -> ExceptT StoreError IO SndMessage -createNewSndMessage db gVar connOrGroupId mkMessage = - createWithRandomId gVar $ \sharedMsgId -> do - let NewMessage {chatMsgEvent, msgBody} = mkMessage $ SharedMsgId sharedMsgId - 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 (?,?,?,?,?,?,?,?,?) - |] - (MDSnd, toCMEventTag chatMsgEvent, msgBody, connId_, groupId_, sharedMsgId, Just True, createdAt, createdAt) - msgId <- insertedRowId db - pure SndMessage {msgId, sharedMsgId = SharedMsgId sharedMsgId, msgBody} - where - (connId_, groupId_) = case connOrGroupId of - ConnectionId connId -> (Just connId, Nothing) - GroupId groupId -> (Nothing, Just groupId) - -createSndMsgDelivery :: DB.Connection -> SndMsgDelivery -> MessageId -> IO Int64 -createSndMsgDelivery db sndMsgDelivery messageId = do - currentTs <- getCurrentTime - msgDeliveryId <- createSndMsgDelivery_ db sndMsgDelivery messageId currentTs - createMsgDeliveryEvent_ db msgDeliveryId MDSSndAgent currentTs - pure msgDeliveryId - -createNewMessageAndRcvMsgDelivery :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewMessage e -> Maybe SharedMsgId -> RcvMsgDelivery -> IO RcvMessage -createNewMessageAndRcvMsgDelivery db connOrGroupId NewMessage {chatMsgEvent, msgBody} sharedMsgId_ RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId} = do - currentTs <- getCurrentTime - DB.execute - db - "INSERT INTO messages (msg_sent, chat_msg_event, msg_body, created_at, updated_at, connection_id, group_id, shared_msg_id) VALUES (?,?,?,?,?,?,?,?)" - (MDRcv, toCMEventTag chatMsgEvent, msgBody, currentTs, currentTs, connId_, groupId_, sharedMsgId_) - msgId <- insertedRowId db - DB.execute - db - "INSERT INTO msg_deliveries (message_id, connection_id, agent_msg_id, agent_msg_meta, agent_ack_cmd_id, chat_ts, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" - (msgId, connId, agentMsgId, msgMetaJson agentMsgMeta, agentAckCmdId, snd $ broker agentMsgMeta, currentTs, currentTs) - msgDeliveryId <- insertedRowId db - createMsgDeliveryEvent_ db msgDeliveryId MDSRcvAgent currentTs - pure RcvMessage {msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody} - where - (connId_, groupId_) = case connOrGroupId of - ConnectionId connId' -> (Just connId', Nothing) - GroupId groupId -> (Nothing, Just groupId) - -createSndMsgDeliveryEvent :: DB.Connection -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> ExceptT StoreError IO () -createSndMsgDeliveryEvent db connId agentMsgId sndMsgDeliveryStatus = do - msgDeliveryId <- getMsgDeliveryId_ db connId agentMsgId - liftIO $ do - currentTs <- getCurrentTime - createMsgDeliveryEvent_ db msgDeliveryId sndMsgDeliveryStatus currentTs - -createRcvMsgDeliveryEvent :: DB.Connection -> Int64 -> CommandId -> MsgDeliveryStatus 'MDRcv -> IO () -createRcvMsgDeliveryEvent db connId cmdId rcvMsgDeliveryStatus = do - msgDeliveryId <- getMsgDeliveryIdByCmdId_ db connId cmdId - forM_ msgDeliveryId $ \mdId -> do - currentTs <- getCurrentTime - createMsgDeliveryEvent_ db mdId rcvMsgDeliveryStatus currentTs - -createSndMsgDelivery_ :: DB.Connection -> SndMsgDelivery -> MessageId -> UTCTime -> IO Int64 -createSndMsgDelivery_ db SndMsgDelivery {connId, agentMsgId} messageId createdAt = do - DB.execute - db - [sql| - INSERT INTO msg_deliveries - (message_id, connection_id, agent_msg_id, agent_msg_meta, chat_ts, created_at, updated_at) - VALUES (?,?,?,NULL,?,?,?) - |] - (messageId, connId, agentMsgId, createdAt, createdAt, createdAt) - insertedRowId db - -createMsgDeliveryEvent_ :: DB.Connection -> Int64 -> MsgDeliveryStatus d -> UTCTime -> IO () -createMsgDeliveryEvent_ db msgDeliveryId msgDeliveryStatus createdAt = do - DB.execute - db - [sql| - INSERT INTO msg_delivery_events - (msg_delivery_id, delivery_status, created_at, updated_at) - VALUES (?,?,?,?) - |] - (msgDeliveryId, msgDeliveryStatus, createdAt, createdAt) - -getMsgDeliveryId_ :: DB.Connection -> Int64 -> AgentMsgId -> ExceptT StoreError IO Int64 -getMsgDeliveryId_ db connId agentMsgId = - ExceptT . firstRow fromOnly (SENoMsgDelivery connId agentMsgId) $ - DB.query - db - [sql| - SELECT msg_delivery_id - FROM msg_deliveries m - WHERE m.connection_id = ? AND m.agent_msg_id = ? - LIMIT 1 - |] - (connId, agentMsgId) - -getMsgDeliveryIdByCmdId_ :: DB.Connection -> Int64 -> CommandId -> IO (Maybe AgentMsgId) -getMsgDeliveryIdByCmdId_ db connId cmdId = - maybeFirstRow fromOnly $ - DB.query - db - [sql| - SELECT msg_delivery_id - FROM msg_deliveries - WHERE connection_id = ? AND agent_ack_cmd_id = ? - LIMIT 1 - |] - (connId, cmdId) - -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) - -getPendingGroupMessages :: DB.Connection -> Int64 -> IO [PendingGroupMessage] -getPendingGroupMessages db groupMemberId = - map pendingGroupMessage - <$> DB.query - db - [sql| - SELECT pgm.message_id, m.chat_msg_event, m.msg_body, pgm.group_member_intro_id - FROM pending_group_messages pgm - JOIN messages m USING (message_id) - WHERE pgm.group_member_id = ? - ORDER BY pgm.message_id ASC - |] - (Only groupMemberId) - where - pendingGroupMessage (msgId, cmEventTag, msgBody, introId_) = - PendingGroupMessage {msgId, cmEventTag, msgBody, introId_} - -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) - -updateChatTs :: DB.Connection -> User -> ChatDirection c d -> UTCTime -> IO () -updateChatTs db User {userId} chatDirection chatTs = case toChatInfo chatDirection of - DirectChat Contact {contactId} -> - DB.execute - db - "UPDATE contacts SET chat_ts = ? WHERE user_id = ? AND contact_id = ?" - (chatTs, userId, contactId) - GroupChat GroupInfo {groupId} -> - DB.execute - db - "UPDATE groups SET chat_ts = ? WHERE user_id = ? AND group_id = ?" - (chatTs, userId, groupId) - _ -> pure () - -createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> Maybe CITimed -> Bool -> UTCTime -> IO ChatItemId -createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciContent quotedItem timed live createdAt = - createNewChatItem_ db user chatDirection createdByMsgId (Just sharedMsgId) ciContent quoteRow timed live createdAt createdAt - 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) - -createNewRcvChatItem :: DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c)) -createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent} sharedMsgId_ ciContent timed live itemTs createdAt = do - ciId <- createNewChatItem_ db user chatDirection (Just msgId) sharedMsgId_ ciContent quoteRow timed live itemTs createdAt - quotedItem <- mapM (getChatItemQuote_ db user chatDirection) quotedMsg - pure (ciId, quotedItem) - where - 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) - CDGroupRcv GroupInfo {membership = GroupMember {memberId = userMemberId}} _ -> - (Just $ Just userMemberId == memberId, memberId) - -createNewChatItemNoMsg :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> CIContent d -> UTCTime -> UTCTime -> IO ChatItemId -createNewChatItemNoMsg db user chatDirection ciContent = - createNewChatItem_ db user chatDirection Nothing Nothing ciContent quoteRow Nothing False - where - quoteRow :: NewQuoteRow - quoteRow = (Nothing, Nothing, Nothing, Nothing, Nothing) - -createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CITimed -> Bool -> UTCTime -> UTCTime -> IO ChatItemId -createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent quoteRow timed live itemTs createdAt = do - DB.execute - db - [sql| - INSERT INTO chat_items ( - -- user and IDs - user_id, created_by_msg_id, contact_id, group_id, group_member_id, - -- meta - item_sent, item_ts, item_content, item_text, item_status, shared_msg_id, created_at, updated_at, item_live, timed_ttl, timed_delete_at, - -- quote - quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id - ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) - |] - ((userId, msgId_) :. idsRow :. itemRow :. quoteRow) - ciId <- insertedRowId db - forM_ msgId_ $ \msgId -> insertChatItemMessage_ db ciId msgId createdAt - pure ciId - where - itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, CIStatus d, Maybe SharedMsgId) :. (UTCTime, UTCTime, Maybe Bool) :. (Maybe Int, Maybe UTCTime) - itemRow = (msgDirection @d, itemTs, ciContent, ciContentToText ciContent, ciCreateStatus ciContent, sharedMsgId) :. (createdAt, createdAt, justTrue live) :. ciTimedRow timed - idsRow :: (Maybe Int64, Maybe Int64, Maybe Int64) - idsRow = case chatDirection of - CDDirectRcv Contact {contactId} -> (Just contactId, Nothing, Nothing) - CDDirectSnd Contact {contactId} -> (Just contactId, Nothing, Nothing) - CDGroupRcv GroupInfo {groupId} GroupMember {groupMemberId} -> (Nothing, Just groupId, Just groupMemberId) - CDGroupSnd GroupInfo {groupId} -> (Nothing, Just groupId, Nothing) - -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) - -getChatItemQuote_ :: DB.Connection -> User -> ChatDirection c 'MDRcv -> QuotedMsg -> IO (CIQuote c) -getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRef = MsgRef {msgId, sentAt, sent, memberId}, content} = - case chatDirection of - CDDirectRcv Contact {contactId} -> getDirectChatItemQuote_ contactId (not sent) - CDGroupRcv GroupInfo {groupId, membership = GroupMember {memberId = userMemberId}} sender@GroupMember {memberId = senderMemberId} -> - case memberId of - Just mId - | mId == userMemberId -> (`ciQuote` CIQGroupSnd) <$> getUserGroupChatItemId_ groupId - | mId == senderMemberId -> (`ciQuote` CIQGroupRcv (Just sender)) <$> getGroupChatItemId_ groupId mId - | 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 = ?" - (userId, contactId, msgId, userSent) - 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) - getGroupChatItemId_ :: Int64 -> MemberId -> IO (Maybe ChatItemId) - getGroupChatItemId_ groupId mId = - 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 = ?" - (userId, groupId, msgId, MDRcv, mId) - getGroupChatItemQuote_ :: Int64 -> MemberId -> IO (CIQuote 'CTGroup) - getGroupChatItemQuote_ groupId mId = do - ciQuoteGroup - <$> DB.queryNamed - db - [sql| - SELECT i.chat_item_id, - -- GroupMember - m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, - m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, - p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences - 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 - LEFT JOIN chat_items i ON i.group_id = m.group_id - AND m.group_member_id = i.group_member_id - AND i.shared_msg_id = :msg_id - WHERE m.user_id = :user_id AND m.group_id = :group_id AND m.member_id = :member_id - |] - [":user_id" := userId, ":group_id" := groupId, ":member_id" := mId, ":msg_id" := msgId] - where - ciQuoteGroup :: [Only (Maybe ChatItemId) :. GroupMemberRow] -> CIQuote 'CTGroup - ciQuoteGroup [] = ciQuote Nothing $ CIQGroupRcv Nothing - ciQuoteGroup ((Only itemId :. memberRow) : _) = ciQuote itemId . CIQGroupRcv . Just $ toGroupMember userContactId memberRow - -getChatPreviews :: DB.Connection -> User -> Bool -> IO [AChat] -getChatPreviews db user withPCC = do - directChats <- getDirectChatPreviews_ db user - groupChats <- getGroupChatPreviews_ db user - cReqChats <- getContactRequestChatPreviews_ db user - connChats <- getContactConnectionChatPreviews_ db user withPCC - pure $ sortOn (Down . ts) (directChats <> groupChats <> cReqChats <> connChats) - where - ts :: AChat -> UTCTime - ts (AChat _ Chat {chatInfo, chatItems}) = case chatInfoChatTs chatInfo of - Just chatTs -> chatTs - Nothing -> case chatItems of - ci : _ -> max (chatItemTs ci) (chatInfoUpdatedAt chatInfo) - _ -> chatInfoUpdatedAt chatInfo - -getDirectChatPreviews_ :: DB.Connection -> User -> IO [AChat] -getDirectChatPreviews_ db user@User {userId} = do - currentTs <- getCurrentTime - map (toDirectChatPreview currentTs) - <$> DB.query - db - [sql| - SELECT - -- Contact - ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, - cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, - -- Connection - c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias, - c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter, - -- ChatStats - COALESCE(ChatStats.UnreadCount, 0), COALESCE(ChatStats.MinUnread, 0), ct.unread_chat, - -- ChatItem - i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, - -- CIFile - f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, - -- DirectQuote - ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent - FROM contacts ct - JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id - JOIN connections c ON c.contact_id = ct.contact_id - LEFT JOIN ( - SELECT contact_id, MAX(chat_item_id) AS MaxId - FROM chat_items - GROUP BY contact_id - ) MaxIds ON MaxIds.contact_id = ct.contact_id - LEFT JOIN chat_items i ON i.contact_id = MaxIds.contact_id - AND i.chat_item_id = MaxIds.MaxId - LEFT JOIN files f ON f.chat_item_id = i.chat_item_id - LEFT JOIN ( - SELECT contact_id, COUNT(1) AS UnreadCount, MIN(chat_item_id) AS MinUnread - FROM chat_items - WHERE item_status = ? - GROUP BY contact_id - ) ChatStats ON ChatStats.contact_id = ct.contact_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 ct.user_id = ? - AND ((c.conn_level = 0 AND c.via_group_link = 0) OR ct.contact_used = 1) - AND ct.deleted = 0 - AND c.connection_id = ( - SELECT cc_connection_id FROM ( - SELECT - cc.connection_id AS cc_connection_id, - (CASE WHEN cc.conn_status = ? OR cc.conn_status = ? THEN 1 ELSE 0 END) AS cc_conn_status_ord - FROM connections cc - WHERE cc.user_id = ct.user_id AND cc.contact_id = ct.contact_id - ORDER BY cc_conn_status_ord DESC, cc_connection_id DESC - LIMIT 1 - ) - ) - ORDER BY i.item_ts DESC - |] - (CISRcvNew, userId, ConnReady, ConnSndReady) - where - toDirectChatPreview :: UTCTime -> ContactRow :. ConnectionRow :. ChatStatsRow :. MaybeChatItemRow :. QuoteRow -> AChat - toDirectChatPreview currentTs (contactRow :. connRow :. statsRow :. ciRow_) = - let contact = toContact user $ contactRow :. connRow - ci_ = toDirectChatItemList currentTs ciRow_ - stats = toChatStats statsRow - in AChat SCTDirect $ Chat (DirectChat contact) ci_ stats - -getGroupChatPreviews_ :: DB.Connection -> User -> IO [AChat] -getGroupChatPreviews_ db User {userId, userContactId} = do - currentTs <- getCurrentTime - map (toGroupChatPreview currentTs) - <$> DB.query - db - [sql| - SELECT - -- GroupInfo - g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, - -- GroupMember - membership - mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, - mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, - pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences, - -- ChatStats - COALESCE(ChatStats.UnreadCount, 0), COALESCE(ChatStats.MinUnread, 0), g.unread_chat, - -- ChatItem - i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, - -- CIFile - f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, - -- Maybe GroupMember - sender - m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, - m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, - p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, - -- quoted ChatItem - ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent, - -- quoted GroupMember - rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category, - rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id, - rp.display_name, rp.full_name, rp.image, rp.contact_link, rp.local_alias, rp.preferences, - -- deleted by GroupMember - dbm.group_member_id, dbm.group_id, dbm.member_id, dbm.member_role, dbm.member_category, - dbm.member_status, dbm.invited_by, dbm.local_display_name, dbm.contact_id, dbm.contact_profile_id, dbp.contact_profile_id, - dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.preferences - FROM groups g - JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id - JOIN group_members mu ON mu.group_id = g.group_id - JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) - LEFT JOIN ( - SELECT group_id, MAX(chat_item_id) AS MaxId - FROM chat_items - GROUP BY group_id - ) MaxIds ON MaxIds.group_id = g.group_id - LEFT JOIN chat_items i ON i.group_id = MaxIds.group_id - AND i.chat_item_id = MaxIds.MaxId - LEFT JOIN files f ON f.chat_item_id = i.chat_item_id - LEFT JOIN ( - SELECT group_id, COUNT(1) AS UnreadCount, MIN(chat_item_id) AS MinUnread - FROM chat_items - WHERE item_status = ? - GROUP BY group_id - ) ChatStats ON ChatStats.group_id = g.group_id - 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 g.user_id = ? AND mu.contact_id = ? - ORDER BY i.item_ts DESC - |] - (CISRcvNew, userId, userContactId) - where - toGroupChatPreview :: UTCTime -> GroupInfoRow :. ChatStatsRow :. MaybeGroupChatItemRow -> AChat - toGroupChatPreview currentTs (groupInfoRow :. statsRow :. ciRow_) = - let groupInfo = toGroupInfo userContactId groupInfoRow - ci_ = toGroupChatItemList currentTs userContactId ciRow_ - stats = toChatStats statsRow - in AChat SCTGroup $ Chat (GroupChat groupInfo) ci_ stats - -getContactRequestChatPreviews_ :: DB.Connection -> User -> IO [AChat] -getContactRequestChatPreviews_ db User {userId} = - map toContactRequestChatPreview - <$> DB.query - db - [sql| - SELECT - cr.contact_request_id, cr.local_display_name, cr.agent_invitation_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, p.preferences, cr.created_at, cr.updated_at - 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 - |] - (userId, userId) - where - toContactRequestChatPreview :: ContactRequestRow -> AChat - toContactRequestChatPreview cReqRow = - let cReq = toContactRequest cReqRow - stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} - in AChat SCTContactRequest $ Chat (ContactRequest cReq) [] stats - -getContactConnectionChatPreviews_ :: DB.Connection -> User -> Bool -> IO [AChat] -getContactConnectionChatPreviews_ _ _ False = pure [] -getContactConnectionChatPreviews_ db User {userId} _ = - map toContactConnectionChatPreview - <$> DB.query - db - [sql| - SELECT connection_id, agent_conn_id, conn_status, via_contact_uri_hash, via_user_contact_link, group_link_id, custom_user_profile_id, conn_req_inv, local_alias, created_at, updated_at - FROM connections - WHERE user_id = ? AND conn_type = ? AND contact_id IS NULL AND conn_level = 0 AND via_contact IS NULL AND (via_group_link = 0 || (via_group_link = 1 AND group_link_id IS NOT NULL)) - |] - (userId, ConnContact) - where - toContactConnectionChatPreview :: (Int64, ConnId, ConnStatus, Maybe ByteString, Maybe Int64, Maybe GroupLinkId, Maybe Int64, Maybe ConnReqInvitation, LocalAlias, UTCTime, UTCTime) -> AChat - toContactConnectionChatPreview connRow = - let conn = toPendingContactConnection connRow - stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} - in AChat SCTContactConnection $ Chat (ContactConnection conn) [] stats - -getPendingContactConnection :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO PendingContactConnection -getPendingContactConnection db userId connId = do - ExceptT . firstRow toPendingContactConnection (SEPendingConnectionNotFound connId) $ - DB.query - db - [sql| - SELECT connection_id, agent_conn_id, conn_status, via_contact_uri_hash, via_user_contact_link, group_link_id, custom_user_profile_id, conn_req_inv, local_alias, created_at, updated_at - FROM connections - WHERE user_id = ? - AND connection_id = ? - AND conn_type = ? - AND contact_id IS NULL - AND conn_level = 0 - AND via_contact IS NULL - |] - (userId, connId, ConnContact) - -deletePendingContactConnection :: DB.Connection -> UserId -> Int64 -> IO () -deletePendingContactConnection db userId connId = - DB.execute - db - [sql| - DELETE FROM connections - WHERE user_id = ? - AND connection_id = ? - AND conn_type = ? - AND contact_id IS NULL - AND conn_level = 0 - AND via_contact IS NULL - |] - (userId, connId, ConnContact) - -updateContactSettings :: DB.Connection -> User -> Int64 -> ChatSettings -> IO () -updateContactSettings db User {userId} contactId ChatSettings {enableNtfs} = - DB.execute db "UPDATE contacts SET enable_ntfs = ? WHERE user_id = ? AND contact_id = ?" (enableNtfs, userId, contactId) - -updateGroupSettings :: DB.Connection -> User -> Int64 -> ChatSettings -> IO () -updateGroupSettings db User {userId} groupId ChatSettings {enableNtfs} = - DB.execute db "UPDATE groups SET enable_ntfs = ? WHERE user_id = ? AND group_id = ?" (enableNtfs, userId, groupId) - -toPendingContactConnection :: (Int64, ConnId, ConnStatus, Maybe ByteString, Maybe Int64, Maybe GroupLinkId, Maybe Int64, Maybe ConnReqInvitation, LocalAlias, UTCTime, UTCTime) -> PendingContactConnection -toPendingContactConnection (pccConnId, acId, pccConnStatus, connReqHash, viaUserContactLink, groupLinkId, customUserProfileId, connReqInv, localAlias, createdAt, updatedAt) = - PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = isJust connReqHash, viaUserContactLink, groupLinkId, customUserProfileId, connReqInv, localAlias, createdAt, updatedAt} - -getDirectChat :: DB.Connection -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTDirect) -getDirectChat db user contactId pagination search_ = do - let search = fromMaybe "" search_ - ct <- getContact db user contactId - liftIO . getDirectChatReactions_ db ct =<< case pagination of - CPLast count -> getDirectChatLast_ db user ct count search - CPAfter afterId count -> getDirectChatAfter_ db user ct afterId count search - CPBefore beforeId count -> getDirectChatBefore_ db user ct beforeId count search - -getDirectChatLast_ :: DB.Connection -> User -> Contact -> Int -> String -> ExceptT StoreError IO (Chat 'CTDirect) -getDirectChatLast_ db user ct@Contact {contactId} count search = do - let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} - chatItems <- getDirectChatItemsLast db user contactId count search - pure $ Chat (DirectChat ct) (reverse chatItems) stats - --- the last items in reverse order (the last item in the conversation is the first in the returned list) -getDirectChatItemsLast :: DB.Connection -> User -> ContactId -> Int -> String -> ExceptT StoreError IO [CChatItem 'CTDirect] -getDirectChatItemsLast db User {userId} contactId count search = ExceptT $ do - currentTs <- getCurrentTime - mapM (toDirectChatItem currentTs) - <$> DB.query - db - [sql| - SELECT - -- ChatItem - i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, - -- CIFile - f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, - -- 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.item_text LIKE '%' || ? || '%' - ORDER BY i.chat_item_id DESC - LIMIT ? - |] - (userId, contactId, search, count) - -getDirectChatAfter_ :: DB.Connection -> User -> Contact -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTDirect) -getDirectChatAfter_ db User {userId} ct@Contact {contactId} afterChatItemId count search = do - let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} - chatItems <- ExceptT getDirectChatItemsAfter_ - pure $ Chat (DirectChat ct) chatItems stats - where - getDirectChatItemsAfter_ :: IO (Either StoreError [CChatItem 'CTDirect]) - getDirectChatItemsAfter_ = do - currentTs <- getCurrentTime - mapM (toDirectChatItem currentTs) - <$> DB.query - db - [sql| - SELECT - -- ChatItem - i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, - -- CIFile - f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, - -- 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.item_text LIKE '%' || ? || '%' - AND i.chat_item_id > ? - ORDER BY i.chat_item_id ASC - LIMIT ? - |] - (userId, contactId, search, afterChatItemId, count) - -getDirectChatBefore_ :: DB.Connection -> User -> Contact -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTDirect) -getDirectChatBefore_ db User {userId} ct@Contact {contactId} beforeChatItemId count search = do - let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} - chatItems <- ExceptT getDirectChatItemsBefore_ - pure $ Chat (DirectChat ct) (reverse chatItems) stats - where - getDirectChatItemsBefore_ :: IO (Either StoreError [CChatItem 'CTDirect]) - getDirectChatItemsBefore_ = do - currentTs <- getCurrentTime - mapM (toDirectChatItem currentTs) - <$> DB.query - db - [sql| - SELECT - -- ChatItem - i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, - -- CIFile - f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, - -- 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.item_text LIKE '%' || ? || '%' - AND i.chat_item_id < ? - ORDER BY i.chat_item_id DESC - LIMIT ? - |] - (userId, contactId, search, beforeChatItemId, count) - -getContactIdByName :: DB.Connection -> User -> ContactName -> ExceptT StoreError IO Int64 -getContactIdByName db User {userId} cName = - ExceptT . firstRow fromOnly (SEContactNotFoundByName cName) $ - DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND local_display_name = ? AND deleted = 0" (userId, cName) - -getContact :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO Contact -getContact db user contactId = getContact_ db user contactId False - -getContact_ :: DB.Connection -> User -> Int64 -> Bool -> ExceptT StoreError IO Contact -getContact_ db user@User {userId} contactId deleted = - ExceptT . fmap join . firstRow (toContactOrError user) (SEContactNotFound contactId) $ - DB.query - db - [sql| - SELECT - -- Contact - ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, - cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, - -- Connection - c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias, - c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter - FROM contacts ct - JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id - LEFT JOIN connections c ON c.contact_id = ct.contact_id - WHERE ct.user_id = ? AND ct.contact_id = ? - AND ct.deleted = ? - AND c.connection_id = ( - SELECT cc_connection_id FROM ( - SELECT - cc.connection_id AS cc_connection_id, - (CASE WHEN cc.conn_status = ? OR cc.conn_status = ? THEN 1 ELSE 0 END) AS cc_conn_status_ord - FROM connections cc - WHERE cc.user_id = ct.user_id AND cc.contact_id = ct.contact_id - ORDER BY cc_conn_status_ord DESC, cc_connection_id DESC - LIMIT 1 - ) - ) - |] - (userId, contactId, deleted, ConnReady, ConnSndReady) - -getGroupChat :: DB.Connection -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTGroup) -getGroupChat db user groupId pagination search_ = do - let search = fromMaybe "" search_ - g <- getGroupInfo db user groupId - liftIO . getGroupChatReactions_ db g =<< case pagination of - CPLast count -> getGroupChatLast_ db user g count search - CPAfter afterId count -> getGroupChatAfter_ db user g afterId count search - CPBefore beforeId count -> getGroupChatBefore_ db user g beforeId count search - -getGroupChatLast_ :: DB.Connection -> User -> GroupInfo -> Int -> String -> ExceptT StoreError IO (Chat 'CTGroup) -getGroupChatLast_ db user@User {userId} g@GroupInfo {groupId} count search = do - let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} - chatItemIds <- liftIO getGroupChatItemIdsLast_ - chatItems <- mapM (getGroupChatItem db user groupId) chatItemIds - pure $ Chat (GroupChat g) (reverse chatItems) stats - where - getGroupChatItemIdsLast_ :: IO [ChatItemId] - getGroupChatItemIdsLast_ = - map fromOnly - <$> DB.query - db - [sql| - SELECT chat_item_id - FROM chat_items - WHERE user_id = ? AND group_id = ? AND item_text LIKE '%' || ? || '%' - ORDER BY item_ts DESC, chat_item_id DESC - LIMIT ? - |] - (userId, groupId, search, count) - -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 - -getGroupChatAfter_ :: DB.Connection -> User -> GroupInfo -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTGroup) -getGroupChatAfter_ db user@User {userId} g@GroupInfo {groupId} afterChatItemId count search = do - let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} - afterChatItem <- getGroupChatItem db user groupId afterChatItemId - chatItemIds <- liftIO $ getGroupChatItemIdsAfter_ (chatItemTs afterChatItem) - chatItems <- mapM (getGroupChatItem db user groupId) chatItemIds - pure $ Chat (GroupChat g) chatItems stats - where - getGroupChatItemIdsAfter_ :: UTCTime -> IO [ChatItemId] - getGroupChatItemIdsAfter_ afterChatItemTs = - map fromOnly - <$> DB.query - db - [sql| - SELECT chat_item_id - FROM chat_items - WHERE user_id = ? AND group_id = ? AND item_text LIKE '%' || ? || '%' - AND (item_ts > ? OR (item_ts = ? AND chat_item_id > ?)) - ORDER BY item_ts ASC, chat_item_id ASC - LIMIT ? - |] - (userId, groupId, search, afterChatItemTs, afterChatItemTs, afterChatItemId, count) - -getGroupChatBefore_ :: DB.Connection -> User -> GroupInfo -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTGroup) -getGroupChatBefore_ db user@User {userId} g@GroupInfo {groupId} beforeChatItemId count search = do - let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} - beforeChatItem <- getGroupChatItem db user groupId beforeChatItemId - chatItemIds <- liftIO $ getGroupChatItemIdsBefore_ (chatItemTs beforeChatItem) - chatItems <- mapM (getGroupChatItem db user groupId) chatItemIds - pure $ Chat (GroupChat g) (reverse chatItems) stats - where - getGroupChatItemIdsBefore_ :: UTCTime -> IO [ChatItemId] - getGroupChatItemIdsBefore_ beforeChatItemTs = - map fromOnly - <$> DB.query - db - [sql| - SELECT chat_item_id - FROM chat_items - WHERE user_id = ? AND group_id = ? AND item_text LIKE '%' || ? || '%' - AND (item_ts < ? OR (item_ts = ? AND chat_item_id < ?)) - ORDER BY item_ts DESC, chat_item_id DESC - LIMIT ? - |] - (userId, groupId, search, beforeChatItemTs, beforeChatItemTs, beforeChatItemId, count) - -getGroupInfo :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO GroupInfo -getGroupInfo db User {userId, userContactId} groupId = - ExceptT . firstRow (toGroupInfo userContactId) (SEGroupNotFound groupId) $ - DB.query - db - [sql| - SELECT - -- GroupInfo - g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, - -- GroupMember - membership - mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, - mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, - pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences - FROM groups g - JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id - JOIN group_members mu ON mu.group_id = g.group_id - JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) - WHERE g.group_id = ? AND g.user_id = ? AND mu.contact_id = ? - |] - (groupId, userId, userContactId) - -updateGroupProfile :: DB.Connection -> User -> GroupInfo -> GroupProfile -> ExceptT StoreError IO GroupInfo -updateGroupProfile db User {userId} g@GroupInfo {groupId, localDisplayName, groupProfile = GroupProfile {displayName}} p'@GroupProfile {displayName = newName, fullName, description, image, groupPreferences} - | displayName == newName = liftIO $ do - currentTs <- getCurrentTime - updateGroupProfile_ currentTs - pure (g :: GroupInfo) {groupProfile = p', fullGroupPreferences} - | otherwise = - ExceptT . withLocalDisplayName db userId newName $ \ldn -> do - currentTs <- getCurrentTime - updateGroupProfile_ currentTs - updateGroup_ ldn currentTs - pure $ Right (g :: GroupInfo) {localDisplayName = ldn, groupProfile = p', fullGroupPreferences} - where - fullGroupPreferences = mergeGroupPreferences groupPreferences - updateGroupProfile_ currentTs = - DB.execute - db - [sql| - UPDATE group_profiles - SET display_name = ?, full_name = ?, description = ?, image = ?, preferences = ?, updated_at = ? - WHERE group_profile_id IN ( - SELECT group_profile_id - FROM groups - WHERE user_id = ? AND group_id = ? - ) - |] - (newName, fullName, description, image, groupPreferences, currentTs, userId, groupId) - updateGroup_ ldn currentTs = do - DB.execute - db - "UPDATE groups SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND group_id = ?" - (ldn, currentTs, userId, groupId) - DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (localDisplayName, userId) - -getAllChatItems :: DB.Connection -> User -> ChatPagination -> Maybe String -> ExceptT StoreError IO [AChatItem] -getAllChatItems db user@User {userId} pagination search_ = do - 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 - mapM (uncurry (getAChatItem db user) >=> liftIO . getACIReactions db) itemRefs - where - search = fromMaybe "" search_ - getAChatItem_ itemId = do - chatRef <- getChatRefViaItemId db user itemId - getAChatItem db user chatRef itemId - getAllChatItemsLast_ count = - reverse - <$> DB.query - db - [sql| - SELECT chat_item_id, contact_id, group_id - FROM chat_items - WHERE user_id = ? AND item_text LIKE '%' || ? || '%' - ORDER BY item_ts DESC, chat_item_id DESC - LIMIT ? - |] - (userId, search, count) - getAllChatItemsAfter_ afterId count afterTs = - DB.query - db - [sql| - SELECT chat_item_id, contact_id, group_id - FROM chat_items - WHERE user_id = ? AND item_text LIKE '%' || ? || '%' - 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| - SELECT chat_item_id, contact_id, group_id - FROM chat_items - WHERE user_id = ? AND item_text LIKE '%' || ? || '%' - 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) - -getGroupIdByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupId -getGroupIdByName db User {userId} gName = - ExceptT . firstRow fromOnly (SEGroupNotFoundByName gName) $ - DB.query db "SELECT group_id FROM groups WHERE user_id = ? AND local_display_name = ?" (userId, gName) - -getGroupMemberIdByName :: DB.Connection -> User -> GroupId -> ContactName -> ExceptT StoreError IO GroupMemberId -getGroupMemberIdByName db User {userId} groupId groupMemberName = - ExceptT . firstRow fromOnly (SEGroupMemberNameNotFound groupId groupMemberName) $ - DB.query db "SELECT group_member_id FROM group_members WHERE user_id = ? AND group_id = ? AND local_display_name = ?" (userId, groupId, groupMemberName) - -getChatItemIdByAgentMsgId :: DB.Connection -> Int64 -> AgentMsgId -> IO (Maybe ChatItemId) -getChatItemIdByAgentMsgId db connId msgId = - fmap join . maybeFirstRow fromOnly $ - DB.query - db - [sql| - SELECT chat_item_id - FROM chat_item_messages - WHERE message_id = ( - SELECT message_id - FROM msg_deliveries - WHERE connection_id = ? AND agent_msg_id = ? - LIMIT 1 - ) - |] - (connId, msgId) - -updateDirectChatItemStatus :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItemId -> CIStatus d -> ExceptT StoreError IO (ChatItem 'CTDirect d) -updateDirectChatItemStatus db user@User {userId} contactId itemId itemStatus = do - ci <- liftEither . correctDir =<< getDirectChatItem db user contactId itemId - currentTs <- liftIO getCurrentTime - liftIO $ DB.execute db "UPDATE chat_items SET item_status = ?, updated_at = ? WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?" (itemStatus, currentTs, userId, contactId, itemId) - pure ci {meta = (meta ci) {itemStatus}} - where - correctDir :: CChatItem c -> Either StoreError (ChatItem c d) - correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci - -updateDirectChatItem :: forall d. (MsgDirectionI d) => DB.Connection -> User -> Int64 -> ChatItemId -> CIContent d -> Bool -> Maybe MessageId -> ExceptT StoreError IO (ChatItem 'CTDirect d) -updateDirectChatItem db user contactId itemId newContent live msgId_ = do - ci <- liftEither . correctDir =<< getDirectChatItem db user contactId itemId - liftIO $ updateDirectChatItem' db user contactId ci newContent live msgId_ - where - correctDir :: CChatItem c -> Either StoreError (ChatItem c d) - correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci - -updateDirectChatItem' :: forall d. (MsgDirectionI d) => DB.Connection -> User -> Int64 -> ChatItem 'CTDirect d -> CIContent d -> Bool -> Maybe MessageId -> IO (ChatItem 'CTDirect d) -updateDirectChatItem' db User {userId} contactId ci newContent live msgId_ = do - currentTs <- liftIO getCurrentTime - let ci' = updatedChatItem ci newContent live currentTs - liftIO $ updateDirectChatItem_ db userId contactId ci' msgId_ - pure ci' - -updatedChatItem :: ChatItem c d -> CIContent d -> Bool -> UTCTime -> ChatItem c d -updatedChatItem ci@ChatItem {meta = meta@CIMeta {itemStatus, itemEdited, itemTimed, itemLive}} newContent live currentTs = - let newText = ciContentToText newContent - edited' = itemEdited || (itemLive /= Just True) - live' = (live &&) <$> itemLive - timed' = 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 - 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 = ? - |] - ((content, itemText, itemStatus, itemDeleted', itemDeletedTs', itemEdited, itemLive, updatedAt) :. ciTimedRow itemTimed :. (userId, contactId, itemId)) - 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 (?,?,?) - |] - (itemId, toMCText msgContent, itemVersionTs) - -deleteDirectChatItem :: DB.Connection -> User -> Contact -> CChatItem 'CTDirect -> IO () -deleteDirectChatItem db User {userId} Contact {contactId} (CChatItem _ ci) = do - 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 () -deleteChatItemMessages_ db itemId = - DB.execute - db - [sql| - DELETE FROM messages - WHERE message_id IN ( - SELECT message_id - FROM chat_item_messages - WHERE chat_item_id = ? - ) - |] - (Only itemId) - -deleteChatItemVersions_ :: DB.Connection -> ChatItemId -> IO () -deleteChatItemVersions_ db itemId = - DB.execute db "DELETE FROM chat_item_versions WHERE chat_item_id = ?" (Only itemId) - -markDirectChatItemDeleted :: DB.Connection -> User -> Contact -> CChatItem 'CTDirect -> MessageId -> UTCTime -> IO () -markDirectChatItemDeleted db User {userId} Contact {contactId} (CChatItem _ ci) msgId deletedTs = do - currentTs <- liftIO getCurrentTime - let itemId = chatItemId' ci - insertChatItemMessage_ db itemId msgId currentTs - DB.execute - db - [sql| - UPDATE chat_items - SET item_deleted = 1, item_deleted_ts = ?, updated_at = ? - WHERE user_id = ? AND contact_id = ? AND chat_item_id = ? - |] - (deletedTs, currentTs, userId, contactId, itemId) - -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 - -getDirectChatItemByAgentMsgId :: DB.Connection -> User -> ContactId -> Int64 -> AgentMsgId -> IO (Maybe (CChatItem 'CTDirect)) -getDirectChatItemByAgentMsgId db user contactId connId msgId = do - itemId_ <- getChatItemIdByAgentMsgId db connId msgId - maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getDirectChatItem db user contactId) itemId_ - -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 - join <$> firstRow (toDirectChatItem currentTs) (SEChatItemNotFound itemId) getItem - where - getItem = - DB.query - db - [sql| - SELECT - -- ChatItem - i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, - -- CIFile - f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, - -- 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 <> "%") - -updateGroupChatItem :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItem 'CTGroup d -> CIContent d -> Bool -> Maybe MessageId -> IO (ChatItem 'CTGroup d) -updateGroupChatItem db user groupId ci newContent live msgId_ = do - currentTs <- liftIO getCurrentTime - let ci' = updatedChatItem ci newContent live currentTs - 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 -updateGroupChatItem_ :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItem 'CTGroup d -> Maybe MessageId -> IO () -updateGroupChatItem_ db User {userId} groupId ChatItem {content, meta} msgId_ = do - let CIMeta {itemId, itemText, itemStatus, itemDeleted, itemEdited, itemTimed, itemLive, updatedAt} = meta - itemDeleted' = isJust itemDeleted - 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 = ? - |] - ((content, itemText, itemStatus, itemDeleted', itemDeletedTs', itemEdited, itemLive, updatedAt) :. ciTimedRow itemTimed :. (userId, groupId, itemId)) - forM_ msgId_ $ \msgId -> insertChatItemMessage_ db itemId msgId updatedAt - -deleteGroupChatItem :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> IO () -deleteGroupChatItem db User {userId} g@GroupInfo {groupId} (CChatItem _ ci) = do - 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) - -updateGroupChatItemModerated :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> GroupMember -> UTCTime -> IO AChatItem -updateGroupChatItemModerated db User {userId} gInfo@GroupInfo {groupId} (CChatItem msgDir ci) m@GroupMember {groupMemberId} deletedTs = do - currentTs <- getCurrentTime - let toContent = msgDirToModeratedContent_ msgDir - 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) - pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) (ci {content = toContent, meta = (meta ci) {itemText = toText, itemDeleted = Just (CIModerated (Just currentTs) m)}, formattedText = Nothing}) - -markGroupChatItemDeleted :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> MessageId -> Maybe GroupMember -> UTCTime -> IO () -markGroupChatItemDeleted db User {userId} GroupInfo {groupId} (CChatItem _ ci) msgId byGroupMember_ deletedTs = do - currentTs <- liftIO getCurrentTime - let itemId = chatItemId' ci - deletedByGroupMemberId = case byGroupMember_ of - Just GroupMember {groupMemberId} -> Just groupMemberId - _ -> Nothing - insertChatItemMessage_ db itemId msgId currentTs - DB.execute - db - [sql| - UPDATE chat_items - SET item_deleted = 1, item_deleted_ts = ?, item_deleted_by_group_member_id = ?, updated_at = ? - WHERE user_id = ? AND group_id = ? AND chat_item_id = ? - |] - (deletedTs, deletedByGroupMemberId, currentTs, userId, groupId, itemId) - -getGroupChatItemBySharedMsgId :: DB.Connection -> User -> GroupId -> GroupMemberId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTGroup) -getGroupChatItemBySharedMsgId db user@User {userId} groupId groupMemberId sharedMsgId = do - 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) - getGroupChatItem db user groupId itemId - -getGroupMemberCIBySharedMsgId :: DB.Connection -> User -> GroupId -> MemberId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTGroup) -getGroupMemberCIBySharedMsgId db user@User {userId} groupId memberId sharedMsgId = do - 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) - getGroupChatItem db user groupId itemId - -getGroupChatItem :: DB.Connection -> User -> Int64 -> ChatItemId -> ExceptT StoreError IO (CChatItem 'CTGroup) -getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do - currentTs <- getCurrentTime - join <$> firstRow (toGroupChatItem currentTs userContactId) (SEChatItemNotFound itemId) getItem - where - getItem = - DB.query - db - [sql| - SELECT - -- ChatItem - i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, - -- CIFile - f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, - -- GroupMember - m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, - m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, - p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, - -- quoted ChatItem - ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent, - -- quoted GroupMember - rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category, - rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id, - rp.display_name, rp.full_name, rp.image, rp.contact_link, rp.local_alias, rp.preferences, - -- deleted by GroupMember - dbm.group_member_id, dbm.group_id, dbm.member_id, dbm.member_role, dbm.member_category, - dbm.member_status, dbm.invited_by, dbm.local_display_name, dbm.contact_id, dbm.contact_profile_id, dbp.contact_profile_id, - dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.preferences - FROM chat_items i - LEFT JOIN files f ON f.chat_item_id = i.chat_item_id - 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 - JOIN contacts c ON c.contact_id = m.contact_id - WHERE i.user_id = ? AND i.group_id = ? AND c.local_display_name = ? AND i.item_text like ? - 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 <> "%") - -getChatItemByFileId :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO AChatItem -getChatItemByFileId db user@User {userId} fileId = do - (chatRef, itemId) <- - ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByFileId fileId) $ - DB.query - db - [sql| - SELECT i.chat_item_id, i.contact_id, i.group_id - 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) - getAChatItem db user chatRef itemId - -getChatItemByGroupId :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO AChatItem -getChatItemByGroupId db user@User {userId} groupId = do - (chatRef, itemId) <- - ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByGroupId groupId) $ - DB.query - db - [sql| - SELECT i.chat_item_id, i.contact_id, i.group_id - 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) - getAChatItem db user chatRef itemId - -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 - (Just contactId, Nothing) -> Right $ ChatRef CTDirect contactId - (Nothing, Just groupId) -> Right $ ChatRef CTGroup groupId - (_, _) -> Left $ SEBadChatItem itemId - -getAChatItem :: DB.Connection -> User -> ChatRef -> ChatItemId -> ExceptT StoreError IO AChatItem -getAChatItem db user chatRef itemId = case chatRef of - ChatRef CTDirect contactId -> do - ct <- getContact db user contactId - (CChatItem msgDir ci) <- getDirectChatItem db user contactId itemId - pure $ AChatItem SCTDirect msgDir (DirectChat ct) ci - ChatRef CTGroup groupId -> do - gInfo <- getGroupInfo db user groupId - (CChatItem msgDir ci) <- getGroupChatItem db user groupId itemId - pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) ci - _ -> throwError $ SEChatItemNotFound itemId - -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} - -getDirectChatReactions_ :: DB.Connection -> Contact -> Chat 'CTDirect -> IO (Chat 'CTDirect) -getDirectChatReactions_ db ct c@Chat {chatItems} = do - chatItems' <- forM chatItems $ \(CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId}}) -> do - reactions <- maybe (pure []) (getDirectCIReactions db ct) itemSharedMsgId - pure $ CChatItem md ci {reactions} - pure c {chatItems = chatItems'} - -getGroupChatReactions_ :: DB.Connection -> GroupInfo -> Chat 'CTGroup -> IO (Chat 'CTGroup) -getGroupChatReactions_ db g c@Chat {chatItems} = do - chatItems' <- forM chatItems $ \(CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId}}) -> do - let GroupMember {memberId} = chatItemMember g ci - reactions <- maybe (pure []) (getGroupCIReactions db g memberId) itemSharedMsgId - pure $ CChatItem md ci {reactions} - pure c {chatItems = chatItems'} - -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) - -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} - GroupChat g -> do - 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) - -toCIReaction :: (MsgReaction, Bool, Int) -> CIReactionCount -toCIReaction (reaction, userReacted, totalReacted) = CIReactionCount {reaction, userReacted, totalReacted} - -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 = ? - |] - (contactId' ct, itemSharedMId, sent) - -setDirectReaction :: DB.Connection -> Contact -> SharedMsgId -> Bool -> MsgReaction -> Bool -> MessageId -> UTCTime -> IO () -setDirectReaction db ct itemSharedMId sent reaction add msgId reactionTs - | add = - DB.execute - db - [sql| - INSERT INTO chat_item_reactions - (contact_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts) - VALUES (?,?,?,?,?,?) - |] - (contactId' ct, itemSharedMId, sent, reaction, msgId, reactionTs) - | otherwise = - DB.execute - db - [sql| - DELETE FROM chat_item_reactions - WHERE contact_id = ? AND shared_msg_id = ? AND reaction_sent = ? AND reaction = ? - |] - (contactId' ct, itemSharedMId, sent, reaction) - -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 = ? - |] - (groupId, groupMemberId' m, itemMemberId, itemSharedMId, sent) - -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 = - 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 (?,?,?,?,?,?,?,?) - |] - (groupId, groupMemberId' m, itemMemberId, itemSharedMId, sent, reaction, msgId, reactionTs) - | otherwise = - 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 = ? - |] - (groupId, groupMemberId' m, itemSharedMId, itemMemberId, sent, reaction) - -updateDirectCIFileStatus :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> ExceptT StoreError IO AChatItem -updateDirectCIFileStatus db user fileId fileStatus = do - aci@(AChatItem cType d cInfo ci) <- getChatItemByFileId db user fileId - case (cType, testEquality d $ msgDirection @d) of - (SCTDirect, Just Refl) -> do - liftIO $ updateCIFileStatus db user fileId fileStatus - pure $ AChatItem SCTDirect d cInfo $ updateFileStatus ci fileStatus - _ -> pure aci - -toChatItemRef :: (ChatItemId, Maybe Int64, Maybe Int64) -> Either StoreError (ChatRef, ChatItemId) -toChatItemRef = \case - (itemId, Just contactId, Nothing) -> Right (ChatRef CTDirect contactId, itemId) - (itemId, Nothing, Just groupId) -> Right (ChatRef CTGroup groupId, itemId) - (itemId, _, _) -> Left $ SEBadChatItem itemId - -updateDirectChatItemsRead :: DB.Connection -> User -> ContactId -> Maybe (ChatItemId, ChatItemId) -> IO () -updateDirectChatItemsRead db User {userId} contactId itemsRange_ = do - currentTs <- getCurrentTime - case itemsRange_ of - Just (fromItemId, toItemId) -> - DB.execute - db - [sql| - UPDATE chat_items SET item_status = ?, updated_at = ? - WHERE user_id = ? AND contact_id = ? AND chat_item_id >= ? AND chat_item_id <= ? AND item_status = ? - |] - (CISRcvRead, currentTs, userId, contactId, fromItemId, toItemId, CISRcvNew) - _ -> - 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) - -getDirectUnreadTimedItems :: DB.Connection -> User -> ContactId -> Maybe (ChatItemId, ChatItemId) -> IO [(ChatItemId, Int)] -getDirectUnreadTimedItems db User {userId} contactId itemsRange_ = case itemsRange_ of - Just (fromItemId, toItemId) -> - DB.query - db - [sql| - SELECT chat_item_id, timed_ttl - FROM chat_items - WHERE user_id = ? AND contact_id = ? - AND chat_item_id >= ? AND chat_item_id <= ? - AND item_status = ? - AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL - AND (item_live IS NULL OR item_live = ?) - |] - (userId, contactId, fromItemId, toItemId, CISRcvNew, False) - _ -> - 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) - -setDirectChatItemDeleteAt :: DB.Connection -> User -> ContactId -> ChatItemId -> UTCTime -> IO () -setDirectChatItemDeleteAt db User {userId} contactId chatItemId deleteAt = - DB.execute - db - "UPDATE chat_items SET timed_delete_at = ? WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?" - (deleteAt, userId, contactId, chatItemId) - -updateGroupChatItemsRead :: DB.Connection -> UserId -> GroupId -> Maybe (ChatItemId, ChatItemId) -> IO () -updateGroupChatItemsRead db userId groupId itemsRange_ = do - currentTs <- getCurrentTime - case itemsRange_ of - Just (fromItemId, toItemId) -> - DB.execute - db - [sql| - UPDATE chat_items SET item_status = ?, updated_at = ? - WHERE user_id = ? AND group_id = ? AND chat_item_id >= ? AND chat_item_id <= ? AND item_status = ? - |] - (CISRcvRead, currentTs, userId, groupId, fromItemId, toItemId, CISRcvNew) - _ -> - 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) - -getGroupUnreadTimedItems :: DB.Connection -> User -> GroupId -> Maybe (ChatItemId, ChatItemId) -> IO [(ChatItemId, Int)] -getGroupUnreadTimedItems db User {userId} groupId itemsRange_ = case itemsRange_ of - Just (fromItemId, toItemId) -> - DB.query - db - [sql| - SELECT chat_item_id, timed_ttl - FROM chat_items - WHERE user_id = ? AND group_id = ? - AND chat_item_id >= ? AND chat_item_id <= ? - AND item_status = ? - AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL - AND (item_live IS NULL OR item_live = ?) - |] - (userId, groupId, fromItemId, toItemId, CISRcvNew, False) - _ -> - 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) - -setGroupChatItemDeleteAt :: DB.Connection -> User -> GroupId -> ChatItemId -> UTCTime -> IO () -setGroupChatItemDeleteAt db User {userId} groupId chatItemId deleteAt = - DB.execute - db - "UPDATE chat_items SET timed_delete_at = ? WHERE user_id = ? AND group_id = ? AND chat_item_id = ?" - (deleteAt, userId, groupId, chatItemId) - -type ChatStatsRow = (Int, ChatItemId, Bool) - -toChatStats :: ChatStatsRow -> ChatStats -toChatStats (unreadCount, minUnreadItemId, unreadChat) = ChatStats {unreadCount, minUnreadItemId, unreadChat} - -type MaybeCIFIleRow = (Maybe Int64, Maybe String, Maybe Integer, Maybe FilePath, Maybe ACIFileStatus, Maybe FileProtocol) - -type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe Bool) - -type ChatItemRow = (Int64, ChatItemTs, AMsgDirection, Text, Text, ACIStatus, Maybe SharedMsgId) :. (Bool, Maybe UTCTime, Maybe Bool, UTCTime, UTCTime) :. ChatItemModeRow :. MaybeCIFIleRow - -type MaybeChatItemRow = (Maybe Int64, Maybe ChatItemTs, Maybe AMsgDirection, Maybe Text, Maybe Text, Maybe ACIStatus, Maybe SharedMsgId) :. (Maybe Bool, Maybe UTCTime, Maybe Bool, Maybe UTCTime, Maybe UTCTime) :. ChatItemModeRow :. MaybeCIFIleRow - -type QuoteRow = (Maybe ChatItemId, Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool) - -toDirectQuote :: QuoteRow -> Maybe (CIQuote 'CTDirect) -toDirectQuote qr@(_, _, _, _, quotedSent) = toQuote qr $ direction <$> quotedSent - 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) -toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_, fileProtocol_)) :. quoteRow) = - 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 - (Just fileId, Just fileName, Just fileSize, Just fileProtocol) -> Just CIFile {fileId, fileName, fileSize, filePath, fileStatus, fileProtocol} - _ -> Nothing - cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTDirect d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTDirect - cItem d chatDir ciStatus content file = - CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toDirectQuote quoteRow, reactions = [], file} - badItem = Left $ SEBadChatItem itemId - ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTDirect d - ciMeta content status = - let itemDeleted' = if itemDeleted then Just (CIDeleted @'CTDirect deletedTs) else Nothing - itemEdited' = fromMaybe False itemEdited - in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs createdAt updatedAt - ciTimed :: Maybe CITimed - ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} - -toDirectChatItemList :: UTCTime -> MaybeChatItemRow :. QuoteRow -> [CChatItem 'CTDirect] -toDirectChatItemList currentTs (((Just itemId, Just itemTs, Just msgDir, Just itemContent, Just itemText, Just itemStatus, sharedMsgId) :. (Just itemDeleted, deletedTs, itemEdited, Just createdAt, Just updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. quoteRow) = - either (const []) (: []) $ toDirectChatItem currentTs (((itemId, itemTs, msgDir, itemContent, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. quoteRow) -toDirectChatItemList _ _ = [] - -type GroupQuoteRow = QuoteRow :. MaybeGroupMemberRow - -type MaybeGroupChatItemRow = MaybeChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow - -toGroupQuote :: QuoteRow -> Maybe GroupMember -> Maybe (CIQuote 'CTGroup) -toGroupQuote qr@(_, _, _, _, quotedSent) quotedMember_ = toQuote qr $ direction quotedSent quotedMember_ - where - direction (Just True) _ = Just CIQGroupSnd - direction (Just False) (Just member) = Just . CIQGroupRcv $ Just member - direction (Just False) Nothing = Just $ CIQGroupRcv Nothing - direction _ _ = Nothing - --- this function can be changed so it never fails, not only avoid failure on invalid json -toGroupChatItem :: UTCTime -> Int64 -> ChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow -> Either StoreError (CChatItem 'CTGroup) -toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_, fileProtocol_)) :. 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) -> Just CIFile {fileId, fileName, fileSize, filePath, 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, formattedText = parseMaybeMarkdownList itemText, quotedItem = toGroupQuote quoteRow quotedMember_, reactions = [], file} - badItem = Left $ SEBadChatItem itemId - ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTGroup d - ciMeta content status = - let itemDeleted' = - if itemDeleted - then Just (maybe (CIDeleted @'CTGroup deletedTs) (CIModerated deletedTs) deletedByGroupMember_) - else Nothing - itemEdited' = fromMaybe False itemEdited - in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs createdAt updatedAt - ciTimed :: Maybe CITimed - ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} - -toGroupChatItemList :: UTCTime -> Int64 -> MaybeGroupChatItemRow -> [CChatItem 'CTGroup] -toGroupChatItemList currentTs userContactId (((Just itemId, Just itemTs, Just msgDir, Just itemContent, Just itemText, Just itemStatus, sharedMsgId) :. (Just itemDeleted, deletedTs, itemEdited, Just createdAt, Just updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = - either (const []) (: []) $ toGroupChatItem currentTs userContactId (((itemId, itemTs, msgDir, itemContent, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) -toGroupChatItemList _ _ _ = [] - -getProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> IO [ServerCfg p] -getProtocolServers db User {userId} = - map toServerCfg - <$> DB.query - db - [sql| - SELECT host, port, key_hash, basic_auth, preset, tested, enabled - FROM protocol_servers - WHERE user_id = ? AND protocol = ?; - |] - (userId, decodeLatin1 $ strEncode protocol) - where - protocol = protocolTypeI @p - toServerCfg :: (NonEmpty TransportHost, String, C.KeyHash, Maybe Text, Bool, Maybe Bool, Bool) -> ServerCfg p - toServerCfg (host, port, keyHash, auth_, preset, tested, enabled) = - let server = ProtoServerWithAuth (ProtocolServer protocol host port keyHash) (BasicAuth . encodeUtf8 <$> auth_) - in ServerCfg {server, preset, tested, enabled} - -overwriteProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> [ServerCfg p] -> ExceptT StoreError IO () -overwriteProtocolServers db User {userId} servers = - checkConstraint SEUniqueID . ExceptT $ do - currentTs <- getCurrentTime - DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND protocol = ? " (userId, protocol) - forM_ servers $ \ServerCfg {server, preset, tested, enabled} -> do - let ProtoServerWithAuth ProtocolServer {host, port, keyHash} auth_ = server - DB.execute - db - [sql| - INSERT INTO protocol_servers - (protocol, host, port, key_hash, basic_auth, preset, tested, enabled, user_id, created_at, updated_at) - VALUES (?,?,?,?,?,?,?,?,?,?,?) - |] - ((protocol, host, port, keyHash, safeDecodeUtf8 . unBasicAuth <$> auth_) :. (preset, tested, enabled, userId, currentTs, currentTs)) - pure $ Right () - where - protocol = decodeLatin1 $ strEncode $ protocolTypeI @p - -createCall :: DB.Connection -> User -> Call -> UTCTime -> IO () -createCall db user@User {userId} Call {contactId, callId, chatItemId, callState} callTs = do - currentTs <- getCurrentTime - deleteCalls db user contactId - DB.execute - db - [sql| - INSERT INTO calls - (contact_id, shared_call_id, chat_item_id, call_state, call_ts, user_id, created_at, updated_at) - VALUES (?,?,?,?,?,?,?,?) - |] - (contactId, callId, chatItemId, callState, callTs, userId, currentTs, currentTs) - -deleteCalls :: DB.Connection -> User -> ContactId -> IO () -deleteCalls db User {userId} contactId = do - DB.execute db "DELETE FROM calls WHERE user_id = ? AND contact_id = ?" (userId, contactId) - -getCalls :: DB.Connection -> IO [Call] -getCalls db = - map toCall - <$> DB.query_ - db - [sql| - SELECT - contact_id, shared_call_id, chat_item_id, call_state, call_ts - FROM calls - ORDER BY call_ts ASC - |] - where - toCall :: (ContactId, CallId, ChatItemId, CallState, UTCTime) -> Call - toCall (contactId, callId, chatItemId, callState, callTs) = Call {contactId, callId, chatItemId, callState, callTs} - -createCommand :: DB.Connection -> User -> Maybe Int64 -> CommandFunction -> IO CommandId -createCommand db User {userId} connId commandFunction = do - currentTs <- getCurrentTime - DB.execute - db - [sql| - INSERT INTO commands (connection_id, command_function, command_status, user_id, created_at, updated_at) - VALUES (?,?,?,?,?,?) - |] - (connId, commandFunction, CSCreated, userId, currentTs, currentTs) - insertedRowId db - -setCommandConnId :: DB.Connection -> User -> CommandId -> Int64 -> IO () -setCommandConnId db User {userId} cmdId connId = do - updatedAt <- getCurrentTime - DB.execute - db - [sql| - UPDATE commands - SET connection_id = ?, updated_at = ? - WHERE user_id = ? AND command_id = ? - |] - (connId, updatedAt, userId, cmdId) - -deleteCommand :: DB.Connection -> User -> CommandId -> IO () -deleteCommand db User {userId} cmdId = - DB.execute db "DELETE FROM commands WHERE user_id = ? AND command_id = ?" (userId, cmdId) - -updateCommandStatus :: DB.Connection -> User -> CommandId -> CommandStatus -> IO () -updateCommandStatus db User {userId} cmdId status = do - updatedAt <- getCurrentTime - DB.execute - db - [sql| - UPDATE commands - SET command_status = ?, updated_at = ? - WHERE user_id = ? AND command_id = ? - |] - (status, updatedAt, userId, cmdId) - -getCommandDataByCorrId :: DB.Connection -> User -> ACorrId -> IO (Maybe CommandData) -getCommandDataByCorrId db User {userId} corrId = - maybeFirstRow toCommandData $ - DB.query - db - [sql| - SELECT command_id, connection_id, command_function, command_status - FROM commands - WHERE user_id = ? AND command_id = ? - |] - (userId, commandId corrId) - where - toCommandData :: (CommandId, Maybe Int64, CommandFunction, CommandStatus) -> CommandData - toCommandData (cmdId, cmdConnId, cmdFunction, cmdStatus) = CommandData {cmdId, cmdConnId, cmdFunction, cmdStatus} - -setConnConnReqInv :: DB.Connection -> User -> Int64 -> ConnReqInvitation -> IO () -setConnConnReqInv db User {userId} connId connReq = do - updatedAt <- getCurrentTime - DB.execute - db - [sql| - UPDATE connections - SET conn_req_inv = ?, updated_at = ? - WHERE user_id = ? AND connection_id = ? - |] - (connReq, updatedAt, userId, connId) - -getXGrpMemIntroContDirect :: DB.Connection -> User -> Contact -> IO (Maybe (Int64, XGrpMemIntroCont)) -getXGrpMemIntroContDirect db User {userId} Contact {contactId} = do - fmap join . maybeFirstRow toCont $ - DB.query - db - [sql| - SELECT ch.connection_id, g.group_id, m.group_member_id, m.member_id, c.conn_req_inv - FROM contacts ct - JOIN group_members m ON m.contact_id = ct.contact_id - LEFT JOIN connections c ON c.connection_id = ( - SELECT MAX(cc.connection_id) - FROM connections cc - WHERE cc.group_member_id = m.group_member_id - ) - JOIN groups g ON g.group_id = m.group_id AND g.group_id = ct.via_group - JOIN group_members mh ON mh.group_id = g.group_id - LEFT JOIN connections ch ON ch.connection_id = ( - SELECT max(cc.connection_id) - FROM connections cc - where cc.group_member_id = mh.group_member_id - ) - WHERE ct.user_id = ? AND ct.contact_id = ? AND ct.deleted = 0 AND mh.member_category = ? - |] - (userId, contactId, GCHostMember) - where - toCont :: (Int64, GroupId, GroupMemberId, MemberId, Maybe ConnReqInvitation) -> Maybe (Int64, XGrpMemIntroCont) - toCont (hostConnId, groupId, groupMemberId, memberId, connReq_) = case connReq_ of - Just groupConnReq -> Just (hostConnId, XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq}) - _ -> Nothing - -getXGrpMemIntroContGroup :: DB.Connection -> User -> GroupMember -> IO (Maybe (Int64, ConnReqInvitation)) -getXGrpMemIntroContGroup db User {userId} GroupMember {groupMemberId} = do - fmap join . maybeFirstRow toCont $ - DB.query - db - [sql| - SELECT ch.connection_id, c.conn_req_inv - FROM group_members m - JOIN contacts ct ON ct.contact_id = m.contact_id - LEFT JOIN connections c ON c.connection_id = ( - SELECT MAX(cc.connection_id) - FROM connections cc - WHERE cc.contact_id = ct.contact_id - ) - JOIN groups g ON g.group_id = m.group_id AND g.group_id = ct.via_group - JOIN group_members mh ON mh.group_id = g.group_id - LEFT JOIN connections ch ON ch.connection_id = ( - SELECT max(cc.connection_id) - FROM connections cc - where cc.group_member_id = mh.group_member_id - ) - WHERE m.user_id = ? AND m.group_member_id = ? AND mh.member_category = ? AND ct.deleted = 0 - |] - (userId, groupMemberId, GCHostMember) - where - toCont :: (Int64, Maybe ConnReqInvitation) -> Maybe (Int64, ConnReqInvitation) - toCont (hostConnId, connReq_) = case connReq_ of - Just connReq -> Just (hostConnId, connReq) - _ -> Nothing - -getTimedItems :: DB.Connection -> User -> UTCTime -> IO [((ChatRef, ChatItemId), UTCTime)] -getTimedItems db User {userId} startTimedThreadCutoff = - mapMaybe toCIRefDeleteAt - <$> DB.query - db - [sql| - SELECT chat_item_id, contact_id, group_id, timed_delete_at - FROM chat_items - WHERE user_id = ? AND timed_delete_at IS NOT NULL AND timed_delete_at <= ? - |] - (userId, startTimedThreadCutoff) - where - toCIRefDeleteAt :: (ChatItemId, Maybe ContactId, Maybe GroupId, UTCTime) -> Maybe ((ChatRef, ChatItemId), UTCTime) - toCIRefDeleteAt = \case - (itemId, Just contactId, Nothing, deleteAt) -> Just ((ChatRef CTDirect contactId, itemId), deleteAt) - (itemId, Nothing, Just groupId, deleteAt) -> Just ((ChatRef CTGroup groupId, itemId), deleteAt) - _ -> Nothing - -getChatItemTTL :: DB.Connection -> User -> IO (Maybe Int64) -getChatItemTTL db User {userId} = - fmap join . maybeFirstRow fromOnly $ DB.query db "SELECT chat_item_ttl FROM settings WHERE user_id = ? LIMIT 1" (Only userId) - -setChatItemTTL :: DB.Connection -> User -> Maybe Int64 -> IO () -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) - -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) - --- | Saves unique local display name based on passed displayName, suffixed with _N if required. --- This function should be called inside transaction. -withLocalDisplayName :: forall a. DB.Connection -> UserId -> Text -> (Text -> IO (Either StoreError a)) -> IO (Either StoreError a) -withLocalDisplayName db userId displayName action = getLdnSuffix >>= (`tryCreateName` 20) - where - getLdnSuffix :: IO Int - getLdnSuffix = - maybe 0 ((+ 1) . fromOnly) . listToMaybe - <$> DB.queryNamed - db - [sql| - SELECT ldn_suffix FROM display_names - WHERE user_id = :user_id AND ldn_base = :display_name - ORDER BY ldn_suffix DESC - LIMIT 1 - |] - [":user_id" := userId, ":display_name" := displayName] - tryCreateName :: Int -> Int -> IO (Either StoreError a) - tryCreateName _ 0 = pure $ Left SEDuplicateName - tryCreateName ldnSuffix attempts = do - currentTs <- getCurrentTime - let ldn = displayName <> (if ldnSuffix == 0 then "" else T.pack $ '_' : show ldnSuffix) - E.try (insertName ldn currentTs) >>= \case - Right () -> action ldn - Left e - | DB.sqlError e == DB.ErrorConstraint -> tryCreateName (ldnSuffix + 1) (attempts - 1) - | otherwise -> E.throwIO e - where - insertName ldn ts = - DB.execute - db - [sql| - INSERT INTO display_names - (local_display_name, ldn_base, ldn_suffix, user_id, created_at, updated_at) - VALUES (?,?,?,?,?,?) - |] - (ldn, displayName, ldnSuffix, userId, ts, ts) - -createWithRandomId :: forall a. TVar ChaChaDRG -> (ByteString -> IO a) -> ExceptT StoreError IO a -createWithRandomId = createWithRandomBytes 12 - -createWithRandomBytes :: forall a. Int -> TVar ChaChaDRG -> (ByteString -> IO a) -> ExceptT StoreError IO a -createWithRandomBytes size gVar create = tryCreate 3 - where - tryCreate :: Int -> ExceptT StoreError IO a - tryCreate 0 = throwError SEUniqueID - tryCreate n = do - id' <- liftIO $ encodedRandomBytes gVar size - liftIO (E.try $ create id') >>= \case - Right x -> pure x - Left e - | DB.sqlError e == DB.ErrorConstraint -> tryCreate (n - 1) - | otherwise -> throwError . SEInternalError $ show e - -encodedRandomBytes :: TVar ChaChaDRG -> Int -> IO ByteString -encodedRandomBytes gVar = fmap B64.encode . randomBytes gVar - -randomBytes :: TVar ChaChaDRG -> Int -> IO ByteString -randomBytes gVar = atomically . stateTVar gVar . randomBytesGenerate - --- These error type constructors must be added to mobile apps -data StoreError - = SEDuplicateName - | SEUserNotFound {userId :: UserId} - | SEUserNotFoundByName {contactName :: ContactName} - | SEUserNotFoundByContactId {contactId :: ContactId} - | SEUserNotFoundByGroupId {groupId :: GroupId} - | SEUserNotFoundByFileId {fileId :: FileTransferId} - | SEUserNotFoundByContactRequestId {contactRequestId :: Int64} - | SEContactNotFound {contactId :: ContactId} - | SEContactNotFoundByName {contactName :: ContactName} - | SEContactNotReady {contactName :: ContactName} - | SEDuplicateContactLink - | SEUserContactLinkNotFound - | SEContactRequestNotFound {contactRequestId :: Int64} - | SEContactRequestNotFoundByName {contactName :: ContactName} - | SEGroupNotFound {groupId :: GroupId} - | SEGroupNotFoundByName {groupName :: GroupName} - | SEGroupMemberNameNotFound {groupId :: GroupId, groupMemberName :: ContactName} - | SEGroupMemberNotFound {groupMemberId :: GroupMemberId} - | SEGroupWithoutUser - | SEDuplicateGroupMember - | SEGroupAlreadyJoined - | SEGroupInvitationNotFound - | SESndFileNotFound {fileId :: FileTransferId} - | SESndFileInvalid {fileId :: FileTransferId} - | SERcvFileNotFound {fileId :: FileTransferId} - | SERcvFileDescrNotFound {fileId :: FileTransferId} - | SEFileNotFound {fileId :: FileTransferId} - | SERcvFileInvalid {fileId :: FileTransferId} - | SERcvFileInvalidDescrPart - | SESharedMsgIdNotFoundByFileId {fileId :: FileTransferId} - | SEFileIdNotFoundBySharedMsgId {sharedMsgId :: SharedMsgId} - | SESndFileNotFoundXFTP {agentSndFileId :: AgentSndFileId} - | SERcvFileNotFoundXFTP {agentRcvFileId :: AgentRcvFileId} - | SEConnectionNotFound {agentConnId :: AgentConnId} - | SEConnectionNotFoundById {connId :: Int64} - | SEPendingConnectionNotFound {connId :: Int64} - | SEIntroNotFound - | SEUniqueID - | SEInternalError {message :: String} - | SENoMsgDelivery {connId :: Int64, agentMsgId :: AgentMsgId} - | SEBadChatItem {itemId :: ChatItemId} - | SEChatItemNotFound {itemId :: ChatItemId} - | SEChatItemNotFoundByText {text :: Text} - | SEChatItemSharedMsgIdNotFound {sharedMsgId :: SharedMsgId} - | SEChatItemNotFoundByFileId {fileId :: FileTransferId} - | SEChatItemNotFoundByGroupId {groupId :: GroupId} - | SEProfileNotFound {profileId :: Int64} - | SEDuplicateGroupLink {groupInfo :: GroupInfo} - | SEGroupLinkNotFound {groupInfo :: GroupInfo} - | SEHostMemberIdNotFound {groupId :: Int64} - | SEContactNotFoundByFileId {fileId :: FileTransferId} - deriving (Show, Exception, Generic) - -instance ToJSON StoreError where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "SE" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "SE" diff --git a/src/Simplex/Chat/Store/Connections.hs b/src/Simplex/Chat/Store/Connections.hs new file mode 100644 index 000000000..da685f4d7 --- /dev/null +++ b/src/Simplex/Chat/Store/Connections.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeOperators #-} + +module Simplex.Chat.Store.Connections + ( getConnectionEntity, + ) +where + +import Control.Applicative ((<|>)) +import Control.Monad.Except +import Data.Int (Int64) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Time.Clock (UTCTime (..)) +import Database.SQLite.Simple ((:.) (..)) +import qualified Database.SQLite.Simple as DB +import Database.SQLite.Simple.QQ (sql) +import Simplex.Chat.Store.Files +import Simplex.Chat.Store.Groups +import Simplex.Chat.Store.Shared +import Simplex.Chat.Protocol +import Simplex.Chat.Types +import Simplex.Messaging.Agent.Store.SQLite (firstRow, firstRow') + +getConnectionEntity :: DB.Connection -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity +getConnectionEntity db user@User {userId, userContactId} agentConnId = do + c@Connection {connType, entityId} <- getConnection_ + case entityId of + Nothing -> + if connType == ConnContact + then pure $ RcvDirectMsgConnection c Nothing + else throwError $ SEInternalError $ "connection " <> show connType <> " without entity" + Just entId -> + case connType of + ConnMember -> uncurry (RcvGroupMsgConnection c) <$> getGroupAndMember_ entId c + ConnContact -> RcvDirectMsgConnection c . Just <$> getContactRec_ entId c + ConnSndFile -> SndFileConnection c <$> getConnSndFileTransfer_ entId c + ConnRcvFile -> RcvFileConnection c <$> getRcvFileTransfer db user entId + ConnUserContact -> UserContactConnection c <$> getUserContact_ entId + where + getConnection_ :: ExceptT StoreError IO Connection + getConnection_ = ExceptT $ do + firstRow toConnection (SEConnectionNotFound agentConnId) $ + DB.query + db + [sql| + SELECT connection_id, agent_conn_id, conn_level, via_contact, via_user_contact_link, via_group_link, group_link_id, custom_user_profile_id, + conn_status, conn_type, local_alias, contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at, security_code, security_code_verified_at, auth_err_counter + FROM connections + WHERE user_id = ? AND agent_conn_id = ? + |] + (userId, agentConnId) + getContactRec_ :: Int64 -> Connection -> ExceptT StoreError IO Contact + getContactRec_ contactId c = ExceptT $ do + toContact' contactId c + <$> DB.query + db + [sql| + SELECT + c.contact_profile_id, c.local_display_name, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, c.via_group, c.contact_used, c.enable_ntfs, + p.preferences, c.user_preferences, c.created_at, c.updated_at, c.chat_ts + FROM contacts c + JOIN contact_profiles p ON c.contact_profile_id = p.contact_profile_id + WHERE c.user_id = ? AND c.contact_id = ? AND c.deleted = 0 + |] + (userId, contactId) + toContact' :: Int64 -> Connection -> [(ProfileId, ContactName, Text, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Int64, Bool, Maybe Bool) :. (Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime)] -> Either StoreError Contact + toContact' contactId activeConn [(profileId, localDisplayName, displayName, fullName, image, contactLink, localAlias, viaGroup, contactUsed, enableNtfs_) :. (preferences, userPreferences, createdAt, updatedAt, chatTs)] = + let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} + chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_} + mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn + in Right Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs} + toContact' _ _ _ = Left $ SEInternalError "referenced contact not found" + getGroupAndMember_ :: Int64 -> Connection -> ExceptT StoreError IO (GroupInfo, GroupMember) + getGroupAndMember_ groupMemberId c = ExceptT $ do + firstRow (toGroupAndMember c) (SEInternalError "referenced group member not found") $ + DB.query + db + [sql| + SELECT + -- GroupInfo + g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, + -- GroupInfo {membership} + mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, + mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, + -- GroupInfo {membership = GroupMember {memberProfile}} + pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences, + -- from GroupMember + m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, + m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences + FROM group_members m + JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) + JOIN groups g ON g.group_id = m.group_id + JOIN group_profiles gp USING (group_profile_id) + JOIN group_members mu ON g.group_id = mu.group_id + JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) + WHERE m.group_member_id = ? AND g.user_id = ? AND mu.contact_id = ? + |] + (groupMemberId, userId, userContactId) + toGroupAndMember :: Connection -> GroupInfoRow :. GroupMemberRow -> (GroupInfo, GroupMember) + toGroupAndMember c (groupInfoRow :. memberRow) = + let groupInfo = toGroupInfo userContactId groupInfoRow + member = toGroupMember userContactId memberRow + in (groupInfo, (member :: GroupMember) {activeConn = Just c}) + getConnSndFileTransfer_ :: Int64 -> Connection -> ExceptT StoreError IO SndFileTransfer + getConnSndFileTransfer_ fileId Connection {connId} = + ExceptT $ + firstRow' (sndFileTransfer_ fileId connId) (SESndFileNotFound fileId) $ + DB.query + db + [sql| + SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.file_descr_id, s.file_inline, s.group_member_id, cs.local_display_name, m.local_display_name + FROM snd_files s + JOIN files f USING (file_id) + LEFT JOIN contacts cs USING (contact_id) + LEFT JOIN group_members m USING (group_member_id) + WHERE f.user_id = ? AND f.file_id = ? AND s.connection_id = ? + |] + (userId, fileId, connId) + sndFileTransfer_ :: Int64 -> Int64 -> (FileStatus, String, Integer, Integer, FilePath, Maybe Int64, Maybe InlineFileMode, Maybe Int64, Maybe ContactName, Maybe ContactName) -> Either StoreError SndFileTransfer + sndFileTransfer_ fileId connId (fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, groupMemberId, contactName_, memberName_) = + case contactName_ <|> memberName_ of + Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, recipientDisplayName, connId, agentConnId, groupMemberId} + Nothing -> Left $ SESndFileInvalid fileId + getUserContact_ :: Int64 -> ExceptT StoreError IO UserContact + getUserContact_ userContactLinkId = ExceptT $ do + userContact_ + <$> DB.query + db + [sql| + SELECT conn_req_contact, group_id + FROM user_contact_links + WHERE user_id = ? AND user_contact_link_id = ? + |] + (userId, userContactLinkId) + where + userContact_ :: [(ConnReqContact, Maybe GroupId)] -> Either StoreError UserContact + userContact_ [(cReq, groupId)] = Right UserContact {userContactLinkId, connReqContact = cReq, groupId} + userContact_ _ = Left SEUserContactLinkNotFound diff --git a/src/Simplex/Chat/Store/Direct.hs b/src/Simplex/Chat/Store/Direct.hs new file mode 100644 index 000000000..27aeab7cf --- /dev/null +++ b/src/Simplex/Chat/Store/Direct.hs @@ -0,0 +1,689 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module Simplex.Chat.Store.Direct + ( updateContact_, + updateContactProfile_, + updateContactProfile_', + deleteContactProfile_, + -- * Contacts and connections functions + getPendingContactConnection, + deletePendingContactConnection, + createDirectConnection, + createConnReqConnection, + getProfileById, + getConnReqContactXContactId, + createDirectContact, + deleteContactConnectionsAndFiles, + deleteContact, + deleteContactWithoutGroups, + setContactDeleted, + getDeletedContacts, + getContactByName, + getContact, + getContactIdByName, + updateContactProfile, + updateContactUserPreferences, + updateContactAlias, + updateContactConnectionAlias, + updateContactUsed, + updateContactUnreadChat, + updateGroupUnreadChat, + setConnectionVerified, + incConnectionAuthErrCounter, + setConnectionAuthErrCounter, + getUserContacts, + createOrUpdateContactRequest, + getContactRequest', + getContactRequest, + getContactRequestIdByName, + deleteContactRequest, + createAcceptedContact, + getUserByContactRequestId, + getPendingContactConnections, + getContactConnections, + getConnectionById, + getConnectionsContacts, + updateConnectionStatus, + updateContactSettings, + setConnConnReqInv, + ) +where + +import Control.Monad.Except +import Data.Either (rights) +import Data.Functor (($>)) +import Data.Int (Int64) +import Data.Maybe (fromMaybe, isJust, isNothing) +import Data.Text (Text) +import Data.Time.Clock (UTCTime (..), getCurrentTime) +import Database.SQLite.Simple (NamedParam (..), Only (..), (:.) (..)) +import qualified Database.SQLite.Simple as DB +import Database.SQLite.Simple.QQ (sql) +import Simplex.Chat.Store.Shared +import Simplex.Chat.Types +import Simplex.Messaging.Agent.Protocol (ConnId, InvitationId, UserId) +import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) + +getPendingContactConnection :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO PendingContactConnection +getPendingContactConnection db userId connId = do + ExceptT . firstRow toPendingContactConnection (SEPendingConnectionNotFound connId) $ + DB.query + db + [sql| + SELECT connection_id, agent_conn_id, conn_status, via_contact_uri_hash, via_user_contact_link, group_link_id, custom_user_profile_id, conn_req_inv, local_alias, created_at, updated_at + FROM connections + WHERE user_id = ? + AND connection_id = ? + AND conn_type = ? + AND contact_id IS NULL + AND conn_level = 0 + AND via_contact IS NULL + |] + (userId, connId, ConnContact) + +deletePendingContactConnection :: DB.Connection -> UserId -> Int64 -> IO () +deletePendingContactConnection db userId connId = + DB.execute + db + [sql| + DELETE FROM connections + WHERE user_id = ? + AND connection_id = ? + AND conn_type = ? + AND contact_id IS NULL + AND conn_level = 0 + AND via_contact IS NULL + |] + (userId, connId, ConnContact) + +createConnReqConnection :: DB.Connection -> UserId -> ConnId -> ConnReqUriHash -> XContactId -> Maybe Profile -> Maybe GroupLinkId -> IO PendingContactConnection +createConnReqConnection db userId acId cReqHash xContactId incognitoProfile groupLinkId = do + createdAt <- getCurrentTime + customUserProfileId <- mapM (createIncognitoProfile_ db userId createdAt) incognitoProfile + let pccConnStatus = ConnJoined + DB.execute + db + [sql| + INSERT INTO connections ( + user_id, agent_conn_id, conn_status, conn_type, + via_contact_uri_hash, xcontact_id, custom_user_profile_id, via_group_link, group_link_id, created_at, updated_at + ) VALUES (?,?,?,?,?,?,?,?,?,?,?) + |] + ((userId, acId, pccConnStatus, ConnContact, cReqHash, xContactId) :. (customUserProfileId, isJust groupLinkId, groupLinkId, createdAt, createdAt)) + pccConnId <- insertedRowId db + pure PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = True, viaUserContactLink = Nothing, groupLinkId, customUserProfileId, connReqInv = Nothing, localAlias = "", createdAt, updatedAt = createdAt} + +getConnReqContactXContactId :: DB.Connection -> User -> ConnReqUriHash -> IO (Maybe Contact, Maybe XContactId) +getConnReqContactXContactId db user@User {userId} cReqHash = do + getContact' >>= \case + c@(Just _) -> pure (c, Nothing) + Nothing -> (Nothing,) <$> getXContactId + where + getContact' :: IO (Maybe Contact) + getContact' = + maybeFirstRow (toContact user) $ + DB.query + db + [sql| + SELECT + -- Contact + ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, + cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, + -- Connection + c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias, + c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter + FROM contacts ct + JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id + JOIN connections c ON c.contact_id = ct.contact_id + WHERE ct.user_id = ? AND c.via_contact_uri_hash = ? AND ct.deleted = 0 + ORDER BY c.connection_id DESC + LIMIT 1 + |] + (userId, cReqHash) + getXContactId :: IO (Maybe XContactId) + getXContactId = + maybeFirstRow fromOnly $ + DB.query + db + "SELECT xcontact_id FROM connections WHERE user_id = ? AND via_contact_uri_hash = ? LIMIT 1" + (userId, cReqHash) + +createDirectConnection :: DB.Connection -> User -> ConnId -> ConnReqInvitation -> ConnStatus -> Maybe Profile -> IO PendingContactConnection +createDirectConnection db User {userId} acId cReq pccConnStatus incognitoProfile = do + createdAt <- getCurrentTime + customUserProfileId <- mapM (createIncognitoProfile_ db userId createdAt) incognitoProfile + DB.execute + db + [sql| + INSERT INTO connections + (user_id, agent_conn_id, conn_req_inv, conn_status, conn_type, custom_user_profile_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?) + |] + (userId, acId, cReq, pccConnStatus, ConnContact, customUserProfileId, createdAt, createdAt) + pccConnId <- insertedRowId db + pure PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = False, viaUserContactLink = Nothing, groupLinkId = Nothing, customUserProfileId, connReqInv = Just cReq, localAlias = "", createdAt, updatedAt = createdAt} + +createIncognitoProfile_ :: DB.Connection -> UserId -> UTCTime -> Profile -> IO Int64 +createIncognitoProfile_ db userId createdAt Profile {displayName, fullName, image} = do + DB.execute + db + [sql| + INSERT INTO contact_profiles (display_name, full_name, image, user_id, incognito, created_at, updated_at) + VALUES (?,?,?,?,?,?,?) + |] + (displayName, fullName, image, userId, Just True, createdAt, createdAt) + insertedRowId db + +createDirectContact :: DB.Connection -> User -> Connection -> Profile -> ExceptT StoreError IO Contact +createDirectContact db user@User {userId} activeConn@Connection {connId, localAlias} p@Profile {preferences} = do + createdAt <- liftIO getCurrentTime + (localDisplayName, contactId, profileId) <- createContact_ db userId connId p localAlias Nothing createdAt (Just createdAt) + let profile = toLocalProfile profileId p localAlias + userPreferences = emptyChatPrefs + mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn + pure $ Contact {contactId, localDisplayName, profile, activeConn, viaGroup = Nothing, contactUsed = False, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt, updatedAt = createdAt, chatTs = Just createdAt} + +deleteContactConnectionsAndFiles :: DB.Connection -> UserId -> Contact -> IO () +deleteContactConnectionsAndFiles db userId Contact {contactId} = do + DB.execute + db + [sql| + DELETE FROM connections WHERE connection_id IN ( + SELECT connection_id + FROM connections c + JOIN contacts ct ON ct.contact_id = c.contact_id + WHERE ct.user_id = ? AND ct.contact_id = ? + ) + |] + (userId, contactId) + DB.execute db "DELETE FROM files WHERE user_id = ? AND contact_id = ?" (userId, contactId) + +deleteContact :: DB.Connection -> User -> Contact -> IO () +deleteContact db user@User {userId} Contact {contactId, localDisplayName, activeConn = Connection {customUserProfileId}} = do + DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND contact_id = ?" (userId, contactId) + ctMember :: (Maybe ContactId) <- maybeFirstRow fromOnly $ DB.query db "SELECT contact_id FROM group_members WHERE user_id = ? AND contact_id = ? LIMIT 1" (userId, contactId) + if isNothing ctMember + then do + deleteContactProfile_ db userId contactId + DB.execute db "DELETE FROM display_names WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName) + else do + currentTs <- getCurrentTime + DB.execute db "UPDATE group_members SET contact_id = NULL, updated_at = ? WHERE user_id = ? AND contact_id = ?" (currentTs, userId, contactId) + DB.execute db "DELETE FROM contacts WHERE user_id = ? AND contact_id = ?" (userId, contactId) + forM_ customUserProfileId $ \profileId -> deleteUnusedIncognitoProfileById_ db user profileId + +-- should only be used if contact is not member of any groups +deleteContactWithoutGroups :: DB.Connection -> User -> Contact -> IO () +deleteContactWithoutGroups db user@User {userId} Contact {contactId, localDisplayName, activeConn = Connection {customUserProfileId}} = do + DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND contact_id = ?" (userId, contactId) + deleteContactProfile_ db userId contactId + DB.execute db "DELETE FROM display_names WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName) + DB.execute db "DELETE FROM contacts WHERE user_id = ? AND contact_id = ?" (userId, contactId) + forM_ customUserProfileId $ \profileId -> deleteUnusedIncognitoProfileById_ db user profileId + +setContactDeleted :: DB.Connection -> User -> Contact -> IO () +setContactDeleted db User {userId} Contact {contactId} = do + currentTs <- getCurrentTime + DB.execute db "UPDATE contacts SET deleted = 1, updated_at = ? WHERE user_id = ? AND contact_id = ?" (currentTs, userId, contactId) + +getDeletedContacts :: DB.Connection -> User -> IO [Contact] +getDeletedContacts db user@User {userId} = do + contactIds <- map fromOnly <$> DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND deleted = 1" (Only userId) + rights <$> mapM (runExceptT . getDeletedContact db user) contactIds + +getDeletedContact :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO Contact +getDeletedContact db user contactId = getContact_ db user contactId True + +deleteContactProfile_ :: DB.Connection -> UserId -> ContactId -> IO () +deleteContactProfile_ db userId contactId = + DB.execute + db + [sql| + DELETE FROM contact_profiles + WHERE contact_profile_id in ( + SELECT contact_profile_id + FROM contacts + WHERE user_id = ? AND contact_id = ? + ) + |] + (userId, contactId) + +updateContactProfile :: DB.Connection -> User -> Contact -> Profile -> ExceptT StoreError IO Contact +updateContactProfile db user@User {userId} c p' + | displayName == newName = do + liftIO $ updateContactProfile_ db userId profileId p' + pure c {profile, mergedPreferences} + | otherwise = + ExceptT . withLocalDisplayName db userId newName $ \ldn -> do + currentTs <- getCurrentTime + updateContactProfile_' db userId profileId p' currentTs + updateContact_ db userId contactId localDisplayName ldn currentTs + pure $ Right c {localDisplayName = ldn, profile, mergedPreferences} + where + Contact {contactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}, activeConn, userPreferences} = c + Profile {displayName = newName, preferences} = p' + profile = toLocalProfile profileId p' localAlias + mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn + +updateContactUserPreferences :: DB.Connection -> User -> Contact -> Preferences -> IO Contact +updateContactUserPreferences db user@User {userId} c@Contact {contactId, activeConn} userPreferences = do + updatedAt <- getCurrentTime + DB.execute + db + "UPDATE contacts SET user_preferences = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?" + (userPreferences, updatedAt, userId, contactId) + let mergedPreferences = contactUserPreferences user userPreferences (preferences' c) $ connIncognito activeConn + pure $ c {mergedPreferences, userPreferences} + +updateContactAlias :: DB.Connection -> UserId -> Contact -> LocalAlias -> IO Contact +updateContactAlias db userId c@Contact {profile = lp@LocalProfile {profileId}} localAlias = do + updatedAt <- getCurrentTime + DB.execute + db + [sql| + UPDATE contact_profiles + SET local_alias = ?, updated_at = ? + WHERE user_id = ? AND contact_profile_id = ? + |] + (localAlias, updatedAt, userId, profileId) + pure $ (c :: Contact) {profile = lp {localAlias}} + +updateContactConnectionAlias :: DB.Connection -> UserId -> PendingContactConnection -> LocalAlias -> IO PendingContactConnection +updateContactConnectionAlias db userId conn localAlias = do + updatedAt <- getCurrentTime + DB.execute + db + [sql| + UPDATE connections + SET local_alias = ?, updated_at = ? + WHERE user_id = ? AND connection_id = ? + |] + (localAlias, updatedAt, userId, pccConnId conn) + pure (conn :: PendingContactConnection) {localAlias} + +updateContactUsed :: DB.Connection -> User -> Contact -> IO () +updateContactUsed db User {userId} Contact {contactId} = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE contacts SET contact_used = 1, updated_at = ? WHERE user_id = ? AND contact_id = ?" (updatedAt, userId, contactId) + +updateContactUnreadChat :: DB.Connection -> User -> Contact -> Bool -> IO () +updateContactUnreadChat db User {userId} Contact {contactId} unreadChat = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE contacts SET unread_chat = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?" (unreadChat, updatedAt, userId, contactId) + +updateGroupUnreadChat :: DB.Connection -> User -> GroupInfo -> Bool -> IO () +updateGroupUnreadChat db User {userId} GroupInfo {groupId} unreadChat = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE groups SET unread_chat = ?, updated_at = ? WHERE user_id = ? AND group_id = ?" (unreadChat, updatedAt, userId, groupId) + +setConnectionVerified :: DB.Connection -> User -> Int64 -> Maybe Text -> IO () +setConnectionVerified db User {userId} connId code = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE connections SET security_code = ?, security_code_verified_at = ?, updated_at = ? WHERE user_id = ? AND connection_id = ?" (code, code $> updatedAt, updatedAt, userId, connId) + +incConnectionAuthErrCounter :: DB.Connection -> User -> Connection -> IO Int +incConnectionAuthErrCounter db User {userId} Connection {connId, authErrCounter} = do + updatedAt <- getCurrentTime + (counter_ :: Maybe Int) <- maybeFirstRow fromOnly $ DB.query db "SELECT auth_err_counter FROM connections WHERE user_id = ? AND connection_id = ?" (userId, connId) + let counter' = fromMaybe authErrCounter counter_ + 1 + DB.execute db "UPDATE connections SET auth_err_counter = ?, updated_at = ? WHERE user_id = ? AND connection_id = ?" (counter', updatedAt, userId, connId) + pure counter' + +setConnectionAuthErrCounter :: DB.Connection -> User -> Connection -> Int -> IO () +setConnectionAuthErrCounter db User {userId} Connection {connId} counter = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE connections SET auth_err_counter = ?, updated_at = ? WHERE user_id = ? AND connection_id = ?" (counter, updatedAt, userId, connId) + +updateContactProfile_ :: DB.Connection -> UserId -> ProfileId -> Profile -> IO () +updateContactProfile_ db userId profileId profile = do + currentTs <- getCurrentTime + updateContactProfile_' db userId profileId profile currentTs + +updateContactProfile_' :: DB.Connection -> UserId -> ProfileId -> Profile -> UTCTime -> IO () +updateContactProfile_' db userId profileId Profile {displayName, fullName, image, contactLink, preferences} updatedAt = do + DB.execute + db + [sql| + UPDATE contact_profiles + SET display_name = ?, full_name = ?, image = ?, contact_link = ?, preferences = ?, updated_at = ? + WHERE user_id = ? AND contact_profile_id = ? + |] + (displayName, fullName, image, contactLink, preferences, updatedAt, userId, profileId) + +updateContact_ :: DB.Connection -> UserId -> Int64 -> ContactName -> ContactName -> UTCTime -> IO () +updateContact_ db userId contactId displayName newName updatedAt = do + DB.execute + db + "UPDATE contacts SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?" + (newName, updatedAt, userId, contactId) + DB.execute + db + "UPDATE group_members SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?" + (newName, updatedAt, userId, contactId) + DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (displayName, userId) + +getContactByName :: DB.Connection -> User -> ContactName -> ExceptT StoreError IO Contact +getContactByName db user localDisplayName = do + cId <- getContactIdByName db user localDisplayName + getContact db user cId + +getUserContacts :: DB.Connection -> User -> IO [Contact] +getUserContacts db user@User {userId} = do + contactIds <- map fromOnly <$> DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND deleted = 0" (Only userId) + rights <$> mapM (runExceptT . getContact db user) contactIds + +createOrUpdateContactRequest :: DB.Connection -> User -> Int64 -> InvitationId -> Profile -> Maybe XContactId -> ExceptT StoreError IO ContactOrRequest +createOrUpdateContactRequest db user@User {userId} userContactLinkId invId Profile {displayName, fullName, image, contactLink, preferences} xContactId_ = + liftIO (maybeM getContact' xContactId_) >>= \case + Just contact -> pure $ CORContact contact + Nothing -> CORRequest <$> createOrUpdate_ + where + maybeM = maybe (pure Nothing) + createOrUpdate_ :: ExceptT StoreError IO UserContactRequest + createOrUpdate_ = do + cReqId <- + ExceptT $ + maybeM getContactRequestByXContactId xContactId_ >>= \case + Nothing -> createContactRequest + Just cr -> updateContactRequest cr $> Right (contactRequestId (cr :: UserContactRequest)) + getContactRequest db user cReqId + createContactRequest :: IO (Either StoreError Int64) + createContactRequest = do + currentTs <- getCurrentTime + withLocalDisplayName db userId displayName (fmap Right . createContactRequest_ currentTs) + where + createContactRequest_ currentTs ldn = do + DB.execute + db + "INSERT INTO contact_profiles (display_name, full_name, image, contact_link, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" + (displayName, fullName, image, contactLink, userId, preferences, currentTs, currentTs) + profileId <- insertedRowId db + DB.execute + db + [sql| + INSERT INTO contact_requests + (user_contact_link_id, agent_invitation_id, contact_profile_id, local_display_name, user_id, created_at, updated_at, xcontact_id) + VALUES (?,?,?,?,?,?,?,?) + |] + (userContactLinkId, invId, profileId, ldn, userId, currentTs, currentTs, xContactId_) + insertedRowId db + getContact' :: XContactId -> IO (Maybe Contact) + getContact' xContactId = + maybeFirstRow (toContact user) $ + DB.query + db + [sql| + SELECT + -- Contact + ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, + cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, + -- Connection + c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias, + c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter + FROM contacts ct + JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id + LEFT JOIN connections c ON c.contact_id = ct.contact_id + WHERE ct.user_id = ? AND ct.xcontact_id = ? AND ct.deleted = 0 + ORDER BY c.connection_id DESC + LIMIT 1 + |] + (userId, xContactId) + getContactRequestByXContactId :: XContactId -> IO (Maybe UserContactRequest) + getContactRequestByXContactId xContactId = + maybeFirstRow toContactRequest $ + DB.query + db + [sql| + SELECT + cr.contact_request_id, cr.local_display_name, cr.agent_invitation_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, p.preferences, cr.created_at, cr.updated_at + FROM contact_requests cr + JOIN connections c USING (user_contact_link_id) + JOIN contact_profiles p USING (contact_profile_id) + WHERE cr.user_id = ? + AND cr.xcontact_id = ? + LIMIT 1 + |] + (userId, xContactId) + updateContactRequest :: UserContactRequest -> IO (Either StoreError ()) + updateContactRequest UserContactRequest {contactRequestId = cReqId, localDisplayName = oldLdn, profile = Profile {displayName = oldDisplayName}} = do + currentTs <- liftIO getCurrentTime + updateProfile currentTs + if displayName == oldDisplayName + then Right <$> DB.execute db "UPDATE contact_requests SET agent_invitation_id = ?, updated_at = ? WHERE user_id = ? AND contact_request_id = ?" (invId, currentTs, userId, cReqId) + else withLocalDisplayName db userId displayName $ \ldn -> + Right <$> do + DB.execute db "UPDATE contact_requests SET agent_invitation_id = ?, local_display_name = ?, updated_at = ? WHERE user_id = ? AND contact_request_id = ?" (invId, ldn, currentTs, userId, cReqId) + DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (oldLdn, userId) + where + updateProfile currentTs = + DB.execute + db + [sql| + UPDATE contact_profiles + SET display_name = ?, + full_name = ?, + image = ?, + contact_link = ?, + updated_at = ? + WHERE contact_profile_id IN ( + SELECT contact_profile_id + FROM contact_requests + WHERE user_id = ? + AND contact_request_id = ? + ) + |] + (displayName, fullName, image, contactLink, currentTs, userId, cReqId) + +getContactRequest' :: DB.Connection -> Int64 -> ExceptT StoreError IO (User, UserContactRequest) +getContactRequest' db contactRequestId = do + user <- getUserByContactRequestId db contactRequestId + (user,) <$> getContactRequest db user contactRequestId + +getContactRequest :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO UserContactRequest +getContactRequest db User {userId} contactRequestId = + ExceptT . firstRow toContactRequest (SEContactRequestNotFound contactRequestId) $ + DB.query + db + [sql| + SELECT + cr.contact_request_id, cr.local_display_name, cr.agent_invitation_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, p.preferences, cr.created_at, cr.updated_at + FROM contact_requests cr + JOIN connections c USING (user_contact_link_id) + JOIN contact_profiles p USING (contact_profile_id) + WHERE cr.user_id = ? + AND cr.contact_request_id = ? + |] + (userId, contactRequestId) + +getContactRequestIdByName :: DB.Connection -> UserId -> ContactName -> ExceptT StoreError IO Int64 +getContactRequestIdByName db userId cName = + ExceptT . firstRow fromOnly (SEContactRequestNotFoundByName cName) $ + DB.query db "SELECT contact_request_id FROM contact_requests WHERE user_id = ? AND local_display_name = ?" (userId, cName) + +deleteContactRequest :: DB.Connection -> User -> Int64 -> IO () +deleteContactRequest db User {userId} contactRequestId = do + DB.execute + db + [sql| + DELETE FROM contact_profiles + WHERE contact_profile_id in ( + SELECT contact_profile_id + FROM contact_requests + WHERE user_id = ? AND contact_request_id = ? + ) + |] + (userId, contactRequestId) + DB.execute + db + [sql| + DELETE FROM display_names + WHERE user_id = ? AND local_display_name = ( + SELECT local_display_name FROM contact_requests + WHERE user_id = ? AND contact_request_id = ? + ) + |] + (userId, userId, contactRequestId) + DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND contact_request_id = ?" (userId, contactRequestId) + +createAcceptedContact :: DB.Connection -> User -> ConnId -> ContactName -> ProfileId -> Profile -> Int64 -> Maybe XContactId -> Maybe IncognitoProfile -> IO Contact +createAcceptedContact db user@User {userId, profile = LocalProfile {preferences}} agentConnId localDisplayName profileId profile userContactLinkId xContactId incognitoProfile = do + DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName) + createdAt <- getCurrentTime + customUserProfileId <- forM incognitoProfile $ \case + NewIncognito p -> createIncognitoProfile_ db userId createdAt p + ExistingIncognito LocalProfile {profileId = pId} -> pure pId + let userPreferences = fromMaybe emptyChatPrefs $ incognitoProfile >> preferences + DB.execute + db + "INSERT INTO contacts (user_id, local_display_name, contact_profile_id, enable_ntfs, user_preferences, created_at, updated_at, chat_ts, xcontact_id) VALUES (?,?,?,?,?,?,?,?,?)" + (userId, localDisplayName, profileId, True, userPreferences, createdAt, createdAt, createdAt, xContactId) + contactId <- insertedRowId db + activeConn <- createConnection_ db userId ConnContact (Just contactId) agentConnId Nothing (Just userContactLinkId) customUserProfileId 0 createdAt + let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn + pure $ Contact {contactId, localDisplayName, profile = toLocalProfile profileId profile "", activeConn, viaGroup = Nothing, contactUsed = False, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = createdAt, updatedAt = createdAt, chatTs = Just createdAt} + +getContactIdByName :: DB.Connection -> User -> ContactName -> ExceptT StoreError IO Int64 +getContactIdByName db User {userId} cName = + ExceptT . firstRow fromOnly (SEContactNotFoundByName cName) $ + DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND local_display_name = ? AND deleted = 0" (userId, cName) + +getContact :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO Contact +getContact db user contactId = getContact_ db user contactId False + +getContact_ :: DB.Connection -> User -> Int64 -> Bool -> ExceptT StoreError IO Contact +getContact_ db user@User {userId} contactId deleted = + ExceptT . fmap join . firstRow (toContactOrError user) (SEContactNotFound contactId) $ + DB.query + db + [sql| + SELECT + -- Contact + ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, + cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, + -- Connection + c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias, + c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter + FROM contacts ct + JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id + LEFT JOIN connections c ON c.contact_id = ct.contact_id + WHERE ct.user_id = ? AND ct.contact_id = ? + AND ct.deleted = ? + AND c.connection_id = ( + SELECT cc_connection_id FROM ( + SELECT + cc.connection_id AS cc_connection_id, + (CASE WHEN cc.conn_status = ? OR cc.conn_status = ? THEN 1 ELSE 0 END) AS cc_conn_status_ord + FROM connections cc + WHERE cc.user_id = ct.user_id AND cc.contact_id = ct.contact_id + ORDER BY cc_conn_status_ord DESC, cc_connection_id DESC + LIMIT 1 + ) + ) + |] + (userId, contactId, deleted, ConnReady, ConnSndReady) + +getUserByContactRequestId :: DB.Connection -> Int64 -> ExceptT StoreError IO User +getUserByContactRequestId db contactRequestId = + ExceptT . firstRow toUser (SEUserNotFoundByContactRequestId contactRequestId) $ + DB.query db (userQuery <> " JOIN contact_requests cr ON cr.user_id = u.user_id WHERE cr.contact_request_id = ?") (Only contactRequestId) + +getPendingContactConnections :: DB.Connection -> User -> IO [PendingContactConnection] +getPendingContactConnections db User {userId} = do + map toPendingContactConnection + <$> DB.queryNamed + db + [sql| + SELECT connection_id, agent_conn_id, conn_status, via_contact_uri_hash, via_user_contact_link, group_link_id, custom_user_profile_id, conn_req_inv, local_alias, created_at, updated_at + FROM connections + WHERE user_id = :user_id + AND conn_type = :conn_type + AND contact_id IS NULL + |] + [":user_id" := userId, ":conn_type" := ConnContact] + +getContactConnections :: DB.Connection -> UserId -> Contact -> ExceptT StoreError IO [Connection] +getContactConnections db userId Contact {contactId} = + connections =<< liftIO getConnections_ + where + getConnections_ = + DB.query + db + [sql| + SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, + c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter + FROM connections c + JOIN contacts ct ON ct.contact_id = c.contact_id + WHERE c.user_id = ? AND ct.user_id = ? AND ct.contact_id = ? + |] + (userId, userId, contactId) + connections [] = throwError $ SEContactNotFound contactId + connections rows = pure $ map toConnection rows + + + + +getConnectionById :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO Connection +getConnectionById db User {userId} connId = ExceptT $ do + firstRow toConnection (SEConnectionNotFoundById connId) $ + DB.query + db + [sql| + SELECT connection_id, agent_conn_id, conn_level, via_contact, via_user_contact_link, via_group_link, group_link_id, custom_user_profile_id, + conn_status, conn_type, local_alias, contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at, security_code, security_code_verified_at, auth_err_counter + FROM connections + WHERE user_id = ? AND connection_id = ? + |] + (userId, connId) + +getConnectionsContacts :: DB.Connection -> [ConnId] -> IO [ContactRef] +getConnectionsContacts db agentConnIds = do + DB.execute_ db "DROP TABLE IF EXISTS temp.conn_ids" + DB.execute_ db "CREATE TABLE temp.conn_ids (conn_id BLOB)" + DB.executeMany db "INSERT INTO temp.conn_ids (conn_id) VALUES (?)" $ map Only agentConnIds + conns <- + map toContactRef + <$> DB.query + db + [sql| + SELECT ct.contact_id, c.connection_id, c.agent_conn_id, ct.local_display_name + FROM contacts ct + JOIN connections c ON c.contact_id = ct.contact_id + WHERE c.agent_conn_id IN (SELECT conn_id FROM temp.conn_ids) + AND c.conn_type = ? + AND ct.deleted = 0 + |] + (Only ConnContact) + DB.execute_ db "DROP TABLE temp.conn_ids" + pure conns + where + toContactRef :: (ContactId, Int64, ConnId, ContactName) -> ContactRef + toContactRef (contactId, connId, acId, localDisplayName) = ContactRef {contactId, connId, agentConnId = AgentConnId acId, localDisplayName} + +updateConnectionStatus :: DB.Connection -> Connection -> ConnStatus -> IO () +updateConnectionStatus db Connection {connId} connStatus = do + currentTs <- getCurrentTime + DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ? WHERE connection_id = ?" (connStatus, currentTs, connId) + +updateContactSettings :: DB.Connection -> User -> Int64 -> ChatSettings -> IO () +updateContactSettings db User {userId} contactId ChatSettings {enableNtfs} = + DB.execute db "UPDATE contacts SET enable_ntfs = ? WHERE user_id = ? AND contact_id = ?" (enableNtfs, userId, contactId) + +setConnConnReqInv :: DB.Connection -> User -> Int64 -> ConnReqInvitation -> IO () +setConnConnReqInv db User {userId} connId connReq = do + updatedAt <- getCurrentTime + DB.execute + db + [sql| + UPDATE connections + SET conn_req_inv = ?, updated_at = ? + WHERE user_id = ? AND connection_id = ? + |] + (connReq, updatedAt, userId, connId) diff --git a/src/Simplex/Chat/Store/Files.hs b/src/Simplex/Chat/Store/Files.hs new file mode 100644 index 000000000..49e149c7f --- /dev/null +++ b/src/Simplex/Chat/Store/Files.hs @@ -0,0 +1,868 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Simplex.Chat.Store.Files + ( getLiveSndFileTransfers, + getLiveRcvFileTransfers, + getPendingSndChunks, + createSndDirectFileTransfer, + createSndDirectFTConnection, + createSndGroupFileTransfer, + createSndGroupFileTransferConnection, + createSndDirectInlineFT, + createSndGroupInlineFT, + updateSndDirectFTDelivery, + updateSndGroupFTDelivery, + getSndFTViaMsgDelivery, + createSndFileTransferXFTP, + createSndFTDescrXFTP, + setSndFTPrivateSndDescr, + updateSndFTDescrXFTP, + createExtraSndFTDescrs, + updateSndFTDeliveryXFTP, + setSndFTAgentDeleted, + getXFTPSndFileDBId, + getXFTPRcvFileDBId, + updateFileCancelled, + updateCIFileStatus, + getSharedMsgIdByFileId, + getFileIdBySharedMsgId, + getGroupFileIdBySharedMsgId, + getDirectFileIdBySharedMsgId, + getChatRefByFileId, + updateSndFileStatus, + createSndFileChunk, + updateSndFileChunkMsg, + updateSndFileChunkSent, + deleteSndFileChunks, + createRcvFileTransfer, + createRcvGroupFileTransfer, + appendRcvFD, + getRcvFileDescrByFileId, + updateRcvFileAgentId, + getRcvFileTransferById, + getRcvFileTransfer, + acceptRcvFileTransfer, + getContactByFileId, + acceptRcvInlineFT, + startRcvInlineFT, + xftpAcceptRcvFT, + setRcvFileToReceive, + getRcvFilesToReceive, + setRcvFTAgentDeleted, + updateRcvFileStatus, + createRcvFileChunk, + updatedRcvFileChunkStored, + deleteRcvFileChunks, + updateFileTransferChatItemId, + getFileTransfer, + getFileTransferProgress, + getFileTransferMeta, + getSndFileTransfer, + getSndFileTransfers, + getContactFileInfo, + updateDirectCIFileStatus, + ) +where + +import Control.Applicative ((<|>)) +import Control.Monad.Except +import Data.Either (rights) +import Data.Int (Int64) +import Data.Maybe (fromMaybe, isJust, listToMaybe) +import Data.Text (Text) +import Data.Time (addUTCTime) +import Data.Time.Clock (UTCTime (..), getCurrentTime, nominalDay) +import Data.Type.Equality +import Database.SQLite.Simple (Only (..), (:.) (..)) +import qualified Database.SQLite.Simple as DB +import Database.SQLite.Simple.QQ (sql) +import Simplex.Chat.Store.Direct +import Simplex.Chat.Store.Messages +import Simplex.Chat.Store.Profiles +import Simplex.Chat.Store.Shared +import Simplex.Chat.Messages +import Simplex.Chat.Messages.CIContent +import Simplex.Chat.Protocol +import Simplex.Chat.Types +import Simplex.Chat.Util (week) +import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, UserId) +import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) + +getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer] +getLiveSndFileTransfers db User {userId} = do + cutoffTs <- addUTCTime (- week) <$> getCurrentTime + fileIds :: [Int64] <- + map fromOnly + <$> DB.query + db + [sql| + SELECT DISTINCT f.file_id + FROM files f + JOIN snd_files s USING (file_id) + WHERE f.user_id = ? + AND s.file_status IN (?, ?, ?) + AND s.file_descr_id IS NULL + AND s.file_inline IS NULL + AND s.created_at > ? + |] + (userId, FSNew, FSAccepted, FSConnected, cutoffTs) + concatMap (filter liveTransfer) . rights <$> mapM (getSndFileTransfers_ db userId) fileIds + where + liveTransfer :: SndFileTransfer -> Bool + liveTransfer SndFileTransfer {fileStatus} = fileStatus `elem` [FSNew, FSAccepted, FSConnected] + +getLiveRcvFileTransfers :: DB.Connection -> User -> IO [RcvFileTransfer] +getLiveRcvFileTransfers db user@User {userId} = do + cutoffTs <- addUTCTime (- week) <$> getCurrentTime + fileIds :: [Int64] <- + map fromOnly + <$> DB.query + db + [sql| + SELECT f.file_id + FROM files f + JOIN rcv_files r USING (file_id) + WHERE f.user_id = ? AND r.file_status IN (?, ?) + AND r.rcv_file_inline IS NULL + AND r.file_descr_id IS NULL + AND r.created_at > ? + |] + (userId, FSAccepted, FSConnected, cutoffTs) + rights <$> mapM (runExceptT . getRcvFileTransfer db user) fileIds + +getPendingSndChunks :: DB.Connection -> Int64 -> Int64 -> IO [Integer] +getPendingSndChunks db fileId connId = + map fromOnly + <$> DB.query + db + [sql| + SELECT chunk_number + FROM snd_file_chunks + WHERE file_id = ? AND connection_id = ? AND chunk_agent_msg_id IS NULL + ORDER BY chunk_number + |] + (fileId, connId) + +createSndDirectFileTransfer :: DB.Connection -> UserId -> Contact -> FilePath -> FileInvitation -> Maybe ConnId -> Integer -> IO FileTransferMeta +createSndDirectFileTransfer db userId Contact {contactId} filePath FileInvitation {fileName, fileSize, fileInline} acId_ chunkSize = do + currentTs <- getCurrentTime + DB.execute + db + "INSERT INTO files (user_id, contact_id, file_name, file_path, file_size, chunk_size, file_inline, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?)" + ((userId, contactId, fileName, filePath, fileSize, chunkSize) :. (fileInline, CIFSSndStored, FPSMP, currentTs, currentTs)) + fileId <- insertedRowId db + forM_ acId_ $ \acId -> do + Connection {connId} <- createSndFileConnection_ db userId fileId acId + let fileStatus = FSNew + DB.execute + db + "INSERT INTO snd_files (file_id, file_status, file_inline, connection_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" + (fileId, fileStatus, fileInline, connId, currentTs, currentTs) + pure FileTransferMeta {fileId, xftpSndFile = Nothing, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False} + +createSndDirectFTConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> IO () +createSndDirectFTConnection db user@User {userId} fileId (cmdId, acId) = do + currentTs <- getCurrentTime + Connection {connId} <- createSndFileConnection_ db userId fileId acId + setCommandConnId db user cmdId connId + DB.execute + db + "INSERT INTO snd_files (file_id, file_status, connection_id, created_at, updated_at) VALUES (?,?,?,?,?)" + (fileId, FSAccepted, connId, currentTs, currentTs) + +createSndGroupFileTransfer :: DB.Connection -> UserId -> GroupInfo -> FilePath -> FileInvitation -> Integer -> IO FileTransferMeta +createSndGroupFileTransfer db userId GroupInfo {groupId} filePath FileInvitation {fileName, fileSize, fileInline} chunkSize = do + currentTs <- getCurrentTime + DB.execute + db + "INSERT INTO files (user_id, group_id, file_name, file_path, file_size, chunk_size, file_inline, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?)" + ((userId, groupId, fileName, filePath, fileSize, chunkSize) :. (fileInline, CIFSSndStored, FPSMP, currentTs, currentTs)) + fileId <- insertedRowId db + pure FileTransferMeta {fileId, xftpSndFile = Nothing, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False} + +createSndGroupFileTransferConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> GroupMember -> IO () +createSndGroupFileTransferConnection db user@User {userId} fileId (cmdId, acId) GroupMember {groupMemberId} = do + currentTs <- getCurrentTime + Connection {connId} <- createSndFileConnection_ db userId fileId acId + setCommandConnId db user cmdId connId + DB.execute + db + "INSERT INTO snd_files (file_id, file_status, connection_id, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" + (fileId, FSAccepted, connId, groupMemberId, currentTs, currentTs) + +createSndDirectInlineFT :: DB.Connection -> Contact -> FileTransferMeta -> IO SndFileTransfer +createSndDirectInlineFT db Contact {localDisplayName = n, activeConn = Connection {connId, agentConnId}} FileTransferMeta {fileId, fileName, filePath, fileSize, chunkSize, fileInline} = do + currentTs <- getCurrentTime + let fileStatus = FSConnected + fileInline' = Just $ fromMaybe IFMOffer fileInline + DB.execute + db + "INSERT INTO snd_files (file_id, file_status, file_inline, connection_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" + (fileId, fileStatus, fileInline', connId, currentTs, currentTs) + pure SndFileTransfer {fileId, fileName, filePath, fileSize, chunkSize, recipientDisplayName = n, connId, agentConnId, groupMemberId = Nothing, fileStatus, fileDescrId = Nothing, fileInline = fileInline'} + +createSndGroupInlineFT :: DB.Connection -> GroupMember -> Connection -> FileTransferMeta -> IO SndFileTransfer +createSndGroupInlineFT db GroupMember {groupMemberId, localDisplayName = n} Connection {connId, agentConnId} FileTransferMeta {fileId, fileName, filePath, fileSize, chunkSize, fileInline} = do + currentTs <- getCurrentTime + let fileStatus = FSConnected + fileInline' = Just $ fromMaybe IFMOffer fileInline + DB.execute + db + "INSERT INTO snd_files (file_id, file_status, file_inline, connection_id, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)" + (fileId, fileStatus, fileInline', connId, groupMemberId, currentTs, currentTs) + pure SndFileTransfer {fileId, fileName, filePath, fileSize, chunkSize, recipientDisplayName = n, connId, agentConnId, groupMemberId = Just groupMemberId, fileStatus, fileDescrId = Nothing, fileInline = fileInline'} + +updateSndDirectFTDelivery :: DB.Connection -> Contact -> FileTransferMeta -> Int64 -> IO () +updateSndDirectFTDelivery db Contact {activeConn = Connection {connId}} FileTransferMeta {fileId} msgDeliveryId = + DB.execute + db + "UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_inline IS NOT NULL" + (msgDeliveryId, connId, fileId) + +updateSndGroupFTDelivery :: DB.Connection -> GroupMember -> Connection -> FileTransferMeta -> Int64 -> IO () +updateSndGroupFTDelivery db GroupMember {groupMemberId} Connection {connId} FileTransferMeta {fileId} msgDeliveryId = + DB.execute + db + "UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE group_member_id = ? AND connection_id = ? AND file_id = ? AND file_inline IS NOT NULL" + (msgDeliveryId, groupMemberId, connId, fileId) + +getSndFTViaMsgDelivery :: DB.Connection -> User -> Connection -> AgentMsgId -> IO (Maybe SndFileTransfer) +getSndFTViaMsgDelivery db User {userId} Connection {connId, agentConnId} agentMsgId = do + (sndFileTransfer_ <=< listToMaybe) + <$> DB.query + db + [sql| + SELECT s.file_id, s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.file_descr_id, s.file_inline, s.group_member_id, c.local_display_name, m.local_display_name + FROM msg_deliveries d + JOIN snd_files s ON s.connection_id = d.connection_id AND s.last_inline_msg_delivery_id = d.msg_delivery_id + JOIN files f ON f.file_id = s.file_id + LEFT JOIN contacts c USING (contact_id) + LEFT JOIN group_members m USING (group_member_id) + WHERE d.connection_id = ? AND d.agent_msg_id = ? AND f.user_id = ? + AND (s.file_descr_id IS NOT NULL OR s.file_inline IS NOT NULL) + |] + (connId, agentMsgId, userId) + where + sndFileTransfer_ :: (Int64, FileStatus, String, Integer, Integer, FilePath, Maybe Int64, Maybe InlineFileMode, Maybe Int64, Maybe ContactName, Maybe ContactName) -> Maybe SndFileTransfer + sndFileTransfer_ (fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, groupMemberId, contactName_, memberName_) = + (\n -> SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, groupMemberId, recipientDisplayName = n, connId, agentConnId}) + <$> (contactName_ <|> memberName_) + +createSndFileTransferXFTP :: DB.Connection -> User -> ContactOrGroup -> FilePath -> FileInvitation -> AgentSndFileId -> Integer -> IO FileTransferMeta +createSndFileTransferXFTP db User {userId} contactOrGroup filePath FileInvitation {fileName, fileSize} agentSndFileId chunkSize = do + currentTs <- getCurrentTime + let xftpSndFile = Just XFTPSndFile {agentSndFileId, privateSndFileDescr = Nothing, agentSndFileDeleted = False} + DB.execute + db + "INSERT INTO files (contact_id, group_id, user_id, file_name, file_path, file_size, chunk_size, agent_snd_file_id, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)" + (contactAndGroupIds contactOrGroup :. (userId, fileName, filePath, fileSize, chunkSize, agentSndFileId, CIFSSndStored, FPXFTP, currentTs, currentTs)) + fileId <- insertedRowId db + pure FileTransferMeta {fileId, xftpSndFile, fileName, filePath, fileSize, fileInline = Nothing, chunkSize, cancelled = False} + +createSndFTDescrXFTP :: DB.Connection -> User -> Maybe GroupMember -> Connection -> FileTransferMeta -> FileDescr -> IO () +createSndFTDescrXFTP db User {userId} m Connection {connId} FileTransferMeta {fileId} FileDescr {fileDescrText, fileDescrPartNo, fileDescrComplete} = do + currentTs <- getCurrentTime + let fileStatus = FSNew + DB.execute + db + "INSERT INTO xftp_file_descriptions (user_id, file_descr_text, file_descr_part_no, file_descr_complete, created_at, updated_at) VALUES (?,?,?,?,?,?)" + (userId, fileDescrText, fileDescrPartNo, fileDescrComplete, currentTs, currentTs) + fileDescrId <- insertedRowId db + DB.execute + db + "INSERT INTO snd_files (file_id, file_status, file_descr_id, group_member_id, connection_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)" + (fileId, fileStatus, fileDescrId, groupMemberId' <$> m, connId, currentTs, currentTs) + +setSndFTPrivateSndDescr :: DB.Connection -> User -> FileTransferId -> Text -> IO () +setSndFTPrivateSndDescr db User {userId} fileId sfdText = do + currentTs <- getCurrentTime + DB.execute + db + "UPDATE files SET private_snd_file_descr = ?, updated_at = ? WHERE user_id = ? AND file_id = ?" + (sfdText, currentTs, userId, fileId) + +updateSndFTDescrXFTP :: DB.Connection -> User -> SndFileTransfer -> Text -> IO () +updateSndFTDescrXFTP db user@User {userId} sft@SndFileTransfer {fileId, fileDescrId} rfdText = do + currentTs <- getCurrentTime + DB.execute + db + [sql| + UPDATE xftp_file_descriptions + SET file_descr_text = ?, file_descr_part_no = ?, file_descr_complete = ?, updated_at = ? + WHERE user_id = ? AND file_descr_id = ? + |] + (rfdText, 1 :: Int, True, currentTs, userId, fileDescrId) + updateCIFileStatus db user fileId $ CIFSSndTransfer 1 1 + updateSndFileStatus db sft FSConnected + +createExtraSndFTDescrs :: DB.Connection -> User -> FileTransferId -> [Text] -> IO () +createExtraSndFTDescrs db User {userId} fileId rfdTexts = do + currentTs <- getCurrentTime + forM_ rfdTexts $ \rfdText -> + DB.execute + db + "INSERT INTO extra_xftp_file_descriptions (file_id, user_id, file_descr_text, created_at, updated_at) VALUES (?,?,?,?,?)" + (fileId, userId, rfdText, currentTs, currentTs) + +updateSndFTDeliveryXFTP :: DB.Connection -> SndFileTransfer -> Int64 -> IO () +updateSndFTDeliveryXFTP db SndFileTransfer {connId, fileId, fileDescrId} msgDeliveryId = + DB.execute + db + "UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_descr_id = ?" + (msgDeliveryId, connId, fileId, fileDescrId) + +setSndFTAgentDeleted :: DB.Connection -> User -> FileTransferId -> IO () +setSndFTAgentDeleted db User {userId} fileId = do + currentTs <- getCurrentTime + DB.execute + db + "UPDATE files SET agent_snd_file_deleted = 1, updated_at = ? WHERE user_id = ? AND file_id = ?" + (currentTs, userId, fileId) + +getXFTPSndFileDBId :: DB.Connection -> User -> AgentSndFileId -> ExceptT StoreError IO FileTransferId +getXFTPSndFileDBId db User {userId} aSndFileId = + ExceptT . firstRow fromOnly (SESndFileNotFoundXFTP aSndFileId) $ + DB.query db "SELECT file_id FROM files WHERE user_id = ? AND agent_snd_file_id = ?" (userId, aSndFileId) + +getXFTPRcvFileDBId :: DB.Connection -> AgentRcvFileId -> ExceptT StoreError IO FileTransferId +getXFTPRcvFileDBId db aRcvFileId = + ExceptT . firstRow fromOnly (SERcvFileNotFoundXFTP aRcvFileId) $ + DB.query db "SELECT file_id FROM rcv_files WHERE agent_rcv_file_id = ?" (Only aRcvFileId) + +updateFileCancelled :: MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> IO () +updateFileCancelled db User {userId} fileId ciFileStatus = do + currentTs <- getCurrentTime + DB.execute db "UPDATE files SET cancelled = 1, ci_file_status = ?, updated_at = ? WHERE user_id = ? AND file_id = ?" (ciFileStatus, currentTs, userId, fileId) + +updateCIFileStatus :: MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> IO () +updateCIFileStatus db User {userId} fileId ciFileStatus = do + currentTs <- getCurrentTime + DB.execute db "UPDATE files SET ci_file_status = ?, updated_at = ? WHERE user_id = ? AND file_id = ?" (ciFileStatus, currentTs, userId, fileId) + +getSharedMsgIdByFileId :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO SharedMsgId +getSharedMsgIdByFileId db userId fileId = + ExceptT . firstRow fromOnly (SESharedMsgIdNotFoundByFileId fileId) $ + DB.query + db + [sql| + SELECT i.shared_msg_id + FROM chat_items i + JOIN files f ON f.chat_item_id = i.chat_item_id + WHERE f.user_id = ? AND f.file_id = ? + |] + (userId, fileId) + +getFileIdBySharedMsgId :: DB.Connection -> UserId -> Int64 -> SharedMsgId -> ExceptT StoreError IO Int64 +getFileIdBySharedMsgId db userId contactId sharedMsgId = + ExceptT . firstRow fromOnly (SEFileIdNotFoundBySharedMsgId sharedMsgId) $ + DB.query + db + [sql| + SELECT f.file_id + FROM files f + JOIN chat_items i ON i.chat_item_id = f.chat_item_id + WHERE i.user_id = ? AND i.contact_id = ? AND i.shared_msg_id = ? + |] + (userId, contactId, sharedMsgId) + +getGroupFileIdBySharedMsgId :: DB.Connection -> UserId -> Int64 -> SharedMsgId -> ExceptT StoreError IO Int64 +getGroupFileIdBySharedMsgId db userId groupId sharedMsgId = + ExceptT . firstRow fromOnly (SEFileIdNotFoundBySharedMsgId sharedMsgId) $ + DB.query + db + [sql| + SELECT f.file_id + FROM files f + JOIN chat_items i ON i.chat_item_id = f.chat_item_id + WHERE i.user_id = ? AND i.group_id = ? AND i.shared_msg_id = ? + |] + (userId, groupId, sharedMsgId) + +getDirectFileIdBySharedMsgId :: DB.Connection -> User -> Contact -> SharedMsgId -> ExceptT StoreError IO Int64 +getDirectFileIdBySharedMsgId db User {userId} Contact {contactId} sharedMsgId = + ExceptT . firstRow fromOnly (SEFileIdNotFoundBySharedMsgId sharedMsgId) $ + DB.query + db + [sql| + SELECT f.file_id + FROM files f + JOIN chat_items i ON i.chat_item_id = f.chat_item_id + WHERE i.user_id = ? AND i.contact_id = ? AND i.shared_msg_id = ? + |] + (userId, contactId, sharedMsgId) + +getChatRefByFileId :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO ChatRef +getChatRefByFileId db User {userId} fileId = + liftIO getChatRef >>= \case + [(Just contactId, Nothing)] -> pure $ ChatRef CTDirect contactId + [(Nothing, Just groupId)] -> pure $ ChatRef CTGroup groupId + _ -> throwError $ SEInternalError "could not retrieve chat ref by file id" + where + getChatRef = + DB.query + db + [sql| + SELECT contact_id, group_id + FROM files + WHERE user_id = ? AND file_id = ? + LIMIT 1 + |] + (userId, fileId) + +createSndFileConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> IO Connection +createSndFileConnection_ db userId fileId agentConnId = do + currentTs <- getCurrentTime + createConnection_ db userId ConnSndFile (Just fileId) agentConnId Nothing Nothing Nothing 0 currentTs + +updateSndFileStatus :: DB.Connection -> SndFileTransfer -> FileStatus -> IO () +updateSndFileStatus db SndFileTransfer {fileId, connId} status = do + currentTs <- getCurrentTime + DB.execute db "UPDATE snd_files SET file_status = ?, updated_at = ? WHERE file_id = ? AND connection_id = ?" (status, currentTs, fileId, connId) + +createSndFileChunk :: DB.Connection -> SndFileTransfer -> IO (Maybe Integer) +createSndFileChunk db SndFileTransfer {fileId, connId, fileSize, chunkSize} = do + chunkNo <- getLastChunkNo + insertChunk chunkNo + pure chunkNo + where + getLastChunkNo = do + ns <- DB.query db "SELECT chunk_number FROM snd_file_chunks WHERE file_id = ? AND connection_id = ? AND chunk_sent = 1 ORDER BY chunk_number DESC LIMIT 1" (fileId, connId) + pure $ case map fromOnly ns of + [] -> Just 1 + n : _ -> if n * chunkSize >= fileSize then Nothing else Just (n + 1) + insertChunk chunkNo_ = forM_ chunkNo_ $ \chunkNo -> do + currentTs <- getCurrentTime + DB.execute + db + "INSERT OR REPLACE INTO snd_file_chunks (file_id, connection_id, chunk_number, created_at, updated_at) VALUES (?,?,?,?,?)" + (fileId, connId, chunkNo, currentTs, currentTs) + +updateSndFileChunkMsg :: DB.Connection -> SndFileTransfer -> Integer -> AgentMsgId -> IO () +updateSndFileChunkMsg db SndFileTransfer {fileId, connId} chunkNo msgId = do + currentTs <- getCurrentTime + DB.execute + db + [sql| + UPDATE snd_file_chunks + SET chunk_agent_msg_id = ?, updated_at = ? + WHERE file_id = ? AND connection_id = ? AND chunk_number = ? + |] + (msgId, currentTs, fileId, connId, chunkNo) + +updateSndFileChunkSent :: DB.Connection -> SndFileTransfer -> AgentMsgId -> IO () +updateSndFileChunkSent db SndFileTransfer {fileId, connId} msgId = do + currentTs <- getCurrentTime + DB.execute + db + [sql| + UPDATE snd_file_chunks + SET chunk_sent = 1, updated_at = ? + WHERE file_id = ? AND connection_id = ? AND chunk_agent_msg_id = ? + |] + (currentTs, fileId, connId, msgId) + +deleteSndFileChunks :: DB.Connection -> SndFileTransfer -> IO () +deleteSndFileChunks db SndFileTransfer {fileId, connId} = + DB.execute db "DELETE FROM snd_file_chunks WHERE file_id = ? AND connection_id = ?" (fileId, connId) + +createRcvFileTransfer :: DB.Connection -> UserId -> Contact -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer +createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do + currentTs <- liftIO getCurrentTime + rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr + let rfdId = (fileDescrId :: RcvFileDescr -> Int64) <$> rfd_ + xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False}) <$> rfd_ + fileProtocol = if isJust rfd_ then FPXFTP else FPSMP + fileId <- liftIO $ do + DB.execute + db + "INSERT INTO files (user_id, contact_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?)" + (userId, contactId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, fileProtocol, currentTs, currentTs) + insertedRowId db + liftIO $ + DB.execute + db + "INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, file_descr_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" + (fileId, FSNew, fileConnReq, fileInline, rcvFileInline, rfdId, currentTs, currentTs) + pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing} + +createRcvGroupFileTransfer :: DB.Connection -> UserId -> GroupMember -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer +createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do + currentTs <- liftIO getCurrentTime + rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr + let rfdId = (fileDescrId :: RcvFileDescr -> Int64) <$> rfd_ + xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False}) <$> rfd_ + fileProtocol = if isJust rfd_ then FPXFTP else FPSMP + fileId <- liftIO $ do + DB.execute + db + "INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?)" + (userId, groupId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, fileProtocol, currentTs, currentTs) + insertedRowId db + liftIO $ + DB.execute + db + "INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, group_member_id, file_descr_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)" + (fileId, FSNew, fileConnReq, fileInline, rcvFileInline, groupMemberId, rfdId, currentTs, currentTs) + pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Just groupMemberId} + +createRcvFD_ :: DB.Connection -> UserId -> UTCTime -> FileDescr -> ExceptT StoreError IO RcvFileDescr +createRcvFD_ db userId currentTs FileDescr {fileDescrText, fileDescrPartNo, fileDescrComplete} = do + when (fileDescrPartNo /= 0) $ throwError SERcvFileInvalidDescrPart + fileDescrId <- liftIO $ do + DB.execute + db + "INSERT INTO xftp_file_descriptions (user_id, file_descr_text, file_descr_part_no, file_descr_complete, created_at, updated_at) VALUES (?,?,?,?,?,?)" + (userId, fileDescrText, fileDescrPartNo, fileDescrComplete, currentTs, currentTs) + insertedRowId db + pure RcvFileDescr {fileDescrId, fileDescrPartNo, fileDescrText, fileDescrComplete} + +appendRcvFD :: DB.Connection -> UserId -> FileTransferId -> FileDescr -> ExceptT StoreError IO RcvFileDescr +appendRcvFD db userId fileId fd@FileDescr {fileDescrText, fileDescrPartNo, fileDescrComplete} = do + currentTs <- liftIO getCurrentTime + liftIO (getRcvFileDescrByFileId_ db fileId) >>= \case + Nothing -> do + rfd@RcvFileDescr {fileDescrId} <- createRcvFD_ db userId currentTs fd + liftIO $ + DB.execute + db + "UPDATE rcv_files SET file_descr_id = ?, updated_at = ? WHERE file_id = ?" + (fileDescrId, currentTs, fileId) + pure rfd + Just + RcvFileDescr + { fileDescrId, + fileDescrText = rfdText, + fileDescrPartNo = rfdPNo, + fileDescrComplete = rfdComplete + } -> do + when (fileDescrPartNo /= rfdPNo + 1 || rfdComplete) $ throwError SERcvFileInvalidDescrPart + let fileDescrText' = rfdText <> fileDescrText + liftIO $ + DB.execute + db + [sql| + UPDATE xftp_file_descriptions + SET file_descr_text = ?, file_descr_part_no = ?, file_descr_complete = ? + WHERE file_descr_id = ? + |] + (fileDescrText', fileDescrPartNo, fileDescrComplete, fileDescrId) + pure RcvFileDescr {fileDescrId, fileDescrText = fileDescrText', fileDescrPartNo, fileDescrComplete} + +getRcvFileDescrByFileId :: DB.Connection -> FileTransferId -> ExceptT StoreError IO RcvFileDescr +getRcvFileDescrByFileId db fileId = do + liftIO (getRcvFileDescrByFileId_ db fileId) >>= \case + Nothing -> throwError $ SERcvFileDescrNotFound fileId + Just rfd -> pure rfd + +getRcvFileDescrByFileId_ :: DB.Connection -> FileTransferId -> IO (Maybe RcvFileDescr) +getRcvFileDescrByFileId_ db fileId = + maybeFirstRow toRcvFileDescr $ + DB.query + db + [sql| + SELECT d.file_descr_id, d.file_descr_text, d.file_descr_part_no, d.file_descr_complete + FROM xftp_file_descriptions d + JOIN rcv_files f ON f.file_descr_id = d.file_descr_id + WHERE f.file_id = ? + LIMIT 1 + |] + (Only fileId) + where + toRcvFileDescr :: (Int64, Text, Int, Bool) -> RcvFileDescr + toRcvFileDescr (fileDescrId, fileDescrText, fileDescrPartNo, fileDescrComplete) = + RcvFileDescr {fileDescrId, fileDescrText, fileDescrPartNo, fileDescrComplete} + +updateRcvFileAgentId :: DB.Connection -> FileTransferId -> Maybe AgentRcvFileId -> IO () +updateRcvFileAgentId db fileId aFileId = do + currentTs <- getCurrentTime + DB.execute db "UPDATE rcv_files SET agent_rcv_file_id = ?, updated_at = ? WHERE file_id = ?" (aFileId, currentTs, fileId) + +getRcvFileTransferById :: DB.Connection -> FileTransferId -> ExceptT StoreError IO (User, RcvFileTransfer) +getRcvFileTransferById db fileId = do + user <- getUserByFileId db fileId + (user,) <$> getRcvFileTransfer db user fileId + +getRcvFileTransfer :: DB.Connection -> User -> FileTransferId -> ExceptT StoreError IO RcvFileTransfer +getRcvFileTransfer db User {userId} fileId = do + rftRow <- + ExceptT . firstRow id (SERcvFileNotFound fileId) $ + DB.query + db + [sql| + SELECT r.file_status, r.file_queue_info, r.group_member_id, f.file_name, + f.file_size, f.chunk_size, f.cancelled, cs.local_display_name, m.local_display_name, + f.file_path, r.file_inline, r.rcv_file_inline, r.agent_rcv_file_id, r.agent_rcv_file_deleted, c.connection_id, c.agent_conn_id + FROM rcv_files r + JOIN files f USING (file_id) + LEFT JOIN connections c ON r.file_id = c.rcv_file_id + LEFT JOIN contacts cs USING (contact_id) + LEFT JOIN group_members m USING (group_member_id) + WHERE f.user_id = ? AND f.file_id = ? + |] + (userId, fileId) + rfd_ <- liftIO $ getRcvFileDescrByFileId_ db fileId + rcvFileTransfer rfd_ rftRow + where + rcvFileTransfer :: + Maybe RcvFileDescr -> + (FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe Bool) :. (Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe InlineFileMode, Maybe InlineFileMode, Maybe AgentRcvFileId, Bool) :. (Maybe Int64, Maybe AgentConnId) -> + ExceptT StoreError IO RcvFileTransfer + rcvFileTransfer rfd_ ((fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_) :. (contactName_, memberName_, filePath_, fileInline, rcvFileInline, agentRcvFileId, agentRcvFileDeleted) :. (connId_, agentConnId_)) = + case contactName_ <|> memberName_ of + Nothing -> throwError $ SERcvFileInvalid fileId + Just name -> do + case fileStatus' of + FSNew -> pure $ ft name RFSNew + FSAccepted -> ft name . RFSAccepted <$> rfi + FSConnected -> ft name . RFSConnected <$> rfi + FSComplete -> ft name . RFSComplete <$> rfi + FSCancelled -> ft name . RFSCancelled <$> rfi_ + where + ft senderDisplayName fileStatus = + let fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq, fileInline, fileDescr = Nothing} + xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId, agentRcvFileDeleted}) <$> rfd_ + in RcvFileTransfer {fileId, xftpRcvFile, fileInvitation, fileStatus, rcvFileInline, senderDisplayName, chunkSize, cancelled, grpMemberId} + rfi = maybe (throwError $ SERcvFileInvalid fileId) pure =<< rfi_ + rfi_ = case (filePath_, connId_, agentConnId_) of + (Just filePath, connId, agentConnId) -> pure $ Just RcvFileInfo {filePath, connId, agentConnId} + _ -> pure Nothing + cancelled = fromMaybe False cancelled_ + +acceptRcvFileTransfer :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> ConnStatus -> FilePath -> ExceptT StoreError IO AChatItem +acceptRcvFileTransfer db user@User {userId} fileId (cmdId, acId) connStatus filePath = ExceptT $ do + currentTs <- getCurrentTime + acceptRcvFT_ db user fileId filePath Nothing currentTs + DB.execute + db + "INSERT INTO connections (agent_conn_id, conn_status, conn_type, rcv_file_id, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)" + (acId, connStatus, ConnRcvFile, fileId, userId, currentTs, currentTs) + connId <- insertedRowId db + setCommandConnId db user cmdId connId + runExceptT $ getChatItemByFileId db user fileId + +getContactByFileId :: DB.Connection -> User -> FileTransferId -> ExceptT StoreError IO Contact +getContactByFileId db user@User {userId} fileId = do + cId <- getContactIdByFileId + getContact db user cId + where + getContactIdByFileId = + ExceptT . firstRow fromOnly (SEContactNotFoundByFileId fileId) $ + DB.query db "SELECT contact_id FROM files WHERE user_id = ? AND file_id = ?" (userId, fileId) + +acceptRcvInlineFT :: DB.Connection -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem +acceptRcvInlineFT db user fileId filePath = do + liftIO $ acceptRcvFT_ db user fileId filePath (Just IFMOffer) =<< getCurrentTime + getChatItemByFileId db user fileId + +startRcvInlineFT :: DB.Connection -> User -> RcvFileTransfer -> FilePath -> Maybe InlineFileMode -> IO () +startRcvInlineFT db user RcvFileTransfer {fileId} filePath rcvFileInline = + acceptRcvFT_ db user fileId filePath rcvFileInline =<< getCurrentTime + +xftpAcceptRcvFT :: DB.Connection -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem +xftpAcceptRcvFT db user fileId filePath = do + liftIO $ acceptRcvFT_ db user fileId filePath Nothing =<< getCurrentTime + getChatItemByFileId db user fileId + +acceptRcvFT_ :: DB.Connection -> User -> FileTransferId -> FilePath -> Maybe InlineFileMode -> UTCTime -> IO () +acceptRcvFT_ db User {userId} fileId filePath rcvFileInline currentTs = do + DB.execute + db + "UPDATE files SET file_path = ?, ci_file_status = ?, updated_at = ? WHERE user_id = ? AND file_id = ?" + (filePath, CIFSRcvAccepted, currentTs, userId, fileId) + DB.execute + db + "UPDATE rcv_files SET rcv_file_inline = ?, file_status = ?, updated_at = ? WHERE file_id = ?" + (rcvFileInline, FSAccepted, currentTs, fileId) + +setRcvFileToReceive :: DB.Connection -> FileTransferId -> IO () +setRcvFileToReceive db fileId = do + currentTs <- getCurrentTime + DB.execute + db + "UPDATE rcv_files SET to_receive = 1, updated_at = ? WHERE file_id = ?" + (currentTs, fileId) + +getRcvFilesToReceive :: DB.Connection -> User -> IO [RcvFileTransfer] +getRcvFilesToReceive db user@User {userId} = do + cutoffTs <- addUTCTime (- (2 * nominalDay)) <$> getCurrentTime + fileIds :: [Int64] <- + map fromOnly + <$> DB.query + db + [sql| + SELECT r.file_id + FROM rcv_files r + JOIN files f ON f.file_id = r.file_id + WHERE f.user_id = ? AND r.file_status = ? + AND r.to_receive = 1 AND r.created_at > ? + |] + (userId, FSNew, cutoffTs) + rights <$> mapM (runExceptT . getRcvFileTransfer db user) fileIds + +setRcvFTAgentDeleted :: DB.Connection -> FileTransferId -> IO () +setRcvFTAgentDeleted db fileId = do + currentTs <- getCurrentTime + DB.execute + db + "UPDATE rcv_files SET agent_rcv_file_deleted = 1, updated_at = ? WHERE file_id = ?" + (currentTs, fileId) + +updateRcvFileStatus :: DB.Connection -> FileTransferId -> FileStatus -> IO () +updateRcvFileStatus db fileId status = do + currentTs <- getCurrentTime + DB.execute db "UPDATE rcv_files SET file_status = ?, updated_at = ? WHERE file_id = ?" (status, currentTs, fileId) + +createRcvFileChunk :: DB.Connection -> RcvFileTransfer -> Integer -> AgentMsgId -> IO RcvChunkStatus +createRcvFileChunk db RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileSize}, chunkSize} chunkNo msgId = do + status <- getLastChunkNo + unless (status == RcvChunkError) $ do + currentTs <- getCurrentTime + DB.execute + db + "INSERT OR REPLACE INTO rcv_file_chunks (file_id, chunk_number, chunk_agent_msg_id, created_at, updated_at) VALUES (?,?,?,?,?)" + (fileId, chunkNo, msgId, currentTs, currentTs) + pure status + where + getLastChunkNo = do + ns <- DB.query db "SELECT chunk_number FROM rcv_file_chunks WHERE file_id = ? ORDER BY chunk_number DESC LIMIT 1" (Only fileId) + pure $ case map fromOnly ns of + [] + | chunkNo == 1 -> + if chunkSize >= fileSize + then RcvChunkFinal + else RcvChunkOk + | otherwise -> RcvChunkError + n : _ + | chunkNo == n -> RcvChunkDuplicate + | chunkNo == n + 1 -> + let prevSize = n * chunkSize + in if prevSize >= fileSize + then RcvChunkError + else + if prevSize + chunkSize >= fileSize + then RcvChunkFinal + else RcvChunkOk + | otherwise -> RcvChunkError + +updatedRcvFileChunkStored :: DB.Connection -> RcvFileTransfer -> Integer -> IO () +updatedRcvFileChunkStored db RcvFileTransfer {fileId} chunkNo = do + currentTs <- getCurrentTime + DB.execute + db + [sql| + UPDATE rcv_file_chunks + SET chunk_stored = 1, updated_at = ? + WHERE file_id = ? AND chunk_number = ? + |] + (currentTs, fileId, chunkNo) + +deleteRcvFileChunks :: DB.Connection -> RcvFileTransfer -> IO () +deleteRcvFileChunks db RcvFileTransfer {fileId} = + DB.execute db "DELETE FROM rcv_file_chunks WHERE file_id = ?" (Only fileId) + +updateFileTransferChatItemId :: DB.Connection -> FileTransferId -> ChatItemId -> UTCTime -> IO () +updateFileTransferChatItemId db fileId ciId currentTs = + DB.execute db "UPDATE files SET chat_item_id = ?, updated_at = ? WHERE file_id = ?" (ciId, currentTs, fileId) + +getFileTransferProgress :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO (FileTransfer, [Integer]) +getFileTransferProgress db user fileId = do + ft <- getFileTransfer db user fileId + liftIO $ + (ft,) . map fromOnly <$> case ft of + FTSnd _ [] -> pure [Only 0] + FTSnd _ _ -> DB.query db "SELECT COUNT(*) FROM snd_file_chunks WHERE file_id = ? and chunk_sent = 1 GROUP BY connection_id" (Only fileId) + FTRcv _ -> DB.query db "SELECT COUNT(*) FROM rcv_file_chunks WHERE file_id = ? AND chunk_stored = 1" (Only fileId) + +getFileTransfer :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO FileTransfer +getFileTransfer db user@User {userId} fileId = + fileTransfer =<< liftIO getFileTransferRow + where + fileTransfer :: [(Maybe Int64, Maybe Int64)] -> ExceptT StoreError IO FileTransfer + fileTransfer [(Nothing, Just _)] = FTRcv <$> getRcvFileTransfer db user fileId + fileTransfer _ = do + (ftm, fts) <- getSndFileTransfer db user fileId + pure $ FTSnd {fileTransferMeta = ftm, sndFileTransfers = fts} + getFileTransferRow :: IO [(Maybe Int64, Maybe Int64)] + getFileTransferRow = + DB.query + db + [sql| + SELECT s.file_id, r.file_id + FROM files f + LEFT JOIN snd_files s ON s.file_id = f.file_id + LEFT JOIN rcv_files r ON r.file_id = f.file_id + WHERE user_id = ? AND f.file_id = ? + |] + (userId, fileId) + +getSndFileTransfer :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO (FileTransferMeta, [SndFileTransfer]) +getSndFileTransfer db user fileId = do + fileTransferMeta <- getFileTransferMeta db user fileId + sndFileTransfers <- getSndFileTransfers db user fileId + pure (fileTransferMeta, sndFileTransfers) + +getSndFileTransfers :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO [SndFileTransfer] +getSndFileTransfers db User {userId} fileId = ExceptT $ getSndFileTransfers_ db userId fileId + +getSndFileTransfers_ :: DB.Connection -> UserId -> Int64 -> IO (Either StoreError [SndFileTransfer]) +getSndFileTransfers_ db userId fileId = + mapM sndFileTransfer + <$> DB.query + db + [sql| + SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.file_descr_id, s.file_inline, s.connection_id, c.agent_conn_id, s.group_member_id, + cs.local_display_name, m.local_display_name + FROM snd_files s + JOIN files f USING (file_id) + JOIN connections c USING (connection_id) + LEFT JOIN contacts cs USING (contact_id) + LEFT JOIN group_members m USING (group_member_id) + WHERE f.user_id = ? AND f.file_id = ? + |] + (userId, fileId) + where + sndFileTransfer :: (FileStatus, String, Integer, Integer, FilePath) :. (Maybe Int64, Maybe InlineFileMode, Int64, AgentConnId, Maybe Int64, Maybe ContactName, Maybe ContactName) -> Either StoreError SndFileTransfer + sndFileTransfer ((fileStatus, fileName, fileSize, chunkSize, filePath) :. (fileDescrId, fileInline, connId, agentConnId, groupMemberId, contactName_, memberName_)) = + case contactName_ <|> memberName_ of + Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, recipientDisplayName, connId, agentConnId, groupMemberId} + Nothing -> Left $ SESndFileInvalid fileId + +getFileTransferMeta :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO FileTransferMeta +getFileTransferMeta db User {userId} fileId = + ExceptT . firstRow fileTransferMeta (SEFileNotFound fileId) $ + DB.query + db + [sql| + SELECT file_name, file_size, chunk_size, file_path, file_inline, agent_snd_file_id, agent_snd_file_deleted, private_snd_file_descr, cancelled + FROM files + WHERE user_id = ? AND file_id = ? + |] + (userId, fileId) + where + fileTransferMeta :: (String, Integer, Integer, FilePath, Maybe InlineFileMode, Maybe AgentSndFileId, Bool, Maybe Text, Maybe Bool) -> FileTransferMeta + fileTransferMeta (fileName, fileSize, chunkSize, filePath, fileInline, aSndFileId_, agentSndFileDeleted, privateSndFileDescr, cancelled_) = + let xftpSndFile = (\fId -> XFTPSndFile {agentSndFileId = fId, privateSndFileDescr, agentSndFileDeleted}) <$> aSndFileId_ + in FileTransferMeta {fileId, xftpSndFile, fileName, fileSize, chunkSize, filePath, fileInline, cancelled = fromMaybe False cancelled_} + +getContactFileInfo :: DB.Connection -> User -> Contact -> IO [CIFileInfo] +getContactFileInfo db User {userId} Contact {contactId} = + map toFileInfo + <$> DB.query db (fileInfoQuery <> " WHERE i.user_id = ? AND i.contact_id = ?") (userId, contactId) + +updateDirectCIFileStatus :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> ExceptT StoreError IO AChatItem +updateDirectCIFileStatus db user fileId fileStatus = do + aci@(AChatItem cType d cInfo ci) <- getChatItemByFileId db user fileId + case (cType, testEquality d $ msgDirection @d) of + (SCTDirect, Just Refl) -> do + liftIO $ updateCIFileStatus db user fileId fileStatus + pure $ AChatItem SCTDirect d cInfo $ updateFileStatus ci fileStatus + _ -> pure aci diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs new file mode 100644 index 000000000..7a09df5ab --- /dev/null +++ b/src/Simplex/Chat/Store/Groups.hs @@ -0,0 +1,1295 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} + +module Simplex.Chat.Store.Groups + ( -- * Util methods + GroupInfoRow, + GroupMemberRow, + MaybeGroupMemberRow, + toGroupInfo, + toGroupMember, + toMaybeGroupMember, + -- * Group functions + createGroupLink, + getGroupLinkConnection, + deleteGroupLink, + getGroupLink, + getGroupLinkId, + setGroupLinkMemberRole, + getGroupAndMember, + createNewGroup, + createGroupInvitation, + setGroupInvitationChatItemId, + getGroup, + getGroupInfo, + updateGroupProfile, + getGroupIdByName, + getGroupMemberIdByName, + getGroupInfoByName, + getGroupMember, + getGroupMemberById, + getGroupMembers, + getGroupMembersForExpiration, + deleteGroupConnectionsAndFiles, + deleteGroupItemsAndMembers, + deleteGroup, + getUserGroups, + getUserGroupDetails, + getContactGroupPreferences, + checkContactHasGroups, + getGroupInvitation, + createNewContactMember, + createNewContactMemberAsync, + getContactViaMember, + setNewContactMemberConnRequest, + getMemberInvitation, + createMemberConnection, + createMemberConnectionAsync, + updateGroupMemberStatus, + updateGroupMemberStatusById, + createNewGroupMember, + checkGroupMemberHasItems, + deleteGroupMember, + deleteGroupMemberConnection, + updateGroupMemberRole, + createIntroductions, + updateIntroStatus, + saveIntroInvitation, + createIntroReMember, + createIntroToMemberContact, + saveMemberInvitation, + getViaGroupMember, + getViaGroupContact, + getMatchingContacts, + createSentProbe, + createSentProbeHash, + deleteSentProbe, + matchReceivedProbe, + matchReceivedProbeHash, + matchSentProbe, + mergeContactRecords, + updateGroupSettings, + getXGrpMemIntroContDirect, + getXGrpMemIntroContGroup, + ) +where + +import Control.Monad.Except +import Crypto.Random (ChaChaDRG) +import Data.Either (rights) +import Data.Int (Int64) +import Data.Maybe (fromMaybe, isNothing) +import Data.Text (Text) +import Data.Time.Clock (UTCTime (..), getCurrentTime) +import Database.SQLite.Simple (NamedParam (..), Only (..), Query (..), (:.) (..)) +import qualified Database.SQLite.Simple as DB +import Database.SQLite.Simple.QQ (sql) +import Simplex.Chat.Messages +import Simplex.Chat.Store.Direct +import Simplex.Chat.Store.Shared +import Simplex.Chat.Types +import Simplex.Messaging.Agent.Protocol (ConnId, UserId) +import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Util (eitherToMaybe) +import UnliftIO.STM + +type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe Text, Maybe ImageData, Maybe ProfileId, Maybe Bool, Maybe GroupPreferences, UTCTime, UTCTime, Maybe UTCTime) :. GroupMemberRow + +type GroupMemberRow = ((Int64, Int64, MemberId, GroupMemberRole, GroupMemberCategory, GroupMemberStatus) :. (Maybe Int64, ContactName, Maybe ContactId, ProfileId, ProfileId, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Preferences)) + +type MaybeGroupMemberRow = ((Maybe Int64, Maybe Int64, Maybe MemberId, Maybe GroupMemberRole, Maybe GroupMemberCategory, Maybe GroupMemberStatus) :. (Maybe Int64, Maybe ContactName, Maybe ContactId, Maybe ProfileId, Maybe ProfileId, Maybe ContactName, Maybe Text, Maybe ImageData, Maybe ConnReqContact, Maybe LocalAlias, Maybe Preferences)) + +toGroupInfo :: Int64 -> GroupInfoRow -> GroupInfo +toGroupInfo userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, groupPreferences, createdAt, updatedAt, chatTs) :. userMemberRow) = + let membership = toGroupMember userContactId userMemberRow + chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_} + fullGroupPreferences = mergeGroupPreferences groupPreferences + groupProfile = GroupProfile {displayName, fullName, description, image, groupPreferences} + in GroupInfo {groupId, localDisplayName, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId, chatSettings, createdAt, updatedAt, chatTs} + +toGroupMember :: Int64 -> GroupMemberRow -> GroupMember +toGroupMember userContactId ((groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus) :. (invitedById, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, preferences)) = + let memberProfile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} + invitedBy = toInvitedBy userContactId invitedById + activeConn = Nothing + in GroupMember {..} + +toMaybeGroupMember :: Int64 -> MaybeGroupMemberRow -> Maybe GroupMember +toMaybeGroupMember userContactId ((Just groupMemberId, Just groupId, Just memberId, Just memberRole, Just memberCategory, Just memberStatus) :. (invitedById, Just localDisplayName, memberContactId, Just memberContactProfileId, Just profileId, Just displayName, Just fullName, image, contactLink, Just localAlias, contactPreferences)) = + Just $ toGroupMember userContactId ((groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus) :. (invitedById, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, contactPreferences)) +toMaybeGroupMember _ _ = Nothing + +createGroupLink :: DB.Connection -> User -> GroupInfo -> ConnId -> ConnReqContact -> GroupLinkId -> GroupMemberRole -> ExceptT StoreError IO () +createGroupLink db User {userId} groupInfo@GroupInfo {groupId, localDisplayName} agentConnId cReq groupLinkId memberRole = + checkConstraint (SEDuplicateGroupLink groupInfo) . liftIO $ do + currentTs <- getCurrentTime + DB.execute + db + "INSERT INTO user_contact_links (user_id, group_id, group_link_id, local_display_name, conn_req_contact, group_link_member_role, auto_accept, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)" + (userId, groupId, groupLinkId, "group_link_" <> localDisplayName, cReq, memberRole, True, currentTs, currentTs) + userContactLinkId <- insertedRowId db + void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId Nothing Nothing Nothing 0 currentTs + +getGroupLinkConnection :: DB.Connection -> User -> GroupInfo -> ExceptT StoreError IO Connection +getGroupLinkConnection db User {userId} groupInfo@GroupInfo {groupId} = + ExceptT . firstRow toConnection (SEGroupLinkNotFound groupInfo) $ + DB.query + db + [sql| + SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, + c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter + FROM connections c + JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id + WHERE c.user_id = ? AND uc.user_id = ? AND uc.group_id = ? + |] + (userId, userId, groupId) + +deleteGroupLink :: DB.Connection -> User -> GroupInfo -> IO () +deleteGroupLink db User {userId} GroupInfo {groupId} = do + DB.execute + db + [sql| + DELETE FROM connections WHERE connection_id IN ( + SELECT connection_id + FROM connections c + JOIN user_contact_links uc USING (user_contact_link_id) + WHERE uc.user_id = ? AND uc.group_id = ? + ) + |] + (userId, groupId) + DB.execute + db + [sql| + DELETE FROM display_names + WHERE user_id = ? + AND local_display_name in ( + SELECT cr.local_display_name + FROM contact_requests cr + JOIN user_contact_links uc USING (user_contact_link_id) + WHERE uc.user_id = ? AND uc.group_id = ? + ) + |] + (userId, userId, groupId) + DB.execute + db + [sql| + DELETE FROM contact_profiles + WHERE contact_profile_id in ( + SELECT cr.contact_profile_id + FROM contact_requests cr + JOIN user_contact_links uc USING (user_contact_link_id) + WHERE uc.user_id = ? AND uc.group_id = ? + ) + |] + (userId, groupId) + DB.execute db "DELETE FROM user_contact_links WHERE user_id = ? AND group_id = ?" (userId, groupId) + +getGroupLink :: DB.Connection -> User -> GroupInfo -> ExceptT StoreError IO (Int64, ConnReqContact, GroupMemberRole) +getGroupLink db User {userId} gInfo@GroupInfo {groupId} = + ExceptT . firstRow groupLink (SEGroupLinkNotFound gInfo) $ + DB.query db "SELECT user_contact_link_id, conn_req_contact, group_link_member_role FROM user_contact_links WHERE user_id = ? AND group_id = ? LIMIT 1" (userId, groupId) + where + groupLink (linkId, cReq, mRole_) = (linkId, cReq, fromMaybe GRMember mRole_) + +getGroupLinkId :: DB.Connection -> User -> GroupInfo -> IO (Maybe GroupLinkId) +getGroupLinkId db User {userId} GroupInfo {groupId} = + fmap join . maybeFirstRow fromOnly $ + DB.query db "SELECT group_link_id FROM user_contact_links WHERE user_id = ? AND group_id = ? LIMIT 1" (userId, groupId) + +setGroupLinkMemberRole :: DB.Connection -> User -> Int64 -> GroupMemberRole -> IO () +setGroupLinkMemberRole db User {userId} userContactLinkId memberRole = + DB.execute db "UPDATE user_contact_links SET group_link_member_role = ? WHERE user_id = ? AND user_contact_link_id = ?" (memberRole, userId, userContactLinkId) + +getGroupAndMember :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO (GroupInfo, GroupMember) +getGroupAndMember db User {userId, userContactId} groupMemberId = + ExceptT . firstRow toGroupAndMember (SEInternalError "referenced group member not found") $ + DB.query + db + [sql| + SELECT + -- GroupInfo + g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, + -- GroupInfo {membership} + mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, + mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, + -- GroupInfo {membership = GroupMember {memberProfile}} + pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences, + -- from GroupMember + m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, + m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, + c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, + c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter + FROM group_members m + JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) + JOIN groups g ON g.group_id = m.group_id + JOIN group_profiles gp USING (group_profile_id) + JOIN group_members mu ON g.group_id = mu.group_id + JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) + LEFT JOIN connections c ON c.connection_id = ( + SELECT max(cc.connection_id) + FROM connections cc + where cc.group_member_id = m.group_member_id + ) + WHERE m.group_member_id = ? AND g.user_id = ? AND mu.contact_id = ? + |] + (groupMemberId, userId, userContactId) + where + toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember) + toGroupAndMember (groupInfoRow :. memberRow :. connRow) = + let groupInfo = toGroupInfo userContactId groupInfoRow + member = toGroupMember userContactId memberRow + in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow}) + +-- | creates completely new group with a single member - the current user +createNewGroup :: DB.Connection -> TVar ChaChaDRG -> User -> GroupProfile -> ExceptT StoreError IO GroupInfo +createNewGroup db gVar user@User {userId} groupProfile = ExceptT $ do + let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile + fullGroupPreferences = mergeGroupPreferences groupPreferences + currentTs <- getCurrentTime + withLocalDisplayName db userId displayName $ \ldn -> runExceptT $ do + groupId <- liftIO $ do + DB.execute + db + "INSERT INTO group_profiles (display_name, full_name, description, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" + (displayName, fullName, description, image, userId, groupPreferences, currentTs, currentTs) + profileId <- insertedRowId db + DB.execute + db + "INSERT INTO groups (local_display_name, user_id, group_profile_id, enable_ntfs, created_at, updated_at, chat_ts) VALUES (?,?,?,?,?,?,?)" + (ldn, userId, profileId, True, currentTs, currentTs, currentTs) + insertedRowId db + memberId <- liftIO $ encodedRandomBytes gVar 12 + membership <- createContactMemberInv_ db user groupId user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser Nothing currentTs + let chatSettings = ChatSettings {enableNtfs = True} + pure GroupInfo {groupId, localDisplayName = ldn, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId = Nothing, chatSettings, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs} + +-- | creates a new group record for the group the current user was invited to, or returns an existing one +createGroupInvitation :: DB.Connection -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> ExceptT StoreError IO (GroupInfo, GroupMemberId) +createGroupInvitation db user@User {userId} contact@Contact {contactId, activeConn = Connection {customUserProfileId}} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile} incognitoProfileId = do + liftIO getInvitationGroupId_ >>= \case + Nothing -> createGroupInvitation_ + Just gId -> do + gInfo@GroupInfo {membership, groupProfile = p'} <- getGroupInfo db user gId + hostId <- getHostMemberId_ db user gId + let GroupMember {groupMemberId, memberId, memberRole} = membership + MemberIdRole {memberId = memberId', memberRole = memberRole'} = invitedMember + liftIO . when (memberId /= memberId' || memberRole /= memberRole') $ + DB.execute db "UPDATE group_members SET member_id = ?, member_role = ? WHERE group_member_id = ?" (memberId', memberRole', groupMemberId) + gInfo' <- + if p' == groupProfile + then pure gInfo + else updateGroupProfile db user gInfo groupProfile + pure (gInfo', hostId) + where + getInvitationGroupId_ :: IO (Maybe Int64) + getInvitationGroupId_ = + maybeFirstRow fromOnly $ + DB.query db "SELECT group_id FROM groups WHERE inv_queue_info = ? AND user_id = ? LIMIT 1" (connRequest, userId) + createGroupInvitation_ :: ExceptT StoreError IO (GroupInfo, GroupMemberId) + createGroupInvitation_ = do + let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile + fullGroupPreferences = mergeGroupPreferences groupPreferences + ExceptT $ + withLocalDisplayName db userId displayName $ \localDisplayName -> runExceptT $ do + currentTs <- liftIO getCurrentTime + groupId <- liftIO $ do + DB.execute + db + "INSERT INTO group_profiles (display_name, full_name, description, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" + (displayName, fullName, description, image, userId, groupPreferences, currentTs, currentTs) + profileId <- insertedRowId db + DB.execute + db + "INSERT INTO groups (group_profile_id, local_display_name, inv_queue_info, host_conn_custom_user_profile_id, user_id, enable_ntfs, created_at, updated_at, chat_ts) VALUES (?,?,?,?,?,?,?,?,?)" + (profileId, localDisplayName, connRequest, customUserProfileId, userId, True, currentTs, currentTs, currentTs) + insertedRowId db + GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId contact fromMember GCHostMember GSMemInvited IBUnknown Nothing currentTs + membership <- createContactMemberInv_ db user groupId user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfileId currentTs + let chatSettings = ChatSettings {enableNtfs = True} + pure (GroupInfo {groupId, localDisplayName, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId = customUserProfileId, chatSettings, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs}, groupMemberId) + +getHostMemberId_ :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO GroupMemberId +getHostMemberId_ db User {userId} groupId = + ExceptT . firstRow fromOnly (SEHostMemberIdNotFound groupId) $ + DB.query db "SELECT group_member_id FROM group_members WHERE user_id = ? AND group_id = ? AND member_category = ?" (userId, groupId, GCHostMember) + +createContactMemberInv_ :: IsContact a => DB.Connection -> User -> GroupId -> a -> MemberIdRole -> GroupMemberCategory -> GroupMemberStatus -> InvitedBy -> Maybe ProfileId -> UTCTime -> ExceptT StoreError IO GroupMember +createContactMemberInv_ db User {userId, userContactId} groupId userOrContact MemberIdRole {memberId, memberRole} memberCategory memberStatus invitedBy incognitoProfileId createdAt = do + incognitoProfile <- forM incognitoProfileId $ \profileId -> getProfileById db userId profileId + (localDisplayName, memberProfile) <- case (incognitoProfile, incognitoProfileId) of + (Just profile@LocalProfile {displayName}, Just profileId) -> + (,profile) <$> insertMemberIncognitoProfile_ displayName profileId + _ -> (,profile' userOrContact) <$> liftIO insertMember_ + groupMemberId <- liftIO $ insertedRowId db + pure + GroupMember + { groupMemberId, + groupId, + memberId, + memberRole, + memberCategory, + memberStatus, + invitedBy, + localDisplayName, + memberProfile, + memberContactId = Just $ contactId' userOrContact, + memberContactProfileId = localProfileId (profile' userOrContact), + activeConn = Nothing + } + where + insertMember_ :: IO ContactName + insertMember_ = do + let localDisplayName = localDisplayName' userOrContact + DB.execute + db + [sql| + INSERT INTO group_members + ( group_id, member_id, member_role, member_category, member_status, invited_by, + user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?) + |] + ( (groupId, memberId, memberRole, memberCategory, memberStatus, fromInvitedBy userContactId invitedBy) + :. (userId, localDisplayName' userOrContact, contactId' userOrContact, localProfileId $ profile' userOrContact, createdAt, createdAt) + ) + pure localDisplayName + insertMemberIncognitoProfile_ :: ContactName -> ProfileId -> ExceptT StoreError IO ContactName + insertMemberIncognitoProfile_ incognitoDisplayName customUserProfileId = ExceptT $ + withLocalDisplayName db userId incognitoDisplayName $ \incognitoLdn -> do + DB.execute + db + [sql| + INSERT INTO group_members + ( group_id, member_id, member_role, member_category, member_status, invited_by, + user_id, local_display_name, contact_id, contact_profile_id, member_profile_id, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?) + |] + ( (groupId, memberId, memberRole, memberCategory, memberStatus, fromInvitedBy userContactId invitedBy) + :. (userId, incognitoLdn, contactId' userOrContact, localProfileId $ profile' userOrContact, customUserProfileId, createdAt, createdAt) + ) + pure $ Right incognitoLdn + +setGroupInvitationChatItemId :: DB.Connection -> User -> GroupId -> ChatItemId -> IO () +setGroupInvitationChatItemId db User {userId} groupId chatItemId = do + currentTs <- getCurrentTime + DB.execute db "UPDATE groups SET chat_item_id = ?, updated_at = ? WHERE user_id = ? AND group_id = ?" (chatItemId, currentTs, userId, groupId) + +-- TODO return the last connection that is ready, not any last connection +-- requires updating connection status +getGroup :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO Group +getGroup db user groupId = do + gInfo <- getGroupInfo db user groupId + members <- liftIO $ getGroupMembers db user gInfo + pure $ Group gInfo members + +deleteGroupConnectionsAndFiles :: DB.Connection -> User -> GroupInfo -> [GroupMember] -> IO () +deleteGroupConnectionsAndFiles db User {userId} GroupInfo {groupId} members = do + forM_ members $ \m -> DB.execute db "DELETE FROM connections WHERE user_id = ? AND group_member_id = ?" (userId, groupMemberId' m) + DB.execute db "DELETE FROM files WHERE user_id = ? AND group_id = ?" (userId, groupId) + +deleteGroupItemsAndMembers :: DB.Connection -> User -> GroupInfo -> [GroupMember] -> IO () +deleteGroupItemsAndMembers db user@User {userId} GroupInfo {groupId} members = do + DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND group_id = ?" (userId, groupId) + void $ runExceptT cleanupHostGroupLinkConn_ -- to allow repeat connection via the same group link if one was used + DB.execute db "DELETE FROM group_members WHERE user_id = ? AND group_id = ?" (userId, groupId) + forM_ members $ \m@GroupMember {memberProfile = LocalProfile {profileId}} -> do + cleanupMemberProfileAndName_ db user m + when (memberIncognito m) $ deleteUnusedIncognitoProfileById_ db user profileId + where + cleanupHostGroupLinkConn_ = do + hostId <- getHostMemberId_ db user groupId + liftIO $ + DB.execute + db + [sql| + UPDATE connections SET via_contact_uri_hash = NULL, xcontact_id = NULL + WHERE user_id = ? AND via_group_link = 1 AND contact_id IN ( + SELECT contact_id + FROM group_members + WHERE user_id = ? AND group_member_id = ? + ) + |] + (userId, userId, hostId) + +deleteGroup :: DB.Connection -> User -> GroupInfo -> IO () +deleteGroup db user@User {userId} GroupInfo {groupId, localDisplayName, membership = membership@GroupMember {memberProfile = LocalProfile {profileId}}} = do + deleteGroupProfile_ db userId groupId + DB.execute db "DELETE FROM groups WHERE user_id = ? AND group_id = ?" (userId, groupId) + DB.execute db "DELETE FROM display_names WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName) + when (memberIncognito membership) $ deleteUnusedIncognitoProfileById_ db user profileId + +deleteGroupProfile_ :: DB.Connection -> UserId -> GroupId -> IO () +deleteGroupProfile_ db userId groupId = + DB.execute + db + [sql| + DELETE FROM group_profiles + WHERE group_profile_id in ( + SELECT group_profile_id + FROM groups + WHERE user_id = ? AND group_id = ? + ) + |] + (userId, groupId) + +getUserGroups :: DB.Connection -> User -> IO [Group] +getUserGroups db user@User {userId} = do + groupIds <- map fromOnly <$> DB.query db "SELECT group_id FROM groups WHERE user_id = ?" (Only userId) + rights <$> mapM (runExceptT . getGroup db user) groupIds + +getUserGroupDetails :: DB.Connection -> User -> IO [GroupInfo] +getUserGroupDetails db User {userId, userContactId} = + map (toGroupInfo userContactId) + <$> DB.query + db + [sql| + SELECT g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, + mu.group_member_id, g.group_id, mu.member_id, mu.member_role, mu.member_category, mu.member_status, + mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences + FROM groups g + JOIN group_profiles gp USING (group_profile_id) + JOIN group_members mu USING (group_id) + JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) + WHERE g.user_id = ? AND mu.contact_id = ? + |] + (userId, userContactId) + +getContactGroupPreferences :: DB.Connection -> User -> Contact -> IO [FullGroupPreferences] +getContactGroupPreferences db User {userId} Contact {contactId} = do + map (mergeGroupPreferences . fromOnly) + <$> DB.query + db + [sql| + SELECT gp.preferences + FROM groups g + JOIN group_profiles gp USING (group_profile_id) + JOIN group_members m USING (group_id) + WHERE g.user_id = ? AND m.contact_id = ? + |] + (userId, contactId) + +checkContactHasGroups :: DB.Connection -> User -> Contact -> IO (Maybe GroupId) +checkContactHasGroups db User {userId} Contact {contactId} = + maybeFirstRow fromOnly $ DB.query db "SELECT group_id FROM group_members WHERE user_id = ? AND contact_id = ? LIMIT 1" (userId, contactId) + +getGroupInfoByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupInfo +getGroupInfoByName db user gName = do + gId <- getGroupIdByName db user gName + getGroupInfo db user gId + +groupMemberQuery :: Query +groupMemberQuery = + [sql| + SELECT + m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, + m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, + c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, + c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter + FROM group_members m + JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) + LEFT JOIN connections c ON c.connection_id = ( + SELECT max(cc.connection_id) + FROM connections cc + where cc.group_member_id = m.group_member_id + ) + |] + +getGroupMember :: DB.Connection -> User -> GroupId -> GroupMemberId -> ExceptT StoreError IO GroupMember +getGroupMember db user@User {userId} groupId groupMemberId = + ExceptT . firstRow (toContactMember user) (SEGroupMemberNotFound groupMemberId) $ + DB.query + db + (groupMemberQuery <> " WHERE m.group_id = ? AND m.group_member_id = ? AND m.user_id = ?") + (groupId, groupMemberId, userId) + +getGroupMemberById :: DB.Connection -> User -> GroupMemberId -> ExceptT StoreError IO GroupMember +getGroupMemberById db user@User {userId} groupMemberId = + ExceptT . firstRow (toContactMember user) (SEGroupMemberNotFound groupMemberId) $ + DB.query + db + (groupMemberQuery <> " WHERE m.group_member_id = ? AND m.user_id = ?") + (groupMemberId, userId) + +getGroupMembers :: DB.Connection -> User -> GroupInfo -> IO [GroupMember] +getGroupMembers db user@User {userId, userContactId} GroupInfo {groupId} = do + map (toContactMember user) + <$> DB.query + db + (groupMemberQuery <> " WHERE m.group_id = ? AND m.user_id = ? AND (m.contact_id IS NULL OR m.contact_id != ?)") + (groupId, userId, userContactId) + +getGroupMembersForExpiration :: DB.Connection -> User -> GroupInfo -> IO [GroupMember] +getGroupMembersForExpiration db user@User {userId, userContactId} GroupInfo {groupId} = do + map (toContactMember user) + <$> DB.query + db + ( groupMemberQuery + <> [sql| + WHERE m.group_id = ? AND m.user_id = ? AND (m.contact_id IS NULL OR m.contact_id != ?) + AND m.member_status IN (?, ?, ?) + AND m.group_member_id NOT IN ( + SELECT DISTINCT group_member_id FROM chat_items + ) + |] + ) + (groupId, userId, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted) + +toContactMember :: User -> (GroupMemberRow :. MaybeConnectionRow) -> GroupMember +toContactMember User {userContactId} (memberRow :. connRow) = + (toGroupMember userContactId memberRow) {activeConn = toMaybeConnection connRow} + +getGroupInvitation :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO ReceivedGroupInvitation +getGroupInvitation db user groupId = + getConnRec_ user >>= \case + Just connRequest -> do + groupInfo@GroupInfo {membership} <- getGroupInfo db user groupId + when (memberStatus membership /= GSMemInvited) $ throwError SEGroupAlreadyJoined + hostId <- getHostMemberId_ db user groupId + fromMember <- getGroupMember db user groupId hostId + pure ReceivedGroupInvitation {fromMember, connRequest, groupInfo} + _ -> throwError SEGroupInvitationNotFound + where + getConnRec_ :: User -> ExceptT StoreError IO (Maybe ConnReqInvitation) + getConnRec_ User {userId} = ExceptT $ do + firstRow fromOnly (SEGroupNotFound groupId) $ + DB.query db "SELECT g.inv_queue_info FROM groups g WHERE g.group_id = ? AND g.user_id = ?" (groupId, userId) + +createNewContactMember :: DB.Connection -> TVar ChaChaDRG -> User -> GroupId -> Contact -> GroupMemberRole -> ConnId -> ConnReqInvitation -> ExceptT StoreError IO GroupMember +createNewContactMember db gVar User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile} memberRole agentConnId connRequest = + createWithRandomId gVar $ \memId -> do + createdAt <- liftIO getCurrentTime + member@GroupMember {groupMemberId} <- createMember_ (MemberId memId) createdAt + void $ createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 createdAt + pure member + where + createMember_ memberId createdAt = do + insertMember_ + groupMemberId <- liftIO $ insertedRowId db + pure + GroupMember + { groupMemberId, + groupId, + memberId, + memberRole, + memberCategory = GCInviteeMember, + memberStatus = GSMemInvited, + invitedBy = IBUser, + localDisplayName, + memberProfile = profile, + memberContactId = Just contactId, + memberContactProfileId = localProfileId profile, + activeConn = Nothing + } + where + insertMember_ = + DB.execute + db + [sql| + INSERT INTO group_members + ( group_id, member_id, member_role, member_category, member_status, invited_by, + user_id, local_display_name, contact_id, contact_profile_id, sent_inv_queue_info, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?) + |] + ( (groupId, memberId, memberRole, GCInviteeMember, GSMemInvited, fromInvitedBy userContactId IBUser) + :. (userId, localDisplayName, contactId, localProfileId profile, connRequest, createdAt, createdAt) + ) + +createNewContactMemberAsync :: DB.Connection -> TVar ChaChaDRG -> User -> GroupId -> Contact -> GroupMemberRole -> (CommandId, ConnId) -> ExceptT StoreError IO () +createNewContactMemberAsync db gVar user@User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile} memberRole (cmdId, agentConnId) = + createWithRandomId gVar $ \memId -> do + createdAt <- liftIO getCurrentTime + insertMember_ (MemberId memId) createdAt + groupMemberId <- liftIO $ insertedRowId db + Connection {connId} <- createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 createdAt + setCommandConnId db user cmdId connId + where + insertMember_ memberId createdAt = + DB.execute + db + [sql| + INSERT INTO group_members + ( group_id, member_id, member_role, member_category, member_status, invited_by, + user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?) + |] + ( (groupId, memberId, memberRole, GCInviteeMember, GSMemInvited, fromInvitedBy userContactId IBUser) + :. (userId, localDisplayName, contactId, localProfileId profile, createdAt, createdAt) + ) + +getContactViaMember :: DB.Connection -> User -> GroupMember -> IO (Maybe Contact) +getContactViaMember db user@User {userId} GroupMember {groupMemberId} = + maybeFirstRow (toContact user) $ + DB.query + db + [sql| + SELECT + -- Contact + ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, + cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, + -- Connection + c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias, + c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter + FROM contacts ct + JOIN contact_profiles cp ON cp.contact_profile_id = ct.contact_profile_id + JOIN connections c ON c.connection_id = ( + SELECT max(cc.connection_id) + FROM connections cc + where cc.contact_id = ct.contact_id + ) + JOIN group_members m ON m.contact_id = ct.contact_id + WHERE ct.user_id = ? AND m.group_member_id = ? AND ct.deleted = 0 + |] + (userId, groupMemberId) + +setNewContactMemberConnRequest :: DB.Connection -> User -> GroupMember -> ConnReqInvitation -> IO () +setNewContactMemberConnRequest db User {userId} GroupMember {groupMemberId} connRequest = do + currentTs <- getCurrentTime + DB.execute db "UPDATE group_members SET sent_inv_queue_info = ?, updated_at = ? WHERE user_id = ? AND group_member_id = ?" (connRequest, currentTs, userId, groupMemberId) + +getMemberInvitation :: DB.Connection -> User -> Int64 -> IO (Maybe ConnReqInvitation) +getMemberInvitation db User {userId} groupMemberId = + fmap join . maybeFirstRow fromOnly $ + DB.query db "SELECT sent_inv_queue_info FROM group_members WHERE group_member_id = ? AND user_id = ?" (groupMemberId, userId) + +createMemberConnection :: DB.Connection -> UserId -> GroupMember -> ConnId -> IO () +createMemberConnection db userId GroupMember {groupMemberId} agentConnId = do + currentTs <- getCurrentTime + void $ createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 currentTs + +createMemberConnectionAsync :: DB.Connection -> User -> GroupMemberId -> (CommandId, ConnId) -> IO () +createMemberConnectionAsync db user@User {userId} groupMemberId (cmdId, agentConnId) = do + currentTs <- getCurrentTime + Connection {connId} <- createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 currentTs + setCommandConnId db user cmdId connId + +updateGroupMemberStatus :: DB.Connection -> UserId -> GroupMember -> GroupMemberStatus -> IO () +updateGroupMemberStatus db userId GroupMember {groupMemberId} = updateGroupMemberStatusById db userId groupMemberId + +updateGroupMemberStatusById :: DB.Connection -> UserId -> GroupMemberId -> GroupMemberStatus -> IO () +updateGroupMemberStatusById db userId groupMemberId memStatus = do + currentTs <- getCurrentTime + DB.execute + db + [sql| + UPDATE group_members + SET member_status = ?, updated_at = ? + WHERE user_id = ? AND group_member_id = ? + |] + (memStatus, currentTs, userId, groupMemberId) + +-- | add new member with profile +createNewGroupMember :: DB.Connection -> User -> GroupInfo -> MemberInfo -> GroupMemberCategory -> GroupMemberStatus -> ExceptT StoreError IO GroupMember +createNewGroupMember db user@User {userId} gInfo memInfo@(MemberInfo _ _ Profile {displayName, fullName, image, contactLink, preferences}) memCategory memStatus = + ExceptT . withLocalDisplayName db userId displayName $ \localDisplayName -> do + currentTs <- getCurrentTime + DB.execute + db + "INSERT INTO contact_profiles (display_name, full_name, image, contact_link, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" + (displayName, fullName, image, contactLink, userId, preferences, currentTs, currentTs) + memProfileId <- insertedRowId db + let newMember = + NewGroupMember + { memInfo, + memCategory, + memStatus, + memInvitedBy = IBUnknown, + localDisplayName, + memContactId = Nothing, + memProfileId + } + Right <$> createNewMember_ db user gInfo newMember currentTs + +createNewMember_ :: DB.Connection -> User -> GroupInfo -> NewGroupMember -> UTCTime -> IO GroupMember +createNewMember_ + db + User {userId, userContactId} + GroupInfo {groupId} + NewGroupMember + { memInfo = MemberInfo memberId memberRole memberProfile, + memCategory = memberCategory, + memStatus = memberStatus, + memInvitedBy = invitedBy, + localDisplayName, + memContactId = memberContactId, + memProfileId = memberContactProfileId + } + createdAt = do + let invitedById = fromInvitedBy userContactId invitedBy + activeConn = Nothing + DB.execute + db + [sql| + INSERT INTO group_members + (group_id, member_id, member_role, member_category, member_status, + invited_by, user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?) + |] + (groupId, memberId, memberRole, memberCategory, memberStatus, invitedById, userId, localDisplayName, memberContactId, memberContactProfileId, createdAt, createdAt) + groupMemberId <- insertedRowId db + pure GroupMember {groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus, invitedBy, localDisplayName, memberProfile = toLocalProfile memberContactProfileId memberProfile "", memberContactId, memberContactProfileId, activeConn} + +checkGroupMemberHasItems :: DB.Connection -> User -> GroupMember -> IO (Maybe ChatItemId) +checkGroupMemberHasItems db User {userId} GroupMember {groupMemberId, groupId} = + maybeFirstRow fromOnly $ DB.query db "SELECT chat_item_id FROM chat_items WHERE user_id = ? AND group_id = ? AND group_member_id = ? LIMIT 1" (userId, groupId, groupMemberId) + +deleteGroupMember :: DB.Connection -> User -> GroupMember -> IO () +deleteGroupMember db user@User {userId} m@GroupMember {groupMemberId, groupId, memberProfile = LocalProfile {profileId}} = do + deleteGroupMemberConnection db user m + DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND group_id = ? AND group_member_id = ?" (userId, groupId, groupMemberId) + DB.execute db "DELETE FROM group_members WHERE user_id = ? AND group_member_id = ?" (userId, groupMemberId) + cleanupMemberProfileAndName_ db user m + when (memberIncognito m) $ deleteUnusedIncognitoProfileById_ db user profileId + +cleanupMemberProfileAndName_ :: DB.Connection -> User -> GroupMember -> IO () +cleanupMemberProfileAndName_ db User {userId} GroupMember {groupMemberId, memberContactId, memberContactProfileId, localDisplayName} = + -- check record has no memberContactId (contact_id) - it means contact has been deleted and doesn't use profile & ldn + when (isNothing memberContactId) $ do + -- check other group member records don't use profile & ldn + sameProfileMember :: (Maybe GroupMemberId) <- maybeFirstRow fromOnly $ DB.query db "SELECT group_member_id FROM group_members WHERE user_id = ? AND contact_profile_id = ? AND group_member_id != ? LIMIT 1" (userId, memberContactProfileId, groupMemberId) + when (isNothing sameProfileMember) $ do + DB.execute db "DELETE FROM contact_profiles WHERE user_id = ? AND contact_profile_id = ?" (userId, memberContactProfileId) + DB.execute db "DELETE FROM display_names WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName) + +deleteGroupMemberConnection :: DB.Connection -> User -> GroupMember -> IO () +deleteGroupMemberConnection db User {userId} GroupMember {groupMemberId} = + DB.execute db "DELETE FROM connections WHERE user_id = ? AND group_member_id = ?" (userId, groupMemberId) + +updateGroupMemberRole :: DB.Connection -> User -> GroupMember -> GroupMemberRole -> IO () +updateGroupMemberRole db User {userId} GroupMember {groupMemberId} memRole = + DB.execute db "UPDATE group_members SET member_role = ? WHERE user_id = ? AND group_member_id = ?" (memRole, userId, groupMemberId) + +createIntroductions :: DB.Connection -> [GroupMember] -> GroupMember -> IO [GroupMemberIntro] +createIntroductions db members toMember = do + let reMembers = filter (\m -> memberCurrent m && groupMemberId' m /= groupMemberId' toMember) members + if null reMembers + then pure [] + else do + currentTs <- getCurrentTime + mapM (insertIntro_ currentTs) reMembers + where + insertIntro_ :: UTCTime -> GroupMember -> IO GroupMemberIntro + insertIntro_ ts reMember = do + DB.execute + db + [sql| + INSERT INTO group_member_intros + (re_group_member_id, to_group_member_id, intro_status, created_at, updated_at) + VALUES (?,?,?,?,?) + |] + (groupMemberId' reMember, groupMemberId' toMember, GMIntroPending, ts, ts) + introId <- insertedRowId db + pure GroupMemberIntro {introId, reMember, toMember, introStatus = GMIntroPending, introInvitation = Nothing} + +updateIntroStatus :: DB.Connection -> Int64 -> GroupMemberIntroStatus -> IO () +updateIntroStatus db introId introStatus = do + currentTs <- getCurrentTime + DB.executeNamed + db + [sql| + UPDATE group_member_intros + SET intro_status = :intro_status, updated_at = :updated_at + WHERE group_member_intro_id = :intro_id + |] + [":intro_status" := introStatus, ":updated_at" := currentTs, ":intro_id" := introId] + +saveIntroInvitation :: DB.Connection -> GroupMember -> GroupMember -> IntroInvitation -> ExceptT StoreError IO GroupMemberIntro +saveIntroInvitation db reMember toMember introInv = do + intro <- getIntroduction_ db reMember toMember + liftIO $ do + currentTs <- getCurrentTime + DB.executeNamed + db + [sql| + UPDATE group_member_intros + SET intro_status = :intro_status, + group_queue_info = :group_queue_info, + direct_queue_info = :direct_queue_info, + updated_at = :updated_at + WHERE group_member_intro_id = :intro_id + |] + [ ":intro_status" := GMIntroInvReceived, + ":group_queue_info" := groupConnReq (introInv :: IntroInvitation), + ":direct_queue_info" := directConnReq introInv, + ":updated_at" := currentTs, + ":intro_id" := introId intro + ] + pure intro {introInvitation = Just introInv, introStatus = GMIntroInvReceived} + +saveMemberInvitation :: DB.Connection -> GroupMember -> IntroInvitation -> IO () +saveMemberInvitation db GroupMember {groupMemberId} IntroInvitation {groupConnReq, directConnReq} = do + currentTs <- getCurrentTime + DB.executeNamed + db + [sql| + UPDATE group_members + SET member_status = :member_status, + group_queue_info = :group_queue_info, + direct_queue_info = :direct_queue_info, + updated_at = :updated_at + WHERE group_member_id = :group_member_id + |] + [ ":member_status" := GSMemIntroInvited, + ":group_queue_info" := groupConnReq, + ":direct_queue_info" := directConnReq, + ":updated_at" := currentTs, + ":group_member_id" := groupMemberId + ] + +getIntroduction_ :: DB.Connection -> GroupMember -> GroupMember -> ExceptT StoreError IO GroupMemberIntro +getIntroduction_ db reMember toMember = ExceptT $ do + toIntro + <$> DB.query + db + [sql| + SELECT group_member_intro_id, group_queue_info, direct_queue_info, intro_status + FROM group_member_intros + WHERE re_group_member_id = ? AND to_group_member_id = ? + |] + (groupMemberId' reMember, groupMemberId' toMember) + where + toIntro :: [(Int64, Maybe ConnReqInvitation, Maybe ConnReqInvitation, GroupMemberIntroStatus)] -> Either StoreError GroupMemberIntro + toIntro [(introId, groupConnReq, directConnReq, introStatus)] = + let introInvitation = IntroInvitation <$> groupConnReq <*> directConnReq + in Right GroupMemberIntro {introId, reMember, toMember, introStatus, introInvitation} + toIntro _ = Left SEIntroNotFound + +createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> (CommandId, ConnId) -> (CommandId, ConnId) -> Maybe ProfileId -> ExceptT StoreError IO GroupMember +createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberProfile) (groupCmdId, groupAgentConnId) (directCmdId, directAgentConnId) customUserProfileId = do + let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn + currentTs <- liftIO getCurrentTime + Connection {connId = directConnId} <- liftIO $ createConnection_ db userId ConnContact Nothing directAgentConnId memberContactId Nothing customUserProfileId cLevel currentTs + liftIO $ setCommandConnId db user directCmdId directConnId + (localDisplayName, contactId, memProfileId) <- createContact_ db userId directConnId memberProfile "" (Just groupId) currentTs Nothing + liftIO $ do + let newMember = + NewGroupMember + { memInfo, + memCategory = GCPreMember, + memStatus = GSMemIntroduced, + memInvitedBy = IBUnknown, + localDisplayName, + memContactId = Just contactId, + memProfileId + } + member <- createNewMember_ db user gInfo newMember currentTs + conn@Connection {connId = groupConnId} <- createMemberConnection_ db userId (groupMemberId' member) groupAgentConnId memberContactId cLevel currentTs + liftIO $ setCommandConnId db user groupCmdId groupConnId + pure (member :: GroupMember) {activeConn = Just conn} + +createIntroToMemberContact :: DB.Connection -> User -> GroupMember -> GroupMember -> (CommandId, ConnId) -> (CommandId, ConnId) -> Maybe ProfileId -> IO () +createIntroToMemberContact db user@User {userId} GroupMember {memberContactId = viaContactId, activeConn} _to@GroupMember {groupMemberId, localDisplayName} (groupCmdId, groupAgentConnId) (directCmdId, directAgentConnId) customUserProfileId = do + let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn + currentTs <- getCurrentTime + Connection {connId = groupConnId} <- createMemberConnection_ db userId groupMemberId groupAgentConnId viaContactId cLevel currentTs + setCommandConnId db user groupCmdId groupConnId + Connection {connId = directConnId} <- createConnection_ db userId ConnContact Nothing directAgentConnId viaContactId Nothing customUserProfileId cLevel currentTs + setCommandConnId db user directCmdId directConnId + contactId <- createMemberContact_ directConnId currentTs + updateMember_ contactId currentTs + where + createMemberContact_ :: Int64 -> UTCTime -> IO Int64 + createMemberContact_ connId ts = do + DB.execute + db + [sql| + INSERT INTO contacts (contact_profile_id, via_group, local_display_name, user_id, created_at, updated_at) + SELECT contact_profile_id, group_id, ?, ?, ?, ? + FROM group_members + WHERE group_member_id = ? + |] + (localDisplayName, userId, ts, ts, groupMemberId) + contactId <- insertedRowId db + DB.execute db "UPDATE connections SET contact_id = ?, updated_at = ? WHERE connection_id = ?" (contactId, ts, connId) + pure contactId + updateMember_ :: Int64 -> UTCTime -> IO () + updateMember_ contactId ts = + DB.executeNamed + db + [sql| + UPDATE group_members + SET contact_id = :contact_id, updated_at = :updated_at + WHERE group_member_id = :group_member_id + |] + [":contact_id" := contactId, ":updated_at" := ts, ":group_member_id" := groupMemberId] + +createMemberConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> Maybe Int64 -> Int -> UTCTime -> IO Connection +createMemberConnection_ db userId groupMemberId agentConnId viaContact = createConnection_ db userId ConnMember (Just groupMemberId) agentConnId viaContact Nothing Nothing + +getViaGroupMember :: DB.Connection -> User -> Contact -> IO (Maybe (GroupInfo, GroupMember)) +getViaGroupMember db User {userId, userContactId} Contact {contactId} = + maybeFirstRow toGroupAndMember $ + DB.query + db + [sql| + SELECT + -- GroupInfo + g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, + -- GroupInfo {membership} + mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, + mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, + -- GroupInfo {membership = GroupMember {memberProfile}} + pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences, + -- via GroupMember + m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, + m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, + c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, + c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter + FROM group_members m + JOIN contacts ct ON ct.contact_id = m.contact_id + JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) + JOIN groups g ON g.group_id = m.group_id AND g.group_id = ct.via_group + JOIN group_profiles gp USING (group_profile_id) + JOIN group_members mu ON g.group_id = mu.group_id + JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) + LEFT JOIN connections c ON c.connection_id = ( + SELECT max(cc.connection_id) + FROM connections cc + where cc.group_member_id = m.group_member_id + ) + WHERE ct.user_id = ? AND ct.contact_id = ? AND mu.contact_id = ? AND ct.deleted = 0 + |] + (userId, contactId, userContactId) + where + toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember) + toGroupAndMember (groupInfoRow :. memberRow :. connRow) = + let groupInfo = toGroupInfo userContactId groupInfoRow + member = toGroupMember userContactId memberRow + in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow}) + +getViaGroupContact :: DB.Connection -> User -> GroupMember -> IO (Maybe Contact) +getViaGroupContact db user@User {userId} GroupMember {groupMemberId} = + maybeFirstRow toContact' $ + DB.query + db + [sql| + SELECT + ct.contact_id, ct.contact_profile_id, ct.local_display_name, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, ct.via_group, ct.contact_used, ct.enable_ntfs, + p.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, + c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, + c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter + FROM contacts ct + JOIN contact_profiles p ON ct.contact_profile_id = p.contact_profile_id + JOIN connections c ON c.connection_id = ( + SELECT max(cc.connection_id) + FROM connections cc + where cc.contact_id = ct.contact_id + ) + JOIN groups g ON g.group_id = ct.via_group + JOIN group_members m ON m.group_id = g.group_id AND m.contact_id = ct.contact_id + WHERE ct.user_id = ? AND m.group_member_id = ? AND ct.deleted = 0 + |] + (userId, groupMemberId) + where + toContact' :: ((ContactId, ProfileId, ContactName, Text, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Int64, Bool, Maybe Bool) :. (Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime)) :. ConnectionRow -> Contact + toContact' (((contactId, profileId, localDisplayName, displayName, fullName, image, contactLink, localAlias, viaGroup, contactUsed, enableNtfs_) :. (preferences, userPreferences, createdAt, updatedAt, chatTs)) :. connRow) = + let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} + chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_} + activeConn = toConnection connRow + mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn + in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs} + +updateGroupProfile :: DB.Connection -> User -> GroupInfo -> GroupProfile -> ExceptT StoreError IO GroupInfo +updateGroupProfile db User {userId} g@GroupInfo {groupId, localDisplayName, groupProfile = GroupProfile {displayName}} p'@GroupProfile {displayName = newName, fullName, description, image, groupPreferences} + | displayName == newName = liftIO $ do + currentTs <- getCurrentTime + updateGroupProfile_ currentTs + pure (g :: GroupInfo) {groupProfile = p', fullGroupPreferences} + | otherwise = + ExceptT . withLocalDisplayName db userId newName $ \ldn -> do + currentTs <- getCurrentTime + updateGroupProfile_ currentTs + updateGroup_ ldn currentTs + pure $ Right (g :: GroupInfo) {localDisplayName = ldn, groupProfile = p', fullGroupPreferences} + where + fullGroupPreferences = mergeGroupPreferences groupPreferences + updateGroupProfile_ currentTs = + DB.execute + db + [sql| + UPDATE group_profiles + SET display_name = ?, full_name = ?, description = ?, image = ?, preferences = ?, updated_at = ? + WHERE group_profile_id IN ( + SELECT group_profile_id + FROM groups + WHERE user_id = ? AND group_id = ? + ) + |] + (newName, fullName, description, image, groupPreferences, currentTs, userId, groupId) + updateGroup_ ldn currentTs = do + DB.execute + db + "UPDATE groups SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND group_id = ?" + (ldn, currentTs, userId, groupId) + DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (localDisplayName, userId) + +getGroupInfo :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO GroupInfo +getGroupInfo db User {userId, userContactId} groupId = + ExceptT . firstRow (toGroupInfo userContactId) (SEGroupNotFound groupId) $ + DB.query + db + [sql| + SELECT + -- GroupInfo + g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, + -- GroupMember - membership + mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, + mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, + pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences + FROM groups g + JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id + JOIN group_members mu ON mu.group_id = g.group_id + JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) + WHERE g.group_id = ? AND g.user_id = ? AND mu.contact_id = ? + |] + (groupId, userId, userContactId) + +getGroupIdByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupId +getGroupIdByName db User {userId} gName = + ExceptT . firstRow fromOnly (SEGroupNotFoundByName gName) $ + DB.query db "SELECT group_id FROM groups WHERE user_id = ? AND local_display_name = ?" (userId, gName) + +getGroupMemberIdByName :: DB.Connection -> User -> GroupId -> ContactName -> ExceptT StoreError IO GroupMemberId +getGroupMemberIdByName db User {userId} groupId groupMemberName = + ExceptT . firstRow fromOnly (SEGroupMemberNameNotFound groupId groupMemberName) $ + DB.query db "SELECT group_member_id FROM group_members WHERE user_id = ? AND group_id = ? AND local_display_name = ?" (userId, groupId, groupMemberName) + + + + +getMatchingContacts :: DB.Connection -> User -> Contact -> IO [Contact] +getMatchingContacts db user@User {userId} Contact {contactId, profile = LocalProfile {displayName, fullName, image}} = do + contactIds <- + map fromOnly + <$> DB.query + db + [sql| + SELECT ct.contact_id + FROM contacts ct + JOIN contact_profiles p ON ct.contact_profile_id = p.contact_profile_id + WHERE ct.user_id = ? AND ct.contact_id != ? + AND ct.deleted = 0 + AND p.display_name = ? AND p.full_name = ? + AND ((p.image IS NULL AND ? IS NULL) OR p.image = ?) + |] + (userId, contactId, displayName, fullName, image, image) + rights <$> mapM (runExceptT . getContact db user) contactIds + +createSentProbe :: DB.Connection -> TVar ChaChaDRG -> UserId -> Contact -> ExceptT StoreError IO (Probe, Int64) +createSentProbe db gVar userId _to@Contact {contactId} = + createWithRandomBytes 32 gVar $ \probe -> do + currentTs <- getCurrentTime + DB.execute + db + "INSERT INTO sent_probes (contact_id, probe, user_id, created_at, updated_at) VALUES (?,?,?,?,?)" + (contactId, probe, userId, currentTs, currentTs) + (Probe probe,) <$> insertedRowId db + +createSentProbeHash :: DB.Connection -> UserId -> Int64 -> Contact -> IO () +createSentProbeHash db userId probeId _to@Contact {contactId} = do + currentTs <- getCurrentTime + DB.execute + db + "INSERT INTO sent_probe_hashes (sent_probe_id, contact_id, user_id, created_at, updated_at) VALUES (?,?,?,?,?)" + (probeId, contactId, userId, currentTs, currentTs) + +deleteSentProbe :: DB.Connection -> UserId -> Int64 -> IO () +deleteSentProbe db userId probeId = + DB.execute + db + "DELETE FROM sent_probes WHERE user_id = ? AND sent_probe_id = ?" + (userId, probeId) + +matchReceivedProbe :: DB.Connection -> User -> Contact -> Probe -> IO (Maybe Contact) +matchReceivedProbe db user@User {userId} _from@Contact {contactId} (Probe probe) = do + let probeHash = C.sha256Hash probe + contactIds <- + map fromOnly + <$> DB.query + db + [sql| + SELECT c.contact_id + FROM contacts c + JOIN received_probes r ON r.contact_id = c.contact_id + WHERE c.user_id = ? AND c.deleted = 0 AND r.probe_hash = ? AND r.probe IS NULL + |] + (userId, probeHash) + currentTs <- getCurrentTime + DB.execute + db + "INSERT INTO received_probes (contact_id, probe, probe_hash, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" + (contactId, probe, probeHash, userId, currentTs, currentTs) + case contactIds of + [] -> pure Nothing + cId : _ -> eitherToMaybe <$> runExceptT (getContact db user cId) + +matchReceivedProbeHash :: DB.Connection -> User -> Contact -> ProbeHash -> IO (Maybe (Contact, Probe)) +matchReceivedProbeHash db user@User {userId} _from@Contact {contactId} (ProbeHash probeHash) = do + namesAndProbes <- + DB.query + db + [sql| + SELECT c.contact_id, r.probe + FROM contacts c + JOIN received_probes r ON r.contact_id = c.contact_id + WHERE c.user_id = ? AND c.deleted = 0 AND r.probe_hash = ? AND r.probe IS NOT NULL + |] + (userId, probeHash) + currentTs <- getCurrentTime + DB.execute + db + "INSERT INTO received_probes (contact_id, probe_hash, user_id, created_at, updated_at) VALUES (?,?,?,?,?)" + (contactId, probeHash, userId, currentTs, currentTs) + case namesAndProbes of + [] -> pure Nothing + (cId, probe) : _ -> + either (const Nothing) (Just . (,Probe probe)) + <$> runExceptT (getContact db user cId) + +matchSentProbe :: DB.Connection -> User -> Contact -> Probe -> IO (Maybe Contact) +matchSentProbe db user@User {userId} _from@Contact {contactId} (Probe probe) = do + contactIds <- + map fromOnly + <$> DB.query + db + [sql| + SELECT c.contact_id + FROM contacts c + JOIN sent_probes s ON s.contact_id = c.contact_id + JOIN sent_probe_hashes h ON h.sent_probe_id = s.sent_probe_id + WHERE c.user_id = ? AND c.deleted = 0 AND s.probe = ? AND h.contact_id = ? + |] + (userId, probe, contactId) + case contactIds of + [] -> pure Nothing + cId : _ -> eitherToMaybe <$> runExceptT (getContact db user cId) + +mergeContactRecords :: DB.Connection -> UserId -> Contact -> Contact -> IO () +mergeContactRecords db userId ct1 ct2 = do + let (toCt, fromCt) = toFromContacts ct1 ct2 + Contact {contactId = toContactId} = toCt + Contact {contactId = fromContactId, localDisplayName} = fromCt + currentTs <- getCurrentTime + -- TODO next query fixes incorrect unused contacts deletion; consider more thorough fix + when (contactDirect toCt && not (contactUsed toCt)) $ + DB.execute + db + "UPDATE contacts SET contact_used = 1, updated_at = ? WHERE user_id = ? AND contact_id = ?" + (currentTs, userId, toContactId) + DB.execute + db + "UPDATE connections SET contact_id = ?, updated_at = ? WHERE contact_id = ? AND user_id = ?" + (toContactId, currentTs, fromContactId, userId) + DB.execute + db + "UPDATE connections SET via_contact = ?, updated_at = ? WHERE via_contact = ? AND user_id = ?" + (toContactId, currentTs, fromContactId, userId) + DB.execute + db + "UPDATE group_members SET invited_by = ?, updated_at = ? WHERE invited_by = ? AND user_id = ?" + (toContactId, currentTs, fromContactId, userId) + DB.execute + db + "UPDATE chat_items SET contact_id = ?, updated_at = ? WHERE contact_id = ? AND user_id = ?" + (toContactId, currentTs, fromContactId, userId) + DB.executeNamed + db + [sql| + UPDATE group_members + SET contact_id = :to_contact_id, + local_display_name = (SELECT local_display_name FROM contacts WHERE contact_id = :to_contact_id), + contact_profile_id = (SELECT contact_profile_id FROM contacts WHERE contact_id = :to_contact_id), + updated_at = :updated_at + WHERE contact_id = :from_contact_id + AND user_id = :user_id + |] + [ ":to_contact_id" := toContactId, + ":from_contact_id" := fromContactId, + ":user_id" := userId, + ":updated_at" := currentTs + ] + deleteContactProfile_ db userId fromContactId + DB.execute db "DELETE FROM contacts WHERE contact_id = ? AND user_id = ?" (fromContactId, userId) + DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (localDisplayName, userId) + where + toFromContacts :: Contact -> Contact -> (Contact, Contact) + toFromContacts c1 c2 + | d1 && not d2 = (c1, c2) + | d2 && not d1 = (c2, c1) + | ctCreatedAt c1 <= ctCreatedAt c2 = (c1, c2) + | otherwise = (c2, c1) + where + d1 = directOrUsed c1 + d2 = directOrUsed c2 + ctCreatedAt Contact {createdAt} = createdAt + +updateGroupSettings :: DB.Connection -> User -> Int64 -> ChatSettings -> IO () +updateGroupSettings db User {userId} groupId ChatSettings {enableNtfs} = + DB.execute db "UPDATE groups SET enable_ntfs = ? WHERE user_id = ? AND group_id = ?" (enableNtfs, userId, groupId) + +getXGrpMemIntroContDirect :: DB.Connection -> User -> Contact -> IO (Maybe (Int64, XGrpMemIntroCont)) +getXGrpMemIntroContDirect db User {userId} Contact {contactId} = do + fmap join . maybeFirstRow toCont $ + DB.query + db + [sql| + SELECT ch.connection_id, g.group_id, m.group_member_id, m.member_id, c.conn_req_inv + FROM contacts ct + JOIN group_members m ON m.contact_id = ct.contact_id + LEFT JOIN connections c ON c.connection_id = ( + SELECT MAX(cc.connection_id) + FROM connections cc + WHERE cc.group_member_id = m.group_member_id + ) + JOIN groups g ON g.group_id = m.group_id AND g.group_id = ct.via_group + JOIN group_members mh ON mh.group_id = g.group_id + LEFT JOIN connections ch ON ch.connection_id = ( + SELECT max(cc.connection_id) + FROM connections cc + where cc.group_member_id = mh.group_member_id + ) + WHERE ct.user_id = ? AND ct.contact_id = ? AND ct.deleted = 0 AND mh.member_category = ? + |] + (userId, contactId, GCHostMember) + where + toCont :: (Int64, GroupId, GroupMemberId, MemberId, Maybe ConnReqInvitation) -> Maybe (Int64, XGrpMemIntroCont) + toCont (hostConnId, groupId, groupMemberId, memberId, connReq_) = case connReq_ of + Just groupConnReq -> Just (hostConnId, XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq}) + _ -> Nothing + +getXGrpMemIntroContGroup :: DB.Connection -> User -> GroupMember -> IO (Maybe (Int64, ConnReqInvitation)) +getXGrpMemIntroContGroup db User {userId} GroupMember {groupMemberId} = do + fmap join . maybeFirstRow toCont $ + DB.query + db + [sql| + SELECT ch.connection_id, c.conn_req_inv + FROM group_members m + JOIN contacts ct ON ct.contact_id = m.contact_id + LEFT JOIN connections c ON c.connection_id = ( + SELECT MAX(cc.connection_id) + FROM connections cc + WHERE cc.contact_id = ct.contact_id + ) + JOIN groups g ON g.group_id = m.group_id AND g.group_id = ct.via_group + JOIN group_members mh ON mh.group_id = g.group_id + LEFT JOIN connections ch ON ch.connection_id = ( + SELECT max(cc.connection_id) + FROM connections cc + where cc.group_member_id = mh.group_member_id + ) + WHERE m.user_id = ? AND m.group_member_id = ? AND mh.member_category = ? AND ct.deleted = 0 + |] + (userId, groupMemberId, GCHostMember) + where + toCont :: (Int64, Maybe ConnReqInvitation) -> Maybe (Int64, ConnReqInvitation) + toCont (hostConnId, connReq_) = case connReq_ of + Just connReq -> Just (hostConnId, connReq) + _ -> Nothing diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs new file mode 100644 index 000000000..efc78f8df --- /dev/null +++ b/src/Simplex/Chat/Store/Messages.hs @@ -0,0 +1,1805 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Simplex.Chat.Store.Messages + ( getContactConnIds_, + getDirectChatReactions_, + toDirectChatItem, + -- * Message and chat item functions + deleteContactCIs, + getGroupFileInfo, + deleteGroupCIs, + createNewSndMessage, + createSndMsgDelivery, + createNewMessageAndRcvMsgDelivery, + createSndMsgDeliveryEvent, + createRcvMsgDeliveryEvent, + createPendingGroupMessage, + getPendingGroupMessages, + deletePendingGroupMessage, + deleteOldMessages, + updateChatTs, + createNewSndChatItem, + createNewRcvChatItem, + createNewChatItemNoMsg, + getChatPreviews, + getDirectChat, + getGroupChat, + getDirectChatItemsLast, + getAllChatItems, + getAChatItem, + updateDirectChatItem, + updateDirectChatItem', + addInitialAndNewCIVersions, + createChatItemVersion, + deleteDirectChatItem, + markDirectChatItemDeleted, + updateGroupChatItem, + deleteGroupChatItem, + updateGroupChatItemModerated, + markGroupChatItemDeleted, + updateDirectChatItemsRead, + getDirectUnreadTimedItems, + setDirectChatItemDeleteAt, + updateGroupChatItemsRead, + getGroupUnreadTimedItems, + setGroupChatItemDeleteAt, + getChatRefViaItemId, + getChatItemVersions, + getDirectCIReactions, + getDirectReactions, + setDirectReaction, + getGroupCIReactions, + getGroupReactions, + setGroupReaction, + getChatItemIdByAgentMsgId, + getDirectChatItem, + getDirectChatItemBySharedMsgId, + getDirectChatItemByAgentMsgId, + getGroupChatItem, + getGroupChatItemBySharedMsgId, + getGroupMemberCIBySharedMsgId, + getGroupMemberChatItemLast, + getDirectChatItemIdByText, + getDirectChatItemIdByText', + getGroupChatItemIdByText, + getGroupChatItemIdByText', + getChatItemByFileId, + getChatItemByGroupId, + updateDirectChatItemStatus, + getTimedItems, + getChatItemTTL, + setChatItemTTL, + getContactExpiredFileInfo, + deleteContactExpiredCIs, + getGroupExpiredFileInfo, + deleteGroupExpiredCIs, + ) +where + +import Control.Monad.Except +import Crypto.Random (ChaChaDRG) +import Data.Bifunctor (first) +import Data.ByteString.Char8 (ByteString) +import Data.Either (fromRight, rights) +import Data.Int (Int64) +import Data.List (sortOn) +import Data.Maybe (fromMaybe, isJust, mapMaybe) +import Data.Ord (Down (..)) +import Data.Text (Text) +import Data.Time (addUTCTime) +import Data.Time.Clock (UTCTime (..), getCurrentTime) +import Database.SQLite.Simple (NamedParam (..), Only (..), (:.) (..)) +import qualified Database.SQLite.Simple as DB +import Database.SQLite.Simple.QQ (sql) +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 +import Simplex.Chat.Store.Shared +import Simplex.Chat.Types +import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, MsgMeta (..), UserId) +import Simplex.Messaging.Agent.Store.SQLite (firstRow, firstRow', maybeFirstRow) +import Simplex.Messaging.Util (eitherToMaybe) +import UnliftIO.STM + +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) + +deleteGroupCIs :: DB.Connection -> User -> GroupInfo -> IO () +deleteGroupCIs db User {userId} GroupInfo {groupId} = do + 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) + +createNewSndMessage :: MsgEncodingI e => DB.Connection -> TVar ChaChaDRG -> ConnOrGroupId -> (SharedMsgId -> NewMessage e) -> ExceptT StoreError IO SndMessage +createNewSndMessage db gVar connOrGroupId mkMessage = + createWithRandomId gVar $ \sharedMsgId -> do + let NewMessage {chatMsgEvent, msgBody} = mkMessage $ SharedMsgId sharedMsgId + 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 (?,?,?,?,?,?,?,?,?) + |] + (MDSnd, toCMEventTag chatMsgEvent, msgBody, connId_, groupId_, sharedMsgId, Just True, createdAt, createdAt) + msgId <- insertedRowId db + pure SndMessage {msgId, sharedMsgId = SharedMsgId sharedMsgId, msgBody} + where + (connId_, groupId_) = case connOrGroupId of + ConnectionId connId -> (Just connId, Nothing) + GroupId groupId -> (Nothing, Just groupId) + +createSndMsgDelivery :: DB.Connection -> SndMsgDelivery -> MessageId -> IO Int64 +createSndMsgDelivery db sndMsgDelivery messageId = do + currentTs <- getCurrentTime + msgDeliveryId <- createSndMsgDelivery_ db sndMsgDelivery messageId currentTs + createMsgDeliveryEvent_ db msgDeliveryId MDSSndAgent currentTs + pure msgDeliveryId + +createNewMessageAndRcvMsgDelivery :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewMessage e -> Maybe SharedMsgId -> RcvMsgDelivery -> IO RcvMessage +createNewMessageAndRcvMsgDelivery db connOrGroupId NewMessage {chatMsgEvent, msgBody} sharedMsgId_ RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId} = do + currentTs <- getCurrentTime + DB.execute + db + "INSERT INTO messages (msg_sent, chat_msg_event, msg_body, created_at, updated_at, connection_id, group_id, shared_msg_id) VALUES (?,?,?,?,?,?,?,?)" + (MDRcv, toCMEventTag chatMsgEvent, msgBody, currentTs, currentTs, connId_, groupId_, sharedMsgId_) + msgId <- insertedRowId db + DB.execute + db + "INSERT INTO msg_deliveries (message_id, connection_id, agent_msg_id, agent_msg_meta, agent_ack_cmd_id, chat_ts, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" + (msgId, connId, agentMsgId, msgMetaJson agentMsgMeta, agentAckCmdId, snd $ broker agentMsgMeta, currentTs, currentTs) + msgDeliveryId <- insertedRowId db + createMsgDeliveryEvent_ db msgDeliveryId MDSRcvAgent currentTs + pure RcvMessage {msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody} + where + (connId_, groupId_) = case connOrGroupId of + ConnectionId connId' -> (Just connId', Nothing) + GroupId groupId -> (Nothing, Just groupId) + +createSndMsgDeliveryEvent :: DB.Connection -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> ExceptT StoreError IO () +createSndMsgDeliveryEvent db connId agentMsgId sndMsgDeliveryStatus = do + msgDeliveryId <- getMsgDeliveryId_ db connId agentMsgId + liftIO $ do + currentTs <- getCurrentTime + createMsgDeliveryEvent_ db msgDeliveryId sndMsgDeliveryStatus currentTs + +createRcvMsgDeliveryEvent :: DB.Connection -> Int64 -> CommandId -> MsgDeliveryStatus 'MDRcv -> IO () +createRcvMsgDeliveryEvent db connId cmdId rcvMsgDeliveryStatus = do + msgDeliveryId <- getMsgDeliveryIdByCmdId_ db connId cmdId + forM_ msgDeliveryId $ \mdId -> do + currentTs <- getCurrentTime + createMsgDeliveryEvent_ db mdId rcvMsgDeliveryStatus currentTs + +createSndMsgDelivery_ :: DB.Connection -> SndMsgDelivery -> MessageId -> UTCTime -> IO Int64 +createSndMsgDelivery_ db SndMsgDelivery {connId, agentMsgId} messageId createdAt = do + DB.execute + db + [sql| + INSERT INTO msg_deliveries + (message_id, connection_id, agent_msg_id, agent_msg_meta, chat_ts, created_at, updated_at) + VALUES (?,?,?,NULL,?,?,?) + |] + (messageId, connId, agentMsgId, createdAt, createdAt, createdAt) + insertedRowId db + +createMsgDeliveryEvent_ :: DB.Connection -> Int64 -> MsgDeliveryStatus d -> UTCTime -> IO () +createMsgDeliveryEvent_ db msgDeliveryId msgDeliveryStatus createdAt = do + DB.execute + db + [sql| + INSERT INTO msg_delivery_events + (msg_delivery_id, delivery_status, created_at, updated_at) + VALUES (?,?,?,?) + |] + (msgDeliveryId, msgDeliveryStatus, createdAt, createdAt) + +getMsgDeliveryId_ :: DB.Connection -> Int64 -> AgentMsgId -> ExceptT StoreError IO Int64 +getMsgDeliveryId_ db connId agentMsgId = + ExceptT . firstRow fromOnly (SENoMsgDelivery connId agentMsgId) $ + DB.query + db + [sql| + SELECT msg_delivery_id + FROM msg_deliveries m + WHERE m.connection_id = ? AND m.agent_msg_id = ? + LIMIT 1 + |] + (connId, agentMsgId) + +getMsgDeliveryIdByCmdId_ :: DB.Connection -> Int64 -> CommandId -> IO (Maybe AgentMsgId) +getMsgDeliveryIdByCmdId_ db connId cmdId = + maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT msg_delivery_id + FROM msg_deliveries + WHERE connection_id = ? AND agent_ack_cmd_id = ? + LIMIT 1 + |] + (connId, cmdId) + +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) + +getPendingGroupMessages :: DB.Connection -> Int64 -> IO [PendingGroupMessage] +getPendingGroupMessages db groupMemberId = + map pendingGroupMessage + <$> DB.query + db + [sql| + SELECT pgm.message_id, m.chat_msg_event, m.msg_body, pgm.group_member_intro_id + FROM pending_group_messages pgm + JOIN messages m USING (message_id) + WHERE pgm.group_member_id = ? + ORDER BY pgm.message_id ASC + |] + (Only groupMemberId) + where + pendingGroupMessage (msgId, cmEventTag, msgBody, introId_) = + PendingGroupMessage {msgId, cmEventTag, msgBody, introId_} + +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) + +updateChatTs :: DB.Connection -> User -> ChatDirection c d -> UTCTime -> IO () +updateChatTs db User {userId} chatDirection chatTs = case toChatInfo chatDirection of + DirectChat Contact {contactId} -> + DB.execute + db + "UPDATE contacts SET chat_ts = ? WHERE user_id = ? AND contact_id = ?" + (chatTs, userId, contactId) + GroupChat GroupInfo {groupId} -> + DB.execute + db + "UPDATE groups SET chat_ts = ? WHERE user_id = ? AND group_id = ?" + (chatTs, userId, groupId) + _ -> pure () + +createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> Maybe CITimed -> Bool -> UTCTime -> IO ChatItemId +createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciContent quotedItem timed live createdAt = + createNewChatItem_ db user chatDirection createdByMsgId (Just sharedMsgId) ciContent quoteRow timed live createdAt createdAt + 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) + +createNewRcvChatItem :: DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c)) +createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent} sharedMsgId_ ciContent timed live itemTs createdAt = do + ciId <- createNewChatItem_ db user chatDirection (Just msgId) sharedMsgId_ ciContent quoteRow timed live itemTs createdAt + quotedItem <- mapM (getChatItemQuote_ db user chatDirection) quotedMsg + pure (ciId, quotedItem) + where + 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) + CDGroupRcv GroupInfo {membership = GroupMember {memberId = userMemberId}} _ -> + (Just $ Just userMemberId == memberId, memberId) + +createNewChatItemNoMsg :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> CIContent d -> UTCTime -> UTCTime -> IO ChatItemId +createNewChatItemNoMsg db user chatDirection ciContent = + createNewChatItem_ db user chatDirection Nothing Nothing ciContent quoteRow Nothing False + where + quoteRow :: NewQuoteRow + quoteRow = (Nothing, Nothing, Nothing, Nothing, Nothing) + +createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CITimed -> Bool -> UTCTime -> UTCTime -> IO ChatItemId +createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent quoteRow timed live itemTs createdAt = do + DB.execute + db + [sql| + INSERT INTO chat_items ( + -- user and IDs + user_id, created_by_msg_id, contact_id, group_id, group_member_id, + -- meta + item_sent, item_ts, item_content, item_text, item_status, shared_msg_id, created_at, updated_at, item_live, timed_ttl, timed_delete_at, + -- quote + quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id + ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) + |] + ((userId, msgId_) :. idsRow :. itemRow :. quoteRow) + ciId <- insertedRowId db + forM_ msgId_ $ \msgId -> insertChatItemMessage_ db ciId msgId createdAt + pure ciId + where + itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, CIStatus d, Maybe SharedMsgId) :. (UTCTime, UTCTime, Maybe Bool) :. (Maybe Int, Maybe UTCTime) + itemRow = (msgDirection @d, itemTs, ciContent, ciContentToText ciContent, ciCreateStatus ciContent, sharedMsgId) :. (createdAt, createdAt, justTrue live) :. ciTimedRow timed + idsRow :: (Maybe Int64, Maybe Int64, Maybe Int64) + idsRow = case chatDirection of + CDDirectRcv Contact {contactId} -> (Just contactId, Nothing, Nothing) + CDDirectSnd Contact {contactId} -> (Just contactId, Nothing, Nothing) + CDGroupRcv GroupInfo {groupId} GroupMember {groupMemberId} -> (Nothing, Just groupId, Just groupMemberId) + CDGroupSnd GroupInfo {groupId} -> (Nothing, Just groupId, Nothing) + +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) + +getChatItemQuote_ :: DB.Connection -> User -> ChatDirection c 'MDRcv -> QuotedMsg -> IO (CIQuote c) +getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRef = MsgRef {msgId, sentAt, sent, memberId}, content} = + case chatDirection of + CDDirectRcv Contact {contactId} -> getDirectChatItemQuote_ contactId (not sent) + CDGroupRcv GroupInfo {groupId, membership = GroupMember {memberId = userMemberId}} sender@GroupMember {memberId = senderMemberId} -> + case memberId of + Just mId + | mId == userMemberId -> (`ciQuote` CIQGroupSnd) <$> getUserGroupChatItemId_ groupId + | mId == senderMemberId -> (`ciQuote` CIQGroupRcv (Just sender)) <$> getGroupChatItemId_ groupId mId + | 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 = ?" + (userId, contactId, msgId, userSent) + 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) + getGroupChatItemId_ :: Int64 -> MemberId -> IO (Maybe ChatItemId) + getGroupChatItemId_ groupId mId = + 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 = ?" + (userId, groupId, msgId, MDRcv, mId) + getGroupChatItemQuote_ :: Int64 -> MemberId -> IO (CIQuote 'CTGroup) + getGroupChatItemQuote_ groupId mId = do + ciQuoteGroup + <$> DB.queryNamed + db + [sql| + SELECT i.chat_item_id, + -- GroupMember + m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, + m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, + p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences + 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 + LEFT JOIN chat_items i ON i.group_id = m.group_id + AND m.group_member_id = i.group_member_id + AND i.shared_msg_id = :msg_id + WHERE m.user_id = :user_id AND m.group_id = :group_id AND m.member_id = :member_id + |] + [":user_id" := userId, ":group_id" := groupId, ":member_id" := mId, ":msg_id" := msgId] + where + ciQuoteGroup :: [Only (Maybe ChatItemId) :. GroupMemberRow] -> CIQuote 'CTGroup + ciQuoteGroup [] = ciQuote Nothing $ CIQGroupRcv Nothing + ciQuoteGroup ((Only itemId :. memberRow) : _) = ciQuote itemId . CIQGroupRcv . Just $ toGroupMember userContactId memberRow + +getChatPreviews :: DB.Connection -> User -> Bool -> IO [AChat] +getChatPreviews db user withPCC = do + directChats <- getDirectChatPreviews_ db user + groupChats <- getGroupChatPreviews_ db user + cReqChats <- getContactRequestChatPreviews_ db user + connChats <- getContactConnectionChatPreviews_ db user withPCC + pure $ sortOn (Down . ts) (directChats <> groupChats <> cReqChats <> connChats) + where + ts :: AChat -> UTCTime + ts (AChat _ Chat {chatInfo, chatItems}) = case chatInfoChatTs chatInfo of + Just chatTs -> chatTs + Nothing -> case chatItems of + ci : _ -> max (chatItemTs ci) (chatInfoUpdatedAt chatInfo) + _ -> chatInfoUpdatedAt chatInfo + +getDirectChatPreviews_ :: DB.Connection -> User -> IO [AChat] +getDirectChatPreviews_ db user@User {userId} = do + currentTs <- getCurrentTime + map (toDirectChatPreview currentTs) + <$> DB.query + db + [sql| + SELECT + -- Contact + ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, + cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, + -- Connection + c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias, + c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter, + -- ChatStats + COALESCE(ChatStats.UnreadCount, 0), COALESCE(ChatStats.MinUnread, 0), ct.unread_chat, + -- ChatItem + i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, + -- CIFile + f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, + -- DirectQuote + ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent + FROM contacts ct + JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id + JOIN connections c ON c.contact_id = ct.contact_id + LEFT JOIN ( + SELECT contact_id, MAX(chat_item_id) AS MaxId + FROM chat_items + GROUP BY contact_id + ) MaxIds ON MaxIds.contact_id = ct.contact_id + LEFT JOIN chat_items i ON i.contact_id = MaxIds.contact_id + AND i.chat_item_id = MaxIds.MaxId + LEFT JOIN files f ON f.chat_item_id = i.chat_item_id + LEFT JOIN ( + SELECT contact_id, COUNT(1) AS UnreadCount, MIN(chat_item_id) AS MinUnread + FROM chat_items + WHERE item_status = ? + GROUP BY contact_id + ) ChatStats ON ChatStats.contact_id = ct.contact_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 ct.user_id = ? + AND ((c.conn_level = 0 AND c.via_group_link = 0) OR ct.contact_used = 1) + AND ct.deleted = 0 + AND c.connection_id = ( + SELECT cc_connection_id FROM ( + SELECT + cc.connection_id AS cc_connection_id, + (CASE WHEN cc.conn_status = ? OR cc.conn_status = ? THEN 1 ELSE 0 END) AS cc_conn_status_ord + FROM connections cc + WHERE cc.user_id = ct.user_id AND cc.contact_id = ct.contact_id + ORDER BY cc_conn_status_ord DESC, cc_connection_id DESC + LIMIT 1 + ) + ) + ORDER BY i.item_ts DESC + |] + (CISRcvNew, userId, ConnReady, ConnSndReady) + where + toDirectChatPreview :: UTCTime -> ContactRow :. ConnectionRow :. ChatStatsRow :. MaybeChatItemRow :. QuoteRow -> AChat + toDirectChatPreview currentTs (contactRow :. connRow :. statsRow :. ciRow_) = + let contact = toContact user $ contactRow :. connRow + ci_ = toDirectChatItemList currentTs ciRow_ + stats = toChatStats statsRow + in AChat SCTDirect $ Chat (DirectChat contact) ci_ stats + +getGroupChatPreviews_ :: DB.Connection -> User -> IO [AChat] +getGroupChatPreviews_ db User {userId, userContactId} = do + currentTs <- getCurrentTime + map (toGroupChatPreview currentTs) + <$> DB.query + db + [sql| + SELECT + -- GroupInfo + g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts, + -- GroupMember - membership + mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, + mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, + pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences, + -- ChatStats + COALESCE(ChatStats.UnreadCount, 0), COALESCE(ChatStats.MinUnread, 0), g.unread_chat, + -- ChatItem + i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, + -- CIFile + f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, + -- Maybe GroupMember - sender + m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, + m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, + p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, + -- quoted ChatItem + ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent, + -- quoted GroupMember + rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category, + rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id, + rp.display_name, rp.full_name, rp.image, rp.contact_link, rp.local_alias, rp.preferences, + -- deleted by GroupMember + dbm.group_member_id, dbm.group_id, dbm.member_id, dbm.member_role, dbm.member_category, + dbm.member_status, dbm.invited_by, dbm.local_display_name, dbm.contact_id, dbm.contact_profile_id, dbp.contact_profile_id, + dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.preferences + FROM groups g + JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id + JOIN group_members mu ON mu.group_id = g.group_id + JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) + LEFT JOIN ( + SELECT group_id, MAX(chat_item_id) AS MaxId + FROM chat_items + GROUP BY group_id + ) MaxIds ON MaxIds.group_id = g.group_id + LEFT JOIN chat_items i ON i.group_id = MaxIds.group_id + AND i.chat_item_id = MaxIds.MaxId + LEFT JOIN files f ON f.chat_item_id = i.chat_item_id + LEFT JOIN ( + SELECT group_id, COUNT(1) AS UnreadCount, MIN(chat_item_id) AS MinUnread + FROM chat_items + WHERE item_status = ? + GROUP BY group_id + ) ChatStats ON ChatStats.group_id = g.group_id + 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 g.user_id = ? AND mu.contact_id = ? + ORDER BY i.item_ts DESC + |] + (CISRcvNew, userId, userContactId) + where + toGroupChatPreview :: UTCTime -> GroupInfoRow :. ChatStatsRow :. MaybeGroupChatItemRow -> AChat + toGroupChatPreview currentTs (groupInfoRow :. statsRow :. ciRow_) = + let groupInfo = toGroupInfo userContactId groupInfoRow + ci_ = toGroupChatItemList currentTs userContactId ciRow_ + stats = toChatStats statsRow + in AChat SCTGroup $ Chat (GroupChat groupInfo) ci_ stats + +getContactRequestChatPreviews_ :: DB.Connection -> User -> IO [AChat] +getContactRequestChatPreviews_ db User {userId} = + map toContactRequestChatPreview + <$> DB.query + db + [sql| + SELECT + cr.contact_request_id, cr.local_display_name, cr.agent_invitation_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, p.preferences, cr.created_at, cr.updated_at + 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 + |] + (userId, userId) + where + toContactRequestChatPreview :: ContactRequestRow -> AChat + toContactRequestChatPreview cReqRow = + let cReq = toContactRequest cReqRow + stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} + in AChat SCTContactRequest $ Chat (ContactRequest cReq) [] stats + +getContactConnectionChatPreviews_ :: DB.Connection -> User -> Bool -> IO [AChat] +getContactConnectionChatPreviews_ _ _ False = pure [] +getContactConnectionChatPreviews_ db User {userId} _ = + map toContactConnectionChatPreview + <$> DB.query + db + [sql| + SELECT connection_id, agent_conn_id, conn_status, via_contact_uri_hash, via_user_contact_link, group_link_id, custom_user_profile_id, conn_req_inv, local_alias, created_at, updated_at + FROM connections + WHERE user_id = ? AND conn_type = ? AND contact_id IS NULL AND conn_level = 0 AND via_contact IS NULL AND (via_group_link = 0 || (via_group_link = 1 AND group_link_id IS NOT NULL)) + |] + (userId, ConnContact) + where + toContactConnectionChatPreview :: (Int64, ConnId, ConnStatus, Maybe ByteString, Maybe Int64, Maybe GroupLinkId, Maybe Int64, Maybe ConnReqInvitation, LocalAlias, UTCTime, UTCTime) -> AChat + toContactConnectionChatPreview connRow = + let conn = toPendingContactConnection connRow + stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} + in AChat SCTContactConnection $ Chat (ContactConnection conn) [] stats + +getDirectChat :: DB.Connection -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTDirect) +getDirectChat db user contactId pagination search_ = do + let search = fromMaybe "" search_ + ct <- getContact db user contactId + liftIO . getDirectChatReactions_ db ct =<< case pagination of + CPLast count -> getDirectChatLast_ db user ct count search + CPAfter afterId count -> getDirectChatAfter_ db user ct afterId count search + CPBefore beforeId count -> getDirectChatBefore_ db user ct beforeId count search + +getDirectChatLast_ :: DB.Connection -> User -> Contact -> Int -> String -> ExceptT StoreError IO (Chat 'CTDirect) +getDirectChatLast_ db user ct@Contact {contactId} count search = do + let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} + chatItems <- getDirectChatItemsLast db user contactId count search + pure $ Chat (DirectChat ct) (reverse chatItems) stats + +-- the last items in reverse order (the last item in the conversation is the first in the returned list) +getDirectChatItemsLast :: DB.Connection -> User -> ContactId -> Int -> String -> ExceptT StoreError IO [CChatItem 'CTDirect] +getDirectChatItemsLast db User {userId} contactId count search = ExceptT $ do + currentTs <- getCurrentTime + mapM (toDirectChatItem currentTs) + <$> DB.query + db + [sql| + SELECT + -- ChatItem + i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, + -- CIFile + f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, + -- 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.item_text LIKE '%' || ? || '%' + ORDER BY i.chat_item_id DESC + LIMIT ? + |] + (userId, contactId, search, count) + +getDirectChatAfter_ :: DB.Connection -> User -> Contact -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTDirect) +getDirectChatAfter_ db User {userId} ct@Contact {contactId} afterChatItemId count search = do + let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} + chatItems <- ExceptT getDirectChatItemsAfter_ + pure $ Chat (DirectChat ct) chatItems stats + where + getDirectChatItemsAfter_ :: IO (Either StoreError [CChatItem 'CTDirect]) + getDirectChatItemsAfter_ = do + currentTs <- getCurrentTime + mapM (toDirectChatItem currentTs) + <$> DB.query + db + [sql| + SELECT + -- ChatItem + i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, + -- CIFile + f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, + -- 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.item_text LIKE '%' || ? || '%' + AND i.chat_item_id > ? + ORDER BY i.chat_item_id ASC + LIMIT ? + |] + (userId, contactId, search, afterChatItemId, count) + +getDirectChatBefore_ :: DB.Connection -> User -> Contact -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTDirect) +getDirectChatBefore_ db User {userId} ct@Contact {contactId} beforeChatItemId count search = do + let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} + chatItems <- ExceptT getDirectChatItemsBefore_ + pure $ Chat (DirectChat ct) (reverse chatItems) stats + where + getDirectChatItemsBefore_ :: IO (Either StoreError [CChatItem 'CTDirect]) + getDirectChatItemsBefore_ = do + currentTs <- getCurrentTime + mapM (toDirectChatItem currentTs) + <$> DB.query + db + [sql| + SELECT + -- ChatItem + i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, + -- CIFile + f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, + -- 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.item_text LIKE '%' || ? || '%' + AND i.chat_item_id < ? + ORDER BY i.chat_item_id DESC + LIMIT ? + |] + (userId, contactId, search, beforeChatItemId, count) + +getGroupChat :: DB.Connection -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTGroup) +getGroupChat db user groupId pagination search_ = do + let search = fromMaybe "" search_ + g <- getGroupInfo db user groupId + liftIO . getGroupChatReactions_ db g =<< case pagination of + CPLast count -> getGroupChatLast_ db user g count search + CPAfter afterId count -> getGroupChatAfter_ db user g afterId count search + CPBefore beforeId count -> getGroupChatBefore_ db user g beforeId count search + +getGroupChatLast_ :: DB.Connection -> User -> GroupInfo -> Int -> String -> ExceptT StoreError IO (Chat 'CTGroup) +getGroupChatLast_ db user@User {userId} g@GroupInfo {groupId} count search = do + let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} + chatItemIds <- liftIO getGroupChatItemIdsLast_ + chatItems <- mapM (getGroupChatItem db user groupId) chatItemIds + pure $ Chat (GroupChat g) (reverse chatItems) stats + where + getGroupChatItemIdsLast_ :: IO [ChatItemId] + getGroupChatItemIdsLast_ = + map fromOnly + <$> DB.query + db + [sql| + SELECT chat_item_id + FROM chat_items + WHERE user_id = ? AND group_id = ? AND item_text LIKE '%' || ? || '%' + ORDER BY item_ts DESC, chat_item_id DESC + LIMIT ? + |] + (userId, groupId, search, count) + +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 + +getGroupChatAfter_ :: DB.Connection -> User -> GroupInfo -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTGroup) +getGroupChatAfter_ db user@User {userId} g@GroupInfo {groupId} afterChatItemId count search = do + let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} + afterChatItem <- getGroupChatItem db user groupId afterChatItemId + chatItemIds <- liftIO $ getGroupChatItemIdsAfter_ (chatItemTs afterChatItem) + chatItems <- mapM (getGroupChatItem db user groupId) chatItemIds + pure $ Chat (GroupChat g) chatItems stats + where + getGroupChatItemIdsAfter_ :: UTCTime -> IO [ChatItemId] + getGroupChatItemIdsAfter_ afterChatItemTs = + map fromOnly + <$> DB.query + db + [sql| + SELECT chat_item_id + FROM chat_items + WHERE user_id = ? AND group_id = ? AND item_text LIKE '%' || ? || '%' + AND (item_ts > ? OR (item_ts = ? AND chat_item_id > ?)) + ORDER BY item_ts ASC, chat_item_id ASC + LIMIT ? + |] + (userId, groupId, search, afterChatItemTs, afterChatItemTs, afterChatItemId, count) + +getGroupChatBefore_ :: DB.Connection -> User -> GroupInfo -> ChatItemId -> Int -> String -> ExceptT StoreError IO (Chat 'CTGroup) +getGroupChatBefore_ db user@User {userId} g@GroupInfo {groupId} beforeChatItemId count search = do + let stats = ChatStats {unreadCount = 0, minUnreadItemId = 0, unreadChat = False} + beforeChatItem <- getGroupChatItem db user groupId beforeChatItemId + chatItemIds <- liftIO $ getGroupChatItemIdsBefore_ (chatItemTs beforeChatItem) + chatItems <- mapM (getGroupChatItem db user groupId) chatItemIds + pure $ Chat (GroupChat g) (reverse chatItems) stats + where + getGroupChatItemIdsBefore_ :: UTCTime -> IO [ChatItemId] + getGroupChatItemIdsBefore_ beforeChatItemTs = + map fromOnly + <$> DB.query + db + [sql| + SELECT chat_item_id + FROM chat_items + WHERE user_id = ? AND group_id = ? AND item_text LIKE '%' || ? || '%' + AND (item_ts < ? OR (item_ts = ? AND chat_item_id < ?)) + ORDER BY item_ts DESC, chat_item_id DESC + LIMIT ? + |] + (userId, groupId, search, beforeChatItemTs, beforeChatItemTs, beforeChatItemId, count) + +toChatItemRef :: (ChatItemId, Maybe Int64, Maybe Int64) -> Either StoreError (ChatRef, ChatItemId) +toChatItemRef = \case + (itemId, Just contactId, Nothing) -> Right (ChatRef CTDirect contactId, itemId) + (itemId, Nothing, Just groupId) -> Right (ChatRef CTGroup groupId, itemId) + (itemId, _, _) -> Left $ SEBadChatItem itemId + +updateDirectChatItemsRead :: DB.Connection -> User -> ContactId -> Maybe (ChatItemId, ChatItemId) -> IO () +updateDirectChatItemsRead db User {userId} contactId itemsRange_ = do + currentTs <- getCurrentTime + case itemsRange_ of + Just (fromItemId, toItemId) -> + DB.execute + db + [sql| + UPDATE chat_items SET item_status = ?, updated_at = ? + WHERE user_id = ? AND contact_id = ? AND chat_item_id >= ? AND chat_item_id <= ? AND item_status = ? + |] + (CISRcvRead, currentTs, userId, contactId, fromItemId, toItemId, CISRcvNew) + _ -> + 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) + +getDirectUnreadTimedItems :: DB.Connection -> User -> ContactId -> Maybe (ChatItemId, ChatItemId) -> IO [(ChatItemId, Int)] +getDirectUnreadTimedItems db User {userId} contactId itemsRange_ = case itemsRange_ of + Just (fromItemId, toItemId) -> + DB.query + db + [sql| + SELECT chat_item_id, timed_ttl + FROM chat_items + WHERE user_id = ? AND contact_id = ? + AND chat_item_id >= ? AND chat_item_id <= ? + AND item_status = ? + AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL + AND (item_live IS NULL OR item_live = ?) + |] + (userId, contactId, fromItemId, toItemId, CISRcvNew, False) + _ -> + 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) + +setDirectChatItemDeleteAt :: DB.Connection -> User -> ContactId -> ChatItemId -> UTCTime -> IO () +setDirectChatItemDeleteAt db User {userId} contactId chatItemId deleteAt = + DB.execute + db + "UPDATE chat_items SET timed_delete_at = ? WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?" + (deleteAt, userId, contactId, chatItemId) + +updateGroupChatItemsRead :: DB.Connection -> UserId -> GroupId -> Maybe (ChatItemId, ChatItemId) -> IO () +updateGroupChatItemsRead db userId groupId itemsRange_ = do + currentTs <- getCurrentTime + case itemsRange_ of + Just (fromItemId, toItemId) -> + DB.execute + db + [sql| + UPDATE chat_items SET item_status = ?, updated_at = ? + WHERE user_id = ? AND group_id = ? AND chat_item_id >= ? AND chat_item_id <= ? AND item_status = ? + |] + (CISRcvRead, currentTs, userId, groupId, fromItemId, toItemId, CISRcvNew) + _ -> + 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) + +getGroupUnreadTimedItems :: DB.Connection -> User -> GroupId -> Maybe (ChatItemId, ChatItemId) -> IO [(ChatItemId, Int)] +getGroupUnreadTimedItems db User {userId} groupId itemsRange_ = case itemsRange_ of + Just (fromItemId, toItemId) -> + DB.query + db + [sql| + SELECT chat_item_id, timed_ttl + FROM chat_items + WHERE user_id = ? AND group_id = ? + AND chat_item_id >= ? AND chat_item_id <= ? + AND item_status = ? + AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL + AND (item_live IS NULL OR item_live = ?) + |] + (userId, groupId, fromItemId, toItemId, CISRcvNew, False) + _ -> + 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) + +setGroupChatItemDeleteAt :: DB.Connection -> User -> GroupId -> ChatItemId -> UTCTime -> IO () +setGroupChatItemDeleteAt db User {userId} groupId chatItemId deleteAt = + DB.execute + db + "UPDATE chat_items SET timed_delete_at = ? WHERE user_id = ? AND group_id = ? AND chat_item_id = ?" + (deleteAt, userId, groupId, chatItemId) + +type ChatStatsRow = (Int, ChatItemId, Bool) + +toChatStats :: ChatStatsRow -> ChatStats +toChatStats (unreadCount, minUnreadItemId, unreadChat) = ChatStats {unreadCount, minUnreadItemId, unreadChat} + +type MaybeCIFIleRow = (Maybe Int64, Maybe String, Maybe Integer, Maybe FilePath, Maybe ACIFileStatus, Maybe FileProtocol) + +type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe Bool) + +type ChatItemRow = (Int64, ChatItemTs, AMsgDirection, Text, Text, ACIStatus, Maybe SharedMsgId) :. (Bool, Maybe UTCTime, Maybe Bool, UTCTime, UTCTime) :. ChatItemModeRow :. MaybeCIFIleRow + +type MaybeChatItemRow = (Maybe Int64, Maybe ChatItemTs, Maybe AMsgDirection, Maybe Text, Maybe Text, Maybe ACIStatus, Maybe SharedMsgId) :. (Maybe Bool, Maybe UTCTime, Maybe Bool, Maybe UTCTime, Maybe UTCTime) :. ChatItemModeRow :. MaybeCIFIleRow + +type QuoteRow = (Maybe ChatItemId, Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool) + +toDirectQuote :: QuoteRow -> Maybe (CIQuote 'CTDirect) +toDirectQuote qr@(_, _, _, _, quotedSent) = toQuote qr $ direction <$> quotedSent + 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) +toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_, fileProtocol_)) :. quoteRow) = + 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 + (Just fileId, Just fileName, Just fileSize, Just fileProtocol) -> Just CIFile {fileId, fileName, fileSize, filePath, fileStatus, fileProtocol} + _ -> Nothing + cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTDirect d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTDirect + cItem d chatDir ciStatus content file = + CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toDirectQuote quoteRow, reactions = [], file} + badItem = Left $ SEBadChatItem itemId + ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTDirect d + ciMeta content status = + let itemDeleted' = if itemDeleted then Just (CIDeleted @'CTDirect deletedTs) else Nothing + itemEdited' = fromMaybe False itemEdited + in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs createdAt updatedAt + ciTimed :: Maybe CITimed + ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} + +toDirectChatItemList :: UTCTime -> MaybeChatItemRow :. QuoteRow -> [CChatItem 'CTDirect] +toDirectChatItemList currentTs (((Just itemId, Just itemTs, Just msgDir, Just itemContent, Just itemText, Just itemStatus, sharedMsgId) :. (Just itemDeleted, deletedTs, itemEdited, Just createdAt, Just updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. quoteRow) = + either (const []) (: []) $ toDirectChatItem currentTs (((itemId, itemTs, msgDir, itemContent, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. quoteRow) +toDirectChatItemList _ _ = [] + +type GroupQuoteRow = QuoteRow :. MaybeGroupMemberRow + +type MaybeGroupChatItemRow = MaybeChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow + +toGroupQuote :: QuoteRow -> Maybe GroupMember -> Maybe (CIQuote 'CTGroup) +toGroupQuote qr@(_, _, _, _, quotedSent) quotedMember_ = toQuote qr $ direction quotedSent quotedMember_ + where + direction (Just True) _ = Just CIQGroupSnd + direction (Just False) (Just member) = Just . CIQGroupRcv $ Just member + direction (Just False) Nothing = Just $ CIQGroupRcv Nothing + direction _ _ = Nothing + +-- this function can be changed so it never fails, not only avoid failure on invalid json +toGroupChatItem :: UTCTime -> Int64 -> ChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow -> Either StoreError (CChatItem 'CTGroup) +toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_, fileProtocol_)) :. 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) -> Just CIFile {fileId, fileName, fileSize, filePath, 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, formattedText = parseMaybeMarkdownList itemText, quotedItem = toGroupQuote quoteRow quotedMember_, reactions = [], file} + badItem = Left $ SEBadChatItem itemId + ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTGroup d + ciMeta content status = + let itemDeleted' = + if itemDeleted + then Just (maybe (CIDeleted @'CTGroup deletedTs) (CIModerated deletedTs) deletedByGroupMember_) + else Nothing + itemEdited' = fromMaybe False itemEdited + in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs createdAt updatedAt + ciTimed :: Maybe CITimed + ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} + +toGroupChatItemList :: UTCTime -> Int64 -> MaybeGroupChatItemRow -> [CChatItem 'CTGroup] +toGroupChatItemList currentTs userContactId (((Just itemId, Just itemTs, Just msgDir, Just itemContent, Just itemText, Just itemStatus, sharedMsgId) :. (Just itemDeleted, deletedTs, itemEdited, Just createdAt, Just updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = + either (const []) (: []) $ toGroupChatItem currentTs userContactId (((itemId, itemTs, msgDir, itemContent, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) +toGroupChatItemList _ _ _ = [] + +getAllChatItems :: DB.Connection -> User -> ChatPagination -> Maybe String -> ExceptT StoreError IO [AChatItem] +getAllChatItems db user@User {userId} pagination search_ = do + 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 + mapM (uncurry (getAChatItem db user) >=> liftIO . getACIReactions db) itemRefs + where + search = fromMaybe "" search_ + getAChatItem_ itemId = do + chatRef <- getChatRefViaItemId db user itemId + getAChatItem db user chatRef itemId + getAllChatItemsLast_ count = + reverse + <$> DB.query + db + [sql| + SELECT chat_item_id, contact_id, group_id + FROM chat_items + WHERE user_id = ? AND item_text LIKE '%' || ? || '%' + ORDER BY item_ts DESC, chat_item_id DESC + LIMIT ? + |] + (userId, search, count) + getAllChatItemsAfter_ afterId count afterTs = + DB.query + db + [sql| + SELECT chat_item_id, contact_id, group_id + FROM chat_items + WHERE user_id = ? AND item_text LIKE '%' || ? || '%' + 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| + SELECT chat_item_id, contact_id, group_id + FROM chat_items + WHERE user_id = ? AND item_text LIKE '%' || ? || '%' + 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) + +getChatItemIdByAgentMsgId :: DB.Connection -> Int64 -> AgentMsgId -> IO (Maybe ChatItemId) +getChatItemIdByAgentMsgId db connId msgId = + fmap join . maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT chat_item_id + FROM chat_item_messages + WHERE message_id = ( + SELECT message_id + FROM msg_deliveries + WHERE connection_id = ? AND agent_msg_id = ? + LIMIT 1 + ) + |] + (connId, msgId) + +updateDirectChatItemStatus :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItemId -> CIStatus d -> ExceptT StoreError IO (ChatItem 'CTDirect d) +updateDirectChatItemStatus db user@User {userId} contactId itemId itemStatus = do + ci <- liftEither . correctDir =<< getDirectChatItem db user contactId itemId + currentTs <- liftIO getCurrentTime + liftIO $ DB.execute db "UPDATE chat_items SET item_status = ?, updated_at = ? WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?" (itemStatus, currentTs, userId, contactId, itemId) + pure ci {meta = (meta ci) {itemStatus}} + where + correctDir :: CChatItem c -> Either StoreError (ChatItem c d) + correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci + +updateDirectChatItem :: forall d. (MsgDirectionI d) => DB.Connection -> User -> Int64 -> ChatItemId -> CIContent d -> Bool -> Maybe MessageId -> ExceptT StoreError IO (ChatItem 'CTDirect d) +updateDirectChatItem db user contactId itemId newContent live msgId_ = do + ci <- liftEither . correctDir =<< getDirectChatItem db user contactId itemId + liftIO $ updateDirectChatItem' db user contactId ci newContent live msgId_ + where + correctDir :: CChatItem c -> Either StoreError (ChatItem c d) + correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci + +updateDirectChatItem' :: forall d. (MsgDirectionI d) => DB.Connection -> User -> Int64 -> ChatItem 'CTDirect d -> CIContent d -> Bool -> Maybe MessageId -> IO (ChatItem 'CTDirect d) +updateDirectChatItem' db User {userId} contactId ci newContent live msgId_ = do + currentTs <- liftIO getCurrentTime + let ci' = updatedChatItem ci newContent live currentTs + liftIO $ updateDirectChatItem_ db userId contactId ci' msgId_ + pure ci' + +updatedChatItem :: ChatItem c d -> CIContent d -> Bool -> UTCTime -> ChatItem c d +updatedChatItem ci@ChatItem {meta = meta@CIMeta {itemStatus, itemEdited, itemTimed, itemLive}} newContent live currentTs = + let newText = ciContentToText newContent + edited' = itemEdited || (itemLive /= Just True) + live' = (live &&) <$> itemLive + timed' = 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 + 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 = ? + |] + ((content, itemText, itemStatus, itemDeleted', itemDeletedTs', itemEdited, itemLive, updatedAt) :. ciTimedRow itemTimed :. (userId, contactId, itemId)) + 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 (?,?,?) + |] + (itemId, toMCText msgContent, itemVersionTs) + +deleteDirectChatItem :: DB.Connection -> User -> Contact -> CChatItem 'CTDirect -> IO () +deleteDirectChatItem db User {userId} Contact {contactId} (CChatItem _ ci) = do + 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 () +deleteChatItemMessages_ db itemId = + DB.execute + db + [sql| + DELETE FROM messages + WHERE message_id IN ( + SELECT message_id + FROM chat_item_messages + WHERE chat_item_id = ? + ) + |] + (Only itemId) + +deleteChatItemVersions_ :: DB.Connection -> ChatItemId -> IO () +deleteChatItemVersions_ db itemId = + DB.execute db "DELETE FROM chat_item_versions WHERE chat_item_id = ?" (Only itemId) + +markDirectChatItemDeleted :: DB.Connection -> User -> Contact -> CChatItem 'CTDirect -> MessageId -> UTCTime -> IO () +markDirectChatItemDeleted db User {userId} Contact {contactId} (CChatItem _ ci) msgId deletedTs = do + currentTs <- liftIO getCurrentTime + let itemId = chatItemId' ci + insertChatItemMessage_ db itemId msgId currentTs + DB.execute + db + [sql| + UPDATE chat_items + SET item_deleted = 1, item_deleted_ts = ?, updated_at = ? + WHERE user_id = ? AND contact_id = ? AND chat_item_id = ? + |] + (deletedTs, currentTs, userId, contactId, itemId) + +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 + +getDirectChatItemByAgentMsgId :: DB.Connection -> User -> ContactId -> Int64 -> AgentMsgId -> IO (Maybe (CChatItem 'CTDirect)) +getDirectChatItemByAgentMsgId db user contactId connId msgId = do + itemId_ <- getChatItemIdByAgentMsgId db connId msgId + maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getDirectChatItem db user contactId) itemId_ + +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 + join <$> firstRow (toDirectChatItem currentTs) (SEChatItemNotFound itemId) getItem + where + getItem = + DB.query + db + [sql| + SELECT + -- ChatItem + i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, + -- CIFile + f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, + -- 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 <> "%") + +updateGroupChatItem :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItem 'CTGroup d -> CIContent d -> Bool -> Maybe MessageId -> IO (ChatItem 'CTGroup d) +updateGroupChatItem db user groupId ci newContent live msgId_ = do + currentTs <- liftIO getCurrentTime + let ci' = updatedChatItem ci newContent live currentTs + 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 +updateGroupChatItem_ :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItem 'CTGroup d -> Maybe MessageId -> IO () +updateGroupChatItem_ db User {userId} groupId ChatItem {content, meta} msgId_ = do + let CIMeta {itemId, itemText, itemStatus, itemDeleted, itemEdited, itemTimed, itemLive, updatedAt} = meta + itemDeleted' = isJust itemDeleted + 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 = ? + |] + ((content, itemText, itemStatus, itemDeleted', itemDeletedTs', itemEdited, itemLive, updatedAt) :. ciTimedRow itemTimed :. (userId, groupId, itemId)) + forM_ msgId_ $ \msgId -> insertChatItemMessage_ db itemId msgId updatedAt + +deleteGroupChatItem :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> IO () +deleteGroupChatItem db User {userId} g@GroupInfo {groupId} (CChatItem _ ci) = do + 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) + +updateGroupChatItemModerated :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> GroupMember -> UTCTime -> IO AChatItem +updateGroupChatItemModerated db User {userId} gInfo@GroupInfo {groupId} (CChatItem msgDir ci) m@GroupMember {groupMemberId} deletedTs = do + currentTs <- getCurrentTime + let toContent = msgDirToModeratedContent_ msgDir + 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) + pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) (ci {content = toContent, meta = (meta ci) {itemText = toText, itemDeleted = Just (CIModerated (Just currentTs) m)}, formattedText = Nothing}) + +markGroupChatItemDeleted :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> MessageId -> Maybe GroupMember -> UTCTime -> IO () +markGroupChatItemDeleted db User {userId} GroupInfo {groupId} (CChatItem _ ci) msgId byGroupMember_ deletedTs = do + currentTs <- liftIO getCurrentTime + let itemId = chatItemId' ci + deletedByGroupMemberId = case byGroupMember_ of + Just GroupMember {groupMemberId} -> Just groupMemberId + _ -> Nothing + insertChatItemMessage_ db itemId msgId currentTs + DB.execute + db + [sql| + UPDATE chat_items + SET item_deleted = 1, item_deleted_ts = ?, item_deleted_by_group_member_id = ?, updated_at = ? + WHERE user_id = ? AND group_id = ? AND chat_item_id = ? + |] + (deletedTs, deletedByGroupMemberId, currentTs, userId, groupId, itemId) + +getGroupChatItemBySharedMsgId :: DB.Connection -> User -> GroupId -> GroupMemberId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTGroup) +getGroupChatItemBySharedMsgId db user@User {userId} groupId groupMemberId sharedMsgId = do + 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) + getGroupChatItem db user groupId itemId + +getGroupMemberCIBySharedMsgId :: DB.Connection -> User -> GroupId -> MemberId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTGroup) +getGroupMemberCIBySharedMsgId db user@User {userId} groupId memberId sharedMsgId = do + 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) + getGroupChatItem db user groupId itemId + +getGroupChatItem :: DB.Connection -> User -> Int64 -> ChatItemId -> ExceptT StoreError IO (CChatItem 'CTGroup) +getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do + currentTs <- getCurrentTime + join <$> firstRow (toGroupChatItem currentTs userContactId) (SEChatItemNotFound itemId) getItem + where + getItem = + DB.query + db + [sql| + SELECT + -- ChatItem + i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, + -- CIFile + f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, + -- GroupMember + m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, + m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, + p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, + -- quoted ChatItem + ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent, + -- quoted GroupMember + rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category, + rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id, + rp.display_name, rp.full_name, rp.image, rp.contact_link, rp.local_alias, rp.preferences, + -- deleted by GroupMember + dbm.group_member_id, dbm.group_id, dbm.member_id, dbm.member_role, dbm.member_category, + dbm.member_status, dbm.invited_by, dbm.local_display_name, dbm.contact_id, dbm.contact_profile_id, dbp.contact_profile_id, + dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.preferences + FROM chat_items i + LEFT JOIN files f ON f.chat_item_id = i.chat_item_id + 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 + JOIN contacts c ON c.contact_id = m.contact_id + WHERE i.user_id = ? AND i.group_id = ? AND c.local_display_name = ? AND i.item_text like ? + 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 <> "%") + +getChatItemByFileId :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO AChatItem +getChatItemByFileId db user@User {userId} fileId = do + (chatRef, itemId) <- + ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByFileId fileId) $ + DB.query + db + [sql| + SELECT i.chat_item_id, i.contact_id, i.group_id + 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) + getAChatItem db user chatRef itemId + +getChatItemByGroupId :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO AChatItem +getChatItemByGroupId db user@User {userId} groupId = do + (chatRef, itemId) <- + ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByGroupId groupId) $ + DB.query + db + [sql| + SELECT i.chat_item_id, i.contact_id, i.group_id + 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) + getAChatItem db user chatRef itemId + +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 + (Just contactId, Nothing) -> Right $ ChatRef CTDirect contactId + (Nothing, Just groupId) -> Right $ ChatRef CTGroup groupId + (_, _) -> Left $ SEBadChatItem itemId + +getAChatItem :: DB.Connection -> User -> ChatRef -> ChatItemId -> ExceptT StoreError IO AChatItem +getAChatItem db user chatRef itemId = case chatRef of + ChatRef CTDirect contactId -> do + ct <- getContact db user contactId + (CChatItem msgDir ci) <- getDirectChatItem db user contactId itemId + pure $ AChatItem SCTDirect msgDir (DirectChat ct) ci + ChatRef CTGroup groupId -> do + gInfo <- getGroupInfo db user groupId + (CChatItem msgDir ci) <- getGroupChatItem db user groupId itemId + pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) ci + _ -> throwError $ SEChatItemNotFound itemId + +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} + +getDirectChatReactions_ :: DB.Connection -> Contact -> Chat 'CTDirect -> IO (Chat 'CTDirect) +getDirectChatReactions_ db ct c@Chat {chatItems} = do + chatItems' <- forM chatItems $ \(CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId}}) -> do + reactions <- maybe (pure []) (getDirectCIReactions db ct) itemSharedMsgId + pure $ CChatItem md ci {reactions} + pure c {chatItems = chatItems'} + +getGroupChatReactions_ :: DB.Connection -> GroupInfo -> Chat 'CTGroup -> IO (Chat 'CTGroup) +getGroupChatReactions_ db g c@Chat {chatItems} = do + chatItems' <- forM chatItems $ \(CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId}}) -> do + let GroupMember {memberId} = chatItemMember g ci + reactions <- maybe (pure []) (getGroupCIReactions db g memberId) itemSharedMsgId + pure $ CChatItem md ci {reactions} + pure c {chatItems = chatItems'} + +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) + +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} + GroupChat g -> do + 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) + +toCIReaction :: (MsgReaction, Bool, Int) -> CIReactionCount +toCIReaction (reaction, userReacted, totalReacted) = CIReactionCount {reaction, userReacted, totalReacted} + +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 = ? + |] + (contactId' ct, itemSharedMId, sent) + +setDirectReaction :: DB.Connection -> Contact -> SharedMsgId -> Bool -> MsgReaction -> Bool -> MessageId -> UTCTime -> IO () +setDirectReaction db ct itemSharedMId sent reaction add msgId reactionTs + | add = + DB.execute + db + [sql| + INSERT INTO chat_item_reactions + (contact_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts) + VALUES (?,?,?,?,?,?) + |] + (contactId' ct, itemSharedMId, sent, reaction, msgId, reactionTs) + | otherwise = + DB.execute + db + [sql| + DELETE FROM chat_item_reactions + WHERE contact_id = ? AND shared_msg_id = ? AND reaction_sent = ? AND reaction = ? + |] + (contactId' ct, itemSharedMId, sent, reaction) + +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 = ? + |] + (groupId, groupMemberId' m, itemMemberId, itemSharedMId, sent) + +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 = + 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 (?,?,?,?,?,?,?,?) + |] + (groupId, groupMemberId' m, itemMemberId, itemSharedMId, sent, reaction, msgId, reactionTs) + | otherwise = + 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 = ? + |] + (groupId, groupMemberId' m, itemSharedMId, itemMemberId, sent, reaction) + +getTimedItems :: DB.Connection -> User -> UTCTime -> IO [((ChatRef, ChatItemId), UTCTime)] +getTimedItems db User {userId} startTimedThreadCutoff = + mapMaybe toCIRefDeleteAt + <$> DB.query + db + [sql| + SELECT chat_item_id, contact_id, group_id, timed_delete_at + FROM chat_items + WHERE user_id = ? AND timed_delete_at IS NOT NULL AND timed_delete_at <= ? + |] + (userId, startTimedThreadCutoff) + where + toCIRefDeleteAt :: (ChatItemId, Maybe ContactId, Maybe GroupId, UTCTime) -> Maybe ((ChatRef, ChatItemId), UTCTime) + toCIRefDeleteAt = \case + (itemId, Just contactId, Nothing, deleteAt) -> Just ((ChatRef CTDirect contactId, itemId), deleteAt) + (itemId, Nothing, Just groupId, deleteAt) -> Just ((ChatRef CTGroup groupId, itemId), deleteAt) + _ -> Nothing + +getChatItemTTL :: DB.Connection -> User -> IO (Maybe Int64) +getChatItemTTL db User {userId} = + fmap join . maybeFirstRow fromOnly $ DB.query db "SELECT chat_item_ttl FROM settings WHERE user_id = ? LIMIT 1" (Only userId) + +setChatItemTTL :: DB.Connection -> User -> Maybe Int64 -> IO () +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) + +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) diff --git a/src/Simplex/Chat/Store/Migrations.hs b/src/Simplex/Chat/Store/Migrations.hs new file mode 100644 index 000000000..32929f022 --- /dev/null +++ b/src/Simplex/Chat/Store/Migrations.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Simplex.Chat.Store.Migrations (migrations) where + +import Data.List (sortOn) +import Database.SQLite.Simple (Query (..)) +import Simplex.Chat.Migrations.M20220101_initial +import Simplex.Chat.Migrations.M20220122_v1_1 +import Simplex.Chat.Migrations.M20220205_chat_item_status +import Simplex.Chat.Migrations.M20220210_deduplicate_contact_requests +import Simplex.Chat.Migrations.M20220224_messages_fks +import Simplex.Chat.Migrations.M20220301_smp_servers +import Simplex.Chat.Migrations.M20220302_profile_images +import Simplex.Chat.Migrations.M20220304_msg_quotes +import Simplex.Chat.Migrations.M20220321_chat_item_edited +import Simplex.Chat.Migrations.M20220404_files_status_fields +import Simplex.Chat.Migrations.M20220514_profiles_user_id +import Simplex.Chat.Migrations.M20220626_auto_reply +import Simplex.Chat.Migrations.M20220702_calls +import Simplex.Chat.Migrations.M20220715_groups_chat_item_id +import Simplex.Chat.Migrations.M20220811_chat_items_indices +import Simplex.Chat.Migrations.M20220812_incognito_profiles +import Simplex.Chat.Migrations.M20220818_chat_notifications +import Simplex.Chat.Migrations.M20220822_groups_host_conn_custom_user_profile_id +import Simplex.Chat.Migrations.M20220823_delete_broken_group_event_chat_items +import Simplex.Chat.Migrations.M20220824_profiles_local_alias +import Simplex.Chat.Migrations.M20220909_commands +import Simplex.Chat.Migrations.M20220926_connection_alias +import Simplex.Chat.Migrations.M20220928_settings +import Simplex.Chat.Migrations.M20221001_shared_msg_id_indices +import Simplex.Chat.Migrations.M20221003_delete_broken_integrity_error_chat_items +import Simplex.Chat.Migrations.M20221004_idx_msg_deliveries_message_id +import Simplex.Chat.Migrations.M20221011_user_contact_links_group_id +import Simplex.Chat.Migrations.M20221012_inline_files +import Simplex.Chat.Migrations.M20221019_unread_chat +import Simplex.Chat.Migrations.M20221021_auto_accept__group_links +import Simplex.Chat.Migrations.M20221024_contact_used +import Simplex.Chat.Migrations.M20221025_chat_settings +import Simplex.Chat.Migrations.M20221029_group_link_id +import Simplex.Chat.Migrations.M20221112_server_password +import Simplex.Chat.Migrations.M20221115_server_cfg +import Simplex.Chat.Migrations.M20221129_delete_group_feature_items +import Simplex.Chat.Migrations.M20221130_delete_item_deleted +import Simplex.Chat.Migrations.M20221209_verified_connection +import Simplex.Chat.Migrations.M20221210_idxs +import Simplex.Chat.Migrations.M20221211_group_description +import Simplex.Chat.Migrations.M20221212_chat_items_timed +import Simplex.Chat.Migrations.M20221214_live_message +import Simplex.Chat.Migrations.M20221222_chat_ts +import Simplex.Chat.Migrations.M20221223_idx_chat_items_item_status +import Simplex.Chat.Migrations.M20221230_idxs +import Simplex.Chat.Migrations.M20230107_connections_auth_err_counter +import Simplex.Chat.Migrations.M20230111_users_agent_user_id +import Simplex.Chat.Migrations.M20230117_fkey_indexes +import Simplex.Chat.Migrations.M20230118_recreate_smp_servers +import Simplex.Chat.Migrations.M20230129_drop_chat_items_group_idx +import Simplex.Chat.Migrations.M20230206_item_deleted_by_group_member_id +import Simplex.Chat.Migrations.M20230303_group_link_role +import Simplex.Chat.Migrations.M20230317_hidden_profiles +import Simplex.Chat.Migrations.M20230318_file_description +import Simplex.Chat.Migrations.M20230321_agent_file_deleted +import Simplex.Chat.Migrations.M20230328_files_protocol +import Simplex.Chat.Migrations.M20230402_protocol_servers +import Simplex.Chat.Migrations.M20230411_extra_xftp_file_descriptions +import Simplex.Chat.Migrations.M20230420_rcv_files_to_receive +import Simplex.Chat.Migrations.M20230422_profile_contact_links +import Simplex.Chat.Migrations.M20230504_recreate_msg_delivery_events_cleanup_messages +import Simplex.Chat.Migrations.M20230505_chat_item_versions +import Simplex.Chat.Migrations.M20230511_reactions +import Simplex.Chat.Migrations.M20230519_item_deleted_ts +import Simplex.Chat.Migrations.M20230526_indexes +import Simplex.Chat.Migrations.M20230529_indexes +import Simplex.Chat.Migrations.M20230608_deleted_contacts +import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..)) + +schemaMigrations :: [(String, Query, Maybe Query)] +schemaMigrations = + [ ("20220101_initial", m20220101_initial, Nothing), + ("20220122_v1_1", m20220122_v1_1, Nothing), + ("20220205_chat_item_status", m20220205_chat_item_status, Nothing), + ("20220210_deduplicate_contact_requests", m20220210_deduplicate_contact_requests, Nothing), + ("20220224_messages_fks", m20220224_messages_fks, Nothing), + ("20220301_smp_servers", m20220301_smp_servers, Nothing), + ("20220302_profile_images", m20220302_profile_images, Nothing), + ("20220304_msg_quotes", m20220304_msg_quotes, Nothing), + ("20220321_chat_item_edited", m20220321_chat_item_edited, Nothing), + ("20220404_files_status_fields", m20220404_files_status_fields, Nothing), + ("20220514_profiles_user_id", m20220514_profiles_user_id, Nothing), + ("20220626_auto_reply", m20220626_auto_reply, Nothing), + ("20220702_calls", m20220702_calls, Nothing), + ("20220715_groups_chat_item_id", m20220715_groups_chat_item_id, Nothing), + ("20220811_chat_items_indices", m20220811_chat_items_indices, Nothing), + ("20220812_incognito_profiles", m20220812_incognito_profiles, Nothing), + ("20220818_chat_notifications", m20220818_chat_notifications, Nothing), + ("20220822_groups_host_conn_custom_user_profile_id", m20220822_groups_host_conn_custom_user_profile_id, Nothing), + ("20220823_delete_broken_group_event_chat_items", m20220823_delete_broken_group_event_chat_items, Nothing), + ("20220824_profiles_local_alias", m20220824_profiles_local_alias, Nothing), + ("20220909_commands", m20220909_commands, Nothing), + ("20220926_connection_alias", m20220926_connection_alias, Nothing), + ("20220928_settings", m20220928_settings, Nothing), + ("20221001_shared_msg_id_indices", m20221001_shared_msg_id_indices, Nothing), + ("20221003_delete_broken_integrity_error_chat_items", m20221003_delete_broken_integrity_error_chat_items, Nothing), + ("20221004_idx_msg_deliveries_message_id", m20221004_idx_msg_deliveries_message_id, Nothing), + ("20221011_user_contact_links_group_id", m20221011_user_contact_links_group_id, Nothing), + ("20221012_inline_files", m20221012_inline_files, Nothing), + ("20221019_unread_chat", m20221019_unread_chat, Nothing), + ("20221021_auto_accept__group_links", m20221021_auto_accept__group_links, Nothing), + ("20221024_contact_used", m20221024_contact_used, Nothing), + ("20221025_chat_settings", m20221025_chat_settings, Nothing), + ("20221029_group_link_id", m20221029_group_link_id, Nothing), + ("20221112_server_password", m20221112_server_password, Nothing), + ("20221115_server_cfg", m20221115_server_cfg, Nothing), + ("20221129_delete_group_feature_items", m20221129_delete_group_feature_items, Nothing), + ("20221130_delete_item_deleted", m20221130_delete_item_deleted, Nothing), + ("20221209_verified_connection", m20221209_verified_connection, Nothing), + ("20221210_idxs", m20221210_idxs, Nothing), + ("20221211_group_description", m20221211_group_description, Nothing), + ("20221212_chat_items_timed", m20221212_chat_items_timed, Nothing), + ("20221214_live_message", m20221214_live_message, Nothing), + ("20221222_chat_ts", m20221222_chat_ts, Nothing), + ("20221223_idx_chat_items_item_status", m20221223_idx_chat_items_item_status, Nothing), + ("20221230_idxs", m20221230_idxs, Nothing), + ("20230107_connections_auth_err_counter", m20230107_connections_auth_err_counter, Nothing), + ("20230111_users_agent_user_id", m20230111_users_agent_user_id, Nothing), + ("20230117_fkey_indexes", m20230117_fkey_indexes, Nothing), + ("20230118_recreate_smp_servers", m20230118_recreate_smp_servers, Nothing), + ("20230129_drop_chat_items_group_idx", m20230129_drop_chat_items_group_idx, Nothing), + ("20230206_item_deleted_by_group_member_id", m20230206_item_deleted_by_group_member_id, Nothing), + ("20230303_group_link_role", m20230303_group_link_role, Nothing), + ("20230317_hidden_profiles", m20230317_hidden_profiles, Just down_m20230317_hidden_profiles), + ("20230318_file_description", m20230318_file_description, Just down_m20230318_file_description), + ("20230321_agent_file_deleted", m20230321_agent_file_deleted, Just down_m20230321_agent_file_deleted), + ("20230328_files_protocol", m20230328_files_protocol, Just down_m20230328_files_protocol), + ("20230402_protocol_servers", m20230402_protocol_servers, Just down_m20230402_protocol_servers), + ("20230411_extra_xftp_file_descriptions", m20230411_extra_xftp_file_descriptions, Just down_m20230411_extra_xftp_file_descriptions), + ("20230420_rcv_files_to_receive", m20230420_rcv_files_to_receive, Just down_m20230420_rcv_files_to_receive), + ("20230422_profile_contact_links", m20230422_profile_contact_links, Just down_m20230422_profile_contact_links), + ("20230504_recreate_msg_delivery_events_cleanup_messages", m20230504_recreate_msg_delivery_events_cleanup_messages, Just down_m20230504_recreate_msg_delivery_events_cleanup_messages), + ("20230505_chat_item_versions", m20230505_chat_item_versions, Just down_m20230505_chat_item_versions), + ("20230511_reactions", m20230511_reactions, Just down_m20230511_reactions), + ("20230519_item_deleted_ts", m20230519_item_deleted_ts, Just down_m20230519_item_deleted_ts), + ("20230526_indexes", m20230526_indexes, Just down_m20230526_indexes), + ("20230529_indexes", m20230529_indexes, Just down_m20230529_indexes), + ("20230608_deleted_contacts", m20230608_deleted_contacts, Just down_m20230608_deleted_contacts) + ] + +-- | The list of migrations in ascending order by date +migrations :: [Migration] +migrations = sortOn name $ map migration schemaMigrations + where + migration (name, up, down) = Migration {name, up = fromQuery up, down = fromQuery <$> down} diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs new file mode 100644 index 000000000..121f563c2 --- /dev/null +++ b/src/Simplex/Chat/Store/Profiles.hs @@ -0,0 +1,537 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Simplex.Chat.Store.Profiles + ( AutoAccept (..), + UserContactLink (..), + createUserRecord, + createUserRecordAt, + getUsersInfo, + getUsers, + setActiveUser, + getSetActiveUser, + getUser, + getUserIdByName, + getUserByAConnId, + getUserByASndFileId, + getUserByARcvFileId, + getUserByContactId, + getUserByGroupId, + getUserByFileId, + getUserFileInfo, + deleteUserRecord, + updateUserPrivacy, + updateUserProfile, + setUserProfileContactLink, + getUserContactProfiles, + createUserContactLink, + getUserAddressConnections, + getUserContactLinks, + deleteUserAddress, + getUserAddress, + getUserContactLinkById, + updateUserAddressAutoAccept, + getProtocolServers, + overwriteProtocolServers, + createCall, + deleteCalls, + getCalls, + createCommand, + setCommandConnId, + deleteCommand, + updateCommandStatus, + getCommandDataByCorrId, + ) +where + +import Control.Monad.Except +import Data.Aeson (ToJSON) +import qualified Data.Aeson as J +import Data.Functor (($>)) +import Data.Int (Int64) +import qualified Data.List.NonEmpty as L +import Data.Maybe (fromMaybe) +import Data.List.NonEmpty (NonEmpty) +import Data.Text (Text) +import Data.Text.Encoding (decodeLatin1, encodeUtf8) +import Data.Time.Clock (UTCTime (..), getCurrentTime) +import Database.SQLite.Simple (NamedParam (..), Only (..), (:.) (..)) +import qualified Database.SQLite.Simple as DB +import Database.SQLite.Simple.QQ (sql) +import GHC.Generics (Generic) +import Simplex.Chat.Call +import Simplex.Chat.Messages +import Simplex.Chat.Protocol +import Simplex.Chat.Store.Direct +import Simplex.Chat.Store.Shared +import Simplex.Chat.Types +import Simplex.Messaging.Agent.Protocol (ACorrId, ConnId, UserId) +import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..)) +import Simplex.Messaging.Transport.Client (TransportHost) +import Simplex.Messaging.Util (safeDecodeUtf8) + +createUserRecord :: DB.Connection -> AgentUserId -> Profile -> Bool -> ExceptT StoreError IO User +createUserRecord db auId p activeUser = createUserRecordAt db auId p activeUser =<< liftIO getCurrentTime + +createUserRecordAt :: DB.Connection -> AgentUserId -> Profile -> Bool -> UTCTime -> ExceptT StoreError IO User +createUserRecordAt db (AgentUserId auId) Profile {displayName, fullName, image, preferences = userPreferences} activeUser currentTs = + checkConstraint SEDuplicateName . liftIO $ do + when activeUser $ DB.execute_ db "UPDATE users SET active_user = 0" + DB.execute + db + "INSERT INTO users (agent_user_id, local_display_name, active_user, contact_id, show_ntfs, created_at, updated_at) VALUES (?,?,?,0,?,?,?)" + (auId, displayName, activeUser, True, currentTs, currentTs) + userId <- insertedRowId db + DB.execute + db + "INSERT INTO display_names (local_display_name, ldn_base, user_id, created_at, updated_at) VALUES (?,?,?,?,?)" + (displayName, displayName, userId, currentTs, currentTs) + DB.execute + db + "INSERT INTO contact_profiles (display_name, full_name, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?)" + (displayName, fullName, image, userId, userPreferences, currentTs, currentTs) + profileId <- insertedRowId db + DB.execute + db + "INSERT INTO contacts (contact_profile_id, local_display_name, user_id, is_user, created_at, updated_at) VALUES (?,?,?,?,?,?)" + (profileId, displayName, userId, True, currentTs, currentTs) + contactId <- insertedRowId db + DB.execute db "UPDATE users SET contact_id = ? WHERE user_id = ?" (contactId, userId) + pure $ toUser $ (userId, auId, contactId, profileId, activeUser, displayName, fullName, image, Nothing, userPreferences, True) :. (Nothing, Nothing) + +getUsersInfo :: DB.Connection -> IO [UserInfo] +getUsersInfo db = getUsers db >>= mapM getUserInfo + where + getUserInfo :: User -> IO UserInfo + getUserInfo user@User {userId} = do + ctCount <- + maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT COUNT(1) + FROM chat_items i + JOIN contacts ct USING (contact_id) + WHERE i.user_id = ? AND i.item_status = ? AND (ct.enable_ntfs = 1 OR ct.enable_ntfs IS NULL) AND ct.deleted = 0 + |] + (userId, CISRcvNew) + gCount <- + maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT COUNT(1) + FROM chat_items i + JOIN groups g USING (group_id) + WHERE i.user_id = ? AND i.item_status = ? AND (g.enable_ntfs = 1 OR g.enable_ntfs IS NULL) + |] + (userId, CISRcvNew) + pure UserInfo {user, unreadCount = fromMaybe 0 ctCount + fromMaybe 0 gCount} + +getUsers :: DB.Connection -> IO [User] +getUsers db = + map toUser <$> DB.query_ db userQuery + +setActiveUser :: DB.Connection -> UserId -> IO () +setActiveUser db userId = do + DB.execute_ db "UPDATE users SET active_user = 0" + DB.execute db "UPDATE users SET active_user = 1 WHERE user_id = ?" (Only userId) + +getSetActiveUser :: DB.Connection -> UserId -> ExceptT StoreError IO User +getSetActiveUser db userId = do + liftIO $ setActiveUser db userId + getUser db userId + +getUser :: DB.Connection -> UserId -> ExceptT StoreError IO User +getUser db userId = + ExceptT . firstRow toUser (SEUserNotFound userId) $ + DB.query db (userQuery <> " WHERE u.user_id = ?") (Only userId) + +getUserIdByName :: DB.Connection -> UserName -> ExceptT StoreError IO Int64 +getUserIdByName db uName = + ExceptT . firstRow fromOnly (SEUserNotFoundByName uName) $ + DB.query db "SELECT user_id FROM users WHERE local_display_name = ?" (Only uName) + +getUserByAConnId :: DB.Connection -> AgentConnId -> IO (Maybe User) +getUserByAConnId db agentConnId = + maybeFirstRow toUser $ + DB.query db (userQuery <> " JOIN connections c ON c.user_id = u.user_id WHERE c.agent_conn_id = ?") (Only agentConnId) + +getUserByASndFileId :: DB.Connection -> AgentSndFileId -> IO (Maybe User) +getUserByASndFileId db aSndFileId = + maybeFirstRow toUser $ + DB.query db (userQuery <> " JOIN files f ON f.user_id = u.user_id WHERE f.agent_snd_file_id = ?") (Only aSndFileId) + +getUserByARcvFileId :: DB.Connection -> AgentRcvFileId -> IO (Maybe User) +getUserByARcvFileId db aRcvFileId = + maybeFirstRow toUser $ + DB.query db (userQuery <> " JOIN files f ON f.user_id = u.user_id JOIN rcv_files r ON r.file_id = f.file_id WHERE r.agent_rcv_file_id = ?") (Only aRcvFileId) + +getUserByContactId :: DB.Connection -> ContactId -> ExceptT StoreError IO User +getUserByContactId db contactId = + ExceptT . firstRow toUser (SEUserNotFoundByContactId contactId) $ + DB.query db (userQuery <> " JOIN contacts ct ON ct.user_id = u.user_id WHERE ct.contact_id = ? AND ct.deleted = 0") (Only contactId) + +getUserByGroupId :: DB.Connection -> GroupId -> ExceptT StoreError IO User +getUserByGroupId db groupId = + ExceptT . firstRow toUser (SEUserNotFoundByGroupId groupId) $ + DB.query db (userQuery <> " JOIN groups g ON g.user_id = u.user_id WHERE g.group_id = ?") (Only groupId) + +getUserByFileId :: DB.Connection -> FileTransferId -> ExceptT StoreError IO User +getUserByFileId db fileId = + ExceptT . firstRow toUser (SEUserNotFoundByFileId fileId) $ + DB.query db (userQuery <> " JOIN files f ON f.user_id = u.user_id WHERE f.file_id = ?") (Only fileId) + +getUserFileInfo :: DB.Connection -> User -> IO [CIFileInfo] +getUserFileInfo db User {userId} = + map toFileInfo + <$> DB.query db (fileInfoQuery <> " WHERE i.user_id = ?") (Only userId) + +deleteUserRecord :: DB.Connection -> User -> IO () +deleteUserRecord db User {userId} = + DB.execute db "DELETE FROM users WHERE user_id = ?" (Only userId) + +updateUserPrivacy :: DB.Connection -> User -> IO () +updateUserPrivacy db User {userId, showNtfs, viewPwdHash} = + DB.execute + db + [sql| + UPDATE users + SET view_pwd_hash = ?, view_pwd_salt = ?, show_ntfs = ? + WHERE user_id = ? + |] + (hashSalt viewPwdHash :. (showNtfs, userId)) + where + hashSalt = L.unzip . fmap (\UserPwdHash {hash, salt} -> (hash, salt)) + +updateUserProfile :: DB.Connection -> User -> Profile -> ExceptT StoreError IO User +updateUserProfile db user p' + | displayName == newName = do + liftIO $ updateContactProfile_ db userId profileId p' + pure user {profile, fullPreferences} + | otherwise = + checkConstraint SEDuplicateName . liftIO $ do + currentTs <- getCurrentTime + DB.execute db "UPDATE users SET local_display_name = ?, updated_at = ? WHERE user_id = ?" (newName, currentTs, userId) + DB.execute + db + "INSERT INTO display_names (local_display_name, ldn_base, user_id, created_at, updated_at) VALUES (?,?,?,?,?)" + (newName, newName, userId, currentTs, currentTs) + updateContactProfile_' db userId profileId p' currentTs + updateContact_ db userId userContactId localDisplayName newName currentTs + pure user {localDisplayName = newName, profile, fullPreferences} + where + User {userId, userContactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}} = user + Profile {displayName = newName, preferences} = p' + profile = toLocalProfile profileId p' localAlias + fullPreferences = mergePreferences Nothing preferences + +setUserProfileContactLink :: DB.Connection -> User -> Maybe UserContactLink -> IO User +setUserProfileContactLink db user@User {userId, profile = p@LocalProfile {profileId}} ucl_ = do + ts <- getCurrentTime + DB.execute + db + [sql| + UPDATE contact_profiles + SET contact_link = ?, updated_at = ? + WHERE user_id = ? AND contact_profile_id = ? + |] + (connReqContact_, ts, userId, profileId) + pure (user :: User) {profile = p {contactLink = connReqContact_}} + where + connReqContact_ = case ucl_ of + Just UserContactLink {connReqContact} -> Just connReqContact + _ -> Nothing + +-- only used in tests +getUserContactProfiles :: DB.Connection -> User -> IO [Profile] +getUserContactProfiles db User {userId} = + map toContactProfile + <$> DB.query + db + [sql| + SELECT display_name, full_name, image, contact_link, preferences + FROM contact_profiles + WHERE user_id = ? + |] + (Only userId) + where + toContactProfile :: (ContactName, Text, Maybe ImageData, Maybe ConnReqContact, Maybe Preferences) -> (Profile) + toContactProfile (displayName, fullName, image, contactLink, preferences) = Profile {displayName, fullName, image, contactLink, preferences} + +createUserContactLink :: DB.Connection -> User -> ConnId -> ConnReqContact -> ExceptT StoreError IO () +createUserContactLink db User {userId} agentConnId cReq = + checkConstraint SEDuplicateContactLink . liftIO $ do + currentTs <- getCurrentTime + DB.execute + db + "INSERT INTO user_contact_links (user_id, conn_req_contact, created_at, updated_at) VALUES (?,?,?,?)" + (userId, cReq, currentTs, currentTs) + userContactLinkId <- insertedRowId db + void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId Nothing Nothing Nothing 0 currentTs + +getUserAddressConnections :: DB.Connection -> User -> ExceptT StoreError IO [Connection] +getUserAddressConnections db User {userId} = do + cs <- liftIO getUserAddressConnections_ + if null cs then throwError SEUserContactLinkNotFound else pure cs + where + getUserAddressConnections_ :: IO [Connection] + getUserAddressConnections_ = + map toConnection + <$> DB.query + db + [sql| + SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, + c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter + FROM connections c + JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id + WHERE c.user_id = ? AND uc.user_id = ? AND uc.local_display_name = '' AND uc.group_id IS NULL + |] + (userId, userId) + +getUserContactLinks :: DB.Connection -> User -> IO [(Connection, UserContact)] +getUserContactLinks db User {userId} = + map toUserContactConnection + <$> DB.query + db + [sql| + SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, + c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter, + uc.user_contact_link_id, uc.conn_req_contact, uc.group_id + FROM connections c + JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id + WHERE c.user_id = ? AND uc.user_id = ? + |] + (userId, userId) + where + toUserContactConnection :: (ConnectionRow :. (Int64, ConnReqContact, Maybe GroupId)) -> (Connection, UserContact) + toUserContactConnection (connRow :. (userContactLinkId, connReqContact, groupId)) = (toConnection connRow, UserContact {userContactLinkId, connReqContact, groupId}) + +deleteUserAddress :: DB.Connection -> User -> IO () +deleteUserAddress db user@User {userId} = do + DB.execute + db + [sql| + DELETE FROM connections WHERE connection_id IN ( + SELECT connection_id + FROM connections c + JOIN user_contact_links uc USING (user_contact_link_id) + WHERE uc.user_id = ? AND uc.local_display_name = '' AND uc.group_id IS NULL + ) + |] + (Only userId) + DB.executeNamed + db + [sql| + DELETE FROM display_names + WHERE user_id = :user_id + AND local_display_name in ( + SELECT cr.local_display_name + FROM contact_requests cr + JOIN user_contact_links uc USING (user_contact_link_id) + WHERE uc.user_id = :user_id AND uc.local_display_name = '' AND uc.group_id IS NULL + ) + |] + [":user_id" := userId] + DB.executeNamed + db + [sql| + DELETE FROM contact_profiles + WHERE contact_profile_id in ( + SELECT cr.contact_profile_id + FROM contact_requests cr + JOIN user_contact_links uc USING (user_contact_link_id) + WHERE uc.user_id = :user_id AND uc.local_display_name = '' AND uc.group_id IS NULL + ) + |] + [":user_id" := userId] + void $ setUserProfileContactLink db user Nothing + DB.execute db "DELETE FROM user_contact_links WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL" (Only userId) + +data UserContactLink = UserContactLink + { connReqContact :: ConnReqContact, + autoAccept :: Maybe AutoAccept + } + deriving (Show, Generic) + +instance ToJSON UserContactLink where toEncoding = J.genericToEncoding J.defaultOptions + +data AutoAccept = AutoAccept + { acceptIncognito :: Bool, + autoReply :: Maybe MsgContent + } + deriving (Show, Generic) + +instance ToJSON AutoAccept where toEncoding = J.genericToEncoding J.defaultOptions + +toUserContactLink :: (ConnReqContact, Bool, Bool, Maybe MsgContent) -> UserContactLink +toUserContactLink (connReq, autoAccept, acceptIncognito, autoReply) = + UserContactLink connReq $ + if autoAccept then Just AutoAccept {acceptIncognito, autoReply} else Nothing + +getUserAddress :: DB.Connection -> User -> ExceptT StoreError IO UserContactLink +getUserAddress db User {userId} = + ExceptT . firstRow toUserContactLink SEUserContactLinkNotFound $ + DB.query + db + [sql| + SELECT conn_req_contact, auto_accept, auto_accept_incognito, auto_reply_msg_content + FROM user_contact_links + WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL + |] + (Only userId) + +getUserContactLinkById :: DB.Connection -> UserId -> Int64 -> IO (Maybe (UserContactLink, Maybe GroupId, GroupMemberRole)) +getUserContactLinkById db userId userContactLinkId = + maybeFirstRow (\(ucl :. (groupId_, mRole_)) -> (toUserContactLink ucl, groupId_, fromMaybe GRMember mRole_)) $ + DB.query + db + [sql| + SELECT conn_req_contact, auto_accept, auto_accept_incognito, auto_reply_msg_content, group_id, group_link_member_role + FROM user_contact_links + WHERE user_id = ? + AND user_contact_link_id = ? + |] + (userId, userContactLinkId) + +updateUserAddressAutoAccept :: DB.Connection -> User -> Maybe AutoAccept -> ExceptT StoreError IO UserContactLink +updateUserAddressAutoAccept db user@User {userId} autoAccept = do + link <- getUserAddress db user + liftIO updateUserAddressAutoAccept_ $> link {autoAccept} + where + updateUserAddressAutoAccept_ = + DB.execute + db + [sql| + UPDATE user_contact_links + SET auto_accept = ?, auto_accept_incognito = ?, auto_reply_msg_content = ? + WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL + |] + (ucl :. Only userId) + ucl = case autoAccept of + Just AutoAccept {acceptIncognito, autoReply} -> (True, acceptIncognito, autoReply) + _ -> (False, False, Nothing) + + + + +getProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> IO [ServerCfg p] +getProtocolServers db User {userId} = + map toServerCfg + <$> DB.query + db + [sql| + SELECT host, port, key_hash, basic_auth, preset, tested, enabled + FROM protocol_servers + WHERE user_id = ? AND protocol = ?; + |] + (userId, decodeLatin1 $ strEncode protocol) + where + protocol = protocolTypeI @p + toServerCfg :: (NonEmpty TransportHost, String, C.KeyHash, Maybe Text, Bool, Maybe Bool, Bool) -> ServerCfg p + toServerCfg (host, port, keyHash, auth_, preset, tested, enabled) = + let server = ProtoServerWithAuth (ProtocolServer protocol host port keyHash) (BasicAuth . encodeUtf8 <$> auth_) + in ServerCfg {server, preset, tested, enabled} + +overwriteProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> [ServerCfg p] -> ExceptT StoreError IO () +overwriteProtocolServers db User {userId} servers = + checkConstraint SEUniqueID . ExceptT $ do + currentTs <- getCurrentTime + DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND protocol = ? " (userId, protocol) + forM_ servers $ \ServerCfg {server, preset, tested, enabled} -> do + let ProtoServerWithAuth ProtocolServer {host, port, keyHash} auth_ = server + DB.execute + db + [sql| + INSERT INTO protocol_servers + (protocol, host, port, key_hash, basic_auth, preset, tested, enabled, user_id, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?,?,?,?) + |] + ((protocol, host, port, keyHash, safeDecodeUtf8 . unBasicAuth <$> auth_) :. (preset, tested, enabled, userId, currentTs, currentTs)) + pure $ Right () + where + protocol = decodeLatin1 $ strEncode $ protocolTypeI @p + +createCall :: DB.Connection -> User -> Call -> UTCTime -> IO () +createCall db user@User {userId} Call {contactId, callId, chatItemId, callState} callTs = do + currentTs <- getCurrentTime + deleteCalls db user contactId + DB.execute + db + [sql| + INSERT INTO calls + (contact_id, shared_call_id, chat_item_id, call_state, call_ts, user_id, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?) + |] + (contactId, callId, chatItemId, callState, callTs, userId, currentTs, currentTs) + +deleteCalls :: DB.Connection -> User -> ContactId -> IO () +deleteCalls db User {userId} contactId = do + DB.execute db "DELETE FROM calls WHERE user_id = ? AND contact_id = ?" (userId, contactId) + +getCalls :: DB.Connection -> IO [Call] +getCalls db = + map toCall + <$> DB.query_ + db + [sql| + SELECT + contact_id, shared_call_id, chat_item_id, call_state, call_ts + FROM calls + ORDER BY call_ts ASC + |] + where + toCall :: (ContactId, CallId, ChatItemId, CallState, UTCTime) -> Call + toCall (contactId, callId, chatItemId, callState, callTs) = Call {contactId, callId, chatItemId, callState, callTs} + +createCommand :: DB.Connection -> User -> Maybe Int64 -> CommandFunction -> IO CommandId +createCommand db User {userId} connId commandFunction = do + currentTs <- getCurrentTime + DB.execute + db + [sql| + INSERT INTO commands (connection_id, command_function, command_status, user_id, created_at, updated_at) + VALUES (?,?,?,?,?,?) + |] + (connId, commandFunction, CSCreated, userId, currentTs, currentTs) + insertedRowId db + +deleteCommand :: DB.Connection -> User -> CommandId -> IO () +deleteCommand db User {userId} cmdId = + DB.execute db "DELETE FROM commands WHERE user_id = ? AND command_id = ?" (userId, cmdId) + +updateCommandStatus :: DB.Connection -> User -> CommandId -> CommandStatus -> IO () +updateCommandStatus db User {userId} cmdId status = do + updatedAt <- getCurrentTime + DB.execute + db + [sql| + UPDATE commands + SET command_status = ?, updated_at = ? + WHERE user_id = ? AND command_id = ? + |] + (status, updatedAt, userId, cmdId) + +getCommandDataByCorrId :: DB.Connection -> User -> ACorrId -> IO (Maybe CommandData) +getCommandDataByCorrId db User {userId} corrId = + maybeFirstRow toCommandData $ + DB.query + db + [sql| + SELECT command_id, connection_id, command_function, command_status + FROM commands + WHERE user_id = ? AND command_id = ? + |] + (userId, commandId corrId) + where + toCommandData :: (CommandId, Maybe Int64, CommandFunction, CommandStatus) -> CommandData + toCommandData (cmdId, cmdConnId, cmdFunction, cmdStatus) = CommandData {cmdId, cmdConnId, cmdFunction, cmdStatus} diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs new file mode 100644 index 000000000..f46ff35b3 --- /dev/null +++ b/src/Simplex/Chat/Store/Shared.hs @@ -0,0 +1,332 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Simplex.Chat.Store.Shared where + +import Control.Concurrent.STM (stateTVar) +import Control.Exception (Exception) +import qualified Control.Exception as E +import Control.Monad.Except +import Crypto.Random (ChaChaDRG, randomBytesGenerate) +import Data.Aeson (ToJSON) +import qualified Data.Aeson as J +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Base64 as B64 +import Data.Int (Int64) +import Data.Maybe (fromMaybe, isJust, listToMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (UTCTime (..), getCurrentTime) +import Database.SQLite.Simple (NamedParam (..), Only (..), Query, SQLError, (:.) (..)) +import qualified Database.SQLite.Simple as DB +import Database.SQLite.Simple.QQ (sql) +import GHC.Generics (Generic) +import Simplex.Chat.Messages +import Simplex.Chat.Protocol +import Simplex.Chat.Types +import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, UserId) +import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) +import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON) +import UnliftIO.STM + +-- These error type constructors must be added to mobile apps +data StoreError + = SEDuplicateName + | SEUserNotFound {userId :: UserId} + | SEUserNotFoundByName {contactName :: ContactName} + | SEUserNotFoundByContactId {contactId :: ContactId} + | SEUserNotFoundByGroupId {groupId :: GroupId} + | SEUserNotFoundByFileId {fileId :: FileTransferId} + | SEUserNotFoundByContactRequestId {contactRequestId :: Int64} + | SEContactNotFound {contactId :: ContactId} + | SEContactNotFoundByName {contactName :: ContactName} + | SEContactNotReady {contactName :: ContactName} + | SEDuplicateContactLink + | SEUserContactLinkNotFound + | SEContactRequestNotFound {contactRequestId :: Int64} + | SEContactRequestNotFoundByName {contactName :: ContactName} + | SEGroupNotFound {groupId :: GroupId} + | SEGroupNotFoundByName {groupName :: GroupName} + | SEGroupMemberNameNotFound {groupId :: GroupId, groupMemberName :: ContactName} + | SEGroupMemberNotFound {groupMemberId :: GroupMemberId} + | SEGroupWithoutUser + | SEDuplicateGroupMember + | SEGroupAlreadyJoined + | SEGroupInvitationNotFound + | SESndFileNotFound {fileId :: FileTransferId} + | SESndFileInvalid {fileId :: FileTransferId} + | SERcvFileNotFound {fileId :: FileTransferId} + | SERcvFileDescrNotFound {fileId :: FileTransferId} + | SEFileNotFound {fileId :: FileTransferId} + | SERcvFileInvalid {fileId :: FileTransferId} + | SERcvFileInvalidDescrPart + | SESharedMsgIdNotFoundByFileId {fileId :: FileTransferId} + | SEFileIdNotFoundBySharedMsgId {sharedMsgId :: SharedMsgId} + | SESndFileNotFoundXFTP {agentSndFileId :: AgentSndFileId} + | SERcvFileNotFoundXFTP {agentRcvFileId :: AgentRcvFileId} + | SEConnectionNotFound {agentConnId :: AgentConnId} + | SEConnectionNotFoundById {connId :: Int64} + | SEPendingConnectionNotFound {connId :: Int64} + | SEIntroNotFound + | SEUniqueID + | SEInternalError {message :: String} + | SENoMsgDelivery {connId :: Int64, agentMsgId :: AgentMsgId} + | SEBadChatItem {itemId :: ChatItemId} + | SEChatItemNotFound {itemId :: ChatItemId} + | SEChatItemNotFoundByText {text :: Text} + | SEChatItemSharedMsgIdNotFound {sharedMsgId :: SharedMsgId} + | SEChatItemNotFoundByFileId {fileId :: FileTransferId} + | SEChatItemNotFoundByGroupId {groupId :: GroupId} + | SEProfileNotFound {profileId :: Int64} + | SEDuplicateGroupLink {groupInfo :: GroupInfo} + | SEGroupLinkNotFound {groupInfo :: GroupInfo} + | SEHostMemberIdNotFound {groupId :: Int64} + | SEContactNotFoundByFileId {fileId :: FileTransferId} + deriving (Show, Exception, Generic) + +instance ToJSON StoreError where + toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "SE" + toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "SE" + +insertedRowId :: DB.Connection -> IO Int64 +insertedRowId db = fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid()" + +checkConstraint :: StoreError -> ExceptT StoreError IO a -> ExceptT StoreError IO a +checkConstraint err action = ExceptT $ runExceptT action `E.catch` (pure . Left . handleSQLError err) + +handleSQLError :: StoreError -> SQLError -> StoreError +handleSQLError err e + | DB.sqlError e == DB.ErrorConstraint = err + | otherwise = SEInternalError $ show e + +fileInfoQuery :: Query +fileInfoQuery = + [sql| + SELECT f.file_id, f.ci_file_status, f.file_path + FROM chat_items i + JOIN files f ON f.chat_item_id = i.chat_item_id + |] + +toFileInfo :: (Int64, Maybe ACIFileStatus, Maybe FilePath) -> CIFileInfo +toFileInfo (fileId, fileStatus, filePath) = CIFileInfo {fileId, fileStatus, filePath} + +type EntityIdsRow = (Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64) + +type ConnectionRow = (Int64, ConnId, Int, Maybe Int64, Maybe Int64, Bool, Maybe GroupLinkId, Maybe Int64, ConnStatus, ConnType, LocalAlias) :. EntityIdsRow :. (UTCTime, Maybe Text, Maybe UTCTime, Int) + +type MaybeConnectionRow = (Maybe Int64, Maybe ConnId, Maybe Int, Maybe Int64, Maybe Int64, Maybe Bool, Maybe GroupLinkId, Maybe Int64, Maybe ConnStatus, Maybe ConnType, Maybe LocalAlias) :. EntityIdsRow :. (Maybe UTCTime, Maybe Text, Maybe UTCTime, Maybe Int) + +toConnection :: ConnectionRow -> Connection +toConnection ((connId, acId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (createdAt, code_, verifiedAt_, authErrCounter)) = + let entityId = entityId_ connType + connectionCode = SecurityCode <$> code_ <*> verifiedAt_ + in Connection {connId, agentConnId = AgentConnId acId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, localAlias, entityId, connectionCode, authErrCounter, createdAt} + where + entityId_ :: ConnType -> Maybe Int64 + entityId_ ConnContact = contactId + entityId_ ConnMember = groupMemberId + entityId_ ConnRcvFile = rcvFileId + entityId_ ConnSndFile = sndFileId + entityId_ ConnUserContact = userContactLinkId + +toMaybeConnection :: MaybeConnectionRow -> Maybe Connection +toMaybeConnection ((Just connId, Just agentConnId, Just connLevel, viaContact, viaUserContactLink, Just viaGroupLink, groupLinkId, customUserProfileId, Just connStatus, Just connType, Just localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (Just createdAt, code_, verifiedAt_, Just authErrCounter)) = + Just $ toConnection ((connId, agentConnId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (createdAt, code_, verifiedAt_, authErrCounter)) +toMaybeConnection _ = Nothing + +createConnection_ :: DB.Connection -> UserId -> ConnType -> Maybe Int64 -> ConnId -> Maybe ContactId -> Maybe Int64 -> Maybe ProfileId -> Int -> UTCTime -> IO Connection +createConnection_ db userId connType entityId acId viaContact viaUserContactLink customUserProfileId connLevel currentTs = do + viaLinkGroupId :: Maybe Int64 <- fmap join . forM viaUserContactLink $ \ucLinkId -> + maybeFirstRow fromOnly $ DB.query db "SELECT group_id FROM user_contact_links WHERE user_id = ? AND user_contact_link_id = ? AND group_id IS NOT NULL" (userId, ucLinkId) + let viaGroupLink = isJust viaLinkGroupId + DB.execute + db + [sql| + INSERT INTO connections ( + user_id, agent_conn_id, conn_level, via_contact, via_user_contact_link, via_group_link, custom_user_profile_id, conn_status, conn_type, + contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at, updated_at + ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) + |] + ( (userId, acId, connLevel, viaContact, viaUserContactLink, viaGroupLink, customUserProfileId, ConnNew, connType) + :. (ent ConnContact, ent ConnMember, ent ConnSndFile, ent ConnRcvFile, ent ConnUserContact, currentTs, currentTs) + ) + connId <- insertedRowId db + pure Connection {connId, agentConnId = AgentConnId acId, connType, entityId, viaContact, viaUserContactLink, viaGroupLink, groupLinkId = Nothing, customUserProfileId, connLevel, connStatus = ConnNew, localAlias = "", createdAt = currentTs, connectionCode = Nothing, authErrCounter = 0} + where + ent ct = if connType == ct then entityId else Nothing + +setCommandConnId :: DB.Connection -> User -> CommandId -> Int64 -> IO () +setCommandConnId db User {userId} cmdId connId = do + updatedAt <- getCurrentTime + DB.execute + db + [sql| + UPDATE commands + SET connection_id = ?, updated_at = ? + WHERE user_id = ? AND command_id = ? + |] + (connId, updatedAt, userId, cmdId) + +createContact_ :: DB.Connection -> UserId -> Int64 -> Profile -> LocalAlias -> Maybe Int64 -> UTCTime -> Maybe UTCTime -> ExceptT StoreError IO (Text, ContactId, ProfileId) +createContact_ db userId connId Profile {displayName, fullName, image, contactLink, preferences} localAlias viaGroup currentTs chatTs = + ExceptT . withLocalDisplayName db userId displayName $ \ldn -> do + DB.execute + db + "INSERT INTO contact_profiles (display_name, full_name, image, contact_link, user_id, local_alias, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)" + (displayName, fullName, image, contactLink, userId, localAlias, preferences, currentTs, currentTs) + profileId <- insertedRowId db + DB.execute + db + "INSERT INTO contacts (contact_profile_id, local_display_name, user_id, via_group, created_at, updated_at, chat_ts) VALUES (?,?,?,?,?,?,?)" + (profileId, ldn, userId, viaGroup, currentTs, currentTs, chatTs) + contactId <- insertedRowId db + DB.execute db "UPDATE connections SET contact_id = ?, updated_at = ? WHERE connection_id = ?" (contactId, currentTs, connId) + pure $ Right (ldn, contactId, profileId) + +deleteUnusedIncognitoProfileById_ :: DB.Connection -> User -> ProfileId -> IO () +deleteUnusedIncognitoProfileById_ db User {userId} profile_id = + DB.executeNamed + db + [sql| + DELETE FROM contact_profiles + WHERE user_id = :user_id AND contact_profile_id = :profile_id AND incognito = 1 + AND 1 NOT IN ( + SELECT 1 FROM connections + WHERE user_id = :user_id AND custom_user_profile_id = :profile_id LIMIT 1 + ) + AND 1 NOT IN ( + SELECT 1 FROM group_members + WHERE user_id = :user_id AND member_profile_id = :profile_id LIMIT 1 + ) + |] + [":user_id" := userId, ":profile_id" := profile_id] + +type ContactRow = (ContactId, ProfileId, ContactName, Maybe Int64, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Bool, Maybe Bool) :. (Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime) + +toContact :: User -> ContactRow :. ConnectionRow -> Contact +toContact user (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, enableNtfs_) :. (preferences, userPreferences, createdAt, updatedAt, chatTs)) :. connRow) = + let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} + activeConn = toConnection connRow + chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_} + mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn + in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs} + +toContactOrError :: User -> ContactRow :. MaybeConnectionRow -> Either StoreError Contact +toContactOrError user (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, enableNtfs_) :. (preferences, userPreferences, createdAt, updatedAt, chatTs)) :. connRow) = + let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} + chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_} + in case toMaybeConnection connRow of + Just activeConn -> + let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn + in Right Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs} + _ -> Left $ SEContactNotReady localDisplayName + +getProfileById :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO LocalProfile +getProfileById db userId profileId = + ExceptT . firstRow toProfile (SEProfileNotFound profileId) $ + DB.query + db + [sql| + SELECT cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, cp.preferences -- , ct.user_preferences + FROM contact_profiles cp + WHERE cp.user_id = ? AND cp.contact_profile_id = ? + |] + (userId, profileId) + where + toProfile :: (ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Preferences) -> LocalProfile + toProfile (displayName, fullName, image, contactLink, localAlias, preferences) = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} + +type ContactRequestRow = (Int64, ContactName, AgentInvId, Int64, AgentConnId, Int64, ContactName, Text, Maybe ImageData, Maybe ConnReqContact) :. (Maybe XContactId, Maybe Preferences, UTCTime, UTCTime) + +toContactRequest :: ContactRequestRow -> UserContactRequest +toContactRequest ((contactRequestId, localDisplayName, agentInvitationId, userContactLinkId, agentContactConnId, profileId, displayName, fullName, image, contactLink) :. (xContactId, preferences, createdAt, updatedAt)) = do + let profile = Profile {displayName, fullName, image, contactLink, preferences} + in UserContactRequest {contactRequestId, agentInvitationId, userContactLinkId, agentContactConnId, localDisplayName, profileId, profile, xContactId, createdAt, updatedAt} + +userQuery :: Query +userQuery = + [sql| + SELECT u.user_id, u.agent_user_id, u.contact_id, ucp.contact_profile_id, u.active_user, u.local_display_name, ucp.full_name, ucp.image, ucp.contact_link, ucp.preferences, u.show_ntfs, u.view_pwd_hash, u.view_pwd_salt + FROM users u + JOIN contacts uct ON uct.contact_id = u.contact_id + JOIN contact_profiles ucp ON ucp.contact_profile_id = uct.contact_profile_id + |] + +toUser :: (UserId, UserId, ContactId, ProfileId, Bool, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, Maybe Preferences, Bool) :. (Maybe B64UrlByteString, Maybe B64UrlByteString) -> User +toUser ((userId, auId, userContactId, profileId, activeUser, displayName, fullName, image, contactLink, userPreferences, showNtfs) :. (viewPwdHash_, viewPwdSalt_)) = + User {userId, agentUserId = AgentUserId auId, userContactId, localDisplayName = displayName, profile, activeUser, fullPreferences, showNtfs, viewPwdHash} + where + profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences = userPreferences, localAlias = ""} + fullPreferences = mergePreferences Nothing userPreferences + viewPwdHash = UserPwdHash <$> viewPwdHash_ <*> viewPwdSalt_ + +toPendingContactConnection :: (Int64, ConnId, ConnStatus, Maybe ByteString, Maybe Int64, Maybe GroupLinkId, Maybe Int64, Maybe ConnReqInvitation, LocalAlias, UTCTime, UTCTime) -> PendingContactConnection +toPendingContactConnection (pccConnId, acId, pccConnStatus, connReqHash, viaUserContactLink, groupLinkId, customUserProfileId, connReqInv, localAlias, createdAt, updatedAt) = + PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = isJust connReqHash, viaUserContactLink, groupLinkId, customUserProfileId, connReqInv, localAlias, createdAt, updatedAt} + +-- | Saves unique local display name based on passed displayName, suffixed with _N if required. +-- This function should be called inside transaction. +withLocalDisplayName :: forall a. DB.Connection -> UserId -> Text -> (Text -> IO (Either StoreError a)) -> IO (Either StoreError a) +withLocalDisplayName db userId displayName action = getLdnSuffix >>= (`tryCreateName` 20) + where + getLdnSuffix :: IO Int + getLdnSuffix = + maybe 0 ((+ 1) . fromOnly) . listToMaybe + <$> DB.queryNamed + db + [sql| + SELECT ldn_suffix FROM display_names + WHERE user_id = :user_id AND ldn_base = :display_name + ORDER BY ldn_suffix DESC + LIMIT 1 + |] + [":user_id" := userId, ":display_name" := displayName] + tryCreateName :: Int -> Int -> IO (Either StoreError a) + tryCreateName _ 0 = pure $ Left SEDuplicateName + tryCreateName ldnSuffix attempts = do + currentTs <- getCurrentTime + let ldn = displayName <> (if ldnSuffix == 0 then "" else T.pack $ '_' : show ldnSuffix) + E.try (insertName ldn currentTs) >>= \case + Right () -> action ldn + Left e + | DB.sqlError e == DB.ErrorConstraint -> tryCreateName (ldnSuffix + 1) (attempts - 1) + | otherwise -> E.throwIO e + where + insertName ldn ts = + DB.execute + db + [sql| + INSERT INTO display_names + (local_display_name, ldn_base, ldn_suffix, user_id, created_at, updated_at) + VALUES (?,?,?,?,?,?) + |] + (ldn, displayName, ldnSuffix, userId, ts, ts) + +createWithRandomId :: forall a. TVar ChaChaDRG -> (ByteString -> IO a) -> ExceptT StoreError IO a +createWithRandomId = createWithRandomBytes 12 + +createWithRandomBytes :: forall a. Int -> TVar ChaChaDRG -> (ByteString -> IO a) -> ExceptT StoreError IO a +createWithRandomBytes size gVar create = tryCreate 3 + where + tryCreate :: Int -> ExceptT StoreError IO a + tryCreate 0 = throwError SEUniqueID + tryCreate n = do + id' <- liftIO $ encodedRandomBytes gVar size + liftIO (E.try $ create id') >>= \case + Right x -> pure x + Left e + | DB.sqlError e == DB.ErrorConstraint -> tryCreate (n - 1) + | otherwise -> throwError . SEInternalError $ show e + +encodedRandomBytes :: TVar ChaChaDRG -> Int -> IO ByteString +encodedRandomBytes gVar = fmap B64.encode . randomBytes gVar + +randomBytes :: TVar ChaChaDRG -> Int -> IO ByteString +randomBytes gVar = atomically . stateTVar gVar . randomBytesGenerate diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index 6cc5cc1d0..13eb391f0 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -23,6 +23,7 @@ import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatDataba import Simplex.Chat.Core import Simplex.Chat.Options import Simplex.Chat.Store +import Simplex.Chat.Store.Profiles import Simplex.Chat.Terminal import Simplex.Chat.Terminal.Output (newChatTerminal) import Simplex.Chat.Types (AgentUserId (..), Profile, User (..)) diff --git a/tests/ChatTests/Utils.hs b/tests/ChatTests/Utils.hs index db8d63457..ec7a87cfe 100644 --- a/tests/ChatTests/Utils.hs +++ b/tests/ChatTests/Utils.hs @@ -18,7 +18,7 @@ import Data.Maybe (fromMaybe) import Data.String import qualified Data.Text as T import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), InlineFilesConfig (..), defaultInlineFilesConfig) -import Simplex.Chat.Store (getUserContactProfiles) +import Simplex.Chat.Store.Profiles (getUserContactProfiles) import Simplex.Chat.Types import Simplex.Messaging.Agent.Store.SQLite (withTransaction) import Simplex.Messaging.Encoding.String diff --git a/tests/MobileTests.hs b/tests/MobileTests.hs index 339dee6bb..f8d443829 100644 --- a/tests/MobileTests.hs +++ b/tests/MobileTests.hs @@ -6,6 +6,7 @@ import ChatTests.Utils import Control.Monad.Except import Simplex.Chat.Mobile import Simplex.Chat.Store +import Simplex.Chat.Store.Profiles import Simplex.Chat.Types (AgentUserId (..), Profile (..)) import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..)) import System.FilePath (())