{-# 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 (..), UserContactLink (..), AutoAccept (..), createChatStore, 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, 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.Time.LocalTime (TimeZone, getCurrentTimeZone) 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.ChatItemContent 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.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) ] -- | 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} createChatStore :: FilePath -> String -> MigrationConfirmation -> IO (Either MigrationError SQLiteStore) createChatStore dbFilePath dbKey = createSQLiteStore dbFilePath 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) |] (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 = ?") (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 = ? 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 -- JOIN contacts ct ON cp.contact_profile_id = ct.contact_profile_id 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 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 = ?" (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 = ? 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 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 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 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 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 = ? |] (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 = ? |] (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 = ? |] (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 = ? |] (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 = ? |] (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 tz <- getCurrentTimeZone currentTs <- getCurrentTime map (toDirectChatPreview tz 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 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 :: TimeZone -> UTCTime -> ContactRow :. ConnectionRow :. ChatStatsRow :. MaybeChatItemRow :. QuoteRow -> AChat toDirectChatPreview tz currentTs (contactRow :. connRow :. statsRow :. ciRow_) = let contact = toContact user $ contactRow :. connRow ci_ = toDirectChatItemList tz 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 tz <- getCurrentTimeZone currentTs <- getCurrentTime map (toGroupChatPreview tz 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 :: TimeZone -> UTCTime -> GroupInfoRow :. ChatStatsRow :. MaybeGroupChatItemRow -> AChat toGroupChatPreview tz currentTs (groupInfoRow :. statsRow :. ciRow_) = let groupInfo = toGroupInfo userContactId groupInfoRow ci_ = toGroupChatItemList tz 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 tz <- getCurrentTimeZone currentTs <- getCurrentTime mapM (toDirectChatItem tz 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 tz <- getCurrentTimeZone currentTs <- getCurrentTime mapM (toDirectChatItem tz 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 tz <- getCurrentTimeZone currentTs <- getCurrentTime mapM (toDirectChatItem tz 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 = ?" (userId, cName) getContact :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO Contact getContact db user@User {userId} contactId = 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 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, 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 tz <- getCurrentTimeZone currentTs <- getCurrentTime join <$> firstRow (toDirectChatItem tz 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 tz <- getCurrentTimeZone currentTs <- getCurrentTime join <$> firstRow (toGroupChatItem tz 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 :: TimeZone -> UTCTime -> ChatItemRow :. QuoteRow -> Either StoreError (CChatItem 'CTDirect) toDirectChatItem tz 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 tz currentTs itemTs createdAt updatedAt ciTimed :: Maybe CITimed ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} toDirectChatItemList :: TimeZone -> UTCTime -> MaybeChatItemRow :. QuoteRow -> [CChatItem 'CTDirect] toDirectChatItemList tz 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 tz 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 :: TimeZone -> UTCTime -> Int64 -> ChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow -> Either StoreError (CChatItem 'CTGroup) toGroupChatItem tz 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 tz currentTs itemTs createdAt updatedAt ciTimed :: Maybe CITimed ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} toGroupChatItemList :: TimeZone -> UTCTime -> Int64 -> MaybeGroupChatItemRow -> [CChatItem 'CTGroup] toGroupChatItemList tz 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 tz 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 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 = ? |] (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"