IntenseFinance/simplex-chat
3
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

core: split Store.hs to multiple files for faster re-compilation (#2589)

Browse Source 
* core: split Store.hs to multiple files for faster re-compilation

* remove unused compiler pragmas
This commit is contained in:
Evgeny Poberezkin 2023-06-18 10:20:11 +01:00 committed by GitHub
parent 9fbcc2b5bb
commit e1370e8f3c
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
15 changed files with 5843 additions and 5607 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
simplex-chat.cabal
View File

@ -107,6 +107,14 @@ library
Simplex.Chat.ProfileGenerator Simplex.Chat.ProfileGenerator
Simplex.Chat.Protocol Simplex.Chat.Protocol
Simplex.Chat.Store Simplex.Chat.Store
Simplex.Chat.Store.Connections
Simplex.Chat.Store.Direct
Simplex.Chat.Store.Files
Simplex.Chat.Store.Groups
Simplex.Chat.Store.Messages
Simplex.Chat.Store.Migrations
Simplex.Chat.Store.Profiles
Simplex.Chat.Store.Shared
Simplex.Chat.Styled Simplex.Chat.Styled
Simplex.Chat.Terminal Simplex.Chat.Terminal
Simplex.Chat.Terminal.Input Simplex.Chat.Terminal.Input

7
src/Simplex/Chat.hs
View File

@ -58,6 +58,13 @@ import Simplex.Chat.Options
import Simplex.Chat.ProfileGenerator (generateRandomProfile) import Simplex.Chat.ProfileGenerator (generateRandomProfile)
import Simplex.Chat.Protocol import Simplex.Chat.Protocol
import Simplex.Chat.Store import Simplex.Chat.Store
import Simplex.Chat.Store.Connections
import Simplex.Chat.Store.Direct
import Simplex.Chat.Store.Files
import Simplex.Chat.Store.Groups
import Simplex.Chat.Store.Messages
import Simplex.Chat.Store.Profiles
import Simplex.Chat.Store.Shared
import Simplex.Chat.Types import Simplex.Chat.Types
import Simplex.FileTransfer.Client.Main (maxFileSize) import Simplex.FileTransfer.Client.Main (maxFileSize)
import Simplex.FileTransfer.Client.Presets (defaultXFTPServers) import Simplex.FileTransfer.Client.Presets (defaultXFTPServers)

1
src/Simplex/Chat/Mobile.hs
View File

@ -37,6 +37,7 @@ import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList)
import Simplex.Chat.Mobile.WebRTC import Simplex.Chat.Mobile.WebRTC
import Simplex.Chat.Options import Simplex.Chat.Options
import Simplex.Chat.Store import Simplex.Chat.Store
import Simplex.Chat.Store.Profiles
import Simplex.Chat.Types import Simplex.Chat.Types
import Simplex.Messaging.Agent.Env.SQLite (createAgentStore) import Simplex.Messaging.Agent.Env.SQLite (createAgentStore)
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), MigrationError) import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), MigrationError)

5611
src/Simplex/Chat/Store.hs
View File

File diff suppressed because it is too large Load Diff

142
src/Simplex/Chat/Store/Connections.hs Normal file
View File

@ -0,0 +1,142 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeOperators #-}
module Simplex.Chat.Store.Connections
( getConnectionEntity,
)
where
import Control.Applicative ((<|>))
import Control.Monad.Except
import Data.Int (Int64)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Time.Clock (UTCTime (..))
import Database.SQLite.Simple ((:.) (..))
import qualified Database.SQLite.Simple as DB
import Database.SQLite.Simple.QQ (sql)
import Simplex.Chat.Store.Files
import Simplex.Chat.Store.Groups
import Simplex.Chat.Store.Shared
import Simplex.Chat.Protocol
import Simplex.Chat.Types
import Simplex.Messaging.Agent.Store.SQLite (firstRow, firstRow')
getConnectionEntity :: DB.Connection -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity
getConnectionEntity db user@User {userId, userContactId} agentConnId = do
c@Connection {connType, entityId} <- getConnection_
case entityId of
Nothing ->
if connType == ConnContact
then pure $ RcvDirectMsgConnection c Nothing
else throwError $ SEInternalError $ "connection " <> show connType <> " without entity"
Just entId ->
case connType of
ConnMember -> uncurry (RcvGroupMsgConnection c) <$> getGroupAndMember_ entId c
ConnContact -> RcvDirectMsgConnection c . Just <$> getContactRec_ entId c
ConnSndFile -> SndFileConnection c <$> getConnSndFileTransfer_ entId c
ConnRcvFile -> RcvFileConnection c <$> getRcvFileTransfer db user entId
ConnUserContact -> UserContactConnection c <$> getUserContact_ entId
where
getConnection_ :: ExceptT StoreError IO Connection
getConnection_ = ExceptT $ do
firstRow toConnection (SEConnectionNotFound agentConnId) $
DB.query
db
[sql|
SELECT connection_id, agent_conn_id, conn_level, via_contact, via_user_contact_link, via_group_link, group_link_id, custom_user_profile_id,
conn_status, conn_type, local_alias, contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at, security_code, security_code_verified_at, auth_err_counter
FROM connections
WHERE user_id = ? AND agent_conn_id = ?
|]
(userId, agentConnId)
getContactRec_ :: Int64 -> Connection -> ExceptT StoreError IO Contact
getContactRec_ contactId c = ExceptT $ do
toContact' contactId c
<$> DB.query
db
[sql|
SELECT
c.contact_profile_id, c.local_display_name, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, c.via_group, c.contact_used, c.enable_ntfs,
p.preferences, c.user_preferences, c.created_at, c.updated_at, c.chat_ts
FROM contacts c
JOIN contact_profiles p ON c.contact_profile_id = p.contact_profile_id
WHERE c.user_id = ? AND c.contact_id = ? AND c.deleted = 0
|]
(userId, contactId)
toContact' :: Int64 -> Connection -> [(ProfileId, ContactName, Text, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Int64, Bool, Maybe Bool) :. (Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime)] -> Either StoreError Contact
toContact' contactId activeConn [(profileId, localDisplayName, displayName, fullName, image, contactLink, localAlias, viaGroup, contactUsed, enableNtfs_) :. (preferences, userPreferences, createdAt, updatedAt, chatTs)] =
let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias}
chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_}
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn
in Right Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs}
toContact' _ _ _ = Left $ SEInternalError "referenced contact not found"
getGroupAndMember_ :: Int64 -> Connection -> ExceptT StoreError IO (GroupInfo, GroupMember)
getGroupAndMember_ groupMemberId c = ExceptT $ do
firstRow (toGroupAndMember c) (SEInternalError "referenced group member not found") $
DB.query
db
[sql|
SELECT
-- GroupInfo
g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, g.chat_ts,
-- GroupInfo {membership}
mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category,
mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id,
-- GroupInfo {membership = GroupMember {memberProfile}}
pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences,
-- from GroupMember
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status,
m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences
FROM group_members m
JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id)
JOIN groups g ON g.group_id = m.group_id
JOIN group_profiles gp USING (group_profile_id)
JOIN group_members mu ON g.group_id = mu.group_id
JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id)
WHERE m.group_member_id = ? AND g.user_id = ? AND mu.contact_id = ?
|]
(groupMemberId, userId, userContactId)
toGroupAndMember :: Connection -> GroupInfoRow :. GroupMemberRow -> (GroupInfo, GroupMember)
toGroupAndMember c (groupInfoRow :. memberRow) =
let groupInfo = toGroupInfo userContactId groupInfoRow
member = toGroupMember userContactId memberRow
in (groupInfo, (member :: GroupMember) {activeConn = Just c})
getConnSndFileTransfer_ :: Int64 -> Connection -> ExceptT StoreError IO SndFileTransfer
getConnSndFileTransfer_ fileId Connection {connId} =
ExceptT $
firstRow' (sndFileTransfer_ fileId connId) (SESndFileNotFound fileId) $
DB.query
db
[sql|
SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.file_descr_id, s.file_inline, s.group_member_id, cs.local_display_name, m.local_display_name
FROM snd_files s
JOIN files f USING (file_id)
LEFT JOIN contacts cs USING (contact_id)
LEFT JOIN group_members m USING (group_member_id)
WHERE f.user_id = ? AND f.file_id = ? AND s.connection_id = ?
|]
(userId, fileId, connId)
sndFileTransfer_ :: Int64 -> Int64 -> (FileStatus, String, Integer, Integer, FilePath, Maybe Int64, Maybe InlineFileMode, Maybe Int64, Maybe ContactName, Maybe ContactName) -> Either StoreError SndFileTransfer
sndFileTransfer_ fileId connId (fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, groupMemberId, contactName_, memberName_) =
case contactName_ <|> memberName_ of
Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, recipientDisplayName, connId, agentConnId, groupMemberId}
Nothing -> Left $ SESndFileInvalid fileId
getUserContact_ :: Int64 -> ExceptT StoreError IO UserContact
getUserContact_ userContactLinkId = ExceptT $ do
userContact_
<$> DB.query
db
[sql|
SELECT conn_req_contact, group_id
FROM user_contact_links
WHERE user_id = ? AND user_contact_link_id = ?
|]
(userId, userContactLinkId)
where
userContact_ :: [(ConnReqContact, Maybe GroupId)] -> Either StoreError UserContact
userContact_ [(cReq, groupId)] = Right UserContact {userContactLinkId, connReqContact = cReq, groupId}
userContact_ _ = Left SEUserContactLinkNotFound

689
src/Simplex/Chat/Store/Direct.hs Normal file
View File

@ -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)

868
src/Simplex/Chat/Store/Files.hs Normal file
View File

