core: split Store.hs to multiple files for faster re-compilation (#2589)
* core: split Store.hs to multiple files for faster re-compilation * remove unused compiler pragmas
This commit is contained in:
parent
9fbcc2b5bb
commit
e1370e8f3c
@ -107,6 +107,14 @@ library
|
||||
Simplex.Chat.ProfileGenerator
|
||||
Simplex.Chat.Protocol
|
||||
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.Terminal
|
||||
Simplex.Chat.Terminal.Input
|
||||
|
@ -58,6 +58,13 @@ import Simplex.Chat.Options
|
||||
import Simplex.Chat.ProfileGenerator (generateRandomProfile)
|
||||
import Simplex.Chat.Protocol
|
||||
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.FileTransfer.Client.Main (maxFileSize)
|
||||
import Simplex.FileTransfer.Client.Presets (defaultXFTPServers)
|
||||
|
@ -37,6 +37,7 @@ import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList)
|
||||
import Simplex.Chat.Mobile.WebRTC
|
||||
import Simplex.Chat.Options
|
||||
import Simplex.Chat.Store
|
||||
import Simplex.Chat.Store.Profiles
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent.Env.SQLite (createAgentStore)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), MigrationError)
|
||||
|
File diff suppressed because it is too large
Load Diff
142
src/Simplex/Chat/Store/Connections.hs
Normal file
142
src/Simplex/Chat/Store/Connections.hs
Normal 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
689
src/Simplex/Chat/Store/Direct.hs
Normal 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
868
src/Simplex/Chat/Store/Files.hs
Normal 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
1295
src/Simplex/Chat/Store/Groups.hs
Normal file
File diff suppressed because it is too large
Load Diff
1805
src/Simplex/Chat/Store/Messages.hs
Normal file
1805
src/Simplex/Chat/Store/Messages.hs
Normal file
File diff suppressed because it is too large
Load Diff
151
src/Simplex/Chat/Store/Migrations.hs
Normal file
151
src/Simplex/Chat/Store/Migrations.hs
Normal 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
537
src/Simplex/Chat/Store/Profiles.hs
Normal 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
332
src/Simplex/Chat/Store/Shared.hs
Normal 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
|
@ -23,6 +23,7 @@ import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatDataba
|
||||
import Simplex.Chat.Core
|
||||
import Simplex.Chat.Options
|
||||
import Simplex.Chat.Store
|
||||
import Simplex.Chat.Store.Profiles
|
||||
import Simplex.Chat.Terminal
|
||||
import Simplex.Chat.Terminal.Output (newChatTerminal)
|
||||
import Simplex.Chat.Types (AgentUserId (..), Profile, User (..))
|
||||
|
@ -18,7 +18,7 @@ import Data.Maybe (fromMaybe)
|
||||
import Data.String
|
||||
import qualified Data.Text as T
|
||||
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.Messaging.Agent.Store.SQLite (withTransaction)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
|
@ -6,6 +6,7 @@ import ChatTests.Utils
|
||||
import Control.Monad.Except
|
||||
import Simplex.Chat.Mobile
|
||||
import Simplex.Chat.Store
|
||||
import Simplex.Chat.Store.Profiles
|
||||
import Simplex.Chat.Types (AgentUserId (..), Profile (..))
|
||||
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..))
|
||||
import System.FilePath ((</>))
|
||||
|
Loading…
Reference in New Issue
Block a user