diff --git a/cabal.project b/cabal.project index c9b8b11722..61ce04a569 100644 --- a/cabal.project +++ b/cabal.project @@ -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 diff --git a/docs/rfcs/2024-10-27-server-operators.md b/docs/rfcs/2024-10-27-server-operators.md new file mode 100644 index 0000000000..5456d28f08 --- /dev/null +++ b/docs/rfcs/2024-10-27-server-operators.md @@ -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. diff --git a/package.yaml b/package.yaml index 94dc13ad2e..2fc50a3532 100644 --- a/package.yaml +++ b/package.yaml @@ -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.* diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index 8de91675e3..3e0f103641 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -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"; diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 96d16f5004..c7d603457c 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -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.* diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 885d4303c8..380f6c5d24 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -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 diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index b39b4d7456..bd2cee3e50 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -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) diff --git a/src/Simplex/Chat/Migrations/M20241027_server_operators.hs b/src/Simplex/Chat/Migrations/M20241027_server_operators.hs new file mode 100644 index 0000000000..bc9f40bddf --- /dev/null +++ b/src/Simplex/Chat/Migrations/M20241027_server_operators.hs @@ -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; +|] diff --git a/src/Simplex/Chat/Migrations/chat_schema.sql b/src/Simplex/Chat/Migrations/chat_schema.sql index 2619a5c4e5..07c363eda9 100644 --- a/src/Simplex/Chat/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Migrations/chat_schema.sql @@ -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 +); diff --git a/src/Simplex/Chat/Operators.hs b/src/Simplex/Chat/Operators.hs new file mode 100644 index 0000000000..9a2dac0b1b --- /dev/null +++ b/src/Simplex/Chat/Operators.hs @@ -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) diff --git a/src/Simplex/Chat/Operators/Conditions.hs b/src/Simplex/Chat/Operators/Conditions.hs new file mode 100644 index 0000000000..55cf8b658d --- /dev/null +++ b/src/Simplex/Chat/Operators/Conditions.hs @@ -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`) diff --git a/src/Simplex/Chat/Store/Migrations.hs b/src/Simplex/Chat/Store/Migrations.hs index e2d12e78d7..e33f2336cc 100644 --- a/src/Simplex/Chat/Store/Migrations.hs +++ b/src/Simplex/Chat/Store/Migrations.hs @@ -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 diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index fb9774a54e..fe2cc737fb 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/src/Simplex/Chat/Store/Profiles.hs @@ -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 diff --git a/src/Simplex/Chat/Terminal.hs b/src/Simplex/Chat/Terminal.hs index 5cc695db04..e38a34d45f 100644 --- a/src/Simplex/Chat/Terminal.hs +++ b/src/Simplex/Chat/Terminal.hs @@ -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 diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index ade36476c7..c53e5a2749 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -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 diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index 75b85d7a5f..d435af186e 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -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, diff --git a/tests/RandomServers.hs b/tests/RandomServers.hs index 0c6baa71bb..e0b1939c9e 100644 --- a/tests/RandomServers.hs +++ b/tests/RandomServers.hs @@ -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 ()