core: auto accept via address and incognito mode specified (#1233)

* core: Auto accept via address and incognito mode specified

* Fix test

* Refactoring

* No forcing

* Apply suggestions from code review

* refactor

* refactor AutoAccept

* Test

* Test

* allow different test output order

* rename

* rename

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com>
This commit is contained in:
Stanislav Dmitrenko
2022-10-21 19:14:12 +03:00
committed by GitHub
parent 5bcb725ea5
commit 1470b8d128
10 changed files with 108 additions and 51 deletions
+42 -18
View File
@@ -20,6 +20,8 @@
module Simplex.Chat.Store
( SQLiteStore,
StoreError (..),
UserContactLink (..),
AutoAccept (..),
createChatStore,
chatStoreFile,
agentStoreFile,
@@ -283,7 +285,7 @@ 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_connections_via_group_link
import Simplex.Chat.Migrations.M20221021_auto_accept__group_links
import Simplex.Chat.Protocol
import Simplex.Chat.Types
import Simplex.Messaging.Agent.Protocol (ACorrId, AgentMsgId, ConnId, InvitationId, MsgMeta (..))
@@ -327,7 +329,7 @@ schemaMigrations =
("20221011_user_contact_links_group_id", m20221011_user_contact_links_group_id),
("20221012_inline_files", m20221012_inline_files),
("20221019_unread_chat", m20221019_unread_chat),
("20221021_connections_via_group_link", m20221021_connections_via_group_link)
("20221021_auto_accept__group_links", m20221021_auto_accept__group_links)
]
-- | The list of migrations in ascending order by date
@@ -785,47 +787,69 @@ deleteUserAddress db User {userId} = do
[":user_id" := userId]
DB.execute db "DELETE FROM user_contact_links WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL" (Only userId)
getUserAddress :: DB.Connection -> UserId -> ExceptT StoreError IO (ConnReqContact, Bool, Maybe MsgContent)
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 -> UserId -> ExceptT StoreError IO UserContactLink
getUserAddress db userId =
ExceptT . firstRow id SEUserContactLinkNotFound $
ExceptT . firstRow toUserContactLink SEUserContactLinkNotFound $
DB.query
db
[sql|
SELECT conn_req_contact, auto_accept, auto_reply_msg_content
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 (ConnReqContact, Bool, Maybe MsgContent, Maybe GroupId))
getUserContactLinkById :: DB.Connection -> UserId -> Int64 -> IO (Maybe (UserContactLink, Maybe GroupId))
getUserContactLinkById db userId userContactLinkId =
maybeFirstRow id $
maybeFirstRow (\(ucl :. Only groupId_) -> (toUserContactLink ucl, groupId_)) $
DB.query
db
[sql|
SELECT conn_req_contact, auto_accept, auto_reply_msg_content, group_id
SELECT conn_req_contact, auto_accept, auto_accept_incognito, auto_reply_msg_content, group_id
FROM user_contact_links
WHERE user_id = ?
AND user_contact_link_id = ?
|]
(userId, userContactLinkId)
updateUserAddressAutoAccept :: DB.Connection -> UserId -> Bool -> Maybe MsgContent -> ExceptT StoreError IO (ConnReqContact, Bool, Maybe MsgContent)
updateUserAddressAutoAccept db userId autoAccept msgContent = do
(cReqUri, _, _) <- getUserAddress db userId
liftIO updateUserAddressAutoAccept_
pure (cReqUri, autoAccept, msgContent)
updateUserAddressAutoAccept :: DB.Connection -> UserId -> Maybe AutoAccept -> ExceptT StoreError IO UserContactLink
updateUserAddressAutoAccept db userId autoAccept = do
link <- getUserAddress db userId
liftIO updateUserAddressAutoAccept_ $> link {autoAccept}
where
updateUserAddressAutoAccept_ :: IO ()
updateUserAddressAutoAccept_ =
DB.execute
db
[sql|
UPDATE user_contact_links
SET auto_accept = ?, auto_reply_msg_content = ?
SET auto_accept = ?, auto_accept_incognito = ?, auto_reply_msg_content = ?
WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL
|]
(autoAccept, msgContent, userId)
(ucl :. Only userId)
ucl = case autoAccept of
Just AutoAccept {acceptIncognito, autoReply} -> (True, acceptIncognito, autoReply)
_ -> (False, False, Nothing)
createGroupLink :: DB.Connection -> User -> GroupInfo -> ConnId -> ConnReqContact -> ExceptT StoreError IO ()
createGroupLink db User {userId} groupInfo@GroupInfo {groupId, localDisplayName} agentConnId cReq =
@@ -2251,7 +2275,7 @@ createSndDirectInlineFT :: DB.Connection -> Contact -> FileTransferMeta -> IO Sn
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
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 (?,?,?,?,?,?)"
@@ -2262,7 +2286,7 @@ createSndGroupInlineFT :: DB.Connection -> GroupMember -> Connection -> FileTran
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
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 (?,?,?,?,?,?,?)"