@ -0,0 +1,868 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Simplex.Chat.Store.Files
( getLiveSndFileTransfers,
getLiveRcvFileTransfers,
getPendingSndChunks,
createSndDirectFileTransfer,
createSndDirectFTConnection,
createSndGroupFileTransfer,
createSndGroupFileTransferConnection,
createSndDirectInlineFT,
createSndGroupInlineFT,
updateSndDirectFTDelivery,
updateSndGroupFTDelivery,
getSndFTViaMsgDelivery,
createSndFileTransferXFTP,
createSndFTDescrXFTP,
setSndFTPrivateSndDescr,
updateSndFTDescrXFTP,
createExtraSndFTDescrs,
updateSndFTDeliveryXFTP,
setSndFTAgentDeleted,
getXFTPSndFileDBId,
getXFTPRcvFileDBId,
updateFileCancelled,
updateCIFileStatus,
getSharedMsgIdByFileId,
getFileIdBySharedMsgId,
getGroupFileIdBySharedMsgId,
getDirectFileIdBySharedMsgId,
getChatRefByFileId,
updateSndFileStatus,
createSndFileChunk,
updateSndFileChunkMsg,
updateSndFileChunkSent,
deleteSndFileChunks,
createRcvFileTransfer,
createRcvGroupFileTransfer,
appendRcvFD,
getRcvFileDescrByFileId,
updateRcvFileAgentId,
getRcvFileTransferById,
getRcvFileTransfer,
acceptRcvFileTransfer,
getContactByFileId,
acceptRcvInlineFT,
startRcvInlineFT,
xftpAcceptRcvFT,
setRcvFileToReceive,
getRcvFilesToReceive,
setRcvFTAgentDeleted,
updateRcvFileStatus,
createRcvFileChunk,
updatedRcvFileChunkStored,
deleteRcvFileChunks,
updateFileTransferChatItemId,
getFileTransfer,
getFileTransferProgress,
getFileTransferMeta,
getSndFileTransfer,
getSndFileTransfers,
getContactFileInfo,
updateDirectCIFileStatus,
)
where
import Control.Applicative ((<|>))
import Control.Monad.Except
import Data.Either (rights)
import Data.Int (Int64)
import Data.Maybe (fromMaybe, isJust, listToMaybe)
import Data.Text (Text)
import Data.Time (addUTCTime)
import Data.Time.Clock (UTCTime (..), getCurrentTime, nominalDay)
import Data.Type.Equality
import Database.SQLite.Simple (Only (..), (:.) (..))
import qualified Database.SQLite.Simple as DB
import Database.SQLite.Simple.QQ (sql)
import Simplex.Chat.Store.Direct
import Simplex.Chat.Store.Messages
import Simplex.Chat.Store.Profiles
import Simplex.Chat.Store.Shared
import Simplex.Chat.Messages
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Protocol
import Simplex.Chat.Types
import Simplex.Chat.Util (week)
import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, UserId)
import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer]
getLiveSndFileTransfers db User {userId} = do
cutoffTs <- addUTCTime (- week) <$> getCurrentTime
fileIds :: [Int64] <-
map fromOnly
<$> DB.query
db
[sql|
SELECT DISTINCT f.file_id
FROM files f
JOIN snd_files s USING (file_id)
WHERE f.user_id = ?
AND s.file_status IN (?, ?, ?)
AND s.file_descr_id IS NULL
AND s.file_inline IS NULL
AND s.created_at > ?
|]
(userId, FSNew, FSAccepted, FSConnected, cutoffTs)
concatMap (filter liveTransfer) . rights <$> mapM (getSndFileTransfers_ db userId) fileIds
where
liveTransfer :: SndFileTransfer -> Bool
liveTransfer SndFileTransfer {fileStatus} = fileStatus `elem` [FSNew, FSAccepted, FSConnected]
getLiveRcvFileTransfers :: DB.Connection -> User -> IO [RcvFileTransfer]
getLiveRcvFileTransfers db user@User {userId} = do
cutoffTs <- addUTCTime (- week) <$> getCurrentTime
fileIds :: [Int64] <-
map fromOnly
<$> DB.query
db
[sql|
SELECT f.file_id
FROM files f
JOIN rcv_files r USING (file_id)
WHERE f.user_id = ? AND r.file_status IN (?, ?)
AND r.rcv_file_inline IS NULL
AND r.file_descr_id IS NULL
AND r.created_at > ?
|]
(userId, FSAccepted, FSConnected, cutoffTs)
rights <$> mapM (runExceptT . getRcvFileTransfer db user) fileIds
getPendingSndChunks :: DB.Connection -> Int64 -> Int64 -> IO [Integer]
getPendingSndChunks db fileId connId =
map fromOnly
<$> DB.query
db
[sql|
SELECT chunk_number
FROM snd_file_chunks
WHERE file_id = ? AND connection_id = ? AND chunk_agent_msg_id IS NULL
ORDER BY chunk_number
|]
(fileId, connId)
createSndDirectFileTransfer :: DB.Connection -> UserId -> Contact -> FilePath -> FileInvitation -> Maybe ConnId -> Integer -> IO FileTransferMeta
createSndDirectFileTransfer db userId Contact {contactId} filePath FileInvitation {fileName, fileSize, fileInline} acId_ chunkSize = do
currentTs <- getCurrentTime
DB.execute
db
"INSERT INTO files (user_id, contact_id, file_name, file_path, file_size, chunk_size, file_inline, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?)"
((userId, contactId, fileName, filePath, fileSize, chunkSize) :. (fileInline, CIFSSndStored, FPSMP, currentTs, currentTs))
fileId <- insertedRowId db
forM_ acId_ $ \acId -> do
Connection {connId} <- createSndFileConnection_ db userId fileId acId
let fileStatus = FSNew
DB.execute
db
"INSERT INTO snd_files (file_id, file_status, file_inline, connection_id, created_at, updated_at) VALUES (?,?,?,?,?,?)"
(fileId, fileStatus, fileInline, connId, currentTs, currentTs)
pure FileTransferMeta {fileId, xftpSndFile = Nothing, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False}
createSndDirectFTConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> IO ()
createSndDirectFTConnection db user@User {userId} fileId (cmdId, acId) = do
currentTs <- getCurrentTime
Connection {connId} <- createSndFileConnection_ db userId fileId acId
setCommandConnId db user cmdId connId
DB.execute
db
"INSERT INTO snd_files (file_id, file_status, connection_id, created_at, updated_at) VALUES (?,?,?,?,?)"
(fileId, FSAccepted, connId, currentTs, currentTs)
createSndGroupFileTransfer :: DB.Connection -> UserId -> GroupInfo -> FilePath -> FileInvitation -> Integer -> IO FileTransferMeta
createSndGroupFileTransfer db userId GroupInfo {groupId} filePath FileInvitation {fileName, fileSize, fileInline} chunkSize = do
currentTs <- getCurrentTime
DB.execute
db
"INSERT INTO files (user_id, group_id, file_name, file_path, file_size, chunk_size, file_inline, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?)"
((userId, groupId, fileName, filePath, fileSize, chunkSize) :. (fileInline, CIFSSndStored, FPSMP, currentTs, currentTs))
fileId <- insertedRowId db
pure FileTransferMeta {fileId, xftpSndFile = Nothing, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False}
createSndGroupFileTransferConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> GroupMember -> IO ()
createSndGroupFileTransferConnection db user@User {userId} fileId (cmdId, acId) GroupMember {groupMemberId} = do
currentTs <- getCurrentTime
Connection {connId} <- createSndFileConnection_ db userId fileId acId
setCommandConnId db user cmdId connId
DB.execute
db
"INSERT INTO snd_files (file_id, file_status, connection_id, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?)"
(fileId, FSAccepted, connId, groupMemberId, currentTs, currentTs)
createSndDirectInlineFT :: DB.Connection -> Contact -> FileTransferMeta -> IO SndFileTransfer
createSndDirectInlineFT db Contact {localDisplayName = n, activeConn = Connection {connId, agentConnId}} FileTransferMeta {fileId, fileName, filePath, fileSize, chunkSize, fileInline} = do
currentTs <- getCurrentTime
let fileStatus = FSConnected
fileInline' = Just $ fromMaybe IFMOffer fileInline
DB.execute
db
"INSERT INTO snd_files (file_id, file_status, file_inline, connection_id, created_at, updated_at) VALUES (?,?,?,?,?,?)"
(fileId, fileStatus, fileInline', connId, currentTs, currentTs)
pure SndFileTransfer {fileId, fileName, filePath, fileSize, chunkSize, recipientDisplayName = n, connId, agentConnId, groupMemberId = Nothing, fileStatus, fileDescrId = Nothing, fileInline = fileInline'}
createSndGroupInlineFT :: DB.Connection -> GroupMember -> Connection -> FileTransferMeta -> IO SndFileTransfer
createSndGroupInlineFT db GroupMember {groupMemberId, localDisplayName = n} Connection {connId, agentConnId} FileTransferMeta {fileId, fileName, filePath, fileSize, chunkSize, fileInline} = do
currentTs <- getCurrentTime
let fileStatus = FSConnected
fileInline' = Just $ fromMaybe IFMOffer fileInline
DB.execute
db
"INSERT INTO snd_files (file_id, file_status, file_inline, connection_id, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)"
(fileId, fileStatus, fileInline', connId, groupMemberId, currentTs, currentTs)
pure SndFileTransfer {fileId, fileName, filePath, fileSize, chunkSize, recipientDisplayName = n, connId, agentConnId, groupMemberId = Just groupMemberId, fileStatus, fileDescrId = Nothing, fileInline = fileInline'}
updateSndDirectFTDelivery :: DB.Connection -> Contact -> FileTransferMeta -> Int64 -> IO ()
updateSndDirectFTDelivery db Contact {activeConn = Connection {connId}} FileTransferMeta {fileId} msgDeliveryId =
DB.execute
db
"UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_inline IS NOT NULL"
(msgDeliveryId, connId, fileId)
updateSndGroupFTDelivery :: DB.Connection -> GroupMember -> Connection -> FileTransferMeta -> Int64 -> IO ()
updateSndGroupFTDelivery db GroupMember {groupMemberId} Connection {connId} FileTransferMeta {fileId} msgDeliveryId =
DB.execute
db
"UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE group_member_id = ? AND connection_id = ? AND file_id = ? AND file_inline IS NOT NULL"
(msgDeliveryId, groupMemberId, connId, fileId)
getSndFTViaMsgDelivery :: DB.Connection -> User -> Connection -> AgentMsgId -> IO (Maybe SndFileTransfer)
getSndFTViaMsgDelivery db User {userId} Connection {connId, agentConnId} agentMsgId = do
(sndFileTransfer_ <=< listToMaybe)
<$> DB.query
db
[sql|
SELECT s.file_id, s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.file_descr_id, s.file_inline, s.group_member_id, c.local_display_name, m.local_display_name
FROM msg_deliveries d
JOIN snd_files s ON s.connection_id = d.connection_id AND s.last_inline_msg_delivery_id = d.msg_delivery_id
JOIN files f ON f.file_id = s.file_id
LEFT JOIN contacts c USING (contact_id)
LEFT JOIN group_members m USING (group_member_id)
WHERE d.connection_id = ? AND d.agent_msg_id = ? AND f.user_id = ?
AND (s.file_descr_id IS NOT NULL OR s.file_inline IS NOT NULL)
|]
(connId, agentMsgId, userId)
where
sndFileTransfer_ :: (Int64, FileStatus, String, Integer, Integer, FilePath, Maybe Int64, Maybe InlineFileMode, Maybe Int64, Maybe ContactName, Maybe ContactName) -> Maybe SndFileTransfer
sndFileTransfer_ (fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, groupMemberId, contactName_, memberName_) =
(\n -> SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, groupMemberId, recipientDisplayName = n, connId, agentConnId})
<$> (contactName_ <|> memberName_)
createSndFileTransferXFTP :: DB.Connection -> User -> ContactOrGroup -> FilePath -> FileInvitation -> AgentSndFileId -> Integer -> IO FileTransferMeta
createSndFileTransferXFTP db User {userId} contactOrGroup filePath FileInvitation {fileName, fileSize} agentSndFileId chunkSize = do
currentTs <- getCurrentTime
let xftpSndFile = Just XFTPSndFile {agentSndFileId, privateSndFileDescr = Nothing, agentSndFileDeleted = False}
DB.execute
db
"INSERT INTO files (contact_id, group_id, user_id, file_name, file_path, file_size, chunk_size, agent_snd_file_id, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)"
(contactAndGroupIds contactOrGroup :. (userId, fileName, filePath, fileSize, chunkSize, agentSndFileId, CIFSSndStored, FPXFTP, currentTs, currentTs))
fileId <- insertedRowId db
pure FileTransferMeta {fileId, xftpSndFile, fileName, filePath, fileSize, fileInline = Nothing, chunkSize, cancelled = False}
createSndFTDescrXFTP :: DB.Connection -> User -> Maybe GroupMember -> Connection -> FileTransferMeta -> FileDescr -> IO ()
createSndFTDescrXFTP db User {userId} m Connection {connId} FileTransferMeta {fileId} FileDescr {fileDescrText, fileDescrPartNo, fileDescrComplete} = do
currentTs <- getCurrentTime
let fileStatus = FSNew
DB.execute
db
"INSERT INTO xftp_file_descriptions (user_id, file_descr_text, file_descr_part_no, file_descr_complete, created_at, updated_at) VALUES (?,?,?,?,?,?)"
(userId, fileDescrText, fileDescrPartNo, fileDescrComplete, currentTs, currentTs)
fileDescrId <- insertedRowId db
DB.execute
db
"INSERT INTO snd_files (file_id, file_status, file_descr_id, group_member_id, connection_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)"
(fileId, fileStatus, fileDescrId, groupMemberId' <$> m, connId, currentTs, currentTs)
setSndFTPrivateSndDescr :: DB.Connection -> User -> FileTransferId -> Text -> IO ()
setSndFTPrivateSndDescr db User {userId} fileId sfdText = do
currentTs <- getCurrentTime
DB.execute
db
"UPDATE files SET private_snd_file_descr = ?, updated_at = ? WHERE user_id = ? AND file_id = ?"
(sfdText, currentTs, userId, fileId)
updateSndFTDescrXFTP :: DB.Connection -> User -> SndFileTransfer -> Text -> IO ()
updateSndFTDescrXFTP db user@User {userId} sft@SndFileTransfer {fileId, fileDescrId} rfdText = do
currentTs <- getCurrentTime
DB.execute
db
[sql|
UPDATE xftp_file_descriptions
SET file_descr_text = ?, file_descr_part_no = ?, file_descr_complete = ?, updated_at = ?
WHERE user_id = ? AND file_descr_id = ?
|]
(rfdText, 1 :: Int, True, currentTs, userId, fileDescrId)
updateCIFileStatus db user fileId $ CIFSSndTransfer 1 1
updateSndFileStatus db sft FSConnected
createExtraSndFTDescrs :: DB.Connection -> User -> FileTransferId -> [Text] -> IO ()
createExtraSndFTDescrs db User {userId} fileId rfdTexts = do
currentTs <- getCurrentTime
forM_ rfdTexts $ \rfdText ->
DB.execute
db
"INSERT INTO extra_xftp_file_descriptions (file_id, user_id, file_descr_text, created_at, updated_at) VALUES (?,?,?,?,?)"
(fileId, userId, rfdText, currentTs, currentTs)
updateSndFTDeliveryXFTP :: DB.Connection -> SndFileTransfer -> Int64 -> IO ()
updateSndFTDeliveryXFTP db SndFileTransfer {connId, fileId, fileDescrId} msgDeliveryId =
DB.execute
db
"UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_descr_id = ?"
(msgDeliveryId, connId, fileId, fileDescrId)
setSndFTAgentDeleted :: DB.Connection -> User -> FileTransferId -> IO ()
setSndFTAgentDeleted db User {userId} fileId = do
currentTs <- getCurrentTime
DB.execute
db
"UPDATE files SET agent_snd_file_deleted = 1, updated_at = ? WHERE user_id = ? AND file_id = ?"
(currentTs, userId, fileId)
getXFTPSndFileDBId :: DB.Connection -> User -> AgentSndFileId -> ExceptT StoreError IO FileTransferId
getXFTPSndFileDBId db User {userId} aSndFileId =
ExceptT . firstRow fromOnly (SESndFileNotFoundXFTP aSndFileId) $
DB.query db "SELECT file_id FROM files WHERE user_id = ? AND agent_snd_file_id = ?" (userId, aSndFileId)
getXFTPRcvFileDBId :: DB.Connection -> AgentRcvFileId -> ExceptT StoreError IO FileTransferId
getXFTPRcvFileDBId db aRcvFileId =
ExceptT . firstRow fromOnly (SERcvFileNotFoundXFTP aRcvFileId) $
DB.query db "SELECT file_id FROM rcv_files WHERE agent_rcv_file_id = ?" (Only aRcvFileId)
updateFileCancelled :: MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> IO ()
updateFileCancelled db User {userId} fileId ciFileStatus = do
currentTs <- getCurrentTime
DB.execute db "UPDATE files SET cancelled = 1, ci_file_status = ?, updated_at = ? WHERE user_id = ? AND file_id = ?" (ciFileStatus, currentTs, userId, fileId)
updateCIFileStatus :: MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> IO ()
updateCIFileStatus db User {userId} fileId ciFileStatus = do
currentTs <- getCurrentTime
DB.execute db "UPDATE files SET ci_file_status = ?, updated_at = ? WHERE user_id = ? AND file_id = ?" (ciFileStatus, currentTs, userId, fileId)
getSharedMsgIdByFileId :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO SharedMsgId
getSharedMsgIdByFileId db userId fileId =
ExceptT . firstRow fromOnly (SESharedMsgIdNotFoundByFileId fileId) $
DB.query
db
[sql|
SELECT i.shared_msg_id
FROM chat_items i
JOIN files f ON f.chat_item_id = i.chat_item_id
WHERE f.user_id = ? AND f.file_id = ?
|]
(userId, fileId)
getFileIdBySharedMsgId :: DB.Connection -> UserId -> Int64 -> SharedMsgId -> ExceptT StoreError IO Int64
getFileIdBySharedMsgId db userId contactId sharedMsgId =
ExceptT . firstRow fromOnly (SEFileIdNotFoundBySharedMsgId sharedMsgId) $
DB.query
db
[sql|
SELECT f.file_id
FROM files f
JOIN chat_items i ON i.chat_item_id = f.chat_item_id
WHERE i.user_id = ? AND i.contact_id = ? AND i.shared_msg_id = ?
|]
(userId, contactId, sharedMsgId)
getGroupFileIdBySharedMsgId :: DB.Connection -> UserId -> Int64 -> SharedMsgId -> ExceptT StoreError IO Int64
getGroupFileIdBySharedMsgId db userId groupId sharedMsgId =
ExceptT . firstRow fromOnly (SEFileIdNotFoundBySharedMsgId sharedMsgId) $
DB.query
db
[sql|
SELECT f.file_id
FROM files f
JOIN chat_items i ON i.chat_item_id = f.chat_item_id
WHERE i.user_id = ? AND i.group_id = ? AND i.shared_msg_id = ?
|]
(userId, groupId, sharedMsgId)
getDirectFileIdBySharedMsgId :: DB.Connection -> User -> Contact -> SharedMsgId -> ExceptT StoreError IO Int64
getDirectFileIdBySharedMsgId db User {userId} Contact {contactId} sharedMsgId =
ExceptT . firstRow fromOnly (SEFileIdNotFoundBySharedMsgId sharedMsgId) $
DB.query
db
[sql|
SELECT f.file_id
FROM files f
JOIN chat_items i ON i.chat_item_id = f.chat_item_id
WHERE i.user_id = ? AND i.contact_id = ? AND i.shared_msg_id = ?
|]
(userId, contactId, sharedMsgId)
getChatRefByFileId :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO ChatRef
getChatRefByFileId db User {userId} fileId =
liftIO getChatRef >>= \case
[(Just contactId, Nothing)] -> pure $ ChatRef CTDirect contactId
[(Nothing, Just groupId)] -> pure $ ChatRef CTGroup groupId
_ -> throwError $ SEInternalError "could not retrieve chat ref by file id"
where
getChatRef =
DB.query
db
[sql|
SELECT contact_id, group_id
FROM files
WHERE user_id = ? AND file_id = ?
LIMIT 1
|]
(userId, fileId)
createSndFileConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> IO Connection
createSndFileConnection_ db userId fileId agentConnId = do
currentTs <- getCurrentTime
createConnection_ db userId ConnSndFile (Just fileId) agentConnId Nothing Nothing Nothing 0 currentTs
updateSndFileStatus :: DB.Connection -> SndFileTransfer -> FileStatus -> IO ()
updateSndFileStatus db SndFileTransfer {fileId, connId} status = do
currentTs <- getCurrentTime
DB.execute db "UPDATE snd_files SET file_status = ?, updated_at = ? WHERE file_id = ? AND connection_id = ?" (status, currentTs, fileId, connId)
createSndFileChunk :: DB.Connection -> SndFileTransfer -> IO (Maybe Integer)
createSndFileChunk db SndFileTransfer {fileId, connId, fileSize, chunkSize} = do
chunkNo <- getLastChunkNo
insertChunk chunkNo
pure chunkNo
where
getLastChunkNo = do
ns <- DB.query db "SELECT chunk_number FROM snd_file_chunks WHERE file_id = ? AND connection_id = ? AND chunk_sent = 1 ORDER BY chunk_number DESC LIMIT 1" (fileId, connId)
pure $ case map fromOnly ns of
[] -> Just 1
n : _ -> if n * chunkSize >= fileSize then Nothing else Just (n + 1)
insertChunk chunkNo_ = forM_ chunkNo_ $ \chunkNo -> do
currentTs <- getCurrentTime
DB.execute
db
"INSERT OR REPLACE INTO snd_file_chunks (file_id, connection_id, chunk_number, created_at, updated_at) VALUES (?,?,?,?,?)"
(fileId, connId, chunkNo, currentTs, currentTs)
updateSndFileChunkMsg :: DB.Connection -> SndFileTransfer -> Integer -> AgentMsgId -> IO ()
updateSndFileChunkMsg db SndFileTransfer {fileId, connId} chunkNo msgId = do
currentTs <- getCurrentTime
DB.execute
db
[sql|
UPDATE snd_file_chunks
SET chunk_agent_msg_id = ?, updated_at = ?
WHERE file_id = ? AND connection_id = ? AND chunk_number = ?
|]
(msgId, currentTs, fileId, connId, chunkNo)
updateSndFileChunkSent :: DB.Connection -> SndFileTransfer -> AgentMsgId -> IO ()
updateSndFileChunkSent db SndFileTransfer {fileId, connId} msgId = do
currentTs <- getCurrentTime
DB.execute
db
[sql|
UPDATE snd_file_chunks
SET chunk_sent = 1, updated_at = ?
WHERE file_id = ? AND connection_id = ? AND chunk_agent_msg_id = ?
|]
(currentTs, fileId, connId, msgId)
deleteSndFileChunks :: DB.Connection -> SndFileTransfer -> IO ()
deleteSndFileChunks db SndFileTransfer {fileId, connId} =
DB.execute db "DELETE FROM snd_file_chunks WHERE file_id = ? AND connection_id = ?" (fileId, connId)
createRcvFileTransfer :: DB.Connection -> UserId -> Contact -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer
createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do
currentTs <- liftIO getCurrentTime
rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr
let rfdId = (fileDescrId :: RcvFileDescr -> Int64) <$> rfd_
xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False}) <$> rfd_
fileProtocol = if isJust rfd_ then FPXFTP else FPSMP
fileId <- liftIO $ do
DB.execute
db
"INSERT INTO files (user_id, contact_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?)"
(userId, contactId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, fileProtocol, currentTs, currentTs)
insertedRowId db
liftIO $
DB.execute
db
"INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, file_descr_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
(fileId, FSNew, fileConnReq, fileInline, rcvFileInline, rfdId, currentTs, currentTs)
pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing}
createRcvGroupFileTransfer :: DB.Connection -> UserId -> GroupMember -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer
createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do
currentTs <- liftIO getCurrentTime
rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr
let rfdId = (fileDescrId :: RcvFileDescr -> Int64) <$> rfd_
xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False}) <$> rfd_
fileProtocol = if isJust rfd_ then FPXFTP else FPSMP
fileId <- liftIO $ do
DB.execute
db
"INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?)"
(userId, groupId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, fileProtocol, currentTs, currentTs)
insertedRowId db
liftIO $
DB.execute
db
"INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, group_member_id, file_descr_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
(fileId, FSNew, fileConnReq, fileInline, rcvFileInline, groupMemberId, rfdId, currentTs, currentTs)
pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Just groupMemberId}
createRcvFD_ :: DB.Connection -> UserId -> UTCTime -> FileDescr -> ExceptT StoreError IO RcvFileDescr
createRcvFD_ db userId currentTs FileDescr {fileDescrText, fileDescrPartNo, fileDescrComplete} = do
when (fileDescrPartNo /= 0) $ throwError SERcvFileInvalidDescrPart
fileDescrId <- liftIO $ do
DB.execute
db
"INSERT INTO xftp_file_descriptions (user_id, file_descr_text, file_descr_part_no, file_descr_complete, created_at, updated_at) VALUES (?,?,?,?,?,?)"
(userId, fileDescrText, fileDescrPartNo, fileDescrComplete, currentTs, currentTs)
insertedRowId db
pure RcvFileDescr {fileDescrId, fileDescrPartNo, fileDescrText, fileDescrComplete}
appendRcvFD :: DB.Connection -> UserId -> FileTransferId -> FileDescr -> ExceptT StoreError IO RcvFileDescr
appendRcvFD db userId fileId fd@FileDescr {fileDescrText, fileDescrPartNo, fileDescrComplete} = do
currentTs <- liftIO getCurrentTime
liftIO (getRcvFileDescrByFileId_ db fileId) >>= \case
Nothing -> do
rfd@RcvFileDescr {fileDescrId} <- createRcvFD_ db userId currentTs fd
liftIO $
DB.execute
db
"UPDATE rcv_files SET file_descr_id = ?, updated_at = ? WHERE file_id = ?"
(fileDescrId, currentTs, fileId)
pure rfd
Just
RcvFileDescr
{ fileDescrId,
fileDescrText = rfdText,
fileDescrPartNo = rfdPNo,
fileDescrComplete = rfdComplete
} -> do
when (fileDescrPartNo /= rfdPNo + 1 || rfdComplete) $ throwError SERcvFileInvalidDescrPart
let fileDescrText' = rfdText <> fileDescrText
liftIO $
DB.execute
db
[sql|
UPDATE xftp_file_descriptions
SET file_descr_text = ?, file_descr_part_no = ?, file_descr_complete = ?
WHERE file_descr_id = ?
|]
(fileDescrText', fileDescrPartNo, fileDescrComplete, fileDescrId)
pure RcvFileDescr {fileDescrId, fileDescrText = fileDescrText', fileDescrPartNo, fileDescrComplete}
getRcvFileDescrByFileId :: DB.Connection -> FileTransferId -> ExceptT StoreError IO RcvFileDescr
getRcvFileDescrByFileId db fileId = do
liftIO (getRcvFileDescrByFileId_ db fileId) >>= \case
Nothing -> throwError $ SERcvFileDescrNotFound fileId
Just rfd -> pure rfd
getRcvFileDescrByFileId_ :: DB.Connection -> FileTransferId -> IO (Maybe RcvFileDescr)
getRcvFileDescrByFileId_ db fileId =
maybeFirstRow toRcvFileDescr $
DB.query
db
[sql|
SELECT d.file_descr_id, d.file_descr_text, d.file_descr_part_no, d.file_descr_complete
FROM xftp_file_descriptions d
JOIN rcv_files f ON f.file_descr_id = d.file_descr_id
WHERE f.file_id = ?
LIMIT 1
|]
(Only fileId)
where
toRcvFileDescr :: (Int64, Text, Int, Bool) -> RcvFileDescr
toRcvFileDescr (fileDescrId, fileDescrText, fileDescrPartNo, fileDescrComplete) =
RcvFileDescr {fileDescrId, fileDescrText, fileDescrPartNo, fileDescrComplete}
updateRcvFileAgentId :: DB.Connection -> FileTransferId -> Maybe AgentRcvFileId -> IO ()
updateRcvFileAgentId db fileId aFileId = do
currentTs <- getCurrentTime
DB.execute db "UPDATE rcv_files SET agent_rcv_file_id = ?, updated_at = ? WHERE file_id = ?" (aFileId, currentTs, fileId)
getRcvFileTransferById :: DB.Connection -> FileTransferId -> ExceptT StoreError IO (User, RcvFileTransfer)
getRcvFileTransferById db fileId = do
user <- getUserByFileId db fileId
(user,) <$> getRcvFileTransfer db user fileId
getRcvFileTransfer :: DB.Connection -> User -> FileTransferId -> ExceptT StoreError IO RcvFileTransfer
getRcvFileTransfer db User {userId} fileId = do
rftRow <-
ExceptT . firstRow id (SERcvFileNotFound fileId) $
DB.query
db
[sql|
SELECT r.file_status, r.file_queue_info, r.group_member_id, f.file_name,
f.file_size, f.chunk_size, f.cancelled, cs.local_display_name, m.local_display_name,
f.file_path, r.file_inline, r.rcv_file_inline, r.agent_rcv_file_id, r.agent_rcv_file_deleted, c.connection_id, c.agent_conn_id
FROM rcv_files r
JOIN files f USING (file_id)
LEFT JOIN connections c ON r.file_id = c.rcv_file_id
LEFT JOIN contacts cs USING (contact_id)
LEFT JOIN group_members m USING (group_member_id)
WHERE f.user_id = ? AND f.file_id = ?
|]
(userId, fileId)
rfd_ <- liftIO $ getRcvFileDescrByFileId_ db fileId
rcvFileTransfer rfd_ rftRow
where
rcvFileTransfer ::
Maybe RcvFileDescr ->
(FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe Bool) :. (Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe InlineFileMode, Maybe InlineFileMode, Maybe AgentRcvFileId, Bool) :. (Maybe Int64, Maybe AgentConnId) ->
ExceptT StoreError IO RcvFileTransfer
rcvFileTransfer rfd_ ((fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_) :. (contactName_, memberName_, filePath_, fileInline, rcvFileInline, agentRcvFileId, agentRcvFileDeleted) :. (connId_, agentConnId_)) =
case contactName_ <|> memberName_ of
Nothing -> throwError $ SERcvFileInvalid fileId
Just name -> do
case fileStatus' of
FSNew -> pure $ ft name RFSNew
FSAccepted -> ft name . RFSAccepted <$> rfi
FSConnected -> ft name . RFSConnected <$> rfi
FSComplete -> ft name . RFSComplete <$> rfi
FSCancelled -> ft name . RFSCancelled <$> rfi_
where
ft senderDisplayName fileStatus =
let fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq, fileInline, fileDescr = Nothing}
xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId, agentRcvFileDeleted}) <$> rfd_
in RcvFileTransfer {fileId, xftpRcvFile, fileInvitation, fileStatus, rcvFileInline, senderDisplayName, chunkSize, cancelled, grpMemberId}
rfi = maybe (throwError $ SERcvFileInvalid fileId) pure =<< rfi_
rfi_ = case (filePath_, connId_, agentConnId_) of
(Just filePath, connId, agentConnId) -> pure $ Just RcvFileInfo {filePath, connId, agentConnId}
_ -> pure Nothing
cancelled = fromMaybe False cancelled_
acceptRcvFileTransfer :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> ConnStatus -> FilePath -> ExceptT StoreError IO AChatItem
acceptRcvFileTransfer db user@User {userId} fileId (cmdId, acId) connStatus filePath = ExceptT $ do
currentTs <- getCurrentTime
acceptRcvFT_ db user fileId filePath Nothing currentTs
DB.execute
db
"INSERT INTO connections (agent_conn_id, conn_status, conn_type, rcv_file_id, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)"
(acId, connStatus, ConnRcvFile, fileId, userId, currentTs, currentTs)
connId <- insertedRowId db
setCommandConnId db user cmdId connId
runExceptT $ getChatItemByFileId db user fileId
getContactByFileId :: DB.Connection -> User -> FileTransferId -> ExceptT StoreError IO Contact
getContactByFileId db user@User {userId} fileId = do
cId <- getContactIdByFileId
getContact db user cId
where
getContactIdByFileId =
ExceptT . firstRow fromOnly (SEContactNotFoundByFileId fileId) $
DB.query db "SELECT contact_id FROM files WHERE user_id = ? AND file_id = ?" (userId, fileId)
acceptRcvInlineFT :: DB.Connection -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem
acceptRcvInlineFT db user fileId filePath = do
liftIO $ acceptRcvFT_ db user fileId filePath (Just IFMOffer) =<< getCurrentTime
getChatItemByFileId db user fileId
startRcvInlineFT :: DB.Connection -> User -> RcvFileTransfer -> FilePath -> Maybe InlineFileMode -> IO ()
startRcvInlineFT db user RcvFileTransfer {fileId} filePath rcvFileInline =
acceptRcvFT_ db user fileId filePath rcvFileInline =<< getCurrentTime
xftpAcceptRcvFT :: DB.Connection -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem
xftpAcceptRcvFT db user fileId filePath = do
liftIO $ acceptRcvFT_ db user fileId filePath Nothing =<< getCurrentTime
getChatItemByFileId db user fileId
acceptRcvFT_ :: DB.Connection -> User -> FileTransferId -> FilePath -> Maybe InlineFileMode -> UTCTime -> IO ()
acceptRcvFT_ db User {userId} fileId filePath rcvFileInline currentTs = do
DB.execute
db
"UPDATE files SET file_path = ?, ci_file_status = ?, updated_at = ? WHERE user_id = ? AND file_id = ?"
(filePath, CIFSRcvAccepted, currentTs, userId, fileId)
DB.execute
db
"UPDATE rcv_files SET rcv_file_inline = ?, file_status = ?, updated_at = ? WHERE file_id = ?"
(rcvFileInline, FSAccepted, currentTs, fileId)
setRcvFileToReceive :: DB.Connection -> FileTransferId -> IO ()
setRcvFileToReceive db fileId = do
currentTs <- getCurrentTime
DB.execute
db
"UPDATE rcv_files SET to_receive = 1, updated_at = ? WHERE file_id = ?"
(currentTs, fileId)
getRcvFilesToReceive :: DB.Connection -> User -> IO [RcvFileTransfer]
getRcvFilesToReceive db user@User {userId} = do
cutoffTs <- addUTCTime (- (2 * nominalDay)) <$> getCurrentTime
fileIds :: [Int64] <-
map fromOnly
<$> DB.query
db
[sql|
SELECT r.file_id
FROM rcv_files r
JOIN files f ON f.file_id = r.file_id
WHERE f.user_id = ? AND r.file_status = ?
AND r.to_receive = 1 AND r.created_at > ?
|]
(userId, FSNew, cutoffTs)
rights <$> mapM (runExceptT . getRcvFileTransfer db user) fileIds
setRcvFTAgentDeleted :: DB.Connection -> FileTransferId -> IO ()
setRcvFTAgentDeleted db fileId = do
currentTs <- getCurrentTime
DB.execute
db
"UPDATE rcv_files SET agent_rcv_file_deleted = 1, updated_at = ? WHERE file_id = ?"
(currentTs, fileId)
updateRcvFileStatus :: DB.Connection -> FileTransferId -> FileStatus -> IO ()
updateRcvFileStatus db fileId status = do
currentTs <- getCurrentTime
DB.execute db "UPDATE rcv_files SET file_status = ?, updated_at = ? WHERE file_id = ?" (status, currentTs, fileId)
createRcvFileChunk :: DB.Connection -> RcvFileTransfer -> Integer -> AgentMsgId -> IO RcvChunkStatus
createRcvFileChunk db RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileSize}, chunkSize} chunkNo msgId = do
status <- getLastChunkNo
unless (status == RcvChunkError) $ do
currentTs <- getCurrentTime
DB.execute
db
"INSERT OR REPLACE INTO rcv_file_chunks (file_id, chunk_number, chunk_agent_msg_id, created_at, updated_at) VALUES (?,?,?,?,?)"
(fileId, chunkNo, msgId, currentTs, currentTs)
pure status
where
getLastChunkNo = do
ns <- DB.query db "SELECT chunk_number FROM rcv_file_chunks WHERE file_id = ? ORDER BY chunk_number DESC LIMIT 1" (Only fileId)
pure $ case map fromOnly ns of
[]
| chunkNo == 1 ->
if chunkSize >= fileSize
then RcvChunkFinal
else RcvChunkOk
| otherwise -> RcvChunkError
n : _
| chunkNo == n -> RcvChunkDuplicate
| chunkNo == n + 1 ->
let prevSize = n * chunkSize
in if prevSize >= fileSize
then RcvChunkError
else
if prevSize + chunkSize >= fileSize
then RcvChunkFinal
else RcvChunkOk
| otherwise -> RcvChunkError
updatedRcvFileChunkStored :: DB.Connection -> RcvFileTransfer -> Integer -> IO ()
updatedRcvFileChunkStored db RcvFileTransfer {fileId} chunkNo = do
currentTs <- getCurrentTime
DB.execute
db
[sql|
UPDATE rcv_file_chunks
SET chunk_stored = 1, updated_at = ?
WHERE file_id = ? AND chunk_number = ?
|]
(currentTs, fileId, chunkNo)
deleteRcvFileChunks :: DB.Connection -> RcvFileTransfer -> IO ()
deleteRcvFileChunks db RcvFileTransfer {fileId} =
DB.execute db "DELETE FROM rcv_file_chunks WHERE file_id = ?" (Only fileId)
updateFileTransferChatItemId :: DB.Connection -> FileTransferId -> ChatItemId -> UTCTime -> IO ()
updateFileTransferChatItemId db fileId ciId currentTs =
DB.execute db "UPDATE files SET chat_item_id = ?, updated_at = ? WHERE file_id = ?" (ciId, currentTs, fileId)
getFileTransferProgress :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO (FileTransfer, [Integer])
getFileTransferProgress db user fileId = do
ft <- getFileTransfer db user fileId
liftIO $
(ft,) . map fromOnly <$> case ft of
FTSnd _ [] -> pure [Only 0]
FTSnd _ _ -> DB.query db "SELECT COUNT(*) FROM snd_file_chunks WHERE file_id = ? and chunk_sent = 1 GROUP BY connection_id" (Only fileId)
FTRcv _ -> DB.query db "SELECT COUNT(*) FROM rcv_file_chunks WHERE file_id = ? AND chunk_stored = 1" (Only fileId)
getFileTransfer :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO FileTransfer
getFileTransfer db user@User {userId} fileId =
fileTransfer =<< liftIO getFileTransferRow
where
fileTransfer :: [(Maybe Int64, Maybe Int64)] -> ExceptT StoreError IO FileTransfer
fileTransfer [(Nothing, Just _)] = FTRcv <$> getRcvFileTransfer db user fileId
fileTransfer _ = do
(ftm, fts) <- getSndFileTransfer db user fileId
pure $ FTSnd {fileTransferMeta = ftm, sndFileTransfers = fts}
getFileTransferRow :: IO [(Maybe Int64, Maybe Int64)]
getFileTransferRow =
DB.query
db
[sql|
SELECT s.file_id, r.file_id
FROM files f
LEFT JOIN snd_files s ON s.file_id = f.file_id
LEFT JOIN rcv_files r ON r.file_id = f.file_id
WHERE user_id = ? AND f.file_id = ?
|]
(userId, fileId)
getSndFileTransfer :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO (FileTransferMeta, [SndFileTransfer])
getSndFileTransfer db user fileId = do
fileTransferMeta <- getFileTransferMeta db user fileId
sndFileTransfers <- getSndFileTransfers db user fileId
pure (fileTransferMeta, sndFileTransfers)
getSndFileTransfers :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO [SndFileTransfer]
getSndFileTransfers db User {userId} fileId = ExceptT $ getSndFileTransfers_ db userId fileId
getSndFileTransfers_ :: DB.Connection -> UserId -> Int64 -> IO (Either StoreError [SndFileTransfer])
getSndFileTransfers_ db userId fileId =
mapM sndFileTransfer
<$> DB.query
db
[sql|
SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.file_descr_id, s.file_inline, s.connection_id, c.agent_conn_id, s.group_member_id,
cs.local_display_name, m.local_display_name
FROM snd_files s
JOIN files f USING (file_id)
JOIN connections c USING (connection_id)
LEFT JOIN contacts cs USING (contact_id)
LEFT JOIN group_members m USING (group_member_id)
WHERE f.user_id = ? AND f.file_id = ?
|]
(userId, fileId)
where
sndFileTransfer :: (FileStatus, String, Integer, Integer, FilePath) :. (Maybe Int64, Maybe InlineFileMode, Int64, AgentConnId, Maybe Int64, Maybe ContactName, Maybe ContactName) -> Either StoreError SndFileTransfer
sndFileTransfer ((fileStatus, fileName, fileSize, chunkSize, filePath) :. (fileDescrId, fileInline, connId, agentConnId, groupMemberId, contactName_, memberName_)) =
case contactName_ <|> memberName_ of
Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, recipientDisplayName, connId, agentConnId, groupMemberId}
Nothing -> Left $ SESndFileInvalid fileId
getFileTransferMeta :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO FileTransferMeta
getFileTransferMeta db User {userId} fileId =
ExceptT . firstRow fileTransferMeta (SEFileNotFound fileId) $
DB.query
db
[sql|
SELECT file_name, file_size, chunk_size, file_path, file_inline, agent_snd_file_id, agent_snd_file_deleted, private_snd_file_descr, cancelled
FROM files
WHERE user_id = ? AND file_id = ?
|]
(userId, fileId)
where
fileTransferMeta :: (String, Integer, Integer, FilePath, Maybe InlineFileMode, Maybe AgentSndFileId, Bool, Maybe Text, Maybe Bool) -> FileTransferMeta
fileTransferMeta (fileName, fileSize, chunkSize, filePath, fileInline, aSndFileId_, agentSndFileDeleted, privateSndFileDescr, cancelled_) =
let xftpSndFile = (\fId -> XFTPSndFile {agentSndFileId = fId, privateSndFileDescr, agentSndFileDeleted}) <$> aSndFileId_
in FileTransferMeta {fileId, xftpSndFile, fileName, fileSize, chunkSize, filePath, fileInline, cancelled = fromMaybe False cancelled_}
getContactFileInfo :: DB.Connection -> User -> Contact -> IO [CIFileInfo]
getContactFileInfo db User {userId} Contact {contactId} =
map toFileInfo
<$> DB.query db (fileInfoQuery <> " WHERE i.user_id = ? AND i.contact_id = ?") (userId, contactId)
updateDirectCIFileStatus :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> ExceptT StoreError IO AChatItem
updateDirectCIFileStatus db user fileId fileStatus = do
aci@(AChatItem cType d cInfo ci) <- getChatItemByFileId db user fileId
case (cType, testEquality d $ msgDirection @d) of
(SCTDirect, Just Refl) -> do
liftIO $ updateCIFileStatus db user fileId fileStatus
pure $ AChatItem SCTDirect d cInfo $ updateFileStatus ci fileStatus
_ -> pure aci

