mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-06-28 12:19:54 +00:00
core: add support for server operators (#4961)
* core: add support for server operators * migration * update schema and queries, rfc * add usage conditions tables * core: server operators new apis draft * update * conditions * update * add get conditions api * add get conditions API * WIP * compiles * fix schema * core: ui logic in types (#5139) * update --------- Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
This commit is contained in:
parent
9a1166f097
commit
97df069730
17 changed files with 440 additions and 36 deletions
|
@ -12,7 +12,7 @@ constraints: zip +disable-bzip2 +disable-zstd
|
|||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/simplex-chat/simplexmq.git
|
||||
tag: ffecf200d4874dfa34f6d15b269964c0115a54ca
|
||||
tag: ff05a465ee15ac7ae2c14a9fb703a18564950631
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
|
|
24
docs/rfcs/2024-10-27-server-operators.md
Normal file
24
docs/rfcs/2024-10-27-server-operators.md
Normal file
|
@ -0,0 +1,24 @@
|
|||
# Server operators
|
||||
|
||||
## Problem
|
||||
|
||||
All preconfigured servers operated by a single company create a risk that user connections can be analysed by aggregating transport information from these servers.
|
||||
|
||||
The solution is to have more than one operator servers pre-configured in the app.
|
||||
|
||||
For operators to be protected from any violations of rights of other users or third parties by the users who use servers of these operators, the users have to explicitely accept conditions of use with the operator, in the same way they accept conditions of use with SimpleX Chat Ltd by downloading the app.
|
||||
|
||||
## Solution
|
||||
|
||||
Allow to assign operators to servers, both with preconfigured operators and servers, and with user-defined operators. Agent added support for server roles, chat app could:
|
||||
- allow assigning server roles only on the operator level.
|
||||
- only on server level.
|
||||
- on both, with server roles overriding operator roles (that would require a different type for server for chat app).
|
||||
|
||||
For simplicity of both UX and logic it is probably better to allow assigning roles only on operators' level, and servers without set operators can be used for both roles.
|
||||
|
||||
For agreements, it is sufficient to record the signatures of these agreements on users' devices, together with the copy of signed agreement (or its hash and version) in a separate table. The terms themselves could be:
|
||||
- included in the app - either in code or in migration.
|
||||
- referenced with a stable link to a particular commit.
|
||||
|
||||
The first solution seems better, as it avoids any third party dependency, and the agreement size is relatively small (~31kb), to reduce size we can store it compressed.
|
|
@ -29,6 +29,7 @@ dependencies:
|
|||
- email-validate == 2.3.*
|
||||
- exceptions == 0.10.*
|
||||
- filepath == 1.4.*
|
||||
- file-embed == 0.0.15.*
|
||||
- http-types == 0.12.*
|
||||
- http2 >= 4.2.2 && < 4.3
|
||||
- memory == 0.18.*
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
{
|
||||
"https://github.com/simplex-chat/simplexmq.git"."ffecf200d4874dfa34f6d15b269964c0115a54ca" = "0kb8hq37fc5g198wq7dswnlwjzk67q8rrzil2dii5lc6xfr47jbs";
|
||||
"https://github.com/simplex-chat/simplexmq.git"."ff05a465ee15ac7ae2c14a9fb703a18564950631" = "1gv4nwqzbqkj7y3ffkiwkr4qwv52vdzppsds5vsfqaayl14rzmgp";
|
||||
"https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
|
||||
"https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d";
|
||||
"https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl";
|
||||
|
|
|
@ -150,10 +150,13 @@ library
|
|||
Simplex.Chat.Migrations.M20240920_user_order
|
||||
Simplex.Chat.Migrations.M20241008_indexes
|
||||
Simplex.Chat.Migrations.M20241010_contact_requests_contact_id
|
||||
Simplex.Chat.Migrations.M20241027_server_operators
|
||||
Simplex.Chat.Mobile
|
||||
Simplex.Chat.Mobile.File
|
||||
Simplex.Chat.Mobile.Shared
|
||||
Simplex.Chat.Mobile.WebRTC
|
||||
Simplex.Chat.Operators
|
||||
Simplex.Chat.Operators.Conditions
|
||||
Simplex.Chat.Options
|
||||
Simplex.Chat.ProfileGenerator
|
||||
Simplex.Chat.Protocol
|
||||
|
@ -213,6 +216,7 @@ library
|
|||
, directory ==1.3.*
|
||||
, email-validate ==2.3.*
|
||||
, exceptions ==0.10.*
|
||||
, file-embed ==0.0.15.*
|
||||
, filepath ==1.4.*
|
||||
, http-types ==0.12.*
|
||||
, http2 >=4.2.2 && <4.3
|
||||
|
@ -276,6 +280,7 @@ executable simplex-bot
|
|||
, directory ==1.3.*
|
||||
, email-validate ==2.3.*
|
||||
, exceptions ==0.10.*
|
||||
, file-embed ==0.0.15.*
|
||||
, filepath ==1.4.*
|
||||
, http-types ==0.12.*
|
||||
, http2 >=4.2.2 && <4.3
|
||||
|
@ -340,6 +345,7 @@ executable simplex-bot-advanced
|
|||
, directory ==1.3.*
|
||||
, email-validate ==2.3.*
|
||||
, exceptions ==0.10.*
|
||||
, file-embed ==0.0.15.*
|
||||
, filepath ==1.4.*
|
||||
, http-types ==0.12.*
|
||||
, http2 >=4.2.2 && <4.3
|
||||
|
@ -407,6 +413,7 @@ executable simplex-broadcast-bot
|
|||
, directory ==1.3.*
|
||||
, email-validate ==2.3.*
|
||||
, exceptions ==0.10.*
|
||||
, file-embed ==0.0.15.*
|
||||
, filepath ==1.4.*
|
||||
, http-types ==0.12.*
|
||||
, http2 >=4.2.2 && <4.3
|
||||
|
@ -472,6 +479,7 @@ executable simplex-chat
|
|||
, directory ==1.3.*
|
||||
, email-validate ==2.3.*
|
||||
, exceptions ==0.10.*
|
||||
, file-embed ==0.0.15.*
|
||||
, filepath ==1.4.*
|
||||
, http-types ==0.12.*
|
||||
, http2 >=4.2.2 && <4.3
|
||||
|
@ -543,6 +551,7 @@ executable simplex-directory-service
|
|||
, directory ==1.3.*
|
||||
, email-validate ==2.3.*
|
||||
, exceptions ==0.10.*
|
||||
, file-embed ==0.0.15.*
|
||||
, filepath ==1.4.*
|
||||
, http-types ==0.12.*
|
||||
, http2 >=4.2.2 && <4.3
|
||||
|
@ -642,6 +651,7 @@ test-suite simplex-chat-test
|
|||
, directory ==1.3.*
|
||||
, email-validate ==2.3.*
|
||||
, exceptions ==0.10.*
|
||||
, file-embed ==0.0.15.*
|
||||
, filepath ==1.4.*
|
||||
, generic-random ==1.5.*
|
||||
, http-types ==0.12.*
|
||||
|
|
|
@ -67,6 +67,7 @@ import Simplex.Chat.Messages
|
|||
import Simplex.Chat.Messages.Batch (MsgBatch (..), batchMessages)
|
||||
import Simplex.Chat.Messages.CIContent
|
||||
import Simplex.Chat.Messages.CIContent.Events
|
||||
import Simplex.Chat.Operators
|
||||
import Simplex.Chat.Options
|
||||
import Simplex.Chat.ProfileGenerator (generateRandomProfile)
|
||||
import Simplex.Chat.Protocol
|
||||
|
@ -97,7 +98,7 @@ import qualified Simplex.FileTransfer.Transport as XFTP
|
|||
import Simplex.FileTransfer.Types (FileErrorType (..), RcvFileId, SndFileId)
|
||||
import Simplex.Messaging.Agent as Agent
|
||||
import Simplex.Messaging.Agent.Client (SubInfo (..), agentClientStore, getAgentQueuesInfo, getAgentWorkersDetails, getAgentWorkersSummary, getFastNetworkConfig, ipAddressProtected, withLockMap)
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), ServerCfg (..), createAgentStore, defaultAgentConfig, enabledServerCfg, presetServerCfg)
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), OperatorId, ServerCfg (..), allRoles, createAgentStore, defaultAgentConfig, enabledServerCfg, presetServerCfg)
|
||||
import Simplex.Messaging.Agent.Lock (withLock)
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import qualified Simplex.Messaging.Agent.Protocol as AP (AgentErrorType (..))
|
||||
|
@ -152,7 +153,7 @@ defaultChatConfig =
|
|||
{ smp = _defaultSMPServers,
|
||||
useSMP = 4,
|
||||
ntf = _defaultNtfServers,
|
||||
xftp = L.map (presetServerCfg True) defaultXFTPServers,
|
||||
xftp = L.map (presetServerCfg True allRoles operatorSimpleXChat) defaultXFTPServers,
|
||||
useXFTP = L.length defaultXFTPServers,
|
||||
netCfg = defaultNetworkConfig
|
||||
},
|
||||
|
@ -181,7 +182,7 @@ _defaultSMPServers :: NonEmpty (ServerCfg 'PSMP)
|
|||
_defaultSMPServers =
|
||||
L.fromList $
|
||||
map
|
||||
(presetServerCfg True)
|
||||
(presetServerCfg True allRoles operatorSimpleXChat)
|
||||
[ "smp://0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU=@smp8.simplex.im,beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion",
|
||||
"smp://SkIkI6EPd2D63F4xFKfHk7I1UGZVNn6k1QWZ5rcyr6w=@smp9.simplex.im,jssqzccmrcws6bhmn77vgmhfjmhwlyr3u7puw4erkyoosywgl67slqqd.onion",
|
||||
"smp://6iIcWT_dF2zN_w5xzZEY7HI2Prbh3ldP07YTyDexPjE=@smp10.simplex.im,rb2pbttocvnbrngnwziclp2f4ckjq65kebafws6g4hy22cdaiv5dwjqd.onion",
|
||||
|
@ -195,12 +196,15 @@ _defaultSMPServers =
|
|||
"smp://N_McQS3F9TGoh4ER0QstUf55kGnNSd-wXfNPZ7HukcM=@smp19.simplex.im,i53bbtoqhlc365k6kxzwdp5w3cdt433s7bwh3y32rcbml2vztiyyz5id.onion"
|
||||
]
|
||||
<> map
|
||||
(presetServerCfg False)
|
||||
(presetServerCfg False allRoles operatorSimpleXChat)
|
||||
[ "smp://u2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU=@smp4.simplex.im,o5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion",
|
||||
"smp://hpq7_4gGJiilmz5Rf-CswuU5kZGkm_zOIooSw6yALRg=@smp5.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion",
|
||||
"smp://PQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo=@smp6.simplex.im,bylepyau3ty4czmn77q4fglvperknl4bi2eb2fdy2bh4jxtf32kf73yd.onion"
|
||||
]
|
||||
|
||||
operatorSimpleXChat :: Maybe OperatorId
|
||||
operatorSimpleXChat = Just 1
|
||||
|
||||
_defaultNtfServers :: [NtfServer]
|
||||
_defaultNtfServers =
|
||||
[ "ntf://FB-Uop7RTaZZEG0ZLD2CIaTjsPh-Fw0zFAnb7QyA8Ks=@ntf2.simplex.im,5ex3mupcazy3zlky64ab27phjhijpemsiby33qzq3pliejipbtx5xgad.onion"
|
||||
|
@ -1484,8 +1488,11 @@ processChatCommand' vr = \case
|
|||
pure $ CRConnNtfMessages ntfMsgs
|
||||
APIGetUserProtoServers userId (AProtocolType p) -> withUserId userId $ \user -> withServerProtocol p $ do
|
||||
cfg@ChatConfig {defaultServers} <- asks config
|
||||
servers <- withFastStore' (`getProtocolServers` user)
|
||||
pure $ CRUserProtoServers user $ AUPS $ UserProtoServers p (useServers cfg p servers) (cfgServers p defaultServers)
|
||||
srvs <- withFastStore' (`getProtocolServers` user)
|
||||
ts <- liftIO getCurrentTime
|
||||
operators <- withFastStore' $ \db -> getServerOperators db ts
|
||||
let servers = AUPS $ UserProtoServers p (useServers cfg p srvs) (cfgServers p defaultServers)
|
||||
pure $ CRUserProtoServers {user, servers, operators}
|
||||
GetUserProtoServers aProtocol -> withUser $ \User {userId} ->
|
||||
processChatCommand $ APIGetUserProtoServers userId aProtocol
|
||||
APISetUserProtoServers userId (APSC p (ProtoServersConfig servers))
|
||||
|
@ -1501,6 +1508,37 @@ processChatCommand' vr = \case
|
|||
lift $ CRServerTestResult user srv <$> withAgent' (\a -> testProtocolServer a (aUserId user) server)
|
||||
TestProtoServer srv -> withUser $ \User {userId} ->
|
||||
processChatCommand $ APITestProtoServer userId srv
|
||||
APIGetServerOperators -> pure $ chatCmdError Nothing "not supported"
|
||||
APISetServerOperators _operators -> pure $ chatCmdError Nothing "not supported"
|
||||
APIGetUserServers userId -> withUserId userId $ \user ->
|
||||
pure $ chatCmdError (Just user) "not supported"
|
||||
APISetUserServers userId _userServers -> withUserId userId $ \user ->
|
||||
pure $ chatCmdError (Just user) "not supported"
|
||||
APIValidateServers _userServers ->
|
||||
-- response is CRUserServersValidation
|
||||
pure $ chatCmdError Nothing "not supported"
|
||||
APIGetUsageConditions -> do
|
||||
-- TODO
|
||||
-- get current conditions
|
||||
-- get latest accepted conditions (from operators)
|
||||
ts <- liftIO getCurrentTime
|
||||
let usageConditions =
|
||||
UsageConditions
|
||||
{ conditionsId = 1,
|
||||
conditionsCommit = "abc",
|
||||
notifiedAt = Nothing,
|
||||
createdAt = ts
|
||||
}
|
||||
pure
|
||||
CRUsageConditions
|
||||
{ usageConditions = usageConditions,
|
||||
conditionsText = usageConditionsText,
|
||||
acceptedConditions = Nothing
|
||||
}
|
||||
APISetConditionsNotified _conditionsId -> do
|
||||
pure $ chatCmdError Nothing "not supported"
|
||||
APIAcceptConditions _conditionsId _opIds ->
|
||||
pure $ chatCmdError Nothing "not supported"
|
||||
APISetChatItemTTL userId newTTL_ -> withUserId userId $ \user ->
|
||||
checkStoreNotChanged $
|
||||
withChatLock "setChatItemTTL" $ do
|
||||
|
|
|
@ -57,6 +57,7 @@ import Simplex.Chat.Call
|
|||
import Simplex.Chat.Markdown (MarkdownList)
|
||||
import Simplex.Chat.Messages
|
||||
import Simplex.Chat.Messages.CIContent
|
||||
import Simplex.Chat.Operators
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Remote.AppVersion
|
||||
import Simplex.Chat.Remote.Types
|
||||
|
@ -70,7 +71,7 @@ import Simplex.Chat.Util (liftIOEither)
|
|||
import Simplex.FileTransfer.Description (FileDescriptionURI)
|
||||
import Simplex.Messaging.Agent (AgentClient, SubscriptionsInfo)
|
||||
import Simplex.Messaging.Agent.Client (AgentLocks, AgentQueuesInfo (..), AgentWorkersDetails (..), AgentWorkersSummary (..), ProtocolTestFailure, SMPServerSubs, ServerQueueInfo, UserNetworkInfo)
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, NetworkConfig, ServerCfg)
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, NetworkConfig, OperatorId, ServerCfg)
|
||||
import Simplex.Messaging.Agent.Lock
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation, SQLiteStore, UpMigration, withTransaction, withTransactionPriority)
|
||||
|
@ -352,6 +353,14 @@ data ChatCommand
|
|||
| SetUserProtoServers AProtoServersConfig
|
||||
| APITestProtoServer UserId AProtoServerWithAuth
|
||||
| TestProtoServer AProtoServerWithAuth
|
||||
| APIGetServerOperators
|
||||
| APISetServerOperators (NonEmpty (OperatorId, Bool))
|
||||
| APIGetUserServers UserId
|
||||
| APISetUserServers UserId (NonEmpty UserServers)
|
||||
| APIValidateServers (NonEmpty UserServers) -- response is CRUserServersValidation
|
||||
| APIGetUsageConditions
|
||||
| APISetConditionsNotified Int64
|
||||
| APIAcceptConditions Int64 (NonEmpty OperatorId)
|
||||
| APISetChatItemTTL UserId (Maybe Int64)
|
||||
| SetChatItemTTL (Maybe Int64)
|
||||
| APIGetChatItemTTL UserId
|
||||
|
@ -577,8 +586,12 @@ data ChatResponse
|
|||
| CRChatItemInfo {user :: User, chatItem :: AChatItem, chatItemInfo :: ChatItemInfo}
|
||||
| CRChatItemId User (Maybe ChatItemId)
|
||||
| CRApiParsedMarkdown {formattedText :: Maybe MarkdownList}
|
||||
| CRUserProtoServers {user :: User, servers :: AUserProtoServers}
|
||||
| CRUserProtoServers {user :: User, servers :: AUserProtoServers, operators :: [ServerOperator]}
|
||||
| CRServerTestResult {user :: User, testServer :: AProtoServerWithAuth, testFailure :: Maybe ProtocolTestFailure}
|
||||
| CRServerOperators {operators :: [ServerOperator], conditionsAction :: UsageConditionsAction}
|
||||
| CRUserServers {userServers :: [UserServers]}
|
||||
| CRUserServersValidation {serverErrors :: [UserServersError]}
|
||||
| CRUsageConditions {usageConditions :: UsageConditions, conditionsText :: Text, acceptedConditions :: Maybe UsageConditions}
|
||||
| CRChatItemTTL {user :: User, chatItemTTL :: Maybe Int64}
|
||||
| CRNetworkConfig {networkConfig :: NetworkConfig}
|
||||
| CRContactInfo {user :: User, contact :: Contact, connectionStats_ :: Maybe ConnectionStats, customUserProfile :: Maybe Profile}
|
||||
|
@ -948,6 +961,12 @@ data AProtoServersConfig = forall p. ProtocolTypeI p => APSC (SProtocolType p) (
|
|||
|
||||
deriving instance Show AProtoServersConfig
|
||||
|
||||
data UserServersError
|
||||
= USEStorageMissing
|
||||
| USEProxyMissing
|
||||
| USEDuplicate {server :: AProtoServerWithAuth}
|
||||
deriving (Show)
|
||||
|
||||
data UserProtoServers p = UserProtoServers
|
||||
{ serverProtocol :: SProtocolType p,
|
||||
protoServers :: NonEmpty (ServerCfg p),
|
||||
|
@ -1526,6 +1545,8 @@ $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "DB") ''DatabaseError)
|
|||
|
||||
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "Chat") ''ChatError)
|
||||
|
||||
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "USE") ''UserServersError)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''AppFilePathsConfig)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''ContactSubStatus)
|
||||
|
|
70
src/Simplex/Chat/Migrations/M20241027_server_operators.hs
Normal file
70
src/Simplex/Chat/Migrations/M20241027_server_operators.hs
Normal file
|
@ -0,0 +1,70 @@
|
|||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Chat.Migrations.M20241027_server_operators where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20241027_server_operators :: Query
|
||||
m20241027_server_operators =
|
||||
[sql|
|
||||
CREATE TABLE server_operators (
|
||||
server_operator_id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
server_operator_tag TEXT,
|
||||
trade_name TEXT NOT NULL,
|
||||
legal_name TEXT,
|
||||
server_domains TEXT,
|
||||
enabled INTEGER NOT NULL DEFAULT 1,
|
||||
role_storage INTEGER NOT NULL DEFAULT 1,
|
||||
role_proxy INTEGER NOT NULL DEFAULT 1,
|
||||
accepted_conditions_commit TEXT,
|
||||
created_at TEXT NOT NULL DEFAULT (datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT (datetime('now'))
|
||||
);
|
||||
|
||||
ALTER TABLE protocol_servers ADD COLUMN server_operator_id INTEGER REFERENCES server_operators ON DELETE SET NULL;
|
||||
|
||||
CREATE TABLE usage_conditions (
|
||||
usage_conditions_id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
conditions_commit TEXT NOT NULL UNIQUE,
|
||||
notified_at TEXT,
|
||||
created_at TEXT NOT NULL DEFAULT (datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT (datetime('now'))
|
||||
);
|
||||
|
||||
CREATE TABLE operator_usage_conditions (
|
||||
operator_usage_conditions_id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
server_operator_id INTEGER REFERENCES server_operators (server_operator_id) ON DELETE SET NULL ON UPDATE CASCADE,
|
||||
server_operator_tag TEXT,
|
||||
conditions_commit TEXT NOT NULL,
|
||||
accepted_at TEXT,
|
||||
created_at TEXT NOT NULL DEFAULT (datetime('now'))
|
||||
);
|
||||
|
||||
CREATE INDEX idx_protocol_servers_server_operator_id ON protocol_servers(server_operator_id);
|
||||
CREATE INDEX idx_operator_usage_conditions_server_operator_id ON operator_usage_conditions(server_operator_id);
|
||||
CREATE UNIQUE INDEX idx_operator_usage_conditions_conditions_commit ON operator_usage_conditions(server_operator_id, conditions_commit);
|
||||
|
||||
INSERT INTO server_operators
|
||||
(server_operator_id, server_operator_tag, trade_name, legal_name, server_domains, enabled)
|
||||
VALUES (1, 'simplex', 'SimpleX Chat', 'SimpleX Chat Ltd', 'simplex.im', 1);
|
||||
INSERT INTO server_operators
|
||||
(server_operator_id, server_operator_tag, trade_name, legal_name, server_domains, enabled)
|
||||
VALUES (2, 'xyz', 'XYZ', 'XYZ Ltd', 'xyz.com', 0);
|
||||
|
||||
-- UPDATE protocol_servers SET server_operator_id = 1 WHERE host LIKE "%.simplex.im" OR host LIKE "%.simplex.im,%";
|
||||
|]
|
||||
|
||||
down_m20241027_server_operators :: Query
|
||||
down_m20241027_server_operators =
|
||||
[sql|
|
||||
DROP INDEX idx_operator_usage_conditions_conditions_commit;
|
||||
DROP INDEX idx_operator_usage_conditions_server_operator_id;
|
||||
DROP INDEX idx_protocol_servers_server_operator_id;
|
||||
|
||||
ALTER TABLE protocol_servers DROP COLUMN server_operator_id;
|
||||
|
||||
DROP TABLE operator_usage_conditions;
|
||||
DROP TABLE usage_conditions;
|
||||
DROP TABLE server_operators;
|
||||
|]
|
|
@ -450,6 +450,7 @@ CREATE TABLE IF NOT EXISTS "protocol_servers"(
|
|||
created_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
protocol TEXT NOT NULL DEFAULT 'smp',
|
||||
server_operator_id INTEGER REFERENCES server_operators ON DELETE SET NULL,
|
||||
UNIQUE(user_id, host, port)
|
||||
);
|
||||
CREATE TABLE xftp_file_descriptions(
|
||||
|
@ -589,6 +590,34 @@ CREATE TABLE note_folders(
|
|||
unread_chat INTEGER NOT NULL DEFAULT 0
|
||||
);
|
||||
CREATE TABLE app_settings(app_settings TEXT NOT NULL);
|
||||
CREATE TABLE server_operators(
|
||||
server_operator_id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
server_operator_tag TEXT,
|
||||
trade_name TEXT NOT NULL,
|
||||
legal_name TEXT,
|
||||
server_domains TEXT,
|
||||
enabled INTEGER NOT NULL DEFAULT 1,
|
||||
role_storage INTEGER NOT NULL DEFAULT 1,
|
||||
role_proxy INTEGER NOT NULL DEFAULT 1,
|
||||
accepted_conditions_commit TEXT,
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
|
||||
);
|
||||
CREATE TABLE usage_conditions(
|
||||
usage_conditions_id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
conditions_commit TEXT NOT NULL UNIQUE,
|
||||
notified_at TEXT,
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
|
||||
);
|
||||
CREATE TABLE operator_usage_conditions(
|
||||
operator_usage_conditions_id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
server_operator_id INTEGER REFERENCES server_operators(server_operator_id) ON DELETE SET NULL ON UPDATE CASCADE,
|
||||
server_operator_tag TEXT,
|
||||
conditions_commit TEXT NOT NULL,
|
||||
accepted_at TEXT,
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now'))
|
||||
);
|
||||
CREATE INDEX contact_profiles_index ON contact_profiles(
|
||||
display_name,
|
||||
full_name
|
||||
|
@ -890,3 +919,13 @@ CREATE INDEX idx_received_probes_group_member_id on received_probes(
|
|||
group_member_id
|
||||
);
|
||||
CREATE INDEX idx_contact_requests_contact_id ON contact_requests(contact_id);
|
||||
CREATE INDEX idx_protocol_servers_server_operator_id ON protocol_servers(
|
||||
server_operator_id
|
||||
);
|
||||
CREATE INDEX idx_operator_usage_conditions_server_operator_id ON operator_usage_conditions(
|
||||
server_operator_id
|
||||
);
|
||||
CREATE UNIQUE INDEX idx_operator_usage_conditions_conditions_commit ON operator_usage_conditions(
|
||||
server_operator_id,
|
||||
conditions_commit
|
||||
);
|
||||
|
|
110
src/Simplex/Chat/Operators.hs
Normal file
110
src/Simplex/Chat/Operators.hs
Normal file
|
@ -0,0 +1,110 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Simplex.Chat.Operators where
|
||||
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.Aeson.Encoding as JE
|
||||
import qualified Data.Aeson.TH as JQ
|
||||
import Data.FileEmbed
|
||||
import Data.Int (Int64)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Database.SQLite.Simple.FromField (FromField (..))
|
||||
import Database.SQLite.Simple.ToField (ToField (..))
|
||||
import Language.Haskell.TH.Syntax (lift)
|
||||
import Simplex.Chat.Operators.Conditions
|
||||
import Simplex.Chat.Types.Util (textParseJSON)
|
||||
import Simplex.Messaging.Agent.Env.SQLite (OperatorId, ServerRoles)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, sumTypeJSON)
|
||||
import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolType (..))
|
||||
import Simplex.Messaging.Util (safeDecodeUtf8)
|
||||
|
||||
usageConditionsCommit :: Text
|
||||
usageConditionsCommit = "165143a1112308c035ac00ed669b96b60599aa1c"
|
||||
|
||||
usageConditionsText :: Text
|
||||
usageConditionsText =
|
||||
$( let s = $(embedFile =<< makeRelativeToProject "PRIVACY.md")
|
||||
in [|stripFrontMatter (safeDecodeUtf8 $(lift s))|]
|
||||
)
|
||||
|
||||
data OperatorTag = OTSimplex | OTXyz
|
||||
deriving (Show)
|
||||
|
||||
instance FromField OperatorTag where fromField = fromTextField_ textDecode
|
||||
|
||||
instance ToField OperatorTag where toField = toField . textEncode
|
||||
|
||||
instance FromJSON OperatorTag where
|
||||
parseJSON = textParseJSON "OperatorTag"
|
||||
|
||||
instance ToJSON OperatorTag where
|
||||
toJSON = J.String . textEncode
|
||||
toEncoding = JE.text . textEncode
|
||||
|
||||
instance TextEncoding OperatorTag where
|
||||
textDecode = \case
|
||||
"simplex" -> Just OTSimplex
|
||||
"xyz" -> Just OTXyz
|
||||
_ -> Nothing
|
||||
textEncode = \case
|
||||
OTSimplex -> "simplex"
|
||||
OTXyz -> "xyz"
|
||||
|
||||
data UsageConditions = UsageConditions
|
||||
{ conditionsId :: Int64,
|
||||
conditionsCommit :: Text,
|
||||
notifiedAt :: Maybe UTCTime,
|
||||
createdAt :: UTCTime
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data UsageConditionsAction
|
||||
= UCAReview {operators :: [ServerOperator], deadline :: Maybe UTCTime, showNotice :: Bool}
|
||||
| UCAAccepted {operators :: [ServerOperator]}
|
||||
deriving (Show)
|
||||
|
||||
-- TODO UI logic
|
||||
usageConditionsAction :: UsageConditionsAction
|
||||
usageConditionsAction = UCAAccepted []
|
||||
|
||||
data ConditionsAcceptance
|
||||
= CAAccepted {acceptedAt :: UTCTime}
|
||||
| CARequired {deadline :: Maybe UTCTime}
|
||||
deriving (Show)
|
||||
|
||||
data ServerOperator = ServerOperator
|
||||
{ operatorId :: OperatorId,
|
||||
operatorTag :: Maybe OperatorTag,
|
||||
tradeName :: Text,
|
||||
legalName :: Maybe Text,
|
||||
serverDomains :: [Text],
|
||||
acceptedConditions :: ConditionsAcceptance,
|
||||
enabled :: Bool,
|
||||
roles :: ServerRoles
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data UserServers = UserServers
|
||||
{ operator :: ServerOperator,
|
||||
smpServers :: NonEmpty (ProtoServerWithAuth 'PSMP),
|
||||
xftpServers :: NonEmpty (ProtoServerWithAuth 'PXFTP)
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''UsageConditions)
|
||||
|
||||
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CA") ''ConditionsAcceptance)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''ServerOperator)
|
||||
|
||||
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "UCA") ''UsageConditionsAction)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''UserServers)
|
19
src/Simplex/Chat/Operators/Conditions.hs
Normal file
19
src/Simplex/Chat/Operators/Conditions.hs
Normal file
|
@ -0,0 +1,19 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Simplex.Chat.Operators.Conditions where
|
||||
|
||||
import Data.Char (isSpace)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
|
||||
stripFrontMatter :: Text -> Text
|
||||
stripFrontMatter =
|
||||
T.unlines
|
||||
. dropWhile ("# " `T.isPrefixOf`) -- strip title
|
||||
. dropWhile (T.all isSpace)
|
||||
. dropWhile fm
|
||||
. (\ls -> let ls' = dropWhile (not . fm) ls in if null ls' then ls else ls')
|
||||
. dropWhile fm
|
||||
. T.lines
|
||||
where
|
||||
fm = ("---" `T.isPrefixOf`)
|
|
@ -114,6 +114,7 @@ import Simplex.Chat.Migrations.M20240827_calls_uuid
|
|||
import Simplex.Chat.Migrations.M20240920_user_order
|
||||
import Simplex.Chat.Migrations.M20241008_indexes
|
||||
import Simplex.Chat.Migrations.M20241010_contact_requests_contact_id
|
||||
import Simplex.Chat.Migrations.M20241027_server_operators
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
|
||||
|
||||
schemaMigrations :: [(String, Query, Maybe Query)]
|
||||
|
@ -227,7 +228,8 @@ schemaMigrations =
|
|||
("20240827_calls_uuid", m20240827_calls_uuid, Just down_m20240827_calls_uuid),
|
||||
("20240920_user_order", m20240920_user_order, Just down_m20240920_user_order),
|
||||
("20241008_indexes", m20241008_indexes, Just down_m20241008_indexes),
|
||||
("20241010_contact_requests_contact_id", m20241010_contact_requests_contact_id, Just down_m20241010_contact_requests_contact_id)
|
||||
("20241010_contact_requests_contact_id", m20241010_contact_requests_contact_id, Just down_m20241010_contact_requests_contact_id),
|
||||
("20241027_server_operators", m20241027_server_operators, Just down_m20241027_server_operators)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
|
|
|
@ -47,7 +47,9 @@ module Simplex.Chat.Store.Profiles
|
|||
getContactWithoutConnViaAddress,
|
||||
updateUserAddressAutoAccept,
|
||||
getProtocolServers,
|
||||
-- overwriteOperatorsAndServers,
|
||||
overwriteProtocolServers,
|
||||
getServerOperators,
|
||||
createCall,
|
||||
deleteCalls,
|
||||
getCalls,
|
||||
|
@ -76,6 +78,7 @@ import Database.SQLite.Simple (NamedParam (..), Only (..), (:.) (..))
|
|||
import Database.SQLite.Simple.QQ (sql)
|
||||
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
|
||||
|
@ -83,7 +86,7 @@ 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 (ServerCfg (..))
|
||||
import Simplex.Messaging.Agent.Env.SQLite (OperatorId, ServerCfg (..), ServerRoles (..))
|
||||
import Simplex.Messaging.Agent.Protocol (ACorrId, ConnId, UserId)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
|
||||
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
||||
|
@ -521,20 +524,25 @@ getProtocolServers db User {userId} =
|
|||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT host, port, key_hash, basic_auth, preset, tested, enabled
|
||||
FROM protocol_servers
|
||||
WHERE user_id = ? AND protocol = ?;
|
||||
SELECT s.host, s.port, s.key_hash, s.basic_auth, s.server_operator_id, s.preset, s.tested, s.enabled, o.role_storage, o.role_proxy
|
||||
FROM protocol_servers s
|
||||
LEFT JOIN server_operators o USING (server_operator_id)
|
||||
WHERE s.user_id = ? AND s.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) =
|
||||
toServerCfg :: (NonEmpty TransportHost, String, C.KeyHash, Maybe Text, Maybe OperatorId, Bool, Maybe Bool, Bool, Maybe Bool, Maybe Bool) -> ServerCfg p
|
||||
toServerCfg (host, port, keyHash, auth_, operator, preset, tested, enabled, storage_, proxy_) =
|
||||
let server = ProtoServerWithAuth (ProtocolServer protocol host port keyHash) (BasicAuth . encodeUtf8 <$> auth_)
|
||||
in ServerCfg {server, preset, tested, enabled}
|
||||
roles = ServerRoles {storage = fromMaybe True storage_, proxy = fromMaybe True proxy_}
|
||||
in ServerCfg {server, operator, preset, tested, enabled, roles}
|
||||
|
||||
overwriteProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> [ServerCfg p] -> ExceptT StoreError IO ()
|
||||
-- overwriteOperatorsAndServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> Maybe [ServerOperator] -> [ServerCfg p] -> ExceptT StoreError IO [ServerCfg p]
|
||||
-- overwriteOperatorsAndServers db user@User {userId} operators_ servers = do
|
||||
overwriteProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> [ServerCfg p] -> ExceptT StoreError IO ()
|
||||
overwriteProtocolServers db User {userId} servers =
|
||||
-- liftIO $ mapM_ (updateServerOperators_ db) operators_
|
||||
checkConstraint SEUniqueID . ExceptT $ do
|
||||
currentTs <- getCurrentTime
|
||||
DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND protocol = ? " (userId, protocol)
|
||||
|
@ -549,9 +557,62 @@ overwriteProtocolServers db User {userId} servers =
|
|||
|]
|
||||
((protocol, host, port, keyHash, safeDecodeUtf8 . unBasicAuth <$> auth_) :. (preset, tested, enabled, userId, currentTs, currentTs))
|
||||
pure $ Right ()
|
||||
-- Right <$> getProtocolServers db user
|
||||
where
|
||||
protocol = decodeLatin1 $ strEncode $ protocolTypeI @p
|
||||
|
||||
getServerOperators :: DB.Connection -> UTCTime -> IO [ServerOperator]
|
||||
getServerOperators db ts =
|
||||
map toOperator
|
||||
<$> DB.query_
|
||||
db
|
||||
[sql|
|
||||
SELECT server_operator_id, server_operator_tag, trade_name, legal_name, server_domains, enabled, role_storage, role_proxy
|
||||
FROM server_operators;
|
||||
|]
|
||||
where
|
||||
-- TODO get conditions state
|
||||
toOperator (operatorId, operatorTag, tradeName, legalName, domains, enabled, storage, proxy) =
|
||||
let roles = ServerRoles {storage, proxy}
|
||||
in ServerOperator {operatorId, operatorTag, tradeName, legalName, serverDomains = [domains], acceptedConditions = CAAccepted ts, enabled, roles}
|
||||
|
||||
-- updateServerOperators_ :: DB.Connection -> [ServerOperator] -> IO [ServerOperator]
|
||||
-- updateServerOperators_ db operators = do
|
||||
-- DB.execute_ db "DELETE FROM server_operators WHERE preset = 0"
|
||||
-- let (existing, new) = partition (isJust . operatorId) operators
|
||||
-- existing' <- mapM (\op -> upsertExisting op $> op) existing
|
||||
-- new' <- mapM insertNew new
|
||||
-- pure $ existing' <> new'
|
||||
-- where
|
||||
-- upsertExisting ServerOperator {operatorId, name, preset, enabled, roles = ServerRoles {storage, proxy}}
|
||||
-- | preset =
|
||||
-- DB.execute
|
||||
-- db
|
||||
-- [sql|
|
||||
-- UPDATE server_operators
|
||||
-- SET enabled = ?, role_storage = ?, role_proxy = ?
|
||||
-- WHERE server_operator_id = ?
|
||||
-- |]
|
||||
-- (enabled, storage, proxy, operatorId)
|
||||
-- | otherwise =
|
||||
-- DB.execute
|
||||
-- db
|
||||
-- [sql|
|
||||
-- INSERT INTO server_operators (server_operator_id, name, preset, enabled, role_storage, role_proxy)
|
||||
-- VALUES (?,?,?,?,?,?)
|
||||
-- |]
|
||||
-- (operatorId, name, preset, enabled, storage, proxy)
|
||||
-- insertNew op@ServerOperator {name, preset, enabled, roles = ServerRoles {storage, proxy}} = do
|
||||
-- DB.execute
|
||||
-- db
|
||||
-- [sql|
|
||||
-- INSERT INTO server_operators (name, preset, enabled, role_storage, role_proxy)
|
||||
-- VALUES (?,?,?,?,?)
|
||||
-- |]
|
||||
-- (name, preset, enabled, storage, proxy)
|
||||
-- opId <- insertedRowId db
|
||||
-- pure op {operatorId = Just opId}
|
||||
|
||||
createCall :: DB.Connection -> User -> Call -> UTCTime -> IO ()
|
||||
createCall db user@User {userId} Call {contactId, callId, callUUID, chatItemId, callState} callTs = do
|
||||
currentTs <- getCurrentTime
|
||||
|
|
|
@ -13,7 +13,7 @@ import qualified Data.Text as T
|
|||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Database.SQLite.Simple (SQLError (..))
|
||||
import qualified Database.SQLite.Simple as DB
|
||||
import Simplex.Chat (defaultChatConfig)
|
||||
import Simplex.Chat (defaultChatConfig, operatorSimpleXChat)
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Core
|
||||
import Simplex.Chat.Help (chatWelcome)
|
||||
|
@ -21,7 +21,7 @@ import Simplex.Chat.Options
|
|||
import Simplex.Chat.Terminal.Input
|
||||
import Simplex.Chat.Terminal.Output
|
||||
import Simplex.FileTransfer.Client.Presets (defaultXFTPServers)
|
||||
import Simplex.Messaging.Agent.Env.SQLite (presetServerCfg)
|
||||
import Simplex.Messaging.Agent.Env.SQLite (allRoles, presetServerCfg)
|
||||
import Simplex.Messaging.Client (NetworkConfig (..), SMPProxyFallback (..), SMPProxyMode (..), defaultNetworkConfig)
|
||||
import Simplex.Messaging.Util (raceAny_)
|
||||
import System.IO (hFlush, hSetEcho, stdin, stdout)
|
||||
|
@ -34,14 +34,14 @@ terminalChatConfig =
|
|||
{ smp =
|
||||
L.fromList $
|
||||
map
|
||||
(presetServerCfg True)
|
||||
(presetServerCfg True allRoles operatorSimpleXChat)
|
||||
[ "smp://u2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU=@smp4.simplex.im,o5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion",
|
||||
"smp://hpq7_4gGJiilmz5Rf-CswuU5kZGkm_zOIooSw6yALRg=@smp5.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion",
|
||||
"smp://PQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo=@smp6.simplex.im,bylepyau3ty4czmn77q4fglvperknl4bi2eb2fdy2bh4jxtf32kf73yd.onion"
|
||||
],
|
||||
useSMP = 3,
|
||||
ntf = ["ntf://FB-Uop7RTaZZEG0ZLD2CIaTjsPh-Fw0zFAnb7QyA8Ks=@ntf2.simplex.im,ntg7jdjy2i3qbib3sykiho3enekwiaqg3icctliqhtqcg6jmoh6cxiad.onion"],
|
||||
xftp = L.map (presetServerCfg True) defaultXFTPServers,
|
||||
xftp = L.map (presetServerCfg True allRoles operatorSimpleXChat) defaultXFTPServers,
|
||||
useXFTP = L.length defaultXFTPServers,
|
||||
netCfg =
|
||||
defaultNetworkConfig
|
||||
|
|
|
@ -19,7 +19,7 @@ import qualified Data.ByteString.Lazy.Char8 as LB
|
|||
import Data.Char (isSpace, toUpper)
|
||||
import Data.Function (on)
|
||||
import Data.Int (Int64)
|
||||
import Data.List (groupBy, intercalate, intersperse, partition, sortOn)
|
||||
import Data.List (foldl', groupBy, intercalate, intersperse, partition, sortOn)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Map.Strict (Map)
|
||||
|
@ -42,6 +42,7 @@ import Simplex.Chat.Help
|
|||
import Simplex.Chat.Markdown
|
||||
import Simplex.Chat.Messages hiding (NewChatItem (..))
|
||||
import Simplex.Chat.Messages.CIContent
|
||||
import Simplex.Chat.Operators
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Remote.AppVersion (AppVersion (..), pattern AppVersionRange)
|
||||
import Simplex.Chat.Remote.Types
|
||||
|
@ -95,8 +96,12 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
|
|||
CRChats chats -> viewChats ts tz chats
|
||||
CRApiChat u chat -> ttyUser u $ if testView then testViewChat chat else [viewJSON chat]
|
||||
CRApiParsedMarkdown ft -> [viewJSON ft]
|
||||
CRUserProtoServers u userServers -> ttyUser u $ viewUserServers userServers testView
|
||||
CRUserProtoServers u userServers operators -> ttyUser u $ viewUserServers userServers operators testView
|
||||
CRServerTestResult u srv testFailure -> ttyUser u $ viewServerTestResult srv testFailure
|
||||
CRServerOperators {} -> []
|
||||
CRUserServers {} -> []
|
||||
CRUserServersValidation _ -> []
|
||||
CRUsageConditions {} -> []
|
||||
CRChatItemTTL u ttl -> ttyUser u $ viewChatItemTTL ttl
|
||||
CRNetworkConfig cfg -> viewNetworkConfig cfg
|
||||
CRContactInfo u ct cStats customUserProfile -> ttyUser u $ viewContactInfo ct cStats customUserProfile
|
||||
|
@ -1209,8 +1214,8 @@ viewUserPrivacy User {userId} User {userId = userId', localDisplayName = n', sho
|
|||
"profile is " <> if isJust viewPwdHash then "hidden" else "visible"
|
||||
]
|
||||
|
||||
viewUserServers :: AUserProtoServers -> Bool -> [StyledString]
|
||||
viewUserServers (AUPS UserProtoServers {serverProtocol = p, protoServers, presetServers}) testView =
|
||||
viewUserServers :: AUserProtoServers -> [ServerOperator] -> Bool -> [StyledString]
|
||||
viewUserServers (AUPS UserProtoServers {serverProtocol = p, protoServers, presetServers}) operators testView =
|
||||
customServers
|
||||
<> if testView
|
||||
then []
|
||||
|
@ -1228,8 +1233,8 @@ viewUserServers (AUPS UserProtoServers {serverProtocol = p, protoServers, preset
|
|||
pName = protocolName p
|
||||
customServers =
|
||||
if null protoServers
|
||||
then ("no " <> pName <> " servers saved, using presets: ") : viewServers presetServers
|
||||
else viewServers protoServers
|
||||
then ("no " <> pName <> " servers saved, using presets: ") : viewServers operators presetServers
|
||||
else viewServers operators protoServers
|
||||
|
||||
protocolName :: ProtocolTypeI p => SProtocolType p -> StyledString
|
||||
protocolName = plain . map toUpper . T.unpack . decodeLatin1 . strEncode
|
||||
|
@ -1326,8 +1331,11 @@ viewConnectionStats ConnectionStats {rcvQueuesInfo, sndQueuesInfo} =
|
|||
["receiving messages via: " <> viewRcvQueuesInfo rcvQueuesInfo | not $ null rcvQueuesInfo]
|
||||
<> ["sending messages via: " <> viewSndQueuesInfo sndQueuesInfo | not $ null sndQueuesInfo]
|
||||
|
||||
viewServers :: ProtocolTypeI p => NonEmpty (ServerCfg p) -> [StyledString]
|
||||
viewServers = map (plain . B.unpack . strEncode . (\ServerCfg {server} -> server)) . L.toList
|
||||
viewServers :: ProtocolTypeI p => [ServerOperator] -> NonEmpty (ServerCfg p) -> [StyledString]
|
||||
viewServers operators = map (plain . (\ServerCfg {server, operator} -> B.unpack (strEncode server) <> viewOperator operator)) . L.toList
|
||||
where
|
||||
ops :: Map (Maybe Int64) Text = foldl' (\m ServerOperator {operatorId, tradeName} -> M.insert (Just operatorId) tradeName m) M.empty operators
|
||||
viewOperator = maybe "" $ \op -> " (operator " <> maybe (show op) T.unpack (M.lookup (Just op) ops) <> ")"
|
||||
|
||||
viewRcvQueuesInfo :: [RcvQueueInfo] -> StyledString
|
||||
viewRcvQueuesInfo = plain . intercalate ", " . map showQueueInfo
|
||||
|
|
|
@ -423,11 +423,10 @@ smpServerCfg =
|
|||
ServerConfig
|
||||
{ transports = [(serverPort, transport @TLS, False)],
|
||||
tbqSize = 1,
|
||||
-- serverTbqSize = 1,
|
||||
msgQueueQuota = 16,
|
||||
msgStoreType = AMSType SMSMemory,
|
||||
maxJournalMsgCount = 1000,
|
||||
maxJournalStateLines = 1000,
|
||||
msgQueueQuota = 16,
|
||||
maxJournalMsgCount = 24,
|
||||
maxJournalStateLines = 4,
|
||||
queueIdBytes = 12,
|
||||
msgIdBytes = 6,
|
||||
storeLogFile = Nothing,
|
||||
|
|
|
@ -9,7 +9,7 @@ import Control.Monad (replicateM)
|
|||
import qualified Data.List.NonEmpty as L
|
||||
import Simplex.Chat (cfgServers, cfgServersToUse, defaultChatConfig, randomServers)
|
||||
import Simplex.Chat.Controller (ChatConfig (..))
|
||||
import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..))
|
||||
import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..), ServerRoles (..))
|
||||
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), SProtocolType (..), UserProtocol)
|
||||
import Test.Hspec
|
||||
|
||||
|
@ -18,6 +18,8 @@ randomServersTests = describe "choosig random servers" $ do
|
|||
it "should choose 4 random SMP servers and keep the rest disabled" testRandomSMPServers
|
||||
it "should keep all 6 XFTP servers" testRandomXFTPServers
|
||||
|
||||
deriving instance Eq ServerRoles
|
||||
|
||||
deriving instance Eq (ServerCfg p)
|
||||
|
||||
testRandomSMPServers :: IO ()
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue