mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-06-28 12:19:54 +00:00
45e395d35a
* core, ui: optionally use short links (#5799) * core: optionally use short links * update test * update simplexmq, short group links * fix query * fix parser for _connect * ios: use short links * shorten links to remove fingerprint and onion hosts from known servers * fix parser * tests * nix * update query plans * update simplexmq, simplex: schema for short links * simplexmq * update ios * fix short links in ios * android: use short links * fix short group links, test short link connection plans * core: fix connection plan to recognize own short links * update simplexmq * space * all tests * relative symlinks in simplexmq to fix windows build * core: improve connection plan for short links (#5825) * core: improve connection plan for short links * improve connection plans * update UI * update simplexmq * ios: add preset server domains to entitlements, add short link paths to .well-known/apple-app-site-association * update simplexmq * fix group short link in iOS, fix simplex:/ scheme saved to database or used for connection plans * update simplexmq * ios: delay opening URI from outside until the app is started * update simplexmq
938 lines
42 KiB
Haskell
938 lines
42 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DeriveAnyClass #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
|
|
|
module Simplex.Chat.Store.Profiles
|
|
( AutoAccept (..),
|
|
UserMsgReceiptSettings (..),
|
|
UserContactLink (..),
|
|
GroupLinkInfo (..),
|
|
createUserRecord,
|
|
createUserRecordAt,
|
|
getUsersInfo,
|
|
getUsers,
|
|
setActiveUser,
|
|
getUser,
|
|
getUserIdByName,
|
|
getUserByAConnId,
|
|
getUserByASndFileId,
|
|
getUserByARcvFileId,
|
|
getUserByContactId,
|
|
getUserByGroupId,
|
|
getUserByNoteFolderId,
|
|
getUserByFileId,
|
|
getUserFileInfo,
|
|
deleteUserRecord,
|
|
updateUserPrivacy,
|
|
updateAllContactReceipts,
|
|
updateUserContactReceipts,
|
|
updateUserGroupReceipts,
|
|
updateUserProfile,
|
|
setUserProfileContactLink,
|
|
getUserContactProfiles,
|
|
createUserContactLink,
|
|
getUserAddressConnections,
|
|
getUserContactLinks,
|
|
deleteUserAddress,
|
|
getUserAddress,
|
|
getUserContactLinkById,
|
|
getGroupLinkInfo,
|
|
getUserContactLinkByConnReq,
|
|
getUserContactLinkViaShortLink,
|
|
getContactWithoutConnViaAddress,
|
|
updateUserAddressAutoAccept,
|
|
getProtocolServers,
|
|
insertProtocolServer,
|
|
getUpdateServerOperators,
|
|
getServerOperators,
|
|
getUserServers,
|
|
setServerOperators,
|
|
getCurrentUsageConditions,
|
|
getLatestAcceptedConditions,
|
|
setConditionsNotified,
|
|
acceptConditions,
|
|
setUserServers,
|
|
setUserServers',
|
|
createCall,
|
|
deleteCalls,
|
|
getCalls,
|
|
createCommand,
|
|
setCommandConnId,
|
|
deleteCommand,
|
|
updateCommandStatus,
|
|
getCommandDataByCorrId,
|
|
setUserUIThemes,
|
|
)
|
|
where
|
|
|
|
import Control.Monad
|
|
import Control.Monad.Except
|
|
import Control.Monad.IO.Class
|
|
import qualified Data.Aeson.TH as J
|
|
import Data.Functor (($>))
|
|
import Data.Int (Int64)
|
|
import Data.List.NonEmpty (NonEmpty)
|
|
import qualified Data.List.NonEmpty as L
|
|
import Data.Maybe (catMaybes, fromMaybe)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
|
import Data.Time.Clock (UTCTime (..), getCurrentTime)
|
|
import Simplex.Chat.Call
|
|
import Simplex.Chat.Messages
|
|
import Simplex.Chat.Operators
|
|
import Simplex.Chat.Protocol
|
|
import Simplex.Chat.Store.Direct
|
|
import Simplex.Chat.Store.Shared
|
|
import Simplex.Chat.Types
|
|
import Simplex.Chat.Types.Preferences
|
|
import Simplex.Chat.Types.Shared
|
|
import Simplex.Chat.Types.UITheme
|
|
import Simplex.Messaging.Agent.Env.SQLite (ServerRoles (..))
|
|
import Simplex.Messaging.Agent.Protocol (ACorrId, ConnId, ConnectionLink (..), CreatedConnLink (..), UserId)
|
|
import Simplex.Messaging.Agent.Store.AgentStore (firstRow, maybeFirstRow)
|
|
import Simplex.Messaging.Agent.Store.DB (BoolInt (..))
|
|
import qualified Simplex.Messaging.Agent.Store.DB as DB
|
|
import qualified Simplex.Messaging.Crypto as C
|
|
import qualified Simplex.Messaging.Crypto.Ratchet as CR
|
|
import Simplex.Messaging.Encoding.String
|
|
import Simplex.Messaging.Parsers (defaultJSON)
|
|
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), ProtocolTypeI (..), SProtocolType (..), SubscriptionMode)
|
|
import Simplex.Messaging.Transport.Client (TransportHost)
|
|
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8)
|
|
#if defined(dbPostgres)
|
|
import Database.PostgreSQL.Simple (Only (..), Query, (:.) (..))
|
|
import Database.PostgreSQL.Simple.SqlQQ (sql)
|
|
#else
|
|
import Database.SQLite.Simple (Only (..), Query, (:.) (..))
|
|
import Database.SQLite.Simple.QQ (sql)
|
|
#endif
|
|
|
|
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"
|
|
let showNtfs = True
|
|
sendRcptsContacts = True
|
|
sendRcptsSmallGroups = True
|
|
order <- getNextActiveOrder db
|
|
DB.execute
|
|
db
|
|
"INSERT INTO users (agent_user_id, local_display_name, active_user, active_order, contact_id, show_ntfs, send_rcpts_contacts, send_rcpts_small_groups, created_at, updated_at) VALUES (?,?,?,?,0,?,?,?,?,?)"
|
|
(auId, displayName, BI activeUser, order, BI showNtfs, BI sendRcptsContacts, BI sendRcptsSmallGroups, 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, chat_ts) VALUES (?,?,?,?,?,?,?)"
|
|
(profileId, displayName, userId, BI True, currentTs, currentTs, currentTs)
|
|
contactId <- insertedRowId db
|
|
DB.execute db "UPDATE users SET contact_id = ? WHERE user_id = ?" (contactId, userId)
|
|
pure $ toUser $ (userId, auId, contactId, profileId, BI activeUser, order, displayName, fullName, image, Nothing, userPreferences) :. (BI showNtfs, BI sendRcptsContacts, BI sendRcptsSmallGroups, Nothing, Nothing, Nothing, Nothing)
|
|
|
|
-- TODO [mentions]
|
|
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 OR (g.enable_ntfs = 2 AND i.user_mention = 1))
|
|
|]
|
|
(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 -> User -> IO User
|
|
setActiveUser db user@User {userId} = do
|
|
DB.execute_ db "UPDATE users SET active_user = 0"
|
|
activeOrder <- getNextActiveOrder db
|
|
DB.execute db "UPDATE users SET active_user = 1, active_order = ? WHERE user_id = ?" (activeOrder, userId)
|
|
pure user {activeUser = True, activeOrder}
|
|
|
|
getNextActiveOrder :: DB.Connection -> IO Int64
|
|
getNextActiveOrder db = do
|
|
order <- fromMaybe 0 . join <$> maybeFirstRow fromOnly (DB.query_ db "SELECT max(active_order) FROM users")
|
|
if order == maxBound
|
|
then 0 <$ DB.execute db "UPDATE users SET active_order = active_order - ?" (Only (maxBound :: Int64))
|
|
else pure $ order + 1
|
|
|
|
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)
|
|
|
|
getUserByNoteFolderId :: DB.Connection -> NoteFolderId -> ExceptT StoreError IO User
|
|
getUserByNoteFolderId db contactId =
|
|
ExceptT . firstRow toUser (SEUserNotFoundByContactId contactId) $
|
|
DB.query db (userQuery <> " JOIN note_folders nf ON nf.user_id = u.user_id WHERE nf.note_folder_id = ?") (Only contactId)
|
|
|
|
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 :. (BI showNtfs, userId))
|
|
where
|
|
hashSalt = L.unzip . fmap (\UserPwdHash {hash, salt} -> (hash, salt))
|
|
|
|
updateAllContactReceipts :: DB.Connection -> Bool -> IO ()
|
|
updateAllContactReceipts db onOff =
|
|
DB.execute
|
|
db
|
|
"UPDATE users SET send_rcpts_contacts = ?, send_rcpts_small_groups = ? WHERE view_pwd_hash IS NULL"
|
|
(BI onOff, BI onOff)
|
|
|
|
updateUserContactReceipts :: DB.Connection -> User -> UserMsgReceiptSettings -> IO ()
|
|
updateUserContactReceipts db User {userId} UserMsgReceiptSettings {enable, clearOverrides} = do
|
|
DB.execute db "UPDATE users SET send_rcpts_contacts = ? WHERE user_id = ?" (BI enable, userId)
|
|
when clearOverrides $ DB.execute_ db "UPDATE contacts SET send_rcpts = NULL"
|
|
|
|
updateUserGroupReceipts :: DB.Connection -> User -> UserMsgReceiptSettings -> IO ()
|
|
updateUserGroupReceipts db User {userId} UserMsgReceiptSettings {enable, clearOverrides} = do
|
|
DB.execute db "UPDATE users SET send_rcpts_small_groups = ? WHERE user_id = ?" (BI enable, userId)
|
|
when clearOverrides $ DB.execute_ db "UPDATE groups SET send_rcpts = NULL"
|
|
|
|
updateUserProfile :: DB.Connection -> User -> Profile -> ExceptT StoreError IO User
|
|
updateUserProfile db user p'
|
|
| displayName == newName = liftIO $ do
|
|
updateContactProfile_ db userId profileId p'
|
|
currentTs <- getCurrentTime
|
|
userMemberProfileUpdatedAt' <- updateUserMemberProfileUpdatedAt_ currentTs
|
|
pure user {profile, fullPreferences, userMemberProfileUpdatedAt = userMemberProfileUpdatedAt'}
|
|
| otherwise =
|
|
checkConstraint SEDuplicateName . liftIO $ do
|
|
currentTs <- getCurrentTime
|
|
DB.execute db "UPDATE users SET local_display_name = ?, updated_at = ? WHERE user_id = ?" (newName, currentTs, userId)
|
|
userMemberProfileUpdatedAt' <- updateUserMemberProfileUpdatedAt_ currentTs
|
|
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
|
|
updateContactLDN_ db user userContactId localDisplayName newName currentTs
|
|
pure user {localDisplayName = newName, profile, fullPreferences, userMemberProfileUpdatedAt = userMemberProfileUpdatedAt'}
|
|
where
|
|
updateUserMemberProfileUpdatedAt_ currentTs
|
|
| userMemberProfileChanged = do
|
|
DB.execute db "UPDATE users SET user_member_profile_updated_at = ? WHERE user_id = ?" (currentTs, userId)
|
|
pure $ Just currentTs
|
|
| otherwise = pure userMemberProfileUpdatedAt
|
|
userMemberProfileChanged = newName /= displayName || newFullName /= fullName || newImage /= image
|
|
User {userId, userContactId, localDisplayName, profile = LocalProfile {profileId, displayName, fullName, image, localAlias}, userMemberProfileUpdatedAt} = user
|
|
Profile {displayName = newName, fullName = newFullName, image = newImage, 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 = ?
|
|
|]
|
|
(contactLink, ts, userId, profileId)
|
|
pure (user :: User) {profile = p {contactLink}}
|
|
where
|
|
-- TODO [short links] this should be replaced with short links once they are supported by all clients.
|
|
-- Or, maybe, we want to allow both, when both are optional.
|
|
contactLink = case ucl_ of
|
|
Just UserContactLink {connLinkContact = CCLink cReq _} -> Just $ CLFull cReq
|
|
_ -> 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 ConnLinkContact, Maybe Preferences) -> Profile
|
|
toContactProfile (displayName, fullName, image, contactLink, preferences) = Profile {displayName, fullName, image, contactLink, preferences}
|
|
|
|
createUserContactLink :: DB.Connection -> User -> ConnId -> CreatedLinkContact -> SubscriptionMode -> ExceptT StoreError IO ()
|
|
createUserContactLink db User {userId} agentConnId (CCLink cReq shortLink) subMode =
|
|
checkConstraint SEDuplicateContactLink . liftIO $ do
|
|
currentTs <- getCurrentTime
|
|
DB.execute
|
|
db
|
|
"INSERT INTO user_contact_links (user_id, conn_req_contact, short_link_contact, created_at, updated_at) VALUES (?,?,?,?,?)"
|
|
(userId, cReq, shortLink, currentTs, currentTs)
|
|
userContactLinkId <- insertedRowId db
|
|
void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId ConnNew initialChatVersion chatInitialVRange Nothing Nothing Nothing 0 currentTs subMode CR.PQSupportOff
|
|
|
|
getUserAddressConnections :: DB.Connection -> VersionRangeChat -> User -> ExceptT StoreError IO [Connection]
|
|
getUserAddressConnections db vr User {userId} = do
|
|
cs <- liftIO getUserAddressConnections_
|
|
if null cs then throwError SEUserContactLinkNotFound else pure cs
|
|
where
|
|
getUserAddressConnections_ :: IO [Connection]
|
|
getUserAddressConnections_ =
|
|
map (toConnection vr)
|
|
<$> 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.contact_conn_initiated, 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.pq_support, c.pq_encryption, c.pq_snd_enabled, c.pq_rcv_enabled, c.auth_err_counter, c.quota_err_counter,
|
|
c.conn_chat_version, c.peer_chat_min_version, c.peer_chat_max_version
|
|
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 -> VersionRangeChat -> User -> IO [(Connection, UserContact)]
|
|
getUserContactLinks db vr 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.contact_conn_initiated, 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.pq_support, c.pq_encryption, c.pq_snd_enabled, c.pq_rcv_enabled, c.auth_err_counter, c.quota_err_counter,
|
|
c.conn_chat_version, c.peer_chat_min_version, c.peer_chat_max_version,
|
|
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 vr 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.execute
|
|
db
|
|
[sql|
|
|
DELETE FROM display_names
|
|
WHERE user_id = ?
|
|
AND local_display_name in (
|
|
SELECT cr.local_display_name
|
|
FROM contact_requests cr
|
|
JOIN user_contact_links uc USING (user_contact_link_id)
|
|
WHERE uc.user_id = ? AND uc.local_display_name = '' AND uc.group_id IS NULL
|
|
)
|
|
AND local_display_name NOT IN (SELECT local_display_name FROM users WHERE user_id = ?)
|
|
|]
|
|
(userId, userId, userId)
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
DELETE FROM contact_profiles
|
|
WHERE contact_profile_id in (
|
|
SELECT cr.contact_profile_id
|
|
FROM contact_requests cr
|
|
JOIN user_contact_links uc USING (user_contact_link_id)
|
|
WHERE uc.user_id = ? AND uc.local_display_name = '' AND uc.group_id IS NULL
|
|
)
|
|
|]
|
|
(Only 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 UserMsgReceiptSettings = UserMsgReceiptSettings
|
|
{ enable :: Bool,
|
|
clearOverrides :: Bool
|
|
}
|
|
deriving (Show)
|
|
|
|
data UserContactLink = UserContactLink
|
|
{ connLinkContact :: CreatedLinkContact,
|
|
autoAccept :: Maybe AutoAccept
|
|
}
|
|
deriving (Show)
|
|
|
|
data GroupLinkInfo = GroupLinkInfo
|
|
{ groupId :: GroupId,
|
|
memberRole :: GroupMemberRole
|
|
}
|
|
deriving (Show)
|
|
|
|
data AutoAccept = AutoAccept
|
|
{ businessAddress :: Bool, -- possibly, it can be wrapped together with acceptIncognito, or AutoAccept made sum type
|
|
acceptIncognito :: IncognitoEnabled,
|
|
autoReply :: Maybe MsgContent
|
|
}
|
|
deriving (Show)
|
|
|
|
$(J.deriveJSON defaultJSON ''AutoAccept)
|
|
|
|
$(J.deriveJSON defaultJSON ''UserContactLink)
|
|
|
|
toUserContactLink :: (ConnReqContact, Maybe ShortLinkContact, BoolInt, BoolInt, BoolInt, Maybe MsgContent) -> UserContactLink
|
|
toUserContactLink (connReq, shortLink, BI autoAccept, BI businessAddress, BI acceptIncognito, autoReply) =
|
|
UserContactLink (CCLink connReq shortLink) $
|
|
if autoAccept then Just AutoAccept {businessAddress, acceptIncognito, autoReply} else Nothing
|
|
|
|
getUserAddress :: DB.Connection -> User -> ExceptT StoreError IO UserContactLink
|
|
getUserAddress db User {userId} =
|
|
ExceptT . firstRow toUserContactLink SEUserContactLinkNotFound $
|
|
DB.query db (userContactLinkQuery <> " WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL") (Only userId)
|
|
|
|
getUserContactLinkById :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO (UserContactLink, Maybe GroupLinkInfo)
|
|
getUserContactLinkById db userId userContactLinkId =
|
|
ExceptT . firstRow (\(ucl :. gli) -> (toUserContactLink ucl, toGroupLinkInfo gli)) SEUserContactLinkNotFound $
|
|
DB.query
|
|
db
|
|
[sql|
|
|
SELECT conn_req_contact, short_link_contact, auto_accept, business_address, 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)
|
|
|
|
toGroupLinkInfo :: (Maybe GroupId, Maybe GroupMemberRole) -> Maybe GroupLinkInfo
|
|
toGroupLinkInfo (groupId_, mRole_) =
|
|
(\groupId -> GroupLinkInfo {groupId, memberRole = fromMaybe GRMember mRole_})
|
|
<$> groupId_
|
|
|
|
getGroupLinkInfo :: DB.Connection -> UserId -> GroupId -> IO (Maybe GroupLinkInfo)
|
|
getGroupLinkInfo db userId groupId =
|
|
fmap join $ maybeFirstRow toGroupLinkInfo $
|
|
DB.query
|
|
db
|
|
[sql|
|
|
SELECT group_id, group_link_member_role
|
|
FROM user_contact_links
|
|
WHERE user_id = ? AND group_id = ?
|
|
|]
|
|
(userId, groupId)
|
|
|
|
getUserContactLinkByConnReq :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe UserContactLink)
|
|
getUserContactLinkByConnReq db User {userId} (cReqSchema1, cReqSchema2) =
|
|
maybeFirstRow toUserContactLink $
|
|
DB.query db (userContactLinkQuery <> " WHERE user_id = ? AND conn_req_contact IN (?,?)") (userId, cReqSchema1, cReqSchema2)
|
|
|
|
getUserContactLinkViaShortLink :: DB.Connection -> User -> ShortLinkContact -> IO (Maybe UserContactLink)
|
|
getUserContactLinkViaShortLink db User {userId} shortLink =
|
|
maybeFirstRow toUserContactLink $
|
|
DB.query db (userContactLinkQuery <> " WHERE user_id = ? AND short_link_contact = ?") (userId, shortLink)
|
|
|
|
userContactLinkQuery :: Query
|
|
userContactLinkQuery =
|
|
[sql|
|
|
SELECT conn_req_contact, short_link_contact, auto_accept, business_address, auto_accept_incognito, auto_reply_msg_content
|
|
FROM user_contact_links
|
|
|]
|
|
|
|
getContactWithoutConnViaAddress :: DB.Connection -> VersionRangeChat -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe Contact)
|
|
getContactWithoutConnViaAddress db vr user@User {userId} (cReqSchema1, cReqSchema2) = do
|
|
ctId_ <-
|
|
maybeFirstRow fromOnly $
|
|
DB.query
|
|
db
|
|
[sql|
|
|
SELECT ct.contact_id
|
|
FROM contacts ct
|
|
JOIN contact_profiles cp ON cp.contact_profile_id = ct.contact_profile_id
|
|
LEFT JOIN connections c ON c.contact_id = ct.contact_id
|
|
WHERE cp.user_id = ? AND cp.contact_link IN (?,?) AND c.connection_id IS NULL
|
|
|]
|
|
(userId, cReqSchema1, cReqSchema2)
|
|
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getContact db vr user) ctId_
|
|
|
|
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 = ?, business_address = ?, 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 {businessAddress, acceptIncognito, autoReply} -> (BI True, BI businessAddress, BI acceptIncognito, autoReply)
|
|
_ -> (BI False, BI False, BI False, Nothing)
|
|
|
|
getProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> SProtocolType p -> User -> IO [UserServer p]
|
|
getProtocolServers db p User {userId} =
|
|
map toUserServer
|
|
<$> DB.query
|
|
db
|
|
[sql|
|
|
SELECT smp_server_id, host, port, key_hash, basic_auth, preset, tested, enabled
|
|
FROM protocol_servers
|
|
WHERE user_id = ? AND protocol = ?
|
|
|]
|
|
(userId, decodeLatin1 $ strEncode p)
|
|
where
|
|
toUserServer :: (DBEntityId, NonEmpty TransportHost, String, C.KeyHash, Maybe Text, BoolInt, Maybe BoolInt, BoolInt) -> UserServer p
|
|
toUserServer (serverId, host, port, keyHash, auth_, BI preset, tested, BI enabled) =
|
|
let server = ProtoServerWithAuth (ProtocolServer p host port keyHash) (BasicAuth . encodeUtf8 <$> auth_)
|
|
in UserServer {serverId, server, preset, tested = unBI <$> tested, enabled, deleted = False}
|
|
|
|
insertProtocolServer :: forall p. ProtocolTypeI p => DB.Connection -> SProtocolType p -> User -> UTCTime -> NewUserServer p -> IO (UserServer p)
|
|
insertProtocolServer db p User {userId} ts srv@UserServer {server, preset, tested, enabled} = do
|
|
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 (?,?,?,?,?,?,?,?,?,?,?)
|
|
|]
|
|
(serverColumns p server :. (BI preset, BI <$> tested, BI enabled, userId, ts, ts))
|
|
sId <- insertedRowId db
|
|
pure (srv :: NewUserServer p) {serverId = DBEntityId sId}
|
|
|
|
updateProtocolServer :: ProtocolTypeI p => DB.Connection -> SProtocolType p -> UTCTime -> UserServer p -> IO ()
|
|
updateProtocolServer db p ts UserServer {serverId, server, preset, tested, enabled} =
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
UPDATE protocol_servers
|
|
SET protocol = ?, host = ?, port = ?, key_hash = ?, basic_auth = ?,
|
|
preset = ?, tested = ?, enabled = ?, updated_at = ?
|
|
WHERE smp_server_id = ?
|
|
|]
|
|
(serverColumns p server :. (BI preset, BI <$> tested, BI enabled, ts, serverId))
|
|
|
|
serverColumns :: ProtocolTypeI p => SProtocolType p -> ProtoServerWithAuth p -> (Text, NonEmpty TransportHost, String, C.KeyHash, Maybe Text)
|
|
serverColumns p (ProtoServerWithAuth ProtocolServer {host, port, keyHash} auth_) =
|
|
let protocol = decodeLatin1 $ strEncode p
|
|
auth = safeDecodeUtf8 . unBasicAuth <$> auth_
|
|
in (protocol, host, port, keyHash, auth)
|
|
|
|
getServerOperators :: DB.Connection -> ExceptT StoreError IO ServerOperatorConditions
|
|
getServerOperators db = do
|
|
currentConditions <- getCurrentUsageConditions db
|
|
liftIO $ do
|
|
now <- getCurrentTime
|
|
latestAcceptedConds_ <- getLatestAcceptedConditions db
|
|
let getConds op = (\ca -> op {conditionsAcceptance = ca}) <$> getOperatorConditions_ db op currentConditions latestAcceptedConds_ now
|
|
ops <- mapM getConds =<< getServerOperators_ db
|
|
let conditionsAction = usageConditionsAction ops currentConditions now
|
|
pure ServerOperatorConditions {serverOperators = ops, currentConditions, conditionsAction}
|
|
|
|
getUserServers :: DB.Connection -> User -> ExceptT StoreError IO ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP])
|
|
getUserServers db user =
|
|
(,,)
|
|
<$> (map Just . serverOperators <$> getServerOperators db)
|
|
<*> liftIO (getProtocolServers db SPSMP user)
|
|
<*> liftIO (getProtocolServers db SPXFTP user)
|
|
|
|
setServerOperators :: DB.Connection -> NonEmpty ServerOperator -> IO ()
|
|
setServerOperators db ops = do
|
|
currentTs <- getCurrentTime
|
|
mapM_ (updateServerOperator db currentTs) ops
|
|
|
|
updateServerOperator :: DB.Connection -> UTCTime -> ServerOperator -> IO ()
|
|
updateServerOperator db currentTs ServerOperator {operatorId, enabled, smpRoles, xftpRoles} =
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
UPDATE server_operators
|
|
SET enabled = ?, smp_role_storage = ?, smp_role_proxy = ?, xftp_role_storage = ?, xftp_role_proxy = ?, updated_at = ?
|
|
WHERE server_operator_id = ?
|
|
|]
|
|
(BI enabled, BI (storage smpRoles), BI (proxy smpRoles), BI (storage xftpRoles), BI (proxy xftpRoles), currentTs, operatorId)
|
|
|
|
getUpdateServerOperators :: DB.Connection -> NonEmpty PresetOperator -> Bool -> IO [(Maybe PresetOperator, Maybe ServerOperator)]
|
|
getUpdateServerOperators db presetOps newUser = do
|
|
conds <- map toUsageConditions <$> DB.query_ db usageCondsQuery
|
|
now <- getCurrentTime
|
|
let (currentConds, condsToAdd) = usageConditionsToAdd newUser now conds
|
|
mapM_ insertConditions condsToAdd
|
|
latestAcceptedConds_ <- getLatestAcceptedConditions db
|
|
ops <- updatedServerOperators presetOps <$> getServerOperators_ db
|
|
forM ops $ traverse $ mapM $ \(ASO _ op) ->
|
|
-- traverse for tuple, mapM for Maybe
|
|
case operatorId op of
|
|
DBNewEntity -> insertOperator op
|
|
DBEntityId _ -> do
|
|
updateOperator op
|
|
getOperatorConditions_ db op currentConds latestAcceptedConds_ now >>= \case
|
|
CARequired (Just ts) | ts < now -> autoAcceptConditions op currentConds now
|
|
ca -> pure op {conditionsAcceptance = ca}
|
|
where
|
|
insertConditions UsageConditions {conditionsId, conditionsCommit, notifiedAt, createdAt} =
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
INSERT INTO usage_conditions
|
|
(usage_conditions_id, conditions_commit, notified_at, created_at)
|
|
VALUES (?,?,?,?)
|
|
|]
|
|
(conditionsId, conditionsCommit, notifiedAt, createdAt)
|
|
updateOperator :: ServerOperator -> IO ()
|
|
updateOperator ServerOperator {operatorId, tradeName, legalName, serverDomains, enabled, smpRoles, xftpRoles} =
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
UPDATE server_operators
|
|
SET trade_name = ?, legal_name = ?, server_domains = ?, enabled = ?, smp_role_storage = ?, smp_role_proxy = ?, xftp_role_storage = ?, xftp_role_proxy = ?
|
|
WHERE server_operator_id = ?
|
|
|]
|
|
(tradeName, legalName, T.intercalate "," serverDomains, BI enabled, BI (storage smpRoles), BI (proxy smpRoles), BI (storage xftpRoles), BI (proxy xftpRoles), operatorId)
|
|
insertOperator :: NewServerOperator -> IO ServerOperator
|
|
insertOperator op@ServerOperator {operatorTag, tradeName, legalName, serverDomains, enabled, smpRoles, xftpRoles} = do
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
INSERT INTO server_operators
|
|
(server_operator_tag, trade_name, legal_name, server_domains, enabled, smp_role_storage, smp_role_proxy, xftp_role_storage, xftp_role_proxy)
|
|
VALUES (?,?,?,?,?,?,?,?,?)
|
|
|]
|
|
(operatorTag, tradeName, legalName, T.intercalate "," serverDomains, BI enabled, BI (storage smpRoles), BI (proxy smpRoles), BI (storage xftpRoles), BI (proxy xftpRoles))
|
|
opId <- insertedRowId db
|
|
pure op {operatorId = DBEntityId opId}
|
|
autoAcceptConditions op UsageConditions {conditionsCommit} now =
|
|
acceptConditions_ db op conditionsCommit now True
|
|
$> op {conditionsAcceptance = CAAccepted (Just now) True}
|
|
|
|
serverOperatorQuery :: Query
|
|
serverOperatorQuery =
|
|
[sql|
|
|
SELECT server_operator_id, server_operator_tag, trade_name, legal_name,
|
|
server_domains, enabled, smp_role_storage, smp_role_proxy, xftp_role_storage, xftp_role_proxy
|
|
FROM server_operators
|
|
|]
|
|
|
|
getServerOperators_ :: DB.Connection -> IO [ServerOperator]
|
|
getServerOperators_ db = map toServerOperator <$> DB.query_ db serverOperatorQuery
|
|
|
|
toServerOperator :: (DBEntityId, Maybe OperatorTag, Text, Maybe Text, Text, BoolInt) :. (BoolInt, BoolInt) :. (BoolInt, BoolInt) -> ServerOperator
|
|
toServerOperator ((operatorId, operatorTag, tradeName, legalName, domains, BI enabled) :. smpRoles' :. xftpRoles') =
|
|
ServerOperator
|
|
{ operatorId,
|
|
operatorTag,
|
|
tradeName,
|
|
legalName,
|
|
serverDomains = T.splitOn "," domains,
|
|
conditionsAcceptance = CARequired Nothing,
|
|
enabled,
|
|
smpRoles = serverRoles smpRoles',
|
|
xftpRoles = serverRoles xftpRoles'
|
|
}
|
|
where
|
|
serverRoles (BI storage, BI proxy) = ServerRoles {storage, proxy}
|
|
|
|
getOperatorConditions_ :: DB.Connection -> ServerOperator -> UsageConditions -> Maybe UsageConditions -> UTCTime -> IO ConditionsAcceptance
|
|
getOperatorConditions_ db ServerOperator {operatorId} UsageConditions {conditionsCommit = currentCommit, createdAt, notifiedAt} latestAcceptedConds_ now = do
|
|
case latestAcceptedConds_ of
|
|
Nothing -> pure $ CARequired Nothing -- no conditions accepted by any operator
|
|
Just UsageConditions {conditionsCommit = latestAcceptedCommit} -> do
|
|
operatorAcceptedConds_ <-
|
|
maybeFirstRow id $
|
|
DB.query
|
|
db
|
|
[sql|
|
|
SELECT conditions_commit, accepted_at, auto_accepted
|
|
FROM operator_usage_conditions
|
|
WHERE server_operator_id = ?
|
|
ORDER BY operator_usage_conditions_id DESC
|
|
LIMIT 1
|
|
|]
|
|
(Only operatorId)
|
|
pure $ case operatorAcceptedConds_ of
|
|
Just (operatorCommit, acceptedAt_, BI autoAccept)
|
|
| operatorCommit /= latestAcceptedCommit -> CARequired Nothing -- TODO should we consider this operator disabled?
|
|
| currentCommit /= latestAcceptedCommit -> CARequired $ conditionsRequiredOrDeadline createdAt (fromMaybe now notifiedAt)
|
|
| otherwise -> CAAccepted acceptedAt_ autoAccept
|
|
_ -> CARequired Nothing -- no conditions were accepted for this operator
|
|
|
|
getCurrentUsageConditions :: DB.Connection -> ExceptT StoreError IO UsageConditions
|
|
getCurrentUsageConditions db =
|
|
ExceptT . firstRow toUsageConditions SEUsageConditionsNotFound $
|
|
DB.query_ db (usageCondsQuery <> " DESC LIMIT 1")
|
|
|
|
usageCondsQuery :: Query
|
|
usageCondsQuery =
|
|
[sql|
|
|
SELECT usage_conditions_id, conditions_commit, notified_at, created_at
|
|
FROM usage_conditions
|
|
ORDER BY usage_conditions_id
|
|
|]
|
|
|
|
toUsageConditions :: (Int64, Text, Maybe UTCTime, UTCTime) -> UsageConditions
|
|
toUsageConditions (conditionsId, conditionsCommit, notifiedAt, createdAt) =
|
|
UsageConditions {conditionsId, conditionsCommit, notifiedAt, createdAt}
|
|
|
|
getLatestAcceptedConditions :: DB.Connection -> IO (Maybe UsageConditions)
|
|
getLatestAcceptedConditions db =
|
|
maybeFirstRow toUsageConditions $
|
|
DB.query_
|
|
db
|
|
[sql|
|
|
SELECT usage_conditions_id, conditions_commit, notified_at, created_at
|
|
FROM usage_conditions
|
|
WHERE conditions_commit = (
|
|
SELECT conditions_commit
|
|
FROM operator_usage_conditions
|
|
ORDER BY accepted_at DESC
|
|
LIMIT 1
|
|
)
|
|
|]
|
|
|
|
setConditionsNotified :: DB.Connection -> Int64 -> UTCTime -> IO ()
|
|
setConditionsNotified db condId notifiedAt =
|
|
DB.execute db "UPDATE usage_conditions SET notified_at = ? WHERE usage_conditions_id = ?" (notifiedAt, condId)
|
|
|
|
acceptConditions :: DB.Connection -> Int64 -> NonEmpty Int64 -> UTCTime -> ExceptT StoreError IO ()
|
|
acceptConditions db condId opIds acceptedAt = do
|
|
UsageConditions {conditionsCommit} <- getUsageConditionsById_ db condId
|
|
operators <- mapM getServerOperator_ opIds
|
|
liftIO $ forM_ operators $ \op -> acceptConditions_ db op conditionsCommit acceptedAt False
|
|
where
|
|
getServerOperator_ opId =
|
|
ExceptT $
|
|
firstRow toServerOperator (SEOperatorNotFound opId) $
|
|
DB.query db (serverOperatorQuery <> " WHERE server_operator_id = ?") (Only opId)
|
|
|
|
acceptConditions_ :: DB.Connection -> ServerOperator -> Text -> UTCTime -> Bool -> IO ()
|
|
acceptConditions_ db ServerOperator {operatorId, operatorTag} conditionsCommit acceptedAt autoAccepted = do
|
|
acceptedAt_ :: Maybe (Maybe UTCTime) <- maybeFirstRow fromOnly $ DB.query db "SELECT accepted_at FROM operator_usage_conditions WHERE server_operator_id = ? AND conditions_commit = ?" (operatorId, conditionsCommit)
|
|
case acceptedAt_ of
|
|
Just Nothing ->
|
|
DB.execute
|
|
db
|
|
(q <> "ON CONFLICT (server_operator_id, conditions_commit) DO UPDATE SET accepted_at = ?, auto_accepted = ?")
|
|
(operatorId, operatorTag, conditionsCommit, acceptedAt, BI autoAccepted, acceptedAt, BI autoAccepted)
|
|
Just (Just _) ->
|
|
DB.execute
|
|
db
|
|
(q <> "ON CONFLICT (server_operator_id, conditions_commit) DO NOTHING")
|
|
(operatorId, operatorTag, conditionsCommit, acceptedAt, BI autoAccepted)
|
|
Nothing ->
|
|
DB.execute
|
|
db
|
|
q
|
|
(operatorId, operatorTag, conditionsCommit, acceptedAt, BI autoAccepted)
|
|
where
|
|
q =
|
|
[sql|
|
|
INSERT INTO operator_usage_conditions
|
|
(server_operator_id, server_operator_tag, conditions_commit, accepted_at, auto_accepted)
|
|
VALUES (?,?,?,?,?)
|
|
|]
|
|
|
|
getUsageConditionsById_ :: DB.Connection -> Int64 -> ExceptT StoreError IO UsageConditions
|
|
getUsageConditionsById_ db conditionsId =
|
|
ExceptT . firstRow toUsageConditions SEUsageConditionsNotFound $
|
|
DB.query
|
|
db
|
|
[sql|
|
|
SELECT usage_conditions_id, conditions_commit, notified_at, created_at
|
|
FROM usage_conditions
|
|
WHERE usage_conditions_id = ?
|
|
|]
|
|
(Only conditionsId)
|
|
|
|
setUserServers :: DB.Connection -> User -> UTCTime -> UpdatedUserOperatorServers -> ExceptT StoreError IO UserOperatorServers
|
|
setUserServers db user ts = checkConstraint SEUniqueID . liftIO . setUserServers' db user ts
|
|
|
|
setUserServers' :: DB.Connection -> User -> UTCTime -> UpdatedUserOperatorServers -> IO UserOperatorServers
|
|
setUserServers' db user@User {userId} ts UpdatedUserOperatorServers {operator, smpServers, xftpServers} = do
|
|
mapM_ (updateServerOperator db ts) operator
|
|
smpSrvs' <- catMaybes <$> mapM (upsertOrDelete SPSMP) smpServers
|
|
xftpSrvs' <- catMaybes <$> mapM (upsertOrDelete SPXFTP) xftpServers
|
|
pure UserOperatorServers {operator, smpServers = smpSrvs', xftpServers = xftpSrvs'}
|
|
where
|
|
upsertOrDelete :: ProtocolTypeI p => SProtocolType p -> AUserServer p -> IO (Maybe (UserServer p))
|
|
upsertOrDelete p (AUS _ s@UserServer {serverId, deleted}) = case serverId of
|
|
DBNewEntity
|
|
| deleted -> pure Nothing
|
|
| otherwise -> Just <$> insertProtocolServer db p user ts s
|
|
DBEntityId srvId
|
|
| deleted -> Nothing <$ DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND smp_server_id = ? AND preset = ?" (userId, srvId, BI False)
|
|
| otherwise -> Just s <$ updateProtocolServer db p ts s
|
|
|
|
createCall :: DB.Connection -> User -> Call -> UTCTime -> IO ()
|
|
createCall db user@User {userId} Call {contactId, callId, callUUID, chatItemId, callState} callTs = do
|
|
currentTs <- getCurrentTime
|
|
deleteCalls db user contactId
|
|
DB.execute
|
|
db
|
|
[sql|
|
|
INSERT INTO calls
|
|
(contact_id, shared_call_id, call_uuid, chat_item_id, call_state, call_ts, user_id, created_at, updated_at)
|
|
VALUES (?,?,?,?,?,?,?,?,?)
|
|
|]
|
|
(contactId, callId, callUUID, 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, call_uuid, chat_item_id, call_state, call_ts
|
|
FROM calls
|
|
ORDER BY call_ts ASC
|
|
|]
|
|
where
|
|
toCall :: (ContactId, CallId, Text, ChatItemId, CallState, UTCTime) -> Call
|
|
toCall (contactId, callId, callUUID, chatItemId, callState, callTs) = Call {contactId, callId, callUUID, 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}
|
|
|
|
setUserUIThemes :: DB.Connection -> User -> Maybe UIThemeEntityOverrides -> IO ()
|
|
setUserUIThemes db User {userId} uiThemes = do
|
|
updatedAt <- getCurrentTime
|
|
DB.execute db "UPDATE users SET ui_themes = ?, updated_at = ? WHERE user_id = ?" (uiThemes, updatedAt, userId)
|