2021-07-16 07:40:55 +01:00
{- # LANGUAGE ConstraintKinds # -}
2021-07-04 18:42:24 +01:00
{- # LANGUAGE DataKinds # -}
{- # LANGUAGE DeriveAnyClass # -}
2022-01-26 21:20:08 +00:00
{- # LANGUAGE DeriveGeneric # -}
2021-06-25 18:18:24 +01:00
{- # LANGUAGE DuplicateRecordFields # -}
2021-07-04 18:42:24 +01:00
{- # LANGUAGE FlexibleContexts # -}
2022-01-26 16:18:27 +04:00
{- # LANGUAGE GADTs # -}
2021-07-04 18:42:24 +01:00
{- # LANGUAGE LambdaCase # -}
2021-06-25 18:18:24 +01:00
{- # LANGUAGE NamedFieldPuns # -}
2021-07-04 18:42:24 +01:00
{- # LANGUAGE OverloadedStrings # -}
2022-04-21 20:04:22 +01:00
{- # LANGUAGE PatternSynonyms # -}
2021-07-04 18:42:24 +01:00
{- # LANGUAGE QuasiQuotes # -}
2021-09-04 07:32:56 +01:00
{- # LANGUAGE RecordWildCards # -}
2021-07-04 18:42:24 +01:00
{- # LANGUAGE ScopedTypeVariables # -}
2021-06-25 18:18:24 +01:00
{- # LANGUAGE TemplateHaskell # -}
2021-07-14 20:11:41 +01:00
{- # LANGUAGE TupleSections # -}
2022-02-07 15:19:34 +04:00
{- # LANGUAGE TypeApplications # -}
2021-07-12 19:00:03 +01:00
{- # LANGUAGE TypeOperators # -}
2021-06-25 18:18:24 +01:00
2021-07-05 20:05:07 +01:00
module Simplex.Chat.Store
2021-07-04 18:42:24 +01:00
( SQLiteStore ,
StoreError ( .. ) ,
2022-10-21 19:14:12 +03:00
UserContactLink ( .. ) ,
AutoAccept ( .. ) ,
2022-09-02 16:38:41 +01:00
createChatStore ,
2021-12-13 12:05:57 +00:00
chatStoreFile ,
2022-09-02 16:38:41 +01:00
agentStoreFile ,
2021-07-05 19:54:44 +01:00
createUser ,
getUsers ,
setActiveUser ,
createDirectConnection ,
2022-02-13 13:19:24 +04:00
createConnReqConnection ,
2022-08-18 11:35:31 +04:00
getProfileById ,
2022-02-13 13:19:24 +04:00
getConnReqContactXContactId ,
2021-07-04 18:42:24 +01:00
createDirectContact ,
2022-06-18 20:06:13 +01:00
deleteContactConnectionsAndFiles ,
2021-07-04 18:42:24 +01:00
deleteContact ,
2022-01-30 10:49:13 +00:00
getContactByName ,
2021-07-12 19:00:03 +01:00
getContact ,
2022-01-30 10:49:13 +00:00
getContactIdByName ,
2021-08-22 15:56:36 +01:00
updateUserProfile ,
updateContactProfile ,
2022-11-01 17:32:49 +03:00
updateContactUserPreferences ,
2022-08-24 19:03:43 +04:00
updateContactAlias ,
2022-09-27 20:45:46 +01:00
updateContactConnectionAlias ,
2022-10-25 12:50:26 +04:00
updateContactUsed ,
2022-10-19 21:38:44 +03:00
updateContactUnreadChat ,
updateGroupUnreadChat ,
2021-07-25 20:23:52 +01:00
getUserContacts ,
2021-12-08 13:09:51 +00:00
createUserContactLink ,
2022-10-13 17:12:22 +04:00
getUserAddressConnections ,
2022-07-17 15:51:17 +01:00
getUserContactLinks ,
2022-10-13 17:12:22 +04:00
deleteUserAddress ,
getUserAddress ,
2022-06-27 19:41:25 +01:00
getUserContactLinkById ,
2022-10-13 17:12:22 +04:00
updateUserAddressAutoAccept ,
createGroupLink ,
getGroupLinkConnection ,
deleteGroupLink ,
getGroupLink ,
2022-11-03 14:46:36 +04:00
getGroupLinkId ,
getConnectionGroupLinkId ,
2022-02-13 13:19:24 +04:00
createOrUpdateContactRequest ,
2021-12-08 13:09:51 +00:00
getContactRequest ,
2022-01-31 21:53:53 +04:00
getContactRequestIdByName ,
2021-12-08 13:09:51 +00:00
deleteContactRequest ,
createAcceptedContact ,
2021-09-04 07:32:56 +01:00
getLiveSndFileTransfers ,
getLiveRcvFileTransfers ,
getPendingSndChunks ,
2022-07-17 15:51:17 +01:00
getPendingContactConnections ,
2021-07-04 18:42:24 +01:00
getContactConnections ,
2022-01-26 16:18:27 +04:00
getConnectionEntity ,
2022-09-14 19:45:21 +04:00
getConnectionById ,
2022-04-25 09:17:12 +01:00
getConnectionsContacts ,
2022-04-05 10:01:08 +04:00
getGroupAndMember ,
2021-07-24 10:26:28 +01:00
updateConnectionStatus ,
2021-07-12 19:00:03 +01:00
createNewGroup ,
2021-07-16 07:40:55 +01:00
createGroupInvitation ,
2022-07-15 17:49:29 +04:00
setGroupInvitationChatItemId ,
2021-07-12 19:00:03 +01:00
getGroup ,
2022-01-26 16:18:27 +04:00
getGroupInfo ,
2022-07-29 19:04:32 +01:00
updateGroupProfile ,
2022-01-30 10:49:13 +00:00
getGroupIdByName ,
2022-07-12 19:20:56 +04:00
getGroupMemberIdByName ,
2022-01-30 10:49:13 +00:00
getGroupInfoByName ,
2022-07-20 14:57:16 +01:00
getGroupMember ,
2022-01-26 16:18:27 +04:00
getGroupMembers ,
2022-10-26 13:37:17 +04:00
getGroupMembersForExpiration ,
2022-08-02 14:10:03 +04:00
deleteGroupConnectionsAndFiles ,
2022-08-04 11:12:50 +01:00
deleteGroupItemsAndMembers ,
2021-08-02 20:10:24 +01:00
deleteGroup ,
2021-07-25 20:23:52 +01:00
getUserGroups ,
2022-01-06 13:09:03 +04:00
getUserGroupDetails ,
2021-07-16 07:40:55 +01:00
getGroupInvitation ,
2022-08-18 11:35:31 +04:00
createNewContactMember ,
2022-10-15 14:48:07 +04:00
createNewContactMemberAsync ,
getContactViaMember ,
setNewContactMemberConnRequest ,
2022-01-06 20:29:57 +00:00
getMemberInvitation ,
2021-07-16 07:40:55 +01:00
createMemberConnection ,
2022-11-03 14:46:36 +04:00
createMemberConnectionAsync ,
2021-07-16 07:40:55 +01:00
updateGroupMemberStatus ,
2022-09-14 19:45:21 +04:00
updateGroupMemberStatusById ,
2021-07-24 10:26:28 +01:00
createNewGroupMember ,
2022-10-26 13:37:17 +04:00
checkGroupMemberHasItems ,
2022-08-04 18:39:31 +01:00
deleteGroupMember ,
2021-08-02 20:10:24 +01:00
deleteGroupMemberConnection ,
2022-10-03 09:00:47 +01:00
updateGroupMemberRole ,
2021-07-24 10:26:28 +01:00
createIntroductions ,
updateIntroStatus ,
saveIntroInvitation ,
createIntroReMember ,
createIntroToMemberContact ,
saveMemberInvitation ,
getViaGroupMember ,
getViaGroupContact ,
2021-07-27 08:08:05 +01:00
getMatchingContacts ,
randomBytes ,
createSentProbe ,
createSentProbeHash ,
2022-08-27 19:56:03 +04:00
deleteSentProbe ,
2021-07-27 08:08:05 +01:00
matchReceivedProbe ,
matchReceivedProbeHash ,
matchSentProbe ,
mergeContactRecords ,
2022-09-20 14:46:30 +01:00
createSndDirectFileTransfer ,
createSndDirectFTConnection ,
2022-05-11 16:18:28 +04:00
createSndGroupFileTransfer ,
createSndGroupFileTransferConnection ,
2022-10-14 13:06:33 +01:00
createSndDirectInlineFT ,
createSndGroupInlineFT ,
updateSndDirectFTDelivery ,
updateSndGroupFTDelivery ,
getSndInlineFTViaMsgDelivery ,
2022-04-05 10:01:08 +04:00
updateFileCancelled ,
2022-04-10 13:30:58 +04:00
updateCIFileStatus ,
2022-04-05 10:01:08 +04:00
getSharedMsgIdByFileId ,
getFileIdBySharedMsgId ,
getGroupFileIdBySharedMsgId ,
2022-09-20 14:46:30 +01:00
getDirectFileIdBySharedMsgId ,
2022-05-11 16:18:28 +04:00
getChatRefByFileId ,
2021-09-04 07:32:56 +01:00
updateSndFileStatus ,
createSndFileChunk ,
updateSndFileChunkMsg ,
updateSndFileChunkSent ,
2021-09-05 14:08:29 +01:00
deleteSndFileChunks ,
2021-09-04 07:32:56 +01:00
createRcvFileTransfer ,
2021-09-05 14:08:29 +01:00
createRcvGroupFileTransfer ,
2021-09-04 07:32:56 +01:00
getRcvFileTransfer ,
acceptRcvFileTransfer ,
2022-10-14 13:06:33 +01:00
acceptRcvInlineFT ,
startRcvInlineFT ,
2021-09-04 07:32:56 +01:00
updateRcvFileStatus ,
createRcvFileChunk ,
updatedRcvFileChunkStored ,
2021-09-05 14:08:29 +01:00
deleteRcvFileChunks ,
2022-01-26 16:18:27 +04:00
updateFileTransferChatItemId ,
2021-09-04 07:32:56 +01:00
getFileTransfer ,
getFileTransferProgress ,
2022-10-14 13:06:33 +01:00
getFileTransferMeta ,
2022-05-11 16:18:28 +04:00
getSndFileTransfer ,
2022-05-17 11:22:09 +04:00
getContactFileInfo ,
2022-10-04 01:33:36 +04:00
getContactMaxItemTs ,
deleteContactCIs ,
2022-05-19 21:57:31 +04:00
updateContactTs ,
2022-10-04 01:33:36 +04:00
getGroupFileInfo ,
getGroupMaxItemTs ,
deleteGroupCIs ,
2022-05-19 21:57:31 +04:00
updateGroupTs ,
2022-03-13 19:34:03 +00:00
createNewSndMessage ,
2021-12-29 23:11:55 +04:00
createSndMsgDelivery ,
createNewMessageAndRcvMsgDelivery ,
createSndMsgDeliveryEvent ,
createRcvMsgDeliveryEvent ,
2022-01-24 16:07:17 +00:00
createPendingGroupMessage ,
getPendingGroupMessages ,
deletePendingGroupMessage ,
2022-03-16 13:20:47 +00:00
createNewSndChatItem ,
createNewRcvChatItem ,
2022-05-28 19:13:07 +01:00
createNewChatItemNoMsg ,
2022-01-26 21:19:46 +04:00
getChatPreviews ,
2022-01-28 11:52:10 +04:00
getDirectChat ,
2022-01-29 16:06:08 +04:00
getGroupChat ,
2022-04-30 21:23:14 +01:00
getAllChatItems ,
2022-02-07 15:19:34 +04:00
getChatItemIdByAgentMsgId ,
2022-03-13 19:34:03 +00:00
getDirectChatItem ,
2022-03-28 20:35:57 +04:00
getDirectChatItemBySharedMsgId ,
2022-05-04 13:31:00 +01:00
getDirectChatItemByAgentMsgId ,
2022-03-13 19:34:03 +00:00
getGroupChatItem ,
2022-03-28 20:35:57 +04:00
getGroupChatItemBySharedMsgId ,
2022-03-13 19:34:03 +00:00
getDirectChatItemIdByText ,
getGroupChatItemIdByText ,
2022-04-15 09:36:38 +04:00
getChatItemByFileId ,
2022-07-15 17:49:29 +04:00
getChatItemByGroupId ,
2022-03-23 11:37:51 +00:00
updateDirectChatItemStatus ,
2022-05-05 13:50:19 +01:00
updateDirectCIFileStatus ,
2022-02-07 15:19:34 +04:00
updateDirectChatItem ,
2022-05-17 11:22:09 +04:00
deleteDirectChatItemLocal ,
2022-03-28 20:35:57 +04:00
deleteDirectChatItemRcvBroadcast ,
2022-03-23 11:37:51 +00:00
updateGroupChatItem ,
2022-10-01 14:31:21 +04:00
deleteGroupChatItemLocal ,
2022-03-28 20:35:57 +04:00
deleteGroupChatItemRcvBroadcast ,
updateDirectChatItemsRead ,
2022-02-08 17:27:43 +04:00
updateGroupChatItemsRead ,
2022-03-10 15:45:40 +04:00
getSMPServers ,
overwriteSMPServers ,
2022-07-04 11:15:25 +01:00
createCall ,
deleteCalls ,
getCalls ,
2022-09-14 19:45:21 +04:00
createCommand ,
setCommandConnId ,
2022-09-16 19:30:02 +04:00
deleteCommand ,
2022-09-14 19:45:21 +04:00
updateCommandStatus ,
getCommandDataByCorrId ,
setConnConnReqInv ,
getXGrpMemIntroContDirect ,
getXGrpMemIntroContGroup ,
2022-09-28 20:47:06 +04:00
getChatItemTTL ,
setChatItemTTL ,
2022-10-05 19:54:28 +04:00
getContactExpiredFileInfo ,
deleteContactExpiredCIs ,
getContactCICount ,
getGroupExpiredFileInfo ,
deleteGroupExpiredCIs ,
getGroupCICount ,
2022-04-25 10:39:28 +01:00
getPendingContactConnection ,
2022-04-23 17:32:40 +01:00
deletePendingContactConnection ,
2022-08-19 15:17:05 +01:00
updateContactSettings ,
updateGroupSettings ,
2022-06-18 20:06:13 +01:00
withTransaction ,
2021-07-04 18:42:24 +01:00
)
where
2021-06-25 18:18:24 +01:00
2021-09-05 14:08:29 +01:00
import Control.Applicative ( ( <|> ) )
2021-07-12 19:00:03 +01:00
import Control.Concurrent.STM ( stateTVar )
2021-07-05 19:54:44 +01:00
import Control.Exception ( Exception )
import qualified Control.Exception as E
2021-07-04 18:42:24 +01:00
import Control.Monad.Except
2021-07-12 19:00:03 +01:00
import Crypto.Random ( ChaChaDRG , randomBytesGenerate )
2022-01-26 21:20:08 +00:00
import Data.Aeson ( ToJSON )
import qualified Data.Aeson as J
2022-02-07 15:19:34 +04:00
import Data.Bifunctor ( first )
2021-07-12 19:00:03 +01:00
import qualified Data.ByteString.Base64 as B64
2021-07-04 18:42:24 +01:00
import Data.ByteString.Char8 ( ByteString )
2022-06-18 20:06:13 +01:00
import Data.Either ( rights )
2021-06-25 18:18:24 +01:00
import Data.Function ( on )
2021-08-22 15:56:36 +01:00
import Data.Functor ( ( $> ) )
2021-07-04 18:42:24 +01:00
import Data.Int ( Int64 )
2022-11-03 14:46:36 +04:00
import Data.List ( sortBy , sortOn )
2022-08-13 11:53:53 +01:00
import Data.List.NonEmpty ( NonEmpty )
2022-10-20 19:27:00 +04:00
import Data.Maybe ( fromMaybe , isJust , isNothing , listToMaybe )
2022-01-29 16:06:08 +04:00
import Data.Ord ( Down ( .. ) )
2021-07-04 18:42:24 +01:00
import Data.Text ( Text )
2021-07-05 19:54:44 +01:00
import qualified Data.Text as T
2022-02-02 20:25:36 +04:00
import Data.Time.Clock ( UTCTime ( .. ) , getCurrentTime )
2022-01-28 10:41:09 +00:00
import Data.Time.LocalTime ( TimeZone , getCurrentTimeZone )
2022-05-05 13:50:19 +01:00
import Data.Type.Equality
2022-01-21 11:09:33 +00:00
import Database.SQLite.Simple ( NamedParam ( .. ) , Only ( .. ) , Query ( .. ) , SQLError , ( :. ) ( .. ) )
2021-06-25 18:18:24 +01:00
import qualified Database.SQLite.Simple as DB
2021-07-04 18:42:24 +01:00
import Database.SQLite.Simple.QQ ( sql )
2022-01-26 21:20:08 +00:00
import GHC.Generics ( Generic )
2022-07-04 11:15:25 +01:00
import Simplex.Chat.Call
2022-02-22 14:05:45 +00:00
import Simplex.Chat.Markdown
2022-01-24 16:07:17 +00:00
import Simplex.Chat.Messages
2022-01-21 11:09:33 +00:00
import Simplex.Chat.Migrations.M20220101_initial
2022-02-02 20:25:36 +04:00
import Simplex.Chat.Migrations.M20220122_v1_1
2022-02-07 15:19:34 +04:00
import Simplex.Chat.Migrations.M20220205_chat_item_status
2022-02-13 13:19:24 +04:00
import Simplex.Chat.Migrations.M20220210_deduplicate_contact_requests
2022-02-25 21:59:35 +04:00
import Simplex.Chat.Migrations.M20220224_messages_fks
2022-03-10 15:45:40 +04:00
import Simplex.Chat.Migrations.M20220301_smp_servers
import Simplex.Chat.Migrations.M20220302_profile_images
2022-03-13 19:34:03 +00:00
import Simplex.Chat.Migrations.M20220304_msg_quotes
2022-03-23 11:37:51 +00:00
import Simplex.Chat.Migrations.M20220321_chat_item_edited
2022-04-10 13:30:58 +04:00
import Simplex.Chat.Migrations.M20220404_files_status_fields
2022-05-14 21:00:46 +04:00
import Simplex.Chat.Migrations.M20220514_profiles_user_id
2022-06-27 19:41:25 +01:00
import Simplex.Chat.Migrations.M20220626_auto_reply
2022-07-04 11:15:25 +01:00
import Simplex.Chat.Migrations.M20220702_calls
2022-07-15 17:49:29 +04:00
import Simplex.Chat.Migrations.M20220715_groups_chat_item_id
2022-08-11 15:48:47 +04:00
import Simplex.Chat.Migrations.M20220811_chat_items_indices
2022-08-18 11:35:31 +04:00
import Simplex.Chat.Migrations.M20220812_incognito_profiles
2022-08-19 15:17:05 +01:00
import Simplex.Chat.Migrations.M20220818_chat_notifications
2022-08-22 23:12:09 +04:00
import Simplex.Chat.Migrations.M20220822_groups_host_conn_custom_user_profile_id
2022-08-23 13:24:43 +01:00
import Simplex.Chat.Migrations.M20220823_delete_broken_group_event_chat_items
2022-08-24 19:03:43 +04:00
import Simplex.Chat.Migrations.M20220824_profiles_local_alias
2022-09-14 19:45:21 +04:00
import Simplex.Chat.Migrations.M20220909_commands
2022-09-27 20:45:46 +01:00
import Simplex.Chat.Migrations.M20220926_connection_alias
2022-09-28 20:47:06 +04:00
import Simplex.Chat.Migrations.M20220928_settings
2022-10-01 14:31:21 +04:00
import Simplex.Chat.Migrations.M20221001_shared_msg_id_indices
2022-10-03 12:55:59 +04:00
import Simplex.Chat.Migrations.M20221003_delete_broken_integrity_error_chat_items
2022-10-05 19:54:28 +04:00
import Simplex.Chat.Migrations.M20221004_idx_msg_deliveries_message_id
2022-10-13 17:12:22 +04:00
import Simplex.Chat.Migrations.M20221011_user_contact_links_group_id
2022-10-14 13:06:33 +01:00
import Simplex.Chat.Migrations.M20221012_inline_files
2022-10-19 21:38:44 +03:00
import Simplex.Chat.Migrations.M20221019_unread_chat
2022-10-21 19:14:12 +03:00
import Simplex.Chat.Migrations.M20221021_auto_accept__group_links
2022-10-25 12:50:26 +04:00
import Simplex.Chat.Migrations.M20221024_contact_used
2022-11-01 17:32:49 +03:00
import Simplex.Chat.Migrations.M20221025_chat_settings
2022-11-03 14:46:36 +04:00
import Simplex.Chat.Migrations.M20221029_group_link_id
2021-07-04 18:42:24 +01:00
import Simplex.Chat.Protocol
import Simplex.Chat.Types
2022-09-14 19:45:21 +04:00
import Simplex.Messaging.Agent.Protocol ( ACorrId , AgentMsgId , ConnId , InvitationId , MsgMeta ( .. ) )
2022-06-18 20:06:13 +01:00
import Simplex.Messaging.Agent.Store.SQLite ( SQLiteStore ( .. ) , createSQLiteStore , firstRow , firstRow' , maybeFirstRow , withTransaction )
2021-06-25 18:18:24 +01:00
import Simplex.Messaging.Agent.Store.SQLite.Migrations ( Migration ( .. ) )
2021-07-27 08:08:05 +01:00
import qualified Simplex.Messaging.Crypto as C
2022-01-29 20:21:37 +00:00
import Simplex.Messaging.Parsers ( dropPrefix , sumTypeJSON )
2022-04-21 20:04:22 +01:00
import Simplex.Messaging.Protocol ( ProtocolServer ( .. ) , SMPServer , pattern SMPServer )
2022-08-13 11:53:53 +01:00
import Simplex.Messaging.Transport.Client ( TransportHost )
2022-06-18 20:06:13 +01:00
import Simplex.Messaging.Util ( eitherToMaybe )
2021-07-12 19:00:03 +01:00
import UnliftIO.STM
2021-06-25 18:18:24 +01:00
2022-01-21 11:09:33 +00:00
schemaMigrations :: [ ( String , Query ) ]
schemaMigrations =
2022-01-24 16:07:17 +00:00
[ ( " 20220101_initial " , m20220101_initial ) ,
2022-02-07 15:19:34 +04:00
( " 20220122_v1_1 " , m20220122_v1_1 ) ,
2022-02-13 13:19:24 +04:00
( " 20220205_chat_item_status " , m20220205_chat_item_status ) ,
2022-02-25 21:59:35 +04:00
( " 20220210_deduplicate_contact_requests " , m20220210_deduplicate_contact_requests ) ,
2022-03-10 15:45:40 +04:00
( " 20220224_messages_fks " , m20220224_messages_fks ) ,
( " 20220301_smp_servers " , m20220301_smp_servers ) ,
2022-03-13 19:34:03 +00:00
( " 20220302_profile_images " , m20220302_profile_images ) ,
2022-03-23 11:37:51 +00:00
( " 20220304_msg_quotes " , m20220304_msg_quotes ) ,
2022-04-05 10:01:08 +04:00
( " 20220321_chat_item_edited " , m20220321_chat_item_edited ) ,
2022-05-14 21:00:46 +04:00
( " 20220404_files_status_fields " , m20220404_files_status_fields ) ,
2022-06-27 19:41:25 +01:00
( " 20220514_profiles_user_id " , m20220514_profiles_user_id ) ,
2022-07-04 11:15:25 +01:00
( " 20220626_auto_reply " , m20220626_auto_reply ) ,
2022-07-15 17:49:29 +04:00
( " 20220702_calls " , m20220702_calls ) ,
2022-08-11 15:48:47 +04:00
( " 20220715_groups_chat_item_id " , m20220715_groups_chat_item_id ) ,
2022-08-18 11:35:31 +04:00
( " 20220811_chat_items_indices " , m20220811_chat_items_indices ) ,
2022-08-19 15:17:05 +01:00
( " 20220812_incognito_profiles " , m20220812_incognito_profiles ) ,
2022-08-22 23:12:09 +04:00
( " 20220818_chat_notifications " , m20220818_chat_notifications ) ,
2022-08-23 13:24:43 +01:00
( " 20220822_groups_host_conn_custom_user_profile_id " , m20220822_groups_host_conn_custom_user_profile_id ) ,
2022-08-24 19:03:43 +04:00
( " 20220823_delete_broken_group_event_chat_items " , m20220823_delete_broken_group_event_chat_items ) ,
2022-09-14 19:45:21 +04:00
( " 20220824_profiles_local_alias " , m20220824_profiles_local_alias ) ,
2022-09-27 20:45:46 +01:00
( " 20220909_commands " , m20220909_commands ) ,
2022-09-28 20:47:06 +04:00
( " 20220926_connection_alias " , m20220926_connection_alias ) ,
2022-10-01 14:31:21 +04:00
( " 20220928_settings " , m20220928_settings ) ,
2022-10-03 12:55:59 +04:00
( " 20221001_shared_msg_id_indices " , m20221001_shared_msg_id_indices ) ,
2022-10-05 19:54:28 +04:00
( " 20221003_delete_broken_integrity_error_chat_items " , m20221003_delete_broken_integrity_error_chat_items ) ,
2022-10-13 17:12:22 +04:00
( " 20221004_idx_msg_deliveries_message_id " , m20221004_idx_msg_deliveries_message_id ) ,
2022-10-14 13:06:33 +01:00
( " 20221011_user_contact_links_group_id " , m20221011_user_contact_links_group_id ) ,
2022-10-19 21:38:44 +03:00
( " 20221012_inline_files " , m20221012_inline_files ) ,
2022-10-21 17:35:07 +04:00
( " 20221019_unread_chat " , m20221019_unread_chat ) ,
2022-10-25 12:50:26 +04:00
( " 20221021_auto_accept__group_links " , m20221021_auto_accept__group_links ) ,
2022-11-01 17:32:49 +03:00
( " 20221024_contact_used " , m20221024_contact_used ) ,
2022-11-03 14:46:36 +04:00
( " 20221025_chat_settings " , m20221025_chat_settings ) ,
( " 20221029_group_link_id " , m20221029_group_link_id )
2022-01-21 11:09:33 +00:00
]
2021-06-25 18:18:24 +01:00
-- | The list of migrations in ascending order by date
migrations :: [ Migration ]
2022-01-21 11:09:33 +00:00
migrations = sortBy ( compare ` on ` name ) $ map migration schemaMigrations
2021-06-25 18:18:24 +01:00
where
2022-01-21 11:09:33 +00:00
migration ( name , query ) = Migration { name = name , up = fromQuery query }
2021-06-25 18:18:24 +01:00
2022-09-02 16:38:41 +01:00
createChatStore :: FilePath -> String -> Bool -> IO SQLiteStore
createChatStore dbFilePath dbKey = createSQLiteStore dbFilePath dbKey migrations
2021-07-04 18:42:24 +01:00
2021-12-13 12:05:57 +00:00
chatStoreFile :: FilePath -> FilePath
2022-01-11 21:23:57 +00:00
chatStoreFile = ( <> " _chat.db " )
2021-12-13 12:05:57 +00:00
2022-09-02 16:38:41 +01:00
agentStoreFile :: FilePath -> FilePath
agentStoreFile = ( <> " _agent.db " )
2022-06-18 20:06:13 +01:00
checkConstraint :: StoreError -> ExceptT StoreError IO a -> ExceptT StoreError IO a
checkConstraint err action = ExceptT $ runExceptT action ` E . catch ` ( pure . Left . handleSQLError err )
2021-07-05 19:54:44 +01:00
handleSQLError :: StoreError -> SQLError -> StoreError
handleSQLError err e
| DB . sqlError e == DB . ErrorConstraint = err
2022-02-07 15:19:34 +04:00
| otherwise = SEInternalError $ show e
2021-07-05 19:54:44 +01:00
2021-07-04 18:42:24 +01:00
insertedRowId :: DB . Connection -> IO Int64
2021-07-12 19:00:03 +01:00
insertedRowId db = fromOnly . head <$> DB . query_ db " SELECT last_insert_rowid() "
2021-07-04 18:42:24 +01:00
2022-06-18 20:06:13 +01:00
createUser :: DB . Connection -> Profile -> Bool -> ExceptT StoreError IO User
2022-11-01 17:32:49 +03:00
createUser db Profile { displayName , fullName , image , preferences = userPreferences } activeUser =
2022-06-18 20:06:13 +01:00
checkConstraint SEDuplicateName . liftIO $ do
2022-02-02 20:25:36 +04:00
currentTs <- getCurrentTime
DB . execute
db
" INSERT INTO users (local_display_name, active_user, contact_id, created_at, updated_at) VALUES (?,?,0,?,?) "
( displayName , activeUser , currentTs , currentTs )
2021-07-05 19:54:44 +01:00
userId <- insertedRowId db
2022-02-02 20:25:36 +04:00
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
2022-11-01 17:32:49 +03:00
" INSERT INTO contact_profiles (display_name, full_name, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?) "
( displayName , fullName , image , userId , userPreferences , currentTs , currentTs )
2021-07-14 20:11:41 +01:00
profileId <- insertedRowId db
2022-02-02 20:25:36 +04:00
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 )
2021-07-04 18:42:24 +01:00
contactId <- insertedRowId db
2021-07-12 19:00:03 +01:00
DB . execute db " UPDATE users SET contact_id = ? WHERE user_id = ? " ( contactId , userId )
2022-11-01 17:32:49 +03:00
pure $ toUser ( userId , contactId , profileId , activeUser , displayName , fullName , image , userPreferences )
2021-07-05 19:54:44 +01:00
2022-06-18 20:06:13 +01:00
getUsers :: DB . Connection -> IO [ User ]
getUsers db =
map toUser
<$> DB . query_
db
[ sql |
2022-11-01 17:32:49 +03:00
SELECT u . user_id , u . contact_id , p . contact_profile_id , u . active_user , u . local_display_name , p . full_name , p . image , p . preferences
2022-06-18 20:06:13 +01:00
FROM users u
JOIN contacts c ON u . contact_id = c . contact_id
JOIN contact_profiles p ON c . contact_profile_id = p . contact_profile_id
| ]
2021-07-05 19:54:44 +01:00
2022-11-01 17:32:49 +03:00
toUser :: ( UserId , ContactId , ProfileId , Bool , ContactName , Text , Maybe ImageData , Maybe ChatPreferences ) -> User
toUser ( userId , userContactId , profileId , activeUser , displayName , fullName , image , userPreferences ) =
let profile = LocalProfile { profileId , displayName , fullName , image , preferences = userPreferences , localAlias = " " }
2021-07-14 20:11:41 +01:00
in User { userId , userContactId , localDisplayName = displayName , profile , activeUser }
2021-07-05 19:54:44 +01:00
2022-06-18 20:06:13 +01:00
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 )
2021-07-05 19:54:44 +01:00
2022-11-03 14:46:36 +04:00
createConnReqConnection :: DB . Connection -> UserId -> ConnId -> ConnReqUriHash -> XContactId -> Maybe Profile -> Maybe GroupLinkId -> IO PendingContactConnection
createConnReqConnection db userId acId cReqHash xContactId incognitoProfile groupLinkId = do
2022-06-18 20:06:13 +01:00
createdAt <- getCurrentTime
2022-10-14 14:57:01 +04:00
customUserProfileId <- mapM ( createIncognitoProfile_ db userId createdAt ) incognitoProfile
2022-06-18 20:06:13 +01:00
let pccConnStatus = ConnJoined
DB . execute
db
[ sql |
INSERT INTO connections (
user_id , agent_conn_id , conn_status , conn_type ,
2022-11-03 14:46:36 +04:00
via_contact_uri_hash , xcontact_id , custom_user_profile_id , via_group_link , group_link_id , created_at , updated_at
) VALUES ( ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? )
2022-06-18 20:06:13 +01:00
| ]
2022-11-03 14:46:36 +04:00
( ( userId , acId , pccConnStatus , ConnContact , cReqHash , xContactId ) :. ( customUserProfileId , isJust groupLinkId , groupLinkId , createdAt , createdAt ) )
2022-06-18 20:06:13 +01:00
pccConnId <- insertedRowId db
2022-11-04 12:00:03 +04:00
pure PendingContactConnection { pccConnId , pccAgentConnId = AgentConnId acId , pccConnStatus , viaContactUri = True , viaUserContactLink = Nothing , groupLinkId , customUserProfileId , connReqInv = Nothing , localAlias = " " , createdAt , updatedAt = createdAt }
2022-06-18 20:06:13 +01:00
getConnReqContactXContactId :: DB . Connection -> UserId -> ConnReqUriHash -> IO ( Maybe Contact , Maybe XContactId )
getConnReqContactXContactId db userId cReqHash = do
getContact' >>= \ case
c @ ( Just _ ) -> pure ( c , Nothing )
Nothing -> ( Nothing , ) <$> getXContactId
2022-02-13 13:19:24 +04:00
where
2022-06-18 20:06:13 +01:00
getContact' :: IO ( Maybe Contact )
getContact' =
maybeFirstRow toContact $
DB . query
2022-02-13 13:19:24 +04:00
db
[ sql |
SELECT
-- Contact
2022-11-01 17:32:49 +03:00
ct . contact_id , ct . contact_profile_id , ct . local_display_name , ct . via_group , cp . display_name , cp . full_name , cp . image , cp . local_alias , ct . contact_used , ct . enable_ntfs , cp . preferences , ct . user_preferences , ct . created_at , ct . updated_at ,
2022-02-13 13:19:24 +04:00
-- Connection
2022-10-24 14:28:58 +04:00
c . connection_id , c . agent_conn_id , c . conn_level , c . via_contact , c . via_user_contact_link , c . via_group_link , c . custom_user_profile_id , c . conn_status , c . conn_type , c . local_alias ,
2022-02-13 13:19:24 +04:00
c . contact_id , c . group_member_id , c . snd_file_id , c . rcv_file_id , c . user_contact_link_id , c . created_at
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 )
2022-06-18 20:06:13 +01:00
getXContactId :: IO ( Maybe XContactId )
getXContactId =
maybeFirstRow fromOnly $
DB . query
2022-02-13 13:19:24 +04:00
db
" SELECT xcontact_id FROM connections WHERE user_id = ? AND via_contact_uri_hash = ? LIMIT 1 "
( userId , cReqHash )
2022-09-27 20:45:46 +01:00
createDirectConnection :: DB . Connection -> UserId -> ConnId -> ConnReqInvitation -> ConnStatus -> Maybe Profile -> IO PendingContactConnection
createDirectConnection db userId acId cReq pccConnStatus incognitoProfile = do
2022-06-18 20:06:13 +01:00
createdAt <- getCurrentTime
2022-10-14 14:57:01 +04:00
customUserProfileId <- mapM ( createIncognitoProfile_ db userId createdAt ) incognitoProfile
2022-06-18 20:06:13 +01:00
DB . execute
db
[ sql |
INSERT INTO connections
2022-09-27 20:45:46 +01:00
( user_id , agent_conn_id , conn_req_inv , conn_status , conn_type , custom_user_profile_id , created_at , updated_at ) VALUES ( ? , ? , ? , ? , ? , ? , ? , ? )
2022-06-18 20:06:13 +01:00
| ]
2022-09-27 20:45:46 +01:00
( userId , acId , cReq , pccConnStatus , ConnContact , customUserProfileId , createdAt , createdAt )
2022-06-18 20:06:13 +01:00
pccConnId <- insertedRowId db
2022-11-04 12:00:03 +04:00
pure PendingContactConnection { pccConnId , pccAgentConnId = AgentConnId acId , pccConnStatus , viaContactUri = False , viaUserContactLink = Nothing , groupLinkId = Nothing , customUserProfileId , connReqInv = Just cReq , localAlias = " " , createdAt , updatedAt = createdAt }
2022-08-18 11:35:31 +04:00
2022-10-14 14:57:01 +04:00
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
2021-07-24 10:26:28 +01:00
2022-08-24 19:03:43 +04:00
getProfileById :: DB . Connection -> UserId -> Int64 -> ExceptT StoreError IO LocalProfile
2022-08-18 11:35:31 +04:00
getProfileById db userId profileId =
ExceptT . firstRow toProfile ( SEProfileNotFound profileId ) $
DB . query
db
[ sql |
2022-11-01 17:32:49 +03:00
SELECT cp . display_name , cp . full_name , cp . image , 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 = ?
2022-08-18 11:35:31 +04:00
| ]
( userId , profileId )
where
2022-11-01 17:32:49 +03:00
toProfile :: ( ContactName , Text , Maybe ImageData , LocalAlias , Maybe ChatPreferences ) -> LocalProfile
toProfile ( displayName , fullName , image , localAlias , preferences ) = LocalProfile { profileId , displayName , fullName , image , preferences , localAlias }
2021-12-08 13:09:51 +00:00
2022-08-18 11:35:31 +04:00
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
2022-10-21 17:35:07 +04:00
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 )
2022-10-24 14:28:58 +04:00
let viaGroupLink = isJust viaLinkGroupId
2021-07-24 10:26:28 +01:00
DB . execute
db
[ sql |
2021-12-08 13:09:51 +00:00
INSERT INTO connections (
2022-10-21 17:35:07 +04:00
user_id , agent_conn_id , conn_level , via_contact , via_user_contact_link , via_group_link , custom_user_profile_id , conn_status , conn_type ,
2022-02-02 20:25:36 +04:00
contact_id , group_member_id , snd_file_id , rcv_file_id , user_contact_link_id , created_at , updated_at
2022-10-21 17:35:07 +04:00
) VALUES ( ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? )
2021-07-24 10:26:28 +01:00
| ]
2022-10-24 14:28:58 +04:00
( ( userId , acId , connLevel , viaContact , viaUserContactLink , viaGroupLink , customUserProfileId , ConnNew , connType )
2022-02-02 20:25:36 +04:00
:. ( ent ConnContact , ent ConnMember , ent ConnSndFile , ent ConnRcvFile , ent ConnUserContact , currentTs , currentTs )
)
2021-07-24 10:26:28 +01:00
connId <- insertedRowId db
2022-10-24 14:28:58 +04:00
pure Connection { connId , agentConnId = AgentConnId acId , connType , entityId , viaContact , viaUserContactLink , viaGroupLink , customUserProfileId , connLevel , connStatus = ConnNew , localAlias = " " , createdAt = currentTs }
2021-12-08 13:09:51 +00:00
where
ent ct = if connType == ct then entityId else Nothing
2021-07-05 19:54:44 +01:00
2022-06-18 20:06:13 +01:00
createDirectContact :: DB . Connection -> UserId -> Connection -> Profile -> ExceptT StoreError IO Contact
2022-09-27 20:45:46 +01:00
createDirectContact db userId activeConn @ Connection { connId , localAlias } profile = do
2022-06-18 20:06:13 +01:00
createdAt <- liftIO getCurrentTime
2022-09-27 20:45:46 +01:00
( localDisplayName , contactId , profileId ) <- createContact_ db userId connId profile localAlias Nothing createdAt
2022-11-01 17:32:49 +03:00
pure $ Contact { contactId , localDisplayName , profile = toLocalProfile profileId profile localAlias , activeConn , viaGroup = Nothing , contactUsed = False , chatSettings = defaultChatSettings , userPreferences = emptyChatPrefs , createdAt , updatedAt = createdAt }
2021-07-24 10:26:28 +01:00
2022-09-27 20:45:46 +01:00
createContact_ :: DB . Connection -> UserId -> Int64 -> Profile -> LocalAlias -> Maybe Int64 -> UTCTime -> ExceptT StoreError IO ( Text , ContactId , ProfileId )
2022-11-01 17:32:49 +03:00
createContact_ db userId connId Profile { displayName , fullName , image , preferences } localAlias viaGroup currentTs =
2022-06-18 20:06:13 +01:00
ExceptT . withLocalDisplayName db userId displayName $ \ ldn -> do
2022-02-02 20:25:36 +04:00
DB . execute
db
2022-11-01 17:32:49 +03:00
" INSERT INTO contact_profiles (display_name, full_name, image, user_id, local_alias, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?) "
( displayName , fullName , image , userId , localAlias , preferences , currentTs , currentTs )
2021-07-24 10:26:28 +01:00
profileId <- insertedRowId db
2022-02-02 20:25:36 +04:00
DB . execute
db
" INSERT INTO contacts (contact_profile_id, local_display_name, user_id, via_group, created_at, updated_at) VALUES (?,?,?,?,?,?) "
( profileId , ldn , userId , viaGroup , currentTs , currentTs )
2021-07-24 10:26:28 +01:00
contactId <- insertedRowId db
2022-02-02 20:25:36 +04:00
DB . execute db " UPDATE connections SET contact_id = ?, updated_at = ? WHERE connection_id = ? " ( contactId , currentTs , connId )
2022-08-18 11:35:31 +04:00
pure . Right $ ( ldn , contactId , profileId )
2021-07-04 18:42:24 +01:00
2022-06-18 20:06:13 +01:00
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 )
2022-10-27 14:25:48 +04:00
deleteContact :: DB . Connection -> User -> Contact -> IO ()
deleteContact db user @ User { userId } Contact { contactId , localDisplayName , activeConn = Connection { customUserProfileId } } = do
2022-06-18 20:06:13 +01:00
DB . execute db " DELETE FROM chat_items WHERE user_id = ? AND contact_id = ? " ( userId , contactId )
2022-10-20 19:27:00 +04:00
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 )
2022-06-18 20:06:13 +01:00
DB . execute db " DELETE FROM contacts WHERE user_id = ? AND contact_id = ? " ( userId , contactId )
2022-10-27 14:25:48 +04:00
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 ]
2021-07-04 18:42:24 +01:00
2022-05-14 21:00:46 +04:00
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 )
2022-06-18 20:06:13 +01:00
updateUserProfile :: DB . Connection -> User -> Profile -> ExceptT StoreError IO ()
2022-08-18 11:35:31 +04:00
updateUserProfile db User { userId , userContactId , localDisplayName , profile = LocalProfile { profileId , displayName } } p' @ Profile { displayName = newName }
2021-08-22 15:56:36 +01:00
| displayName == newName =
2022-10-18 13:16:28 +04:00
liftIO $ updateContactProfile_ db userId profileId p'
2021-08-22 15:56:36 +01:00
| otherwise =
2022-10-18 13:16:28 +04:00
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
2021-08-22 15:56:36 +01:00
2022-06-18 20:06:13 +01:00
updateContactProfile :: DB . Connection -> UserId -> Contact -> Profile -> ExceptT StoreError IO Contact
2022-08-24 19:03:43 +04:00
updateContactProfile db userId c @ Contact { contactId , localDisplayName , profile = LocalProfile { profileId , displayName , localAlias } } p' @ Profile { displayName = newName }
2021-08-22 15:56:36 +01:00
| displayName == newName =
2022-10-18 13:16:28 +04:00
liftIO $ updateContactProfile_ db userId profileId p' $> ( c :: Contact ) { profile = toLocalProfile profileId p' localAlias }
2021-08-22 15:56:36 +01:00
| otherwise =
2022-10-18 13:16:28 +04:00
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 :: Contact ) { localDisplayName = ldn , profile = toLocalProfile profileId p' localAlias }
2022-08-24 19:03:43 +04:00
2022-11-01 17:32:49 +03:00
updateContactUserPreferences :: DB . Connection -> UserId -> Int64 -> ChatPreferences -> IO ()
updateContactUserPreferences db userId contactId userPreferences = do
updatedAt <- getCurrentTime
DB . execute
db
" UPDATE contacts SET user_preferences = ?, updated_at = ? WHERE user_id = ? AND contact_id = ? "
( userPreferences , updatedAt , userId , contactId )
2022-08-24 19:03:43 +04:00
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 )
2022-09-27 20:45:46 +01:00
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 }
2021-08-22 15:56:36 +01:00
2022-10-25 12:50:26 +04:00
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 )
2022-10-19 21:38:44 +03:00
2022-10-25 12:50:26 +04:00
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 )
2022-10-19 21:38:44 +03:00
2022-08-18 11:35:31 +04:00
updateContactProfile_ :: DB . Connection -> UserId -> ProfileId -> Profile -> IO ()
updateContactProfile_ db userId profileId profile = do
2022-02-02 20:25:36 +04:00
currentTs <- getCurrentTime
2022-08-18 11:35:31 +04:00
updateContactProfile_' db userId profileId profile currentTs
2022-02-02 20:25:36 +04:00
2022-08-18 11:35:31 +04:00
updateContactProfile_' :: DB . Connection -> UserId -> ProfileId -> Profile -> UTCTime -> IO ()
2022-11-01 17:32:49 +03:00
updateContactProfile_' db userId profileId Profile { displayName , fullName , image , preferences } updatedAt = do
2022-08-18 11:35:31 +04:00
DB . execute
2021-08-22 15:56:36 +01:00
db
[ sql |
UPDATE contact_profiles
2022-11-01 17:32:49 +03:00
SET display_name = ? , full_name = ? , image = ? , preferences = ? , updated_at = ?
2022-08-18 11:35:31 +04:00
WHERE user_id = ? AND contact_profile_id = ?
2021-08-22 15:56:36 +01:00
| ]
2022-11-01 17:32:49 +03:00
( displayName , fullName , image , preferences , updatedAt , userId , profileId )
2021-08-22 15:56:36 +01:00
2022-02-02 20:25:36 +04:00
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 )
2021-08-22 15:56:36 +01:00
DB . execute db " DELETE FROM display_names WHERE local_display_name = ? AND user_id = ? " ( displayName , userId )
2022-11-01 17:32:49 +03:00
type ContactRow = ( ContactId , ProfileId , ContactName , Maybe Int64 , ContactName , Text , Maybe ImageData , LocalAlias , Bool , Maybe Bool ) :. ( Maybe ChatPreferences , ChatPreferences , UTCTime , UTCTime )
2022-01-26 21:19:46 +04:00
2022-02-02 20:25:36 +04:00
toContact :: ContactRow :. ConnectionRow -> Contact
2022-11-01 17:32:49 +03:00
toContact ( ( ( contactId , profileId , localDisplayName , viaGroup , displayName , fullName , image , localAlias , contactUsed , enableNtfs_ ) :. ( preferences , userPreferences , createdAt , updatedAt ) ) :. connRow ) =
let profile = LocalProfile { profileId , displayName , fullName , image , preferences , localAlias }
2022-01-26 21:19:46 +04:00
activeConn = toConnection connRow
2022-08-19 15:17:05 +01:00
chatSettings = ChatSettings { enableNtfs = fromMaybe True enableNtfs_ }
2022-11-01 17:32:49 +03:00
in Contact { contactId , localDisplayName , profile , activeConn , viaGroup , contactUsed , chatSettings , userPreferences , createdAt , updatedAt }
2022-01-26 21:19:46 +04:00
2022-02-02 20:25:36 +04:00
toContactOrError :: ContactRow :. MaybeConnectionRow -> Either StoreError Contact
2022-11-01 17:32:49 +03:00
toContactOrError ( ( ( contactId , profileId , localDisplayName , viaGroup , displayName , fullName , image , localAlias , contactUsed , enableNtfs_ ) :. ( preferences , userPreferences , createdAt , updatedAt ) ) :. connRow ) =
let profile = LocalProfile { profileId , displayName , fullName , image , preferences , localAlias }
2022-08-19 15:17:05 +01:00
chatSettings = ChatSettings { enableNtfs = fromMaybe True enableNtfs_ }
2022-01-30 10:49:13 +00:00
in case toMaybeConnection connRow of
Just activeConn ->
2022-11-01 17:32:49 +03:00
Right Contact { contactId , localDisplayName , profile , activeConn , viaGroup , contactUsed , chatSettings , userPreferences , createdAt , updatedAt }
2022-01-30 10:49:13 +00:00
_ -> Left $ SEContactNotReady localDisplayName
2021-07-25 20:23:52 +01:00
-- TODO return the last connection that is ready, not any last connection
-- requires updating connection status
2022-09-05 15:23:38 +01:00
getContactByName :: DB . Connection -> User -> ContactName -> ExceptT StoreError IO Contact
getContactByName db user @ User { userId } localDisplayName = do
cId <- getContactIdByName db user localDisplayName
2022-06-18 20:06:13 +01:00
getContact db userId cId
getUserContacts :: DB . Connection -> User -> IO [ Contact ]
getUserContacts db User { userId } = do
contactIds <- map fromOnly <$> DB . query db " SELECT contact_id FROM contacts WHERE user_id = ? " ( Only userId )
rights <$> mapM ( runExceptT . getContact db userId ) contactIds
createUserContactLink :: DB . Connection -> UserId -> ConnId -> ConnReqContact -> ExceptT StoreError IO ()
createUserContactLink db userId agentConnId cReq =
checkConstraint SEDuplicateContactLink . liftIO $ do
2022-02-02 20:25:36 +04:00
currentTs <- getCurrentTime
DB . execute
db
" INSERT INTO user_contact_links (user_id, conn_req_contact, created_at, updated_at) VALUES (?,?,?,?) "
( userId , cReq , currentTs , currentTs )
2021-12-08 13:09:51 +00:00
userContactLinkId <- insertedRowId db
2022-08-18 11:35:31 +04:00
void $ createConnection_ db userId ConnUserContact ( Just userContactLinkId ) agentConnId Nothing Nothing Nothing 0 currentTs
2021-12-08 13:09:51 +00:00
2022-10-13 17:12:22 +04:00
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 |
2022-10-24 14:28:58 +04:00
SELECT c . connection_id , c . agent_conn_id , c . conn_level , c . via_contact , c . via_user_contact_link , c . via_group_link , c . custom_user_profile_id ,
2022-10-13 17:12:22 +04:00
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
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 )
2022-07-17 15:51:17 +01:00
getUserContactLinks :: DB . Connection -> User -> IO [ ( Connection , UserContact ) ]
getUserContactLinks db User { userId } =
2022-10-13 17:12:22 +04:00
map toUserContactConnection
<$> DB . query
2022-07-17 15:51:17 +01:00
db
[ sql |
2022-10-24 14:28:58 +04:00
SELECT c . connection_id , c . agent_conn_id , c . conn_level , c . via_contact , c . via_user_contact_link , c . via_group_link , c . custom_user_profile_id ,
2022-09-27 20:45:46 +01:00
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 ,
2022-10-13 17:12:22 +04:00
uc . user_contact_link_id , uc . conn_req_contact , uc . group_id
2022-07-17 15:51:17 +01:00
FROM connections c
JOIN user_contact_links uc ON c . user_contact_link_id = uc . user_contact_link_id
2022-10-13 17:12:22 +04:00
WHERE c . user_id = ? AND uc . user_id = ?
2022-07-17 15:51:17 +01:00
| ]
2022-10-13 17:12:22 +04:00
( userId , userId )
2022-06-18 20:06:13 +01:00
where
2022-10-13 17:12:22 +04:00
toUserContactConnection :: ( ConnectionRow :. ( Int64 , ConnReqContact , Maybe GroupId ) ) -> ( Connection , UserContact )
toUserContactConnection ( connRow :. ( userContactLinkId , connReqContact , groupId ) ) = ( toConnection connRow , UserContact { userContactLinkId , connReqContact , groupId } )
2021-12-08 13:09:51 +00:00
2022-10-13 17:12:22 +04:00
deleteUserAddress :: DB . Connection -> User -> IO ()
deleteUserAddress db User { userId } = do
2022-06-18 20:06:13 +01:00
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 )
2022-10-13 17:12:22 +04:00
WHERE uc . user_id = ? AND uc . local_display_name = ' ' AND uc . group_id IS NULL
2022-06-18 20:06:13 +01:00
)
| ]
( 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
2021-12-08 13:09:51 +00:00
FROM contact_requests cr
JOIN user_contact_links uc USING ( user_contact_link_id )
2022-10-13 17:12:22 +04:00
WHERE uc . user_id = : user_id AND uc . local_display_name = ' ' AND uc . group_id IS NULL
2021-12-08 13:09:51 +00:00
)
2022-06-18 20:06:13 +01:00
| ]
[ " :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 )
2022-10-13 17:12:22 +04:00
WHERE uc . user_id = : user_id AND uc . local_display_name = ' ' AND uc . group_id IS NULL
2022-06-18 20:06:13 +01:00
)
| ]
[ " :user_id " := userId ]
2022-10-13 17:12:22 +04:00
DB . execute db " DELETE FROM user_contact_links WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL " ( Only userId )
2022-02-14 14:59:11 +04:00
2022-10-21 19:14:12 +03:00
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 -> UserId -> ExceptT StoreError IO UserContactLink
2022-10-13 17:12:22 +04:00
getUserAddress db userId =
2022-10-21 19:14:12 +03:00
ExceptT . firstRow toUserContactLink SEUserContactLinkNotFound $
2022-02-14 14:59:11 +04:00
DB . query
db
[ sql |
2022-10-21 19:14:12 +03:00
SELECT conn_req_contact , auto_accept , auto_accept_incognito , auto_reply_msg_content
2022-02-14 14:59:11 +04:00
FROM user_contact_links
2022-10-13 17:12:22 +04:00
WHERE user_id = ? AND local_display_name = ' ' AND group_id IS NULL
2022-02-14 14:59:11 +04:00
| ]
( Only userId )
2022-10-21 19:14:12 +03:00
getUserContactLinkById :: DB . Connection -> UserId -> Int64 -> IO ( Maybe ( UserContactLink , Maybe GroupId ) )
2022-06-27 19:41:25 +01:00
getUserContactLinkById db userId userContactLinkId =
2022-10-21 19:14:12 +03:00
maybeFirstRow ( \ ( ucl :. Only groupId_ ) -> ( toUserContactLink ucl , groupId_ ) ) $
2022-06-27 19:41:25 +01:00
DB . query
db
[ sql |
2022-10-21 19:14:12 +03:00
SELECT conn_req_contact , auto_accept , auto_accept_incognito , auto_reply_msg_content , group_id
2022-06-27 19:41:25 +01:00
FROM user_contact_links
WHERE user_id = ?
AND user_contact_link_id = ?
| ]
( userId , userContactLinkId )
2022-10-21 19:14:12 +03:00
updateUserAddressAutoAccept :: DB . Connection -> UserId -> Maybe AutoAccept -> ExceptT StoreError IO UserContactLink
updateUserAddressAutoAccept db userId autoAccept = do
link <- getUserAddress db userId
liftIO updateUserAddressAutoAccept_ $> link { autoAccept }
2022-02-14 14:59:11 +04:00
where
2022-10-13 17:12:22 +04:00
updateUserAddressAutoAccept_ =
2022-02-14 14:59:11 +04:00
DB . execute
2021-12-08 13:09:51 +00:00
db
[ sql |
2022-02-14 14:59:11 +04:00
UPDATE user_contact_links
2022-10-21 19:14:12 +03:00
SET auto_accept = ? , auto_accept_incognito = ? , auto_reply_msg_content = ?
2022-10-13 17:12:22 +04:00
WHERE user_id = ? AND local_display_name = ' ' AND group_id IS NULL
2021-12-08 13:09:51 +00:00
| ]
2022-10-21 19:14:12 +03:00
( ucl :. Only userId )
ucl = case autoAccept of
Just AutoAccept { acceptIncognito , autoReply } -> ( True , acceptIncognito , autoReply )
_ -> ( False , False , Nothing )
2021-12-08 13:09:51 +00:00
2022-11-03 14:46:36 +04:00
createGroupLink :: DB . Connection -> User -> GroupInfo -> ConnId -> ConnReqContact -> GroupLinkId -> ExceptT StoreError IO ()
createGroupLink db User { userId } groupInfo @ GroupInfo { groupId , localDisplayName } agentConnId cReq groupLinkId =
2022-10-13 17:12:22 +04:00
checkConstraint ( SEDuplicateGroupLink groupInfo ) . liftIO $ do
currentTs <- getCurrentTime
DB . execute
db
2022-11-03 14:46:36 +04:00
" INSERT INTO user_contact_links (user_id, group_id, group_link_id, local_display_name, conn_req_contact, auto_accept, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?) "
( userId , groupId , groupLinkId , " group_link_ " <> localDisplayName , cReq , True , currentTs , currentTs )
userContactLinkId <- insertedRowId db
void $ createConnection_ db userId ConnUserContact ( Just userContactLinkId ) agentConnId Nothing Nothing Nothing 0 currentTs
2022-10-13 17:12:22 +04:00
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 |
2022-10-24 14:28:58 +04:00
SELECT c . connection_id , c . agent_conn_id , c . conn_level , c . via_contact , c . via_user_contact_link , c . via_group_link , c . custom_user_profile_id ,
2022-10-13 17:12:22 +04:00
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
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 ConnReqContact
getGroupLink db User { userId } gInfo @ GroupInfo { groupId } =
ExceptT . firstRow fromOnly ( SEGroupLinkNotFound gInfo ) $
2022-11-03 14:46:36 +04:00
DB . query db " SELECT conn_req_contact FROM user_contact_links WHERE user_id = ? AND group_id = ? LIMIT 1 " ( userId , groupId )
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 )
getConnectionGroupLinkId :: DB . Connection -> User -> Int64 -> IO ( Maybe GroupLinkId )
getConnectionGroupLinkId db User { userId } connId =
fmap join . maybeFirstRow fromOnly $
DB . query db " SELECT group_link_id FROM connections WHERE user_id = ? AND connection_id = ? LIMIT 1 " ( userId , connId )
2022-10-13 17:12:22 +04:00
2022-06-18 20:06:13 +01:00
createOrUpdateContactRequest :: DB . Connection -> UserId -> Int64 -> InvitationId -> Profile -> Maybe XContactId -> ExceptT StoreError IO ContactOrRequest
2022-11-01 17:32:49 +03:00
createOrUpdateContactRequest db userId userContactLinkId invId Profile { displayName , fullName , image , preferences } xContactId_ =
2022-06-18 20:06:13 +01:00
liftIO ( maybeM getContact' xContactId_ ) >>= \ case
Just contact -> pure $ CORContact contact
Nothing -> CORRequest <$> createOrUpdate_
2022-01-31 21:53:53 +04:00
where
2022-02-13 13:19:24 +04:00
maybeM = maybe ( pure Nothing )
2022-06-18 20:06:13 +01:00
createOrUpdate_ :: ExceptT StoreError IO UserContactRequest
createOrUpdate_ = do
2022-05-14 00:57:24 +04:00
cReqId <-
ExceptT $
maybeM getContactRequest' xContactId_ >>= \ case
Nothing -> createContactRequest
Just cr -> updateContactRequest cr $> Right ( contactRequestId ( cr :: UserContactRequest ) )
2022-06-18 20:06:13 +01:00
getContactRequest db userId cReqId
2022-05-14 00:57:24 +04:00
createContactRequest :: IO ( Either StoreError Int64 )
2022-02-13 13:19:24 +04:00
createContactRequest = do
2022-02-02 20:25:36 +04:00
currentTs <- getCurrentTime
2022-08-18 11:35:31 +04:00
withLocalDisplayName db userId displayName ( fmap Right . createContactRequest_ currentTs )
2022-02-13 13:19:24 +04:00
where
createContactRequest_ currentTs ldn = do
DB . execute
db
2022-11-01 17:32:49 +03:00
" INSERT INTO contact_profiles (display_name, full_name, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?) "
( displayName , fullName , image , userId , preferences , currentTs , currentTs )
2022-02-13 13:19:24 +04:00
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_ )
2022-05-14 00:57:24 +04:00
insertedRowId db
2022-02-13 13:19:24 +04:00
getContact' :: XContactId -> IO ( Maybe Contact )
getContact' xContactId =
2022-06-18 20:06:13 +01:00
maybeFirstRow toContact $
DB . query
2022-02-13 13:19:24 +04:00
db
[ sql |
SELECT
-- Contact
2022-11-01 17:32:49 +03:00
ct . contact_id , ct . contact_profile_id , ct . local_display_name , ct . via_group , cp . display_name , cp . full_name , cp . image , cp . local_alias , ct . contact_used , ct . enable_ntfs , cp . preferences , ct . user_preferences , ct . created_at , ct . updated_at ,
2022-02-13 13:19:24 +04:00
-- Connection
2022-10-24 14:28:58 +04:00
c . connection_id , c . agent_conn_id , c . conn_level , c . via_contact , c . via_user_contact_link , c . via_group_link , c . custom_user_profile_id , c . conn_status , c . conn_type , c . local_alias ,
2022-02-13 13:19:24 +04:00
c . contact_id , c . group_member_id , c . snd_file_id , c . rcv_file_id , c . user_contact_link_id , c . created_at
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 )
getContactRequest' :: XContactId -> IO ( Maybe UserContactRequest )
getContactRequest' xContactId =
2022-06-18 20:06:13 +01:00
maybeFirstRow toContactRequest $
DB . query
2022-02-13 13:19:24 +04:00
db
[ sql |
SELECT
cr . contact_request_id , cr . local_display_name , cr . agent_invitation_id , cr . user_contact_link_id ,
2022-11-01 17:32:49 +03:00
c . agent_conn_id , cr . contact_profile_id , p . display_name , p . full_name , p . image , cr . xcontact_id , p . preferences , cr . created_at , cr . updated_at
2022-02-13 13:19:24 +04:00
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 )
2022-05-14 00:57:24 +04:00
updateContactRequest :: UserContactRequest -> IO ( Either StoreError () )
updateContactRequest UserContactRequest { contactRequestId = cReqId , localDisplayName = oldLdn , profile = Profile { displayName = oldDisplayName } } = do
2022-02-13 13:19:24 +04:00
currentTs <- liftIO getCurrentTime
2022-05-14 00:57:24 +04:00
updateProfile currentTs
2022-02-13 13:19:24 +04:00
if displayName == oldDisplayName
2022-05-14 00:57:24 +04:00
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 )
2022-08-18 11:35:31 +04:00
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 )
2022-02-13 13:19:24 +04:00
where
2022-05-14 00:57:24 +04:00
updateProfile currentTs =
2022-02-13 13:19:24 +04:00
DB . execute
db
[ sql |
UPDATE contact_profiles
SET display_name = ? ,
full_name = ? ,
2022-03-10 15:45:40 +04:00
image = ? ,
2022-02-13 13:19:24 +04:00
updated_at = ?
WHERE contact_profile_id IN (
SELECT contact_profile_id
FROM contact_requests
WHERE user_id = ?
AND contact_request_id = ?
)
| ]
2022-05-14 00:57:24 +04:00
( displayName , fullName , image , currentTs , userId , cReqId )
2021-12-08 13:09:51 +00:00
2022-06-18 20:06:13 +01:00
getContactRequest :: DB . Connection -> UserId -> Int64 -> ExceptT StoreError IO UserContactRequest
getContactRequest db userId contactRequestId =
ExceptT . firstRow toContactRequest ( SEContactRequestNotFound contactRequestId ) $
2022-01-31 22:43:39 +04:00
DB . query
2022-01-31 21:53:53 +04:00
db
[ sql |
SELECT
2022-01-31 22:43:39 +04:00
cr . contact_request_id , cr . local_display_name , cr . agent_invitation_id , cr . user_contact_link_id ,
2022-11-01 17:32:49 +03:00
c . agent_conn_id , cr . contact_profile_id , p . display_name , p . full_name , p . image , cr . xcontact_id , p . preferences , cr . created_at , cr . updated_at
2022-01-31 21:53:53 +04:00
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 )
2022-01-31 22:43:39 +04:00
2022-11-01 17:32:49 +03:00
type ContactRequestRow = ( Int64 , ContactName , AgentInvId , Int64 , AgentConnId , Int64 , ContactName , Text , Maybe ImageData ) :. ( Maybe XContactId , Maybe ChatPreferences , UTCTime , UTCTime )
2022-01-31 22:43:39 +04:00
toContactRequest :: ContactRequestRow -> UserContactRequest
2022-11-01 17:32:49 +03:00
toContactRequest ( ( contactRequestId , localDisplayName , agentInvitationId , userContactLinkId , agentContactConnId , profileId , displayName , fullName , image ) :. ( xContactId , preferences , createdAt , updatedAt ) ) = do
let profile = Profile { displayName , fullName , image , preferences }
2022-04-24 09:05:54 +01:00
in UserContactRequest { contactRequestId , agentInvitationId , userContactLinkId , agentContactConnId , localDisplayName , profileId , profile , xContactId , createdAt , updatedAt }
2022-01-31 21:53:53 +04:00
2022-06-18 20:06:13 +01:00
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 )
2021-12-08 13:09:51 +00:00
2022-06-18 20:06:13 +01:00
deleteContactRequest :: DB . Connection -> UserId -> Int64 -> IO ()
deleteContactRequest db 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 )
2021-12-08 13:09:51 +00:00
2022-11-01 17:32:49 +03:00
createAcceptedContact :: DB . Connection -> User -> ConnId -> ContactName -> ProfileId -> Profile -> Int64 -> Maybe XContactId -> Maybe IncognitoProfile -> IO Contact
createAcceptedContact db User { userId , profile = LocalProfile { preferences } } agentConnId localDisplayName profileId profile userContactLinkId xContactId incognitoProfile = do
2022-06-18 20:06:13 +01:00
DB . execute db " DELETE FROM contact_requests WHERE user_id = ? AND local_display_name = ? " ( userId , localDisplayName )
2022-08-18 11:35:31 +04:00
createdAt <- getCurrentTime
2022-10-14 14:57:01 +04:00
customUserProfileId <- forM incognitoProfile $ \ case
NewIncognito p -> createIncognitoProfile_ db userId createdAt p
ExistingIncognito LocalProfile { profileId = pId } -> pure pId
2022-11-01 17:32:49 +03:00
let contactUserPrefs = fromMaybe emptyChatPrefs $ incognitoProfile >> preferences
2022-06-18 20:06:13 +01:00
DB . execute
db
2022-11-01 17:32:49 +03:00
" INSERT INTO contacts (user_id, local_display_name, contact_profile_id, enable_ntfs, user_preferences, created_at, updated_at, xcontact_id) VALUES (?,?,?,?,?,?,?,?) "
( userId , localDisplayName , profileId , True , contactUserPrefs , createdAt , createdAt , xContactId )
2022-06-18 20:06:13 +01:00
contactId <- insertedRowId db
2022-08-18 11:35:31 +04:00
activeConn <- createConnection_ db userId ConnContact ( Just contactId ) agentConnId Nothing ( Just userContactLinkId ) customUserProfileId 0 createdAt
2022-11-01 17:32:49 +03:00
pure $ Contact { contactId , localDisplayName , profile = toLocalProfile profileId profile " " , activeConn , viaGroup = Nothing , contactUsed = False , chatSettings = defaultChatSettings , userPreferences = contactUserPrefs , createdAt = createdAt , updatedAt = createdAt }
2022-06-18 20:06:13 +01:00
getLiveSndFileTransfers :: DB . Connection -> User -> IO [ SndFileTransfer ]
getLiveSndFileTransfers db User { userId } = do
fileIds :: [ Int64 ] <-
map fromOnly
<$> DB . query
db
[ sql |
SELECT DISTINCT f . file_id
FROM files f
JOIN snd_files s
2022-10-14 13:06:33 +01:00
WHERE f . user_id = ? AND s . file_status IN ( ? , ? , ? ) AND s . file_inline IS NULL
2022-06-18 20:06:13 +01:00
| ]
( userId , FSNew , FSAccepted , FSConnected )
concatMap ( filter liveTransfer ) . rights <$> mapM ( getSndFileTransfers_ db userId ) fileIds
2021-09-04 07:32:56 +01:00
where
liveTransfer :: SndFileTransfer -> Bool
liveTransfer SndFileTransfer { fileStatus } = fileStatus ` elem ` [ FSNew , FSAccepted , FSConnected ]
2022-06-18 20:06:13 +01:00
getLiveRcvFileTransfers :: DB . Connection -> User -> IO [ RcvFileTransfer ]
getLiveRcvFileTransfers db user @ User { userId } = do
fileIds :: [ Int64 ] <-
2021-09-04 07:32:56 +01:00
map fromOnly
<$> DB . query
db
[ sql |
2022-06-18 20:06:13 +01:00
SELECT f . file_id
FROM files f
JOIN rcv_files r
2022-10-14 13:06:33 +01:00
WHERE f . user_id = ? AND r . file_status IN ( ? , ? ) AND r . rcv_file_inline IS NULL
2021-09-04 07:32:56 +01:00
| ]
2022-06-18 20:06:13 +01:00
( userId , FSAccepted , FSConnected )
rights <$> mapM ( runExceptT . getRcvFileTransfer db user ) fileIds
2021-09-04 07:32:56 +01:00
2022-06-18 20:06:13 +01:00
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 )
2021-08-28 20:54:53 +10:00
2022-07-17 15:51:17 +01:00
getPendingContactConnections :: DB . Connection -> User -> IO [ PendingContactConnection ]
getPendingContactConnections db User { userId } = do
map toPendingContactConnection
2022-06-18 20:06:13 +01:00
<$> DB . queryNamed
db
[ sql |
2022-11-04 12:00:03 +04:00
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
2022-06-18 20:06:13 +01:00
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
2021-07-04 18:42:24 +01:00
db
[ sql |
2022-10-24 14:28:58 +04:00
SELECT c . connection_id , c . agent_conn_id , c . conn_level , c . via_contact , c . via_user_contact_link , c . via_group_link , c . custom_user_profile_id ,
2022-09-27 20:45:46 +01:00
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
2021-07-05 19:54:44 +01:00
FROM connections c
2022-01-31 15:14:56 +04:00
JOIN contacts ct ON ct . contact_id = c . contact_id
WHERE c . user_id = ? AND ct . user_id = ? AND ct . contact_id = ?
2021-07-04 18:42:24 +01:00
| ]
2022-01-31 15:14:56 +04:00
( userId , userId , contactId )
2022-06-18 20:06:13 +01:00
connections [] = throwError $ SEContactNotFound contactId
connections rows = pure $ map toConnection rows
2021-07-12 19:00:03 +01:00
2022-06-27 19:41:25 +01:00
type EntityIdsRow = ( Maybe Int64 , Maybe Int64 , Maybe Int64 , Maybe Int64 , Maybe Int64 )
2022-10-24 14:28:58 +04:00
type ConnectionRow = ( Int64 , ConnId , Int , Maybe Int64 , Maybe Int64 , Bool , Maybe Int64 , ConnStatus , ConnType , LocalAlias ) :. EntityIdsRow :. Only UTCTime
2021-07-04 18:42:24 +01:00
2022-10-24 14:28:58 +04:00
type MaybeConnectionRow = ( Maybe Int64 , Maybe ConnId , Maybe Int , Maybe Int64 , Maybe Int64 , Maybe Bool , Maybe Int64 , Maybe ConnStatus , Maybe ConnType , Maybe LocalAlias ) :. EntityIdsRow :. Only ( Maybe UTCTime )
2021-07-16 07:40:55 +01:00
2021-07-12 19:00:03 +01:00
toConnection :: ConnectionRow -> Connection
2022-10-24 14:28:58 +04:00
toConnection ( ( connId , acId , connLevel , viaContact , viaUserContactLink , viaGroupLink , customUserProfileId , connStatus , connType , localAlias ) :. ( contactId , groupMemberId , sndFileId , rcvFileId , userContactLinkId ) :. Only createdAt ) =
2021-07-05 19:54:44 +01:00
let entityId = entityId_ connType
2022-10-24 14:28:58 +04:00
in Connection { connId , agentConnId = AgentConnId acId , connLevel , viaContact , viaUserContactLink , viaGroupLink , customUserProfileId , connStatus , connType , localAlias , entityId , createdAt }
2021-07-05 19:54:44 +01:00
where
entityId_ :: ConnType -> Maybe Int64
entityId_ ConnContact = contactId
entityId_ ConnMember = groupMemberId
2021-09-04 07:32:56 +01:00
entityId_ ConnRcvFile = rcvFileId
entityId_ ConnSndFile = sndFileId
2021-12-08 13:09:51 +00:00
entityId_ ConnUserContact = userContactLinkId
2021-07-04 18:42:24 +01:00
2021-07-16 07:40:55 +01:00
toMaybeConnection :: MaybeConnectionRow -> Maybe Connection
2022-10-24 14:28:58 +04:00
toMaybeConnection ( ( Just connId , Just agentConnId , Just connLevel , viaContact , viaUserContactLink , Just viaGroupLink , customUserProfileId , Just connStatus , Just connType , Just localAlias ) :. ( contactId , groupMemberId , sndFileId , rcvFileId , userContactLinkId ) :. Only ( Just createdAt ) ) =
Just $ toConnection ( ( connId , agentConnId , connLevel , viaContact , viaUserContactLink , viaGroupLink , customUserProfileId , connStatus , connType , localAlias ) :. ( contactId , groupMemberId , sndFileId , rcvFileId , userContactLinkId ) :. Only createdAt )
2021-07-16 07:40:55 +01:00
toMaybeConnection _ = Nothing
2022-06-18 20:06:13 +01:00
getMatchingContacts :: DB . Connection -> UserId -> Contact -> IO [ Contact ]
2022-08-18 11:35:31 +04:00
getMatchingContacts db userId Contact { contactId , profile = LocalProfile { displayName , fullName , image } } = do
2022-06-18 20:06:13 +01:00
contactIds <-
map fromOnly
2022-08-18 11:35:31 +04:00
<$> DB . query
2022-02-02 20:25:36 +04:00
db
2022-06-18 20:06:13 +01:00
[ sql |
SELECT ct . contact_id
FROM contacts ct
JOIN contact_profiles p ON ct . contact_profile_id = p . contact_profile_id
2022-08-18 11:35:31 +04:00
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 = ? )
2022-06-18 20:06:13 +01:00
| ]
2022-08-18 11:35:31 +04:00
( userId , contactId , displayName , fullName , image , image )
2022-06-18 20:06:13 +01:00
rights <$> mapM ( runExceptT . getContact db userId ) contactIds
2021-07-27 08:08:05 +01:00
2022-06-18 20:06:13 +01:00
createSentProbe :: DB . Connection -> TVar ChaChaDRG -> UserId -> Contact -> ExceptT StoreError IO ( Probe , Int64 )
createSentProbe db gVar userId _to @ Contact { contactId } =
createWithRandomBytes 32 gVar $ \ probe -> do
2022-02-02 20:25:36 +04:00
currentTs <- getCurrentTime
DB . execute
db
2022-06-18 20:06:13 +01:00
" 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 )
2022-08-27 19:56:03 +04:00
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 )
2022-06-18 20:06:13 +01:00
matchReceivedProbe :: DB . Connection -> UserId -> Contact -> Probe -> IO ( Maybe Contact )
matchReceivedProbe db userId _from @ Contact { contactId } ( Probe probe ) = do
let probeHash = C . sha256Hash probe
contactIds <-
map fromOnly
<$> DB . query
2021-07-27 08:08:05 +01:00
db
[ sql |
2022-06-18 20:06:13 +01:00
SELECT c . contact_id
2021-07-27 08:08:05 +01:00
FROM contacts c
JOIN received_probes r ON r . contact_id = c . contact_id
2022-06-18 20:06:13 +01:00
WHERE c . user_id = ? AND r . probe_hash = ? AND r . probe IS NULL
2021-07-27 08:08:05 +01:00
| ]
( userId , probeHash )
2022-06-18 20:06:13 +01:00
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 userId cId )
matchReceivedProbeHash :: DB . Connection -> UserId -> Contact -> ProbeHash -> IO ( Maybe ( Contact , Probe ) )
matchReceivedProbeHash db userId _from @ Contact { contactId } ( ProbeHash probeHash ) = do
namesAndProbes <-
DB . query
2021-07-27 08:08:05 +01:00
db
[ sql |
2022-06-18 20:06:13 +01:00
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
2021-07-27 08:08:05 +01:00
| ]
2022-06-18 20:06:13 +01:00
( 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 userId cId )
matchSentProbe :: DB . Connection -> UserId -> Contact -> Probe -> IO ( Maybe Contact )
matchSentProbe db 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 userId cId )
mergeContactRecords :: DB . Connection -> UserId -> Contact -> Contact -> IO ()
mergeContactRecords db userId Contact { contactId = toContactId } Contact { contactId = fromContactId , localDisplayName } = do
currentTs <- getCurrentTime
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 )
2022-10-27 23:38:03 +04:00
DB . execute
db
" UPDATE chat_items SET contact_id = ?, updated_at = ? WHERE contact_id = ? AND user_id = ? "
( toContactId , currentTs , fromContactId , userId )
2022-06-18 20:06:13 +01:00
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 )
2022-07-17 15:51:17 +01:00
getConnectionEntity :: DB . Connection -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity
2022-06-18 20:06:13 +01:00
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
2021-07-04 18:42:24 +01:00
where
2022-06-18 20:06:13 +01:00
getConnection_ :: ExceptT StoreError IO Connection
getConnection_ = ExceptT $ do
2022-07-17 15:51:17 +01:00
firstRow toConnection ( SEConnectionNotFound agentConnId ) $
DB . query
2021-07-05 19:54:44 +01:00
db
[ sql |
2022-10-24 14:28:58 +04:00
SELECT connection_id , agent_conn_id , conn_level , via_contact , via_user_contact_link , via_group_link , custom_user_profile_id ,
2022-09-27 20:45:46 +01:00
conn_status , conn_type , local_alias , contact_id , group_member_id , snd_file_id , rcv_file_id , user_contact_link_id , created_at
2021-07-05 19:54:44 +01:00
FROM connections
2021-07-12 19:00:03 +01:00
WHERE user_id = ? AND agent_conn_id = ?
2021-07-05 19:54:44 +01:00
| ]
( userId , agentConnId )
2022-06-18 20:06:13 +01:00
getContactRec_ :: Int64 -> Connection -> ExceptT StoreError IO Contact
getContactRec_ contactId c = ExceptT $ do
2022-02-02 20:25:36 +04:00
toContact' contactId c
2021-07-05 19:54:44 +01:00
<$> DB . query
db
[ sql |
2022-11-01 17:32:49 +03:00
SELECT c . contact_profile_id , c . local_display_name , p . display_name , p . full_name , p . image , p . local_alias , c . via_group , c . contact_used , c . enable_ntfs , p . preferences , c . user_preferences , c . created_at , c . updated_at
2021-07-05 19:54:44 +01:00
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 )
2022-11-01 17:32:49 +03:00
toContact' :: Int64 -> Connection -> [ ( ProfileId , ContactName , Text , Text , Maybe ImageData , LocalAlias , Maybe Int64 , Bool , Maybe Bool ) :. ( Maybe ChatPreferences , ChatPreferences , UTCTime , UTCTime ) ] -> Either StoreError Contact
toContact' contactId activeConn [ ( profileId , localDisplayName , displayName , fullName , image , localAlias , viaGroup , contactUsed , enableNtfs_ ) :. ( preferences , userPreferences , createdAt , updatedAt ) ] =
let profile = LocalProfile { profileId , displayName , fullName , image , preferences , localAlias }
2022-08-19 15:17:05 +01:00
chatSettings = ChatSettings { enableNtfs = fromMaybe True enableNtfs_ }
2022-11-01 17:32:49 +03:00
in Right $ Contact { contactId , localDisplayName , profile , activeConn , viaGroup , contactUsed , chatSettings , userPreferences , createdAt , updatedAt }
2022-02-07 15:19:34 +04:00
toContact' _ _ _ = Left $ SEInternalError " referenced contact not found "
2022-06-18 20:06:13 +01:00
getGroupAndMember_ :: Int64 -> Connection -> ExceptT StoreError IO ( GroupInfo , GroupMember )
getGroupAndMember_ groupMemberId c = ExceptT $ do
2022-02-07 15:19:34 +04:00
firstRow ( toGroupAndMember c ) ( SEInternalError " referenced group member not found " ) $
2022-01-26 16:18:27 +04:00
DB . query
2021-07-16 07:40:55 +01:00
db
[ sql |
SELECT
2022-01-26 16:18:27 +04:00
-- GroupInfo
2022-11-01 17:32:49 +03:00
g . group_id , g . local_display_name , gp . display_name , gp . full_name , gp . image , g . host_conn_custom_user_profile_id , g . enable_ntfs , gp . preferences , g . created_at , g . updated_at ,
2022-01-29 16:06:08 +04:00
-- GroupInfo {membership}
mu . group_member_id , mu . group_id , mu . member_id , mu . member_role , mu . member_category ,
2022-08-18 11:35:31 +04:00
mu . member_status , mu . invited_by , mu . local_display_name , mu . contact_id , mu . contact_profile_id , pu . contact_profile_id ,
2022-01-29 16:06:08 +04:00
-- GroupInfo {membership = GroupMember {memberProfile}}
2022-11-01 17:32:49 +03:00
pu . display_name , pu . full_name , pu . image , pu . local_alias , pu . preferences ,
2022-01-26 16:18:27 +04:00
-- from GroupMember
2021-09-05 14:08:29 +01:00
m . group_member_id , m . group_id , m . member_id , m . member_role , m . member_category , m . member_status ,
2022-11-01 17:32:49 +03:00
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 . local_alias , p . preferences
2021-07-16 07:40:55 +01:00
FROM group_members m
2022-08-18 11:35:31 +04:00
JOIN contact_profiles p ON p . contact_profile_id = COALESCE ( m . member_profile_id , m . contact_profile_id )
2021-07-16 07:40:55 +01:00
JOIN groups g ON g . group_id = m . group_id
2022-01-26 16:18:27 +04:00
JOIN group_profiles gp USING ( group_profile_id )
JOIN group_members mu ON g . group_id = mu . group_id
2022-08-18 11:35:31 +04:00
JOIN contact_profiles pu ON pu . contact_profile_id = COALESCE ( mu . member_profile_id , mu . contact_profile_id )
2022-01-26 16:18:27 +04:00
WHERE m . group_member_id = ? AND g . user_id = ? AND mu . contact_id = ?
2021-07-16 07:40:55 +01:00
| ]
2022-01-26 16:18:27 +04:00
( groupMemberId , userId , userContactId )
2022-01-29 16:06:08 +04:00
toGroupAndMember :: Connection -> GroupInfoRow :. GroupMemberRow -> ( GroupInfo , GroupMember )
2022-01-31 22:43:39 +04:00
toGroupAndMember c ( groupInfoRow :. memberRow ) =
let groupInfo = toGroupInfo userContactId groupInfoRow
member = toGroupMember userContactId memberRow
in ( groupInfo , ( member :: GroupMember ) { activeConn = Just c } )
2022-06-18 20:06:13 +01:00
getConnSndFileTransfer_ :: Int64 -> Connection -> ExceptT StoreError IO SndFileTransfer
getConnSndFileTransfer_ fileId Connection { connId } =
2021-09-04 07:32:56 +01:00
ExceptT $
2022-07-17 15:51:17 +01:00
firstRow' ( sndFileTransfer_ fileId connId ) ( SESndFileNotFound fileId ) $
DB . query
2021-09-04 07:32:56 +01:00
db
[ sql |
2022-10-14 13:06:33 +01:00
SELECT s . file_status , f . file_name , f . file_size , f . chunk_size , f . file_path , s . file_inline , cs . local_display_name , m . local_display_name
2021-09-04 07:32:56 +01:00
FROM snd_files s
JOIN files f USING ( file_id )
2021-09-05 14:08:29 +01:00
LEFT JOIN contacts cs USING ( contact_id )
2022-04-05 10:01:08 +04:00
LEFT JOIN group_members m USING ( group_member_id )
2021-09-04 07:32:56 +01:00
WHERE f . user_id = ? AND f . file_id = ? AND s . connection_id = ?
| ]
( userId , fileId , connId )
2022-10-14 13:06:33 +01:00
sndFileTransfer_ :: Int64 -> Int64 -> ( FileStatus , String , Integer , Integer , FilePath , Maybe InlineFileMode , Maybe ContactName , Maybe ContactName ) -> Either StoreError SndFileTransfer
sndFileTransfer_ fileId connId ( fileStatus , fileName , fileSize , chunkSize , filePath , fileInline , contactName_ , memberName_ ) =
2021-09-05 14:08:29 +01:00
case contactName_ <|> memberName_ of
2022-10-14 13:06:33 +01:00
Just recipientDisplayName -> Right SndFileTransfer { fileId , fileStatus , fileName , fileSize , chunkSize , filePath , fileInline , recipientDisplayName , connId , agentConnId }
2021-09-05 14:08:29 +01:00
Nothing -> Left $ SESndFileInvalid fileId
2022-06-18 20:06:13 +01:00
getUserContact_ :: Int64 -> ExceptT StoreError IO UserContact
getUserContact_ userContactLinkId = ExceptT $ do
2021-12-08 13:09:51 +00:00
userContact_
<$> DB . query
db
[ sql |
2022-10-13 17:12:22 +04:00
SELECT conn_req_contact , group_id
2021-12-08 13:09:51 +00:00
FROM user_contact_links
WHERE user_id = ? AND user_contact_link_id = ?
| ]
( userId , userContactLinkId )
where
2022-10-13 17:12:22 +04:00
userContact_ :: [ ( ConnReqContact , Maybe GroupId ) ] -> Either StoreError UserContact
userContact_ [ ( cReq , groupId ) ] = Right UserContact { userContactLinkId , connReqContact = cReq , groupId }
2021-12-08 13:09:51 +00:00
userContact_ _ = Left SEUserContactLinkNotFound
2021-07-24 10:26:28 +01:00
2022-09-14 19:45:21 +04:00
getConnectionById :: DB . Connection -> User -> Int64 -> ExceptT StoreError IO Connection
getConnectionById db User { userId } connId = ExceptT $ do
firstRow toConnection ( SEConnectionNotFoundById connId ) $
DB . query
db
[ sql |
2022-10-24 14:28:58 +04:00
SELECT connection_id , agent_conn_id , conn_level , via_contact , via_user_contact_link , via_group_link , custom_user_profile_id ,
2022-09-27 20:45:46 +01:00
conn_status , conn_type , local_alias , contact_id , group_member_id , snd_file_id , rcv_file_id , user_contact_link_id , created_at
2022-09-14 19:45:21 +04:00
FROM connections
WHERE user_id = ? AND connection_id = ?
| ]
( userId , connId )
2022-06-18 20:06:13 +01:00
getConnectionsContacts :: DB . Connection -> UserId -> [ ConnId ] -> IO [ ContactRef ]
getConnectionsContacts db userId 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 ( uncurry ContactRef )
<$> DB . query
2022-04-05 10:01:08 +04:00
db
[ sql |
2022-06-18 20:06:13 +01:00
SELECT ct . contact_id , ct . local_display_name
FROM contacts ct
JOIN connections c ON c . contact_id = ct . contact_id
WHERE ct . user_id = ?
AND c . agent_conn_id IN ( SELECT conn_id FROM temp . conn_ids )
AND c . conn_type = ?
2022-04-05 10:01:08 +04:00
| ]
2022-06-18 20:06:13 +01:00
( userId , ConnContact )
DB . execute_ db " DROP TABLE temp.conn_ids "
pure conns
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
2022-11-01 17:32:49 +03:00
g . group_id , g . local_display_name , gp . display_name , gp . full_name , gp . image , g . host_conn_custom_user_profile_id , g . enable_ntfs , gp . preferences , g . created_at , g . updated_at ,
2022-06-18 20:06:13 +01:00
-- GroupInfo {membership}
mu . group_member_id , mu . group_id , mu . member_id , mu . member_role , mu . member_category ,
2022-08-18 11:35:31 +04:00
mu . member_status , mu . invited_by , mu . local_display_name , mu . contact_id , mu . contact_profile_id , pu . contact_profile_id ,
2022-06-18 20:06:13 +01:00
-- GroupInfo {membership = GroupMember {memberProfile}}
2022-11-01 17:32:49 +03:00
pu . display_name , pu . full_name , pu . image , pu . local_alias , pu . preferences ,
2022-06-18 20:06:13 +01:00
-- from GroupMember
m . group_member_id , m . group_id , m . member_id , m . member_role , m . member_category , m . member_status ,
2022-11-01 17:32:49 +03:00
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 . local_alias , p . preferences ,
2022-10-24 14:28:58 +04:00
c . connection_id , c . agent_conn_id , c . conn_level , c . via_contact , c . via_user_contact_link , c . via_group_link , c . custom_user_profile_id ,
2022-09-27 20:45:46 +01:00
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
2022-06-18 20:06:13 +01:00
FROM group_members m
2022-08-18 11:35:31 +04:00
JOIN contact_profiles p ON p . contact_profile_id = COALESCE ( m . member_profile_id , m . contact_profile_id )
2022-06-18 20:06:13 +01:00
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
2022-08-18 11:35:31 +04:00
JOIN contact_profiles pu ON pu . contact_profile_id = COALESCE ( mu . member_profile_id , mu . contact_profile_id )
2022-06-18 20:06:13 +01:00
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
2022-04-05 10:01:08 +04:00
member = toGroupMember userContactId memberRow
in ( groupInfo , ( member :: GroupMember ) { activeConn = toMaybeConnection connRow } )
2022-06-18 20:06:13 +01:00
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 )
2021-07-04 18:42:24 +01:00
2021-07-12 19:00:03 +01:00
-- | creates completely new group with a single member - the current user
2022-08-27 19:56:03 +04:00
createNewGroup :: DB . Connection -> TVar ChaChaDRG -> User -> GroupProfile -> ExceptT StoreError IO GroupInfo
createNewGroup db gVar user @ User { userId } groupProfile = ExceptT $ do
2022-11-01 17:32:49 +03:00
let GroupProfile { displayName , fullName , image , preferences } = groupProfile
2022-07-31 18:54:49 +01:00
currentTs <- getCurrentTime
2022-08-18 11:35:31 +04:00
withLocalDisplayName db userId displayName $ \ ldn -> runExceptT $ do
groupId <- liftIO $ do
DB . execute
db
2022-11-01 17:32:49 +03:00
" INSERT INTO group_profiles (display_name, full_name, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?) "
( displayName , fullName , image , userId , preferences , currentTs , currentTs )
2022-08-18 11:35:31 +04:00
profileId <- insertedRowId db
DB . execute
db
2022-08-19 15:17:05 +01:00
" INSERT INTO groups (local_display_name, user_id, group_profile_id, enable_ntfs, created_at, updated_at) VALUES (?,?,?,?,?,?) "
( ldn , userId , profileId , True , currentTs , currentTs )
2022-08-18 11:35:31 +04:00
insertedRowId db
memberId <- liftIO $ encodedRandomBytes gVar 12
2022-08-27 19:56:03 +04:00
membership <- createContactMemberInv_ db user groupId user ( MemberIdRole ( MemberId memberId ) GROwner ) GCUserMember GSMemCreator IBUser Nothing currentTs
2022-08-19 15:17:05 +01:00
let chatSettings = ChatSettings { enableNtfs = True }
2022-08-22 11:04:34 +04:00
pure GroupInfo { groupId , localDisplayName = ldn , groupProfile , membership , hostConnCustomUserProfileId = Nothing , chatSettings , createdAt = currentTs , updatedAt = currentTs }
2021-07-12 19:00:03 +01:00
2022-01-06 23:39:58 +04:00
-- | creates a new group record for the group the current user was invited to, or returns an existing one
2022-11-03 14:46:36 +04:00
createGroupInvitation :: DB . Connection -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> ExceptT StoreError IO ( GroupInfo , GroupMemberId )
2022-08-27 19:56:03 +04:00
createGroupInvitation db user @ User { userId } contact @ Contact { contactId , activeConn = Connection { customUserProfileId } } GroupInvitation { fromMember , invitedMember , connRequest , groupProfile } incognitoProfileId = do
2022-06-18 20:06:13 +01:00
liftIO getInvitationGroupId_ >>= \ case
2022-08-18 11:35:31 +04:00
Nothing -> createGroupInvitation_
2022-10-03 09:00:47 +01:00
Just gId -> do
gInfo @ GroupInfo { membership , groupProfile = p' } <- getGroupInfo db user gId
2022-11-03 14:46:36 +04:00
hostId <- getHostMemberId_ db user gId
2022-10-03 09:00:47 +01:00
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 )
2022-11-03 14:46:36 +04:00
gInfo' <-
if p' == groupProfile
then pure gInfo
else updateGroupProfile db user gInfo groupProfile
pure ( gInfo' , hostId )
2022-01-06 23:39:58 +04:00
where
2022-06-18 20:06:13 +01:00
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 )
2022-11-03 14:46:36 +04:00
createGroupInvitation_ :: ExceptT StoreError IO ( GroupInfo , GroupMemberId )
2022-06-18 20:06:13 +01:00
createGroupInvitation_ = do
2022-11-01 17:32:49 +03:00
let GroupProfile { displayName , fullName , image , preferences } = groupProfile
2022-08-18 11:35:31 +04:00
ExceptT $
withLocalDisplayName db userId displayName $ \ localDisplayName -> runExceptT $ do
currentTs <- liftIO getCurrentTime
groupId <- liftIO $ do
DB . execute
db
2022-11-01 17:32:49 +03:00
" INSERT INTO group_profiles (display_name, full_name, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?) "
( displayName , fullName , image , userId , preferences , currentTs , currentTs )
2022-08-18 11:35:31 +04:00
profileId <- insertedRowId db
DB . execute
db
2022-08-22 23:12:09 +04:00
" 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) VALUES (?,?,?,?,?,?,?,?) "
( profileId , localDisplayName , connRequest , customUserProfileId , userId , True , currentTs , currentTs )
2022-08-18 11:35:31 +04:00
insertedRowId db
2022-11-03 14:46:36 +04:00
GroupMember { groupMemberId } <- createContactMemberInv_ db user groupId contact fromMember GCHostMember GSMemInvited IBUnknown Nothing currentTs
2022-08-27 19:56:03 +04:00
membership <- createContactMemberInv_ db user groupId user invitedMember GCUserMember GSMemInvited ( IBContact contactId ) incognitoProfileId currentTs
2022-08-19 15:17:05 +01:00
let chatSettings = ChatSettings { enableNtfs = True }
2022-11-03 14:46:36 +04:00
pure ( GroupInfo { groupId , localDisplayName , groupProfile , membership , hostConnCustomUserProfileId = customUserProfileId , chatSettings , createdAt = currentTs , updatedAt = 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 )
2022-08-18 11:35:31 +04:00
2022-08-27 19:56:03 +04:00
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
2022-08-24 19:03:43 +04:00
( localDisplayName , memberProfile ) <- case ( incognitoProfile , incognitoProfileId ) of
2022-08-27 19:56:03 +04:00
( Just profile @ LocalProfile { displayName } , Just profileId ) ->
( , profile ) <$> insertMemberIncognitoProfile_ displayName profileId
2022-08-18 11:35:31 +04:00
_ -> ( , 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
2022-02-02 20:25:36 +04:00
DB . execute
db
2022-08-18 11:35:31 +04:00
[ 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
2021-07-12 19:00:03 +01:00
2022-07-15 17:49:29 +04:00
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 )
2021-07-12 19:00:03 +01:00
-- TODO return the last connection that is ready, not any last connection
-- requires updating connection status
2022-07-12 19:20:56 +04:00
getGroup :: DB . Connection -> User -> GroupId -> ExceptT StoreError IO Group
2022-06-18 20:06:13 +01:00
getGroup db user groupId = do
gInfo <- getGroupInfo db user groupId
members <- liftIO $ getGroupMembers db user gInfo
2022-01-26 16:18:27 +04:00
pure $ Group gInfo members
2021-07-16 07:40:55 +01:00
2022-08-04 11:12:50 +01:00
deleteGroupConnectionsAndFiles :: DB . Connection -> User -> GroupInfo -> [ GroupMember ] -> IO ()
deleteGroupConnectionsAndFiles db User { userId } GroupInfo { groupId } members = do
2022-07-15 17:49:29 +04:00
forM_ members $ \ m -> DB . execute db " DELETE FROM connections WHERE user_id = ? AND group_member_id = ? " ( userId , groupMemberId' m )
2022-08-02 14:10:03 +04:00
DB . execute db " DELETE FROM files WHERE user_id = ? AND group_id = ? " ( userId , groupId )
2022-10-20 19:27:00 +04:00
deleteGroupItemsAndMembers :: DB . Connection -> User -> GroupInfo -> [ GroupMember ] -> IO ()
deleteGroupItemsAndMembers db user @ User { userId } GroupInfo { groupId } members = do
2022-08-02 14:10:03 +04:00
DB . execute db " DELETE FROM chat_items WHERE user_id = ? AND group_id = ? " ( userId , groupId )
2022-06-18 20:06:13 +01:00
DB . execute db " DELETE FROM group_members WHERE user_id = ? AND group_id = ? " ( userId , groupId )
2022-10-26 13:37:17 +04:00
forM_ members $ \ m -> cleanupMemberContactAndProfile_ db user m
2022-08-04 11:12:50 +01:00
deleteGroup :: DB . Connection -> User -> GroupInfo -> IO ()
deleteGroup db User { userId } GroupInfo { groupId , localDisplayName } = do
2022-08-02 14:10:03 +04:00
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 )
deleteGroupProfile_ :: DB . Connection -> UserId -> GroupId -> IO ()
deleteGroupProfile_ db userId groupId =
2022-06-18 20:06:13 +01:00
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
2022-05-14 21:00:46 +04:00
db
[ sql |
2022-11-01 17:32:49 +03:00
SELECT g . group_id , g . local_display_name , gp . display_name , gp . full_name , gp . image , g . host_conn_custom_user_profile_id , g . enable_ntfs , gp . preferences , g . created_at , g . updated_at ,
2022-08-22 11:04:34 +04:00
mu . group_member_id , g . group_id , mu . member_id , mu . member_role , mu . member_category , mu . member_status ,
2022-11-01 17:32:49 +03:00
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 . local_alias , pu . preferences
2022-06-18 20:06:13 +01:00
FROM groups g
JOIN group_profiles gp USING ( group_profile_id )
2022-08-22 11:04:34 +04:00
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 = ?
2022-05-14 21:00:46 +04:00
| ]
2022-06-18 20:06:13 +01:00
( userId , userContactId )
2022-01-26 16:18:27 +04:00
2022-06-18 20:06:13 +01:00
getGroupInfoByName :: DB . Connection -> User -> GroupName -> ExceptT StoreError IO GroupInfo
getGroupInfoByName db user gName = do
gId <- getGroupIdByName db user gName
getGroupInfo db user gId
2022-01-26 16:18:27 +04:00
2022-11-01 17:32:49 +03:00
type GroupInfoRow = ( Int64 , GroupName , GroupName , Text , Maybe ImageData , Maybe ProfileId , Maybe Bool , Maybe ChatPreferences , UTCTime , UTCTime ) :. GroupMemberRow
2022-01-29 16:06:08 +04:00
toGroupInfo :: Int64 -> GroupInfoRow -> GroupInfo
2022-11-01 17:32:49 +03:00
toGroupInfo userContactId ( ( groupId , localDisplayName , displayName , fullName , image , hostConnCustomUserProfileId , enableNtfs_ , preferences , createdAt , updatedAt ) :. userMemberRow ) =
2022-01-29 16:06:08 +04:00
let membership = toGroupMember userContactId userMemberRow
2022-08-19 15:17:05 +01:00
chatSettings = ChatSettings { enableNtfs = fromMaybe True enableNtfs_ }
2022-11-01 17:32:49 +03:00
in GroupInfo { groupId , localDisplayName , groupProfile = GroupProfile { displayName , fullName , image , preferences } , membership , hostConnCustomUserProfileId , chatSettings , createdAt , updatedAt }
2022-01-26 16:18:27 +04:00
2022-07-20 14:57:16 +01:00
getGroupMember :: DB . Connection -> User -> GroupId -> GroupMemberId -> ExceptT StoreError IO GroupMember
getGroupMember db user @ User { userId } groupId groupMemberId =
ExceptT . firstRow ( toContactMember user ) ( SEGroupMemberNotFound { groupId , groupMemberId } ) $
DB . query
db
[ sql |
SELECT
m . group_member_id , m . group_id , m . member_id , m . member_role , m . member_category , m . member_status ,
2022-11-01 17:32:49 +03:00
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 . local_alias , p . preferences ,
2022-10-24 14:28:58 +04:00
c . connection_id , c . agent_conn_id , c . conn_level , c . via_contact , c . via_user_contact_link , c . via_group_link , c . custom_user_profile_id ,
2022-09-27 20:45:46 +01:00
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
2022-07-20 14:57:16 +01:00
FROM group_members m
2022-08-18 11:35:31 +04:00
JOIN contact_profiles p ON p . contact_profile_id = COALESCE ( m . member_profile_id , m . contact_profile_id )
2022-07-20 14:57:16 +01:00
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_id = ? AND m . group_member_id = ? AND m . user_id = ?
| ]
( groupId , groupMemberId , userId )
2022-06-18 20:06:13 +01:00
getGroupMembers :: DB . Connection -> User -> GroupInfo -> IO [ GroupMember ]
2022-07-20 14:57:16 +01:00
getGroupMembers db user @ User { userId , userContactId } GroupInfo { groupId } = do
map ( toContactMember user )
2022-01-26 16:18:27 +04:00
<$> DB . query
db
[ sql |
SELECT
m . group_member_id , m . group_id , m . member_id , m . member_role , m . member_category , m . member_status ,
2022-11-01 17:32:49 +03:00
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 . local_alias , p . preferences ,
2022-10-24 14:28:58 +04:00
c . connection_id , c . agent_conn_id , c . conn_level , c . via_contact , c . via_user_contact_link , c . via_group_link , c . custom_user_profile_id ,
2022-09-27 20:45:46 +01:00
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
2022-01-26 16:18:27 +04:00
FROM group_members m
2022-08-18 11:35:31 +04:00
JOIN contact_profiles p ON p . contact_profile_id = COALESCE ( m . member_profile_id , m . contact_profile_id )
2022-01-26 16:18:27 +04:00
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_id = ? AND m . user_id = ? AND ( m . contact_id IS NULL OR m . contact_id != ? )
| ]
( groupId , userId , userContactId )
2022-07-20 14:57:16 +01:00
2022-10-26 13:37:17 +04:00
getGroupMembersForExpiration :: DB . Connection -> User -> GroupInfo -> IO [ GroupMember ]
getGroupMembersForExpiration db user @ User { userId , userContactId } GroupInfo { groupId } = do
map ( toContactMember user )
<$> DB . query
db
[ 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 . local_alias ,
c . connection_id , c . agent_conn_id , c . conn_level , c . via_contact , c . via_user_contact_link , c . via_group_link , 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
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
)
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 )
2022-07-20 14:57:16 +01:00
toContactMember :: User -> ( GroupMemberRow :. MaybeConnectionRow ) -> GroupMember
toContactMember User { userContactId } ( memberRow :. connRow ) =
( toGroupMember userContactId memberRow ) { activeConn = toMaybeConnection connRow }
2021-12-10 11:45:58 +00:00
2022-07-12 19:20:56 +04:00
getGroupInvitation :: DB . Connection -> User -> GroupId -> ExceptT StoreError IO ReceivedGroupInvitation
2022-11-03 14:46:36 +04:00
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
2022-06-18 20:06:13 +01:00
pure ReceivedGroupInvitation { fromMember , connRequest , groupInfo }
_ -> throwError SEGroupInvitationNotFound
2021-07-16 07:40:55 +01:00
where
2022-06-18 20:06:13 +01:00
getConnRec_ :: User -> ExceptT StoreError IO ( Maybe ConnReqInvitation )
getConnRec_ User { userId } = ExceptT $ do
2022-07-12 19:20:56 +04:00
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 )
2021-07-12 19:00:03 +01:00
2022-11-01 17:32:49 +03:00
type GroupMemberRow = ( ( Int64 , Int64 , MemberId , GroupMemberRole , GroupMemberCategory , GroupMemberStatus ) :. ( Maybe Int64 , ContactName , Maybe ContactId , ProfileId , ProfileId , ContactName , Text , Maybe ImageData , LocalAlias , Maybe ChatPreferences ) )
2021-07-12 19:00:03 +01:00
2022-11-01 17:32:49 +03:00
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 LocalAlias , Maybe ChatPreferences ) )
2022-01-29 16:06:08 +04:00
2021-07-16 07:40:55 +01:00
toGroupMember :: Int64 -> GroupMemberRow -> GroupMember
2022-11-01 17:32:49 +03:00
toGroupMember userContactId ( ( groupMemberId , groupId , memberId , memberRole , memberCategory , memberStatus ) :. ( invitedById , localDisplayName , memberContactId , memberContactProfileId , profileId , displayName , fullName , image , localAlias , preferences ) ) =
let memberProfile = LocalProfile { profileId , displayName , fullName , image , preferences , localAlias }
2021-07-16 07:40:55 +01:00
invitedBy = toInvitedBy userContactId invitedById
2021-09-05 14:08:29 +01:00
activeConn = Nothing
in GroupMember { .. }
2021-07-16 07:40:55 +01:00
2022-01-29 16:06:08 +04:00
toMaybeGroupMember :: Int64 -> MaybeGroupMemberRow -> Maybe GroupMember
2022-11-01 17:32:49 +03:00
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 , Just localAlias , contactPreferences ) ) =
Just $ toGroupMember userContactId ( ( groupMemberId , groupId , memberId , memberRole , memberCategory , memberStatus ) :. ( invitedById , localDisplayName , memberContactId , memberContactProfileId , profileId , displayName , fullName , image , localAlias , contactPreferences ) )
2022-01-29 16:06:08 +04:00
toMaybeGroupMember _ _ = Nothing
2022-08-18 11:35:31 +04:00
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 =
2022-06-18 20:06:13 +01:00
createWithRandomId gVar $ \ memId -> do
2022-08-18 11:35:31 +04:00
createdAt <- liftIO getCurrentTime
member @ GroupMember { groupMemberId } <- createMember_ ( MemberId memId ) createdAt
void $ createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 createdAt
2022-06-18 20:06:13 +01:00
pure member
2022-08-18 11:35:31 +04:00
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 )
)
2021-07-12 19:00:03 +01:00
2022-10-15 14:48:07 +04:00
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 { userId } GroupMember { groupMemberId } =
maybeFirstRow toContact $
DB . query
db
[ sql |
SELECT
-- Contact
2022-11-01 17:32:49 +03:00
ct . contact_id , ct . contact_profile_id , ct . local_display_name , ct . via_group , cp . display_name , cp . full_name , cp . image , cp . local_alias , ct . contact_used , ct . enable_ntfs , cp . preferences , ct . user_preferences , ct . created_at , ct . updated_at ,
2022-10-15 14:48:07 +04:00
-- Connection
2022-10-24 14:28:58 +04:00
c . connection_id , c . agent_conn_id , c . conn_level , c . via_contact , c . via_user_contact_link , c . via_group_link , c . custom_user_profile_id , c . conn_status , c . conn_type , c . local_alias ,
2022-10-15 14:48:07 +04:00
c . contact_id , c . group_member_id , c . snd_file_id , c . rcv_file_id , c . user_contact_link_id , c . created_at
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 )
2022-06-18 20:06:13 +01:00
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
2022-11-03 14:46:36 +04:00
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
2022-06-18 20:06:13 +01:00
updateGroupMemberStatus :: DB . Connection -> UserId -> GroupMember -> GroupMemberStatus -> IO ()
2022-09-14 19:45:21 +04:00
updateGroupMemberStatus db userId GroupMember { groupMemberId } = updateGroupMemberStatusById db userId groupMemberId
updateGroupMemberStatusById :: DB . Connection -> UserId -> GroupMemberId -> GroupMemberStatus -> IO ()
updateGroupMemberStatusById db userId groupMemberId memStatus = do
2022-06-18 20:06:13 +01:00
currentTs <- getCurrentTime
2022-08-18 11:35:31 +04:00
DB . execute
2022-06-18 20:06:13 +01:00
db
[ sql |
UPDATE group_members
2022-08-18 11:35:31 +04:00
SET member_status = ? , updated_at = ?
WHERE user_id = ? AND group_member_id = ?
2022-06-18 20:06:13 +01:00
| ]
2022-08-18 11:35:31 +04:00
( memStatus , currentTs , userId , groupMemberId )
2021-07-24 10:26:28 +01:00
-- | add new member with profile
2022-06-18 20:06:13 +01:00
createNewGroupMember :: DB . Connection -> User -> GroupInfo -> MemberInfo -> GroupMemberCategory -> GroupMemberStatus -> ExceptT StoreError IO GroupMember
2022-11-01 17:32:49 +03:00
createNewGroupMember db user @ User { userId } gInfo memInfo @ ( MemberInfo _ _ Profile { displayName , fullName , image , preferences } ) memCategory memStatus =
2022-06-18 20:06:13 +01:00
ExceptT . withLocalDisplayName db userId displayName $ \ localDisplayName -> do
currentTs <- getCurrentTime
DB . execute
db
2022-11-01 17:32:49 +03:00
" INSERT INTO contact_profiles (display_name, full_name, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?) "
( displayName , fullName , image , userId , preferences , currentTs , currentTs )
2022-06-18 20:06:13 +01:00
memProfileId <- insertedRowId db
let newMember =
NewGroupMember
{ memInfo ,
memCategory ,
memStatus ,
memInvitedBy = IBUnknown ,
localDisplayName ,
memContactId = Nothing ,
memProfileId
}
2022-08-18 11:35:31 +04:00
Right <$> createNewMember_ db user gInfo newMember currentTs
2021-07-24 10:26:28 +01:00
2022-02-02 20:25:36 +04:00
createNewMember_ :: DB . Connection -> User -> GroupInfo -> NewGroupMember -> UTCTime -> IO GroupMember
2021-07-24 10:26:28 +01:00
createNewMember_
db
User { userId , userContactId }
2022-01-26 16:18:27 +04:00
GroupInfo { groupId }
2021-07-24 10:26:28 +01:00
NewGroupMember
{ memInfo = MemberInfo memberId memberRole memberProfile ,
memCategory = memberCategory ,
memStatus = memberStatus ,
memInvitedBy = invitedBy ,
localDisplayName ,
memContactId = memberContactId ,
2022-08-18 11:35:31 +04:00
memProfileId = memberContactProfileId
2022-02-02 20:25:36 +04:00
}
createdAt = do
2021-07-24 10:26:28 +01:00
let invitedById = fromInvitedBy userContactId invitedBy
2021-09-05 14:08:29 +01:00
activeConn = Nothing
2021-07-24 10:26:28 +01:00
DB . execute
db
[ sql |
INSERT INTO group_members
( group_id , member_id , member_role , member_category , member_status ,
2022-08-18 11:35:31 +04:00
invited_by , user_id , local_display_name , contact_id , contact_profile_id , created_at , updated_at )
2022-02-02 20:25:36 +04:00
VALUES ( ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? )
2021-07-24 10:26:28 +01:00
| ]
2022-08-18 11:35:31 +04:00
( groupId , memberId , memberRole , memberCategory , memberStatus , invitedById , userId , localDisplayName , memberContactId , memberContactProfileId , createdAt , createdAt )
2021-07-24 10:26:28 +01:00
groupMemberId <- insertedRowId db
2022-08-24 19:03:43 +04:00
pure GroupMember { groupMemberId , groupId , memberId , memberRole , memberCategory , memberStatus , invitedBy , localDisplayName , memberProfile = toLocalProfile memberContactProfileId memberProfile " " , memberContactId , memberContactProfileId , activeConn }
2021-07-24 10:26:28 +01:00
2022-10-26 13:37:17 +04:00
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 )
2022-08-04 18:39:31 +01:00
deleteGroupMember :: DB . Connection -> User -> GroupMember -> IO ()
2022-10-26 13:37:17 +04:00
deleteGroupMember db user @ User { userId } m @ GroupMember { groupMemberId , groupId } = do
2022-08-04 18:39:31 +01:00
deleteGroupMemberConnection db user m
2022-10-22 14:23:03 +04:00
DB . execute db " DELETE FROM chat_items WHERE user_id = ? AND group_id = ? AND group_member_id = ? " ( userId , groupId , groupMemberId )
2022-08-04 18:39:31 +01:00
DB . execute db " DELETE FROM group_members WHERE user_id = ? AND group_member_id = ? " ( userId , groupMemberId )
2022-10-26 13:37:17 +04:00
cleanupMemberContactAndProfile_ db user m
2022-10-27 14:25:48 +04:00
-- it's important this function is used in transaction after the actual group_members record is deleted, see checkIncognitoProfileInUse_
2022-10-26 13:37:17 +04:00
cleanupMemberContactAndProfile_ :: DB . Connection -> User -> GroupMember -> IO ()
2022-10-27 14:25:48 +04:00
cleanupMemberContactAndProfile_ db user @ User { userId } m @ GroupMember { groupMemberId , localDisplayName , memberContactId , memberContactProfileId , memberProfile = LocalProfile { profileId } } =
2022-10-26 13:37:17 +04:00
case memberContactId of
Just contactId ->
runExceptT ( getContact db userId contactId ) >>= \ case
Right ct @ Contact { activeConn = Connection { connLevel , viaGroupLink } , contactUsed } ->
2022-10-27 14:25:48 +04:00
unless ( ( connLevel == 0 && not viaGroupLink ) || contactUsed ) $ deleteContact db user ct
2022-10-26 13:37:17 +04:00
_ -> pure ()
Nothing -> do
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 )
unless ( isJust 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 )
2022-10-27 14:25:48 +04:00
when ( memberIncognito m ) $ deleteUnusedIncognitoProfileById_ db user profileId
2022-08-04 18:39:31 +01:00
deleteGroupMemberConnection :: DB . Connection -> User -> GroupMember -> IO ()
deleteGroupMemberConnection db User { userId } GroupMember { groupMemberId } =
2021-08-02 20:10:24 +01:00
DB . execute db " DELETE FROM connections WHERE user_id = ? AND group_member_id = ? " ( userId , groupMemberId )
2022-10-03 09:00:47 +01:00
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 )
2022-06-18 20:06:13 +01:00
createIntroductions :: DB . Connection -> [ GroupMember ] -> GroupMember -> IO [ GroupMemberIntro ]
createIntroductions db members toMember = do
2022-07-15 17:49:29 +04:00
let reMembers = filter ( \ m -> memberCurrent m && groupMemberId' m /= groupMemberId' toMember ) members
2021-07-24 10:26:28 +01:00
if null reMembers
then pure []
2022-06-18 20:06:13 +01:00
else do
2022-02-02 20:25:36 +04:00
currentTs <- getCurrentTime
2022-06-18 20:06:13 +01:00
mapM ( insertIntro_ currentTs ) reMembers
2021-07-24 10:26:28 +01:00
where
2022-06-18 20:06:13 +01:00
insertIntro_ :: UTCTime -> GroupMember -> IO GroupMemberIntro
insertIntro_ ts reMember = do
2021-07-24 10:26:28 +01:00
DB . execute
db
[ sql |
INSERT INTO group_member_intros
2022-02-02 20:25:36 +04:00
( re_group_member_id , to_group_member_id , intro_status , created_at , updated_at )
VALUES ( ? , ? , ? , ? , ? )
2021-07-24 10:26:28 +01:00
| ]
2022-07-15 17:49:29 +04:00
( groupMemberId' reMember , groupMemberId' toMember , GMIntroPending , ts , ts )
2021-07-24 10:26:28 +01:00
introId <- insertedRowId db
pure GroupMemberIntro { introId , reMember , toMember , introStatus = GMIntroPending , introInvitation = Nothing }
2022-06-18 20:06:13 +01:00
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 ]
2021-07-24 10:26:28 +01:00
2022-06-18 20:06:13 +01:00
saveIntroInvitation :: DB . Connection -> GroupMember -> GroupMember -> IntroInvitation -> ExceptT StoreError IO GroupMemberIntro
saveIntroInvitation db reMember toMember introInv = do
intro <- getIntroduction_ db reMember toMember
liftIO $ do
2022-02-02 20:25:36 +04:00
currentTs <- getCurrentTime
2021-07-24 10:26:28 +01:00
DB . executeNamed
db
[ sql |
2022-06-18 20:06:13 +01:00
UPDATE group_member_intros
SET intro_status = : intro_status ,
2021-07-24 10:26:28 +01:00
group_queue_info = : group_queue_info ,
2022-02-02 20:25:36 +04:00
direct_queue_info = : direct_queue_info ,
updated_at = : updated_at
2022-06-18 20:06:13 +01:00
WHERE group_member_intro_id = : intro_id
2021-07-24 10:26:28 +01:00
| ]
2022-06-18 20:06:13 +01:00
[ " :intro_status " := GMIntroInvReceived ,
2022-09-14 19:45:21 +04:00
" :group_queue_info " := groupConnReq ( introInv :: IntroInvitation ) ,
2022-06-18 20:06:13 +01:00
" :direct_queue_info " := directConnReq introInv ,
2022-02-02 20:25:36 +04:00
" :updated_at " := currentTs ,
2022-06-18 20:06:13 +01:00
" :intro_id " := introId intro
2021-07-24 10:26:28 +01:00
]
2022-06-18 20:06:13 +01:00
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
]
2021-07-24 10:26:28 +01:00
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 = ?
| ]
2022-07-15 17:49:29 +04:00
( groupMemberId' reMember , groupMemberId' toMember )
2021-07-24 10:26:28 +01:00
where
2021-12-08 13:09:51 +00:00
toIntro :: [ ( Int64 , Maybe ConnReqInvitation , Maybe ConnReqInvitation , GroupMemberIntroStatus ) ] -> Either StoreError GroupMemberIntro
2021-12-02 11:17:09 +00:00
toIntro [ ( introId , groupConnReq , directConnReq , introStatus ) ] =
let introInvitation = IntroInvitation <$> groupConnReq <*> directConnReq
2021-07-24 10:26:28 +01:00
in Right GroupMemberIntro { introId , reMember , toMember , introStatus , introInvitation }
toIntro _ = Left SEIntroNotFound
2022-09-14 19:45:21 +04:00
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
2022-06-18 20:06:13 +01:00
let cLevel = 1 + maybe 0 ( connLevel :: Connection -> Int ) activeConn
currentTs <- liftIO getCurrentTime
2022-08-18 11:35:31 +04:00
Connection { connId = directConnId } <- liftIO $ createConnection_ db userId ConnContact Nothing directAgentConnId memberContactId Nothing customUserProfileId cLevel currentTs
2022-09-14 19:45:21 +04:00
liftIO $ setCommandConnId db user directCmdId directConnId
2022-09-27 20:45:46 +01:00
( localDisplayName , contactId , memProfileId ) <- createContact_ db userId directConnId memberProfile " " ( Just groupId ) currentTs
2022-06-18 20:06:13 +01:00
liftIO $ do
let newMember =
NewGroupMember
{ memInfo ,
memCategory = GCPreMember ,
memStatus = GSMemIntroduced ,
memInvitedBy = IBUnknown ,
localDisplayName ,
memContactId = Just contactId ,
memProfileId
}
member <- createNewMember_ db user gInfo newMember currentTs
2022-09-14 19:45:21 +04:00
conn @ Connection { connId = groupConnId } <- createMemberConnection_ db userId ( groupMemberId' member ) groupAgentConnId memberContactId cLevel currentTs
liftIO $ setCommandConnId db user groupCmdId groupConnId
2022-06-18 20:06:13 +01:00
pure ( member :: GroupMember ) { activeConn = Just conn }
2022-09-14 19:45:21 +04:00
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
2022-06-18 20:06:13 +01:00
let cLevel = 1 + maybe 0 ( connLevel :: Connection -> Int ) activeConn
currentTs <- getCurrentTime
2022-09-14 19:45:21 +04:00
Connection { connId = groupConnId } <- createMemberConnection_ db userId groupMemberId groupAgentConnId viaContactId cLevel currentTs
setCommandConnId db user groupCmdId groupConnId
2022-08-18 11:35:31 +04:00
Connection { connId = directConnId } <- createConnection_ db userId ConnContact Nothing directAgentConnId viaContactId Nothing customUserProfileId cLevel currentTs
2022-09-14 19:45:21 +04:00
setCommandConnId db user directCmdId directConnId
2022-06-18 20:06:13 +01:00
contactId <- createMemberContact_ directConnId currentTs
updateMember_ contactId currentTs
2021-07-24 10:26:28 +01:00
where
2022-06-18 20:06:13 +01:00
createMemberContact_ :: Int64 -> UTCTime -> IO Int64
createMemberContact_ connId ts = do
2022-02-02 20:25:36 +04:00
DB . execute
2021-07-24 10:26:28 +01:00
db
[ sql |
2022-02-02 20:25:36 +04:00
INSERT INTO contacts ( contact_profile_id , via_group , local_display_name , user_id , created_at , updated_at )
SELECT contact_profile_id , group_id , ? , ? , ? , ?
2021-07-24 10:26:28 +01:00
FROM group_members
2022-02-02 20:25:36 +04:00
WHERE group_member_id = ?
2021-07-24 10:26:28 +01:00
| ]
2022-02-02 20:25:36 +04:00
( localDisplayName , userId , ts , ts , groupMemberId )
2021-07-24 10:26:28 +01:00
contactId <- insertedRowId db
2022-02-02 20:25:36 +04:00
DB . execute db " UPDATE connections SET contact_id = ?, updated_at = ? WHERE connection_id = ? " ( contactId , ts , connId )
2021-07-24 10:26:28 +01:00
pure contactId
2022-06-18 20:06:13 +01:00
updateMember_ :: Int64 -> UTCTime -> IO ()
updateMember_ contactId ts =
2021-07-24 10:26:28 +01:00
DB . executeNamed
db
[ sql |
UPDATE group_members
2022-02-02 20:25:36 +04:00
SET contact_id = : contact_id , updated_at = : updated_at
2021-07-24 10:26:28 +01:00
WHERE group_member_id = : group_member_id
| ]
2022-02-02 20:25:36 +04:00
[ " :contact_id " := contactId , " :updated_at " := ts , " :group_member_id " := groupMemberId ]
2021-07-16 07:40:55 +01:00
2022-02-02 20:25:36 +04:00
createMemberConnection_ :: DB . Connection -> UserId -> Int64 -> ConnId -> Maybe Int64 -> Int -> UTCTime -> IO Connection
2022-08-18 11:35:31 +04:00
createMemberConnection_ db userId groupMemberId agentConnId viaContact = createConnection_ db userId ConnMember ( Just groupMemberId ) agentConnId viaContact Nothing Nothing
2021-07-12 19:00:03 +01:00
2022-06-18 20:06:13 +01:00
getViaGroupMember :: DB . Connection -> User -> Contact -> IO ( Maybe ( GroupInfo , GroupMember ) )
getViaGroupMember db User { userId , userContactId } Contact { contactId } =
maybeFirstRow toGroupAndMember $
DB . query
db
[ sql |
SELECT
-- GroupInfo
2022-11-01 17:32:49 +03:00
g . group_id , g . local_display_name , gp . display_name , gp . full_name , gp . image , g . host_conn_custom_user_profile_id , g . enable_ntfs , gp . preferences , g . created_at , g . updated_at ,
2022-06-18 20:06:13 +01:00
-- GroupInfo {membership}
mu . group_member_id , mu . group_id , mu . member_id , mu . member_role , mu . member_category ,
2022-08-18 11:35:31 +04:00
mu . member_status , mu . invited_by , mu . local_display_name , mu . contact_id , mu . contact_profile_id , pu . contact_profile_id ,
2022-06-18 20:06:13 +01:00
-- GroupInfo {membership = GroupMember {memberProfile}}
2022-11-01 17:32:49 +03:00
pu . display_name , pu . full_name , pu . image , pu . local_alias , pu . preferences ,
2022-06-18 20:06:13 +01:00
-- via GroupMember
m . group_member_id , m . group_id , m . member_id , m . member_role , m . member_category , m . member_status ,
2022-11-01 17:32:49 +03:00
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 . local_alias , p . preferences ,
2022-10-24 14:28:58 +04:00
c . connection_id , c . agent_conn_id , c . conn_level , c . via_contact , c . via_user_contact_link , c . via_group_link , c . custom_user_profile_id ,
2022-09-27 20:45:46 +01:00
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
2022-06-18 20:06:13 +01:00
FROM group_members m
JOIN contacts ct ON ct . contact_id = m . contact_id
2022-08-18 11:35:31 +04:00
JOIN contact_profiles p ON p . contact_profile_id = COALESCE ( m . member_profile_id , m . contact_profile_id )
2022-06-18 20:06:13 +01:00
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
2022-08-18 11:35:31 +04:00
JOIN contact_profiles pu ON pu . contact_profile_id = COALESCE ( mu . member_profile_id , mu . contact_profile_id )
2022-06-18 20:06:13 +01:00
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 )
2021-07-24 10:26:28 +01:00
where
2022-06-18 20:06:13 +01:00
toGroupAndMember :: ( GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow ) -> ( GroupInfo , GroupMember )
toGroupAndMember ( groupInfoRow :. memberRow :. connRow ) =
2022-01-31 22:43:39 +04:00
let groupInfo = toGroupInfo userContactId groupInfoRow
member = toGroupMember userContactId memberRow
2022-06-18 20:06:13 +01:00
in ( groupInfo , ( member :: GroupMember ) { activeConn = toMaybeConnection connRow } )
2021-07-24 10:26:28 +01:00
2022-06-18 20:06:13 +01:00
getViaGroupContact :: DB . Connection -> User -> GroupMember -> IO ( Maybe Contact )
getViaGroupContact db User { userId } GroupMember { groupMemberId } =
maybeFirstRow toContact' $
DB . query
db
[ sql |
SELECT
2022-11-01 17:32:49 +03:00
ct . contact_id , ct . contact_profile_id , ct . local_display_name , p . display_name , p . full_name , p . image , p . local_alias , ct . via_group , ct . contact_used , ct . enable_ntfs , p . preferences , ct . user_preferences , ct . created_at , ct . updated_at ,
2022-10-24 14:28:58 +04:00
c . connection_id , c . agent_conn_id , c . conn_level , c . via_contact , c . via_user_contact_link , c . via_group_link , c . custom_user_profile_id ,
2022-09-27 20:45:46 +01:00
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
2022-06-18 20:06:13 +01:00
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 )
2021-07-24 10:26:28 +01:00
where
2022-11-01 17:32:49 +03:00
toContact' :: ( ( ContactId , ProfileId , ContactName , Text , Text , Maybe ImageData , LocalAlias , Maybe Int64 , Bool , Maybe Bool ) :. ( Maybe ChatPreferences , ChatPreferences , UTCTime , UTCTime ) ) :. ConnectionRow -> Contact
toContact' ( ( ( contactId , profileId , localDisplayName , displayName , fullName , image , localAlias , viaGroup , contactUsed , enableNtfs_ ) :. ( preferences , userPreferences , createdAt , updatedAt ) ) :. connRow ) =
let profile = LocalProfile { profileId , displayName , fullName , image , preferences , localAlias }
2022-08-19 15:17:05 +01:00
chatSettings = ChatSettings { enableNtfs = fromMaybe True enableNtfs_ }
2021-07-24 10:26:28 +01:00
activeConn = toConnection connRow
2022-11-01 17:32:49 +03:00
in Contact { contactId , localDisplayName , profile , activeConn , viaGroup , contactUsed , chatSettings , userPreferences , createdAt , updatedAt }
2021-09-04 07:32:56 +01:00
2022-10-14 13:06:33 +01:00
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
2022-06-18 20:06:13 +01:00
currentTs <- getCurrentTime
DB . execute
db
2022-10-14 13:06:33 +01:00
" INSERT INTO files (user_id, contact_id, file_name, file_path, file_size, chunk_size, file_inline, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?) "
( userId , contactId , fileName , filePath , fileSize , chunkSize , fileInline , CIFSSndStored , currentTs , currentTs )
2022-06-18 20:06:13 +01:00
fileId <- insertedRowId db
2022-10-14 13:06:33 +01:00
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 , fileName , filePath , fileSize , fileInline , chunkSize , cancelled = False }
2022-09-20 14:46:30 +01:00
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 )
2022-10-14 13:06:33 +01:00
createSndGroupFileTransfer :: DB . Connection -> UserId -> GroupInfo -> FilePath -> FileInvitation -> Integer -> IO FileTransferMeta
createSndGroupFileTransfer db userId GroupInfo { groupId } filePath FileInvitation { fileName , fileSize , fileInline } chunkSize = do
2022-06-18 20:06:13 +01:00
currentTs <- getCurrentTime
DB . execute
db
2022-10-14 13:06:33 +01:00
" INSERT INTO files (user_id, group_id, file_name, file_path, file_size, chunk_size, file_inline, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?) "
( userId , groupId , fileName , filePath , fileSize , chunkSize , fileInline , CIFSSndStored , currentTs , currentTs )
fileId <- insertedRowId db
pure FileTransferMeta { fileId , fileName , filePath , fileSize , fileInline , chunkSize , cancelled = False }
2022-04-05 10:01:08 +04:00
2022-09-14 19:45:21 +04:00
createSndGroupFileTransferConnection :: DB . Connection -> User -> Int64 -> ( CommandId , ConnId ) -> GroupMember -> IO ()
createSndGroupFileTransferConnection db user @ User { userId } fileId ( cmdId , acId ) GroupMember { groupMemberId } = do
2022-06-18 20:06:13 +01:00
currentTs <- getCurrentTime
Connection { connId } <- createSndFileConnection_ db userId fileId acId
2022-09-14 19:45:21 +04:00
setCommandConnId db user cmdId connId
2022-06-18 20:06:13 +01:00
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 )
2022-04-05 10:01:08 +04:00
2022-10-14 13:06:33 +01:00
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
2022-10-21 19:14:12 +03:00
fileInline' = Just $ fromMaybe IFMOffer fileInline
2022-10-14 13:06:33 +01:00
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 , fileStatus , 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
2022-10-21 19:14:12 +03:00
fileInline' = Just $ fromMaybe IFMOffer fileInline
2022-10-14 13:06:33 +01:00
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 , fileStatus , 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 )
getSndInlineFTViaMsgDelivery :: DB . Connection -> User -> Connection -> AgentMsgId -> IO ( Maybe SndFileTransfer )
getSndInlineFTViaMsgDelivery 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_inline , 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_inline IS NOT NULL
| ]
( connId , agentMsgId , userId )
where
sndFileTransfer_ :: ( Int64 , FileStatus , String , Integer , Integer , FilePath , Maybe InlineFileMode , Maybe ContactName , Maybe ContactName ) -> Maybe SndFileTransfer
sndFileTransfer_ ( fileId , fileStatus , fileName , fileSize , chunkSize , filePath , fileInline , contactName_ , memberName_ ) =
( \ n -> SndFileTransfer { fileId , fileStatus , fileName , fileSize , chunkSize , filePath , fileInline , recipientDisplayName = n , connId , agentConnId } )
<$> ( contactName_ <|> memberName_ )
2022-06-18 20:06:13 +01:00
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 )
2022-05-05 13:50:19 +01:00
2022-06-18 20:06:13 +01:00
updateCIFileStatus :: MsgDirectionI d => DB . Connection -> User -> Int64 -> CIFileStatus d -> IO ()
updateCIFileStatus db User { userId } fileId ciFileStatus = do
2022-05-05 13:50:19 +01:00
currentTs <- getCurrentTime
DB . execute db " UPDATE files SET ci_file_status = ?, updated_at = ? WHERE user_id = ? AND file_id = ? " ( ciFileStatus , currentTs , userId , fileId )
2022-04-10 13:30:58 +04:00
2022-06-18 20:06:13 +01:00
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 )
2022-04-05 10:01:08 +04:00
2022-06-18 20:06:13 +01:00
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 )
2022-04-05 10:01:08 +04:00
2022-06-18 20:06:13 +01:00
getGroupFileIdBySharedMsgId :: DB . Connection -> UserId -> Int64 -> SharedMsgId -> ExceptT StoreError IO Int64
getGroupFileIdBySharedMsgId db userId groupId sharedMsgId =
ExceptT . firstRow fromOnly ( SEFileIdNotFoundBySharedMsgId sharedMsgId ) $
2022-05-11 16:18:28 +04:00
DB . query
db
[ sql |
2022-06-18 20:06:13 +01:00
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 = ?
2022-05-11 16:18:28 +04:00
| ]
2022-06-18 20:06:13 +01:00
( userId , groupId , sharedMsgId )
2022-09-20 14:46:30 +01:00
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 )
2022-06-18 20:06:13 +01:00
getChatRefByFileId :: DB . Connection -> User -> Int64 -> ExceptT StoreError IO ChatRef
getChatRefByFileId db User { userId } fileId =
liftIO getChatRef >>= \ case
2022-05-11 16:18:28 +04:00
[ ( Just contactId , Nothing ) ] -> pure $ ChatRef CTDirect contactId
[ ( Nothing , Just groupId ) ] -> pure $ ChatRef CTGroup groupId
_ -> throwError $ SEInternalError " could not retrieve chat ref by file id "
2022-06-18 20:06:13 +01:00
where
getChatRef =
DB . query
db
[ sql |
SELECT contact_id , group_id
FROM files
WHERE user_id = ? AND file_id = ?
LIMIT 1
| ]
( userId , fileId )
2022-05-11 16:18:28 +04:00
2021-09-04 07:32:56 +01:00
createSndFileConnection_ :: DB . Connection -> UserId -> Int64 -> ConnId -> IO Connection
2022-02-02 20:25:36 +04:00
createSndFileConnection_ db userId fileId agentConnId = do
currentTs <- getCurrentTime
2022-08-18 11:35:31 +04:00
createConnection_ db userId ConnSndFile ( Just fileId ) agentConnId Nothing Nothing Nothing 0 currentTs
2021-09-04 07:32:56 +01:00
2022-06-18 20:06:13 +01:00
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
2021-09-04 07:32:56 +01:00
where
2022-06-18 20:06:13 +01:00
getLastChunkNo = do
2021-09-04 07:32:56 +01:00
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 )
2022-08-18 11:35:31 +04:00
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 )
2021-09-04 07:32:56 +01:00
2022-06-18 20:06:13 +01:00
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 )
2021-09-04 07:32:56 +01:00
2022-06-18 20:06:13 +01:00
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 )
2021-09-04 07:32:56 +01:00
2022-06-18 20:06:13 +01:00
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 )
2021-09-05 14:08:29 +01:00
2022-10-14 13:06:33 +01:00
createRcvFileTransfer :: DB . Connection -> UserId -> Contact -> FileInvitation -> Maybe InlineFileMode -> Integer -> IO RcvFileTransfer
createRcvFileTransfer db userId Contact { contactId , localDisplayName = c } f @ FileInvitation { fileName , fileSize , fileConnReq , fileInline } rcvFileInline chunkSize = do
2022-06-18 20:06:13 +01:00
currentTs <- getCurrentTime
DB . execute
db
2022-10-14 13:06:33 +01:00
" INSERT INTO files (user_id, contact_id, file_name, file_size, chunk_size, file_inline, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?) "
( userId , contactId , fileName , fileSize , chunkSize , fileInline , CIFSRcvInvitation , currentTs , currentTs )
2022-06-18 20:06:13 +01:00
fileId <- insertedRowId db
DB . execute
db
2022-10-14 13:06:33 +01:00
" INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, created_at, updated_at) VALUES (?,?,?,?,?,?,?) "
( fileId , FSNew , fileConnReq , fileInline , rcvFileInline , currentTs , currentTs )
pure RcvFileTransfer { fileId , fileInvitation = f , fileStatus = RFSNew , rcvFileInline , senderDisplayName = c , chunkSize , cancelled = False , grpMemberId = Nothing }
2021-09-05 14:08:29 +01:00
2022-10-14 13:06:33 +01:00
createRcvGroupFileTransfer :: DB . Connection -> UserId -> GroupMember -> FileInvitation -> Maybe InlineFileMode -> Integer -> IO RcvFileTransfer
createRcvGroupFileTransfer db userId GroupMember { groupId , groupMemberId , localDisplayName = c } f @ FileInvitation { fileName , fileSize , fileConnReq , fileInline } rcvFileInline chunkSize = do
2022-06-18 20:06:13 +01:00
currentTs <- getCurrentTime
DB . execute
db
2022-10-14 13:06:33 +01:00
" INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size, file_inline, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?) "
( userId , groupId , fileName , fileSize , chunkSize , fileInline , CIFSRcvInvitation , currentTs , currentTs )
2022-06-18 20:06:13 +01:00
fileId <- insertedRowId db
DB . execute
db
2022-10-14 13:06:33 +01:00
" INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?) "
( fileId , FSNew , fileConnReq , fileInline , rcvFileInline , groupMemberId , currentTs , currentTs )
pure RcvFileTransfer { fileId , fileInvitation = f , fileStatus = RFSNew , rcvFileInline , senderDisplayName = c , chunkSize , cancelled = False , grpMemberId = Just groupMemberId }
2022-06-18 20:06:13 +01:00
getRcvFileTransfer :: DB . Connection -> User -> Int64 -> ExceptT StoreError IO RcvFileTransfer
2022-10-14 13:06:33 +01:00
getRcvFileTransfer db user @ User { userId } fileId = do
rftRow <-
ExceptT . firstRow id ( SERcvFileNotFound fileId ) $
DB . query
db
[ sql |
2022-04-05 10:01:08 +04:00
SELECT r . file_status , r . file_queue_info , r . group_member_id , f . file_name ,
2022-10-14 13:06:33 +01:00
f . file_size , f . chunk_size , f . cancelled , cs . contact_id , cs . local_display_name , m . group_id , m . group_member_id , m . local_display_name ,
f . file_path , r . file_inline , r . rcv_file_inline , c . connection_id , c . agent_conn_id
2021-09-04 07:32:56 +01:00
FROM rcv_files r
JOIN files f USING ( file_id )
LEFT JOIN connections c ON r . file_id = c . rcv_file_id
2021-09-05 14:08:29 +01:00
LEFT JOIN contacts cs USING ( contact_id )
LEFT JOIN group_members m USING ( group_member_id )
2021-09-04 07:32:56 +01:00
WHERE f . user_id = ? AND f . file_id = ?
| ]
2022-10-14 13:06:33 +01:00
( userId , fileId )
rcvFileTransfer rftRow
2021-09-04 07:32:56 +01:00
where
rcvFileTransfer ::
2022-10-14 13:06:33 +01:00
( FileStatus , Maybe ConnReqInvitation , Maybe Int64 , String , Integer , Integer , Maybe Bool ) :. ( Maybe Int64 , Maybe ContactName , Maybe Int64 , Maybe Int64 , Maybe ContactName , Maybe FilePath , Maybe InlineFileMode , Maybe InlineFileMode ) :. ( Maybe Int64 , Maybe AgentConnId ) ->
ExceptT StoreError IO RcvFileTransfer
rcvFileTransfer ( ( fileStatus' , fileConnReq , grpMemberId , fileName , fileSize , chunkSize , cancelled_ ) :. ( contactId_ , contactName_ , groupId_ , groupMemberId_ , memberName_ , filePath_ , fileInline , rcvFileInline ) :. ( connId_ , agentConnId_ ) ) = do
let fileInv = FileInvitation { fileName , fileSize , fileConnReq , fileInline }
fileInfo = ( filePath_ , connId_ , agentConnId_ , contactId_ , groupId_ , groupMemberId_ , isJust fileInline )
case contactName_ <|> memberName_ of
Nothing -> throwError $ SERcvFileInvalid fileId
Just name -> do
case fileStatus' of
FSNew -> pure $ ft name fileInv RFSNew
FSAccepted -> ft name fileInv . RFSAccepted <$> rfi fileInfo
FSConnected -> ft name fileInv . RFSConnected <$> rfi fileInfo
FSComplete -> ft name fileInv . RFSComplete <$> rfi fileInfo
FSCancelled -> ft name fileInv . RFSCancelled <$> rfi_ fileInfo
2021-09-04 07:32:56 +01:00
where
2022-05-11 16:18:28 +04:00
ft senderDisplayName fileInvitation fileStatus =
2022-10-14 13:06:33 +01:00
RcvFileTransfer { fileId , fileInvitation , fileStatus , rcvFileInline , senderDisplayName , chunkSize , cancelled , grpMemberId }
rfi fileInfo = maybe ( throwError $ SERcvFileInvalid fileId ) pure =<< rfi_ fileInfo
2022-05-11 16:18:28 +04:00
rfi_ = \ case
2022-10-14 13:06:33 +01:00
( Just filePath , Just connId , Just agentConnId , _ , _ , _ , _ ) -> pure $ Just RcvFileInfo { filePath , connId , agentConnId }
( Just filePath , Nothing , Nothing , Just contactId , _ , _ , True ) -> do
Contact { activeConn = Connection { connId , agentConnId } } <- getContact db userId contactId
pure $ Just RcvFileInfo { filePath , connId , agentConnId }
( Just filePath , Nothing , Nothing , _ , Just groupId , Just groupMemberId , True ) -> do
getGroupMember db user groupId groupMemberId >>= \ case
GroupMember { activeConn = Just Connection { connId , agentConnId } } ->
pure $ Just RcvFileInfo { filePath , connId , agentConnId }
_ -> pure Nothing
_ -> pure Nothing
2022-04-05 10:01:08 +04:00
cancelled = fromMaybe False cancelled_
2021-09-04 07:32:56 +01:00
2022-06-18 20:06:13 +01:00
acceptRcvFileTransfer :: DB . Connection -> User -> Int64 -> ConnId -> ConnStatus -> FilePath -> ExceptT StoreError IO AChatItem
acceptRcvFileTransfer db user @ User { userId } fileId agentConnId connStatus filePath = ExceptT $ do
currentTs <- getCurrentTime
2022-10-14 13:06:33 +01:00
acceptRcvFT_ db user fileId filePath currentTs
DB . execute
db
" INSERT INTO connections (agent_conn_id, conn_status, conn_type, rcv_file_id, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?) "
( agentConnId , connStatus , ConnRcvFile , fileId , userId , currentTs , currentTs )
runExceptT $ getChatItemByFileId db user fileId
acceptRcvInlineFT :: DB . Connection -> User -> Int64 -> FilePath -> ExceptT StoreError IO AChatItem
acceptRcvInlineFT db user fileId filePath = do
liftIO $ acceptRcvFT_ db user fileId filePath =<< getCurrentTime
getChatItemByFileId db user fileId
startRcvInlineFT :: DB . Connection -> User -> RcvFileTransfer -> FilePath -> IO ()
startRcvInlineFT db user RcvFileTransfer { fileId } filePath =
acceptRcvFT_ db user fileId filePath =<< getCurrentTime
acceptRcvFT_ :: DB . Connection -> User -> Int64 -> FilePath -> UTCTime -> IO ()
acceptRcvFT_ db User { userId } fileId filePath currentTs = do
2022-06-18 20:06:13 +01:00
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 file_status = ?, updated_at = ? WHERE file_id = ? "
( FSAccepted , currentTs , fileId )
updateRcvFileStatus :: DB . Connection -> RcvFileTransfer -> FileStatus -> IO ()
updateRcvFileStatus db RcvFileTransfer { 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
2022-02-02 20:25:36 +04:00
currentTs <- getCurrentTime
DB . execute
db
2022-06-18 20:06:13 +01:00
" 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
2021-09-04 07:32:56 +01:00
where
2022-06-18 20:06:13 +01:00
getLastChunkNo = do
2021-09-04 07:32:56 +01:00
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
2021-09-25 10:09:49 +01:00
[]
| chunkNo == 1 ->
2022-10-18 13:16:28 +04:00
if chunkSize >= fileSize
then RcvChunkFinal
else RcvChunkOk
2021-09-25 10:09:49 +01:00
| otherwise -> RcvChunkError
2021-09-04 07:32:56 +01:00
n : _
| chunkNo == n -> RcvChunkDuplicate
| chunkNo == n + 1 ->
2022-10-18 13:16:28 +04:00
let prevSize = n * chunkSize
in if prevSize >= fileSize
then RcvChunkError
else
if prevSize + chunkSize >= fileSize
then RcvChunkFinal
else RcvChunkOk
2021-09-04 07:32:56 +01:00
| otherwise -> RcvChunkError
2022-06-18 20:06:13 +01:00
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 )
2022-01-26 16:18:27 +04:00
2022-06-18 20:06:13 +01:00
deleteRcvFileChunks :: DB . Connection -> RcvFileTransfer -> IO ()
deleteRcvFileChunks db RcvFileTransfer { fileId } =
DB . execute db " DELETE FROM rcv_file_chunks WHERE file_id = ? " ( Only fileId )
2021-09-04 07:32:56 +01:00
2022-06-18 20:06:13 +01:00
updateFileTransferChatItemId :: DB . Connection -> FileTransferId -> ChatItemId -> IO ()
updateFileTransferChatItemId db fileId ciId = do
currentTs <- getCurrentTime
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
2021-09-04 07:32:56 +01:00
where
2022-06-18 20:06:13 +01:00
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
2022-05-11 16:18:28 +04:00
pure $ FTSnd { fileTransferMeta = ftm , sndFileTransfers = fts }
2022-06-18 20:06:13 +01:00
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 )
2022-05-11 16:18:28 +04:00
2022-06-18 20:06:13 +01:00
getSndFileTransfer :: DB . Connection -> User -> Int64 -> ExceptT StoreError IO ( FileTransferMeta , [ SndFileTransfer ] )
2022-10-14 13:06:33 +01:00
getSndFileTransfer db user @ User { userId } fileId = do
fileTransferMeta <- getFileTransferMeta db user fileId
2022-05-11 16:18:28 +04:00
sndFileTransfers <- ExceptT $ getSndFileTransfers_ db userId fileId
pure ( fileTransferMeta , sndFileTransfers )
2021-09-04 07:32:56 +01:00
getSndFileTransfers_ :: DB . Connection -> UserId -> Int64 -> IO ( Either StoreError [ SndFileTransfer ] )
getSndFileTransfers_ db userId fileId =
2022-10-14 13:06:33 +01:00
mapM sndFileTransfer
2021-09-04 07:32:56 +01:00
<$> DB . query
db
[ sql |
2022-10-14 13:06:33 +01:00
SELECT s . file_status , f . file_name , f . file_size , f . chunk_size , f . file_path , s . file_inline , s . connection_id , c . agent_conn_id ,
2021-09-05 14:08:29 +01:00
cs . local_display_name , m . local_display_name
2021-09-04 07:32:56 +01:00
FROM snd_files s
JOIN files f USING ( file_id )
JOIN connections c USING ( connection_id )
2021-09-05 14:08:29 +01:00
LEFT JOIN contacts cs USING ( contact_id )
LEFT JOIN group_members m USING ( group_member_id )
2021-09-04 07:32:56 +01:00
WHERE f . user_id = ? AND f . file_id = ?
| ]
( userId , fileId )
where
2022-10-14 13:06:33 +01:00
sndFileTransfer :: ( FileStatus , String , Integer , Integer , FilePath , Maybe InlineFileMode , Int64 , AgentConnId , Maybe ContactName , Maybe ContactName ) -> Either StoreError SndFileTransfer
sndFileTransfer ( fileStatus , fileName , fileSize , chunkSize , filePath , fileInline , connId , agentConnId , contactName_ , memberName_ ) =
2021-09-05 14:08:29 +01:00
case contactName_ <|> memberName_ of
2022-10-14 13:06:33 +01:00
Just recipientDisplayName -> Right SndFileTransfer { fileId , fileStatus , fileName , fileSize , chunkSize , filePath , fileInline , recipientDisplayName , connId , agentConnId }
2021-09-05 14:08:29 +01:00
Nothing -> Left $ SESndFileInvalid fileId
2021-09-04 07:32:56 +01:00
2022-10-14 13:06:33 +01:00
getFileTransferMeta :: DB . Connection -> User -> Int64 -> ExceptT StoreError IO FileTransferMeta
getFileTransferMeta db User { userId } fileId =
ExceptT . firstRow fileTransferMeta ( SEFileNotFound fileId ) $
2022-04-05 10:01:08 +04:00
DB . query
db
[ sql |
2022-10-14 13:06:33 +01:00
SELECT f . file_name , f . file_size , f . chunk_size , f . file_path , f . file_inline , f . cancelled
2022-04-05 10:01:08 +04:00
FROM files f
WHERE f . user_id = ? AND f . file_id = ?
| ]
( userId , fileId )
where
2022-10-14 13:06:33 +01:00
fileTransferMeta :: ( String , Integer , Integer , FilePath , Maybe InlineFileMode , Maybe Bool ) -> FileTransferMeta
fileTransferMeta ( fileName , fileSize , chunkSize , filePath , fileInline , cancelled_ ) =
FileTransferMeta { fileId , fileName , fileSize , chunkSize , filePath , fileInline , cancelled = fromMaybe False cancelled_ }
2022-06-18 20:06:13 +01:00
2022-10-04 01:33:36 +04:00
getContactFileInfo :: DB . Connection -> User -> Contact -> IO [ CIFileInfo ]
getContactFileInfo db User { userId } Contact { contactId } =
2022-06-18 20:06:13 +01:00
map toFileInfo
<$> DB . query
db
[ sql |
2022-04-15 13:16:34 +01:00
SELECT f . file_id , f . ci_file_status , f . file_path
2022-04-15 09:36:38 +04:00
FROM chat_items i
JOIN files f ON f . chat_item_id = i . chat_item_id
WHERE i . user_id = ? AND i . contact_id = ?
| ]
2022-06-18 20:06:13 +01:00
( userId , contactId )
2022-05-17 11:22:09 +04:00
2022-10-05 19:54:28 +04:00
toFileInfo :: ( Int64 , Maybe ACIFileStatus , Maybe FilePath ) -> CIFileInfo
2022-05-17 11:22:09 +04:00
toFileInfo ( fileId , fileStatus , filePath ) = CIFileInfo { fileId , fileStatus , filePath }
2022-10-04 01:33:36 +04:00
getContactMaxItemTs :: DB . Connection -> User -> Contact -> IO ( Maybe UTCTime )
getContactMaxItemTs db User { userId } Contact { contactId } =
fmap join . maybeFirstRow fromOnly $
DB . query db " SELECT MAX(item_ts) FROM chat_items WHERE user_id = ? AND contact_id = ? " ( userId , contactId )
2022-05-17 11:22:09 +04:00
2022-10-04 01:33:36 +04:00
deleteContactCIs :: DB . Connection -> User -> Contact -> IO ()
2022-10-05 19:54:28 +04:00
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 )
2022-10-04 01:33:36 +04:00
DB . execute db " DELETE FROM chat_items WHERE user_id = ? AND contact_id = ? " ( userId , contactId )
2022-10-05 19:54:28 +04:00
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 )
2022-05-17 22:48:54 +04:00
2022-06-18 20:06:13 +01:00
updateContactTs :: DB . Connection -> User -> Contact -> UTCTime -> IO ()
updateContactTs db User { userId } Contact { contactId } updatedAt =
DB . execute
db
" UPDATE contacts SET updated_at = ? WHERE user_id = ? AND contact_id = ? "
( updatedAt , userId , contactId )
2022-05-19 21:57:31 +04:00
2022-10-04 01:33:36 +04:00
getGroupFileInfo :: DB . Connection -> User -> GroupInfo -> IO [ CIFileInfo ]
getGroupFileInfo db User { userId } GroupInfo { groupId } =
map toFileInfo
2022-06-18 20:06:13 +01:00
<$> DB . query
db
[ sql |
2022-10-04 01:33:36 +04:00
SELECT f . file_id , f . ci_file_status , f . file_path
2022-06-18 20:06:13 +01:00
FROM chat_items i
2022-10-04 01:33:36 +04:00
JOIN files f ON f . chat_item_id = i . chat_item_id
2022-06-18 20:06:13 +01:00
WHERE i . user_id = ? AND i . group_id = ?
| ]
( userId , groupId )
2022-05-17 11:22:09 +04:00
2022-10-04 01:33:36 +04:00
getGroupMaxItemTs :: DB . Connection -> User -> GroupInfo -> IO ( Maybe UTCTime )
getGroupMaxItemTs db User { userId } GroupInfo { groupId } =
fmap join . maybeFirstRow fromOnly $
DB . query db " SELECT MAX(item_ts) FROM chat_items WHERE user_id = ? AND group_id = ? " ( userId , groupId )
deleteGroupCIs :: DB . Connection -> User -> GroupInfo -> IO ()
deleteGroupCIs db User { userId } GroupInfo { groupId } = do
2022-10-05 19:54:28 +04:00
DB . execute db " DELETE FROM messages WHERE group_id = ? " ( Only groupId )
2022-10-04 01:33:36 +04:00
DB . execute db " DELETE FROM chat_items WHERE user_id = ? AND group_id = ? " ( userId , groupId )
2022-05-19 21:57:31 +04:00
2022-06-18 20:06:13 +01:00
updateGroupTs :: DB . Connection -> User -> GroupInfo -> UTCTime -> IO ()
updateGroupTs db User { userId } GroupInfo { groupId } updatedAt =
DB . execute
db
" UPDATE groups SET updated_at = ? WHERE user_id = ? AND group_id = ? "
( updatedAt , userId , groupId )
2022-10-14 13:06:33 +01:00
createNewSndMessage :: MsgEncodingI e => DB . Connection -> TVar ChaChaDRG -> ConnOrGroupId -> ( SharedMsgId -> NewMessage e ) -> ExceptT StoreError IO SndMessage
2022-06-18 20:06:13 +01:00
createNewSndMessage db gVar connOrGroupId mkMessage =
createWithRandomId gVar $ \ sharedMsgId -> do
let NewMessage { chatMsgEvent , msgBody } = mkMessage $ SharedMsgId sharedMsgId
createdAt <- getCurrentTime
2022-05-19 21:57:31 +04:00
DB . execute
db
2022-06-18 20:06:13 +01:00
[ 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 }
2022-03-13 19:34:03 +00:00
where
( connId_ , groupId_ ) = case connOrGroupId of
ConnectionId connId -> ( Just connId , Nothing )
GroupId groupId -> ( Nothing , Just groupId )
2021-12-29 23:11:55 +04:00
2022-10-14 13:06:33 +01:00
createSndMsgDelivery :: DB . Connection -> SndMsgDelivery -> MessageId -> IO Int64
2022-06-18 20:06:13 +01:00
createSndMsgDelivery db sndMsgDelivery messageId = do
currentTs <- getCurrentTime
msgDeliveryId <- createSndMsgDelivery_ db sndMsgDelivery messageId currentTs
createMsgDeliveryEvent_ db msgDeliveryId MDSSndAgent currentTs
2022-10-14 13:06:33 +01:00
pure msgDeliveryId
2021-12-29 23:11:55 +04:00
2022-10-14 13:06:33 +01:00
createNewMessageAndRcvMsgDelivery :: forall e . MsgEncodingI e => DB . Connection -> ConnOrGroupId -> NewMessage e -> Maybe SharedMsgId -> RcvMsgDelivery -> IO RcvMessage
2022-09-14 19:45:21 +04:00
createNewMessageAndRcvMsgDelivery db connOrGroupId NewMessage { chatMsgEvent , msgBody } sharedMsgId_ RcvMsgDelivery { connId , agentMsgId , agentMsgMeta , agentAckCmdId } = do
2022-06-18 20:06:13 +01:00
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
2022-09-14 19:45:21 +04:00
" 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 )
2022-06-18 20:06:13 +01:00
msgDeliveryId <- insertedRowId db
createMsgDeliveryEvent_ db msgDeliveryId MDSRcvAgent currentTs
2022-10-14 13:06:33 +01:00
pure RcvMessage { msgId , chatMsgEvent = ACME ( encoding @ e ) chatMsgEvent , sharedMsgId_ , msgBody }
2022-03-13 19:34:03 +00:00
where
( connId_ , groupId_ ) = case connOrGroupId of
ConnectionId connId' -> ( Just connId' , Nothing )
GroupId groupId -> ( Nothing , Just groupId )
2021-12-29 23:11:55 +04:00
2022-06-18 20:06:13 +01:00
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
2021-12-29 23:11:55 +04:00
2022-09-14 19:45:21 +04:00
createRcvMsgDeliveryEvent :: DB . Connection -> Int64 -> CommandId -> MsgDeliveryStatus 'MDRcv -> IO ()
createRcvMsgDeliveryEvent db connId cmdId rcvMsgDeliveryStatus = do
msgDeliveryId <- getMsgDeliveryIdByCmdId_ db connId cmdId
forM_ msgDeliveryId $ \ mdId -> do
2022-06-18 20:06:13 +01:00
currentTs <- getCurrentTime
2022-09-14 19:45:21 +04:00
createMsgDeliveryEvent_ db mdId rcvMsgDeliveryStatus currentTs
2021-12-29 23:11:55 +04:00
2022-02-02 20:25:36 +04:00
createSndMsgDelivery_ :: DB . Connection -> SndMsgDelivery -> MessageId -> UTCTime -> IO Int64
createSndMsgDelivery_ db SndMsgDelivery { connId , agentMsgId } messageId createdAt = do
2021-12-29 23:11:55 +04:00
DB . execute
db
[ sql |
INSERT INTO msg_deliveries
2022-02-02 20:25:36 +04:00
( message_id , connection_id , agent_msg_id , agent_msg_meta , chat_ts , created_at , updated_at )
VALUES ( ? , ? , ? , NULL , ? , ? , ? )
2021-12-29 23:11:55 +04:00
| ]
2022-02-02 20:25:36 +04:00
( messageId , connId , agentMsgId , createdAt , createdAt , createdAt )
2021-12-29 23:11:55 +04:00
insertedRowId db
2022-02-02 20:25:36 +04:00
createMsgDeliveryEvent_ :: DB . Connection -> Int64 -> MsgDeliveryStatus d -> UTCTime -> IO ()
createMsgDeliveryEvent_ db msgDeliveryId msgDeliveryStatus createdAt = do
2021-12-29 23:11:55 +04:00
DB . execute
db
[ sql |
INSERT INTO msg_delivery_events
2022-02-02 20:25:36 +04:00
( msg_delivery_id , delivery_status , created_at , updated_at )
VALUES ( ? , ? , ? , ? )
2021-12-29 23:11:55 +04:00
| ]
2022-02-02 20:25:36 +04:00
( msgDeliveryId , msgDeliveryStatus , createdAt , createdAt )
2021-12-29 23:11:55 +04:00
2022-06-18 20:06:13 +01:00
getMsgDeliveryId_ :: DB . Connection -> Int64 -> AgentMsgId -> ExceptT StoreError IO Int64
2021-12-29 23:11:55 +04:00
getMsgDeliveryId_ db connId agentMsgId =
2022-06-18 20:06:13 +01:00
ExceptT . firstRow fromOnly ( SENoMsgDelivery connId agentMsgId ) $
2022-02-07 15:19:34 +04:00
DB . query
2021-12-29 23:11:55 +04:00
db
[ sql |
SELECT msg_delivery_id
FROM msg_deliveries m
2022-01-29 16:06:08 +04:00
WHERE m . connection_id = ? AND m . agent_msg_id = ?
2022-02-02 20:25:36 +04:00
LIMIT 1
2021-12-29 23:11:55 +04:00
| ]
( connId , agentMsgId )
2022-09-14 19:45:21 +04:00
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 )
2022-06-18 20:06:13 +01:00
createPendingGroupMessage :: DB . Connection -> Int64 -> MessageId -> Maybe Int64 -> IO ()
createPendingGroupMessage db groupMemberId messageId introId_ = do
currentTs <- getCurrentTime
DB . execute
db
[ sql |
INSERT INTO pending_group_messages
( group_member_id , message_id , group_member_intro_id , created_at , updated_at ) VALUES ( ? , ? , ? , ? , ? )
| ]
( groupMemberId , messageId , introId_ , currentTs , currentTs )
getPendingGroupMessages :: DB . Connection -> Int64 -> IO [ PendingGroupMessage ]
getPendingGroupMessages db groupMemberId =
map pendingGroupMessage
<$> DB . query
2022-01-24 16:07:17 +00:00
db
[ sql |
2022-06-18 20:06:13 +01:00
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
2022-01-24 16:07:17 +00:00
| ]
2022-06-18 20:06:13 +01:00
( Only groupMemberId )
2022-01-24 16:07:17 +00:00
where
pendingGroupMessage ( msgId , cmEventTag , msgBody , introId_ ) =
PendingGroupMessage { msgId , cmEventTag , msgBody , introId_ }
2022-06-18 20:06:13 +01:00
deletePendingGroupMessage :: DB . Connection -> Int64 -> MessageId -> IO ()
deletePendingGroupMessage db groupMemberId messageId =
DB . execute db " DELETE FROM pending_group_messages WHERE group_member_id = ? AND message_id = ? " ( groupMemberId , messageId )
2022-01-24 16:07:17 +00:00
2022-03-16 13:20:47 +00:00
type NewQuoteRow = ( Maybe SharedMsgId , Maybe UTCTime , Maybe MsgContent , Maybe Bool , Maybe MemberId )
2022-06-18 20:06:13 +01:00
createNewSndChatItem :: DB . Connection -> User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe ( CIQuote c ) -> UTCTime -> IO ChatItemId
createNewSndChatItem db user chatDirection SndMessage { msgId , sharedMsgId } ciContent quotedItem createdAt =
createNewChatItem_ db user chatDirection createdByMsgId ( Just sharedMsgId ) ciContent quoteRow createdAt createdAt
2022-03-16 13:20:47 +00:00
where
createdByMsgId = if msgId == 0 then Nothing else Just msgId
quoteRow :: NewQuoteRow
quoteRow = case quotedItem of
Nothing -> ( Nothing , Nothing , Nothing , Nothing , Nothing )
2022-03-23 11:37:51 +00:00
Just CIQuote { chatDir , sharedMsgId = quotedSharedMsgId , sentAt , content } ->
2022-03-16 13:20:47 +00:00
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 )
2022-06-18 20:06:13 +01:00
createNewRcvChatItem :: DB . Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> UTCTime -> UTCTime -> IO ( ChatItemId , Maybe ( CIQuote c ) )
createNewRcvChatItem db user chatDirection RcvMessage { msgId , chatMsgEvent } sharedMsgId_ ciContent itemTs createdAt = do
ciId <- createNewChatItem_ db user chatDirection ( Just msgId ) sharedMsgId_ ciContent quoteRow itemTs createdAt
quotedItem <- mapM ( getChatItemQuote_ db user chatDirection ) quotedMsg
pure ( ciId , quotedItem )
2022-01-26 16:18:27 +04:00
where
2022-03-16 13:20:47 +00:00
quotedMsg = cmToQuotedMsg chatMsgEvent
quoteRow :: NewQuoteRow
quoteRow = case quotedMsg of
Nothing -> ( Nothing , Nothing , Nothing , Nothing , Nothing )
Just QuotedMsg { msgRef = MsgRef { msgId = sharedMsgId , sentAt , sent , memberId } , content } ->
uncurry ( sharedMsgId , Just sentAt , Just content , , ) $ case chatDirection of
CDDirectRcv _ -> ( Just $ not sent , Nothing )
CDGroupRcv GroupInfo { membership = GroupMember { memberId = userMemberId } } _ ->
( Just $ Just userMemberId == memberId , memberId )
2022-06-18 20:06:13 +01:00
createNewChatItemNoMsg :: forall c d . MsgDirectionI d => DB . Connection -> User -> ChatDirection c d -> CIContent d -> UTCTime -> UTCTime -> IO ChatItemId
2022-09-29 16:26:43 +01:00
createNewChatItemNoMsg db user chatDirection ciContent =
createNewChatItem_ db user chatDirection Nothing Nothing ciContent quoteRow
2022-05-28 19:13:07 +01:00
where
quoteRow :: NewQuoteRow
quoteRow = ( Nothing , Nothing , Nothing , Nothing , Nothing )
2022-03-16 13:20:47 +00:00
createNewChatItem_ :: forall c d . MsgDirectionI d => DB . Connection -> User -> ChatDirection c d -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> UTCTime -> UTCTime -> IO ChatItemId
2022-03-28 20:35:57 +04:00
createNewChatItem_ db User { userId } chatDirection msgId_ sharedMsgId ciContent quoteRow itemTs createdAt = do
2022-03-16 13:20:47 +00:00
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 ,
-- quote
quoted_shared_msg_id , quoted_sent_at , quoted_content , quoted_sent , quoted_member_id
) VALUES ( ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? , ? )
| ]
2022-03-28 20:35:57 +04:00
( ( userId , msgId_ ) :. idsRow :. itemRow :. quoteRow )
2022-03-16 13:20:47 +00:00
ciId <- insertedRowId db
2022-08-18 11:35:31 +04:00
forM_ msgId_ $ \ msgId -> insertChatItemMessage_ db ciId msgId createdAt
2022-03-16 13:20:47 +00:00
pure ciId
where
itemRow :: ( SMsgDirection d , UTCTime , CIContent d , Text , CIStatus d , Maybe SharedMsgId , UTCTime , UTCTime )
itemRow = ( msgDirection @ d , itemTs , ciContent , ciContentToText ciContent , ciStatusNew @ d , sharedMsgId , createdAt , createdAt )
idsRow :: ( Maybe Int64 , Maybe Int64 , Maybe Int64 )
idsRow = case chatDirection of
2022-01-28 10:41:09 +00:00
CDDirectRcv Contact { contactId } -> ( Just contactId , Nothing , Nothing )
2022-03-16 13:20:47 +00:00
CDDirectSnd Contact { contactId } -> ( Just contactId , Nothing , Nothing )
2022-01-28 10:41:09 +00:00
CDGroupRcv GroupInfo { groupId } GroupMember { groupMemberId } -> ( Nothing , Just groupId , Just groupMemberId )
2022-03-16 13:20:47 +00:00
CDGroupSnd GroupInfo { groupId } -> ( Nothing , Just groupId , Nothing )
2022-03-28 20:35:57 +04:00
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 )
2022-03-16 13:20:47 +00:00
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
2022-03-13 19:34:03 +00:00
where
2022-03-16 13:20:47 +00:00
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
2022-06-18 20:06:13 +01:00
fmap ciQuoteDirect . maybeFirstRow fromOnly $
DB . query
2022-03-13 19:34:03 +00:00
db
" SELECT chat_item_id FROM chat_items WHERE user_id = ? AND contact_id = ? AND shared_msg_id = ? AND item_sent = ? "
2022-03-16 13:20:47 +00:00
( userId , contactId , msgId , userSent )
2022-03-13 19:34:03 +00:00
where
2022-03-16 13:20:47 +00:00
ciQuoteDirect :: Maybe ChatItemId -> CIQuote 'CTDirect
ciQuoteDirect = ( ` ciQuote ` if userSent then CIQDirectSnd else CIQDirectRcv )
getUserGroupChatItemId_ :: Int64 -> IO ( Maybe ChatItemId )
getUserGroupChatItemId_ groupId =
2022-06-18 20:06:13 +01:00
maybeFirstRow fromOnly $
DB . query
2022-03-16 13:20:47 +00:00
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 =
2022-06-18 20:06:13 +01:00
maybeFirstRow fromOnly $
DB . query
2022-03-16 13:20:47 +00:00
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
2022-03-13 19:34:03 +00:00
db
[ sql |
SELECT i . chat_item_id ,
-- GroupMember
m . group_member_id , m . group_id , m . member_id , m . member_role , m . member_category ,
2022-08-18 11:35:31 +04:00
m . member_status , m . invited_by , m . local_display_name , m . contact_id , m . contact_profile_id , p . contact_profile_id ,
2022-11-01 17:32:49 +03:00
p . display_name , p . full_name , p . image , p . local_alias , p . preferences
2022-03-13 19:34:03 +00:00
FROM group_members m
2022-08-18 11:35:31 +04:00
JOIN contact_profiles p ON p . contact_profile_id = COALESCE ( m . member_profile_id , m . contact_profile_id )
2022-03-16 13:20:47 +00:00
LEFT JOIN contacts c ON m . contact_id = c . contact_id
2022-03-13 19:34:03 +00:00
LEFT JOIN chat_items i ON i . group_id = m . group_id
2022-03-16 13:20:47 +00:00
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
2022-03-13 19:34:03 +00:00
| ]
2022-03-16 13:20:47 +00:00
[ " :user_id " := userId , " :group_id " := groupId , " :member_id " := mId , " :msg_id " := msgId ]
2022-03-13 19:34:03 +00:00
where
2022-03-16 13:20:47 +00:00
ciQuoteGroup :: [ Only ( Maybe ChatItemId ) :. GroupMemberRow ] -> CIQuote 'CTGroup
ciQuoteGroup [] = ciQuote Nothing $ CIQGroupRcv Nothing
ciQuoteGroup ( ( Only itemId :. memberRow ) : _ ) = ciQuote itemId . CIQGroupRcv . Just $ toGroupMember userContactId memberRow
2022-01-26 16:18:27 +04:00
2022-06-18 20:06:13 +01:00
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 )
2022-01-29 16:06:08 +04:00
where
2022-01-30 21:51:23 +00:00
ts :: AChat -> UTCTime
2022-05-19 21:57:31 +04:00
ts ( AChat _ Chat { chatInfo , chatItems = ci : _ } ) = max ( chatItemTs ci ) ( chatInfoUpdatedAt chatInfo )
ts ( AChat _ Chat { chatInfo } ) = chatInfoUpdatedAt chatInfo
2022-02-01 15:05:27 +04:00
2022-01-30 21:51:23 +00:00
getDirectChatPreviews_ :: DB . Connection -> User -> IO [ AChat ]
2022-01-28 19:24:31 +04:00
getDirectChatPreviews_ db User { userId } = do
tz <- getCurrentTimeZone
2022-03-23 11:37:51 +00:00
currentTs <- getCurrentTime
map ( toDirectChatPreview tz currentTs )
2022-01-26 21:19:46 +04:00
<$> DB . query
db
[ sql |
SELECT
-- Contact
2022-11-01 17:32:49 +03:00
ct . contact_id , ct . contact_profile_id , ct . local_display_name , ct . via_group , cp . display_name , cp . full_name , cp . image , cp . local_alias , ct . contact_used , ct . enable_ntfs , cp . preferences , ct . user_preferences , ct . created_at , ct . updated_at ,
2022-01-30 10:49:13 +00:00
-- Connection
2022-10-24 14:28:58 +04:00
c . connection_id , c . agent_conn_id , c . conn_level , c . via_contact , c . via_user_contact_link , c . via_group_link , c . custom_user_profile_id , c . conn_status , c . conn_type , c . local_alias ,
2022-01-28 19:24:31 +04:00
c . contact_id , c . group_member_id , c . snd_file_id , c . rcv_file_id , c . user_contact_link_id , c . created_at ,
2022-02-08 20:38:57 +04:00
-- ChatStats
2022-10-19 21:38:44 +03:00
COALESCE ( ChatStats . UnreadCount , 0 ) , COALESCE ( ChatStats . MinUnread , 0 ) , ct . unread_chat ,
2022-01-29 16:06:08 +04:00
-- ChatItem
2022-05-04 13:31:00 +01:00
i . chat_item_id , i . item_ts , i . item_content , i . item_text , i . item_status , i . shared_msg_id , i . item_deleted , i . item_edited , i . created_at , i . updated_at ,
2022-04-10 13:30:58 +04:00
-- CIFile
f . file_id , f . file_name , f . file_size , f . file_path , f . ci_file_status ,
2022-03-13 19:34:03 +00:00
-- DirectQuote
2022-03-16 13:20:47 +00:00
ri . chat_item_id , i . quoted_shared_msg_id , i . quoted_sent_at , i . quoted_content , i . quoted_sent
2022-01-26 21:19:46 +04:00
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
2022-01-28 19:24:31 +04:00
LEFT JOIN (
2022-02-09 20:58:02 +04:00
SELECT contact_id , MAX ( chat_item_id ) AS MaxId
2022-01-28 19:24:31 +04:00
FROM chat_items
WHERE item_deleted != 1
GROUP BY contact_id
2022-02-09 20:58:02 +04:00
) MaxIds ON MaxIds . contact_id = ct . contact_id
2022-03-13 19:34:03 +00:00
LEFT JOIN chat_items i ON i . contact_id = MaxIds . contact_id
AND i . chat_item_id = MaxIds . MaxId
2022-04-10 13:30:58 +04:00
LEFT JOIN files f ON f . chat_item_id = i . chat_item_id
2022-02-08 20:38:57 +04:00
LEFT JOIN (
SELECT contact_id , COUNT ( 1 ) AS UnreadCount , MIN ( chat_item_id ) AS MinUnread
FROM chat_items
2022-05-17 22:48:54 +04:00
WHERE item_status = ? AND item_deleted != 1
2022-02-08 20:38:57 +04:00
GROUP BY contact_id
) ChatStats ON ChatStats . contact_id = ct . contact_id
2022-03-13 19:34:03 +00:00
LEFT JOIN chat_items ri ON i . quoted_shared_msg_id = ri . shared_msg_id
2022-01-26 21:19:46 +04:00
WHERE ct . user_id = ?
2022-10-26 13:37:17 +04:00
AND ( ( c . conn_level = 0 AND c . via_group_link = 0 ) OR ct . contact_used = 1 )
2022-02-07 18:34:54 +04:00
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
)
2022-01-31 13:20:26 +04:00
)
2022-03-13 19:34:03 +00:00
ORDER BY i . item_ts DESC
2022-01-26 21:19:46 +04:00
| ]
2022-02-08 20:38:57 +04:00
( CISRcvNew , userId , ConnReady , ConnSndReady )
2022-01-26 21:19:46 +04:00
where
2022-03-23 11:37:51 +00:00
toDirectChatPreview :: TimeZone -> UTCTime -> ContactRow :. ConnectionRow :. ChatStatsRow :. MaybeChatItemRow :. QuoteRow -> AChat
toDirectChatPreview tz currentTs ( contactRow :. connRow :. statsRow :. ciRow_ ) =
2022-02-02 20:25:36 +04:00
let contact = toContact $ contactRow :. connRow
2022-03-23 11:37:51 +00:00
ci_ = toDirectChatItemList tz currentTs ciRow_
2022-02-08 20:38:57 +04:00
stats = toChatStats statsRow
in AChat SCTDirect $ Chat ( DirectChat contact ) ci_ stats
2022-01-26 21:19:46 +04:00
2022-01-30 21:51:23 +00:00
getGroupChatPreviews_ :: DB . Connection -> User -> IO [ AChat ]
2022-01-29 16:06:08 +04:00
getGroupChatPreviews_ db User { userId , userContactId } = do
tz <- getCurrentTimeZone
2022-03-23 11:37:51 +00:00
currentTs <- getCurrentTime
map ( toGroupChatPreview tz currentTs )
2022-01-26 21:19:46 +04:00
<$> DB . query
db
[ sql |
SELECT
-- GroupInfo
2022-11-01 17:32:49 +03:00
g . group_id , g . local_display_name , gp . display_name , gp . full_name , gp . image , g . host_conn_custom_user_profile_id , g . enable_ntfs , gp . preferences , g . created_at , g . updated_at ,
2022-01-30 10:49:13 +00:00
-- GroupMember - membership
2022-01-29 16:06:08 +04:00
mu . group_member_id , mu . group_id , mu . member_id , mu . member_role , mu . member_category ,
2022-08-18 11:35:31 +04:00
mu . member_status , mu . invited_by , mu . local_display_name , mu . contact_id , mu . contact_profile_id , pu . contact_profile_id ,
2022-11-01 17:32:49 +03:00
pu . display_name , pu . full_name , pu . image , pu . local_alias , pu . preferences ,
2022-02-08 20:38:57 +04:00
-- ChatStats
2022-10-19 21:38:44 +03:00
COALESCE ( ChatStats . UnreadCount , 0 ) , COALESCE ( ChatStats . MinUnread , 0 ) , g . unread_chat ,
2022-01-29 16:06:08 +04:00
-- ChatItem
2022-05-04 13:31:00 +01:00
i . chat_item_id , i . item_ts , i . item_content , i . item_text , i . item_status , i . shared_msg_id , i . item_deleted , i . item_edited , i . created_at , i . updated_at ,
2022-04-10 13:30:58 +04:00
-- CIFile
f . file_id , f . file_name , f . file_size , f . file_path , f . ci_file_status ,
2022-01-30 10:49:13 +00:00
-- Maybe GroupMember - sender
2022-01-29 16:06:08 +04:00
m . group_member_id , m . group_id , m . member_id , m . member_role , m . member_category ,
2022-08-18 11:35:31 +04:00
m . member_status , m . invited_by , m . local_display_name , m . contact_id , m . contact_profile_id , p . contact_profile_id ,
2022-11-01 17:32:49 +03:00
p . display_name , p . full_name , p . image , p . local_alias , p . preferences ,
2022-03-13 19:34:03 +00:00
-- quoted ChatItem
2022-03-16 13:20:47 +00:00
ri . chat_item_id , i . quoted_shared_msg_id , i . quoted_sent_at , i . quoted_content , i . quoted_sent ,
2022-03-13 19:34:03 +00:00
-- quoted GroupMember
rm . group_member_id , rm . group_id , rm . member_id , rm . member_role , rm . member_category ,
2022-08-18 11:35:31 +04:00
rm . member_status , rm . invited_by , rm . local_display_name , rm . contact_id , rm . contact_profile_id , rp . contact_profile_id ,
2022-11-01 17:32:49 +03:00
rp . display_name , rp . full_name , rp . image , rp . local_alias , rp . preferences
2022-01-26 21:19:46 +04:00
FROM groups g
2022-01-29 16:06:08 +04:00
JOIN group_profiles gp ON gp . group_profile_id = g . group_profile_id
JOIN group_members mu ON mu . group_id = g . group_id
2022-08-18 11:35:31 +04:00
JOIN contact_profiles pu ON pu . contact_profile_id = COALESCE ( mu . member_profile_id , mu . contact_profile_id )
2022-01-29 16:06:08 +04:00
LEFT JOIN (
2022-02-09 20:58:02 +04:00
SELECT group_id , MAX ( chat_item_id ) AS MaxId
2022-01-29 16:06:08 +04:00
FROM chat_items
WHERE item_deleted != 1
GROUP BY group_id
2022-02-09 20:58:02 +04:00
) MaxIds ON MaxIds . group_id = g . group_id
2022-03-13 19:34:03 +00:00
LEFT JOIN chat_items i ON i . group_id = MaxIds . group_id
AND i . chat_item_id = MaxIds . MaxId
2022-04-10 13:30:58 +04:00
LEFT JOIN files f ON f . chat_item_id = i . chat_item_id
2022-02-08 20:38:57 +04:00
LEFT JOIN (
SELECT group_id , COUNT ( 1 ) AS UnreadCount , MIN ( chat_item_id ) AS MinUnread
FROM chat_items
2022-05-17 22:48:54 +04:00
WHERE item_status = ? AND item_deleted != 1
2022-02-08 20:38:57 +04:00
GROUP BY group_id
) ChatStats ON ChatStats . group_id = g . group_id
2022-03-13 19:34:03 +00:00
LEFT JOIN group_members m ON m . group_member_id = i . group_member_id
2022-08-18 11:35:31 +04:00
LEFT JOIN contact_profiles p ON p . contact_profile_id = COALESCE ( m . member_profile_id , m . contact_profile_id )
2022-03-13 19:34:03 +00:00
LEFT JOIN chat_items ri ON i . quoted_shared_msg_id = ri . shared_msg_id
LEFT JOIN group_members rm ON rm . group_member_id = ri . group_member_id
2022-08-18 11:35:31 +04:00
LEFT JOIN contact_profiles rp ON rp . contact_profile_id = COALESCE ( rm . member_profile_id , rm . contact_profile_id )
2022-01-28 19:24:31 +04:00
WHERE g . user_id = ? AND mu . contact_id = ?
2022-03-13 19:34:03 +00:00
ORDER BY i . item_ts DESC
2022-01-26 21:19:46 +04:00
| ]
2022-02-08 20:38:57 +04:00
( CISRcvNew , userId , userContactId )
2022-01-26 21:19:46 +04:00
where
2022-03-23 11:37:51 +00:00
toGroupChatPreview :: TimeZone -> UTCTime -> GroupInfoRow :. ChatStatsRow :. MaybeGroupChatItemRow -> AChat
toGroupChatPreview tz currentTs ( groupInfoRow :. statsRow :. ciRow_ ) =
2022-01-31 22:43:39 +04:00
let groupInfo = toGroupInfo userContactId groupInfoRow
2022-03-23 11:37:51 +00:00
ci_ = toGroupChatItemList tz currentTs userContactId ciRow_
2022-02-08 20:38:57 +04:00
stats = toChatStats statsRow
in AChat SCTGroup $ Chat ( GroupChat groupInfo ) ci_ stats
2022-01-26 21:19:46 +04:00
2022-01-31 22:43:39 +04:00
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 ,
2022-11-01 17:32:49 +03:00
c . agent_conn_id , cr . contact_profile_id , p . display_name , p . full_name , p . image , cr . xcontact_id , p . preferences , cr . created_at , cr . updated_at
2022-01-31 22:43:39 +04:00
FROM contact_requests cr
2022-10-13 17:12:22 +04:00
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
2022-01-31 22:43:39 +04:00
| ]
2022-10-13 17:12:22 +04:00
( userId , userId )
2022-01-31 22:43:39 +04:00
where
toContactRequestChatPreview :: ContactRequestRow -> AChat
toContactRequestChatPreview cReqRow =
let cReq = toContactRequest cReqRow
2022-10-19 21:38:44 +03:00
stats = ChatStats { unreadCount = 0 , minUnreadItemId = 0 , unreadChat = False }
2022-02-08 20:38:57 +04:00
in AChat SCTContactRequest $ Chat ( ContactRequest cReq ) [] stats
2022-01-31 22:43:39 +04:00
2022-04-23 17:32:40 +01:00
getContactConnectionChatPreviews_ :: DB . Connection -> User -> Bool -> IO [ AChat ]
getContactConnectionChatPreviews_ _ _ False = pure []
getContactConnectionChatPreviews_ db User { userId } _ =
map toContactConnectionChatPreview
<$> DB . query
db
[ sql |
2022-11-04 12:00:03 +04:00
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
2022-04-23 17:32:40 +01:00
FROM connections
2022-11-04 12:00:03 +04:00
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 ) )
2022-04-23 17:32:40 +01:00
| ]
( userId , ConnContact )
where
2022-11-04 12:00:03 +04:00
toContactConnectionChatPreview :: ( Int64 , ConnId , ConnStatus , Maybe ByteString , Maybe Int64 , Maybe GroupLinkId , Maybe Int64 , Maybe ConnReqInvitation , LocalAlias , UTCTime , UTCTime ) -> AChat
2022-04-23 17:32:40 +01:00
toContactConnectionChatPreview connRow =
let conn = toPendingContactConnection connRow
2022-10-19 21:38:44 +03:00
stats = ChatStats { unreadCount = 0 , minUnreadItemId = 0 , unreadChat = False }
2022-04-23 17:32:40 +01:00
in AChat SCTContactConnection $ Chat ( ContactConnection conn ) [] stats
2022-06-18 20:06:13 +01:00
getPendingContactConnection :: DB . Connection -> UserId -> Int64 -> ExceptT StoreError IO PendingContactConnection
getPendingContactConnection db userId connId = do
ExceptT . firstRow toPendingContactConnection ( SEPendingConnectionNotFound connId ) $
DB . query
2022-04-25 10:39:28 +01:00
db
[ sql |
2022-11-04 12:00:03 +04:00
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
2022-06-18 20:06:13 +01:00
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
2022-04-25 10:39:28 +01:00
| ]
( userId , connId , ConnContact )
2022-04-23 17:32:40 +01:00
2022-06-18 20:06:13 +01:00
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 )
2022-08-19 15:17:05 +01:00
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 )
2022-11-04 12:00:03 +04:00
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 }
2022-04-23 17:32:40 +01:00
2022-08-08 22:48:42 +04:00
getDirectChat :: DB . Connection -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO ( Chat 'CTDirect )
getDirectChat db user contactId pagination search_ = do
let search = fromMaybe " " search_
2022-06-18 20:06:13 +01:00
case pagination of
2022-08-08 22:48:42 +04:00
CPLast count -> getDirectChatLast_ db user contactId count search
CPAfter afterId count -> getDirectChatAfter_ db user contactId afterId count search
CPBefore beforeId count -> getDirectChatBefore_ db user contactId beforeId count search
2022-02-01 15:05:27 +04:00
2022-08-08 22:48:42 +04:00
getDirectChatLast_ :: DB . Connection -> User -> Int64 -> Int -> String -> ExceptT StoreError IO ( Chat 'CTDirect )
2022-08-13 11:53:53 +01:00
getDirectChatLast_ db User { userId } contactId count search = do
2022-06-18 20:06:13 +01:00
contact <- getContact db userId contactId
2022-10-19 21:38:44 +03:00
let stats = ChatStats { unreadCount = 0 , minUnreadItemId = 0 , unreadChat = False }
2022-02-07 15:19:34 +04:00
chatItems <- ExceptT getDirectChatItemsLast_
2022-02-08 20:38:57 +04:00
pure $ Chat ( DirectChat contact ) ( reverse chatItems ) stats
2022-02-01 15:05:27 +04:00
where
2022-02-07 15:19:34 +04:00
getDirectChatItemsLast_ :: IO ( Either StoreError [ CChatItem 'CTDirect ] )
2022-02-01 15:05:27 +04:00
getDirectChatItemsLast_ = do
tz <- getCurrentTimeZone
2022-03-23 11:37:51 +00:00
currentTs <- getCurrentTime
mapM ( toDirectChatItem tz currentTs )
2022-02-01 15:05:27 +04:00
<$> DB . query
db
[ sql |
2022-02-07 15:19:34 +04:00
SELECT
-- ChatItem
2022-05-04 13:31:00 +01:00
i . chat_item_id , i . item_ts , i . item_content , i . item_text , i . item_status , i . shared_msg_id , i . item_deleted , i . item_edited , i . created_at , i . updated_at ,
2022-04-10 13:30:58 +04:00
-- CIFile
f . file_id , f . file_name , f . file_size , f . file_path , f . ci_file_status ,
2022-03-13 19:34:03 +00:00
-- DirectQuote
2022-03-16 13:20:47 +00:00
ri . chat_item_id , i . quoted_shared_msg_id , i . quoted_sent_at , i . quoted_content , i . quoted_sent
2022-03-13 19:34:03 +00:00
FROM chat_items i
2022-04-10 13:30:58 +04:00
LEFT JOIN files f ON f . chat_item_id = i . chat_item_id
2022-03-13 19:34:03 +00:00
LEFT JOIN chat_items ri ON i . quoted_shared_msg_id = ri . shared_msg_id
2022-08-08 22:48:42 +04:00
WHERE i . user_id = ? AND i . contact_id = ? AND i . item_deleted != 1 AND i . item_text LIKE '%' || ? || '%'
2022-03-13 19:34:03 +00:00
ORDER BY i . chat_item_id DESC
2022-02-01 15:05:27 +04:00
LIMIT ?
| ]
2022-08-08 22:48:42 +04:00
( userId , contactId , search , count )
2022-02-01 15:05:27 +04:00
2022-08-08 22:48:42 +04:00
getDirectChatAfter_ :: DB . Connection -> User -> Int64 -> ChatItemId -> Int -> String -> ExceptT StoreError IO ( Chat 'CTDirect )
getDirectChatAfter_ db User { userId } contactId afterChatItemId count search = do
2022-06-18 20:06:13 +01:00
contact <- getContact db userId contactId
2022-10-19 21:38:44 +03:00
let stats = ChatStats { unreadCount = 0 , minUnreadItemId = 0 , unreadChat = False }
2022-02-07 15:19:34 +04:00
chatItems <- ExceptT getDirectChatItemsAfter_
2022-02-08 20:38:57 +04:00
pure $ Chat ( DirectChat contact ) chatItems stats
2022-02-01 15:05:27 +04:00
where
2022-02-07 15:19:34 +04:00
getDirectChatItemsAfter_ :: IO ( Either StoreError [ CChatItem 'CTDirect ] )
2022-02-01 15:05:27 +04:00
getDirectChatItemsAfter_ = do
tz <- getCurrentTimeZone
2022-03-23 11:37:51 +00:00
currentTs <- getCurrentTime
mapM ( toDirectChatItem tz currentTs )
2022-02-01 15:05:27 +04:00
<$> DB . query
db
[ sql |
2022-02-07 15:19:34 +04:00
SELECT
-- ChatItem
2022-05-04 13:31:00 +01:00
i . chat_item_id , i . item_ts , i . item_content , i . item_text , i . item_status , i . shared_msg_id , i . item_deleted , i . item_edited , i . created_at , i . updated_at ,
2022-04-10 13:30:58 +04:00
-- CIFile
f . file_id , f . file_name , f . file_size , f . file_path , f . ci_file_status ,
2022-03-13 19:34:03 +00:00
-- DirectQuote
2022-03-16 13:20:47 +00:00
ri . chat_item_id , i . quoted_shared_msg_id , i . quoted_sent_at , i . quoted_content , i . quoted_sent
2022-03-13 19:34:03 +00:00
FROM chat_items i
2022-04-10 13:30:58 +04:00
LEFT JOIN files f ON f . chat_item_id = i . chat_item_id
2022-03-13 19:34:03 +00:00
LEFT JOIN chat_items ri ON i . quoted_shared_msg_id = ri . shared_msg_id
2022-08-08 22:48:42 +04:00
WHERE i . user_id = ? AND i . contact_id = ? AND i . item_deleted != 1 AND i . item_text LIKE '%' || ? || '%'
AND i . chat_item_id > ?
2022-03-13 19:34:03 +00:00
ORDER BY i . chat_item_id ASC
2022-02-01 15:05:27 +04:00
LIMIT ?
| ]
2022-08-08 22:48:42 +04:00
( userId , contactId , search , afterChatItemId , count )
2022-02-01 15:05:27 +04:00
2022-08-08 22:48:42 +04:00
getDirectChatBefore_ :: DB . Connection -> User -> Int64 -> ChatItemId -> Int -> String -> ExceptT StoreError IO ( Chat 'CTDirect )
getDirectChatBefore_ db User { userId } contactId beforeChatItemId count search = do
2022-06-18 20:06:13 +01:00
contact <- getContact db userId contactId
2022-10-19 21:38:44 +03:00
let stats = ChatStats { unreadCount = 0 , minUnreadItemId = 0 , unreadChat = False }
2022-02-07 15:19:34 +04:00
chatItems <- ExceptT getDirectChatItemsBefore_
2022-02-08 20:38:57 +04:00
pure $ Chat ( DirectChat contact ) ( reverse chatItems ) stats
2022-02-01 15:05:27 +04:00
where
2022-02-07 15:19:34 +04:00
getDirectChatItemsBefore_ :: IO ( Either StoreError [ CChatItem 'CTDirect ] )
2022-02-01 15:05:27 +04:00
getDirectChatItemsBefore_ = do
tz <- getCurrentTimeZone
2022-03-23 11:37:51 +00:00
currentTs <- getCurrentTime
mapM ( toDirectChatItem tz currentTs )
2022-02-01 15:05:27 +04:00
<$> DB . query
db
[ sql |
2022-02-07 15:19:34 +04:00
SELECT
-- ChatItem
2022-05-04 13:31:00 +01:00
i . chat_item_id , i . item_ts , i . item_content , i . item_text , i . item_status , i . shared_msg_id , i . item_deleted , i . item_edited , i . created_at , i . updated_at ,
2022-04-10 13:30:58 +04:00
-- CIFile
f . file_id , f . file_name , f . file_size , f . file_path , f . ci_file_status ,
2022-03-13 19:34:03 +00:00
-- DirectQuote
2022-03-16 13:20:47 +00:00
ri . chat_item_id , i . quoted_shared_msg_id , i . quoted_sent_at , i . quoted_content , i . quoted_sent
2022-03-13 19:34:03 +00:00
FROM chat_items i
2022-04-10 13:30:58 +04:00
LEFT JOIN files f ON f . chat_item_id = i . chat_item_id
2022-03-13 19:34:03 +00:00
LEFT JOIN chat_items ri ON i . quoted_shared_msg_id = ri . shared_msg_id
2022-08-08 22:48:42 +04:00
WHERE i . user_id = ? AND i . contact_id = ? AND i . item_deleted != 1 AND i . item_text LIKE '%' || ? || '%'
AND i . chat_item_id < ?
2022-03-13 19:34:03 +00:00
ORDER BY i . chat_item_id DESC
2022-02-01 15:05:27 +04:00
LIMIT ?
| ]
2022-08-08 22:48:42 +04:00
( userId , contactId , search , beforeChatItemId , count )
2022-01-28 11:52:10 +04:00
2022-09-05 15:23:38 +01:00
getContactIdByName :: DB . Connection -> User -> ContactName -> ExceptT StoreError IO Int64
getContactIdByName db User { userId } cName =
2022-06-18 20:06:13 +01:00
ExceptT . firstRow fromOnly ( SEContactNotFoundByName cName ) $
2022-01-30 10:49:13 +00:00
DB . query db " SELECT contact_id FROM contacts WHERE user_id = ? AND local_display_name = ? " ( userId , cName )
2022-06-18 20:06:13 +01:00
getContact :: DB . Connection -> UserId -> Int64 -> ExceptT StoreError IO Contact
getContact db userId contactId =
ExceptT . fmap join . firstRow toContactOrError ( SEContactNotFound contactId ) $
DB . query
db
[ sql |
SELECT
-- Contact
2022-11-01 17:32:49 +03:00
ct . contact_id , ct . contact_profile_id , ct . local_display_name , ct . via_group , cp . display_name , cp . full_name , cp . image , cp . local_alias , ct . contact_used , ct . enable_ntfs , cp . preferences , ct . user_preferences , ct . created_at , ct . updated_at ,
2022-06-18 20:06:13 +01:00
-- Connection
2022-10-24 14:28:58 +04:00
c . connection_id , c . agent_conn_id , c . conn_level , c . via_contact , c . via_user_contact_link , c . via_group_link , c . custom_user_profile_id , c . conn_status , c . conn_type , c . local_alias ,
2022-06-18 20:06:13 +01:00
c . contact_id , c . group_member_id , c . snd_file_id , c . rcv_file_id , c . user_contact_link_id , c . created_at
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 )
2022-01-30 10:49:13 +00:00
2022-08-08 22:48:42 +04:00
getGroupChat :: DB . Connection -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO ( Chat 'CTGroup )
getGroupChat db user groupId pagination search_ = do
let search = fromMaybe " " search_
2022-06-18 20:06:13 +01:00
case pagination of
2022-08-08 22:48:42 +04:00
CPLast count -> getGroupChatLast_ db user groupId count search
CPAfter afterId count -> getGroupChatAfter_ db user groupId afterId count search
CPBefore beforeId count -> getGroupChatBefore_ db user groupId beforeId count search
2022-02-01 15:05:27 +04:00
2022-08-08 22:48:42 +04:00
getGroupChatLast_ :: DB . Connection -> User -> Int64 -> Int -> String -> ExceptT StoreError IO ( Chat 'CTGroup )
getGroupChatLast_ db user @ User { userId } groupId count search = do
2022-06-18 20:06:13 +01:00
groupInfo <- getGroupInfo db user groupId
2022-10-19 21:38:44 +03:00
let stats = ChatStats { unreadCount = 0 , minUnreadItemId = 0 , unreadChat = False }
2022-07-22 15:48:04 +04:00
chatItemIds <- liftIO getGroupChatItemIdsLast_
chatItems <- mapM ( getGroupChatItem db user groupId ) chatItemIds
2022-02-08 20:38:57 +04:00
pure $ Chat ( GroupChat groupInfo ) ( reverse chatItems ) stats
2022-02-01 15:05:27 +04:00
where
2022-07-22 15:48:04 +04:00
getGroupChatItemIdsLast_ :: IO [ ChatItemId ]
2022-08-08 14:13:51 +04:00
getGroupChatItemIdsLast_ =
2022-07-22 15:48:04 +04:00
map fromOnly
2022-02-01 15:05:27 +04:00
<$> DB . query
db
[ sql |
2022-07-22 15:48:04 +04:00
SELECT chat_item_id
FROM chat_items
2022-08-08 22:48:42 +04:00
WHERE user_id = ? AND group_id = ? AND item_deleted != 1 AND item_text LIKE '%' || ? || '%'
2022-07-22 15:48:04 +04:00
ORDER BY item_ts DESC , chat_item_id DESC
2022-02-01 15:05:27 +04:00
LIMIT ?
| ]
2022-08-08 22:48:42 +04:00
( userId , groupId , search , count )
2022-02-01 15:05:27 +04:00
2022-08-08 22:48:42 +04:00
getGroupChatAfter_ :: DB . Connection -> User -> Int64 -> ChatItemId -> Int -> String -> ExceptT StoreError IO ( Chat 'CTGroup )
getGroupChatAfter_ db user @ User { userId } groupId afterChatItemId count search = do
2022-06-18 20:06:13 +01:00
groupInfo <- getGroupInfo db user groupId
2022-10-19 21:38:44 +03:00
let stats = ChatStats { unreadCount = 0 , minUnreadItemId = 0 , unreadChat = False }
2022-08-08 14:13:51 +04:00
afterChatItem <- getGroupChatItem db user groupId afterChatItemId
chatItemIds <- liftIO $ getGroupChatItemIdsAfter_ ( chatItemTs afterChatItem )
chatItems <- mapM ( getGroupChatItem db user groupId ) chatItemIds
2022-02-08 20:38:57 +04:00
pure $ Chat ( GroupChat groupInfo ) chatItems stats
2022-02-01 15:05:27 +04:00
where
2022-08-08 14:13:51 +04:00
getGroupChatItemIdsAfter_ :: UTCTime -> IO [ ChatItemId ]
getGroupChatItemIdsAfter_ afterChatItemTs =
map fromOnly
2022-02-01 15:05:27 +04:00
<$> DB . query
db
[ sql |
2022-08-08 14:13:51 +04:00
SELECT chat_item_id
FROM chat_items
2022-08-08 22:48:42 +04:00
WHERE user_id = ? AND group_id = ? AND item_deleted != 1 AND item_text LIKE '%' || ? || '%'
2022-08-08 14:13:51 +04:00
AND ( item_ts > ? OR ( item_ts = ? AND chat_item_id > ? ) )
ORDER BY item_ts ASC , chat_item_id ASC
2022-02-01 15:05:27 +04:00
LIMIT ?
| ]
2022-08-08 22:48:42 +04:00
( userId , groupId , search , afterChatItemTs , afterChatItemTs , afterChatItemId , count )
2022-02-01 15:05:27 +04:00
2022-08-08 22:48:42 +04:00
getGroupChatBefore_ :: DB . Connection -> User -> Int64 -> ChatItemId -> Int -> String -> ExceptT StoreError IO ( Chat 'CTGroup )
getGroupChatBefore_ db user @ User { userId } groupId beforeChatItemId count search = do
2022-06-18 20:06:13 +01:00
groupInfo <- getGroupInfo db user groupId
2022-10-19 21:38:44 +03:00
let stats = ChatStats { unreadCount = 0 , minUnreadItemId = 0 , unreadChat = False }
2022-08-08 14:13:51 +04:00
beforeChatItem <- getGroupChatItem db user groupId beforeChatItemId
chatItemIds <- liftIO $ getGroupChatItemIdsBefore_ ( chatItemTs beforeChatItem )
chatItems <- mapM ( getGroupChatItem db user groupId ) chatItemIds
2022-02-08 20:38:57 +04:00
pure $ Chat ( GroupChat groupInfo ) ( reverse chatItems ) stats
2022-02-01 15:05:27 +04:00
where
2022-08-08 14:13:51 +04:00
getGroupChatItemIdsBefore_ :: UTCTime -> IO [ ChatItemId ]
getGroupChatItemIdsBefore_ beforeChatItemTs =
map fromOnly
2022-02-01 15:05:27 +04:00
<$> DB . query
db
[ sql |
2022-08-08 14:13:51 +04:00
SELECT chat_item_id
FROM chat_items
2022-08-08 22:48:42 +04:00
WHERE user_id = ? AND group_id = ? AND item_deleted != 1 AND item_text LIKE '%' || ? || '%'
2022-08-08 14:13:51 +04:00
AND ( item_ts < ? OR ( item_ts = ? AND chat_item_id < ? ) )
ORDER BY item_ts DESC , chat_item_id DESC
2022-02-01 15:05:27 +04:00
LIMIT ?
| ]
2022-08-08 22:48:42 +04:00
( userId , groupId , search , beforeChatItemTs , beforeChatItemTs , beforeChatItemId , count )
2022-01-29 16:06:08 +04:00
2022-06-18 20:06:13 +01:00
getGroupInfo :: DB . Connection -> User -> Int64 -> ExceptT StoreError IO GroupInfo
getGroupInfo db User { userId , userContactId } groupId =
ExceptT . firstRow ( toGroupInfo userContactId ) ( SEGroupNotFound groupId ) $
2022-01-29 16:06:08 +04:00
DB . query
db
[ sql |
SELECT
-- GroupInfo
2022-11-01 17:32:49 +03:00
g . group_id , g . local_display_name , gp . display_name , gp . full_name , gp . image , g . host_conn_custom_user_profile_id , g . enable_ntfs , gp . preferences , g . created_at , g . updated_at ,
2022-01-30 10:49:13 +00:00
-- GroupMember - membership
2022-01-29 16:06:08 +04:00
mu . group_member_id , mu . group_id , mu . member_id , mu . member_role , mu . member_category ,
2022-08-18 11:35:31 +04:00
mu . member_status , mu . invited_by , mu . local_display_name , mu . contact_id , mu . contact_profile_id , pu . contact_profile_id ,
2022-11-01 17:32:49 +03:00
pu . display_name , pu . full_name , pu . image , pu . local_alias , pu . preferences
2022-01-29 16:06:08 +04:00
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
2022-08-18 11:35:31 +04:00
JOIN contact_profiles pu ON pu . contact_profile_id = COALESCE ( mu . member_profile_id , mu . contact_profile_id )
2022-01-29 16:06:08 +04:00
WHERE g . group_id = ? AND g . user_id = ? AND mu . contact_id = ?
| ]
( groupId , userId , userContactId )
2022-07-29 19:04:32 +01:00
updateGroupProfile :: DB . Connection -> User -> GroupInfo -> GroupProfile -> ExceptT StoreError IO GroupInfo
2022-11-01 17:32:49 +03:00
updateGroupProfile db User { userId } g @ GroupInfo { groupId , localDisplayName , groupProfile = GroupProfile { displayName , preferences } } p' @ GroupProfile { displayName = newName , fullName , image }
2022-07-29 19:04:32 +01:00
| displayName == newName = liftIO $ do
2022-10-18 13:16:28 +04:00
currentTs <- getCurrentTime
updateGroupProfile_ currentTs $> ( g :: GroupInfo ) { groupProfile = p' }
2022-10-14 13:06:33 +01:00
| otherwise =
2022-10-18 13:16:28 +04:00
ExceptT . withLocalDisplayName db userId newName $ \ ldn -> do
currentTs <- getCurrentTime
updateGroupProfile_ currentTs
updateGroup_ ldn currentTs
pure . Right $ ( g :: GroupInfo ) { localDisplayName = ldn , groupProfile = p' }
2022-07-29 19:04:32 +01:00
where
updateGroupProfile_ currentTs =
DB . execute
db
[ sql |
UPDATE group_profiles
2022-11-01 17:32:49 +03:00
SET display_name = ? , full_name = ? , image = ? , preferences = ? , updated_at = ?
2022-07-29 19:04:32 +01:00
WHERE group_profile_id IN (
SELECT group_profile_id
FROM groups
WHERE user_id = ? AND group_id = ?
)
| ]
2022-11-01 17:32:49 +03:00
( newName , fullName , image , preferences , currentTs , userId , groupId )
2022-07-29 19:04:32 +01:00
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 )
2022-06-18 20:06:13 +01:00
getAllChatItems :: DB . Connection -> User -> ChatPagination -> ExceptT StoreError IO [ AChatItem ]
getAllChatItems db user pagination = do
case pagination of
CPLast count -> getAllChatItemsLast_ db user count
CPAfter _afterId _count -> throwError $ SEInternalError " not implemented "
CPBefore _beforeId _count -> throwError $ SEInternalError " not implemented "
2022-04-30 21:23:14 +01:00
getAllChatItemsLast_ :: DB . Connection -> User -> Int -> ExceptT StoreError IO [ AChatItem ]
getAllChatItemsLast_ db user @ User { userId } count = do
itemRefs <-
liftIO $
reverse . rights . map toChatItemRef
<$> DB . query
db
[ sql |
SELECT chat_item_id , contact_id , group_id
FROM chat_items
WHERE user_id = ?
ORDER BY item_ts DESC , chat_item_id DESC
LIMIT ?
| ]
( userId , count )
mapM ( uncurry $ getAChatItem_ db user ) itemRefs
2022-07-12 19:20:56 +04:00
getGroupIdByName :: DB . Connection -> User -> GroupName -> ExceptT StoreError IO GroupId
2022-06-18 20:06:13 +01:00
getGroupIdByName db User { userId } gName =
ExceptT . firstRow fromOnly ( SEGroupNotFoundByName gName ) $
2022-01-30 10:49:13 +00:00
DB . query db " SELECT group_id FROM groups WHERE user_id = ? AND local_display_name = ? " ( userId , gName )
2022-07-12 19:20:56 +04:00
getGroupMemberIdByName :: DB . Connection -> User -> GroupId -> ContactName -> ExceptT StoreError IO GroupMemberId
getGroupMemberIdByName db User { userId } groupId groupMemberName =
2022-07-20 14:57:16 +01:00
ExceptT . firstRow fromOnly ( SEGroupMemberNameNotFound groupId groupMemberName ) $
2022-07-12 19:20:56 +04:00
DB . query db " SELECT group_member_id FROM group_members WHERE user_id = ? AND group_id = ? AND local_display_name = ? " ( userId , groupId , groupMemberName )
2022-06-18 20:06:13 +01:00
getChatItemIdByAgentMsgId :: DB . Connection -> Int64 -> AgentMsgId -> IO ( Maybe ChatItemId )
getChatItemIdByAgentMsgId db connId msgId =
fmap join . maybeFirstRow fromOnly $
DB . query
2022-05-04 13:31:00 +01:00
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 )
2022-01-28 19:24:31 +04:00
2022-06-18 20:06:13 +01:00
updateDirectChatItemStatus :: forall d . MsgDirectionI d => DB . Connection -> UserId -> Int64 -> ChatItemId -> CIStatus d -> ExceptT StoreError IO ( ChatItem 'CTDirect d )
updateDirectChatItemStatus db userId contactId itemId itemStatus = do
ci <- liftEither . correctDir =<< getDirectChatItem db userId 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 } }
2022-02-07 15:19:34 +04:00
where
correctDir :: CChatItem c -> Either StoreError ( ChatItem c d )
correctDir ( CChatItem _ ci ) = first SEInternalError $ checkDirection ci
2022-06-18 20:06:13 +01:00
updateDirectChatItem :: forall d . MsgDirectionI d => DB . Connection -> UserId -> Int64 -> ChatItemId -> CIContent d -> Maybe MessageId -> ExceptT StoreError IO ( ChatItem 'CTDirect d )
updateDirectChatItem db userId contactId itemId newContent msgId_ = do
currentTs <- liftIO getCurrentTime
ci <- updateDirectChatItem_ db userId contactId itemId newContent currentTs
forM_ msgId_ $ \ msgId -> liftIO $ insertChatItemMessage_ db itemId msgId currentTs
pure ci
updateDirectChatItem_ :: forall d . ( MsgDirectionI d ) => DB . Connection -> UserId -> Int64 -> ChatItemId -> CIContent d -> UTCTime -> ExceptT StoreError IO ( ChatItem 'CTDirect d )
updateDirectChatItem_ db userId contactId itemId newContent currentTs = do
ci <- liftEither . correctDir =<< getDirectChatItem db userId contactId itemId
2022-03-23 11:37:51 +00:00
let newText = ciContentToText newContent
2022-03-28 20:35:57 +04:00
liftIO $ do
2022-03-23 11:37:51 +00:00
DB . execute
db
[ sql |
UPDATE chat_items
2022-03-28 20:35:57 +04:00
SET item_content = ? , item_text = ? , item_deleted = 0 , item_edited = 1 , updated_at = ?
2022-03-23 11:37:51 +00:00
WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?
| ]
( newContent , newText , currentTs , userId , contactId , itemId )
2022-03-25 22:26:05 +04:00
pure ci { content = newContent , meta = ( meta ci ) { itemText = newText , itemEdited = True } , formattedText = parseMaybeMarkdownList newText }
2022-03-23 11:37:51 +00:00
where
correctDir :: CChatItem c -> Either StoreError ( ChatItem c d )
correctDir ( CChatItem _ ci ) = first SEInternalError $ checkDirection ci
2022-06-18 20:06:13 +01:00
deleteDirectChatItemLocal :: DB . Connection -> UserId -> Contact -> ChatItemId -> CIDeleteMode -> ExceptT StoreError IO AChatItem
deleteDirectChatItemLocal db userId ct itemId mode = do
liftIO $ deleteChatItemMessages_ db itemId
deleteDirectChatItem_ db userId ct itemId mode
2022-05-17 11:22:09 +04:00
2022-06-18 20:06:13 +01:00
deleteDirectChatItem_ :: DB . Connection -> UserId -> Contact -> ChatItemId -> CIDeleteMode -> ExceptT StoreError IO AChatItem
deleteDirectChatItem_ db userId ct @ Contact { contactId } itemId mode = do
( CChatItem msgDir ci ) <- getDirectChatItem db userId contactId itemId
2022-05-17 11:22:09 +04:00
let toContent = msgDirToDeletedContent_ msgDir mode
liftIO $ do
DB . execute
db
[ sql |
DELETE FROM chat_items
WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?
| ]
( userId , contactId , itemId )
pure $ AChatItem SCTDirect msgDir ( DirectChat ct ) ( ci { content = toContent , meta = ( meta ci ) { itemText = ciDeleteModeToText mode , itemDeleted = True } , formattedText = Nothing } )
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 )
2022-03-28 20:35:57 +04:00
2022-06-18 20:06:13 +01:00
deleteDirectChatItemRcvBroadcast :: DB . Connection -> UserId -> Contact -> ChatItemId -> MessageId -> ExceptT StoreError IO AChatItem
deleteDirectChatItemRcvBroadcast db userId ct itemId msgId = do
currentTs <- liftIO getCurrentTime
liftIO $ insertChatItemMessage_ db itemId msgId currentTs
updateDirectChatItemRcvDeleted_ db userId ct itemId currentTs
2022-03-28 20:35:57 +04:00
2022-06-18 20:06:13 +01:00
updateDirectChatItemRcvDeleted_ :: DB . Connection -> UserId -> Contact -> ChatItemId -> UTCTime -> ExceptT StoreError IO AChatItem
updateDirectChatItemRcvDeleted_ db userId ct @ Contact { contactId } itemId currentTs = do
( CChatItem msgDir ci ) <- getDirectChatItem db userId contactId itemId
2022-05-17 11:22:09 +04:00
let toContent = msgDirToDeletedContent_ msgDir CIDMBroadcast
toText = ciDeleteModeToText CIDMBroadcast
2022-03-28 20:35:57 +04:00
liftIO $ do
DB . execute
db
[ sql |
UPDATE chat_items
2022-05-17 11:22:09 +04:00
SET item_content = ? , item_text = ? , updated_at = ?
2022-03-28 20:35:57 +04:00
WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?
| ]
2022-05-17 11:22:09 +04:00
( toContent , toText , currentTs , userId , contactId , itemId )
pure $ AChatItem SCTDirect msgDir ( DirectChat ct ) ( ci { content = toContent , meta = ( meta ci ) { itemText = toText } , formattedText = Nothing } )
2022-03-28 20:35:57 +04:00
2022-06-18 20:06:13 +01:00
getDirectChatItemBySharedMsgId :: DB . Connection -> UserId -> ContactId -> SharedMsgId -> ExceptT StoreError IO ( CChatItem 'CTDirect )
getDirectChatItemBySharedMsgId db userId contactId sharedMsgId = do
itemId <- getDirectChatItemIdBySharedMsgId_ db userId contactId sharedMsgId
getDirectChatItem db userId contactId itemId
2022-03-28 20:35:57 +04:00
2022-06-18 20:06:13 +01:00
getDirectChatItemByAgentMsgId :: DB . Connection -> UserId -> ContactId -> Int64 -> AgentMsgId -> IO ( Maybe ( CChatItem 'CTDirect ) )
getDirectChatItemByAgentMsgId db userId contactId connId msgId = do
itemId_ <- getChatItemIdByAgentMsgId db connId msgId
maybe ( pure Nothing ) ( fmap eitherToMaybe . runExceptT . getDirectChatItem db userId contactId ) itemId_
2022-03-23 11:37:51 +00:00
2022-06-18 20:06:13 +01:00
getDirectChatItemIdBySharedMsgId_ :: DB . Connection -> UserId -> Int64 -> SharedMsgId -> ExceptT StoreError IO Int64
2022-03-23 11:37:51 +00:00
getDirectChatItemIdBySharedMsgId_ db userId contactId sharedMsgId =
2022-06-18 20:06:13 +01:00
ExceptT . firstRow fromOnly ( SEChatItemSharedMsgIdNotFound sharedMsgId ) $
2022-03-23 11:37:51 +00:00
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 )
2022-06-18 20:06:13 +01:00
getDirectChatItem :: DB . Connection -> UserId -> Int64 -> ChatItemId -> ExceptT StoreError IO ( CChatItem 'CTDirect )
getDirectChatItem db userId contactId itemId = ExceptT $ do
2022-03-13 19:34:03 +00:00
tz <- getCurrentTimeZone
2022-03-23 11:37:51 +00:00
currentTs <- getCurrentTime
join <$> firstRow ( toDirectChatItem tz currentTs ) ( SEChatItemNotFound itemId ) getItem
2022-03-13 19:34:03 +00:00
where
getItem =
DB . query
db
[ sql |
SELECT
-- ChatItem
2022-05-04 13:31:00 +01:00
i . chat_item_id , i . item_ts , i . item_content , i . item_text , i . item_status , i . shared_msg_id , i . item_deleted , i . item_edited , i . created_at , i . updated_at ,
2022-04-10 13:30:58 +04:00
-- CIFile
f . file_id , f . file_name , f . file_size , f . file_path , f . ci_file_status ,
2022-03-13 19:34:03 +00:00
-- DirectQuote
2022-03-16 13:20:47 +00:00
ri . chat_item_id , i . quoted_shared_msg_id , i . quoted_sent_at , i . quoted_content , i . quoted_sent
2022-03-13 19:34:03 +00:00
FROM chat_items i
2022-04-10 13:30:58 +04:00
LEFT JOIN files f ON f . chat_item_id = i . chat_item_id
2022-03-13 19:34:03 +00:00
LEFT JOIN chat_items ri ON i . quoted_shared_msg_id = ri . shared_msg_id
WHERE i . user_id = ? AND i . contact_id = ? AND i . chat_item_id = ?
| ]
( userId , contactId , itemId )
2022-06-18 20:06:13 +01:00
getDirectChatItemIdByText :: DB . Connection -> UserId -> Int64 -> SMsgDirection d -> Text -> ExceptT StoreError IO ChatItemId
getDirectChatItemIdByText db userId contactId msgDir quotedMsg =
ExceptT . firstRow fromOnly SEQuotedChatItemNotFound $
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 <> " % " )
2022-03-23 11:37:51 +00:00
2022-06-18 20:06:13 +01:00
updateGroupChatItem :: forall d . MsgDirectionI d => DB . Connection -> User -> Int64 -> ChatItemId -> CIContent d -> MessageId -> ExceptT StoreError IO ( ChatItem 'CTGroup d )
updateGroupChatItem db user @ User { userId } groupId itemId newContent msgId = do
ci <- liftEither . correctDir =<< getGroupChatItem db user groupId itemId
2022-03-23 11:37:51 +00:00
currentTs <- liftIO getCurrentTime
let newText = ciContentToText newContent
2022-03-28 20:35:57 +04:00
liftIO $ do
2022-03-23 11:37:51 +00:00
DB . execute
db
[ sql |
UPDATE chat_items
2022-03-28 20:35:57 +04:00
SET item_content = ? , item_text = ? , item_deleted = 0 , item_edited = 1 , updated_at = ?
2022-03-23 11:37:51 +00:00
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
| ]
( newContent , newText , currentTs , userId , groupId , itemId )
2022-03-28 20:35:57 +04:00
insertChatItemMessage_ db itemId msgId currentTs
2022-03-25 22:26:05 +04:00
pure ci { content = newContent , meta = ( meta ci ) { itemText = newText , itemEdited = True } , formattedText = parseMaybeMarkdownList newText }
2022-03-23 11:37:51 +00:00
where
correctDir :: CChatItem c -> Either StoreError ( ChatItem c d )
correctDir ( CChatItem _ ci ) = first SEInternalError $ checkDirection ci
2022-10-01 14:31:21 +04:00
deleteGroupChatItemLocal :: DB . Connection -> User -> GroupInfo -> ChatItemId -> CIDeleteMode -> ExceptT StoreError IO AChatItem
deleteGroupChatItemLocal db user gInfo itemId mode = do
liftIO $ deleteChatItemMessages_ db itemId
deleteGroupChatItem_ db user gInfo itemId mode
2022-06-18 20:06:13 +01:00
2022-10-01 14:31:21 +04:00
deleteGroupChatItem_ :: DB . Connection -> User -> GroupInfo -> ChatItemId -> CIDeleteMode -> ExceptT StoreError IO AChatItem
deleteGroupChatItem_ db user @ User { userId } gInfo @ GroupInfo { groupId } itemId mode = do
( CChatItem msgDir ci ) <- getGroupChatItem db user groupId itemId
let toContent = msgDirToDeletedContent_ msgDir mode
liftIO $ do
DB . execute
db
[ sql |
DELETE FROM chat_items
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
| ]
( userId , groupId , itemId )
pure $ AChatItem SCTGroup msgDir ( GroupChat gInfo ) ( ci { content = toContent , meta = ( meta ci ) { itemText = ciDeleteModeToText mode , itemDeleted = True } , formattedText = Nothing } )
2022-06-18 20:06:13 +01:00
2022-10-01 14:31:21 +04:00
deleteGroupChatItemRcvBroadcast :: DB . Connection -> User -> GroupInfo -> ChatItemId -> MessageId -> ExceptT StoreError IO AChatItem
deleteGroupChatItemRcvBroadcast db user gInfo itemId msgId = do
2022-03-28 20:35:57 +04:00
currentTs <- liftIO getCurrentTime
2022-06-18 20:06:13 +01:00
liftIO $ insertChatItemMessage_ db itemId msgId currentTs
2022-10-01 14:31:21 +04:00
updateGroupChatItemRcvDeleted_ db user gInfo itemId currentTs
2022-03-28 20:35:57 +04:00
2022-10-01 14:31:21 +04:00
updateGroupChatItemRcvDeleted_ :: DB . Connection -> User -> GroupInfo -> ChatItemId -> UTCTime -> ExceptT StoreError IO AChatItem
updateGroupChatItemRcvDeleted_ db user @ User { userId } gInfo @ GroupInfo { groupId } itemId currentTs = do
2022-06-18 20:06:13 +01:00
( CChatItem msgDir ci ) <- getGroupChatItem db user groupId itemId
2022-10-01 14:31:21 +04:00
let toContent = msgDirToDeletedContent_ msgDir CIDMBroadcast
toText = ciDeleteModeToText CIDMBroadcast
2022-03-28 20:35:57 +04:00
liftIO $ do
DB . execute
db
[ sql |
UPDATE chat_items
2022-10-01 14:31:21 +04:00
SET item_content = ? , item_text = ? , updated_at = ?
2022-03-28 20:35:57 +04:00
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
| ]
2022-10-01 14:31:21 +04:00
( toContent , toText , currentTs , userId , groupId , itemId )
pure $ AChatItem SCTGroup msgDir ( GroupChat gInfo ) ( ci { content = toContent , meta = ( meta ci ) { itemText = toText } , formattedText = Nothing } )
2022-03-28 20:35:57 +04:00
2022-10-01 14:31:21 +04:00
getGroupChatItemBySharedMsgId :: DB . Connection -> User -> GroupId -> GroupMemberId -> SharedMsgId -> ExceptT StoreError IO ( CChatItem 'CTGroup )
getGroupChatItemBySharedMsgId db user @ User { userId } groupId groupMemberId sharedMsgId = do
2022-06-18 20:06:13 +01:00
itemId <-
ExceptT . firstRow fromOnly ( SEChatItemSharedMsgIdNotFound sharedMsgId ) $
DB . query
db
[ sql |
SELECT chat_item_id
FROM chat_items
2022-10-01 14:31:21 +04:00
WHERE user_id = ? AND group_id = ? AND group_member_id = ? AND shared_msg_id = ?
2022-06-18 20:06:13 +01:00
ORDER BY chat_item_id DESC
LIMIT 1
| ]
2022-10-01 14:31:21 +04:00
( userId , groupId , groupMemberId , sharedMsgId )
2022-06-18 20:06:13 +01:00
getGroupChatItem db user groupId itemId
2022-03-23 11:37:51 +00:00
2022-06-18 20:06:13 +01:00
getGroupChatItem :: DB . Connection -> User -> Int64 -> ChatItemId -> ExceptT StoreError IO ( CChatItem 'CTGroup )
getGroupChatItem db User { userId , userContactId } groupId itemId = ExceptT $ do
2022-03-23 11:37:51 +00:00
tz <- getCurrentTimeZone
2022-06-18 20:06:13 +01:00
currentTs <- getCurrentTime
2022-03-23 11:37:51 +00:00
join <$> firstRow ( toGroupChatItem tz currentTs userContactId ) ( SEChatItemNotFound itemId ) getItem
2022-03-13 19:34:03 +00:00
where
2022-03-23 11:37:51 +00:00
getItem =
2022-03-13 19:34:03 +00:00
DB . query
db
[ sql |
SELECT
-- ChatItem
2022-05-04 13:31:00 +01:00
i . chat_item_id , i . item_ts , i . item_content , i . item_text , i . item_status , i . shared_msg_id , i . item_deleted , i . item_edited , i . created_at , i . updated_at ,
2022-04-10 13:30:58 +04:00
-- CIFile
f . file_id , f . file_name , f . file_size , f . file_path , f . ci_file_status ,
2022-03-13 19:34:03 +00:00
-- GroupMember
m . group_member_id , m . group_id , m . member_id , m . member_role , m . member_category ,
2022-08-18 11:35:31 +04:00
m . member_status , m . invited_by , m . local_display_name , m . contact_id , m . contact_profile_id , p . contact_profile_id ,
2022-11-01 17:32:49 +03:00
p . display_name , p . full_name , p . image , p . local_alias , p . preferences ,
2022-03-13 19:34:03 +00:00
-- quoted ChatItem
2022-03-16 13:20:47 +00:00
ri . chat_item_id , i . quoted_shared_msg_id , i . quoted_sent_at , i . quoted_content , i . quoted_sent ,
2022-03-13 19:34:03 +00:00
-- quoted GroupMember
rm . group_member_id , rm . group_id , rm . member_id , rm . member_role , rm . member_category ,
2022-08-18 11:35:31 +04:00
rm . member_status , rm . invited_by , rm . local_display_name , rm . contact_id , rm . contact_profile_id , rp . contact_profile_id ,
2022-11-01 17:32:49 +03:00
rp . display_name , rp . full_name , rp . image , rp . local_alias , rp . preferences
2022-03-13 19:34:03 +00:00
FROM chat_items i
2022-04-10 13:30:58 +04:00
LEFT JOIN files f ON f . chat_item_id = i . chat_item_id
2022-03-13 19:34:03 +00:00
LEFT JOIN group_members m ON m . group_member_id = i . group_member_id
2022-08-18 11:35:31 +04:00
LEFT JOIN contact_profiles p ON p . contact_profile_id = COALESCE ( m . member_profile_id , m . contact_profile_id )
2022-03-13 19:34:03 +00:00
LEFT JOIN chat_items ri ON i . quoted_shared_msg_id = ri . shared_msg_id
LEFT JOIN group_members rm ON rm . group_member_id = ri . group_member_id
2022-08-18 11:35:31 +04:00
LEFT JOIN contact_profiles rp ON rp . contact_profile_id = COALESCE ( rm . member_profile_id , rm . contact_profile_id )
2022-03-13 19:34:03 +00:00
WHERE i . user_id = ? AND i . group_id = ? AND i . chat_item_id = ?
| ]
( userId , groupId , itemId )
2022-06-18 20:06:13 +01:00
getGroupChatItemIdByText :: DB . Connection -> User -> Int64 -> Maybe ContactName -> Text -> ExceptT StoreError IO ChatItemId
getGroupChatItemIdByText db User { userId , localDisplayName = userName } groupId contactName_ quotedMsg =
ExceptT . firstRow fromOnly SEQuotedChatItemNotFound $ case contactName_ of
Nothing -> anyMemberChatItem_
Just cName
| userName == cName -> userChatItem_
| otherwise -> memberChatItem_ cName
2022-03-19 09:04:53 +00:00
where
2022-06-18 20:06:13 +01:00
anyMemberChatItem_ =
2022-03-19 09:04:53 +00:00
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 <> " % " )
2022-06-18 20:06:13 +01:00
userChatItem_ =
2022-03-19 09:04:53 +00:00
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 <> " % " )
2022-06-18 20:06:13 +01:00
memberChatItem_ cName =
2022-03-19 09:04:53 +00:00
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 <> " % " )
2022-03-13 19:34:03 +00:00
2022-06-18 20:06:13 +01:00
getChatItemByFileId :: DB . Connection -> User -> Int64 -> ExceptT StoreError IO AChatItem
getChatItemByFileId db user @ User { userId } fileId = do
( itemId , chatRef ) <-
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 )
2022-04-30 21:23:14 +01:00
getAChatItem_ db user itemId chatRef
2022-07-15 17:49:29 +04:00
getChatItemByGroupId :: DB . Connection -> User -> GroupId -> ExceptT StoreError IO AChatItem
getChatItemByGroupId db user @ User { userId } groupId = do
( itemId , chatRef ) <-
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 itemId chatRef
2022-04-30 21:23:14 +01:00
getAChatItem_ :: DB . Connection -> User -> ChatItemId -> ChatRef -> ExceptT StoreError IO AChatItem
getAChatItem_ db user @ User { userId } itemId = \ case
ChatRef CTDirect contactId -> do
2022-06-18 20:06:13 +01:00
ct <- getContact db userId contactId
( CChatItem msgDir ci ) <- getDirectChatItem db userId contactId itemId
2022-04-30 21:23:14 +01:00
pure $ AChatItem SCTDirect msgDir ( DirectChat ct ) ci
ChatRef CTGroup groupId -> do
2022-06-18 20:06:13 +01:00
gInfo <- getGroupInfo db user groupId
( CChatItem msgDir ci ) <- getGroupChatItem db user groupId itemId
2022-04-30 21:23:14 +01:00
pure $ AChatItem SCTGroup msgDir ( GroupChat gInfo ) ci
_ -> throwError $ SEChatItemNotFound itemId
2022-06-18 20:06:13 +01:00
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
2022-05-05 13:50:19 +01:00
2022-04-30 21:23:14 +01:00
toChatItemRef :: ( ChatItemId , Maybe Int64 , Maybe Int64 ) -> Either StoreError ( ChatItemId , ChatRef )
toChatItemRef = \ case
( itemId , Just contactId , Nothing ) -> Right ( itemId , ChatRef CTDirect contactId )
( itemId , Nothing , Just groupId ) -> Right ( itemId , ChatRef CTGroup groupId )
( itemId , _ , _ ) -> Left $ SEBadChatItem itemId
2022-06-18 20:06:13 +01:00
updateDirectChatItemsRead :: DB . Connection -> Int64 -> Maybe ( ChatItemId , ChatItemId ) -> IO ()
updateDirectChatItemsRead db contactId itemsRange_ = do
currentTs <- getCurrentTime
case itemsRange_ of
Just ( fromItemId , toItemId ) ->
DB . execute
db
[ sql |
UPDATE chat_items SET item_status = ? , updated_at = ?
WHERE contact_id = ? AND chat_item_id >= ? AND chat_item_id <= ? AND item_status = ?
| ]
( CISRcvRead , currentTs , contactId , fromItemId , toItemId , CISRcvNew )
_ ->
DB . execute
db
[ sql |
UPDATE chat_items SET item_status = ? , updated_at = ?
WHERE contact_id = ? AND item_status = ?
| ]
( CISRcvRead , currentTs , contactId , CISRcvNew )
2022-02-08 17:27:43 +04:00
2022-06-18 20:06:13 +01:00
updateGroupChatItemsRead :: DB . Connection -> Int64 -> Maybe ( ChatItemId , ChatItemId ) -> IO ()
updateGroupChatItemsRead db groupId itemsRange_ = do
currentTs <- getCurrentTime
case itemsRange_ of
Just ( fromItemId , toItemId ) ->
DB . execute
db
[ sql |
UPDATE chat_items SET item_status = ? , updated_at = ?
WHERE group_id = ? AND chat_item_id >= ? AND chat_item_id <= ? AND item_status = ?
| ]
( CISRcvRead , currentTs , groupId , fromItemId , toItemId , CISRcvNew )
_ ->
DB . execute
db
[ sql |
UPDATE chat_items SET item_status = ? , updated_at = ?
WHERE group_id = ? AND item_status = ?
| ]
( CISRcvRead , currentTs , groupId , CISRcvNew )
2022-02-08 20:38:57 +04:00
2022-10-19 21:38:44 +03:00
type ChatStatsRow = ( Int , ChatItemId , Bool )
2022-02-08 20:38:57 +04:00
toChatStats :: ChatStatsRow -> ChatStats
2022-10-19 21:38:44 +03:00
toChatStats ( unreadCount , minUnreadItemId , unreadChat ) = ChatStats { unreadCount , minUnreadItemId , unreadChat }
2022-02-08 17:27:43 +04:00
2022-04-10 13:30:58 +04:00
type MaybeCIFIleRow = ( Maybe Int64 , Maybe String , Maybe Integer , Maybe FilePath , Maybe ACIFileStatus )
2022-02-07 15:19:34 +04:00
2022-05-04 13:31:00 +01:00
type ChatItemRow = ( Int64 , ChatItemTs , ACIContent , Text , ACIStatus , Maybe SharedMsgId , Bool , Maybe Bool , UTCTime , UTCTime ) :. MaybeCIFIleRow
2022-02-07 15:19:34 +04:00
2022-05-04 13:31:00 +01:00
type MaybeChatItemRow = ( Maybe Int64 , Maybe ChatItemTs , Maybe ACIContent , Maybe Text , Maybe ACIStatus , Maybe SharedMsgId , Maybe Bool , Maybe Bool , Maybe UTCTime , Maybe UTCTime ) :. MaybeCIFIleRow
2022-03-13 19:34:03 +00:00
2022-04-10 13:30:58 +04:00
type QuoteRow = ( Maybe ChatItemId , Maybe SharedMsgId , Maybe UTCTime , Maybe MsgContent , Maybe Bool )
2022-03-13 19:34:03 +00:00
2022-03-16 13:20:47 +00:00
toDirectQuote :: QuoteRow -> Maybe ( CIQuote 'CTDirect )
toDirectQuote qr @ ( _ , _ , _ , _ , quotedSent ) = toQuote qr $ direction <$> quotedSent
where
direction sent = if sent then CIQDirectSnd else CIQDirectRcv
2022-03-13 19:34:03 +00:00
2022-03-16 13:20:47 +00:00
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 )
2022-03-13 19:34:03 +00:00
2022-03-23 11:37:51 +00:00
toDirectChatItem :: TimeZone -> UTCTime -> ChatItemRow :. QuoteRow -> Either StoreError ( CChatItem 'CTDirect )
2022-05-04 13:31:00 +01:00
toDirectChatItem tz currentTs ( ( ( itemId , itemTs , itemContent , itemText , itemStatus , sharedMsgId , itemDeleted , itemEdited , createdAt , updatedAt ) :. ( fileId_ , fileName_ , fileSize_ , filePath , fileStatus_ ) ) :. quoteRow ) =
2022-04-10 13:30:58 +04:00
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
2022-02-07 15:19:34 +04:00
_ -> badItem
where
2022-04-10 13:30:58 +04:00
maybeCIFile :: CIFileStatus d -> Maybe ( CIFile d )
maybeCIFile fileStatus =
case ( fileId_ , fileName_ , fileSize_ ) of
( Just fileId , Just fileName , Just fileSize ) -> Just CIFile { fileId , fileName , fileSize , filePath , fileStatus }
_ -> 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 , file }
2022-02-07 15:19:34 +04:00
badItem = Left $ SEBadChatItem itemId
2022-03-28 20:35:57 +04:00
ciMeta :: CIContent d -> CIStatus d -> CIMeta d
2022-05-04 13:31:00 +01:00
ciMeta content status = mkCIMeta itemId content itemText status sharedMsgId itemDeleted ( fromMaybe False itemEdited ) tz currentTs itemTs createdAt updatedAt
2022-01-28 19:24:31 +04:00
2022-03-23 11:37:51 +00:00
toDirectChatItemList :: TimeZone -> UTCTime -> MaybeChatItemRow :. QuoteRow -> [ CChatItem 'CTDirect ]
2022-05-04 13:31:00 +01:00
toDirectChatItemList tz currentTs ( ( ( Just itemId , Just itemTs , Just itemContent , Just itemText , Just itemStatus , sharedMsgId , Just itemDeleted , itemEdited , Just createdAt , Just updatedAt ) :. fileRow ) :. quoteRow ) =
either ( const [] ) ( : [] ) $ toDirectChatItem tz currentTs ( ( ( itemId , itemTs , itemContent , itemText , itemStatus , sharedMsgId , itemDeleted , itemEdited , createdAt , updatedAt ) :. fileRow ) :. quoteRow )
2022-03-23 11:37:51 +00:00
toDirectChatItemList _ _ _ = []
2022-01-26 16:18:27 +04:00
2022-03-16 13:20:47 +00:00
type GroupQuoteRow = QuoteRow :. MaybeGroupMemberRow
2022-03-13 19:34:03 +00:00
2022-03-16 13:20:47 +00:00
type MaybeGroupChatItemRow = MaybeChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow
2022-01-29 16:06:08 +04:00
2022-03-16 13:20:47 +00:00
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
2022-01-29 16:06:08 +04:00
2022-03-23 11:37:51 +00:00
toGroupChatItem :: TimeZone -> UTCTime -> Int64 -> ChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow -> Either StoreError ( CChatItem 'CTGroup )
2022-05-04 13:31:00 +01:00
toGroupChatItem tz currentTs userContactId ( ( ( itemId , itemTs , itemContent , itemText , itemStatus , sharedMsgId , itemDeleted , itemEdited , createdAt , updatedAt ) :. ( fileId_ , fileName_ , fileSize_ , filePath , fileStatus_ ) ) :. memberRow_ :. quoteRow :. quotedMemberRow_ ) = do
2022-02-07 15:19:34 +04:00
let member_ = toMaybeGroupMember userContactId memberRow_
2022-03-13 19:34:03 +00:00
let quotedMember_ = toMaybeGroupMember userContactId quotedMemberRow_
2022-04-10 13:30:58 +04:00
case ( itemContent , itemStatus , member_ , fileStatus_ ) of
( ACIContent SMDSnd ciContent , ACIStatus SMDSnd ciStatus , _ , Just ( AFS SMDSnd fileStatus ) ) ->
Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent quotedMember_ ( maybeCIFile fileStatus )
( ACIContent SMDSnd ciContent , ACIStatus SMDSnd ciStatus , _ , Nothing ) ->
Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent quotedMember_ Nothing
( ACIContent SMDRcv ciContent , ACIStatus SMDRcv ciStatus , Just member , Just ( AFS SMDRcv fileStatus ) ) ->
Right $ cItem SMDRcv ( CIGroupRcv member ) ciStatus ciContent quotedMember_ ( maybeCIFile fileStatus )
( ACIContent SMDRcv ciContent , ACIStatus SMDRcv ciStatus , Just member , Nothing ) ->
Right $ cItem SMDRcv ( CIGroupRcv member ) ciStatus ciContent quotedMember_ Nothing
2022-02-07 15:19:34 +04:00
_ -> badItem
where
2022-04-10 13:30:58 +04:00
maybeCIFile :: CIFileStatus d -> Maybe ( CIFile d )
maybeCIFile fileStatus =
case ( fileId_ , fileName_ , fileSize_ ) of
( Just fileId , Just fileName , Just fileSize ) -> Just CIFile { fileId , fileName , fileSize , filePath , fileStatus }
_ -> Nothing
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTGroup d -> CIStatus d -> CIContent d -> Maybe GroupMember -> Maybe ( CIFile d ) -> CChatItem 'CTGroup
cItem d chatDir ciStatus content quotedMember_ file =
CChatItem d ChatItem { chatDir , meta = ciMeta content ciStatus , content , formattedText = parseMaybeMarkdownList itemText , quotedItem = toGroupQuote quoteRow quotedMember_ , file }
2022-02-07 15:19:34 +04:00
badItem = Left $ SEBadChatItem itemId
2022-03-28 20:35:57 +04:00
ciMeta :: CIContent d -> CIStatus d -> CIMeta d
2022-05-04 13:31:00 +01:00
ciMeta content status = mkCIMeta itemId content itemText status sharedMsgId itemDeleted ( fromMaybe False itemEdited ) tz currentTs itemTs createdAt updatedAt
2022-01-29 16:06:08 +04:00
2022-03-23 11:37:51 +00:00
toGroupChatItemList :: TimeZone -> UTCTime -> Int64 -> MaybeGroupChatItemRow -> [ CChatItem 'CTGroup ]
2022-05-04 13:31:00 +01:00
toGroupChatItemList tz currentTs userContactId ( ( ( Just itemId , Just itemTs , Just itemContent , Just itemText , Just itemStatus , sharedMsgId , Just itemDeleted , itemEdited , Just createdAt , Just updatedAt ) :. fileRow ) :. memberRow_ :. quoteRow :. quotedMemberRow_ ) =
either ( const [] ) ( : [] ) $ toGroupChatItem tz currentTs userContactId ( ( ( itemId , itemTs , itemContent , itemText , itemStatus , sharedMsgId , itemDeleted , itemEdited , createdAt , updatedAt ) :. fileRow ) :. memberRow_ :. quoteRow :. quotedMemberRow_ )
2022-03-23 11:37:51 +00:00
toGroupChatItemList _ _ _ _ = []
2022-01-26 16:18:27 +04:00
2022-06-18 20:06:13 +01:00
getSMPServers :: DB . Connection -> User -> IO [ SMPServer ]
getSMPServers db User { userId } =
map toSmpServer
<$> DB . query
db
[ sql |
SELECT host , port , key_hash
FROM smp_servers
WHERE user_id = ? ;
| ]
( Only userId )
2022-03-10 15:45:40 +04:00
where
2022-08-13 11:53:53 +01:00
toSmpServer :: ( NonEmpty TransportHost , String , C . KeyHash ) -> SMPServer
2022-03-10 15:45:40 +04:00
toSmpServer ( host , port , keyHash ) = SMPServer host port keyHash
2022-06-18 20:06:13 +01:00
overwriteSMPServers :: DB . Connection -> User -> [ SMPServer ] -> ExceptT StoreError IO ()
overwriteSMPServers db User { userId } smpServers =
checkConstraint SEUniqueID . ExceptT $ do
2022-03-10 15:45:40 +04:00
currentTs <- getCurrentTime
DB . execute db " DELETE FROM smp_servers WHERE user_id = ? " ( Only userId )
2022-04-21 20:04:22 +01:00
forM_ smpServers $ \ ProtocolServer { host , port , keyHash } ->
2022-03-10 15:45:40 +04:00
DB . execute
db
[ sql |
INSERT INTO smp_servers
( host , port , key_hash , user_id , created_at , updated_at )
VALUES ( ? , ? , ? , ? , ? , ? )
| ]
( host , port , keyHash , userId , currentTs , currentTs )
pure $ Right ()
2022-07-04 11:15:25 +01:00
createCall :: DB . Connection -> User -> Call -> UTCTime -> IO ()
createCall db User { userId } Call { contactId , callId , chatItemId , callState } callTs = do
currentTs <- getCurrentTime
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 -> User -> IO [ Call ]
getCalls db User { userId } = do
map toCall
<$> DB . query
db
[ sql |
SELECT
contact_id , shared_call_id , chat_item_id , call_state , call_ts
FROM calls
WHERE user_id = ?
2022-07-05 15:15:15 +04:00
ORDER BY call_ts ASC
2022-07-04 11:15:25 +01:00
| ]
( Only userId )
where
toCall :: ( ContactId , CallId , ChatItemId , CallState , UTCTime ) -> Call
toCall ( contactId , callId , chatItemId , callState , callTs ) = Call { contactId , callId , chatItemId , callState , callTs }
2022-09-14 19:45:21 +04:00
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 )
2022-09-16 19:30:02 +04:00
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 )
2022-09-14 19:45:21 +04:00
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
2022-09-28 20:47:06 +04:00
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 )
2022-10-05 19:54:28 +04:00
getContactExpiredFileInfo :: DB . Connection -> User -> Contact -> UTCTime -> IO [ CIFileInfo ]
getContactExpiredFileInfo db User { userId } Contact { contactId } expirationDate =
2022-10-04 01:33:36 +04:00
map toFileInfo
<$> DB . query
db
[ 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
2022-10-05 19:54:28 +04:00
WHERE i . user_id = ? AND i . contact_id = ? AND i . created_at <= ?
2022-10-04 01:33:36 +04:00
| ]
2022-10-05 19:54:28 +04:00
( userId , contactId , expirationDate )
2022-10-04 01:33:36 +04:00
2022-10-05 19:54:28 +04:00
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_items WHERE user_id = ? AND contact_id = ? AND created_at <= ? " ( userId , contactId , expirationDate )
2022-10-04 01:33:36 +04:00
2022-10-05 19:54:28 +04:00
getContactCICount :: DB . Connection -> User -> Contact -> IO ( Maybe Int64 )
getContactCICount db User { userId } Contact { contactId } =
fmap join . maybeFirstRow fromOnly $
DB . query db " SELECT COUNT(1) FROM chat_items WHERE user_id = ? AND contact_id = ? " ( userId , contactId )
2022-09-28 20:47:06 +04:00
2022-10-05 19:54:28 +04:00
getGroupExpiredFileInfo :: DB . Connection -> User -> GroupInfo -> UTCTime -> UTCTime -> IO [ CIFileInfo ]
getGroupExpiredFileInfo db User { userId } GroupInfo { groupId } expirationDate createdAtCutoff =
map toFileInfo
2022-09-28 20:47:06 +04:00
<$> DB . query
db
[ sql |
2022-10-05 19:54:28 +04:00
SELECT f . file_id , f . ci_file_status , f . file_path
2022-09-28 20:47:06 +04:00
FROM chat_items i
2022-10-05 19:54:28 +04:00
JOIN files f ON f . chat_item_id = i . chat_item_id
WHERE i . user_id = ? AND i . group_id = ? AND i . item_ts <= ? AND i . created_at <= ?
2022-09-28 20:47:06 +04:00
| ]
2022-10-05 19:54:28 +04:00
( userId , groupId , expirationDate , createdAtCutoff )
2022-09-28 20:47:06 +04:00
2022-10-05 19:54:28 +04:00
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_items WHERE user_id = ? AND group_id = ? AND item_ts <= ? AND created_at <= ? " ( userId , groupId , expirationDate , createdAtCutoff )
getGroupCICount :: DB . Connection -> User -> GroupInfo -> IO ( Maybe Int64 )
getGroupCICount db User { userId } GroupInfo { groupId } =
fmap join . maybeFirstRow fromOnly $
DB . query db " SELECT COUNT(1) FROM chat_items WHERE user_id = ? AND group_id = ? " ( userId , groupId )
2022-09-28 20:47:06 +04:00
2021-07-14 20:11:41 +01:00
-- | Saves unique local display name based on passed displayName, suffixed with _N if required.
-- This function should be called inside transaction.
2022-08-18 11:35:31 +04:00
withLocalDisplayName :: forall a . DB . Connection -> UserId -> Text -> ( Text -> IO ( Either StoreError a ) ) -> IO ( Either StoreError a )
2021-07-14 20:11:41 +01:00
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
2022-02-02 20:25:36 +04:00
currentTs <- getCurrentTime
2021-07-14 20:11:41 +01:00
let ldn = displayName <> ( if ldnSuffix == 0 then " " else T . pack $ '_' : show ldnSuffix )
2022-02-02 20:25:36 +04:00
E . try ( insertName ldn currentTs ) >>= \ case
2022-08-18 11:35:31 +04:00
Right () -> action ldn
2021-07-14 20:11:41 +01:00
Left e
| DB . sqlError e == DB . ErrorConstraint -> tryCreateName ( ldnSuffix + 1 ) ( attempts - 1 )
| otherwise -> E . throwIO e
where
2022-02-02 20:25:36 +04:00
insertName ldn ts =
2021-07-14 20:11:41 +01:00
DB . execute
db
[ sql |
INSERT INTO display_names
2022-02-02 20:25:36 +04:00
( local_display_name , ldn_base , ldn_suffix , user_id , created_at , updated_at )
VALUES ( ? , ? , ? , ? , ? , ? )
2021-07-14 20:11:41 +01:00
| ]
2022-02-02 20:25:36 +04:00
( ldn , displayName , ldnSuffix , userId , ts , ts )
2021-07-14 20:11:41 +01:00
2022-06-18 20:06:13 +01:00
createWithRandomId :: forall a . TVar ChaChaDRG -> ( ByteString -> IO a ) -> ExceptT StoreError IO a
2021-07-27 08:08:05 +01:00
createWithRandomId = createWithRandomBytes 12
2022-06-18 20:06:13 +01:00
createWithRandomBytes :: forall a . Int -> TVar ChaChaDRG -> ( ByteString -> IO a ) -> ExceptT StoreError IO a
2021-07-27 08:08:05 +01:00
createWithRandomBytes size gVar create = tryCreate 3
2021-07-12 19:00:03 +01:00
where
2022-06-18 20:06:13 +01:00
tryCreate :: Int -> ExceptT StoreError IO a
tryCreate 0 = throwError SEUniqueID
2021-07-12 19:00:03 +01:00
tryCreate n = do
2022-06-18 20:06:13 +01:00
id' <- liftIO $ encodedRandomBytes gVar size
liftIO ( E . try $ create id' ) >>= \ case
Right x -> pure x
2021-07-12 19:00:03 +01:00
Left e
| DB . sqlError e == DB . ErrorConstraint -> tryCreate ( n - 1 )
2022-06-18 20:06:13 +01:00
| otherwise -> throwError . SEInternalError $ show e
2021-07-12 19:00:03 +01:00
2022-05-03 10:22:35 +01:00
encodedRandomBytes :: TVar ChaChaDRG -> Int -> IO ByteString
encodedRandomBytes gVar = fmap B64 . encode . randomBytes gVar
2021-07-27 08:08:05 +01:00
randomBytes :: TVar ChaChaDRG -> Int -> IO ByteString
2022-05-03 10:22:35 +01:00
randomBytes gVar = atomically . stateTVar gVar . randomBytesGenerate
2021-07-12 19:00:03 +01:00
2022-02-06 18:26:22 +00:00
-- These error type constructors must be added to mobile apps
2021-07-04 18:42:24 +01:00
data StoreError
2021-07-14 20:11:41 +01:00
= SEDuplicateName
2022-01-29 16:06:08 +04:00
| SEContactNotFound { contactId :: Int64 }
| SEContactNotFoundByName { contactName :: ContactName }
2022-01-27 22:01:15 +00:00
| SEContactNotReady { contactName :: ContactName }
2021-12-08 13:09:51 +00:00
| SEDuplicateContactLink
| SEUserContactLinkNotFound
2022-01-31 21:53:53 +04:00
| SEContactRequestNotFound { contactRequestId :: Int64 }
| SEContactRequestNotFoundByName { contactName :: ContactName }
2022-07-12 19:20:56 +04:00
| SEGroupNotFound { groupId :: GroupId }
2022-01-29 16:06:08 +04:00
| SEGroupNotFoundByName { groupName :: GroupName }
2022-07-20 14:57:16 +01:00
| SEGroupMemberNameNotFound { groupId :: GroupId , groupMemberName :: ContactName }
| SEGroupMemberNotFound { groupId :: GroupId , groupMemberId :: GroupMemberId }
2021-07-12 19:00:03 +01:00
| SEGroupWithoutUser
| SEDuplicateGroupMember
2021-07-16 07:40:55 +01:00
| SEGroupAlreadyJoined
2021-07-24 10:26:28 +01:00
| SEGroupInvitationNotFound
2022-01-27 22:01:15 +00:00
| SESndFileNotFound { fileId :: FileTransferId }
| SESndFileInvalid { fileId :: FileTransferId }
| SERcvFileNotFound { fileId :: FileTransferId }
| SEFileNotFound { fileId :: FileTransferId }
| SERcvFileInvalid { fileId :: FileTransferId }
2022-04-05 10:01:08 +04:00
| SESharedMsgIdNotFoundByFileId { fileId :: FileTransferId }
| SEFileIdNotFoundBySharedMsgId { sharedMsgId :: SharedMsgId }
2022-01-27 22:01:15 +00:00
| SEConnectionNotFound { agentConnId :: AgentConnId }
2022-09-14 19:45:21 +04:00
| SEConnectionNotFoundById { connId :: Int64 }
2022-04-23 17:32:40 +01:00
| SEPendingConnectionNotFound { connId :: Int64 }
2021-07-24 10:26:28 +01:00
| SEIntroNotFound
2021-07-12 19:00:03 +01:00
| SEUniqueID
2022-02-07 15:19:34 +04:00
| SEInternalError { message :: String }
2022-01-27 22:01:15 +00:00
| SENoMsgDelivery { connId :: Int64 , agentMsgId :: AgentMsgId }
2022-02-07 15:19:34 +04:00
| SEBadChatItem { itemId :: ChatItemId }
| SEChatItemNotFound { itemId :: ChatItemId }
2022-03-13 19:34:03 +00:00
| SEQuotedChatItemNotFound
2022-03-23 11:37:51 +00:00
| SEChatItemSharedMsgIdNotFound { sharedMsgId :: SharedMsgId }
2022-04-15 09:36:38 +04:00
| SEChatItemNotFoundByFileId { fileId :: FileTransferId }
2022-07-15 17:49:29 +04:00
| SEChatItemNotFoundByGroupId { groupId :: GroupId }
2022-08-18 11:35:31 +04:00
| SEProfileNotFound { profileId :: Int64 }
2022-10-13 17:12:22 +04:00
| SEDuplicateGroupLink { groupInfo :: GroupInfo }
| SEGroupLinkNotFound { groupInfo :: GroupInfo }
2022-11-03 14:46:36 +04:00
| SEHostMemberIdNotFound { groupId :: Int64 }
2022-01-26 21:20:08 +00:00
deriving ( Show , Exception , Generic )
instance ToJSON StoreError where
2022-01-29 20:21:37 +00:00
toJSON = J . genericToJSON . sumTypeJSON $ dropPrefix " SE "
toEncoding = J . genericToEncoding . sumTypeJSON $ dropPrefix " SE "