1295
src/Simplex/Chat/Store/Groups.hs Normal file
View File

File diff suppressed because it is too large Load Diff

1805
src/Simplex/Chat/Store/Messages.hs Normal file
View File

File diff suppressed because it is too large Load Diff

151
src/Simplex/Chat/Store/Migrations.hs Normal file
View File

@ -0,0 +1,151 @@
{-# LANGUAGE NamedFieldPuns #-}
module Simplex.Chat.Store.Migrations (migrations) where
import Data.List (sortOn)
import Database.SQLite.Simple (Query (..))
import Simplex.Chat.Migrations.M20220101_initial
import Simplex.Chat.Migrations.M20220122_v1_1
import Simplex.Chat.Migrations.M20220205_chat_item_status
import Simplex.Chat.Migrations.M20220210_deduplicate_contact_requests
import Simplex.Chat.Migrations.M20220224_messages_fks
import Simplex.Chat.Migrations.M20220301_smp_servers
import Simplex.Chat.Migrations.M20220302_profile_images
import Simplex.Chat.Migrations.M20220304_msg_quotes
import Simplex.Chat.Migrations.M20220321_chat_item_edited
import Simplex.Chat.Migrations.M20220404_files_status_fields
import Simplex.Chat.Migrations.M20220514_profiles_user_id
import Simplex.Chat.Migrations.M20220626_auto_reply
import Simplex.Chat.Migrations.M20220702_calls
import Simplex.Chat.Migrations.M20220715_groups_chat_item_id
import Simplex.Chat.Migrations.M20220811_chat_items_indices
import Simplex.Chat.Migrations.M20220812_incognito_profiles
import Simplex.Chat.Migrations.M20220818_chat_notifications
import Simplex.Chat.Migrations.M20220822_groups_host_conn_custom_user_profile_id
import Simplex.Chat.Migrations.M20220823_delete_broken_group_event_chat_items
import Simplex.Chat.Migrations.M20220824_profiles_local_alias
import Simplex.Chat.Migrations.M20220909_commands
import Simplex.Chat.Migrations.M20220926_connection_alias
import Simplex.Chat.Migrations.M20220928_settings
import Simplex.Chat.Migrations.M20221001_shared_msg_id_indices
import Simplex.Chat.Migrations.M20221003_delete_broken_integrity_error_chat_items
import Simplex.Chat.Migrations.M20221004_idx_msg_deliveries_message_id
import Simplex.Chat.Migrations.M20221011_user_contact_links_group_id
import Simplex.Chat.Migrations.M20221012_inline_files
import Simplex.Chat.Migrations.M20221019_unread_chat
import Simplex.Chat.Migrations.M20221021_auto_accept__group_links
import Simplex.Chat.Migrations.M20221024_contact_used
import Simplex.Chat.Migrations.M20221025_chat_settings
import Simplex.Chat.Migrations.M20221029_group_link_id
import Simplex.Chat.Migrations.M20221112_server_password
import Simplex.Chat.Migrations.M20221115_server_cfg
import Simplex.Chat.Migrations.M20221129_delete_group_feature_items
import Simplex.Chat.Migrations.M20221130_delete_item_deleted
import Simplex.Chat.Migrations.M20221209_verified_connection
import Simplex.Chat.Migrations.M20221210_idxs
import Simplex.Chat.Migrations.M20221211_group_description
import Simplex.Chat.Migrations.M20221212_chat_items_timed
import Simplex.Chat.Migrations.M20221214_live_message
import Simplex.Chat.Migrations.M20221222_chat_ts
import Simplex.Chat.Migrations.M20221223_idx_chat_items_item_status
import Simplex.Chat.Migrations.M20221230_idxs
import Simplex.Chat.Migrations.M20230107_connections_auth_err_counter
import Simplex.Chat.Migrations.M20230111_users_agent_user_id
import Simplex.Chat.Migrations.M20230117_fkey_indexes
import Simplex.Chat.Migrations.M20230118_recreate_smp_servers
import Simplex.Chat.Migrations.M20230129_drop_chat_items_group_idx
import Simplex.Chat.Migrations.M20230206_item_deleted_by_group_member_id
import Simplex.Chat.Migrations.M20230303_group_link_role
import Simplex.Chat.Migrations.M20230317_hidden_profiles
import Simplex.Chat.Migrations.M20230318_file_description
import Simplex.Chat.Migrations.M20230321_agent_file_deleted
import Simplex.Chat.Migrations.M20230328_files_protocol
import Simplex.Chat.Migrations.M20230402_protocol_servers
import Simplex.Chat.Migrations.M20230411_extra_xftp_file_descriptions
import Simplex.Chat.Migrations.M20230420_rcv_files_to_receive
import Simplex.Chat.Migrations.M20230422_profile_contact_links
import Simplex.Chat.Migrations.M20230504_recreate_msg_delivery_events_cleanup_messages
import Simplex.Chat.Migrations.M20230505_chat_item_versions
import Simplex.Chat.Migrations.M20230511_reactions
import Simplex.Chat.Migrations.M20230519_item_deleted_ts
import Simplex.Chat.Migrations.M20230526_indexes
import Simplex.Chat.Migrations.M20230529_indexes
import Simplex.Chat.Migrations.M20230608_deleted_contacts
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
schemaMigrations :: [(String, Query, Maybe Query)]
schemaMigrations =
[ ("20220101_initial", m20220101_initial, Nothing),
("20220122_v1_1", m20220122_v1_1, Nothing),
("20220205_chat_item_status", m20220205_chat_item_status, Nothing),
("20220210_deduplicate_contact_requests", m20220210_deduplicate_contact_requests, Nothing),
("20220224_messages_fks", m20220224_messages_fks, Nothing),
("20220301_smp_servers", m20220301_smp_servers, Nothing),
("20220302_profile_images", m20220302_profile_images, Nothing),
("20220304_msg_quotes", m20220304_msg_quotes, Nothing),
("20220321_chat_item_edited", m20220321_chat_item_edited, Nothing),
("20220404_files_status_fields", m20220404_files_status_fields, Nothing),
("20220514_profiles_user_id", m20220514_profiles_user_id, Nothing),
("20220626_auto_reply", m20220626_auto_reply, Nothing),
("20220702_calls", m20220702_calls, Nothing),
("20220715_groups_chat_item_id", m20220715_groups_chat_item_id, Nothing),
("20220811_chat_items_indices", m20220811_chat_items_indices, Nothing),
("20220812_incognito_profiles", m20220812_incognito_profiles, Nothing),
("20220818_chat_notifications", m20220818_chat_notifications, Nothing),
("20220822_groups_host_conn_custom_user_profile_id", m20220822_groups_host_conn_custom_user_profile_id, Nothing),
("20220823_delete_broken_group_event_chat_items", m20220823_delete_broken_group_event_chat_items, Nothing),
("20220824_profiles_local_alias", m20220824_profiles_local_alias, Nothing),
("20220909_commands", m20220909_commands, Nothing),
("20220926_connection_alias", m20220926_connection_alias, Nothing),
("20220928_settings", m20220928_settings, Nothing),
("20221001_shared_msg_id_indices", m20221001_shared_msg_id_indices, Nothing),
("20221003_delete_broken_integrity_error_chat_items", m20221003_delete_broken_integrity_error_chat_items, Nothing),
("20221004_idx_msg_deliveries_message_id", m20221004_idx_msg_deliveries_message_id, Nothing),
("20221011_user_contact_links_group_id", m20221011_user_contact_links_group_id, Nothing),
("20221012_inline_files", m20221012_inline_files, Nothing),
("20221019_unread_chat", m20221019_unread_chat, Nothing),
("20221021_auto_accept__group_links", m20221021_auto_accept__group_links, Nothing),
("20221024_contact_used", m20221024_contact_used, Nothing),
("20221025_chat_settings", m20221025_chat_settings, Nothing),
("20221029_group_link_id", m20221029_group_link_id, Nothing),
("20221112_server_password", m20221112_server_password, Nothing),
("20221115_server_cfg", m20221115_server_cfg, Nothing),
("20221129_delete_group_feature_items", m20221129_delete_group_feature_items, Nothing),
("20221130_delete_item_deleted", m20221130_delete_item_deleted, Nothing),
("20221209_verified_connection", m20221209_verified_connection, Nothing),
("20221210_idxs", m20221210_idxs, Nothing),
("20221211_group_description", m20221211_group_description, Nothing),
("20221212_chat_items_timed", m20221212_chat_items_timed, Nothing),
("20221214_live_message", m20221214_live_message, Nothing),
("20221222_chat_ts", m20221222_chat_ts, Nothing),
("20221223_idx_chat_items_item_status", m20221223_idx_chat_items_item_status, Nothing),
("20221230_idxs", m20221230_idxs, Nothing),
("20230107_connections_auth_err_counter", m20230107_connections_auth_err_counter, Nothing),
("20230111_users_agent_user_id", m20230111_users_agent_user_id, Nothing),
("20230117_fkey_indexes", m20230117_fkey_indexes, Nothing),
("20230118_recreate_smp_servers", m20230118_recreate_smp_servers, Nothing),
("20230129_drop_chat_items_group_idx", m20230129_drop_chat_items_group_idx, Nothing),
("20230206_item_deleted_by_group_member_id", m20230206_item_deleted_by_group_member_id, Nothing),
("20230303_group_link_role", m20230303_group_link_role, Nothing),
("20230317_hidden_profiles", m20230317_hidden_profiles, Just down_m20230317_hidden_profiles),
("20230318_file_description", m20230318_file_description, Just down_m20230318_file_description),
("20230321_agent_file_deleted", m20230321_agent_file_deleted, Just down_m20230321_agent_file_deleted),
("20230328_files_protocol", m20230328_files_protocol, Just down_m20230328_files_protocol),
("20230402_protocol_servers", m20230402_protocol_servers, Just down_m20230402_protocol_servers),
("20230411_extra_xftp_file_descriptions", m20230411_extra_xftp_file_descriptions, Just down_m20230411_extra_xftp_file_descriptions),
("20230420_rcv_files_to_receive", m20230420_rcv_files_to_receive, Just down_m20230420_rcv_files_to_receive),
("20230422_profile_contact_links", m20230422_profile_contact_links, Just down_m20230422_profile_contact_links),
("20230504_recreate_msg_delivery_events_cleanup_messages", m20230504_recreate_msg_delivery_events_cleanup_messages, Just down_m20230504_recreate_msg_delivery_events_cleanup_messages),
("20230505_chat_item_versions", m20230505_chat_item_versions, Just down_m20230505_chat_item_versions),
("20230511_reactions", m20230511_reactions, Just down_m20230511_reactions),
("20230519_item_deleted_ts", m20230519_item_deleted_ts, Just down_m20230519_item_deleted_ts),
("20230526_indexes", m20230526_indexes, Just down_m20230526_indexes),
("20230529_indexes", m20230529_indexes, Just down_m20230529_indexes),
("20230608_deleted_contacts", m20230608_deleted_contacts, Just down_m20230608_deleted_contacts)
]
-- | The list of migrations in ascending order by date
migrations :: [Migration]
migrations = sortOn name $ map migration schemaMigrations
where
migration (name, up, down) = Migration {name, up = fromQuery up, down = fromQuery <$> down}

537
src/Simplex/Chat/Store/Profiles.hs Normal file
View File

@ -0,0 +1,537 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Simplex.Chat.Store.Profiles
( AutoAccept (..),
UserContactLink (..),
createUserRecord,
createUserRecordAt,
getUsersInfo,
getUsers,
setActiveUser,
getSetActiveUser,
getUser,
getUserIdByName,
getUserByAConnId,
getUserByASndFileId,
getUserByARcvFileId,
getUserByContactId,
getUserByGroupId,
getUserByFileId,
getUserFileInfo,
deleteUserRecord,
updateUserPrivacy,
updateUserProfile,
setUserProfileContactLink,
getUserContactProfiles,
createUserContactLink,
getUserAddressConnections,
getUserContactLinks,
deleteUserAddress,
getUserAddress,
getUserContactLinkById,
updateUserAddressAutoAccept,
getProtocolServers,
overwriteProtocolServers,
createCall,
deleteCalls,
getCalls,
createCommand,
setCommandConnId,
deleteCommand,
updateCommandStatus,
getCommandDataByCorrId,
)
where
import Control.Monad.Except
import Data.Aeson (ToJSON)
import qualified Data.Aeson as J
import Data.Functor (($>))
import Data.Int (Int64)
import qualified Data.List.NonEmpty as L
import Data.Maybe (fromMaybe)
import Data.List.NonEmpty (NonEmpty)
import Data.Text (Text)
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time.Clock (UTCTime (..), getCurrentTime)
import Database.SQLite.Simple (NamedParam (..), Only (..), (:.) (..))
import qualified Database.SQLite.Simple as DB
import Database.SQLite.Simple.QQ (sql)
import GHC.Generics (Generic)
import Simplex.Chat.Call
import Simplex.Chat.Messages
import Simplex.Chat.Protocol
import Simplex.Chat.Store.Direct
import Simplex.Chat.Store.Shared
import Simplex.Chat.Types
import Simplex.Messaging.Agent.Protocol (ACorrId, ConnId, UserId)
import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..))
import Simplex.Messaging.Transport.Client (TransportHost)
import Simplex.Messaging.Util (safeDecodeUtf8)
createUserRecord :: DB.Connection -> AgentUserId -> Profile -> Bool -> ExceptT StoreError IO User
createUserRecord db auId p activeUser = createUserRecordAt db auId p activeUser =<< liftIO getCurrentTime
createUserRecordAt :: DB.Connection -> AgentUserId -> Profile -> Bool -> UTCTime -> ExceptT StoreError IO User
createUserRecordAt db (AgentUserId auId) Profile {displayName, fullName, image, preferences = userPreferences} activeUser currentTs =
checkConstraint SEDuplicateName . liftIO $ do
when activeUser $ DB.execute_ db "UPDATE users SET active_user = 0"
DB.execute
db
"INSERT INTO users (agent_user_id, local_display_name, active_user, contact_id, show_ntfs, created_at, updated_at) VALUES (?,?,?,0,?,?,?)"
(auId, displayName, activeUser, True, currentTs, currentTs)
userId <- insertedRowId db
DB.execute
db
"INSERT INTO display_names (local_display_name, ldn_base, user_id, created_at, updated_at) VALUES (?,?,?,?,?)"
(displayName, displayName, userId, currentTs, currentTs)
DB.execute
db
"INSERT INTO contact_profiles (display_name, full_name, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?)"
(displayName, fullName, image, userId, userPreferences, currentTs, currentTs)
profileId <- insertedRowId db
DB.execute
db
"INSERT INTO contacts (contact_profile_id, local_display_name, user_id, is_user, created_at, updated_at) VALUES (?,?,?,?,?,?)"
(profileId, displayName, userId, True, currentTs, currentTs)
contactId <- insertedRowId db
DB.execute db "UPDATE users SET contact_id = ? WHERE user_id = ?" (contactId, userId)
pure $ toUser $ (userId, auId, contactId, profileId, activeUser, displayName, fullName, image, Nothing, userPreferences, True) :. (Nothing, Nothing)
getUsersInfo :: DB.Connection -> IO [UserInfo]
getUsersInfo db = getUsers db >>= mapM getUserInfo
where
getUserInfo :: User -> IO UserInfo
getUserInfo user@User {userId} = do
ctCount <-
maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT COUNT(1)
FROM chat_items i
JOIN contacts ct USING (contact_id)
WHERE i.user_id = ? AND i.item_status = ? AND (ct.enable_ntfs = 1 OR ct.enable_ntfs IS NULL) AND ct.deleted = 0
|]
(userId, CISRcvNew)
gCount <-
maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT COUNT(1)
FROM chat_items i
JOIN groups g USING (group_id)
WHERE i.user_id = ? AND i.item_status = ? AND (g.enable_ntfs = 1 OR g.enable_ntfs IS NULL)
|]
(userId, CISRcvNew)
pure UserInfo {user, unreadCount = fromMaybe 0 ctCount + fromMaybe 0 gCount}
getUsers :: DB.Connection -> IO [User]
getUsers db =
map toUser <$> DB.query_ db userQuery
setActiveUser :: DB.Connection -> UserId -> IO ()
setActiveUser db userId = do
DB.execute_ db "UPDATE users SET active_user = 0"
DB.execute db "UPDATE users SET active_user = 1 WHERE user_id = ?" (Only userId)
getSetActiveUser :: DB.Connection -> UserId -> ExceptT StoreError IO User
getSetActiveUser db userId = do
liftIO $ setActiveUser db userId
getUser db userId
getUser :: DB.Connection -> UserId -> ExceptT StoreError IO User
getUser db userId =
ExceptT . firstRow toUser (SEUserNotFound userId) $
DB.query db (userQuery <> " WHERE u.user_id = ?") (Only userId)
getUserIdByName :: DB.Connection -> UserName -> ExceptT StoreError IO Int64
getUserIdByName db uName =
ExceptT . firstRow fromOnly (SEUserNotFoundByName uName) $
DB.query db "SELECT user_id FROM users WHERE local_display_name = ?" (Only uName)
getUserByAConnId :: DB.Connection -> AgentConnId -> IO (Maybe User)
getUserByAConnId db agentConnId =
maybeFirstRow toUser $
DB.query db (userQuery <> " JOIN connections c ON c.user_id = u.user_id WHERE c.agent_conn_id = ?") (Only agentConnId)
getUserByASndFileId :: DB.Connection -> AgentSndFileId -> IO (Maybe User)
getUserByASndFileId db aSndFileId =
maybeFirstRow toUser $
DB.query db (userQuery <> " JOIN files f ON f.user_id = u.user_id WHERE f.agent_snd_file_id = ?") (Only aSndFileId)
getUserByARcvFileId :: DB.Connection -> AgentRcvFileId -> IO (Maybe User)
getUserByARcvFileId db aRcvFileId =
maybeFirstRow toUser $
DB.query db (userQuery <> " JOIN files f ON f.user_id = u.user_id JOIN rcv_files r ON r.file_id = f.file_id WHERE r.agent_rcv_file_id = ?") (Only aRcvFileId)
getUserByContactId :: DB.Connection -> ContactId -> ExceptT StoreError IO User
getUserByContactId db contactId =
ExceptT . firstRow toUser (SEUserNotFoundByContactId contactId) $
DB.query db (userQuery <> " JOIN contacts ct ON ct.user_id = u.user_id WHERE ct.contact_id = ? AND ct.deleted = 0") (Only contactId)
getUserByGroupId :: DB.Connection -> GroupId -> ExceptT StoreError IO User
getUserByGroupId db groupId =
ExceptT . firstRow toUser (SEUserNotFoundByGroupId groupId) $
DB.query db (userQuery <> " JOIN groups g ON g.user_id = u.user_id WHERE g.group_id = ?") (Only groupId)
getUserByFileId :: DB.Connection -> FileTransferId -> ExceptT StoreError IO User
getUserByFileId db fileId =
ExceptT . firstRow toUser (SEUserNotFoundByFileId fileId) $
DB.query db (userQuery <> " JOIN files f ON f.user_id = u.user_id WHERE f.file_id = ?") (Only fileId)
getUserFileInfo :: DB.Connection -> User -> IO [CIFileInfo]
getUserFileInfo db User {userId} =
map toFileInfo
<$> DB.query db (fileInfoQuery <> " WHERE i.user_id = ?") (Only userId)
deleteUserRecord :: DB.Connection -> User -> IO ()
deleteUserRecord db User {userId} =
DB.execute db "DELETE FROM users WHERE user_id = ?" (Only userId)
updateUserPrivacy :: DB.Connection -> User -> IO ()
updateUserPrivacy db User {userId, showNtfs, viewPwdHash} =
DB.execute
db
[sql|
UPDATE users
SET view_pwd_hash = ?, view_pwd_salt = ?, show_ntfs = ?
WHERE user_id = ?
|]
(hashSalt viewPwdHash :. (showNtfs, userId))
where
hashSalt = L.unzip . fmap (\UserPwdHash {hash, salt} -> (hash, salt))
updateUserProfile :: DB.Connection -> User -> Profile -> ExceptT StoreError IO User
updateUserProfile db user p'
| displayName == newName = do
liftIO $ updateContactProfile_ db userId profileId p'
pure user {profile, fullPreferences}
| otherwise =
checkConstraint SEDuplicateName . liftIO $ do
currentTs <- getCurrentTime
DB.execute db "UPDATE users SET local_display_name = ?, updated_at = ? WHERE user_id = ?" (newName, currentTs, userId)
DB.execute
db
"INSERT INTO display_names (local_display_name, ldn_base, user_id, created_at, updated_at) VALUES (?,?,?,?,?)"
(newName, newName, userId, currentTs, currentTs)
updateContactProfile_' db userId profileId p' currentTs
updateContact_ db userId userContactId localDisplayName newName currentTs
pure user {localDisplayName = newName, profile, fullPreferences}
where
User {userId, userContactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}} = user
Profile {displayName = newName, preferences} = p'
profile = toLocalProfile profileId p' localAlias
fullPreferences = mergePreferences Nothing preferences
setUserProfileContactLink :: DB.Connection -> User -> Maybe UserContactLink -> IO User
setUserProfileContactLink db user@User {userId, profile = p@LocalProfile {profileId}} ucl_ = do
ts <- getCurrentTime
DB.execute
db
[sql|
UPDATE contact_profiles
SET contact_link = ?, updated_at = ?
WHERE user_id = ? AND contact_profile_id = ?
|]
(connReqContact_, ts, userId, profileId)
pure (user :: User) {profile = p {contactLink = connReqContact_}}
where
connReqContact_ = case ucl_ of
Just UserContactLink {connReqContact} -> Just connReqContact
_ -> Nothing
-- only used in tests
getUserContactProfiles :: DB.Connection -> User -> IO [Profile]
getUserContactProfiles db User {userId} =
map toContactProfile
<$> DB.query
db
[sql|
SELECT display_name, full_name, image, contact_link, preferences
FROM contact_profiles
WHERE user_id = ?
|]
(Only userId)
where
toContactProfile :: (ContactName, Text, Maybe ImageData, Maybe ConnReqContact, Maybe Preferences) -> (Profile)
toContactProfile (displayName, fullName, image, contactLink, preferences) = Profile {displayName, fullName, image, contactLink, preferences}
createUserContactLink :: DB.Connection -> User -> ConnId -> ConnReqContact -> ExceptT StoreError IO ()
createUserContactLink db User {userId} agentConnId cReq =
checkConstraint SEDuplicateContactLink . liftIO $ do
currentTs <- getCurrentTime
DB.execute
db
"INSERT INTO user_contact_links (user_id, conn_req_contact, created_at, updated_at) VALUES (?,?,?,?)"
(userId, cReq, currentTs, currentTs)
userContactLinkId <- insertedRowId db
void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId Nothing Nothing Nothing 0 currentTs
getUserAddressConnections :: DB.Connection -> User -> ExceptT StoreError IO [Connection]
getUserAddressConnections db User {userId} = do
cs <- liftIO getUserAddressConnections_
if null cs then throwError SEUserContactLinkNotFound else pure cs
where
getUserAddressConnections_ :: IO [Connection]
getUserAddressConnections_ =
map toConnection
<$> DB.query
db
[sql|
SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id,
c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter
FROM connections c
JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id
WHERE c.user_id = ? AND uc.user_id = ? AND uc.local_display_name = '' AND uc.group_id IS NULL
|]
(userId, userId)
getUserContactLinks :: DB.Connection -> User -> IO [(Connection, UserContact)]
getUserContactLinks db User {userId} =
map toUserContactConnection
<$> DB.query
db
[sql|
SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id,
c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter,
uc.user_contact_link_id, uc.conn_req_contact, uc.group_id
FROM connections c
JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id
WHERE c.user_id = ? AND uc.user_id = ?
|]
(userId, userId)
where
toUserContactConnection :: (ConnectionRow :. (Int64, ConnReqContact, Maybe GroupId)) -> (Connection, UserContact)
toUserContactConnection (connRow :. (userContactLinkId, connReqContact, groupId)) = (toConnection connRow, UserContact {userContactLinkId, connReqContact, groupId})
deleteUserAddress :: DB.Connection -> User -> IO ()
deleteUserAddress db user@User {userId} = do
DB.execute
db
[sql|
DELETE FROM connections WHERE connection_id IN (
SELECT connection_id
FROM connections c
JOIN user_contact_links uc USING (user_contact_link_id)
WHERE uc.user_id = ? AND uc.local_display_name = '' AND uc.group_id IS NULL
)
|]
(Only userId)
DB.executeNamed
db
[sql|
DELETE FROM display_names
WHERE user_id = :user_id
AND local_display_name in (
SELECT cr.local_display_name
FROM contact_requests cr
JOIN user_contact_links uc USING (user_contact_link_id)
WHERE uc.user_id = :user_id AND uc.local_display_name = '' AND uc.group_id IS NULL
)
|]
[":user_id" := userId]
DB.executeNamed
db
[sql|
DELETE FROM contact_profiles
WHERE contact_profile_id in (
SELECT cr.contact_profile_id
FROM contact_requests cr
JOIN user_contact_links uc USING (user_contact_link_id)
WHERE uc.user_id = :user_id AND uc.local_display_name = '' AND uc.group_id IS NULL
)
|]
[":user_id" := userId]
void $ setUserProfileContactLink db user Nothing
DB.execute db "DELETE FROM user_contact_links WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL" (Only userId)
data UserContactLink = UserContactLink
{ connReqContact :: ConnReqContact,
autoAccept :: Maybe AutoAccept
}
deriving (Show, Generic)
instance ToJSON UserContactLink where toEncoding = J.genericToEncoding J.defaultOptions
data AutoAccept = AutoAccept
{ acceptIncognito :: Bool,
autoReply :: Maybe MsgContent
}
deriving (Show, Generic)
instance ToJSON AutoAccept where toEncoding = J.genericToEncoding J.defaultOptions
toUserContactLink :: (ConnReqContact, Bool, Bool, Maybe MsgContent) -> UserContactLink
toUserContactLink (connReq, autoAccept, acceptIncognito, autoReply) =
UserContactLink connReq $
if autoAccept then Just AutoAccept {acceptIncognito, autoReply} else Nothing
getUserAddress :: DB.Connection -> User -> ExceptT StoreError IO UserContactLink
getUserAddress db User {userId} =
ExceptT . firstRow toUserContactLink SEUserContactLinkNotFound $
DB.query
db
[sql|
SELECT conn_req_contact, auto_accept, auto_accept_incognito, auto_reply_msg_content
FROM user_contact_links
WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL
|]
(Only userId)
getUserContactLinkById :: DB.Connection -> UserId -> Int64 -> IO (Maybe (UserContactLink, Maybe GroupId, GroupMemberRole))
getUserContactLinkById db userId userContactLinkId =
maybeFirstRow (\(ucl :. (groupId_, mRole_)) -> (toUserContactLink ucl, groupId_, fromMaybe GRMember mRole_)) $
DB.query
db
[sql|
SELECT conn_req_contact, auto_accept, auto_accept_incognito, auto_reply_msg_content, group_id, group_link_member_role
FROM user_contact_links
WHERE user_id = ?
AND user_contact_link_id = ?
|]
(userId, userContactLinkId)
updateUserAddressAutoAccept :: DB.Connection -> User -> Maybe AutoAccept -> ExceptT StoreError IO UserContactLink
updateUserAddressAutoAccept db user@User {userId} autoAccept = do
link <- getUserAddress db user
liftIO updateUserAddressAutoAccept_ $> link {autoAccept}
where
updateUserAddressAutoAccept_ =
DB.execute
db
[sql|
UPDATE user_contact_links
SET auto_accept = ?, auto_accept_incognito = ?, auto_reply_msg_content = ?
WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL
|]
(ucl :. Only userId)
ucl = case autoAccept of
Just AutoAccept {acceptIncognito, autoReply} -> (True, acceptIncognito, autoReply)
_ -> (False, False, Nothing)
getProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> IO [ServerCfg p]
getProtocolServers db User {userId} =
map toServerCfg
<$> DB.query
db
[sql|
SELECT host, port, key_hash, basic_auth, preset, tested, enabled
FROM protocol_servers
WHERE user_id = ? AND protocol = ?;
|]
(userId, decodeLatin1 $ strEncode protocol)
where
protocol = protocolTypeI @p
toServerCfg :: (NonEmpty TransportHost, String, C.KeyHash, Maybe Text, Bool, Maybe Bool, Bool) -> ServerCfg p
toServerCfg (host, port, keyHash, auth_, preset, tested, enabled) =
let server = ProtoServerWithAuth (ProtocolServer protocol host port keyHash) (BasicAuth . encodeUtf8 <$> auth_)
in ServerCfg {server, preset, tested, enabled}
overwriteProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> [ServerCfg p] -> ExceptT StoreError IO ()
overwriteProtocolServers db User {userId} servers =
checkConstraint SEUniqueID . ExceptT $ do
currentTs <- getCurrentTime
DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND protocol = ? " (userId, protocol)
forM_ servers $ \ServerCfg {server, preset, tested, enabled} -> do
let ProtoServerWithAuth ProtocolServer {host, port, keyHash} auth_ = server
DB.execute
db
[sql|
INSERT INTO protocol_servers
(protocol, host, port, key_hash, basic_auth, preset, tested, enabled, user_id, created_at, updated_at)
VALUES (?,?,?,?,?,?,?,?,?,?,?)
|]
((protocol, host, port, keyHash, safeDecodeUtf8 . unBasicAuth <$> auth_) :. (preset, tested, enabled, userId, currentTs, currentTs))
pure $ Right ()
where
protocol = decodeLatin1 $ strEncode $ protocolTypeI @p
createCall :: DB.Connection -> User -> Call -> UTCTime -> IO ()
createCall db user@User {userId} Call {contactId, callId, chatItemId, callState} callTs = do
currentTs <- getCurrentTime
deleteCalls db user contactId
DB.execute
db
[sql|
INSERT INTO calls
(contact_id, shared_call_id, chat_item_id, call_state, call_ts, user_id, created_at, updated_at)
VALUES (?,?,?,?,?,?,?,?)
|]
(contactId, callId, chatItemId, callState, callTs, userId, currentTs, currentTs)
deleteCalls :: DB.Connection -> User -> ContactId -> IO ()
deleteCalls db User {userId} contactId = do
DB.execute db "DELETE FROM calls WHERE user_id = ? AND contact_id = ?" (userId, contactId)
getCalls :: DB.Connection -> IO [Call]
getCalls db =
map toCall
<$> DB.query_
db
[sql|
SELECT
contact_id, shared_call_id, chat_item_id, call_state, call_ts
FROM calls
ORDER BY call_ts ASC
|]
where
toCall :: (ContactId, CallId, ChatItemId, CallState, UTCTime) -> Call
toCall (contactId, callId, chatItemId, callState, callTs) = Call {contactId, callId, chatItemId, callState, callTs}
createCommand :: DB.Connection -> User -> Maybe Int64 -> CommandFunction -> IO CommandId
createCommand db User {userId} connId commandFunction = do
currentTs <- getCurrentTime
DB.execute
db
[sql|
INSERT INTO commands (connection_id, command_function, command_status, user_id, created_at, updated_at)
VALUES (?,?,?,?,?,?)
|]
(connId, commandFunction, CSCreated, userId, currentTs, currentTs)
insertedRowId db
deleteCommand :: DB.Connection -> User -> CommandId -> IO ()
deleteCommand db User {userId} cmdId =
DB.execute db "DELETE FROM commands WHERE user_id = ? AND command_id = ?" (userId, cmdId)
updateCommandStatus :: DB.Connection -> User -> CommandId -> CommandStatus -> IO ()
updateCommandStatus db User {userId} cmdId status = do
updatedAt <- getCurrentTime
DB.execute
db
[sql|
UPDATE commands
SET command_status = ?, updated_at = ?
WHERE user_id = ? AND command_id = ?
|]
(status, updatedAt, userId, cmdId)
getCommandDataByCorrId :: DB.Connection -> User -> ACorrId -> IO (Maybe CommandData)
getCommandDataByCorrId db User {userId} corrId =
maybeFirstRow toCommandData $
DB.query
db
[sql|
SELECT command_id, connection_id, command_function, command_status
FROM commands
WHERE user_id = ? AND command_id = ?
|]
(userId, commandId corrId)
where
toCommandData :: (CommandId, Maybe Int64, CommandFunction, CommandStatus) -> CommandData
toCommandData (cmdId, cmdConnId, cmdFunction, cmdStatus) = CommandData {cmdId, cmdConnId, cmdFunction, cmdStatus}

332
src/Simplex/Chat/Store/Shared.hs Normal file
View File

@ -0,0 +1,332 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module Simplex.Chat.Store.Shared where
import Control.Concurrent.STM (stateTVar)
import Control.Exception (Exception)
import qualified Control.Exception as E
import Control.Monad.Except
import Crypto.Random (ChaChaDRG, randomBytesGenerate)
import Data.Aeson (ToJSON)
import qualified Data.Aeson as J
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Base64 as B64
import Data.Int (Int64)
import Data.Maybe (fromMaybe, isJust, listToMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (UTCTime (..), getCurrentTime)
import Database.SQLite.Simple (NamedParam (..), Only (..), Query, SQLError, (:.) (..))
import qualified Database.SQLite.Simple as DB
import Database.SQLite.Simple.QQ (sql)
import GHC.Generics (Generic)
import Simplex.Chat.Messages
import Simplex.Chat.Protocol
import Simplex.Chat.Types
import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, UserId)
import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
import UnliftIO.STM
-- These error type constructors must be added to mobile apps
data StoreError
= SEDuplicateName
| SEUserNotFound {userId :: UserId}
| SEUserNotFoundByName {contactName :: ContactName}
| SEUserNotFoundByContactId {contactId :: ContactId}
| SEUserNotFoundByGroupId {groupId :: GroupId}
| SEUserNotFoundByFileId {fileId :: FileTransferId}
| SEUserNotFoundByContactRequestId {contactRequestId :: Int64}
| SEContactNotFound {contactId :: ContactId}
| SEContactNotFoundByName {contactName :: ContactName}
| SEContactNotReady {contactName :: ContactName}
| SEDuplicateContactLink
| SEUserContactLinkNotFound
| SEContactRequestNotFound {contactRequestId :: Int64}
| SEContactRequestNotFoundByName {contactName :: ContactName}
| SEGroupNotFound {groupId :: GroupId}
| SEGroupNotFoundByName {groupName :: GroupName}
| SEGroupMemberNameNotFound {groupId :: GroupId, groupMemberName :: ContactName}
| SEGroupMemberNotFound {groupMemberId :: GroupMemberId}
| SEGroupWithoutUser
| SEDuplicateGroupMember
| SEGroupAlreadyJoined
| SEGroupInvitationNotFound
| SESndFileNotFound {fileId :: FileTransferId}
| SESndFileInvalid {fileId :: FileTransferId}
| SERcvFileNotFound {fileId :: FileTransferId}
| SERcvFileDescrNotFound {fileId :: FileTransferId}
| SEFileNotFound {fileId :: FileTransferId}
| SERcvFileInvalid {fileId :: FileTransferId}
| SERcvFileInvalidDescrPart
| SESharedMsgIdNotFoundByFileId {fileId :: FileTransferId}
| SEFileIdNotFoundBySharedMsgId {sharedMsgId :: SharedMsgId}
| SESndFileNotFoundXFTP {agentSndFileId :: AgentSndFileId}
| SERcvFileNotFoundXFTP {agentRcvFileId :: AgentRcvFileId}
| SEConnectionNotFound {agentConnId :: AgentConnId}
| SEConnectionNotFoundById {connId :: Int64}
| SEPendingConnectionNotFound {connId :: Int64}
| SEIntroNotFound
| SEUniqueID
| SEInternalError {message :: String}
| SENoMsgDelivery {connId :: Int64, agentMsgId :: AgentMsgId}
| SEBadChatItem {itemId :: ChatItemId}
| SEChatItemNotFound {itemId :: ChatItemId}
| SEChatItemNotFoundByText {text :: Text}
| SEChatItemSharedMsgIdNotFound {sharedMsgId :: SharedMsgId}
| SEChatItemNotFoundByFileId {fileId :: FileTransferId}
| SEChatItemNotFoundByGroupId {groupId :: GroupId}
| SEProfileNotFound {profileId :: Int64}
| SEDuplicateGroupLink {groupInfo :: GroupInfo}
| SEGroupLinkNotFound {groupInfo :: GroupInfo}
| SEHostMemberIdNotFound {groupId :: Int64}
| SEContactNotFoundByFileId {fileId :: FileTransferId}
deriving (Show, Exception, Generic)
instance ToJSON StoreError where
toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "SE"
toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "SE"
insertedRowId :: DB.Connection -> IO Int64
insertedRowId db = fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid()"
checkConstraint :: StoreError -> ExceptT StoreError IO a -> ExceptT StoreError IO a
checkConstraint err action = ExceptT $ runExceptT action `E.catch` (pure . Left . handleSQLError err)
handleSQLError :: StoreError -> SQLError -> StoreError
handleSQLError err e
| DB.sqlError e == DB.ErrorConstraint = err
| otherwise = SEInternalError $ show e
fileInfoQuery :: Query
fileInfoQuery =
[sql|
SELECT f.file_id, f.ci_file_status, f.file_path
FROM chat_items i
JOIN files f ON f.chat_item_id = i.chat_item_id
|]
toFileInfo :: (Int64, Maybe ACIFileStatus, Maybe FilePath) -> CIFileInfo
toFileInfo (fileId, fileStatus, filePath) = CIFileInfo {fileId, fileStatus, filePath}
type EntityIdsRow = (Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64)
type ConnectionRow = (Int64, ConnId, Int, Maybe Int64, Maybe Int64, Bool, Maybe GroupLinkId, Maybe Int64, ConnStatus, ConnType, LocalAlias) :. EntityIdsRow :. (UTCTime, Maybe Text, Maybe UTCTime, Int)
type MaybeConnectionRow = (Maybe Int64, Maybe ConnId, Maybe Int, Maybe Int64, Maybe Int64, Maybe Bool, Maybe GroupLinkId, Maybe Int64, Maybe ConnStatus, Maybe ConnType, Maybe LocalAlias) :. EntityIdsRow :. (Maybe UTCTime, Maybe Text, Maybe UTCTime, Maybe Int)
toConnection :: ConnectionRow -> Connection
toConnection ((connId, acId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (createdAt, code_, verifiedAt_, authErrCounter)) =
let entityId = entityId_ connType
connectionCode = SecurityCode <$> code_ <*> verifiedAt_
in Connection {connId, agentConnId = AgentConnId acId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, localAlias, entityId, connectionCode, authErrCounter, createdAt}
where
entityId_ :: ConnType -> Maybe Int64
entityId_ ConnContact = contactId
entityId_ ConnMember = groupMemberId
entityId_ ConnRcvFile = rcvFileId
entityId_ ConnSndFile = sndFileId
entityId_ ConnUserContact = userContactLinkId
toMaybeConnection :: MaybeConnectionRow -> Maybe Connection
toMaybeConnection ((Just connId, Just agentConnId, Just connLevel, viaContact, viaUserContactLink, Just viaGroupLink, groupLinkId, customUserProfileId, Just connStatus, Just connType, Just localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (Just createdAt, code_, verifiedAt_, Just authErrCounter)) =
Just $ toConnection ((connId, agentConnId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (createdAt, code_, verifiedAt_, authErrCounter))
toMaybeConnection _ = Nothing
createConnection_ :: DB.Connection -> UserId -> ConnType -> Maybe Int64 -> ConnId -> Maybe ContactId -> Maybe Int64 -> Maybe ProfileId -> Int -> UTCTime -> IO Connection
createConnection_ db userId connType entityId acId viaContact viaUserContactLink customUserProfileId connLevel currentTs = do
viaLinkGroupId :: Maybe Int64 <- fmap join . forM viaUserContactLink $ \ucLinkId ->
maybeFirstRow fromOnly $ DB.query db "SELECT group_id FROM user_contact_links WHERE user_id = ? AND user_contact_link_id = ? AND group_id IS NOT NULL" (userId, ucLinkId)
let viaGroupLink = isJust viaLinkGroupId
DB.execute
db
[sql|
INSERT INTO connections (
user_id, agent_conn_id, conn_level, via_contact, via_user_contact_link, via_group_link, custom_user_profile_id, conn_status, conn_type,
contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at, updated_at
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|]
( (userId, acId, connLevel, viaContact, viaUserContactLink, viaGroupLink, customUserProfileId, ConnNew, connType)
:. (ent ConnContact, ent ConnMember, ent ConnSndFile, ent ConnRcvFile, ent ConnUserContact, currentTs, currentTs)
)
connId <- insertedRowId db
pure Connection {connId, agentConnId = AgentConnId acId, connType, entityId, viaContact, viaUserContactLink, viaGroupLink, groupLinkId = Nothing, customUserProfileId, connLevel, connStatus = ConnNew, localAlias = "", createdAt = currentTs, connectionCode = Nothing, authErrCounter = 0}
where
ent ct = if connType == ct then entityId else Nothing
setCommandConnId :: DB.Connection -> User -> CommandId -> Int64 -> IO ()
setCommandConnId db User {userId} cmdId connId = do
updatedAt <- getCurrentTime
DB.execute
db
[sql|
UPDATE commands
SET connection_id = ?, updated_at = ?
WHERE user_id = ? AND command_id = ?
|]
(connId, updatedAt, userId, cmdId)
createContact_ :: DB.Connection -> UserId -> Int64 -> Profile -> LocalAlias -> Maybe Int64 -> UTCTime -> Maybe UTCTime -> ExceptT StoreError IO (Text, ContactId, ProfileId)
createContact_ db userId connId Profile {displayName, fullName, image, contactLink, preferences} localAlias viaGroup currentTs chatTs =
ExceptT . withLocalDisplayName db userId displayName $ \ldn -> do
DB.execute
db
"INSERT INTO contact_profiles (display_name, full_name, image, contact_link, user_id, local_alias, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
(displayName, fullName, image, contactLink, userId, localAlias, preferences, currentTs, currentTs)
profileId <- insertedRowId db
DB.execute
db
"INSERT INTO contacts (contact_profile_id, local_display_name, user_id, via_group, created_at, updated_at, chat_ts) VALUES (?,?,?,?,?,?,?)"
(profileId, ldn, userId, viaGroup, currentTs, currentTs, chatTs)
contactId <- insertedRowId db
DB.execute db "UPDATE connections SET contact_id = ?, updated_at = ? WHERE connection_id = ?" (contactId, currentTs, connId)
pure $ Right (ldn, contactId, profileId)
deleteUnusedIncognitoProfileById_ :: DB.Connection -> User -> ProfileId -> IO ()
deleteUnusedIncognitoProfileById_ db User {userId} profile_id =
DB.executeNamed
db
[sql|
DELETE FROM contact_profiles
WHERE user_id = :user_id AND contact_profile_id = :profile_id AND incognito = 1
AND 1 NOT IN (
SELECT 1 FROM connections
WHERE user_id = :user_id AND custom_user_profile_id = :profile_id LIMIT 1
)
AND 1 NOT IN (
SELECT 1 FROM group_members
WHERE user_id = :user_id AND member_profile_id = :profile_id LIMIT 1
)
|]
[":user_id" := userId, ":profile_id" := profile_id]
type ContactRow = (ContactId, ProfileId, ContactName, Maybe Int64, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Bool, Maybe Bool) :. (Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime)
toContact :: User -> ContactRow :. ConnectionRow -> Contact
toContact user (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, enableNtfs_) :. (preferences, userPreferences, createdAt, updatedAt, chatTs)) :. connRow) =
let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias}
activeConn = toConnection connRow
chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_}
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn
in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs}
toContactOrError :: User -> ContactRow :. MaybeConnectionRow -> Either StoreError Contact
toContactOrError user (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, enableNtfs_) :. (preferences, userPreferences, createdAt, updatedAt, chatTs)) :. connRow) =
let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias}
chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_}
in case toMaybeConnection connRow of
Just activeConn ->
let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn
in Right Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs}
_ -> Left $ SEContactNotReady localDisplayName
getProfileById :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO LocalProfile
getProfileById db userId profileId =
ExceptT . firstRow toProfile (SEProfileNotFound profileId) $
DB.query
db
[sql|
SELECT cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, cp.preferences -- , ct.user_preferences
FROM contact_profiles cp
WHERE cp.user_id = ? AND cp.contact_profile_id = ?
|]
(userId, profileId)
where
toProfile :: (ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Preferences) -> LocalProfile
toProfile (displayName, fullName, image, contactLink, localAlias, preferences) = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias}
type ContactRequestRow = (Int64, ContactName, AgentInvId, Int64, AgentConnId, Int64, ContactName, Text, Maybe ImageData, Maybe ConnReqContact) :. (Maybe XContactId, Maybe Preferences, UTCTime, UTCTime)
toContactRequest :: ContactRequestRow -> UserContactRequest
toContactRequest ((contactRequestId, localDisplayName, agentInvitationId, userContactLinkId, agentContactConnId, profileId, displayName, fullName, image, contactLink) :. (xContactId, preferences, createdAt, updatedAt)) = do
let profile = Profile {displayName, fullName, image, contactLink, preferences}
in UserContactRequest {contactRequestId, agentInvitationId, userContactLinkId, agentContactConnId, localDisplayName, profileId, profile, xContactId, createdAt, updatedAt}
userQuery :: Query
userQuery =
[sql|
SELECT u.user_id, u.agent_user_id, u.contact_id, ucp.contact_profile_id, u.active_user, u.local_display_name, ucp.full_name, ucp.image, ucp.contact_link, ucp.preferences, u.show_ntfs, u.view_pwd_hash, u.view_pwd_salt
FROM users u
JOIN contacts uct ON uct.contact_id = u.contact_id
JOIN contact_profiles ucp ON ucp.contact_profile_id = uct.contact_profile_id
|]
toUser :: (UserId, UserId, ContactId, ProfileId, Bool, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, Maybe Preferences, Bool) :. (Maybe B64UrlByteString, Maybe B64UrlByteString) -> User
toUser ((userId, auId, userContactId, profileId, activeUser, displayName, fullName, image, contactLink, userPreferences, showNtfs) :. (viewPwdHash_, viewPwdSalt_)) =
User {userId, agentUserId = AgentUserId auId, userContactId, localDisplayName = displayName, profile, activeUser, fullPreferences, showNtfs, viewPwdHash}
where
profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences = userPreferences, localAlias = ""}
fullPreferences = mergePreferences Nothing userPreferences
viewPwdHash = UserPwdHash <$> viewPwdHash_ <*> viewPwdSalt_
toPendingContactConnection :: (Int64, ConnId, ConnStatus, Maybe ByteString, Maybe Int64, Maybe GroupLinkId, Maybe Int64, Maybe ConnReqInvitation, LocalAlias, UTCTime, UTCTime) -> PendingContactConnection
toPendingContactConnection (pccConnId, acId, pccConnStatus, connReqHash, viaUserContactLink, groupLinkId, customUserProfileId, connReqInv, localAlias, createdAt, updatedAt) =
PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = isJust connReqHash, viaUserContactLink, groupLinkId, customUserProfileId, connReqInv, localAlias, createdAt, updatedAt}
-- | Saves unique local display name based on passed displayName, suffixed with _N if required.
-- This function should be called inside transaction.
withLocalDisplayName :: forall a. DB.Connection -> UserId -> Text -> (Text -> IO (Either StoreError a)) -> IO (Either StoreError a)
withLocalDisplayName db userId displayName action = getLdnSuffix >>= (`tryCreateName` 20)
where
getLdnSuffix :: IO Int
getLdnSuffix =
maybe 0 ((+ 1) . fromOnly) . listToMaybe
<$> DB.queryNamed
db
[sql|
SELECT ldn_suffix FROM display_names
WHERE user_id = :user_id AND ldn_base = :display_name
ORDER BY ldn_suffix DESC
LIMIT 1
|]
[":user_id" := userId, ":display_name" := displayName]
tryCreateName :: Int -> Int -> IO (Either StoreError a)
tryCreateName _ 0 = pure $ Left SEDuplicateName
tryCreateName ldnSuffix attempts = do
currentTs <- getCurrentTime
let ldn = displayName <> (if ldnSuffix == 0 then "" else T.pack $ '_' : show ldnSuffix)
E.try (insertName ldn currentTs) >>= \case
Right () -> action ldn
Left e
| DB.sqlError e == DB.ErrorConstraint -> tryCreateName (ldnSuffix + 1) (attempts - 1)
| otherwise -> E.throwIO e
where
insertName ldn ts =
DB.execute
db
[sql|
INSERT INTO display_names
(local_display_name, ldn_base, ldn_suffix, user_id, created_at, updated_at)
VALUES (?,?,?,?,?,?)
|]
(ldn, displayName, ldnSuffix, userId, ts, ts)
createWithRandomId :: forall a. TVar ChaChaDRG -> (ByteString -> IO a) -> ExceptT StoreError IO a
createWithRandomId = createWithRandomBytes 12
createWithRandomBytes :: forall a. Int -> TVar ChaChaDRG -> (ByteString -> IO a) -> ExceptT StoreError IO a
createWithRandomBytes size gVar create = tryCreate 3
where
tryCreate :: Int -> ExceptT StoreError IO a
tryCreate 0 = throwError SEUniqueID
tryCreate n = do
id' <- liftIO $ encodedRandomBytes gVar size
liftIO (E.try $ create id') >>= \case
Right x -> pure x
Left e
| DB.sqlError e == DB.ErrorConstraint -> tryCreate (n - 1)
| otherwise -> throwError . SEInternalError $ show e
encodedRandomBytes :: TVar ChaChaDRG -> Int -> IO ByteString
encodedRandomBytes gVar = fmap B64.encode . randomBytes gVar
randomBytes :: TVar ChaChaDRG -> Int -> IO ByteString
randomBytes gVar = atomically . stateTVar gVar . randomBytesGenerate

1
tests/ChatClient.hs
View File

@ -23,6 +23,7 @@ import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatDataba
import Simplex.Chat.Core import Simplex.Chat.Core
import Simplex.Chat.Options import Simplex.Chat.Options
import Simplex.Chat.Store import Simplex.Chat.Store
import Simplex.Chat.Store.Profiles
import Simplex.Chat.Terminal import Simplex.Chat.Terminal
import Simplex.Chat.Terminal.Output (newChatTerminal) import Simplex.Chat.Terminal.Output (newChatTerminal)
import Simplex.Chat.Types (AgentUserId (..), Profile, User (..)) import Simplex.Chat.Types (AgentUserId (..), Profile, User (..))

2
tests/ChatTests/Utils.hs
View File

@ -18,7 +18,7 @@ import Data.Maybe (fromMaybe)
import Data.String import Data.String
import qualified Data.Text as T import qualified Data.Text as T
import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), InlineFilesConfig (..), defaultInlineFilesConfig) import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), InlineFilesConfig (..), defaultInlineFilesConfig)
import Simplex.Chat.Store (getUserContactProfiles) import Simplex.Chat.Store.Profiles (getUserContactProfiles)
import Simplex.Chat.Types import Simplex.Chat.Types
import Simplex.Messaging.Agent.Store.SQLite (withTransaction) import Simplex.Messaging.Agent.Store.SQLite (withTransaction)
import Simplex.Messaging.Encoding.String import Simplex.Messaging.Encoding.String

1
tests/MobileTests.hs
View File

@ -6,6 +6,7 @@ import ChatTests.Utils
import Control.Monad.Except import Control.Monad.Except
import Simplex.Chat.Mobile import Simplex.Chat.Mobile
import Simplex.Chat.Store import Simplex.Chat.Store
import Simplex.Chat.Store.Profiles
import Simplex.Chat.Types (AgentUserId (..), Profile (..)) import Simplex.Chat.Types (AgentUserId (..), Profile (..))
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..)) import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..))
import System.FilePath ((</>)) import System.FilePath ((</>))