mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-05-26 09:44:55 +00:00
core: split Store.hs to multiple files for faster re-compilation (#2589)
* core: split Store.hs to multiple files for faster re-compilation * remove unused compiler pragmas
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
9fbcc2b5bb
commit
e1370e8f3c
@@ -0,0 +1,689 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Simplex.Chat.Store.Direct
|
||||
( updateContact_,
|
||||
updateContactProfile_,
|
||||
updateContactProfile_',
|
||||
deleteContactProfile_,
|
||||
-- * Contacts and connections functions
|
||||
getPendingContactConnection,
|
||||
deletePendingContactConnection,
|
||||
createDirectConnection,
|
||||
createConnReqConnection,
|
||||
getProfileById,
|
||||
getConnReqContactXContactId,
|
||||
createDirectContact,
|
||||
deleteContactConnectionsAndFiles,
|
||||
deleteContact,
|
||||
deleteContactWithoutGroups,
|
||||
setContactDeleted,
|
||||
getDeletedContacts,
|
||||
getContactByName,
|
||||
getContact,
|
||||
getContactIdByName,
|
||||
updateContactProfile,
|
||||
updateContactUserPreferences,
|
||||
updateContactAlias,
|
||||
updateContactConnectionAlias,
|
||||
updateContactUsed,
|
||||
updateContactUnreadChat,
|
||||
updateGroupUnreadChat,
|
||||
setConnectionVerified,
|
||||
incConnectionAuthErrCounter,
|
||||
setConnectionAuthErrCounter,
|
||||
getUserContacts,
|
||||
createOrUpdateContactRequest,
|
||||
getContactRequest',
|
||||
getContactRequest,
|
||||
getContactRequestIdByName,
|
||||
deleteContactRequest,
|
||||
createAcceptedContact,
|
||||
getUserByContactRequestId,
|
||||
getPendingContactConnections,
|
||||
getContactConnections,
|
||||
getConnectionById,
|
||||
getConnectionsContacts,
|
||||
updateConnectionStatus,
|
||||
updateContactSettings,
|
||||
setConnConnReqInv,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.Except
|
||||
import Data.Either (rights)
|
||||
import Data.Functor (($>))
|
||||
import Data.Int (Int64)
|
||||
import Data.Maybe (fromMaybe, isJust, isNothing)
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock (UTCTime (..), getCurrentTime)
|
||||
import Database.SQLite.Simple (NamedParam (..), Only (..), (:.) (..))
|
||||
import qualified Database.SQLite.Simple as DB
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
import Simplex.Chat.Store.Shared
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent.Protocol (ConnId, InvitationId, UserId)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
|
||||
|
||||
getPendingContactConnection :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO PendingContactConnection
|
||||
getPendingContactConnection db userId connId = do
|
||||
ExceptT . firstRow toPendingContactConnection (SEPendingConnectionNotFound connId) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT connection_id, agent_conn_id, conn_status, via_contact_uri_hash, via_user_contact_link, group_link_id, custom_user_profile_id, conn_req_inv, local_alias, created_at, updated_at
|
||||
FROM connections
|
||||
WHERE user_id = ?
|
||||
AND connection_id = ?
|
||||
AND conn_type = ?
|
||||
AND contact_id IS NULL
|
||||
AND conn_level = 0
|
||||
AND via_contact IS NULL
|
||||
|]
|
||||
(userId, connId, ConnContact)
|
||||
|
||||
deletePendingContactConnection :: DB.Connection -> UserId -> Int64 -> IO ()
|
||||
deletePendingContactConnection db userId connId =
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
DELETE FROM connections
|
||||
WHERE user_id = ?
|
||||
AND connection_id = ?
|
||||
AND conn_type = ?
|
||||
AND contact_id IS NULL
|
||||
AND conn_level = 0
|
||||
AND via_contact IS NULL
|
||||
|]
|
||||
(userId, connId, ConnContact)
|
||||
|
||||
createConnReqConnection :: DB.Connection -> UserId -> ConnId -> ConnReqUriHash -> XContactId -> Maybe Profile -> Maybe GroupLinkId -> IO PendingContactConnection
|
||||
createConnReqConnection db userId acId cReqHash xContactId incognitoProfile groupLinkId = do
|
||||
createdAt <- getCurrentTime
|
||||
customUserProfileId <- mapM (createIncognitoProfile_ db userId createdAt) incognitoProfile
|
||||
let pccConnStatus = ConnJoined
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO connections (
|
||||
user_id, agent_conn_id, conn_status, conn_type,
|
||||
via_contact_uri_hash, xcontact_id, custom_user_profile_id, via_group_link, group_link_id, created_at, updated_at
|
||||
) VALUES (?,?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
((userId, acId, pccConnStatus, ConnContact, cReqHash, xContactId) :. (customUserProfileId, isJust groupLinkId, groupLinkId, createdAt, createdAt))
|
||||
pccConnId <- insertedRowId db
|
||||
pure PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = True, viaUserContactLink = Nothing, groupLinkId, customUserProfileId, connReqInv = Nothing, localAlias = "", createdAt, updatedAt = createdAt}
|
||||
|
||||
getConnReqContactXContactId :: DB.Connection -> User -> ConnReqUriHash -> IO (Maybe Contact, Maybe XContactId)
|
||||
getConnReqContactXContactId db user@User {userId} cReqHash = do
|
||||
getContact' >>= \case
|
||||
c@(Just _) -> pure (c, Nothing)
|
||||
Nothing -> (Nothing,) <$> getXContactId
|
||||
where
|
||||
getContact' :: IO (Maybe Contact)
|
||||
getContact' =
|
||||
maybeFirstRow (toContact user) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT
|
||||
-- Contact
|
||||
ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs,
|
||||
cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts,
|
||||
-- Connection
|
||||
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias,
|
||||
c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter
|
||||
FROM contacts ct
|
||||
JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id
|
||||
JOIN connections c ON c.contact_id = ct.contact_id
|
||||
WHERE ct.user_id = ? AND c.via_contact_uri_hash = ? AND ct.deleted = 0
|
||||
ORDER BY c.connection_id DESC
|
||||
LIMIT 1
|
||||
|]
|
||||
(userId, cReqHash)
|
||||
getXContactId :: IO (Maybe XContactId)
|
||||
getXContactId =
|
||||
maybeFirstRow fromOnly $
|
||||
DB.query
|
||||
db
|
||||
"SELECT xcontact_id FROM connections WHERE user_id = ? AND via_contact_uri_hash = ? LIMIT 1"
|
||||
(userId, cReqHash)
|
||||
|
||||
createDirectConnection :: DB.Connection -> User -> ConnId -> ConnReqInvitation -> ConnStatus -> Maybe Profile -> IO PendingContactConnection
|
||||
createDirectConnection db User {userId} acId cReq pccConnStatus incognitoProfile = do
|
||||
createdAt <- getCurrentTime
|
||||
customUserProfileId <- mapM (createIncognitoProfile_ db userId createdAt) incognitoProfile
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO connections
|
||||
(user_id, agent_conn_id, conn_req_inv, conn_status, conn_type, custom_user_profile_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
(userId, acId, cReq, pccConnStatus, ConnContact, customUserProfileId, createdAt, createdAt)
|
||||
pccConnId <- insertedRowId db
|
||||
pure PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = False, viaUserContactLink = Nothing, groupLinkId = Nothing, customUserProfileId, connReqInv = Just cReq, localAlias = "", createdAt, updatedAt = createdAt}
|
||||
|
||||
createIncognitoProfile_ :: DB.Connection -> UserId -> UTCTime -> Profile -> IO Int64
|
||||
createIncognitoProfile_ db userId createdAt Profile {displayName, fullName, image} = do
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO contact_profiles (display_name, full_name, image, user_id, incognito, created_at, updated_at)
|
||||
VALUES (?,?,?,?,?,?,?)
|
||||
|]
|
||||
(displayName, fullName, image, userId, Just True, createdAt, createdAt)
|
||||
insertedRowId db
|
||||
|
||||
createDirectContact :: DB.Connection -> User -> Connection -> Profile -> ExceptT StoreError IO Contact
|
||||
createDirectContact db user@User {userId} activeConn@Connection {connId, localAlias} p@Profile {preferences} = do
|
||||
createdAt <- liftIO getCurrentTime
|
||||
(localDisplayName, contactId, profileId) <- createContact_ db userId connId p localAlias Nothing createdAt (Just createdAt)
|
||||
let profile = toLocalProfile profileId p localAlias
|
||||
userPreferences = emptyChatPrefs
|
||||
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn
|
||||
pure $ Contact {contactId, localDisplayName, profile, activeConn, viaGroup = Nothing, contactUsed = False, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt, updatedAt = createdAt, chatTs = Just createdAt}
|
||||
|
||||
deleteContactConnectionsAndFiles :: DB.Connection -> UserId -> Contact -> IO ()
|
||||
deleteContactConnectionsAndFiles db userId Contact {contactId} = do
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
DELETE FROM connections WHERE connection_id IN (
|
||||
SELECT connection_id
|
||||
FROM connections c
|
||||
JOIN contacts ct ON ct.contact_id = c.contact_id
|
||||
WHERE ct.user_id = ? AND ct.contact_id = ?
|
||||
)
|
||||
|]
|
||||
(userId, contactId)
|
||||
DB.execute db "DELETE FROM files WHERE user_id = ? AND contact_id = ?" (userId, contactId)
|
||||
|
||||
deleteContact :: DB.Connection -> User -> Contact -> IO ()
|
||||
deleteContact db user@User {userId} Contact {contactId, localDisplayName, activeConn = Connection {customUserProfileId}} = do
|
||||
DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND contact_id = ?" (userId, contactId)
|
||||
ctMember :: (Maybe ContactId) <- maybeFirstRow fromOnly $ DB.query db "SELECT contact_id FROM group_members WHERE user_id = ? AND contact_id = ? LIMIT 1" (userId, contactId)
|
||||
if isNothing ctMember
|
||||
then do
|
||||
deleteContactProfile_ db userId contactId
|
||||
DB.execute db "DELETE FROM display_names WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName)
|
||||
else do
|
||||
currentTs <- getCurrentTime
|
||||
DB.execute db "UPDATE group_members SET contact_id = NULL, updated_at = ? WHERE user_id = ? AND contact_id = ?" (currentTs, userId, contactId)
|
||||
DB.execute db "DELETE FROM contacts WHERE user_id = ? AND contact_id = ?" (userId, contactId)
|
||||
forM_ customUserProfileId $ \profileId -> deleteUnusedIncognitoProfileById_ db user profileId
|
||||
|
||||
-- should only be used if contact is not member of any groups
|
||||
deleteContactWithoutGroups :: DB.Connection -> User -> Contact -> IO ()
|
||||
deleteContactWithoutGroups db user@User {userId} Contact {contactId, localDisplayName, activeConn = Connection {customUserProfileId}} = do
|
||||
DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND contact_id = ?" (userId, contactId)
|
||||
deleteContactProfile_ db userId contactId
|
||||
DB.execute db "DELETE FROM display_names WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName)
|
||||
DB.execute db "DELETE FROM contacts WHERE user_id = ? AND contact_id = ?" (userId, contactId)
|
||||
forM_ customUserProfileId $ \profileId -> deleteUnusedIncognitoProfileById_ db user profileId
|
||||
|
||||
setContactDeleted :: DB.Connection -> User -> Contact -> IO ()
|
||||
setContactDeleted db User {userId} Contact {contactId} = do
|
||||
currentTs <- getCurrentTime
|
||||
DB.execute db "UPDATE contacts SET deleted = 1, updated_at = ? WHERE user_id = ? AND contact_id = ?" (currentTs, userId, contactId)
|
||||
|
||||
getDeletedContacts :: DB.Connection -> User -> IO [Contact]
|
||||
getDeletedContacts db user@User {userId} = do
|
||||
contactIds <- map fromOnly <$> DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND deleted = 1" (Only userId)
|
||||
rights <$> mapM (runExceptT . getDeletedContact db user) contactIds
|
||||
|
||||
getDeletedContact :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO Contact
|
||||
getDeletedContact db user contactId = getContact_ db user contactId True
|
||||
|
||||
deleteContactProfile_ :: DB.Connection -> UserId -> ContactId -> IO ()
|
||||
deleteContactProfile_ db userId contactId =
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
DELETE FROM contact_profiles
|
||||
WHERE contact_profile_id in (
|
||||
SELECT contact_profile_id
|
||||
FROM contacts
|
||||
WHERE user_id = ? AND contact_id = ?
|
||||
)
|
||||
|]
|
||||
(userId, contactId)
|
||||
|
||||
updateContactProfile :: DB.Connection -> User -> Contact -> Profile -> ExceptT StoreError IO Contact
|
||||
updateContactProfile db user@User {userId} c p'
|
||||
| displayName == newName = do
|
||||
liftIO $ updateContactProfile_ db userId profileId p'
|
||||
pure c {profile, mergedPreferences}
|
||||
| otherwise =
|
||||
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
|
||||
currentTs <- getCurrentTime
|
||||
updateContactProfile_' db userId profileId p' currentTs
|
||||
updateContact_ db userId contactId localDisplayName ldn currentTs
|
||||
pure $ Right c {localDisplayName = ldn, profile, mergedPreferences}
|
||||
where
|
||||
Contact {contactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}, activeConn, userPreferences} = c
|
||||
Profile {displayName = newName, preferences} = p'
|
||||
profile = toLocalProfile profileId p' localAlias
|
||||
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn
|
||||
|
||||
updateContactUserPreferences :: DB.Connection -> User -> Contact -> Preferences -> IO Contact
|
||||
updateContactUserPreferences db user@User {userId} c@Contact {contactId, activeConn} userPreferences = do
|
||||
updatedAt <- getCurrentTime
|
||||
DB.execute
|
||||
db
|
||||
"UPDATE contacts SET user_preferences = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?"
|
||||
(userPreferences, updatedAt, userId, contactId)
|
||||
let mergedPreferences = contactUserPreferences user userPreferences (preferences' c) $ connIncognito activeConn
|
||||
pure $ c {mergedPreferences, userPreferences}
|
||||
|
||||
updateContactAlias :: DB.Connection -> UserId -> Contact -> LocalAlias -> IO Contact
|
||||
updateContactAlias db userId c@Contact {profile = lp@LocalProfile {profileId}} localAlias = do
|
||||
updatedAt <- getCurrentTime
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE contact_profiles
|
||||
SET local_alias = ?, updated_at = ?
|
||||
WHERE user_id = ? AND contact_profile_id = ?
|
||||
|]
|
||||
(localAlias, updatedAt, userId, profileId)
|
||||
pure $ (c :: Contact) {profile = lp {localAlias}}
|
||||
|
||||
updateContactConnectionAlias :: DB.Connection -> UserId -> PendingContactConnection -> LocalAlias -> IO PendingContactConnection
|
||||
updateContactConnectionAlias db userId conn localAlias = do
|
||||
updatedAt <- getCurrentTime
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE connections
|
||||
SET local_alias = ?, updated_at = ?
|
||||
WHERE user_id = ? AND connection_id = ?
|
||||
|]
|
||||
(localAlias, updatedAt, userId, pccConnId conn)
|
||||
pure (conn :: PendingContactConnection) {localAlias}
|
||||
|
||||
updateContactUsed :: DB.Connection -> User -> Contact -> IO ()
|
||||
updateContactUsed db User {userId} Contact {contactId} = do
|
||||
updatedAt <- getCurrentTime
|
||||
DB.execute db "UPDATE contacts SET contact_used = 1, updated_at = ? WHERE user_id = ? AND contact_id = ?" (updatedAt, userId, contactId)
|
||||
|
||||
updateContactUnreadChat :: DB.Connection -> User -> Contact -> Bool -> IO ()
|
||||
updateContactUnreadChat db User {userId} Contact {contactId} unreadChat = do
|
||||
updatedAt <- getCurrentTime
|
||||
DB.execute db "UPDATE contacts SET unread_chat = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?" (unreadChat, updatedAt, userId, contactId)
|
||||
|
||||
updateGroupUnreadChat :: DB.Connection -> User -> GroupInfo -> Bool -> IO ()
|
||||
updateGroupUnreadChat db User {userId} GroupInfo {groupId} unreadChat = do
|
||||
updatedAt <- getCurrentTime
|
||||
DB.execute db "UPDATE groups SET unread_chat = ?, updated_at = ? WHERE user_id = ? AND group_id = ?" (unreadChat, updatedAt, userId, groupId)
|
||||
|
||||
setConnectionVerified :: DB.Connection -> User -> Int64 -> Maybe Text -> IO ()
|
||||
setConnectionVerified db User {userId} connId code = do
|
||||
updatedAt <- getCurrentTime
|
||||
DB.execute db "UPDATE connections SET security_code = ?, security_code_verified_at = ?, updated_at = ? WHERE user_id = ? AND connection_id = ?" (code, code $> updatedAt, updatedAt, userId, connId)
|
||||
|
||||
incConnectionAuthErrCounter :: DB.Connection -> User -> Connection -> IO Int
|
||||
incConnectionAuthErrCounter db User {userId} Connection {connId, authErrCounter} = do
|
||||
updatedAt <- getCurrentTime
|
||||
(counter_ :: Maybe Int) <- maybeFirstRow fromOnly $ DB.query db "SELECT auth_err_counter FROM connections WHERE user_id = ? AND connection_id = ?" (userId, connId)
|
||||
let counter' = fromMaybe authErrCounter counter_ + 1
|
||||
DB.execute db "UPDATE connections SET auth_err_counter = ?, updated_at = ? WHERE user_id = ? AND connection_id = ?" (counter', updatedAt, userId, connId)
|
||||
pure counter'
|
||||
|
||||
setConnectionAuthErrCounter :: DB.Connection -> User -> Connection -> Int -> IO ()
|
||||
setConnectionAuthErrCounter db User {userId} Connection {connId} counter = do
|
||||
updatedAt <- getCurrentTime
|
||||
DB.execute db "UPDATE connections SET auth_err_counter = ?, updated_at = ? WHERE user_id = ? AND connection_id = ?" (counter, updatedAt, userId, connId)
|
||||
|
||||
updateContactProfile_ :: DB.Connection -> UserId -> ProfileId -> Profile -> IO ()
|
||||
updateContactProfile_ db userId profileId profile = do
|
||||
currentTs <- getCurrentTime
|
||||
updateContactProfile_' db userId profileId profile currentTs
|
||||
|
||||
updateContactProfile_' :: DB.Connection -> UserId -> ProfileId -> Profile -> UTCTime -> IO ()
|
||||
updateContactProfile_' db userId profileId Profile {displayName, fullName, image, contactLink, preferences} updatedAt = do
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE contact_profiles
|
||||
SET display_name = ?, full_name = ?, image = ?, contact_link = ?, preferences = ?, updated_at = ?
|
||||
WHERE user_id = ? AND contact_profile_id = ?
|
||||
|]
|
||||
(displayName, fullName, image, contactLink, preferences, updatedAt, userId, profileId)
|
||||
|
||||
updateContact_ :: DB.Connection -> UserId -> Int64 -> ContactName -> ContactName -> UTCTime -> IO ()
|
||||
updateContact_ db userId contactId displayName newName updatedAt = do
|
||||
DB.execute
|
||||
db
|
||||
"UPDATE contacts SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?"
|
||||
(newName, updatedAt, userId, contactId)
|
||||
DB.execute
|
||||
db
|
||||
"UPDATE group_members SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?"
|
||||
(newName, updatedAt, userId, contactId)
|
||||
DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (displayName, userId)
|
||||
|
||||
getContactByName :: DB.Connection -> User -> ContactName -> ExceptT StoreError IO Contact
|
||||
getContactByName db user localDisplayName = do
|
||||
cId <- getContactIdByName db user localDisplayName
|
||||
getContact db user cId
|
||||
|
||||
getUserContacts :: DB.Connection -> User -> IO [Contact]
|
||||
getUserContacts db user@User {userId} = do
|
||||
contactIds <- map fromOnly <$> DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND deleted = 0" (Only userId)
|
||||
rights <$> mapM (runExceptT . getContact db user) contactIds
|
||||
|
||||
createOrUpdateContactRequest :: DB.Connection -> User -> Int64 -> InvitationId -> Profile -> Maybe XContactId -> ExceptT StoreError IO ContactOrRequest
|
||||
createOrUpdateContactRequest db user@User {userId} userContactLinkId invId Profile {displayName, fullName, image, contactLink, preferences} xContactId_ =
|
||||
liftIO (maybeM getContact' xContactId_) >>= \case
|
||||
Just contact -> pure $ CORContact contact
|
||||
Nothing -> CORRequest <$> createOrUpdate_
|
||||
where
|
||||
maybeM = maybe (pure Nothing)
|
||||
createOrUpdate_ :: ExceptT StoreError IO UserContactRequest
|
||||
createOrUpdate_ = do
|
||||
cReqId <-
|
||||
ExceptT $
|
||||
maybeM getContactRequestByXContactId xContactId_ >>= \case
|
||||
Nothing -> createContactRequest
|
||||
Just cr -> updateContactRequest cr $> Right (contactRequestId (cr :: UserContactRequest))
|
||||
getContactRequest db user cReqId
|
||||
createContactRequest :: IO (Either StoreError Int64)
|
||||
createContactRequest = do
|
||||
currentTs <- getCurrentTime
|
||||
withLocalDisplayName db userId displayName (fmap Right . createContactRequest_ currentTs)
|
||||
where
|
||||
createContactRequest_ currentTs ldn = do
|
||||
DB.execute
|
||||
db
|
||||
"INSERT INTO contact_profiles (display_name, full_name, image, contact_link, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
|
||||
(displayName, fullName, image, contactLink, userId, preferences, currentTs, currentTs)
|
||||
profileId <- insertedRowId db
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO contact_requests
|
||||
(user_contact_link_id, agent_invitation_id, contact_profile_id, local_display_name, user_id, created_at, updated_at, xcontact_id)
|
||||
VALUES (?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
(userContactLinkId, invId, profileId, ldn, userId, currentTs, currentTs, xContactId_)
|
||||
insertedRowId db
|
||||
getContact' :: XContactId -> IO (Maybe Contact)
|
||||
getContact' xContactId =
|
||||
maybeFirstRow (toContact user) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT
|
||||
-- Contact
|
||||
ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs,
|
||||
cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts,
|
||||
-- Connection
|
||||
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias,
|
||||
c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter
|
||||
FROM contacts ct
|
||||
JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id
|
||||
LEFT JOIN connections c ON c.contact_id = ct.contact_id
|
||||
WHERE ct.user_id = ? AND ct.xcontact_id = ? AND ct.deleted = 0
|
||||
ORDER BY c.connection_id DESC
|
||||
LIMIT 1
|
||||
|]
|
||||
(userId, xContactId)
|
||||
getContactRequestByXContactId :: XContactId -> IO (Maybe UserContactRequest)
|
||||
getContactRequestByXContactId xContactId =
|
||||
maybeFirstRow toContactRequest $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT
|
||||
cr.contact_request_id, cr.local_display_name, cr.agent_invitation_id, cr.user_contact_link_id,
|
||||
c.agent_conn_id, cr.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, cr.xcontact_id, p.preferences, cr.created_at, cr.updated_at
|
||||
FROM contact_requests cr
|
||||
JOIN connections c USING (user_contact_link_id)
|
||||
JOIN contact_profiles p USING (contact_profile_id)
|
||||
WHERE cr.user_id = ?
|
||||
AND cr.xcontact_id = ?
|
||||
LIMIT 1
|
||||
|]
|
||||
(userId, xContactId)
|
||||
updateContactRequest :: UserContactRequest -> IO (Either StoreError ())
|
||||
updateContactRequest UserContactRequest {contactRequestId = cReqId, localDisplayName = oldLdn, profile = Profile {displayName = oldDisplayName}} = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
updateProfile currentTs
|
||||
if displayName == oldDisplayName
|
||||
then Right <$> DB.execute db "UPDATE contact_requests SET agent_invitation_id = ?, updated_at = ? WHERE user_id = ? AND contact_request_id = ?" (invId, currentTs, userId, cReqId)
|
||||
else withLocalDisplayName db userId displayName $ \ldn ->
|
||||
Right <$> do
|
||||
DB.execute db "UPDATE contact_requests SET agent_invitation_id = ?, local_display_name = ?, updated_at = ? WHERE user_id = ? AND contact_request_id = ?" (invId, ldn, currentTs, userId, cReqId)
|
||||
DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (oldLdn, userId)
|
||||
where
|
||||
updateProfile currentTs =
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE contact_profiles
|
||||
SET display_name = ?,
|
||||
full_name = ?,
|
||||
image = ?,
|
||||
contact_link = ?,
|
||||
updated_at = ?
|
||||
WHERE contact_profile_id IN (
|
||||
SELECT contact_profile_id
|
||||
FROM contact_requests
|
||||
WHERE user_id = ?
|
||||
AND contact_request_id = ?
|
||||
)
|
||||
|]
|
||||
(displayName, fullName, image, contactLink, currentTs, userId, cReqId)
|
||||
|
||||
getContactRequest' :: DB.Connection -> Int64 -> ExceptT StoreError IO (User, UserContactRequest)
|
||||
getContactRequest' db contactRequestId = do
|
||||
user <- getUserByContactRequestId db contactRequestId
|
||||
(user,) <$> getContactRequest db user contactRequestId
|
||||
|
||||
getContactRequest :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO UserContactRequest
|
||||
getContactRequest db User {userId} contactRequestId =
|
||||
ExceptT . firstRow toContactRequest (SEContactRequestNotFound contactRequestId) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT
|
||||
cr.contact_request_id, cr.local_display_name, cr.agent_invitation_id, cr.user_contact_link_id,
|
||||
c.agent_conn_id, cr.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, cr.xcontact_id, p.preferences, cr.created_at, cr.updated_at
|
||||
FROM contact_requests cr
|
||||
JOIN connections c USING (user_contact_link_id)
|
||||
JOIN contact_profiles p USING (contact_profile_id)
|
||||
WHERE cr.user_id = ?
|
||||
AND cr.contact_request_id = ?
|
||||
|]
|
||||
(userId, contactRequestId)
|
||||
|
||||
getContactRequestIdByName :: DB.Connection -> UserId -> ContactName -> ExceptT StoreError IO Int64
|
||||
getContactRequestIdByName db userId cName =
|
||||
ExceptT . firstRow fromOnly (SEContactRequestNotFoundByName cName) $
|
||||
DB.query db "SELECT contact_request_id FROM contact_requests WHERE user_id = ? AND local_display_name = ?" (userId, cName)
|
||||
|
||||
deleteContactRequest :: DB.Connection -> User -> Int64 -> IO ()
|
||||
deleteContactRequest db User {userId} contactRequestId = do
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
DELETE FROM contact_profiles
|
||||
WHERE contact_profile_id in (
|
||||
SELECT contact_profile_id
|
||||
FROM contact_requests
|
||||
WHERE user_id = ? AND contact_request_id = ?
|
||||
)
|
||||
|]
|
||||
(userId, contactRequestId)
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
DELETE FROM display_names
|
||||
WHERE user_id = ? AND local_display_name = (
|
||||
SELECT local_display_name FROM contact_requests
|
||||
WHERE user_id = ? AND contact_request_id = ?
|
||||
)
|
||||
|]
|
||||
(userId, userId, contactRequestId)
|
||||
DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND contact_request_id = ?" (userId, contactRequestId)
|
||||
|
||||
createAcceptedContact :: DB.Connection -> User -> ConnId -> ContactName -> ProfileId -> Profile -> Int64 -> Maybe XContactId -> Maybe IncognitoProfile -> IO Contact
|
||||
createAcceptedContact db user@User {userId, profile = LocalProfile {preferences}} agentConnId localDisplayName profileId profile userContactLinkId xContactId incognitoProfile = do
|
||||
DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName)
|
||||
createdAt <- getCurrentTime
|
||||
customUserProfileId <- forM incognitoProfile $ \case
|
||||
NewIncognito p -> createIncognitoProfile_ db userId createdAt p
|
||||
ExistingIncognito LocalProfile {profileId = pId} -> pure pId
|
||||
let userPreferences = fromMaybe emptyChatPrefs $ incognitoProfile >> preferences
|
||||
DB.execute
|
||||
db
|
||||
"INSERT INTO contacts (user_id, local_display_name, contact_profile_id, enable_ntfs, user_preferences, created_at, updated_at, chat_ts, xcontact_id) VALUES (?,?,?,?,?,?,?,?,?)"
|
||||
(userId, localDisplayName, profileId, True, userPreferences, createdAt, createdAt, createdAt, xContactId)
|
||||
contactId <- insertedRowId db
|
||||
activeConn <- createConnection_ db userId ConnContact (Just contactId) agentConnId Nothing (Just userContactLinkId) customUserProfileId 0 createdAt
|
||||
let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn
|
||||
pure $ Contact {contactId, localDisplayName, profile = toLocalProfile profileId profile "", activeConn, viaGroup = Nothing, contactUsed = False, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = createdAt, updatedAt = createdAt, chatTs = Just createdAt}
|
||||
|
||||
getContactIdByName :: DB.Connection -> User -> ContactName -> ExceptT StoreError IO Int64
|
||||
getContactIdByName db User {userId} cName =
|
||||
ExceptT . firstRow fromOnly (SEContactNotFoundByName cName) $
|
||||
DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND local_display_name = ? AND deleted = 0" (userId, cName)
|
||||
|
||||
getContact :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO Contact
|
||||
getContact db user contactId = getContact_ db user contactId False
|
||||
|
||||
getContact_ :: DB.Connection -> User -> Int64 -> Bool -> ExceptT StoreError IO Contact
|
||||
getContact_ db user@User {userId} contactId deleted =
|
||||
ExceptT . fmap join . firstRow (toContactOrError user) (SEContactNotFound contactId) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT
|
||||
-- Contact
|
||||
ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs,
|
||||
cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts,
|
||||
-- Connection
|
||||
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias,
|
||||
c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter
|
||||
FROM contacts ct
|
||||
JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id
|
||||
LEFT JOIN connections c ON c.contact_id = ct.contact_id
|
||||
WHERE ct.user_id = ? AND ct.contact_id = ?
|
||||
AND ct.deleted = ?
|
||||
AND c.connection_id = (
|
||||
SELECT cc_connection_id FROM (
|
||||
SELECT
|
||||
cc.connection_id AS cc_connection_id,
|
||||
(CASE WHEN cc.conn_status = ? OR cc.conn_status = ? THEN 1 ELSE 0 END) AS cc_conn_status_ord
|
||||
FROM connections cc
|
||||
WHERE cc.user_id = ct.user_id AND cc.contact_id = ct.contact_id
|
||||
ORDER BY cc_conn_status_ord DESC, cc_connection_id DESC
|
||||
LIMIT 1
|
||||
)
|
||||
)
|
||||
|]
|
||||
(userId, contactId, deleted, ConnReady, ConnSndReady)
|
||||
|
||||
getUserByContactRequestId :: DB.Connection -> Int64 -> ExceptT StoreError IO User
|
||||
getUserByContactRequestId db contactRequestId =
|
||||
ExceptT . firstRow toUser (SEUserNotFoundByContactRequestId contactRequestId) $
|
||||
DB.query db (userQuery <> " JOIN contact_requests cr ON cr.user_id = u.user_id WHERE cr.contact_request_id = ?") (Only contactRequestId)
|
||||
|
||||
getPendingContactConnections :: DB.Connection -> User -> IO [PendingContactConnection]
|
||||
getPendingContactConnections db User {userId} = do
|
||||
map toPendingContactConnection
|
||||
<$> DB.queryNamed
|
||||
db
|
||||
[sql|
|
||||
SELECT connection_id, agent_conn_id, conn_status, via_contact_uri_hash, via_user_contact_link, group_link_id, custom_user_profile_id, conn_req_inv, local_alias, created_at, updated_at
|
||||
FROM connections
|
||||
WHERE user_id = :user_id
|
||||
AND conn_type = :conn_type
|
||||
AND contact_id IS NULL
|
||||
|]
|
||||
[":user_id" := userId, ":conn_type" := ConnContact]
|
||||
|
||||
getContactConnections :: DB.Connection -> UserId -> Contact -> ExceptT StoreError IO [Connection]
|
||||
getContactConnections db userId Contact {contactId} =
|
||||
connections =<< liftIO getConnections_
|
||||
where
|
||||
getConnections_ =
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id,
|
||||
c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter
|
||||
FROM connections c
|
||||
JOIN contacts ct ON ct.contact_id = c.contact_id
|
||||
WHERE c.user_id = ? AND ct.user_id = ? AND ct.contact_id = ?
|
||||
|]
|
||||
(userId, userId, contactId)
|
||||
connections [] = throwError $ SEContactNotFound contactId
|
||||
connections rows = pure $ map toConnection rows
|
||||
|
||||
|
||||
|
||||
|
||||
getConnectionById :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO Connection
|
||||
getConnectionById db User {userId} connId = ExceptT $ do
|
||||
firstRow toConnection (SEConnectionNotFoundById connId) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT connection_id, agent_conn_id, conn_level, via_contact, via_user_contact_link, via_group_link, group_link_id, custom_user_profile_id,
|
||||
conn_status, conn_type, local_alias, contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at, security_code, security_code_verified_at, auth_err_counter
|
||||
FROM connections
|
||||
WHERE user_id = ? AND connection_id = ?
|
||||
|]
|
||||
(userId, connId)
|
||||
|
||||
getConnectionsContacts :: DB.Connection -> [ConnId] -> IO [ContactRef]
|
||||
getConnectionsContacts db agentConnIds = do
|
||||
DB.execute_ db "DROP TABLE IF EXISTS temp.conn_ids"
|
||||
DB.execute_ db "CREATE TABLE temp.conn_ids (conn_id BLOB)"
|
||||
DB.executeMany db "INSERT INTO temp.conn_ids (conn_id) VALUES (?)" $ map Only agentConnIds
|
||||
conns <-
|
||||
map toContactRef
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT ct.contact_id, c.connection_id, c.agent_conn_id, ct.local_display_name
|
||||
FROM contacts ct
|
||||
JOIN connections c ON c.contact_id = ct.contact_id
|
||||
WHERE c.agent_conn_id IN (SELECT conn_id FROM temp.conn_ids)
|
||||
AND c.conn_type = ?
|
||||
AND ct.deleted = 0
|
||||
|]
|
||||
(Only ConnContact)
|
||||
DB.execute_ db "DROP TABLE temp.conn_ids"
|
||||
pure conns
|
||||
where
|
||||
toContactRef :: (ContactId, Int64, ConnId, ContactName) -> ContactRef
|
||||
toContactRef (contactId, connId, acId, localDisplayName) = ContactRef {contactId, connId, agentConnId = AgentConnId acId, localDisplayName}
|
||||
|
||||
updateConnectionStatus :: DB.Connection -> Connection -> ConnStatus -> IO ()
|
||||
updateConnectionStatus db Connection {connId} connStatus = do
|
||||
currentTs <- getCurrentTime
|
||||
DB.execute db "UPDATE connections SET conn_status = ?, updated_at = ? WHERE connection_id = ?" (connStatus, currentTs, connId)
|
||||
|
||||
updateContactSettings :: DB.Connection -> User -> Int64 -> ChatSettings -> IO ()
|
||||
updateContactSettings db User {userId} contactId ChatSettings {enableNtfs} =
|
||||
DB.execute db "UPDATE contacts SET enable_ntfs = ? WHERE user_id = ? AND contact_id = ?" (enableNtfs, userId, contactId)
|
||||
|
||||
setConnConnReqInv :: DB.Connection -> User -> Int64 -> ConnReqInvitation -> IO ()
|
||||
setConnConnReqInv db User {userId} connId connReq = do
|
||||
updatedAt <- getCurrentTime
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE connections
|
||||
SET conn_req_inv = ?, updated_at = ?
|
||||
WHERE user_id = ? AND connection_id = ?
|
||||
|]
|
||||
(connReq, updatedAt, userId, connId)
|
||||
Reference in New Issue
Block a user