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:
Evgeny 2024-11-04 13:28:57 +00:00 committed by GitHub
parent 9a1166f097
commit 97df069730
No known key found for this signature in database
GPG key ID: B5690EEEBB952194
17 changed files with 440 additions and 36 deletions

View file

@ -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

View 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.

View file

@ -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.*

View file

@ -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";

View file

@ -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.*

View file

@ -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

View file

@ -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)

View 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;
|]

View file

@ -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
);

View 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)

View 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`)

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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,

View file

@ -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 ()