mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2024-12-17 17:20:21 +01:00
core: update servers API to include XFTP servers, ios: generalize UI to manage servers (#2140)
* core: update servers API to include XFTP servers, ios: generalize UI to manage servers * add test * update migrations to pass tests * fix readme * update simplexmq
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
1e280fb7e1
commit
1a3f0bed47
+23
-29
@@ -246,8 +246,6 @@ module Simplex.Chat.Store
|
||||
updateGroupChatItemsRead,
|
||||
getGroupUnreadTimedItems,
|
||||
setGroupChatItemDeleteAt,
|
||||
getSMPServers,
|
||||
overwriteSMPServers,
|
||||
getProtocolServers,
|
||||
overwriteProtocolServers,
|
||||
createCall,
|
||||
@@ -297,7 +295,7 @@ import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe, mapMaybe)
|
||||
import Data.Ord (Down (..))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
import Data.Time (addUTCTime)
|
||||
import Data.Time.Clock (UTCTime (..), getCurrentTime)
|
||||
import Data.Time.LocalTime (TimeZone, getCurrentTimeZone)
|
||||
@@ -365,6 +363,7 @@ 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.Protocol
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Util (week)
|
||||
@@ -372,8 +371,9 @@ import Simplex.Messaging.Agent.Protocol (ACorrId, AgentMsgId, ConnId, Invitation
|
||||
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation, MigrationError, SQLiteStore (..), createSQLiteStore, firstRow, firstRow', maybeFirstRow, withTransaction)
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
|
||||
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), ProtocolTypeI (..), SProtocolType (..), pattern SMPServer)
|
||||
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..))
|
||||
import Simplex.Messaging.Transport.Client (TransportHost)
|
||||
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8)
|
||||
import UnliftIO.STM
|
||||
@@ -435,7 +435,8 @@ schemaMigrations =
|
||||
("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)
|
||||
("20230328_files_protocol", m20230328_files_protocol, Just down_m20230328_files_protocol),
|
||||
("20230402_protocol_servers", m20230402_protocol_servers, Just down_m20230402_protocol_servers)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
@@ -4849,49 +4850,42 @@ toGroupChatItemList tz currentTs userContactId (((Just itemId, Just itemTs, Just
|
||||
either (const []) (: []) $ toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_)
|
||||
toGroupChatItemList _ _ _ _ = []
|
||||
|
||||
getSMPServers :: DB.Connection -> User -> IO [ServerCfg 'PSMP]
|
||||
getSMPServers db User {userId} =
|
||||
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 smp_servers
|
||||
WHERE user_id = ?;
|
||||
FROM protocol_servers
|
||||
WHERE user_id = ? AND protocol = ?;
|
||||
|]
|
||||
(Only userId)
|
||||
(userId, decodeLatin1 $ strEncode protocol)
|
||||
where
|
||||
toServerCfg :: (NonEmpty TransportHost, String, C.KeyHash, Maybe Text, Bool, Maybe Bool, Bool) -> ServerCfg 'PSMP
|
||||
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 (SMPServer host port keyHash) (BasicAuth . encodeUtf8 <$> auth_)
|
||||
let server = ProtoServerWithAuth (ProtocolServer protocol host port keyHash) (BasicAuth . encodeUtf8 <$> auth_)
|
||||
in ServerCfg {server, preset, tested, enabled}
|
||||
|
||||
overwriteSMPServers :: DB.Connection -> User -> [ServerCfg 'PSMP] -> ExceptT StoreError IO ()
|
||||
overwriteSMPServers db User {userId} servers =
|
||||
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 smp_servers WHERE user_id = ?" (Only userId)
|
||||
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 smp_servers
|
||||
(host, port, key_hash, basic_auth, preset, tested, enabled, user_id, created_at, updated_at)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?)
|
||||
INSERT INTO protocol_servers
|
||||
(protocol, host, port, key_hash, basic_auth, preset, tested, enabled, user_id, created_at, updated_at)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
(host, port, keyHash, safeDecodeUtf8 . unBasicAuth <$> auth_, preset, tested, enabled, userId, currentTs, currentTs)
|
||||
((protocol, host, port, keyHash, safeDecodeUtf8 . unBasicAuth <$> auth_) :. (preset, tested, enabled, userId, currentTs, currentTs))
|
||||
pure $ Right ()
|
||||
|
||||
getProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> IO [ServerCfg p]
|
||||
getProtocolServers db user = case protocolTypeI @p of
|
||||
SPSMP -> getSMPServers db user
|
||||
_ -> pure [] -- TODO read from the new table of all servers (alternatively, we could migrate data)
|
||||
|
||||
overwriteProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> [ServerCfg p] -> ExceptT StoreError IO ()
|
||||
overwriteProtocolServers db user servers = case protocolTypeI @p of
|
||||
SPSMP -> overwriteSMPServers db user servers
|
||||
_ -> pure () -- TODO write the new table of all servers
|
||||
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
|
||||
|
||||
Reference in New Issue
Block a user