mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-03-14 09:45:42 +00:00
621b291da1
* core: member mentions, types and rfc * update * update rfc * save/get mentions (WIP) * markdown * store received mentions and userMention flag * sent mentions * update message with mentions * db queries * CLI mentions, test passes * use maps for mentions * tests * comment * save mentions on sent messages * postresql schema * refactor * M.empty * include both displayName and localAlias into MentionedMemberInfo * fix saving sent mentions * include mentions in previews * update plans
696 lines
33 KiB
Haskell
696 lines
33 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE DeriveAnyClass #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PatternSynonyms #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
|
|
|
module Simplex.Chat.Store.Shared where
|
|
|
|
import Control.Exception (Exception)
|
|
import qualified Control.Exception as E
|
|
import Control.Monad
|
|
import Control.Monad.Except
|
|
import Control.Monad.IO.Class
|
|
import Crypto.Random (ChaChaDRG)
|
|
import qualified Data.Aeson.TH as J
|
|
import qualified Data.ByteString.Base64 as B64
|
|
import Data.ByteString.Char8 (ByteString)
|
|
import Data.Int (Int64)
|
|
import Data.Maybe (fromMaybe, isJust, listToMaybe)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import Data.Time.Clock (UTCTime (..), getCurrentTime)
|
|
import Simplex.Chat.Messages
|
|
import Simplex.Chat.Protocol
|
|
import Simplex.Chat.Remote.Types
|
|
import Simplex.Chat.Types
|
|
import Simplex.Chat.Types.Preferences
|
|
import Simplex.Chat.Types.Shared
|
|
import Simplex.Chat.Types.UITheme
|
|
import Simplex.Messaging.Agent.Protocol (ConnId, UserId)
|
|
import Simplex.Messaging.Agent.Store.AgentStore (firstRow, maybeFirstRow)
|
|
import Simplex.Messaging.Agent.Store.DB (BoolInt (..))
|
|
import qualified Simplex.Messaging.Agent.Store.DB as DB
|
|
import qualified Simplex.Messaging.Crypto as C
|
|
import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..))
|
|
import qualified Simplex.Messaging.Crypto.Ratchet as CR
|
|
import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
|
|
import Simplex.Messaging.Protocol (SubscriptionMode (..))
|
|
import Simplex.Messaging.Util (allFinally)
|
|
import Simplex.Messaging.Version
|
|
import UnliftIO.STM
|
|
#if defined(dbPostgres)
|
|
import Database.PostgreSQL.Simple (Only (..), Query, SqlError, (:.) (..))
|
|
import Database.PostgreSQL.Simple.Errors (constraintViolation)
|
|
import Database.PostgreSQL.Simple.SqlQQ (sql)
|
|
#else
|
|
import Database.SQLite.Simple (Only (..), Query, SQLError, (:.) (..))
|
|
import qualified Database.SQLite.Simple as SQL
|
|
import Database.SQLite.Simple.QQ (sql)
|
|
#endif
|
|
|
|
data ChatLockEntity
|
|
= CLInvitation ByteString
|
|
| CLConnection Int64
|
|
| CLContact ContactId
|
|
| CLGroup GroupId
|
|
| CLUserContact Int64
|
|
| CLFile Int64
|
|
deriving (Eq, Ord)
|
|
|
|
-- These error type constructors must be added to mobile apps
|
|
data StoreError
|
|
= SEDuplicateName
|
|
| SEUserNotFound {userId :: UserId}
|
|
| SEUserNotFoundByName {contactName :: ContactName}
|
|
| SEUserNotFoundByContactId {contactId :: ContactId}
|
|
| SEUserNotFoundByGroupId {groupId :: GroupId}
|
|
| SEUserNotFoundByFileId {fileId :: FileTransferId}
|
|
| SEUserNotFoundByContactRequestId {contactRequestId :: Int64}
|
|
| SEContactNotFound {contactId :: ContactId}
|
|
| SEContactNotFoundByName {contactName :: ContactName}
|
|
| SEContactNotFoundByMemberId {groupMemberId :: GroupMemberId}
|
|
| SEContactNotReady {contactName :: ContactName}
|
|
| SEDuplicateContactLink
|
|
| SEUserContactLinkNotFound
|
|
| SEContactRequestNotFound {contactRequestId :: Int64}
|
|
| SEContactRequestNotFoundByName {contactName :: ContactName}
|
|
| SEGroupNotFound {groupId :: GroupId}
|
|
| SEGroupNotFoundByName {groupName :: GroupName}
|
|
| SEGroupMemberNameNotFound {groupId :: GroupId, groupMemberName :: ContactName}
|
|
| SEGroupMemberNotFound {groupMemberId :: GroupMemberId}
|
|
| SEGroupMemberNotFoundByMemberId {memberId :: MemberId}
|
|
| SEMemberContactGroupMemberNotFound {contactId :: ContactId}
|
|
| SEGroupWithoutUser
|
|
| SEDuplicateGroupMember
|
|
| SEGroupAlreadyJoined
|
|
| SEGroupInvitationNotFound
|
|
| SENoteFolderAlreadyExists {noteFolderId :: NoteFolderId}
|
|
| SENoteFolderNotFound {noteFolderId :: NoteFolderId}
|
|
| SEUserNoteFolderNotFound
|
|
| SESndFileNotFound {fileId :: FileTransferId}
|
|
| SESndFileInvalid {fileId :: FileTransferId}
|
|
| SERcvFileNotFound {fileId :: FileTransferId}
|
|
| SERcvFileDescrNotFound {fileId :: FileTransferId}
|
|
| SEFileNotFound {fileId :: FileTransferId}
|
|
| SERcvFileInvalid {fileId :: FileTransferId}
|
|
| SERcvFileInvalidDescrPart
|
|
| SELocalFileNoTransfer {fileId :: FileTransferId}
|
|
| SESharedMsgIdNotFoundByFileId {fileId :: FileTransferId}
|
|
| SEFileIdNotFoundBySharedMsgId {sharedMsgId :: SharedMsgId}
|
|
| SESndFileNotFoundXFTP {agentSndFileId :: AgentSndFileId}
|
|
| SERcvFileNotFoundXFTP {agentRcvFileId :: AgentRcvFileId}
|
|
| SEConnectionNotFound {agentConnId :: AgentConnId}
|
|
| SEConnectionNotFoundById {connId :: Int64}
|
|
| SEConnectionNotFoundByMemberId {groupMemberId :: GroupMemberId}
|
|
| SEPendingConnectionNotFound {connId :: Int64}
|
|
| SEIntroNotFound
|
|
| SEUniqueID
|
|
| SELargeMsg
|
|
| SEInternalError {message :: String}
|
|
| SEDBException {message :: String}
|
|
| SEDBBusyError {message :: String}
|
|
| SEBadChatItem {itemId :: ChatItemId, itemTs :: Maybe ChatItemTs}
|
|
| SEChatItemNotFound {itemId :: ChatItemId}
|
|
| SEChatItemNotFoundByText {text :: Text}
|
|
| SEChatItemSharedMsgIdNotFound {sharedMsgId :: SharedMsgId}
|
|
| SEChatItemNotFoundByFileId {fileId :: FileTransferId}
|
|
| SEChatItemNotFoundByContactId {contactId :: ContactId}
|
|
| SEChatItemNotFoundByGroupId {groupId :: GroupId}
|
|
| SEProfileNotFound {profileId :: Int64}
|
|
| SEDuplicateGroupLink {groupInfo :: GroupInfo}
|
|
| SEGroupLinkNotFound {groupInfo :: GroupInfo}
|
|
| SEHostMemberIdNotFound {groupId :: Int64}
|
|
| SEContactNotFoundByFileId {fileId :: FileTransferId}
|
|
| SENoGroupSndStatus {itemId :: ChatItemId, groupMemberId :: GroupMemberId}
|
|
| SEDuplicateGroupMessage {groupId :: Int64, sharedMsgId :: SharedMsgId, authorGroupMemberId :: Maybe GroupMemberId, forwardedByGroupMemberId :: Maybe GroupMemberId}
|
|
| SERemoteHostNotFound {remoteHostId :: RemoteHostId}
|
|
| SERemoteHostUnknown -- attempting to store KnownHost without a known fingerprint
|
|
| SERemoteHostDuplicateCA
|
|
| SERemoteCtrlNotFound {remoteCtrlId :: RemoteCtrlId}
|
|
| SERemoteCtrlDuplicateCA
|
|
| SEProhibitedDeleteUser {userId :: UserId, contactId :: ContactId}
|
|
| SEOperatorNotFound {serverOperatorId :: Int64}
|
|
| SEUsageConditionsNotFound
|
|
| SEInvalidQuote
|
|
| SEInvalidMention
|
|
deriving (Show, Exception)
|
|
|
|
$(J.deriveJSON (sumTypeJSON $ dropPrefix "SE") ''StoreError)
|
|
|
|
insertedRowId :: DB.Connection -> IO Int64
|
|
insertedRowId db = fromOnly . head <$> DB.query_ db q
|
|
where
|
|
#if defined(dbPostgres)
|
|
q = "SELECT lastval()"
|
|
#else
|
|
q = "SELECT last_insert_rowid()"
|
|
#endif
|
|
|
|
checkConstraint :: StoreError -> ExceptT StoreError IO a -> ExceptT StoreError IO a
|
|
checkConstraint err action = ExceptT $ runExceptT action `E.catch` (pure . Left . handleSQLError err)
|
|
|
|
#if defined(dbPostgres)
|
|
type SQLError = SqlError
|
|
#endif
|
|
|
|
constraintError :: SQLError -> Bool
|
|
#if defined(dbPostgres)
|
|
constraintError = isJust . constraintViolation
|
|
#else
|
|
constraintError e = SQL.sqlError e == SQL.ErrorConstraint
|
|
#endif
|
|
{-# INLINE constraintError #-}
|
|
|
|
handleSQLError :: StoreError -> SQLError -> StoreError
|
|
handleSQLError err e
|
|
| constraintError e = err
|
|
| otherwise = SEInternalError $ show e
|
|
|
|
storeFinally :: ExceptT StoreError IO a -> ExceptT StoreError IO b -> ExceptT StoreError IO a
|
|
storeFinally = allFinally mkStoreError
|
|
{-# INLINE storeFinally #-}
|
|
|
|
mkStoreError :: E.SomeException -> StoreError
|
|
mkStoreError = SEInternalError . show
|
|
{-# INLINE mkStoreError #-}
|
|
|
|
fileInfoQuery :: Query
|
|
fileInfoQuery =
|
|
[sql|
|
|
SELECT f.file_id, f.ci_file_status, f.file_path
|
|
FROM chat_items i
|
|
JOIN files f ON f.chat_item_id = i.chat_item_id
|
|
|]
|
|
|
|
toFileInfo :: (Int64, Maybe ACIFileStatus, Maybe FilePath) -> CIFileInfo
|
|
toFileInfo (fileId, fileStatus, filePath) = CIFileInfo {fileId, fileStatus, filePath}
|
|
|
|
type EntityIdsRow = (Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64)
|
|
|
|
type ConnectionRow = (Int64, ConnId, Int, Maybe Int64, Maybe Int64, BoolInt, Maybe GroupLinkId, Maybe Int64, ConnStatus, ConnType, BoolInt, LocalAlias) :. EntityIdsRow :. (UTCTime, Maybe Text, Maybe UTCTime, PQSupport, PQEncryption, Maybe PQEncryption, Maybe PQEncryption, Int, Int, Maybe VersionChat, VersionChat, VersionChat)
|
|
|
|
type MaybeConnectionRow = (Maybe Int64, Maybe ConnId, Maybe Int, Maybe Int64, Maybe Int64, Maybe BoolInt, Maybe GroupLinkId, Maybe Int64, Maybe ConnStatus, Maybe ConnType, Maybe BoolInt, Maybe LocalAlias) :. EntityIdsRow :. (Maybe UTCTime, Maybe Text, Maybe UTCTime, Maybe PQSupport, Maybe PQEncryption, Maybe PQEncryption, Maybe PQEncryption, Maybe Int, Maybe Int, Maybe VersionChat, Maybe VersionChat, Maybe VersionChat)
|
|
|
|
toConnection :: VersionRangeChat -> ConnectionRow -> Connection
|
|
toConnection vr ((connId, acId, connLevel, viaContact, viaUserContactLink, BI viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, BI contactConnInitiated, localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (createdAt, code_, verifiedAt_, pqSupport, pqEncryption, pqSndEnabled, pqRcvEnabled, authErrCounter, quotaErrCounter, chatV, minVer, maxVer)) =
|
|
Connection
|
|
{ connId,
|
|
agentConnId = AgentConnId acId,
|
|
connChatVersion = fromMaybe (vr `peerConnChatVersion` peerChatVRange) chatV,
|
|
peerChatVRange = peerChatVRange,
|
|
connLevel,
|
|
viaContact,
|
|
viaUserContactLink,
|
|
viaGroupLink,
|
|
groupLinkId,
|
|
customUserProfileId,
|
|
connStatus,
|
|
connType,
|
|
contactConnInitiated,
|
|
localAlias,
|
|
entityId = entityId_ connType,
|
|
connectionCode = SecurityCode <$> code_ <*> verifiedAt_,
|
|
pqSupport,
|
|
pqEncryption,
|
|
pqSndEnabled,
|
|
pqRcvEnabled,
|
|
authErrCounter,
|
|
quotaErrCounter,
|
|
createdAt
|
|
}
|
|
where
|
|
peerChatVRange = fromMaybe (versionToRange maxVer) $ safeVersionRange minVer maxVer
|
|
entityId_ :: ConnType -> Maybe Int64
|
|
entityId_ ConnContact = contactId
|
|
entityId_ ConnMember = groupMemberId
|
|
entityId_ ConnRcvFile = rcvFileId
|
|
entityId_ ConnSndFile = sndFileId
|
|
entityId_ ConnUserContact = userContactLinkId
|
|
|
|
toMaybeConnection :: VersionRangeChat -> MaybeConnectionRow -> Maybe Connection
|
|
toMaybeConnection vr ((Just connId, Just agentConnId, Just connLevel, viaContact, viaUserContactLink, Just viaGroupLink, groupLinkId, customUserProfileId, Just connStatus, Just connType, Just contactConnInitiated, Just localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (Just createdAt, code_, verifiedAt_, Just pqSupport, Just pqEncryption, pqSndEnabled_, pqRcvEnabled_, Just authErrCounter, Just quotaErrCounter, connChatVersion, Just minVer, Just maxVer)) =
|
|
Just $ toConnection vr ((connId, agentConnId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, contactConnInitiated, localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (createdAt, code_, verifiedAt_, pqSupport, pqEncryption, pqSndEnabled_, pqRcvEnabled_, authErrCounter, quotaErrCounter, connChatVersion, minVer, maxVer))
|
|
toMaybeConnection _ _ = Nothing
|
|
|
|
createConnection_ :: DB.Connection -> UserId -> ConnType -> Maybe Int64 -> ConnId -> ConnStatus -> VersionChat -> VersionRangeChat -> Maybe ContactId -> Maybe Int64 -> Maybe ProfileId -> Int -> UTCTime -> SubscriptionMode -> PQSupport -> IO Connection
|
|
createConnection_ db userId connType entityId acId connStatus connChatVersion peerChatVRange@(VersionRange minV maxV) viaContact viaUserContactLink customUserProfileId connLevel currentTs subMode pqSup = do
|
|
viaLinkGroupId :: Maybe Int64 <- fmap join . forM viaUserContactLink $ \ucLinkId ->
|
|
maybeFirstRow fromOnly $ DB.query db "SELECT group_id FROM user_contact_links WHERE user_id = ? AND user_contact_link_id = ? AND group_id IS NOT NULL" (userId, ucLinkId)
|
|
let viaGroupLink = isJust viaLinkGroupId
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
INSERT INTO connections (
|
|
user_id, agent_conn_id, conn_level, via_contact, via_user_contact_link, via_group_link, custom_user_profile_id, conn_status, conn_type,
|
|
contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at, updated_at,
|
|
conn_chat_version, peer_chat_min_version, peer_chat_max_version, to_subscribe, pq_support, pq_encryption
|
|
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
|
|]
|
|
( (userId, acId, connLevel, viaContact, viaUserContactLink, BI viaGroupLink, customUserProfileId, connStatus, connType)
|
|
:. (ent ConnContact, ent ConnMember, ent ConnSndFile, ent ConnRcvFile, ent ConnUserContact, currentTs, currentTs)
|
|
:. (connChatVersion, minV, maxV, BI (subMode == SMOnlyCreate), pqSup, pqSup)
|
|
)
|
|
connId <- insertedRowId db
|
|
pure
|
|
Connection
|
|
{ connId,
|
|
agentConnId = AgentConnId acId,
|
|
connChatVersion,
|
|
peerChatVRange,
|
|
connType,
|
|
contactConnInitiated = False,
|
|
entityId,
|
|
viaContact,
|
|
viaUserContactLink,
|
|
viaGroupLink,
|
|
groupLinkId = Nothing,
|
|
customUserProfileId,
|
|
connLevel,
|
|
connStatus,
|
|
localAlias = "",
|
|
createdAt = currentTs,
|
|
connectionCode = Nothing,
|
|
pqSupport = pqSup,
|
|
pqEncryption = CR.pqSupportToEnc pqSup,
|
|
pqSndEnabled = Nothing,
|
|
pqRcvEnabled = Nothing,
|
|
authErrCounter = 0,
|
|
quotaErrCounter = 0
|
|
}
|
|
where
|
|
ent ct = if connType == ct then entityId else Nothing
|
|
|
|
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 (BI True), createdAt, createdAt)
|
|
insertedRowId db
|
|
|
|
updateConnSupportPQ :: DB.Connection -> Int64 -> PQSupport -> PQEncryption -> IO ()
|
|
updateConnSupportPQ db connId pqSup pqEnc =
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
UPDATE connections
|
|
SET pq_support = ?, pq_encryption = ?
|
|
WHERE connection_id = ?
|
|
|]
|
|
(pqSup, pqEnc, connId)
|
|
|
|
updateConnPQSndEnabled :: DB.Connection -> Int64 -> PQEncryption -> IO ()
|
|
updateConnPQSndEnabled db connId pqSndEnabled =
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
UPDATE connections
|
|
SET pq_snd_enabled = ?
|
|
WHERE connection_id = ?
|
|
|]
|
|
(pqSndEnabled, connId)
|
|
|
|
updateConnPQRcvEnabled :: DB.Connection -> Int64 -> PQEncryption -> IO ()
|
|
updateConnPQRcvEnabled db connId pqRcvEnabled =
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
UPDATE connections
|
|
SET pq_rcv_enabled = ?
|
|
WHERE connection_id = ?
|
|
|]
|
|
(pqRcvEnabled, connId)
|
|
|
|
updateConnPQEnabledCON :: DB.Connection -> Int64 -> PQEncryption -> IO ()
|
|
updateConnPQEnabledCON db connId pqEnabled =
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
UPDATE connections
|
|
SET pq_snd_enabled = ?, pq_rcv_enabled = ?
|
|
WHERE connection_id = ?
|
|
|]
|
|
(pqEnabled, pqEnabled, connId)
|
|
|
|
setPeerChatVRange :: DB.Connection -> Int64 -> VersionChat -> VersionRangeChat -> IO ()
|
|
setPeerChatVRange db connId chatV (VersionRange minVer maxVer) =
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
UPDATE connections
|
|
SET conn_chat_version = ?, peer_chat_min_version = ?, peer_chat_max_version = ?
|
|
WHERE connection_id = ?
|
|
|]
|
|
(chatV, minVer, maxVer, connId)
|
|
|
|
setMemberChatVRange :: DB.Connection -> GroupMemberId -> VersionRangeChat -> IO ()
|
|
setMemberChatVRange db mId (VersionRange minVer maxVer) =
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
UPDATE group_members
|
|
SET peer_chat_min_version = ?, peer_chat_max_version = ?
|
|
WHERE group_member_id = ?
|
|
|]
|
|
(minVer, maxVer, mId)
|
|
|
|
setCommandConnId :: DB.Connection -> User -> CommandId -> Int64 -> IO ()
|
|
setCommandConnId db User {userId} cmdId connId = do
|
|
updatedAt <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
UPDATE commands
|
|
SET connection_id = ?, updated_at = ?
|
|
WHERE user_id = ? AND command_id = ?
|
|
|]
|
|
(connId, updatedAt, userId, cmdId)
|
|
|
|
createContact :: DB.Connection -> User -> Profile -> ExceptT StoreError IO ()
|
|
createContact db User {userId} profile = do
|
|
currentTs <- liftIO getCurrentTime
|
|
void $ createContact_ db userId profile "" Nothing currentTs True
|
|
|
|
createContact_ :: DB.Connection -> UserId -> Profile -> LocalAlias -> Maybe Int64 -> UTCTime -> Bool -> ExceptT StoreError IO (Text, ContactId, ProfileId)
|
|
createContact_ db userId Profile {displayName, fullName, image, contactLink, preferences} localAlias viaGroup currentTs contactUsed =
|
|
ExceptT . withLocalDisplayName db userId displayName $ \ldn -> do
|
|
DB.execute
|
|
db
|
|
"INSERT INTO contact_profiles (display_name, full_name, image, contact_link, user_id, local_alias, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
|
|
(displayName, fullName, image, contactLink, userId, localAlias, preferences, currentTs, currentTs)
|
|
profileId <- insertedRowId db
|
|
DB.execute
|
|
db
|
|
"INSERT INTO contacts (contact_profile_id, local_display_name, user_id, via_group, created_at, updated_at, chat_ts, contact_used) VALUES (?,?,?,?,?,?,?,?)"
|
|
(profileId, ldn, userId, viaGroup, currentTs, currentTs, currentTs, BI contactUsed)
|
|
contactId <- insertedRowId db
|
|
pure $ Right (ldn, contactId, profileId)
|
|
|
|
deleteUnusedIncognitoProfileById_ :: DB.Connection -> User -> ProfileId -> IO ()
|
|
deleteUnusedIncognitoProfileById_ db User {userId} profileId =
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
DELETE FROM contact_profiles
|
|
WHERE user_id = ? AND contact_profile_id = ? AND incognito = 1
|
|
AND 1 NOT IN (
|
|
SELECT 1 FROM connections
|
|
WHERE user_id = ? AND custom_user_profile_id = ? LIMIT 1
|
|
)
|
|
AND 1 NOT IN (
|
|
SELECT 1 FROM group_members
|
|
WHERE user_id = ? AND member_profile_id = ? LIMIT 1
|
|
)
|
|
|]
|
|
(userId, profileId, userId, profileId, userId, profileId)
|
|
|
|
type ContactRow' = (ProfileId, ContactName, Maybe Int64, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, BoolInt, ContactStatus) :. (Maybe MsgFilter, Maybe BoolInt, BoolInt, Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime) :. (Maybe GroupMemberId, BoolInt, Maybe UIThemeEntityOverrides, BoolInt, Maybe CustomData, Maybe Int64)
|
|
|
|
type ContactRow = Only ContactId :. ContactRow'
|
|
|
|
toContact :: VersionRangeChat -> User -> [ChatTagId] -> ContactRow :. MaybeConnectionRow -> Contact
|
|
toContact vr user chatTags ((Only contactId :. (profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, BI contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, BI favorite, preferences, userPreferences, createdAt, updatedAt, chatTs) :. (contactGroupMemberId, BI contactGrpInvSent, uiThemes, BI chatDeleted, customData, chatItemTTL)) :. connRow) =
|
|
let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias}
|
|
activeConn = toMaybeConnection vr connRow
|
|
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts = unBI <$> sendRcpts, favorite}
|
|
incognito = maybe False connIncognito activeConn
|
|
mergedPreferences = contactUserPreferences user userPreferences preferences incognito
|
|
in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent, chatTags, chatItemTTL, uiThemes, chatDeleted, customData}
|
|
|
|
getProfileById :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO LocalProfile
|
|
getProfileById db userId profileId =
|
|
ExceptT . firstRow toProfile (SEProfileNotFound profileId) $
|
|
DB.query
|
|
db
|
|
[sql|
|
|
SELECT cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, cp.preferences -- , ct.user_preferences
|
|
FROM contact_profiles cp
|
|
WHERE cp.user_id = ? AND cp.contact_profile_id = ?
|
|
|]
|
|
(userId, profileId)
|
|
where
|
|
toProfile :: (ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Preferences) -> LocalProfile
|
|
toProfile (displayName, fullName, image, contactLink, localAlias, preferences) = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias}
|
|
|
|
type ContactRequestRow = (Int64, ContactName, AgentInvId, Maybe ContactId, Int64, AgentConnId, Int64, ContactName, Text, Maybe ImageData, Maybe ConnReqContact) :. (Maybe XContactId, PQSupport, Maybe Preferences, UTCTime, UTCTime, VersionChat, VersionChat)
|
|
|
|
toContactRequest :: ContactRequestRow -> UserContactRequest
|
|
toContactRequest ((contactRequestId, localDisplayName, agentInvitationId, contactId_, userContactLinkId, agentContactConnId, profileId, displayName, fullName, image, contactLink) :. (xContactId, pqSupport, preferences, createdAt, updatedAt, minVer, maxVer)) = do
|
|
let profile = Profile {displayName, fullName, image, contactLink, preferences}
|
|
cReqChatVRange = fromMaybe (versionToRange maxVer) $ safeVersionRange minVer maxVer
|
|
in UserContactRequest {contactRequestId, agentInvitationId, contactId_, userContactLinkId, agentContactConnId, cReqChatVRange, localDisplayName, profileId, profile, xContactId, pqSupport, createdAt, updatedAt}
|
|
|
|
userQuery :: Query
|
|
userQuery =
|
|
[sql|
|
|
SELECT u.user_id, u.agent_user_id, u.contact_id, ucp.contact_profile_id, u.active_user, u.active_order, u.local_display_name, ucp.full_name, ucp.image, ucp.contact_link, ucp.preferences,
|
|
u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.ui_themes
|
|
FROM users u
|
|
JOIN contacts uct ON uct.contact_id = u.contact_id
|
|
JOIN contact_profiles ucp ON ucp.contact_profile_id = uct.contact_profile_id
|
|
|]
|
|
|
|
toUser :: (UserId, UserId, ContactId, ProfileId, BoolInt, Int64, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, Maybe Preferences) :. (BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString, Maybe B64UrlByteString, Maybe UTCTime, Maybe UIThemeEntityOverrides) -> User
|
|
toUser ((userId, auId, userContactId, profileId, BI activeUser, activeOrder, displayName, fullName, image, contactLink, userPreferences) :. (BI showNtfs, BI sendRcptsContacts, BI sendRcptsSmallGroups, viewPwdHash_, viewPwdSalt_, userMemberProfileUpdatedAt, uiThemes)) =
|
|
User {userId, agentUserId = AgentUserId auId, userContactId, localDisplayName = displayName, profile, activeUser, activeOrder, fullPreferences, showNtfs, sendRcptsContacts, sendRcptsSmallGroups, viewPwdHash, userMemberProfileUpdatedAt, uiThemes}
|
|
where
|
|
profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences = userPreferences, localAlias = ""}
|
|
fullPreferences = mergePreferences Nothing userPreferences
|
|
viewPwdHash = UserPwdHash <$> viewPwdHash_ <*> viewPwdSalt_
|
|
|
|
toPendingContactConnection :: (Int64, ConnId, ConnStatus, Maybe ByteString, Maybe Int64, Maybe GroupLinkId, Maybe Int64, Maybe ConnReqInvitation, LocalAlias, UTCTime, UTCTime) -> PendingContactConnection
|
|
toPendingContactConnection (pccConnId, acId, pccConnStatus, connReqHash, viaUserContactLink, groupLinkId, customUserProfileId, connReqInv, localAlias, createdAt, updatedAt) =
|
|
PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = isJust connReqHash, viaUserContactLink, groupLinkId, customUserProfileId, connReqInv, localAlias, createdAt, updatedAt}
|
|
|
|
getConnReqInv :: DB.Connection -> Int64 -> ExceptT StoreError IO ConnReqInvitation
|
|
getConnReqInv db connId =
|
|
ExceptT . firstRow fromOnly (SEConnectionNotFoundById connId) $
|
|
DB.query
|
|
db
|
|
"SELECT conn_req_inv FROM connections WHERE connection_id = ?"
|
|
(Only connId)
|
|
|
|
-- | Saves unique local display name based on passed displayName, suffixed with _N if required.
|
|
-- This function should be called inside transaction.
|
|
withLocalDisplayName :: forall a. DB.Connection -> UserId -> Text -> (Text -> IO (Either StoreError a)) -> IO (Either StoreError a)
|
|
withLocalDisplayName db userId displayName action = getLdnSuffix >>= (`tryCreateName` 20)
|
|
where
|
|
getLdnSuffix :: IO Int
|
|
getLdnSuffix =
|
|
maybe 0 ((+ 1) . fromOnly) . listToMaybe
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT ldn_suffix FROM display_names
|
|
WHERE user_id = ? AND ldn_base = ?
|
|
ORDER BY ldn_suffix DESC
|
|
LIMIT 1
|
|
|]
|
|
(userId, displayName)
|
|
tryCreateName :: Int -> Int -> IO (Either StoreError a)
|
|
tryCreateName _ 0 = pure $ Left SEDuplicateName
|
|
tryCreateName ldnSuffix attempts = do
|
|
currentTs <- getCurrentTime
|
|
let ldn = displayName <> (if ldnSuffix == 0 then "" else T.pack $ '_' : show ldnSuffix)
|
|
E.try (insertName ldn currentTs) >>= \case
|
|
Right () -> action ldn
|
|
Left e
|
|
| constraintError e -> tryCreateName (ldnSuffix + 1) (attempts - 1)
|
|
| otherwise -> E.throwIO e
|
|
where
|
|
insertName ldn ts =
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
INSERT INTO display_names
|
|
(local_display_name, ldn_base, ldn_suffix, user_id, created_at, updated_at)
|
|
VALUES (?,?,?,?,?,?)
|
|
|]
|
|
(ldn, displayName, ldnSuffix, userId, ts, ts)
|
|
|
|
createWithRandomId :: forall a. TVar ChaChaDRG -> (ByteString -> IO a) -> ExceptT StoreError IO a
|
|
createWithRandomId = createWithRandomBytes 12
|
|
|
|
createWithRandomId' :: forall a. TVar ChaChaDRG -> (ByteString -> IO (Either StoreError a)) -> ExceptT StoreError IO a
|
|
createWithRandomId' = createWithRandomBytes' 12
|
|
|
|
createWithRandomBytes :: forall a. Int -> TVar ChaChaDRG -> (ByteString -> IO a) -> ExceptT StoreError IO a
|
|
createWithRandomBytes size gVar create = createWithRandomBytes' size gVar (fmap Right . create)
|
|
|
|
createWithRandomBytes' :: forall a. Int -> TVar ChaChaDRG -> (ByteString -> IO (Either StoreError a)) -> ExceptT StoreError IO a
|
|
createWithRandomBytes' size gVar create = tryCreate 3
|
|
where
|
|
tryCreate :: Int -> ExceptT StoreError IO a
|
|
tryCreate 0 = throwError SEUniqueID
|
|
tryCreate n = do
|
|
id' <- liftIO $ encodedRandomBytes gVar size
|
|
liftIO (E.try $ create id') >>= \case
|
|
Right x -> liftEither x
|
|
Left e
|
|
| constraintError e -> tryCreate (n - 1)
|
|
| otherwise -> throwError . SEInternalError $ show e
|
|
|
|
encodedRandomBytes :: TVar ChaChaDRG -> Int -> IO ByteString
|
|
encodedRandomBytes gVar n = atomically $ B64.encode <$> C.randomBytes n gVar
|
|
|
|
assertNotUser :: DB.Connection -> User -> Contact -> ExceptT StoreError IO ()
|
|
assertNotUser db User {userId} Contact {contactId, localDisplayName} = do
|
|
r :: (Maybe Int64) <-
|
|
-- This query checks that the foreign keys in the users table
|
|
-- are not referencing the contact about to be deleted.
|
|
-- With the current schema it would cause cascade delete of user,
|
|
-- with mofified schema (in v5.6.0-beta.0) it would cause foreign key violation error.
|
|
liftIO . maybeFirstRow fromOnly $
|
|
DB.query
|
|
db
|
|
[sql|
|
|
SELECT 1 FROM users
|
|
WHERE (user_id = ? AND local_display_name = ?)
|
|
OR contact_id = ?
|
|
LIMIT 1
|
|
|]
|
|
(userId, localDisplayName, contactId)
|
|
when (isJust r) $ throwError $ SEProhibitedDeleteUser userId contactId
|
|
|
|
safeDeleteLDN :: DB.Connection -> User -> ContactName -> IO ()
|
|
safeDeleteLDN db User {userId} localDisplayName = do
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
DELETE FROM display_names
|
|
WHERE user_id = ? AND local_display_name = ?
|
|
AND local_display_name NOT IN (SELECT local_display_name FROM users WHERE user_id = ?)
|
|
|]
|
|
(userId, localDisplayName, userId)
|
|
|
|
type BusinessChatInfoRow = (Maybe BusinessChatType, Maybe MemberId, Maybe MemberId)
|
|
|
|
type GroupInfoRow = (Int64, GroupName, GroupName, Text, Text, Maybe Text, Maybe ImageData, Maybe ProfileId, Maybe MsgFilter, Maybe BoolInt, BoolInt, Maybe GroupPreferences) :. (UTCTime, UTCTime, Maybe UTCTime, Maybe UTCTime) :. BusinessChatInfoRow :. (Maybe UIThemeEntityOverrides, Maybe CustomData, Maybe Int64) :. GroupMemberRow
|
|
|
|
type GroupMemberRow = ((Int64, Int64, MemberId, VersionChat, VersionChat, GroupMemberRole, GroupMemberCategory, GroupMemberStatus, BoolInt, Maybe MemberRestrictionStatus) :. (Maybe Int64, Maybe GroupMemberId, ContactName, Maybe ContactId, ProfileId, ProfileId, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Preferences))
|
|
|
|
toGroupInfo :: VersionRangeChat -> Int64 -> [ChatTagId] -> GroupInfoRow -> GroupInfo
|
|
toGroupInfo vr userContactId chatTags ((groupId, localDisplayName, displayName, fullName, localAlias, description, image, hostConnCustomUserProfileId, enableNtfs_, sendRcpts, BI favorite, groupPreferences) :. (createdAt, updatedAt, chatTs, userMemberProfileSentAt) :. businessRow :. (uiThemes, customData, chatItemTTL) :. userMemberRow) =
|
|
let membership = (toGroupMember userContactId userMemberRow) {memberChatVRange = vr}
|
|
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts = unBI <$> sendRcpts, favorite}
|
|
fullGroupPreferences = mergeGroupPreferences groupPreferences
|
|
groupProfile = GroupProfile {displayName, fullName, description, image, groupPreferences}
|
|
businessChat = toBusinessChatInfo businessRow
|
|
in GroupInfo {groupId, localDisplayName, groupProfile, localAlias, businessChat, fullGroupPreferences, membership, hostConnCustomUserProfileId, chatSettings, createdAt, updatedAt, chatTs, userMemberProfileSentAt, chatTags, chatItemTTL, uiThemes, customData}
|
|
|
|
toGroupMember :: Int64 -> GroupMemberRow -> GroupMember
|
|
toGroupMember userContactId ((groupMemberId, groupId, memberId, minVer, maxVer, memberRole, memberCategory, memberStatus, BI showMessages, memberRestriction_) :. (invitedById, invitedByGroupMemberId, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, preferences)) =
|
|
let memberProfile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias}
|
|
memberSettings = GroupMemberSettings {showMessages}
|
|
blockedByAdmin = maybe False mrsBlocked memberRestriction_
|
|
invitedBy = toInvitedBy userContactId invitedById
|
|
activeConn = Nothing
|
|
memberChatVRange = fromMaybe (versionToRange maxVer) $ safeVersionRange minVer maxVer
|
|
in GroupMember {..}
|
|
|
|
toBusinessChatInfo :: BusinessChatInfoRow -> Maybe BusinessChatInfo
|
|
toBusinessChatInfo (Just chatType, Just businessId, Just customerId) = Just BusinessChatInfo {chatType, businessId, customerId}
|
|
toBusinessChatInfo _ = Nothing
|
|
|
|
groupInfoQuery :: Query
|
|
groupInfoQuery =
|
|
[sql|
|
|
SELECT
|
|
-- GroupInfo
|
|
g.group_id, g.local_display_name, gp.display_name, gp.full_name, g.local_alias, gp.description, gp.image,
|
|
g.host_conn_custom_user_profile_id, g.enable_ntfs, g.send_rcpts, g.favorite, gp.preferences,
|
|
g.created_at, g.updated_at, g.chat_ts, g.user_member_profile_sent_at, g.business_chat, g.business_member_id, g.customer_member_id, g.ui_themes, g.custom_data, g.chat_item_ttl,
|
|
-- GroupMember - membership
|
|
mu.group_member_id, mu.group_id, mu.member_id, mu.peer_chat_min_version, mu.peer_chat_max_version, mu.member_role, mu.member_category,
|
|
mu.member_status, mu.show_messages, mu.member_restriction, mu.invited_by, mu.invited_by_group_member_id, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id,
|
|
pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences
|
|
FROM groups g
|
|
JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id
|
|
JOIN group_members mu ON mu.group_id = g.group_id
|
|
JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id)
|
|
|]
|
|
|
|
createChatTag :: DB.Connection -> User -> Maybe Text -> Text -> IO ChatTagId
|
|
createChatTag db User {userId} emoji text = do
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
INSERT INTO chat_tags (user_id, chat_tag_emoji, chat_tag_text, tag_order)
|
|
VALUES (?,?,?, COALESCE((SELECT MAX(tag_order) + 1 FROM chat_tags WHERE user_id = ?), 1))
|
|
|]
|
|
(userId, emoji, text, userId)
|
|
insertedRowId db
|
|
|
|
deleteChatTag :: DB.Connection -> User -> ChatTagId -> IO ()
|
|
deleteChatTag db User {userId} tId =
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
DELETE FROM chat_tags
|
|
WHERE user_id = ? AND chat_tag_id = ?
|
|
|]
|
|
(userId, tId)
|
|
|
|
updateChatTag :: DB.Connection -> User -> ChatTagId -> Maybe Text -> Text -> IO ()
|
|
updateChatTag db User {userId} tId emoji text =
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
UPDATE chat_tags
|
|
SET chat_tag_emoji = ?, chat_tag_text = ?
|
|
WHERE user_id = ? AND chat_tag_id = ?
|
|
|]
|
|
(emoji, text, userId, tId)
|
|
|
|
updateChatTagOrder :: DB.Connection -> User -> ChatTagId -> Int -> IO ()
|
|
updateChatTagOrder db User {userId} tId order =
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
UPDATE chat_tags
|
|
SET tag_order = ?
|
|
WHERE user_id = ? AND chat_tag_id = ?
|
|
|]
|
|
(order, userId, tId)
|
|
|
|
reorderChatTags :: DB.Connection -> User -> [ChatTagId] -> IO ()
|
|
reorderChatTags db user tIds =
|
|
forM_ (zip [1 ..] tIds) $ \(order, tId) ->
|
|
updateChatTagOrder db user tId order
|
|
|
|
getUserChatTags :: DB.Connection -> User -> IO [ChatTag]
|
|
getUserChatTags db User {userId} =
|
|
map toChatTag
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT chat_tag_id, chat_tag_emoji, chat_tag_text
|
|
FROM chat_tags
|
|
WHERE user_id = ?
|
|
ORDER BY tag_order
|
|
|]
|
|
(Only userId)
|
|
where
|
|
toChatTag :: (ChatTagId, Maybe Text, Text) -> ChatTag
|
|
toChatTag (chatTagId, chatTagEmoji, chatTagText) = ChatTag {chatTagId, chatTagEmoji, chatTagText}
|
|
|
|
getGroupChatTags :: DB.Connection -> GroupId -> IO [ChatTagId]
|
|
getGroupChatTags db groupId =
|
|
map fromOnly <$> DB.query db "SELECT chat_tag_id FROM chat_tags_chats WHERE group_id = ?" (Only groupId)
|
|
|
|
addGroupChatTags :: DB.Connection -> GroupInfo -> IO GroupInfo
|
|
addGroupChatTags db g@GroupInfo {groupId} = do
|
|
chatTags <- getGroupChatTags db groupId
|
|
pure (g :: GroupInfo) {chatTags}
|