mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-07-03 17:42:08 +00:00
Merge branch 'ep/operators-preset-servers' into ep/operators-preset-servers-android
This commit is contained in:
Evgeny Poberezkin
@@ -922,10 +922,9 @@
|
||||
5CB924DF27A8678B00ACCCDD /* UserSettings */ = {
|
||||
isa = PBXGroup;
|
||||
children = (
|
||||
643B3B4C2CCFD34B0083A2CF /* NetworkAndServers */,
|
||||
5CB924D627A8563F00ACCCDD /* SettingsView.swift */,
|
||||
5CB346E62868D76D001FD2EF /* NotificationsView.swift */,
|
||||
5C9C2DA6289957AE00CC63B1 /* AdvancedNetworkSettings.swift */,
|
||||
5C9C2DA82899DA6F00CC63B1 /* NetworkAndServers.swift */,
|
||||
5CADE79929211BB900072E13 /* PreferencesView.swift */,
|
||||
5C5DB70D289ABDD200730FFF /* AppearanceSettings.swift */,
|
||||
5C05DF522840AA1D00C683F9 /* CallSettings.swift */,
|
||||
@@ -933,9 +932,6 @@
|
||||
5CC036DF29C488D500C0EF20 /* HiddenProfileView.swift */,
|
||||
5C577F7C27C83AA10006112D /* MarkdownHelp.swift */,
|
||||
5C3F1D57284363C400EC8A82 /* PrivacySettings.swift */,
|
||||
5C93292E29239A170090FFF9 /* ProtocolServersView.swift */,
|
||||
5C93293029239BED0090FFF9 /* ProtocolServerView.swift */,
|
||||
5C9329402929248A0090FFF9 /* ScanProtocolServer.swift */,
|
||||
5CB2084E28DA4B4800D024EC /* RTCServers.swift */,
|
||||
64F1CC3A28B39D8600CD1FB1 /* IncognitoHelp.swift */,
|
||||
18415845648CA4F5A8BCA272 /* UserProfilesView.swift */,
|
||||
@@ -1066,6 +1062,18 @@
|
||||
path = Database;
|
||||
sourceTree = "<group>";
|
||||
};
|
||||
643B3B4C2CCFD34B0083A2CF /* NetworkAndServers */ = {
|
||||
isa = PBXGroup;
|
||||
children = (
|
||||
5C9329402929248A0090FFF9 /* ScanProtocolServer.swift */,
|
||||
5C93293029239BED0090FFF9 /* ProtocolServerView.swift */,
|
||||
5C93292E29239A170090FFF9 /* ProtocolServersView.swift */,
|
||||
5C9C2DA6289957AE00CC63B1 /* AdvancedNetworkSettings.swift */,
|
||||
5C9C2DA82899DA6F00CC63B1 /* NetworkAndServers.swift */,
|
||||
);
|
||||
path = NetworkAndServers;
|
||||
sourceTree = "<group>";
|
||||
};
|
||||
6440CA01288AEC770062C672 /* Group */ = {
|
||||
isa = PBXGroup;
|
||||
children = (
|
||||
|
||||
+1
-1
@@ -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: 93f30c8edf9243ad2291dd6427d87328e282560a
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
|
||||
@@ -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.
|
||||
+3
-1
@@ -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.*
|
||||
@@ -38,6 +39,7 @@ dependencies:
|
||||
- optparse-applicative >= 0.15 && < 0.17
|
||||
- random >= 1.1 && < 1.3
|
||||
- record-hasfield == 1.0.*
|
||||
- scientific ==0.3.7.*
|
||||
- simple-logger == 0.1.*
|
||||
- simplexmq >= 5.0
|
||||
- socks == 0.6.*
|
||||
@@ -72,7 +74,7 @@ when:
|
||||
- bytestring == 0.10.*
|
||||
- process >= 1.6 && < 1.6.18
|
||||
- template-haskell == 2.16.*
|
||||
- text >= 1.2.3.0 && < 1.3
|
||||
- text >= 1.2.4.0 && < 1.3
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
|
||||
@@ -1,5 +1,5 @@
|
||||
{
|
||||
"https://github.com/simplex-chat/simplexmq.git"."ffecf200d4874dfa34f6d15b269964c0115a54ca" = "0kb8hq37fc5g198wq7dswnlwjzk67q8rrzil2dii5lc6xfr47jbs";
|
||||
"https://github.com/simplex-chat/simplexmq.git"."93f30c8edf9243ad2291dd6427d87328e282560a" = "1zf0sp9dy6kz4zvyz6mdgmhydps7khcq84n30irp983w1xh7gzs7";
|
||||
"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";
|
||||
|
||||
+24
-7
@@ -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
|
||||
@@ -223,6 +227,7 @@ library
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
, random >=1.1 && <1.3
|
||||
, record-hasfield ==1.0.*
|
||||
, scientific ==0.3.7.*
|
||||
, simple-logger ==0.1.*
|
||||
, simplexmq >=5.0
|
||||
, socks ==0.6.*
|
||||
@@ -249,7 +254,7 @@ library
|
||||
bytestring ==0.10.*
|
||||
, process >=1.6 && <1.6.18
|
||||
, template-haskell ==2.16.*
|
||||
, text >=1.2.3.0 && <1.3
|
||||
, text >=1.2.4.0 && <1.3
|
||||
|
||||
executable simplex-bot
|
||||
main-is: Main.hs
|
||||
@@ -276,6 +281,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
|
||||
@@ -286,6 +292,7 @@ executable simplex-bot
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
, random >=1.1 && <1.3
|
||||
, record-hasfield ==1.0.*
|
||||
, scientific ==0.3.7.*
|
||||
, simple-logger ==0.1.*
|
||||
, simplex-chat
|
||||
, simplexmq >=5.0
|
||||
@@ -313,7 +320,7 @@ executable simplex-bot
|
||||
bytestring ==0.10.*
|
||||
, process >=1.6 && <1.6.18
|
||||
, template-haskell ==2.16.*
|
||||
, text >=1.2.3.0 && <1.3
|
||||
, text >=1.2.4.0 && <1.3
|
||||
|
||||
executable simplex-bot-advanced
|
||||
main-is: Main.hs
|
||||
@@ -340,6 +347,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
|
||||
@@ -350,6 +358,7 @@ executable simplex-bot-advanced
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
, random >=1.1 && <1.3
|
||||
, record-hasfield ==1.0.*
|
||||
, scientific ==0.3.7.*
|
||||
, simple-logger ==0.1.*
|
||||
, simplex-chat
|
||||
, simplexmq >=5.0
|
||||
@@ -377,7 +386,7 @@ executable simplex-bot-advanced
|
||||
bytestring ==0.10.*
|
||||
, process >=1.6 && <1.6.18
|
||||
, template-haskell ==2.16.*
|
||||
, text >=1.2.3.0 && <1.3
|
||||
, text >=1.2.4.0 && <1.3
|
||||
|
||||
executable simplex-broadcast-bot
|
||||
main-is: Main.hs
|
||||
@@ -407,6 +416,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
|
||||
@@ -417,6 +427,7 @@ executable simplex-broadcast-bot
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
, random >=1.1 && <1.3
|
||||
, record-hasfield ==1.0.*
|
||||
, scientific ==0.3.7.*
|
||||
, simple-logger ==0.1.*
|
||||
, simplex-chat
|
||||
, simplexmq >=5.0
|
||||
@@ -444,7 +455,7 @@ executable simplex-broadcast-bot
|
||||
bytestring ==0.10.*
|
||||
, process >=1.6 && <1.6.18
|
||||
, template-haskell ==2.16.*
|
||||
, text >=1.2.3.0 && <1.3
|
||||
, text >=1.2.4.0 && <1.3
|
||||
|
||||
executable simplex-chat
|
||||
main-is: Main.hs
|
||||
@@ -472,6 +483,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
|
||||
@@ -482,6 +494,7 @@ executable simplex-chat
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
, random >=1.1 && <1.3
|
||||
, record-hasfield ==1.0.*
|
||||
, scientific ==0.3.7.*
|
||||
, simple-logger ==0.1.*
|
||||
, simplex-chat
|
||||
, simplexmq >=5.0
|
||||
@@ -510,7 +523,7 @@ executable simplex-chat
|
||||
bytestring ==0.10.*
|
||||
, process >=1.6 && <1.6.18
|
||||
, template-haskell ==2.16.*
|
||||
, text >=1.2.3.0 && <1.3
|
||||
, text >=1.2.4.0 && <1.3
|
||||
|
||||
executable simplex-directory-service
|
||||
main-is: Main.hs
|
||||
@@ -543,6 +556,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
|
||||
@@ -553,6 +567,7 @@ executable simplex-directory-service
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
, random >=1.1 && <1.3
|
||||
, record-hasfield ==1.0.*
|
||||
, scientific ==0.3.7.*
|
||||
, simple-logger ==0.1.*
|
||||
, simplex-chat
|
||||
, simplexmq >=5.0
|
||||
@@ -580,7 +595,7 @@ executable simplex-directory-service
|
||||
bytestring ==0.10.*
|
||||
, process >=1.6 && <1.6.18
|
||||
, template-haskell ==2.16.*
|
||||
, text >=1.2.3.0 && <1.3
|
||||
, text >=1.2.4.0 && <1.3
|
||||
|
||||
test-suite simplex-chat-test
|
||||
type: exitcode-stdio-1.0
|
||||
@@ -642,6 +657,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.*
|
||||
@@ -653,6 +669,7 @@ test-suite simplex-chat-test
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
, random >=1.1 && <1.3
|
||||
, record-hasfield ==1.0.*
|
||||
, scientific ==0.3.7.*
|
||||
, silently ==1.2.*
|
||||
, simple-logger ==0.1.*
|
||||
, simplex-chat
|
||||
@@ -681,7 +698,7 @@ test-suite simplex-chat-test
|
||||
bytestring ==0.10.*
|
||||
, process >=1.6 && <1.6.18
|
||||
, template-haskell ==2.16.*
|
||||
, text >=1.2.3.0 && <1.3
|
||||
, text >=1.2.4.0 && <1.3
|
||||
if impl(ghc >= 9.6.2)
|
||||
build-depends:
|
||||
hspec ==2.11.*
|
||||
|
||||
+296
-141
@@ -6,6 +6,7 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
@@ -43,7 +44,7 @@ import Data.Functor (($>))
|
||||
import Data.Functor.Identity
|
||||
import Data.Int (Int64)
|
||||
import Data.List (find, foldl', isSuffixOf, mapAccumL, partition, sortOn, zipWith4)
|
||||
import Data.List.NonEmpty (NonEmpty (..), nonEmpty, toList, (<|))
|
||||
import Data.List.NonEmpty (NonEmpty (..), (<|))
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
@@ -54,6 +55,7 @@ import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
import Data.Time (NominalDiffTime, addUTCTime, defaultTimeLocale, formatTime)
|
||||
import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime, nominalDay, nominalDiffTimeToSeconds)
|
||||
import Data.Type.Equality
|
||||
import qualified Data.UUID as UUID
|
||||
import qualified Data.UUID.V4 as V4
|
||||
import Data.Word (Word32)
|
||||
@@ -67,6 +69,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 +100,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 (..), ServerCfg (..), ServerRoles (..), allRoles, createAgentStore, defaultAgentConfig)
|
||||
import Simplex.Messaging.Agent.Lock (withLock)
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import qualified Simplex.Messaging.Agent.Protocol as AP (AgentErrorType (..))
|
||||
@@ -137,6 +140,32 @@ import qualified UnliftIO.Exception as E
|
||||
import UnliftIO.IO (hClose, hSeek, hTell, openFile)
|
||||
import UnliftIO.STM
|
||||
|
||||
operatorSimpleXChat :: NewServerOperator
|
||||
operatorSimpleXChat =
|
||||
ServerOperator
|
||||
{ operatorId = DBNewEntity,
|
||||
operatorTag = Just OTSimplex,
|
||||
tradeName = "SimpleX Chat",
|
||||
legalName = Just "SimpleX Chat Ltd",
|
||||
serverDomains = ["simplex.im"],
|
||||
conditionsAcceptance = CARequired Nothing,
|
||||
enabled = True,
|
||||
roles = allRoles
|
||||
}
|
||||
|
||||
operatorXYZ :: NewServerOperator
|
||||
operatorXYZ =
|
||||
ServerOperator
|
||||
{ operatorId = DBNewEntity,
|
||||
operatorTag = Just OTXyz,
|
||||
tradeName = "XYZ",
|
||||
legalName = Just "XYZ Ltd",
|
||||
serverDomains = ["xyz.com"],
|
||||
conditionsAcceptance = CARequired Nothing,
|
||||
enabled = False,
|
||||
roles = ServerRoles {storage = False, proxy = True}
|
||||
}
|
||||
|
||||
defaultChatConfig :: ChatConfig
|
||||
defaultChatConfig =
|
||||
ChatConfig
|
||||
@@ -147,13 +176,25 @@ defaultChatConfig =
|
||||
},
|
||||
chatVRange = supportedChatVRange,
|
||||
confirmMigrations = MCConsole,
|
||||
defaultServers =
|
||||
DefaultAgentServers
|
||||
{ smp = _defaultSMPServers,
|
||||
useSMP = 4,
|
||||
presetServers =
|
||||
PresetServers
|
||||
{ operators =
|
||||
[ PresetOperator
|
||||
{ operator = Just operatorSimpleXChat,
|
||||
smp = simplexChatSMPServers,
|
||||
useSMP = 4,
|
||||
xftp = map (presetServer True) $ L.toList defaultXFTPServers,
|
||||
useXFTP = 3
|
||||
},
|
||||
PresetOperator
|
||||
{ operator = Just operatorXYZ,
|
||||
smp = xyzSMPServers,
|
||||
useSMP = 3,
|
||||
xftp = xyzXFTPServers,
|
||||
useXFTP = 3
|
||||
}
|
||||
],
|
||||
ntf = _defaultNtfServers,
|
||||
xftp = L.map (presetServerCfg True) defaultXFTPServers,
|
||||
useXFTP = L.length defaultXFTPServers,
|
||||
netCfg = defaultNetworkConfig
|
||||
},
|
||||
tbqSize = 1024,
|
||||
@@ -177,29 +218,52 @@ defaultChatConfig =
|
||||
chatHooks = defaultChatHooks
|
||||
}
|
||||
|
||||
_defaultSMPServers :: NonEmpty (ServerCfg 'PSMP)
|
||||
_defaultSMPServers =
|
||||
L.fromList $
|
||||
map
|
||||
(presetServerCfg True)
|
||||
[ "smp://0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU=@smp8.simplex.im,beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion",
|
||||
"smp://SkIkI6EPd2D63F4xFKfHk7I1UGZVNn6k1QWZ5rcyr6w=@smp9.simplex.im,jssqzccmrcws6bhmn77vgmhfjmhwlyr3u7puw4erkyoosywgl67slqqd.onion",
|
||||
"smp://6iIcWT_dF2zN_w5xzZEY7HI2Prbh3ldP07YTyDexPjE=@smp10.simplex.im,rb2pbttocvnbrngnwziclp2f4ckjq65kebafws6g4hy22cdaiv5dwjqd.onion",
|
||||
"smp://1OwYGt-yqOfe2IyVHhxz3ohqo3aCCMjtB-8wn4X_aoY=@smp11.simplex.im,6ioorbm6i3yxmuoezrhjk6f6qgkc4syabh7m3so74xunb5nzr4pwgfqd.onion",
|
||||
"smp://UkMFNAXLXeAAe0beCa4w6X_zp18PwxSaSjY17BKUGXQ=@smp12.simplex.im,ie42b5weq7zdkghocs3mgxdjeuycheeqqmksntj57rmejagmg4eor5yd.onion",
|
||||
"smp://enEkec4hlR3UtKx2NMpOUK_K4ZuDxjWBO1d9Y4YXVaA=@smp14.simplex.im,aspkyu2sopsnizbyfabtsicikr2s4r3ti35jogbcekhm3fsoeyjvgrid.onion",
|
||||
"smp://h--vW7ZSkXPeOUpfxlFGgauQmXNFOzGoizak7Ult7cw=@smp15.simplex.im,oauu4bgijybyhczbnxtlggo6hiubahmeutaqineuyy23aojpih3dajad.onion",
|
||||
"smp://hejn2gVIqNU6xjtGM3OwQeuk8ZEbDXVJXAlnSBJBWUA=@smp16.simplex.im,p3ktngodzi6qrf7w64mmde3syuzrv57y55hxabqcq3l5p6oi7yzze6qd.onion",
|
||||
"smp://ZKe4uxF4Z_aLJJOEsC-Y6hSkXgQS5-oc442JQGkyP8M=@smp17.simplex.im,ogtwfxyi3h2h5weftjjpjmxclhb5ugufa5rcyrmg7j4xlch7qsr5nuqd.onion",
|
||||
"smp://PtsqghzQKU83kYTlQ1VKg996dW4Cw4x_bvpKmiv8uns=@smp18.simplex.im,lyqpnwbs2zqfr45jqkncwpywpbtq7jrhxnib5qddtr6npjyezuwd3nqd.onion",
|
||||
"smp://N_McQS3F9TGoh4ER0QstUf55kGnNSd-wXfNPZ7HukcM=@smp19.simplex.im,i53bbtoqhlc365k6kxzwdp5w3cdt433s7bwh3y32rcbml2vztiyyz5id.onion"
|
||||
simplexChatSMPServers :: [NewUserServer 'PSMP]
|
||||
simplexChatSMPServers =
|
||||
map
|
||||
(presetServer True)
|
||||
[ "smp://0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU=@smp8.simplex.im,beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion",
|
||||
"smp://SkIkI6EPd2D63F4xFKfHk7I1UGZVNn6k1QWZ5rcyr6w=@smp9.simplex.im,jssqzccmrcws6bhmn77vgmhfjmhwlyr3u7puw4erkyoosywgl67slqqd.onion",
|
||||
"smp://6iIcWT_dF2zN_w5xzZEY7HI2Prbh3ldP07YTyDexPjE=@smp10.simplex.im,rb2pbttocvnbrngnwziclp2f4ckjq65kebafws6g4hy22cdaiv5dwjqd.onion",
|
||||
"smp://1OwYGt-yqOfe2IyVHhxz3ohqo3aCCMjtB-8wn4X_aoY=@smp11.simplex.im,6ioorbm6i3yxmuoezrhjk6f6qgkc4syabh7m3so74xunb5nzr4pwgfqd.onion",
|
||||
"smp://UkMFNAXLXeAAe0beCa4w6X_zp18PwxSaSjY17BKUGXQ=@smp12.simplex.im,ie42b5weq7zdkghocs3mgxdjeuycheeqqmksntj57rmejagmg4eor5yd.onion",
|
||||
"smp://enEkec4hlR3UtKx2NMpOUK_K4ZuDxjWBO1d9Y4YXVaA=@smp14.simplex.im,aspkyu2sopsnizbyfabtsicikr2s4r3ti35jogbcekhm3fsoeyjvgrid.onion",
|
||||
"smp://h--vW7ZSkXPeOUpfxlFGgauQmXNFOzGoizak7Ult7cw=@smp15.simplex.im,oauu4bgijybyhczbnxtlggo6hiubahmeutaqineuyy23aojpih3dajad.onion",
|
||||
"smp://hejn2gVIqNU6xjtGM3OwQeuk8ZEbDXVJXAlnSBJBWUA=@smp16.simplex.im,p3ktngodzi6qrf7w64mmde3syuzrv57y55hxabqcq3l5p6oi7yzze6qd.onion",
|
||||
"smp://ZKe4uxF4Z_aLJJOEsC-Y6hSkXgQS5-oc442JQGkyP8M=@smp17.simplex.im,ogtwfxyi3h2h5weftjjpjmxclhb5ugufa5rcyrmg7j4xlch7qsr5nuqd.onion",
|
||||
"smp://PtsqghzQKU83kYTlQ1VKg996dW4Cw4x_bvpKmiv8uns=@smp18.simplex.im,lyqpnwbs2zqfr45jqkncwpywpbtq7jrhxnib5qddtr6npjyezuwd3nqd.onion",
|
||||
"smp://N_McQS3F9TGoh4ER0QstUf55kGnNSd-wXfNPZ7HukcM=@smp19.simplex.im,i53bbtoqhlc365k6kxzwdp5w3cdt433s7bwh3y32rcbml2vztiyyz5id.onion"
|
||||
]
|
||||
<> map
|
||||
(presetServer False)
|
||||
[ "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"
|
||||
]
|
||||
<> map
|
||||
(presetServerCfg False)
|
||||
[ "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"
|
||||
]
|
||||
|
||||
xyzSMPServers :: [NewUserServer 'PSMP]
|
||||
xyzSMPServers =
|
||||
map
|
||||
(presetServer True)
|
||||
[ "smp://abcd@smp1.xyz.com",
|
||||
"smp://abcd@smp2.xyz.com",
|
||||
"smp://abcd@smp3.xyz.com",
|
||||
"smp://abcd@smp4.xyz.com",
|
||||
"smp://abcd@smp5.xyz.com",
|
||||
"smp://abcd@smp6.xyz.com"
|
||||
]
|
||||
|
||||
xyzXFTPServers :: [NewUserServer 'PXFTP]
|
||||
xyzXFTPServers =
|
||||
map
|
||||
(presetServer True)
|
||||
[ "xftp://abcd@xftp1.xyz.com",
|
||||
"xftp://abcd@xftp2.xyz.com",
|
||||
"xftp://abcd@xftp3.xyz.com",
|
||||
"xftp://abcd@xftp4.xyz.com",
|
||||
"xftp://abcd@xftp5.xyz.com",
|
||||
"xftp://abcd@xftp6.xyz.com"
|
||||
]
|
||||
|
||||
_defaultNtfServers :: [NtfServer]
|
||||
_defaultNtfServers =
|
||||
@@ -236,16 +300,19 @@ newChatController :: ChatDatabase -> Maybe User -> ChatConfig -> ChatOpts -> Boo
|
||||
newChatController
|
||||
ChatDatabase {chatStore, agentStore}
|
||||
user
|
||||
cfg@ChatConfig {agentConfig = aCfg, defaultServers, inlineFiles, deviceNameForRemote, confirmMigrations}
|
||||
cfg@ChatConfig {agentConfig = aCfg, presetServers, inlineFiles, deviceNameForRemote, confirmMigrations}
|
||||
ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, simpleNetCfg, logLevel, logConnections, logServerHosts, logFile, tbqSize, highlyAvailable, yesToUpMigrations}, deviceName, optFilesFolder, optTempDirectory, showReactions, allowInstantFiles, autoAcceptFileSize}
|
||||
backgroundMode = do
|
||||
let inlineFiles' = if allowInstantFiles || autoAcceptFileSize > 0 then inlineFiles else inlineFiles {sendChunks = 0, receiveInstant = False}
|
||||
confirmMigrations' = if confirmMigrations == MCConsole && yesToUpMigrations then MCYesUp else confirmMigrations
|
||||
config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, defaultServers = configServers, inlineFiles = inlineFiles', autoAcceptFileSize, highlyAvailable, confirmMigrations = confirmMigrations'}
|
||||
config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, presetServers = presetServers', inlineFiles = inlineFiles', autoAcceptFileSize, highlyAvailable, confirmMigrations = confirmMigrations'}
|
||||
firstTime = dbNew chatStore
|
||||
currentUser <- newTVarIO user
|
||||
randomSMP <- randomPresetServers SPSMP presetServers'
|
||||
randomXFTP <- randomPresetServers SPXFTP presetServers'
|
||||
let randomServers = RandomServers {smpServers = randomSMP, xftpServers = randomXFTP}
|
||||
currentRemoteHost <- newTVarIO Nothing
|
||||
servers <- agentServers config
|
||||
servers <- withTransaction chatStore $ \db -> agentServers db config randomServers
|
||||
smpAgent <- getSMPAgentClient aCfg {tbqSize} servers agentStore backgroundMode
|
||||
agentAsync <- newTVarIO Nothing
|
||||
random <- liftIO C.newRandom
|
||||
@@ -281,6 +348,7 @@ newChatController
|
||||
ChatController
|
||||
{ firstTime,
|
||||
currentUser,
|
||||
randomServers,
|
||||
currentRemoteHost,
|
||||
smpAgent,
|
||||
agentAsync,
|
||||
@@ -318,28 +386,41 @@ newChatController
|
||||
contactMergeEnabled
|
||||
}
|
||||
where
|
||||
configServers :: DefaultAgentServers
|
||||
configServers =
|
||||
let DefaultAgentServers {smp = defSmp, xftp = defXftp, netCfg} = defaultServers
|
||||
smp' = maybe defSmp (L.map enabledServerCfg) (nonEmpty smpServers)
|
||||
xftp' = maybe defXftp (L.map enabledServerCfg) (nonEmpty xftpServers)
|
||||
in defaultServers {smp = smp', xftp = xftp', netCfg = updateNetworkConfig netCfg simpleNetCfg}
|
||||
agentServers :: ChatConfig -> IO InitialAgentServers
|
||||
agentServers config@ChatConfig {defaultServers = defServers@DefaultAgentServers {ntf, netCfg}} = do
|
||||
users <- withTransaction chatStore getUsers
|
||||
smp' <- getUserServers users SPSMP
|
||||
xftp' <- getUserServers users SPXFTP
|
||||
presetServers' :: PresetServers
|
||||
presetServers' = presetServers {operators = operators', netCfg = netCfg'}
|
||||
where
|
||||
PresetServers {operators, netCfg} = presetServers
|
||||
netCfg' = updateNetworkConfig netCfg simpleNetCfg
|
||||
operators' = case (smpServers, xftpServers) of
|
||||
([], []) -> operators
|
||||
(smpSrvs, []) -> L.map disableSMP operators <> [custom smpSrvs []]
|
||||
([], xftpSrvs) -> L.map disableXFTP operators <> [custom [] xftpSrvs]
|
||||
(smpSrvs, xftpSrvs) -> [custom smpSrvs xftpSrvs]
|
||||
disableSMP op@PresetOperator {smp} = (op :: PresetOperator) {smp = map disableSrv smp}
|
||||
disableXFTP op@PresetOperator {xftp} = (op :: PresetOperator) {xftp = map disableSrv xftp}
|
||||
disableSrv :: forall p. NewUserServer p -> NewUserServer p
|
||||
disableSrv srv = (srv :: NewUserServer p) {enabled = False}
|
||||
custom smpSrvs xftpSrvs =
|
||||
PresetOperator
|
||||
{ operator = Nothing,
|
||||
smp = map newUserServer smpSrvs,
|
||||
useSMP = 0,
|
||||
xftp = map newUserServer xftpSrvs,
|
||||
useXFTP = 0
|
||||
}
|
||||
agentServers :: DB.Connection -> ChatConfig -> RandomServers -> IO InitialAgentServers
|
||||
agentServers db ChatConfig {presetServers = PresetServers {operators = presetOps, ntf, netCfg}} rs = do
|
||||
users <- getUsers db
|
||||
opDomains <- operatorDomains <$> getUpdateServerOperators db presetOps (null users)
|
||||
smp' <- getServers SPSMP users opDomains
|
||||
xftp' <- getServers SPXFTP users opDomains
|
||||
pure InitialAgentServers {smp = smp', xftp = xftp', ntf, netCfg}
|
||||
where
|
||||
getUserServers :: forall p. (ProtocolTypeI p, UserProtocol p) => [User] -> SProtocolType p -> IO (Map UserId (NonEmpty (ServerCfg p)))
|
||||
getUserServers users protocol = case users of
|
||||
[] -> pure $ M.fromList [(1, cfgServers protocol defServers)]
|
||||
_ -> M.fromList <$> initialServers
|
||||
where
|
||||
initialServers :: IO [(UserId, NonEmpty (ServerCfg p))]
|
||||
initialServers = mapM (\u -> (aUserId u,) <$> userServers u) users
|
||||
userServers :: User -> IO (NonEmpty (ServerCfg p))
|
||||
userServers user' = useServers config protocol <$> withTransaction chatStore (`getProtocolServers` user')
|
||||
getServers :: forall p. (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> [User] -> [(Text, ServerOperator)] -> IO (Map UserId (NonEmpty (ServerCfg p)))
|
||||
getServers p users opDomains = do
|
||||
let rs' = rndServers p rs
|
||||
fmap M.fromList $ forM users $ \u ->
|
||||
(aUserId u,) . agentServerCfgs opDomains rs' <$> getUpdateUserServers db p presetOps rs' u
|
||||
|
||||
updateNetworkConfig :: NetworkConfig -> SimpleNetCfg -> NetworkConfig
|
||||
updateNetworkConfig cfg SimpleNetCfg {socksProxy, socksMode, hostMode, requiredHostMode, smpProxyMode_, smpProxyFallback_, smpWebPort, tcpTimeout_, logTLSErrors} =
|
||||
@@ -382,33 +463,37 @@ withFileLock :: String -> Int64 -> CM a -> CM a
|
||||
withFileLock name = withEntityLock name . CLFile
|
||||
{-# INLINE withFileLock #-}
|
||||
|
||||
useServers :: UserProtocol p => ChatConfig -> SProtocolType p -> [ServerCfg p] -> NonEmpty (ServerCfg p)
|
||||
useServers ChatConfig {defaultServers} p = fromMaybe (cfgServers p defaultServers) . nonEmpty
|
||||
serverCfg :: ProtoServerWithAuth p -> ServerCfg p
|
||||
serverCfg server = ServerCfg {server, operator = Nothing, enabled = True, roles = allRoles}
|
||||
|
||||
randomServers :: forall p. UserProtocol p => SProtocolType p -> ChatConfig -> IO (NonEmpty (ServerCfg p), [ServerCfg p])
|
||||
randomServers p ChatConfig {defaultServers} = do
|
||||
let srvs = cfgServers p defaultServers
|
||||
(enbldSrvs, dsbldSrvs) = L.partition (\ServerCfg {enabled} -> enabled) srvs
|
||||
toUse = cfgServersToUse p defaultServers
|
||||
if length enbldSrvs <= toUse
|
||||
then pure (srvs, [])
|
||||
else do
|
||||
(enbldSrvs', srvsToDisable) <- splitAt toUse <$> shuffle enbldSrvs
|
||||
let dsbldSrvs' = map (\srv -> (srv :: ServerCfg p) {enabled = False}) srvsToDisable
|
||||
srvs' = sortOn server' $ enbldSrvs' <> dsbldSrvs' <> dsbldSrvs
|
||||
pure (fromMaybe srvs $ L.nonEmpty srvs', srvs')
|
||||
useServers :: forall p. UserProtocol p => SProtocolType p -> RandomServers -> [UserServer p] -> NonEmpty (NewUserServer p)
|
||||
useServers p rs servers = case L.nonEmpty servers of
|
||||
Nothing -> rndServers p rs
|
||||
Just srvs -> L.map (\srv -> (srv :: UserServer p) {serverId = DBNewEntity}) srvs
|
||||
|
||||
rndServers :: UserProtocol p => SProtocolType p -> RandomServers -> NonEmpty (NewUserServer p)
|
||||
rndServers p RandomServers {smpServers, xftpServers} = case p of
|
||||
SPSMP -> smpServers
|
||||
SPXFTP -> xftpServers
|
||||
|
||||
randomPresetServers :: forall p. UserProtocol p => SProtocolType p -> PresetServers -> IO (NonEmpty (NewUserServer p))
|
||||
randomPresetServers p PresetServers {operators} = toJust . L.nonEmpty . concat =<< mapM opSrvs operators
|
||||
where
|
||||
server' ServerCfg {server = ProtoServerWithAuth srv _} = srv
|
||||
|
||||
cfgServers :: UserProtocol p => SProtocolType p -> DefaultAgentServers -> NonEmpty (ServerCfg p)
|
||||
cfgServers p DefaultAgentServers {smp, xftp} = case p of
|
||||
SPSMP -> smp
|
||||
SPXFTP -> xftp
|
||||
|
||||
cfgServersToUse :: UserProtocol p => SProtocolType p -> DefaultAgentServers -> Int
|
||||
cfgServersToUse p DefaultAgentServers {useSMP, useXFTP} = case p of
|
||||
SPSMP -> useSMP
|
||||
SPXFTP -> useXFTP
|
||||
toJust = \case
|
||||
Just a -> pure a
|
||||
Nothing -> E.throwIO $ userError "no preset servers"
|
||||
opSrvs :: PresetOperator -> IO [NewUserServer p]
|
||||
opSrvs op = do
|
||||
let srvs = operatorServers p op
|
||||
toUse = operatorServersToUse p op
|
||||
(enbldSrvs, dsbldSrvs) = partition (\UserServer {enabled} -> enabled) srvs
|
||||
if toUse <= 0 || toUse >= length enbldSrvs
|
||||
then pure srvs
|
||||
else do
|
||||
(enbldSrvs', srvsToDisable) <- splitAt toUse <$> shuffle enbldSrvs
|
||||
let dsbldSrvs' = map (\srv -> (srv :: NewUserServer p) {enabled = False}) srvsToDisable
|
||||
pure $ sortOn server' $ enbldSrvs' <> dsbldSrvs' <> dsbldSrvs
|
||||
server' UserServer {server = ProtoServerWithAuth srv _} = srv
|
||||
|
||||
-- enableSndFiles has no effect when mainApp is True
|
||||
startChatController :: Bool -> Bool -> CM' (Async ())
|
||||
@@ -552,19 +637,24 @@ processChatCommand' vr = \case
|
||||
forM_ profile $ \Profile {displayName} -> checkValidName displayName
|
||||
p@Profile {displayName} <- liftIO $ maybe generateRandomProfile pure profile
|
||||
u <- asks currentUser
|
||||
(smp, smpServers) <- chooseServers SPSMP
|
||||
(xftp, xftpServers) <- chooseServers SPXFTP
|
||||
smpServers <- chooseServers SPSMP
|
||||
xftpServers <- chooseServers SPXFTP
|
||||
users <- withFastStore' getUsers
|
||||
forM_ users $ \User {localDisplayName = n, activeUser, viewPwdHash} ->
|
||||
when (n == displayName) . throwChatError $
|
||||
if activeUser || isNothing viewPwdHash then CEUserExists displayName else CEInvalidDisplayName {displayName, validName = ""}
|
||||
opDomains <- operatorDomains . fst <$> withFastStore getServerOperators
|
||||
rs <- asks randomServers
|
||||
let smp = agentServerCfgs opDomains (rndServers SPSMP rs) smpServers
|
||||
xftp = agentServerCfgs opDomains (rndServers SPXFTP rs) xftpServers
|
||||
auId <- withAgent (\a -> createUser a smp xftp)
|
||||
ts <- liftIO $ getCurrentTime >>= if pastTimestamp then coupleDaysAgo else pure
|
||||
user <- withFastStore $ \db -> createUserRecordAt db (AgentUserId auId) p True ts
|
||||
createPresetContactCards user `catchChatError` \_ -> pure ()
|
||||
withFastStore $ \db -> createNoteFolder db user
|
||||
storeServers user smpServers
|
||||
storeServers user xftpServers
|
||||
withFastStore $ \db -> do
|
||||
createNoteFolder db user
|
||||
liftIO $ mapM_ (insertProtocolServer db SPSMP user ts) $ useServers SPSMP rs smpServers
|
||||
liftIO $ mapM_ (insertProtocolServer db SPXFTP user ts) $ useServers SPXFTP rs xftpServers
|
||||
atomically . writeTVar u $ Just user
|
||||
pure $ CRActiveUser user
|
||||
where
|
||||
@@ -573,18 +663,10 @@ processChatCommand' vr = \case
|
||||
withFastStore $ \db -> do
|
||||
createContact db user simplexStatusContactProfile
|
||||
createContact db user simplexTeamContactProfile
|
||||
chooseServers :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> CM (NonEmpty (ServerCfg p), [ServerCfg p])
|
||||
chooseServers protocol =
|
||||
asks currentUser >>= readTVarIO >>= \case
|
||||
Nothing -> asks config >>= liftIO . randomServers protocol
|
||||
Just user -> chosenServers =<< withFastStore' (`getProtocolServers` user)
|
||||
where
|
||||
chosenServers servers = do
|
||||
cfg <- asks config
|
||||
pure (useServers cfg protocol servers, servers)
|
||||
storeServers user servers =
|
||||
unless (null servers) . withFastStore $
|
||||
\db -> overwriteProtocolServers db user servers
|
||||
chooseServers :: forall p. ProtocolTypeI p => SProtocolType p -> CM [UserServer p]
|
||||
chooseServers p = do
|
||||
srvs <- chatReadVar currentUser >>= mapM (\user -> withFastStore' $ \db -> getProtocolServers db p user)
|
||||
pure $ fromMaybe [] srvs
|
||||
coupleDaysAgo t = (`addUTCTime` t) . fromInteger . negate . (+ (2 * day)) <$> randomRIO (0, day)
|
||||
day = 86400
|
||||
ListUsers -> CRUsersList <$> withFastStore' getUsersInfo
|
||||
@@ -1482,25 +1564,80 @@ processChatCommand' vr = \case
|
||||
msgs <- lift $ withAgent' $ \a -> getConnectionMessages a acIds
|
||||
let ntfMsgs = L.map (\msg -> receivedMsgInfo <$> msg) msgs
|
||||
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)
|
||||
GetUserProtoServers aProtocol -> withUser $ \User {userId} ->
|
||||
processChatCommand $ APIGetUserProtoServers userId aProtocol
|
||||
APISetUserProtoServers userId (APSC p (ProtoServersConfig servers))
|
||||
| null servers || any (\ServerCfg {enabled} -> enabled) servers -> withUserId userId $ \user -> withServerProtocol p $ do
|
||||
withFastStore $ \db -> overwriteProtocolServers db user servers
|
||||
cfg <- asks config
|
||||
lift $ withAgent' $ \a -> setProtocolServers a (aUserId user) $ useServers cfg p servers
|
||||
ok user
|
||||
| otherwise -> withUserId userId $ \user -> pure $ chatCmdError (Just user) "all servers are disabled"
|
||||
SetUserProtoServers serversConfig -> withUser $ \User {userId} ->
|
||||
processChatCommand $ APISetUserProtoServers userId serversConfig
|
||||
GetUserProtoServers (AProtocolType p) -> withUser $ \user -> withServerProtocol p $ do
|
||||
(operators, smpServers, xftpServers) <- withFastStore (`getUserServers` user)
|
||||
userServers <- liftIO $ groupByOperator $ case p of
|
||||
SPSMP -> (operators, smpServers, [])
|
||||
SPXFTP -> (operators, [], xftpServers)
|
||||
pure $ CRUserServers user userServers
|
||||
SetUserProtoServers (AProtocolType (p :: SProtocolType p)) srvs -> withUser $ \user@User {userId} -> withServerProtocol p $ do
|
||||
srvs' <- mapM aUserServer srvs
|
||||
userServers_ <- liftIO . groupByOperator =<< withFastStore (`getUserServers` user)
|
||||
case L.nonEmpty userServers_ of
|
||||
Nothing -> throwChatError $ CECommandError "no servers"
|
||||
Just userServers -> case srvs of
|
||||
[] -> throwChatError $ CECommandError "no servers"
|
||||
_ -> processChatCommand $ APISetUserServers userId $ L.map updatedSrvs userServers
|
||||
where
|
||||
-- disable preset and replace custom servers (groupByOperator always adds custom)
|
||||
updatedSrvs UserOperatorServers {operator, smpServers, xftpServers} = case p of
|
||||
SPSMP -> u (updateSrvs smpServers, map (AUS SDBStored) xftpServers)
|
||||
SPXFTP -> u (map (AUS SDBStored) smpServers, updateSrvs xftpServers)
|
||||
where
|
||||
u = uncurry $ UpdatedUserOperatorServers operator
|
||||
updateSrvs :: [UserServer p] -> [AUserServer p]
|
||||
updateSrvs pSrvs = map disableSrv pSrvs <> maybe srvs' (const []) operator
|
||||
disableSrv srv@UserServer {preset} =
|
||||
AUS SDBStored $ if preset then srv {enabled = False} else srv {deleted = True}
|
||||
where
|
||||
aUserServer :: AProtoServerWithAuth -> CM (AUserServer p)
|
||||
aUserServer (AProtoServerWithAuth p' srv) = case testEquality p p' of
|
||||
Just Refl -> pure $ AUS SDBNew $ newUserServer srv
|
||||
Nothing -> throwChatError $ CECommandError $ "incorrect server protocol: " <> B.unpack (strEncode srv)
|
||||
APITestProtoServer userId srv@(AProtoServerWithAuth _ server) -> withUserId userId $ \user ->
|
||||
lift $ CRServerTestResult user srv <$> withAgent' (\a -> testProtocolServer a (aUserId user) server)
|
||||
TestProtoServer srv -> withUser $ \User {userId} ->
|
||||
processChatCommand $ APITestProtoServer userId srv
|
||||
APIGetServerOperators -> uncurry CRServerOperators <$> withFastStore getServerOperators
|
||||
APISetServerOperators operatorsEnabled -> withFastStore $ \db -> do
|
||||
liftIO $ setServerOperators db operatorsEnabled
|
||||
uncurry CRServerOperators <$> getServerOperators db
|
||||
APIGetUserServers userId -> withUserId userId $ \user -> withFastStore $ \db ->
|
||||
CRUserServers user <$> (liftIO . groupByOperator =<< getUserServers db user)
|
||||
APISetUserServers userId userServers -> withUserId userId $ \user -> do
|
||||
let errors = validateUserServers userServers
|
||||
unless (null errors) $ throwChatError (CECommandError $ "user servers validation error(s): " <> show errors)
|
||||
(operators, smpServers, xftpServers) <- withFastStore $ \db -> do
|
||||
setUserServers db user userServers
|
||||
getUserServers db user
|
||||
let opDomains = operatorDomains operators
|
||||
rs <- asks randomServers
|
||||
lift $ withAgent' $ \a -> do
|
||||
let auId = aUserId user
|
||||
setProtocolServers a auId $ agentServerCfgs opDomains (rndServers SPSMP rs) smpServers
|
||||
setProtocolServers a auId $ agentServerCfgs opDomains (rndServers SPXFTP rs) xftpServers
|
||||
ok_
|
||||
APIValidateServers userServers -> pure $ CRUserServersValidation $ validateUserServers userServers
|
||||
APIGetUsageConditions -> do
|
||||
(usageConditions, acceptedConditions) <- withFastStore $ \db -> do
|
||||
usageConditions <- getCurrentUsageConditions db
|
||||
acceptedConditions <- liftIO $ getLatestAcceptedConditions db
|
||||
pure (usageConditions, acceptedConditions)
|
||||
-- TODO if db commit is different from source commit, conditionsText should be nothing in response
|
||||
pure
|
||||
CRUsageConditions
|
||||
{ usageConditions,
|
||||
conditionsText = usageConditionsText,
|
||||
acceptedConditions
|
||||
}
|
||||
APISetConditionsNotified condId -> do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
withFastStore' $ \db -> setConditionsNotified db condId currentTs
|
||||
ok_
|
||||
APIAcceptConditions condId opIds -> withFastStore $ \db -> do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
acceptConditions db condId opIds currentTs
|
||||
uncurry CRServerOperators <$> getServerOperators db
|
||||
APISetChatItemTTL userId newTTL_ -> withUserId userId $ \user ->
|
||||
checkStoreNotChanged $
|
||||
withChatLock "setChatItemTTL" $ do
|
||||
@@ -1753,8 +1890,9 @@ processChatCommand' vr = \case
|
||||
canKeepLink (CRInvitationUri crData _) newUser = do
|
||||
let ConnReqUriData {crSmpQueues = q :| _} = crData
|
||||
SMPQueueUri {queueAddress = SMPQueueAddress {smpServer}} = q
|
||||
cfg <- asks config
|
||||
newUserServers <- L.map (\ServerCfg {server} -> protoServer server) . useServers cfg SPSMP <$> withFastStore' (`getProtocolServers` newUser)
|
||||
newUserServers <-
|
||||
map protoServer' . filter (\ServerCfg {enabled} -> enabled)
|
||||
<$> getKnownAgentServers SPSMP newUser
|
||||
pure $ smpServer `elem` newUserServers
|
||||
updateConnRecord user@User {userId} conn@PendingContactConnection {customUserProfileId} newUser = do
|
||||
withAgent $ \a -> changeConnectionUser a (aUserId user) (aConnId' conn) (aUserId newUser)
|
||||
@@ -2088,7 +2226,7 @@ processChatCommand' vr = \case
|
||||
where
|
||||
changeMemberRole user gInfo members m gEvent = do
|
||||
let GroupMember {memberId = mId, memberRole = mRole, memberStatus = mStatus, memberContactId, localDisplayName = cName} = m
|
||||
assertUserGroupRole gInfo $ maximum [GRAdmin, mRole, memRole]
|
||||
assertUserGroupRole gInfo $ maximum ([GRAdmin, mRole, memRole] :: [GroupMemberRole])
|
||||
withGroupLock "memberRole" groupId . procCmd $ do
|
||||
unless (mRole == memRole) $ do
|
||||
withFastStore' $ \db -> updateGroupMemberRole db user m memRole
|
||||
@@ -2486,14 +2624,15 @@ processChatCommand' vr = \case
|
||||
pure $ CRAgentSubsTotal user subsTotal hasSession
|
||||
GetAgentServersSummary userId -> withUserId userId $ \user -> do
|
||||
agentServersSummary <- lift $ withAgent' getAgentServersSummary
|
||||
cfg <- asks config
|
||||
(users, smpServers, xftpServers) <-
|
||||
withStore' $ \db -> (,,) <$> getUsers db <*> getServers db cfg user SPSMP <*> getServers db cfg user SPXFTP
|
||||
let presentedServersSummary = toPresentedServersSummary agentServersSummary users user smpServers xftpServers _defaultNtfServers
|
||||
pure $ CRAgentServersSummary user presentedServersSummary
|
||||
withStore' $ \db -> do
|
||||
users <- getUsers db
|
||||
smpServers <- getServers db user SPSMP
|
||||
xftpServers <- getServers db user SPXFTP
|
||||
let presentedServersSummary = toPresentedServersSummary agentServersSummary users user smpServers xftpServers _defaultNtfServers
|
||||
pure $ CRAgentServersSummary user presentedServersSummary
|
||||
where
|
||||
getServers :: (ProtocolTypeI p, UserProtocol p) => DB.Connection -> ChatConfig -> User -> SProtocolType p -> IO (NonEmpty (ProtocolServer p))
|
||||
getServers db cfg user p = L.map (\ServerCfg {server} -> protoServer server) . useServers cfg p <$> getProtocolServers db user
|
||||
getServers :: ProtocolTypeI p => DB.Connection -> User -> SProtocolType p -> IO [ProtocolServer p]
|
||||
getServers db user p = map (\UserServer {server} -> protoServer server) <$> getProtocolServers db p user
|
||||
ResetAgentServersStats -> withAgent resetAgentServersStats >> ok_
|
||||
GetAgentWorkers -> lift $ CRAgentWorkersSummary <$> withAgent' getAgentWorkersSummary
|
||||
GetAgentWorkersDetails -> lift $ CRAgentWorkersDetails <$> withAgent' getAgentWorkersDetails
|
||||
@@ -3611,8 +3750,7 @@ receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete}
|
||||
S.toList $ S.fromList $ concatMap (\FD.FileChunk {replicas} -> map (\FD.FileChunkReplica {server} -> server) replicas) chunks
|
||||
getUnknownSrvs :: [XFTPServer] -> CM [XFTPServer]
|
||||
getUnknownSrvs srvs = do
|
||||
cfg <- asks config
|
||||
knownSrvs <- L.map (\ServerCfg {server} -> protoServer server) . useServers cfg SPXFTP <$> withStore' (`getProtocolServers` user)
|
||||
knownSrvs <- map protoServer' <$> getKnownAgentServers SPXFTP user
|
||||
pure $ filter (`notElem` knownSrvs) srvs
|
||||
ipProtectedForSrvs :: [XFTPServer] -> CM Bool
|
||||
ipProtectedForSrvs srvs = do
|
||||
@@ -3626,6 +3764,17 @@ receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete}
|
||||
toView $ CRChatItemUpdated user aci
|
||||
throwChatError $ CEFileNotApproved fileId unknownSrvs
|
||||
|
||||
getKnownAgentServers :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> User -> CM [ServerCfg p]
|
||||
getKnownAgentServers p user = do
|
||||
rs <- asks randomServers
|
||||
withStore $ \db -> do
|
||||
opDomains <- operatorDomains . fst <$> getServerOperators db
|
||||
srvs <- liftIO $ getProtocolServers db p user
|
||||
pure $ L.toList $ agentServerCfgs opDomains (rndServers p rs) srvs
|
||||
|
||||
protoServer' :: ServerCfg p -> ProtocolServer p
|
||||
protoServer' ServerCfg {server} = protoServer server
|
||||
|
||||
getNetworkConfig :: CM' NetworkConfig
|
||||
getNetworkConfig = withAgent' $ liftIO . getFastNetworkConfig
|
||||
|
||||
@@ -3824,7 +3973,7 @@ subscribeUserConnections vr onlyNeeded agentBatchSubscribe user = do
|
||||
(sftConns, sfts) <- getSndFileTransferConns
|
||||
(rftConns, rfts) <- getRcvFileTransferConns
|
||||
(pcConns, pcs) <- getPendingContactConns
|
||||
let conns = concat [ctConns, ucConns, mConns, sftConns, rftConns, pcConns]
|
||||
let conns = concat ([ctConns, ucConns, mConns, sftConns, rftConns, pcConns] :: [[ConnId]])
|
||||
pure (conns, cts, ucs, gs, ms, sfts, rfts, pcs)
|
||||
-- subscribe using batched commands
|
||||
rs <- withAgent $ \a -> agentBatchSubscribe a conns
|
||||
@@ -4632,7 +4781,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
ctItem = AChatItem SCTDirect SMDSnd (DirectChat ct)
|
||||
SWITCH qd phase cStats -> do
|
||||
toView $ CRContactSwitch user ct (SwitchProgress qd phase cStats)
|
||||
when (phase `elem` [SPStarted, SPCompleted]) $ case qd of
|
||||
when (phase == SPStarted || phase == SPCompleted) $ case qd of
|
||||
QDRcv -> createInternalChatItem user (CDDirectSnd ct) (CISndConnEvent $ SCESwitchQueue phase Nothing) Nothing
|
||||
QDSnd -> createInternalChatItem user (CDDirectRcv ct) (CIRcvConnEvent $ RCESwitchQueue phase) Nothing
|
||||
RSYNC rss cryptoErr_ cStats ->
|
||||
@@ -4917,7 +5066,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
(Just fileDescrText, Just msgId) -> do
|
||||
partSize <- asks $ xftpDescrPartSize . config
|
||||
let parts = splitFileDescr partSize fileDescrText
|
||||
pure . toList $ L.map (XMsgFileDescr msgId) parts
|
||||
pure . L.toList $ L.map (XMsgFileDescr msgId) parts
|
||||
_ -> pure []
|
||||
let fileDescrChatMsgs = map (ChatMessage senderVRange Nothing) fileDescrEvents
|
||||
GroupMember {memberId} = sender
|
||||
@@ -5043,7 +5192,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
when continued $ sendPendingGroupMessages user m conn
|
||||
SWITCH qd phase cStats -> do
|
||||
toView $ CRGroupMemberSwitch user gInfo m (SwitchProgress qd phase cStats)
|
||||
when (phase `elem` [SPStarted, SPCompleted]) $ case qd of
|
||||
when (phase == SPStarted || phase == SPCompleted) $ case qd of
|
||||
QDRcv -> createInternalChatItem user (CDGroupSnd gInfo) (CISndConnEvent . SCESwitchQueue phase . Just $ groupMemberRef m) Nothing
|
||||
QDSnd -> createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvConnEvent $ RCESwitchQueue phase) Nothing
|
||||
RSYNC rss cryptoErr_ cStats ->
|
||||
@@ -6607,15 +6756,17 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
messageWarning "x.grp.mem.con: neither member is invitee"
|
||||
where
|
||||
inviteeXGrpMemCon :: GroupMemberIntro -> CM ()
|
||||
inviteeXGrpMemCon GroupMemberIntro {introId, introStatus}
|
||||
| introStatus == GMIntroReConnected = updateStatus introId GMIntroConnected
|
||||
| introStatus `elem` [GMIntroToConnected, GMIntroConnected] = pure ()
|
||||
| otherwise = updateStatus introId GMIntroToConnected
|
||||
inviteeXGrpMemCon GroupMemberIntro {introId, introStatus} = case introStatus of
|
||||
GMIntroReConnected -> updateStatus introId GMIntroConnected
|
||||
GMIntroToConnected -> pure ()
|
||||
GMIntroConnected -> pure ()
|
||||
_ -> updateStatus introId GMIntroToConnected
|
||||
forwardMemberXGrpMemCon :: GroupMemberIntro -> CM ()
|
||||
forwardMemberXGrpMemCon GroupMemberIntro {introId, introStatus}
|
||||
| introStatus == GMIntroToConnected = updateStatus introId GMIntroConnected
|
||||
| introStatus `elem` [GMIntroReConnected, GMIntroConnected] = pure ()
|
||||
| otherwise = updateStatus introId GMIntroReConnected
|
||||
forwardMemberXGrpMemCon GroupMemberIntro {introId, introStatus} = case introStatus of
|
||||
GMIntroToConnected -> updateStatus introId GMIntroConnected
|
||||
GMIntroReConnected -> pure ()
|
||||
GMIntroConnected -> pure ()
|
||||
_ -> updateStatus introId GMIntroReConnected
|
||||
updateStatus introId status = withStore' $ \db -> updateIntroStatus db introId status
|
||||
|
||||
xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> RcvMessage -> UTCTime -> CM ()
|
||||
@@ -8080,14 +8231,18 @@ chatCommandP =
|
||||
"/smp test " *> (TestProtoServer . AProtoServerWithAuth SPSMP <$> strP),
|
||||
"/xftp test " *> (TestProtoServer . AProtoServerWithAuth SPXFTP <$> strP),
|
||||
"/ntf test " *> (TestProtoServer . AProtoServerWithAuth SPNTF <$> strP),
|
||||
"/_servers " *> (APISetUserProtoServers <$> A.decimal <* A.space <*> srvCfgP),
|
||||
"/smp " *> (SetUserProtoServers . APSC SPSMP . ProtoServersConfig . map enabledServerCfg <$> protocolServersP),
|
||||
"/smp default" $> SetUserProtoServers (APSC SPSMP $ ProtoServersConfig []),
|
||||
"/xftp " *> (SetUserProtoServers . APSC SPXFTP . ProtoServersConfig . map enabledServerCfg <$> protocolServersP),
|
||||
"/xftp default" $> SetUserProtoServers (APSC SPXFTP $ ProtoServersConfig []),
|
||||
"/_servers " *> (APIGetUserProtoServers <$> A.decimal <* A.space <*> strP),
|
||||
"/smp " *> (SetUserProtoServers (AProtocolType SPSMP) . map (AProtoServerWithAuth SPSMP) <$> protocolServersP),
|
||||
"/xftp " *> (SetUserProtoServers (AProtocolType SPXFTP) . map (AProtoServerWithAuth SPXFTP) <$> protocolServersP),
|
||||
"/smp" $> GetUserProtoServers (AProtocolType SPSMP),
|
||||
"/xftp" $> GetUserProtoServers (AProtocolType SPXFTP),
|
||||
"/_operators" $> APIGetServerOperators,
|
||||
"/_operators " *> (APISetServerOperators <$> jsonP),
|
||||
"/_servers " *> (APIGetUserServers <$> A.decimal),
|
||||
"/_servers " *> (APISetUserServers <$> A.decimal <* A.space <*> jsonP),
|
||||
"/_validate_servers " *> (APIValidateServers <$> jsonP),
|
||||
"/_conditions" $> APIGetUsageConditions,
|
||||
"/_conditions_notified " *> (APISetConditionsNotified <$> A.decimal),
|
||||
"/_accept_conditions " *> (APIAcceptConditions <$> A.decimal <*> _strP),
|
||||
"/_ttl " *> (APISetChatItemTTL <$> A.decimal <* A.space <*> ciTTLDecimal),
|
||||
"/ttl " *> (SetChatItemTTL <$> ciTTL),
|
||||
"/_ttl " *> (APIGetChatItemTTL <$> A.decimal),
|
||||
@@ -8429,7 +8584,7 @@ chatCommandP =
|
||||
onOffP
|
||||
(Just <$> (AutoAccept <$> (" incognito=" *> onOffP <|> pure False) <*> optional (A.space *> msgContentP)))
|
||||
(pure Nothing)
|
||||
srvCfgP = strP >>= \case AProtocolType p -> APSC p <$> (A.space *> jsonP)
|
||||
-- srvCfgP = strP >>= \case AProtocolType p -> APSC p <$> (A.space *> jsonP)
|
||||
rcCtrlAddressP = RCCtrlAddress <$> ("addr=" *> strP) <*> (" iface=" *> (jsonP <|> text1P))
|
||||
text1P = safeDecodeUtf8 <$> A.takeTill (== ' ')
|
||||
char_ = optional . A.char
|
||||
|
||||
@@ -35,7 +35,6 @@ import qualified Data.ByteArray as BA
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Char (ord)
|
||||
import Data.Constraint (Dict (..))
|
||||
import Data.Int (Int64)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Map.Strict (Map)
|
||||
@@ -57,6 +56,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 +70,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)
|
||||
import Simplex.Messaging.Agent.Lock
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation, SQLiteStore, UpMigration, withTransaction, withTransactionPriority)
|
||||
@@ -84,7 +84,7 @@ import Simplex.Messaging.Crypto.Ratchet (PQEncryption)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfTknStatus)
|
||||
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, parseAll, parseString, sumTypeJSON)
|
||||
import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType (..), CorrId, MsgId, NMsgMeta (..), NtfServer, ProtocolType (..), ProtocolTypeI, QueueId, SMPMsgMeta (..), SProtocolType, SubscriptionMode (..), UserProtocol, XFTPServer, userProtocol)
|
||||
import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType (..), CorrId, MsgId, NMsgMeta (..), NtfServer, ProtocolType (..), QueueId, SMPMsgMeta (..), SubscriptionMode (..), XFTPServer)
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import Simplex.Messaging.Transport (TLS, simplexMQVersion)
|
||||
import Simplex.Messaging.Transport.Client (SocksProxyWithAuth, TransportHost)
|
||||
@@ -132,7 +132,7 @@ data ChatConfig = ChatConfig
|
||||
{ agentConfig :: AgentConfig,
|
||||
chatVRange :: VersionRangeChat,
|
||||
confirmMigrations :: MigrationConfirmation,
|
||||
defaultServers :: DefaultAgentServers,
|
||||
presetServers :: PresetServers,
|
||||
tbqSize :: Natural,
|
||||
fileChunkSize :: Integer,
|
||||
xftpDescrPartSize :: Int,
|
||||
@@ -154,6 +154,12 @@ data ChatConfig = ChatConfig
|
||||
chatHooks :: ChatHooks
|
||||
}
|
||||
|
||||
data RandomServers = RandomServers
|
||||
{ smpServers :: NonEmpty (NewUserServer 'PSMP),
|
||||
xftpServers :: NonEmpty (NewUserServer 'PXFTP)
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- The hooks can be used to extend or customize chat core in mobile or CLI clients.
|
||||
data ChatHooks = ChatHooks
|
||||
{ -- preCmdHook can be used to process or modify the commands before they are processed.
|
||||
@@ -172,12 +178,9 @@ defaultChatHooks =
|
||||
eventHook = \_ -> pure
|
||||
}
|
||||
|
||||
data DefaultAgentServers = DefaultAgentServers
|
||||
{ smp :: NonEmpty (ServerCfg 'PSMP),
|
||||
useSMP :: Int,
|
||||
data PresetServers = PresetServers
|
||||
{ operators :: NonEmpty PresetOperator,
|
||||
ntf :: [NtfServer],
|
||||
xftp :: NonEmpty (ServerCfg 'PXFTP),
|
||||
useXFTP :: Int,
|
||||
netCfg :: NetworkConfig
|
||||
}
|
||||
|
||||
@@ -203,6 +206,7 @@ data ChatDatabase = ChatDatabase {chatStore :: SQLiteStore, agentStore :: SQLite
|
||||
|
||||
data ChatController = ChatController
|
||||
{ currentUser :: TVar (Maybe User),
|
||||
randomServers :: RandomServers,
|
||||
currentRemoteHost :: TVar (Maybe RemoteHostId),
|
||||
firstTime :: Bool,
|
||||
smpAgent :: AgentClient,
|
||||
@@ -346,12 +350,18 @@ data ChatCommand
|
||||
| APIGetGroupLink GroupId
|
||||
| APICreateMemberContact GroupId GroupMemberId
|
||||
| APISendMemberContactInvitation {contactId :: ContactId, msgContent_ :: Maybe MsgContent}
|
||||
| APIGetUserProtoServers UserId AProtocolType
|
||||
| GetUserProtoServers AProtocolType
|
||||
| APISetUserProtoServers UserId AProtoServersConfig
|
||||
| SetUserProtoServers AProtoServersConfig
|
||||
| SetUserProtoServers AProtocolType [AProtoServerWithAuth]
|
||||
| APITestProtoServer UserId AProtoServerWithAuth
|
||||
| TestProtoServer AProtoServerWithAuth
|
||||
| APIGetServerOperators
|
||||
| APISetServerOperators (NonEmpty ServerOperator)
|
||||
| APIGetUserServers UserId
|
||||
| APISetUserServers UserId (NonEmpty UpdatedUserOperatorServers)
|
||||
| APIValidateServers (NonEmpty UpdatedUserOperatorServers) -- response is CRUserServersValidation
|
||||
| APIGetUsageConditions
|
||||
| APISetConditionsNotified Int64
|
||||
| APIAcceptConditions Int64 (NonEmpty Int64)
|
||||
| APISetChatItemTTL UserId (Maybe Int64)
|
||||
| SetChatItemTTL (Maybe Int64)
|
||||
| APIGetChatItemTTL UserId
|
||||
@@ -577,8 +587,11 @@ data ChatResponse
|
||||
| CRChatItemInfo {user :: User, chatItem :: AChatItem, chatItemInfo :: ChatItemInfo}
|
||||
| CRChatItemId User (Maybe ChatItemId)
|
||||
| CRApiParsedMarkdown {formattedText :: Maybe MarkdownList}
|
||||
| CRUserProtoServers {user :: User, servers :: AUserProtoServers}
|
||||
| CRServerTestResult {user :: User, testServer :: AProtoServerWithAuth, testFailure :: Maybe ProtocolTestFailure}
|
||||
| CRServerOperators {operators :: [ServerOperator], conditionsAction :: Maybe UsageConditionsAction}
|
||||
| CRUserServers {user :: User, userServers :: [UserOperatorServers]}
|
||||
| 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}
|
||||
@@ -941,23 +954,23 @@ instance ToJSON AgentQueueId where
|
||||
toJSON = strToJSON
|
||||
toEncoding = strToJEncoding
|
||||
|
||||
data ProtoServersConfig p = ProtoServersConfig {servers :: [ServerCfg p]}
|
||||
deriving (Show)
|
||||
-- data ProtoServersConfig p = ProtoServersConfig {servers :: [ServerCfg p]}
|
||||
-- deriving (Show)
|
||||
|
||||
data AProtoServersConfig = forall p. ProtocolTypeI p => APSC (SProtocolType p) (ProtoServersConfig p)
|
||||
-- data AProtoServersConfig = forall p. ProtocolTypeI p => APSC (SProtocolType p) (ProtoServersConfig p)
|
||||
|
||||
deriving instance Show AProtoServersConfig
|
||||
-- deriving instance Show AProtoServersConfig
|
||||
|
||||
data UserProtoServers p = UserProtoServers
|
||||
{ serverProtocol :: SProtocolType p,
|
||||
protoServers :: NonEmpty (ServerCfg p),
|
||||
presetServers :: NonEmpty (ServerCfg p)
|
||||
}
|
||||
deriving (Show)
|
||||
-- data UserProtoServers p = UserProtoServers
|
||||
-- { serverProtocol :: SProtocolType p,
|
||||
-- protoServers :: NonEmpty (ServerCfg p),
|
||||
-- presetServers :: NonEmpty (ServerCfg p)
|
||||
-- }
|
||||
-- deriving (Show)
|
||||
|
||||
data AUserProtoServers = forall p. (ProtocolTypeI p, UserProtocol p) => AUPS (UserProtoServers p)
|
||||
-- data AUserProtoServers = forall p. (ProtocolTypeI p, UserProtocol p) => AUPS (UserProtoServers p)
|
||||
|
||||
deriving instance Show AUserProtoServers
|
||||
-- deriving instance Show AUserProtoServers
|
||||
|
||||
data ArchiveConfig = ArchiveConfig {archivePath :: FilePath, disableCompression :: Maybe Bool, parentTempDirectory :: Maybe FilePath}
|
||||
deriving (Show)
|
||||
@@ -1560,28 +1573,28 @@ $(JQ.deriveJSON defaultJSON ''CoreVersionInfo)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''SlowSQLQuery)
|
||||
|
||||
instance ProtocolTypeI p => FromJSON (ProtoServersConfig p) where
|
||||
parseJSON = $(JQ.mkParseJSON defaultJSON ''ProtoServersConfig)
|
||||
-- instance ProtocolTypeI p => FromJSON (ProtoServersConfig p) where
|
||||
-- parseJSON = $(JQ.mkParseJSON defaultJSON ''ProtoServersConfig)
|
||||
|
||||
instance ProtocolTypeI p => FromJSON (UserProtoServers p) where
|
||||
parseJSON = $(JQ.mkParseJSON defaultJSON ''UserProtoServers)
|
||||
-- instance ProtocolTypeI p => FromJSON (UserProtoServers p) where
|
||||
-- parseJSON = $(JQ.mkParseJSON defaultJSON ''UserProtoServers)
|
||||
|
||||
instance ProtocolTypeI p => ToJSON (UserProtoServers p) where
|
||||
toJSON = $(JQ.mkToJSON defaultJSON ''UserProtoServers)
|
||||
toEncoding = $(JQ.mkToEncoding defaultJSON ''UserProtoServers)
|
||||
-- instance ProtocolTypeI p => ToJSON (UserProtoServers p) where
|
||||
-- toJSON = $(JQ.mkToJSON defaultJSON ''UserProtoServers)
|
||||
-- toEncoding = $(JQ.mkToEncoding defaultJSON ''UserProtoServers)
|
||||
|
||||
instance FromJSON AUserProtoServers where
|
||||
parseJSON v = J.withObject "AUserProtoServers" parse v
|
||||
where
|
||||
parse o = do
|
||||
AProtocolType (p :: SProtocolType p) <- o .: "serverProtocol"
|
||||
case userProtocol p of
|
||||
Just Dict -> AUPS <$> J.parseJSON @(UserProtoServers p) v
|
||||
Nothing -> fail $ "AUserProtoServers: unsupported protocol " <> show p
|
||||
-- instance FromJSON AUserProtoServers where
|
||||
-- parseJSON v = J.withObject "AUserProtoServers" parse v
|
||||
-- where
|
||||
-- parse o = do
|
||||
-- AProtocolType (p :: SProtocolType p) <- o .: "serverProtocol"
|
||||
-- case userProtocol p of
|
||||
-- Just Dict -> AUPS <$> J.parseJSON @(UserProtoServers p) v
|
||||
-- Nothing -> fail $ "AUserProtoServers: unsupported protocol " <> show p
|
||||
|
||||
instance ToJSON AUserProtoServers where
|
||||
toJSON (AUPS s) = $(JQ.mkToJSON defaultJSON ''UserProtoServers) s
|
||||
toEncoding (AUPS s) = $(JQ.mkToEncoding defaultJSON ''UserProtoServers) s
|
||||
-- instance ToJSON AUserProtoServers where
|
||||
-- toJSON (AUPS s) = $(JQ.mkToJSON defaultJSON ''UserProtoServers) s
|
||||
-- toEncoding (AUPS s) = $(JQ.mkToEncoding defaultJSON ''UserProtoServers) s
|
||||
|
||||
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RCS") ''RemoteCtrlSessionState)
|
||||
|
||||
|
||||
@@ -0,0 +1,54 @@
|
||||
{-# 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,
|
||||
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 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(conditions_commit, server_operator_id);
|
||||
|]
|
||||
|
||||
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 TABLE operator_usage_conditions;
|
||||
DROP TABLE usage_conditions;
|
||||
DROP TABLE server_operators;
|
||||
|]
|
||||
@@ -589,6 +589,33 @@ 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,
|
||||
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 +917,10 @@ 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_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(
|
||||
conditions_commit,
|
||||
server_operator_id
|
||||
);
|
||||
|
||||
@@ -0,0 +1,438 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module Simplex.Chat.Operators where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
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.Foldable (foldMap')
|
||||
import Data.IORef
|
||||
import Data.Int (Int64)
|
||||
import Data.List (find, foldl')
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (fromMaybe, isNothing, mapMaybe)
|
||||
import Data.Scientific (floatingOrInteger)
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as S
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time (addUTCTime)
|
||||
import Data.Time.Clock (UTCTime, nominalDay)
|
||||
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 (ServerCfg (..), ServerRoles (..), allRoles)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, sumTypeJSON)
|
||||
import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), ProtocolTypeI, SProtocolType (..), UserProtocol)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost (..))
|
||||
import Simplex.Messaging.Util (atomicModifyIORef'_, safeDecodeUtf8)
|
||||
|
||||
usageConditionsCommit :: Text
|
||||
usageConditionsCommit = "165143a1112308c035ac00ed669b96b60599aa1c"
|
||||
|
||||
previousConditionsCommit :: Text
|
||||
previousConditionsCommit = "edf99fcd1d7d38d2501d19608b94c084cf00f2ac"
|
||||
|
||||
usageConditionsText :: Text
|
||||
usageConditionsText =
|
||||
$( let s = $(embedFile =<< makeRelativeToProject "PRIVACY.md")
|
||||
in [|stripFrontMatter $(lift (safeDecodeUtf8 s))|]
|
||||
)
|
||||
|
||||
data DBStored = DBStored | DBNew
|
||||
|
||||
data SDBStored (s :: DBStored) where
|
||||
SDBStored :: SDBStored 'DBStored
|
||||
SDBNew :: SDBStored 'DBNew
|
||||
|
||||
deriving instance Show (SDBStored s)
|
||||
|
||||
class DBStoredI s where sdbStored :: SDBStored s
|
||||
|
||||
instance DBStoredI 'DBStored where sdbStored = SDBStored
|
||||
|
||||
instance DBStoredI 'DBNew where sdbStored = SDBNew
|
||||
|
||||
data DBEntityId' (s :: DBStored) where
|
||||
DBEntityId :: Int64 -> DBEntityId' 'DBStored
|
||||
DBNewEntity :: DBEntityId' 'DBNew
|
||||
|
||||
deriving instance Show (DBEntityId' s)
|
||||
|
||||
type DBEntityId = DBEntityId' 'DBStored
|
||||
|
||||
type DBNewEntity = DBEntityId' 'DBNew
|
||||
|
||||
data OperatorTag = OTSimplex | OTXyz
|
||||
deriving (Eq, Ord, 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"
|
||||
|
||||
-- this and other types only define instances of serialization for known DB IDs only,
|
||||
-- entities without IDs cannot be serialized to JSON
|
||||
instance FromField DBEntityId where fromField f = DBEntityId <$> fromField f
|
||||
|
||||
instance ToField DBEntityId where toField (DBEntityId i) = toField i
|
||||
|
||||
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)
|
||||
|
||||
usageConditionsAction :: [ServerOperator] -> UsageConditions -> UTCTime -> Maybe UsageConditionsAction
|
||||
usageConditionsAction operators UsageConditions {createdAt, notifiedAt} now = do
|
||||
let enabledOperators = filter (\ServerOperator {enabled} -> enabled) operators
|
||||
if
|
||||
| null enabledOperators -> Nothing
|
||||
| all conditionsAccepted enabledOperators ->
|
||||
let acceptedForOperators = filter conditionsAccepted operators
|
||||
in Just $ UCAAccepted acceptedForOperators
|
||||
| otherwise ->
|
||||
let acceptForOperators = filter (not . conditionsAccepted) enabledOperators
|
||||
deadline = conditionsRequiredOrDeadline createdAt (fromMaybe now notifiedAt)
|
||||
showNotice = isNothing notifiedAt
|
||||
in Just $ UCAReview acceptForOperators deadline showNotice
|
||||
|
||||
conditionsRequiredOrDeadline :: UTCTime -> UTCTime -> Maybe UTCTime
|
||||
conditionsRequiredOrDeadline createdAt notifiedAtOrNow =
|
||||
if notifiedAtOrNow < addUTCTime (14 * nominalDay) createdAt
|
||||
then Just $ conditionsDeadline notifiedAtOrNow
|
||||
else Nothing -- required
|
||||
where
|
||||
conditionsDeadline :: UTCTime -> UTCTime
|
||||
conditionsDeadline = addUTCTime (31 * nominalDay)
|
||||
|
||||
data ConditionsAcceptance
|
||||
= CAAccepted {acceptedAt :: Maybe UTCTime}
|
||||
| CARequired {deadline :: Maybe UTCTime}
|
||||
deriving (Show)
|
||||
|
||||
type ServerOperator = ServerOperator' 'DBStored
|
||||
|
||||
type NewServerOperator = ServerOperator' 'DBNew
|
||||
|
||||
data AServerOperator = forall s. ASO (SDBStored s) (ServerOperator' s)
|
||||
|
||||
deriving instance Show AServerOperator
|
||||
|
||||
data ServerOperator' s = ServerOperator
|
||||
{ operatorId :: DBEntityId' s,
|
||||
operatorTag :: Maybe OperatorTag,
|
||||
tradeName :: Text,
|
||||
legalName :: Maybe Text,
|
||||
serverDomains :: [Text],
|
||||
conditionsAcceptance :: ConditionsAcceptance,
|
||||
enabled :: Bool,
|
||||
roles :: ServerRoles
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
conditionsAccepted :: ServerOperator -> Bool
|
||||
conditionsAccepted ServerOperator {conditionsAcceptance} = case conditionsAcceptance of
|
||||
CAAccepted {} -> True
|
||||
_ -> False
|
||||
|
||||
data UserOperatorServers = UserOperatorServers
|
||||
{ operator :: Maybe ServerOperator,
|
||||
smpServers :: [UserServer 'PSMP],
|
||||
xftpServers :: [UserServer 'PXFTP]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data UpdatedUserOperatorServers = UpdatedUserOperatorServers
|
||||
{ operator :: Maybe ServerOperator,
|
||||
smpServers :: [AUserServer 'PSMP],
|
||||
xftpServers :: [AUserServer 'PXFTP]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
updatedServers :: UserProtocol p => UpdatedUserOperatorServers -> SProtocolType p -> [AUserServer p]
|
||||
updatedServers UpdatedUserOperatorServers {smpServers, xftpServers} = \case
|
||||
SPSMP -> smpServers
|
||||
SPXFTP -> xftpServers
|
||||
|
||||
type UserServer p = UserServer' 'DBStored p
|
||||
|
||||
type NewUserServer p = UserServer' 'DBNew p
|
||||
|
||||
data AUserServer p = forall s. AUS (SDBStored s) (UserServer' s p)
|
||||
|
||||
deriving instance Show (AUserServer p)
|
||||
|
||||
data UserServer' s p = UserServer
|
||||
{ serverId :: DBEntityId' s,
|
||||
server :: ProtoServerWithAuth p,
|
||||
preset :: Bool,
|
||||
tested :: Maybe Bool,
|
||||
enabled :: Bool,
|
||||
deleted :: Bool
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data PresetOperator = PresetOperator
|
||||
{ operator :: Maybe NewServerOperator,
|
||||
smp :: [NewUserServer 'PSMP],
|
||||
useSMP :: Int,
|
||||
xftp :: [NewUserServer 'PXFTP],
|
||||
useXFTP :: Int
|
||||
}
|
||||
|
||||
operatorServers :: UserProtocol p => SProtocolType p -> PresetOperator -> [NewUserServer p]
|
||||
operatorServers p PresetOperator {smp, xftp} = case p of
|
||||
SPSMP -> smp
|
||||
SPXFTP -> xftp
|
||||
|
||||
operatorServersToUse :: UserProtocol p => SProtocolType p -> PresetOperator -> Int
|
||||
operatorServersToUse p PresetOperator {useSMP, useXFTP} = case p of
|
||||
SPSMP -> useSMP
|
||||
SPXFTP -> useXFTP
|
||||
|
||||
presetServer :: Bool -> ProtoServerWithAuth p -> NewUserServer p
|
||||
presetServer = newUserServer_ True
|
||||
|
||||
newUserServer :: ProtoServerWithAuth p -> NewUserServer p
|
||||
newUserServer = newUserServer_ False True
|
||||
|
||||
newUserServer_ :: Bool -> Bool -> ProtoServerWithAuth p -> NewUserServer p
|
||||
newUserServer_ preset enabled server =
|
||||
UserServer {serverId = DBNewEntity, server, preset, tested = Nothing, enabled, deleted = False}
|
||||
|
||||
-- This function should be used inside DB transaction to update conditions in the database
|
||||
-- it evaluates to (conditions to mark as accepted to SimpleX operator, current conditions, and conditions to add)
|
||||
usageConditionsToAdd :: Bool -> UTCTime -> [UsageConditions] -> (Maybe UsageConditions, UsageConditions, [UsageConditions])
|
||||
usageConditionsToAdd = usageConditionsToAdd' previousConditionsCommit usageConditionsCommit
|
||||
|
||||
-- This function is used in unit tests
|
||||
usageConditionsToAdd' :: Text -> Text -> Bool -> UTCTime -> [UsageConditions] -> (Maybe UsageConditions, UsageConditions, [UsageConditions])
|
||||
usageConditionsToAdd' prevCommit sourceCommit newUser createdAt = \case
|
||||
[]
|
||||
| newUser -> (Just sourceCond, sourceCond, [sourceCond])
|
||||
| otherwise -> (Just prevCond, sourceCond, [prevCond, sourceCond])
|
||||
where
|
||||
prevCond = conditions 1 prevCommit
|
||||
sourceCond = conditions 2 sourceCommit
|
||||
conds
|
||||
| hasSourceCond -> (Nothing, last conds, [])
|
||||
| otherwise -> (Nothing, sourceCond, [sourceCond])
|
||||
where
|
||||
hasSourceCond = any ((sourceCommit ==) . conditionsCommit) conds
|
||||
sourceCond = conditions cId sourceCommit
|
||||
cId = maximum (map conditionsId conds) + 1
|
||||
where
|
||||
conditions cId commit = UsageConditions {conditionsId = cId, conditionsCommit = commit, notifiedAt = Nothing, createdAt}
|
||||
|
||||
-- This function should be used inside DB transaction to update operators.
|
||||
-- It allows to add/remove/update preset operators in the database preserving enabled and roles settings,
|
||||
-- and preserves custom operators without tags for forward compatibility.
|
||||
updatedServerOperators :: NonEmpty PresetOperator -> [ServerOperator] -> [AServerOperator]
|
||||
updatedServerOperators presetOps storedOps =
|
||||
foldr addPreset [] presetOps
|
||||
<> map (ASO SDBStored) (filter (isNothing . operatorTag) storedOps)
|
||||
where
|
||||
-- TODO remove domains of preset operators from custom
|
||||
addPreset PresetOperator {operator} = case operator of
|
||||
Nothing -> id
|
||||
Just presetOp -> (storedOp' :)
|
||||
where
|
||||
storedOp' = case find ((operatorTag presetOp ==) . operatorTag) storedOps of
|
||||
Just ServerOperator {operatorId, conditionsAcceptance, enabled, roles} ->
|
||||
ASO SDBStored presetOp {operatorId, conditionsAcceptance, enabled, roles}
|
||||
Nothing -> ASO SDBNew presetOp
|
||||
|
||||
-- This function should be used inside DB transaction to update servers.
|
||||
updatedUserServers :: forall p. UserProtocol p => SProtocolType p -> NonEmpty PresetOperator -> NonEmpty (NewUserServer p) -> [UserServer p] -> NonEmpty (AUserServer p)
|
||||
updatedUserServers _ _ randomSrvs [] = L.map (AUS SDBNew) randomSrvs
|
||||
updatedUserServers p presetOps randomSrvs srvs =
|
||||
fromMaybe (L.map (AUS SDBNew) randomSrvs) (L.nonEmpty updatedSrvs)
|
||||
where
|
||||
updatedSrvs = map userServer presetSrvs <> map (AUS SDBStored) (filter customServer srvs)
|
||||
storedSrvs :: Map (ProtoServerWithAuth p) (UserServer p)
|
||||
storedSrvs = foldl' (\ss srv@UserServer {server} -> M.insert server srv ss) M.empty srvs
|
||||
customServer :: UserServer p -> Bool
|
||||
customServer srv = not (preset srv) && all (`S.notMember` presetHosts) (srvHost srv)
|
||||
presetSrvs :: [NewUserServer p]
|
||||
presetSrvs = concatMap (operatorServers p) presetOps
|
||||
presetHosts :: Set TransportHost
|
||||
presetHosts = foldMap' (S.fromList . L.toList . srvHost) presetSrvs
|
||||
userServer :: NewUserServer p -> AUserServer p
|
||||
userServer srv@UserServer {server} = maybe (AUS SDBNew srv) (AUS SDBStored) (M.lookup server storedSrvs)
|
||||
|
||||
srvHost :: UserServer' s p -> NonEmpty TransportHost
|
||||
srvHost UserServer {server = ProtoServerWithAuth srv _} = host srv
|
||||
|
||||
agentServerCfgs :: [(Text, ServerOperator)] -> NonEmpty (NewUserServer p) -> [UserServer' s p] -> NonEmpty (ServerCfg p)
|
||||
agentServerCfgs opDomains randomSrvs =
|
||||
fromMaybe fallbackSrvs . L.nonEmpty . mapMaybe enabledOpAgentServer
|
||||
where
|
||||
fallbackSrvs = L.map (snd . agentServer) randomSrvs
|
||||
enabledOpAgentServer srv =
|
||||
let (opEnabled, srvCfg) = agentServer srv
|
||||
in if opEnabled then Just srvCfg else Nothing
|
||||
agentServer :: UserServer' s p -> (Bool, ServerCfg p)
|
||||
agentServer srv@UserServer {server, enabled} =
|
||||
case find (\(d, _) -> any (matchingHost d) (srvHost srv)) opDomains of
|
||||
Just (_, ServerOperator {operatorId = DBEntityId opId, enabled = opEnabled, roles}) ->
|
||||
(opEnabled, ServerCfg {server, enabled, operator = Just opId, roles})
|
||||
Nothing ->
|
||||
(True, ServerCfg {server, enabled, operator = Nothing, roles = allRoles})
|
||||
|
||||
matchingHost :: Text -> TransportHost -> Bool
|
||||
matchingHost d = \case
|
||||
THDomainName h -> d `T.isSuffixOf` T.pack h
|
||||
_ -> False
|
||||
|
||||
operatorDomains :: [ServerOperator] -> [(Text, ServerOperator)]
|
||||
operatorDomains = foldr (\op ds -> foldr (\d -> ((d, op) :)) ds (serverDomains op)) []
|
||||
|
||||
groupByOperator :: ([ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP]) -> IO [UserOperatorServers]
|
||||
groupByOperator (ops, smpSrvs, xftpSrvs) = do
|
||||
ss <- mapM (\op -> (serverDomains op,) <$> newIORef (UserOperatorServers (Just op) [] [])) ops
|
||||
custom <- newIORef $ UserOperatorServers Nothing [] []
|
||||
mapM_ (addServer ss custom addSMP) (reverse smpSrvs)
|
||||
mapM_ (addServer ss custom addXFTP) (reverse xftpSrvs)
|
||||
opSrvs <- mapM (readIORef . snd) ss
|
||||
customSrvs <- readIORef custom
|
||||
pure $ opSrvs <> [customSrvs]
|
||||
where
|
||||
addServer :: [([Text], IORef UserOperatorServers)] -> IORef UserOperatorServers -> (UserServer p -> UserOperatorServers -> UserOperatorServers) -> UserServer p -> IO ()
|
||||
addServer ss custom add srv =
|
||||
let v = maybe custom snd $ find (\(ds, _) -> any (\d -> any (matchingHost d) (srvHost srv)) ds) ss
|
||||
in atomicModifyIORef'_ v $ add srv
|
||||
addSMP srv s@UserOperatorServers {smpServers} = (s :: UserOperatorServers) {smpServers = srv : smpServers}
|
||||
addXFTP srv s@UserOperatorServers {xftpServers} = (s :: UserOperatorServers) {xftpServers = srv : xftpServers}
|
||||
|
||||
data UserServersError
|
||||
= USEStorageMissing {protocol :: AProtocolType}
|
||||
| USEProxyMissing {protocol :: AProtocolType}
|
||||
| USEDuplicateServer {protocol :: AProtocolType, duplicateServer :: AProtoServerWithAuth, duplicateHost :: TransportHost}
|
||||
deriving (Show)
|
||||
|
||||
validateUserServers :: NonEmpty UpdatedUserOperatorServers -> [UserServersError]
|
||||
validateUserServers uss =
|
||||
missingRolesErr SPSMP storage USEStorageMissing
|
||||
<> missingRolesErr SPSMP proxy USEProxyMissing
|
||||
<> missingRolesErr SPXFTP storage USEStorageMissing
|
||||
<> duplicatServerErrs SPSMP
|
||||
<> duplicatServerErrs SPXFTP
|
||||
where
|
||||
missingRolesErr :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> (ServerRoles -> Bool) -> (AProtocolType -> UserServersError) -> [UserServersError]
|
||||
missingRolesErr p roleSel err = [err (AProtocolType p) | not hasRole]
|
||||
where
|
||||
hasRole =
|
||||
any (\(AUS _ UserServer {deleted, enabled}) -> enabled && not deleted) $
|
||||
concatMap (`updatedServers` p) $ filter roleEnabled (L.toList uss)
|
||||
roleEnabled UpdatedUserOperatorServers {operator} =
|
||||
maybe True (\ServerOperator {enabled, roles} -> enabled && roleSel roles) operator
|
||||
duplicatServerErrs :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> [UserServersError]
|
||||
duplicatServerErrs p = mapMaybe duplicateErr_ srvs
|
||||
where
|
||||
srvs =
|
||||
filter (\(AUS _ UserServer {deleted}) -> not deleted) $
|
||||
concatMap (`updatedServers` p) (L.toList uss)
|
||||
duplicateErr_ (AUS _ srv@UserServer {server}) =
|
||||
USEDuplicateServer (AProtocolType p) (AProtoServerWithAuth p server)
|
||||
<$> find (`S.member` duplicateHosts) (srvHost srv)
|
||||
duplicateHosts = snd $ foldl' addHost (S.empty, S.empty) allHosts
|
||||
allHosts = concatMap (\(AUS _ srv) -> L.toList $ srvHost srv) srvs
|
||||
addHost (hs, dups) h
|
||||
| h `S.member` hs = (hs, S.insert h dups)
|
||||
| otherwise = (S.insert h hs, dups)
|
||||
|
||||
instance ToJSON (DBEntityId' s) where
|
||||
toEncoding = \case
|
||||
DBEntityId i -> toEncoding i
|
||||
DBNewEntity -> JE.null_
|
||||
toJSON = \case
|
||||
DBEntityId i -> toJSON i
|
||||
DBNewEntity -> J.Null
|
||||
|
||||
instance DBStoredI s => FromJSON (DBEntityId' s) where
|
||||
parseJSON v = case (v, sdbStored @s) of
|
||||
(J.Null, SDBNew) -> pure DBNewEntity
|
||||
(J.Number n, SDBStored) -> case floatingOrInteger n of
|
||||
Left (_ :: Double) -> fail "bad DBEntityId"
|
||||
Right i -> pure $ DBEntityId (fromInteger i)
|
||||
_ -> fail "bad DBEntityId"
|
||||
omittedField = case sdbStored @s of
|
||||
SDBStored -> Nothing
|
||||
SDBNew -> Just DBNewEntity
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''UsageConditions)
|
||||
|
||||
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CA") ''ConditionsAcceptance)
|
||||
|
||||
instance ToJSON (ServerOperator' s) where
|
||||
toEncoding = $(JQ.mkToEncoding defaultJSON ''ServerOperator')
|
||||
toJSON = $(JQ.mkToJSON defaultJSON ''ServerOperator')
|
||||
|
||||
instance DBStoredI s => FromJSON (ServerOperator' s) where
|
||||
parseJSON = $(JQ.mkParseJSON defaultJSON ''ServerOperator')
|
||||
|
||||
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "UCA") ''UsageConditionsAction)
|
||||
|
||||
instance ProtocolTypeI p => ToJSON (UserServer' s p) where
|
||||
toEncoding = $(JQ.mkToEncoding defaultJSON ''UserServer')
|
||||
toJSON = $(JQ.mkToJSON defaultJSON ''UserServer')
|
||||
|
||||
instance (DBStoredI s, ProtocolTypeI p) => FromJSON (UserServer' s p) where
|
||||
parseJSON = $(JQ.mkParseJSON defaultJSON ''UserServer')
|
||||
|
||||
instance ProtocolTypeI p => FromJSON (AUserServer p) where
|
||||
parseJSON v = (AUS SDBStored <$> parseJSON v) <|> (AUS SDBNew <$> parseJSON v)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''UserOperatorServers)
|
||||
|
||||
instance FromJSON UpdatedUserOperatorServers where
|
||||
parseJSON = $(JQ.mkParseJSON defaultJSON ''UpdatedUserOperatorServers)
|
||||
|
||||
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "USE") ''UserServersError)
|
||||
@@ -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`)
|
||||
@@ -7,7 +7,6 @@ module Simplex.Chat.Stats where
|
||||
|
||||
import qualified Data.Aeson.TH as J
|
||||
import Data.List (partition)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (fromMaybe, isJust)
|
||||
@@ -131,7 +130,7 @@ data NtfServerSummary = NtfServerSummary
|
||||
-- - users are passed to exclude hidden users from totalServersSummary;
|
||||
-- - if currentUser is hidden, it should be accounted in totalServersSummary;
|
||||
-- - known is set only in user level summaries based on passed userSMPSrvs and userXFTPSrvs
|
||||
toPresentedServersSummary :: AgentServersSummary -> [User] -> User -> NonEmpty SMPServer -> NonEmpty XFTPServer -> [NtfServer] -> PresentedServersSummary
|
||||
toPresentedServersSummary :: AgentServersSummary -> [User] -> User -> [SMPServer] -> [XFTPServer] -> [NtfServer] -> PresentedServersSummary
|
||||
toPresentedServersSummary agentSummary users currentUser userSMPSrvs userXFTPSrvs userNtfSrvs = do
|
||||
let (userSMPSrvsSumms, allSMPSrvsSumms) = accSMPSrvsSummaries
|
||||
(userSMPCurr, userSMPPrev, userSMPProx) = smpSummsIntoCategories userSMPSrvsSumms
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -1,5 +1,8 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
@@ -47,7 +50,19 @@ module Simplex.Chat.Store.Profiles
|
||||
getContactWithoutConnViaAddress,
|
||||
updateUserAddressAutoAccept,
|
||||
getProtocolServers,
|
||||
getUpdateUserServers,
|
||||
-- overwriteOperatorsAndServers,
|
||||
overwriteProtocolServers,
|
||||
insertProtocolServer,
|
||||
getUpdateServerOperators,
|
||||
getServerOperators,
|
||||
getUserServers,
|
||||
setServerOperators,
|
||||
getCurrentUsageConditions,
|
||||
getLatestAcceptedConditions,
|
||||
setConditionsNotified,
|
||||
acceptConditions,
|
||||
setUserServers,
|
||||
createCall,
|
||||
deleteCalls,
|
||||
getCalls,
|
||||
@@ -70,12 +85,14 @@ import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
import Data.Time.Clock (UTCTime (..), getCurrentTime)
|
||||
import Database.SQLite.Simple (NamedParam (..), Only (..), (:.) (..))
|
||||
import Database.SQLite.Simple (NamedParam (..), Only (..), Query, (:.) (..))
|
||||
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 +100,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 (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
|
||||
@@ -91,7 +108,7 @@ import qualified Simplex.Messaging.Crypto as C
|
||||
import qualified Simplex.Messaging.Crypto.Ratchet as CR
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (defaultJSON)
|
||||
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..), SubscriptionMode)
|
||||
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), ProtocolTypeI (..), SProtocolType (..), SubscriptionMode, UserProtocol)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost)
|
||||
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8)
|
||||
|
||||
@@ -515,42 +532,311 @@ updateUserAddressAutoAccept db user@User {userId} autoAccept = do
|
||||
Just AutoAccept {acceptIncognito, autoReply} -> (True, acceptIncognito, autoReply)
|
||||
_ -> (False, False, Nothing)
|
||||
|
||||
getProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> IO [ServerCfg p]
|
||||
getProtocolServers db User {userId} =
|
||||
map toServerCfg
|
||||
getUpdateUserServers :: forall p. (ProtocolTypeI p, UserProtocol p) => DB.Connection -> SProtocolType p -> NonEmpty PresetOperator -> NonEmpty (NewUserServer p) -> User -> IO [UserServer p]
|
||||
getUpdateUserServers db p presetOps randomSrvs user = do
|
||||
ts <- getCurrentTime
|
||||
srvs <- getProtocolServers db p user
|
||||
let srvs' = L.toList $ updatedUserServers p presetOps randomSrvs srvs
|
||||
mapM (upsertServer ts) srvs'
|
||||
where
|
||||
upsertServer :: UTCTime -> AUserServer p -> IO (UserServer p)
|
||||
upsertServer ts (AUS _ s@UserServer {serverId}) = case serverId of
|
||||
DBNewEntity -> insertProtocolServer db p user ts s
|
||||
DBEntityId _ -> updateProtocolServer db p ts s $> s
|
||||
|
||||
getProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> SProtocolType p -> User -> IO [UserServer p]
|
||||
getProtocolServers db p User {userId} =
|
||||
map toUserServer
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT host, port, key_hash, basic_auth, preset, tested, enabled
|
||||
SELECT smp_server_id, host, port, key_hash, basic_auth, preset, tested, enabled
|
||||
FROM protocol_servers
|
||||
WHERE user_id = ? AND protocol = ?;
|
||||
WHERE user_id = ? AND protocol = ?
|
||||
|]
|
||||
(userId, decodeLatin1 $ strEncode protocol)
|
||||
(userId, decodeLatin1 $ strEncode p)
|
||||
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) =
|
||||
let server = ProtoServerWithAuth (ProtocolServer protocol host port keyHash) (BasicAuth . encodeUtf8 <$> auth_)
|
||||
in ServerCfg {server, preset, tested, enabled}
|
||||
toUserServer :: (DBEntityId, NonEmpty TransportHost, String, C.KeyHash, Maybe Text, Bool, Maybe Bool, Bool) -> UserServer p
|
||||
toUserServer (serverId, host, port, keyHash, auth_, preset, tested, enabled) =
|
||||
let server = ProtoServerWithAuth (ProtocolServer p host port keyHash) (BasicAuth . encodeUtf8 <$> auth_)
|
||||
in UserServer {serverId, server, preset, tested, enabled, deleted = False}
|
||||
|
||||
overwriteProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> [ServerCfg p] -> ExceptT StoreError IO ()
|
||||
overwriteProtocolServers db User {userId} servers =
|
||||
-- TODO remove
|
||||
-- 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 :: ProtocolTypeI p => DB.Connection -> SProtocolType p -> User -> [UserServer p] -> ExceptT StoreError IO ()
|
||||
overwriteProtocolServers db p 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)
|
||||
forM_ servers $ \ServerCfg {server, preset, tested, enabled} -> do
|
||||
let ProtoServerWithAuth ProtocolServer {host, port, keyHash} auth_ = server
|
||||
DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND protocol = ? " (userId, decodeLatin1 $ strEncode p)
|
||||
forM_ servers $ \UserServer {serverId, server, preset, tested, enabled} -> do
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO protocol_servers
|
||||
(protocol, host, port, key_hash, basic_auth, preset, tested, enabled, user_id, created_at, updated_at)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?)
|
||||
(server_id, protocol, host, port, key_hash, basic_auth, preset, tested, enabled, user_id, created_at, updated_at)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
((protocol, host, port, keyHash, safeDecodeUtf8 . unBasicAuth <$> auth_) :. (preset, tested, enabled, userId, currentTs, currentTs))
|
||||
(Only serverId :. serverColumns p server :. (preset, tested, enabled, userId, currentTs, currentTs))
|
||||
pure $ Right ()
|
||||
|
||||
insertProtocolServer :: forall p. ProtocolTypeI p => DB.Connection -> SProtocolType p -> User -> UTCTime -> NewUserServer p -> IO (UserServer p)
|
||||
insertProtocolServer db p User {userId} ts srv@UserServer {server, preset, tested, enabled} = do
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO protocol_servers
|
||||
(protocol, host, port, key_hash, basic_auth, preset, tested, enabled, user_id, created_at, updated_at)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
(serverColumns p server :. (preset, tested, enabled, userId, ts, ts))
|
||||
sId <- insertedRowId db
|
||||
pure (srv :: NewUserServer p) {serverId = DBEntityId sId}
|
||||
|
||||
updateProtocolServer :: ProtocolTypeI p => DB.Connection -> SProtocolType p -> UTCTime -> UserServer p -> IO ()
|
||||
updateProtocolServer db p ts UserServer {serverId, server, preset, tested, enabled} =
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE protocol_servers
|
||||
SET protocol = ?, host = ?, port = ?, key_hash = ?, basic_auth = ?,
|
||||
preset = ?, tested = ?, enabled = ?, updated_at = ?
|
||||
WHERE smp_server_id = ?
|
||||
|]
|
||||
(serverColumns p server :. (preset, tested, enabled, ts, serverId))
|
||||
|
||||
serverColumns :: ProtocolTypeI p => SProtocolType p -> ProtoServerWithAuth p -> (Text, NonEmpty TransportHost, String, C.KeyHash, Maybe Text)
|
||||
serverColumns p (ProtoServerWithAuth ProtocolServer {host, port, keyHash} auth_) =
|
||||
let protocol = decodeLatin1 $ strEncode p
|
||||
auth = safeDecodeUtf8 . unBasicAuth <$> auth_
|
||||
in (protocol, host, port, keyHash, auth)
|
||||
|
||||
getServerOperators :: DB.Connection -> ExceptT StoreError IO ([ServerOperator], Maybe UsageConditionsAction)
|
||||
getServerOperators db = do
|
||||
currentConds <- getCurrentUsageConditions db
|
||||
liftIO $ do
|
||||
now <- getCurrentTime
|
||||
latestAcceptedConds_ <- getLatestAcceptedConditions db
|
||||
let getConds op = (\ca -> op {conditionsAcceptance = ca}) <$> getOperatorConditions_ db op currentConds latestAcceptedConds_ now
|
||||
operators <- mapM getConds =<< getServerOperators_ db
|
||||
pure (operators, usageConditionsAction operators currentConds now)
|
||||
|
||||
getUserServers :: DB.Connection -> User -> ExceptT StoreError IO ([ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP])
|
||||
getUserServers db user =
|
||||
(,,)
|
||||
<$> (fst <$> getServerOperators db)
|
||||
<*> liftIO (getProtocolServers db SPSMP user)
|
||||
<*> liftIO (getProtocolServers db SPXFTP user)
|
||||
|
||||
setServerOperators :: DB.Connection -> NonEmpty ServerOperator -> IO ()
|
||||
setServerOperators db ops = do
|
||||
currentTs <- getCurrentTime
|
||||
mapM_ (updateServerOperator db currentTs) ops
|
||||
|
||||
updateServerOperator :: DB.Connection -> UTCTime -> ServerOperator -> IO ()
|
||||
updateServerOperator db currentTs ServerOperator {operatorId, enabled, roles = ServerRoles {storage, proxy}} =
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE server_operators
|
||||
SET enabled = ?, role_storage = ?, role_proxy = ?, updated_at = ?
|
||||
WHERE server_operator_id = ?
|
||||
|]
|
||||
(enabled, storage, proxy, operatorId, currentTs)
|
||||
|
||||
getUpdateServerOperators :: DB.Connection -> NonEmpty PresetOperator -> Bool -> IO [ServerOperator]
|
||||
getUpdateServerOperators db presetOps newUser = do
|
||||
conds <- map toUsageConditions <$> DB.query_ db usageCondsQuery
|
||||
now <- getCurrentTime
|
||||
let (acceptForSimplex_, currentConds, condsToAdd) = usageConditionsToAdd newUser now conds
|
||||
mapM_ insertConditions condsToAdd
|
||||
latestAcceptedConds_ <- getLatestAcceptedConditions db
|
||||
ops <- updatedServerOperators presetOps <$> getServerOperators_ db
|
||||
forM ops $ \(ASO _ op) ->
|
||||
case operatorId op of
|
||||
DBNewEntity -> do
|
||||
op' <- insertOperator op
|
||||
case (operatorTag op', acceptForSimplex_) of
|
||||
(Just OTSimplex, Just cond) -> autoAcceptConditions op' cond
|
||||
_ -> pure op'
|
||||
DBEntityId _ -> do
|
||||
updateOperator op
|
||||
getOperatorConditions_ db op currentConds latestAcceptedConds_ now >>= \case
|
||||
CARequired Nothing | operatorTag op == Just OTSimplex -> autoAcceptConditions op currentConds
|
||||
CARequired (Just ts) | ts < now -> autoAcceptConditions op currentConds
|
||||
ca -> pure op {conditionsAcceptance = ca}
|
||||
where
|
||||
protocol = decodeLatin1 $ strEncode $ protocolTypeI @p
|
||||
insertConditions UsageConditions {conditionsId, conditionsCommit, notifiedAt, createdAt} =
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO usage_conditions
|
||||
(usage_conditions_id, conditions_commit, notified_at, created_at)
|
||||
VALUES (?,?,?,?)
|
||||
|]
|
||||
(conditionsId, conditionsCommit, notifiedAt, createdAt)
|
||||
updateOperator :: ServerOperator -> IO ()
|
||||
updateOperator ServerOperator {operatorId, tradeName, legalName, serverDomains, enabled, roles = ServerRoles {storage, proxy}} =
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE server_operators
|
||||
SET trade_name = ?, legal_name = ?, server_domains = ?, enabled = ?, role_storage = ?, role_proxy = ?
|
||||
WHERE server_operator_id = ?
|
||||
|]
|
||||
(tradeName, legalName, T.intercalate "," serverDomains, enabled, storage, proxy, operatorId)
|
||||
insertOperator :: NewServerOperator -> IO ServerOperator
|
||||
insertOperator op@ServerOperator {operatorTag, tradeName, legalName, serverDomains, enabled, roles = ServerRoles {storage, proxy}} = do
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO server_operators
|
||||
(server_operator_tag, trade_name, legal_name, server_domains, enabled, role_storage, role_proxy)
|
||||
VALUES (?,?,?,?,?,?,?)
|
||||
|]
|
||||
(operatorTag, tradeName, legalName, T.intercalate "," serverDomains, enabled, storage, proxy)
|
||||
opId <- insertedRowId db
|
||||
pure op {operatorId = DBEntityId opId}
|
||||
autoAcceptConditions op UsageConditions {conditionsCommit} =
|
||||
acceptConditions_ db op conditionsCommit Nothing
|
||||
$> op {conditionsAcceptance = CAAccepted Nothing}
|
||||
|
||||
serverOperatorQuery :: Query
|
||||
serverOperatorQuery =
|
||||
[sql|
|
||||
SELECT server_operator_id, server_operator_tag, trade_name, legal_name,
|
||||
server_domains, enabled, role_storage, role_proxy
|
||||
FROM server_operators
|
||||
|]
|
||||
|
||||
getServerOperators_ :: DB.Connection -> IO [ServerOperator]
|
||||
getServerOperators_ db = map toServerOperator <$> DB.query_ db serverOperatorQuery
|
||||
|
||||
toServerOperator :: (DBEntityId, Maybe OperatorTag, Text, Maybe Text, Text, Bool, Bool, Bool) -> ServerOperator
|
||||
toServerOperator (operatorId, operatorTag, tradeName, legalName, domains, enabled, storage, proxy) =
|
||||
ServerOperator
|
||||
{ operatorId,
|
||||
operatorTag,
|
||||
tradeName,
|
||||
legalName,
|
||||
serverDomains = T.splitOn "," domains,
|
||||
conditionsAcceptance = CARequired Nothing,
|
||||
enabled,
|
||||
roles = ServerRoles {storage, proxy}
|
||||
}
|
||||
|
||||
getOperatorConditions_ :: DB.Connection -> ServerOperator -> UsageConditions -> Maybe UsageConditions -> UTCTime -> IO ConditionsAcceptance
|
||||
getOperatorConditions_ db ServerOperator {operatorId} UsageConditions {conditionsCommit = currentCommit, createdAt, notifiedAt} latestAcceptedConds_ now = do
|
||||
case latestAcceptedConds_ of
|
||||
Nothing -> pure $ CARequired Nothing -- no conditions accepted by any operator
|
||||
Just UsageConditions {conditionsCommit = latestAcceptedCommit} -> do
|
||||
operatorAcceptedConds_ <-
|
||||
maybeFirstRow id $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT conditions_commit, accepted_at
|
||||
FROM operator_usage_conditions
|
||||
WHERE server_operator_id = ?
|
||||
ORDER BY operator_usage_conditions_id DESC
|
||||
LIMIT 1
|
||||
|]
|
||||
(Only operatorId)
|
||||
pure $ case operatorAcceptedConds_ of
|
||||
Just (operatorCommit, acceptedAt_)
|
||||
| operatorCommit /= latestAcceptedCommit -> CARequired Nothing -- TODO should we consider this operator disabled?
|
||||
| currentCommit /= latestAcceptedCommit -> CARequired $ conditionsRequiredOrDeadline createdAt (fromMaybe now notifiedAt)
|
||||
| otherwise -> CAAccepted acceptedAt_
|
||||
_ -> CARequired Nothing -- no conditions were accepted for this operator
|
||||
|
||||
getCurrentUsageConditions :: DB.Connection -> ExceptT StoreError IO UsageConditions
|
||||
getCurrentUsageConditions db =
|
||||
ExceptT . firstRow toUsageConditions SEUsageConditionsNotFound $
|
||||
DB.query_ db (usageCondsQuery <> " DESC LIMIT 1")
|
||||
|
||||
usageCondsQuery :: Query
|
||||
usageCondsQuery =
|
||||
[sql|
|
||||
SELECT usage_conditions_id, conditions_commit, notified_at, created_at
|
||||
FROM usage_conditions
|
||||
ORDER BY usage_conditions_id
|
||||
|]
|
||||
|
||||
toUsageConditions :: (Int64, Text, Maybe UTCTime, UTCTime) -> UsageConditions
|
||||
toUsageConditions (conditionsId, conditionsCommit, notifiedAt, createdAt) =
|
||||
UsageConditions {conditionsId, conditionsCommit, notifiedAt, createdAt}
|
||||
|
||||
getLatestAcceptedConditions :: DB.Connection -> IO (Maybe UsageConditions)
|
||||
getLatestAcceptedConditions db =
|
||||
maybeFirstRow toUsageConditions $
|
||||
DB.query_
|
||||
db
|
||||
[sql|
|
||||
SELECT usage_conditions_id, conditions_commit, notified_at, created_at
|
||||
FROM usage_conditions
|
||||
WHERE conditions_commit = (
|
||||
SELECT conditions_commit
|
||||
FROM operator_usage_conditions
|
||||
ORDER BY accepted_at DESC
|
||||
LIMIT 1
|
||||
)
|
||||
|]
|
||||
|
||||
setConditionsNotified :: DB.Connection -> Int64 -> UTCTime -> IO ()
|
||||
setConditionsNotified db condId notifiedAt =
|
||||
DB.execute db "UPDATE usage_conditions SET notified_at = ? WHERE usage_conditions_id = ?" (notifiedAt, condId)
|
||||
|
||||
acceptConditions :: DB.Connection -> Int64 -> NonEmpty Int64 -> UTCTime -> ExceptT StoreError IO ()
|
||||
acceptConditions db condId opIds acceptedAt = do
|
||||
UsageConditions {conditionsCommit} <- getUsageConditionsById_ db condId
|
||||
operators <- mapM getServerOperator_ opIds
|
||||
let ts = Just acceptedAt
|
||||
liftIO $ forM_ operators $ \op -> acceptConditions_ db op conditionsCommit ts
|
||||
where
|
||||
getServerOperator_ opId =
|
||||
ExceptT $ firstRow toServerOperator (SEOperatorNotFound opId) $
|
||||
DB.query db (serverOperatorQuery <> " WHERE operator_id = ?") (Only opId)
|
||||
|
||||
acceptConditions_ :: DB.Connection -> ServerOperator -> Text -> Maybe UTCTime -> IO ()
|
||||
acceptConditions_ db ServerOperator {operatorId, operatorTag} conditionsCommit acceptedAt =
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO operator_usage_conditions
|
||||
(server_operator_id, server_operator_tag, conditions_commit, accepted_at)
|
||||
VALUES (?,?,?,?)
|
||||
|]
|
||||
(operatorId, operatorTag, conditionsCommit, acceptedAt)
|
||||
|
||||
getUsageConditionsById_ :: DB.Connection -> Int64 -> ExceptT StoreError IO UsageConditions
|
||||
getUsageConditionsById_ db conditionsId =
|
||||
ExceptT . firstRow toUsageConditions SEUsageConditionsNotFound $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT usage_conditions_id, conditions_commit, notified_at, created_at
|
||||
FROM usage_conditions
|
||||
WHERE usage_conditions_id = ?
|
||||
|]
|
||||
(Only conditionsId)
|
||||
|
||||
setUserServers :: DB.Connection -> User -> NonEmpty UpdatedUserOperatorServers -> ExceptT StoreError IO ()
|
||||
setUserServers db user@User {userId} userServers = checkConstraint SEUniqueID $ liftIO $ do
|
||||
ts <- getCurrentTime
|
||||
forM_ userServers $ \UpdatedUserOperatorServers {operator, smpServers, xftpServers} -> do
|
||||
mapM_ (updateServerOperator db ts) operator
|
||||
mapM_ (upsertOrDelete SPSMP ts) smpServers
|
||||
mapM_ (upsertOrDelete SPXFTP ts) xftpServers
|
||||
where
|
||||
upsertOrDelete :: ProtocolTypeI p => SProtocolType p -> UTCTime -> AUserServer p -> IO ()
|
||||
upsertOrDelete p ts (AUS _ s@UserServer {serverId, deleted}) = case serverId of
|
||||
DBNewEntity
|
||||
| deleted -> pure ()
|
||||
| otherwise -> void $ insertProtocolServer db p user ts s
|
||||
DBEntityId srvId
|
||||
| deleted -> DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND smp_server_id = ? AND preset = ?" (userId, srvId, False)
|
||||
| otherwise -> updateProtocolServer db p ts s
|
||||
|
||||
createCall :: DB.Connection -> User -> Call -> UTCTime -> IO ()
|
||||
createCall db user@User {userId} Call {contactId, callId, callUUID, chatItemId, callState} callTs = do
|
||||
|
||||
@@ -127,6 +127,8 @@ data StoreError
|
||||
| SERemoteCtrlNotFound {remoteCtrlId :: RemoteCtrlId}
|
||||
| SERemoteCtrlDuplicateCA
|
||||
| SEProhibitedDeleteUser {userId :: UserId, contactId :: ContactId}
|
||||
| SEOperatorNotFound {serverOperatorId :: Int64}
|
||||
| SEUsageConditionsNotFound
|
||||
deriving (Show, Exception)
|
||||
|
||||
$(J.deriveJSON (sumTypeJSON $ dropPrefix "SE") ''StoreError)
|
||||
|
||||
@@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Simplex.Chat.Terminal where
|
||||
@@ -13,15 +14,15 @@ 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 (_defaultNtfServers, defaultChatConfig, operatorSimpleXChat)
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Core
|
||||
import Simplex.Chat.Help (chatWelcome)
|
||||
import Simplex.Chat.Operators
|
||||
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.Client (NetworkConfig (..), SMPProxyFallback (..), SMPProxyMode (..), defaultNetworkConfig)
|
||||
import Simplex.Messaging.Util (raceAny_)
|
||||
import System.IO (hFlush, hSetEcho, stdin, stdout)
|
||||
@@ -29,20 +30,24 @@ import System.IO (hFlush, hSetEcho, stdin, stdout)
|
||||
terminalChatConfig :: ChatConfig
|
||||
terminalChatConfig =
|
||||
defaultChatConfig
|
||||
{ defaultServers =
|
||||
DefaultAgentServers
|
||||
{ smp =
|
||||
L.fromList $
|
||||
map
|
||||
(presetServerCfg True)
|
||||
[ "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,
|
||||
useXFTP = L.length defaultXFTPServers,
|
||||
{ presetServers =
|
||||
PresetServers
|
||||
{ operators =
|
||||
[ PresetOperator
|
||||
{ operator = Just operatorSimpleXChat,
|
||||
smp =
|
||||
map
|
||||
(presetServer True)
|
||||
[ "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,
|
||||
xftp = map (presetServer True) $ L.toList defaultXFTPServers,
|
||||
useXFTP = 3
|
||||
}
|
||||
],
|
||||
ntf = _defaultNtfServers,
|
||||
netCfg =
|
||||
defaultNetworkConfig
|
||||
{ smpProxyMode = SPMUnknown,
|
||||
|
||||
@@ -10,7 +10,7 @@ import Data.Maybe (fromMaybe)
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import Data.Time.LocalTime (getCurrentTimeZone)
|
||||
import Network.Socket
|
||||
import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatResponse (..), DefaultAgentServers (DefaultAgentServers, netCfg), SimpleNetCfg (..), currentRemoteHost, versionNumber, versionString)
|
||||
import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatResponse (..), PresetServers (..), SimpleNetCfg (..), currentRemoteHost, versionNumber, versionString)
|
||||
import Simplex.Chat.Core
|
||||
import Simplex.Chat.Options
|
||||
import Simplex.Chat.Terminal
|
||||
@@ -56,7 +56,7 @@ simplexChatCLI' cfg opts@ChatOpts {chatCmd, chatCmdLog, chatCmdDelay, chatServer
|
||||
putStrLn $ serializeChatResponse (rh, Just user) ts tz rh r
|
||||
|
||||
welcome :: ChatConfig -> ChatOpts -> IO ()
|
||||
welcome ChatConfig {defaultServers = DefaultAgentServers {netCfg}} ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, simpleNetCfg = SimpleNetCfg {socksProxy, socksMode, smpProxyMode_, smpProxyFallback_}}} =
|
||||
welcome ChatConfig {presetServers = PresetServers {netCfg}} ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, simpleNetCfg = SimpleNetCfg {socksProxy, socksMode, smpProxyMode_, smpProxyFallback_}}} =
|
||||
mapM_
|
||||
putStrLn
|
||||
[ versionString versionNumber,
|
||||
|
||||
+86
-25
@@ -25,6 +25,7 @@ import qualified Data.List.NonEmpty as L
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
|
||||
import Data.String
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeLatin1)
|
||||
@@ -42,6 +43,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
|
||||
@@ -53,7 +55,7 @@ import Simplex.Chat.Types.Shared
|
||||
import Simplex.Chat.Types.UITheme
|
||||
import qualified Simplex.FileTransfer.Transport as XFTP
|
||||
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), SubscriptionsInfo (..))
|
||||
import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..), ServerCfg (..))
|
||||
import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..), ServerRoles (..))
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..))
|
||||
import Simplex.Messaging.Client (SMPProxyFallback, SMPProxyMode (..), SocksMode (..))
|
||||
@@ -95,8 +97,11 @@ 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
|
||||
CRServerTestResult u srv testFailure -> ttyUser u $ viewServerTestResult srv testFailure
|
||||
CRServerOperators ops ca -> viewServerOperators ops ca
|
||||
CRUserServers u uss -> ttyUser u $ concatMap viewUserServers uss <> (if testView then [] else serversUserHelp)
|
||||
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,27 +1214,31 @@ 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 =
|
||||
customServers
|
||||
<> if testView
|
||||
then []
|
||||
else
|
||||
[ "",
|
||||
"use " <> highlight (srvCmd <> " test <srv>") <> " to test " <> pName <> " server connection",
|
||||
"use " <> highlight (srvCmd <> " <srv1[,srv2,...]>") <> " to configure " <> pName <> " servers",
|
||||
"use " <> highlight (srvCmd <> " default") <> " to remove configured " <> pName <> " servers and use presets"
|
||||
]
|
||||
<> case p of
|
||||
SPSMP -> ["(chat option " <> highlight' "-s" <> " (" <> highlight' "--server" <> ") has precedence over saved SMP servers for chat session)"]
|
||||
SPXFTP -> ["(chat option " <> highlight' "-xftp-servers" <> " has precedence over saved XFTP servers for chat session)"]
|
||||
viewUserServers :: UserOperatorServers -> [StyledString]
|
||||
viewUserServers (UserOperatorServers _ [] []) = []
|
||||
viewUserServers UserOperatorServers {operator, smpServers, xftpServers} =
|
||||
[plain $ maybe "Your servers" shortViewOperator operator]
|
||||
<> viewServers SPSMP smpServers
|
||||
<> viewServers SPXFTP xftpServers
|
||||
where
|
||||
srvCmd = "/" <> strEncode p
|
||||
pName = protocolName p
|
||||
customServers =
|
||||
if null protoServers
|
||||
then ("no " <> pName <> " servers saved, using presets: ") : viewServers presetServers
|
||||
else viewServers protoServers
|
||||
viewServers :: ProtocolTypeI p => SProtocolType p -> [UserServer p] -> [StyledString]
|
||||
viewServers _ [] = []
|
||||
viewServers p srvs = [" " <> protocolName p <> " servers"] <> map (plain . (" " <> ) . viewServer) srvs
|
||||
where
|
||||
viewServer UserServer {server, preset, tested, enabled} = safeDecodeUtf8 (strEncode server) <> serverInfo
|
||||
where
|
||||
serverInfo = if null serverInfo_ then "" else parens $ T.intercalate ", " serverInfo_
|
||||
serverInfo_ = ["preset" | preset] <> testedInfo <> ["disabled" | not enabled]
|
||||
testedInfo = maybe [] (\t -> ["test: " <> if t then "passed" else "failed"]) tested
|
||||
|
||||
serversUserHelp :: [StyledString]
|
||||
serversUserHelp =
|
||||
[ "",
|
||||
"use " <> highlight' "/smp test <srv>" <> " to test SMP server connection",
|
||||
"use " <> highlight' "/smp <srv1[,srv2,...]>" <> " to configure SMP servers",
|
||||
"or the same commands starting from /xftp for XFTP servers",
|
||||
"chat options " <> highlight' "-s" <> " (" <> highlight' "--server" <> ") and " <> highlight' "--xftp-servers" <> " have precedence over preset servers for new user profiles"
|
||||
]
|
||||
|
||||
protocolName :: ProtocolTypeI p => SProtocolType p -> StyledString
|
||||
protocolName = plain . map toUpper . T.unpack . decodeLatin1 . strEncode
|
||||
@@ -1250,6 +1259,53 @@ viewServerTestResult (AProtoServerWithAuth p _) = \case
|
||||
where
|
||||
pName = protocolName p
|
||||
|
||||
viewServerOperators :: [ServerOperator] -> Maybe UsageConditionsAction -> [StyledString]
|
||||
viewServerOperators ops ca = map (plain . viewOperator) ops <> maybe [] viewConditionsAction ca
|
||||
|
||||
viewOperator :: ServerOperator' s -> Text
|
||||
viewOperator op@ServerOperator {tradeName, legalName, serverDomains, conditionsAcceptance} =
|
||||
viewOpIdTag op
|
||||
<> tradeName
|
||||
<> maybe "" parens legalName
|
||||
<> (", domains: " <> T.intercalate ", " serverDomains)
|
||||
<> (", conditions: " <> viewOpConditions conditionsAcceptance)
|
||||
<> (", " <> viewOpEnabled op)
|
||||
|
||||
shortViewOperator :: ServerOperator -> Text
|
||||
shortViewOperator op@ServerOperator {operatorId = DBEntityId opId, tradeName} =
|
||||
tshow opId <> ". " <> tradeName <> parens (viewOpEnabled op)
|
||||
|
||||
viewOpIdTag :: ServerOperator' s -> Text
|
||||
viewOpIdTag ServerOperator {operatorId, operatorTag} = case operatorId of
|
||||
DBEntityId i -> tshow i <> " - " <> tag
|
||||
DBNewEntity -> tag
|
||||
where
|
||||
tag = maybe "" textEncode operatorTag <> ". "
|
||||
|
||||
viewOpConditions :: ConditionsAcceptance -> Text
|
||||
viewOpConditions = \case
|
||||
CAAccepted ts -> viewCond "accepted" ts
|
||||
CARequired ts -> viewCond "required" ts
|
||||
where
|
||||
viewCond w ts = w <> maybe "" (parens . tshow) ts
|
||||
|
||||
viewOpEnabled :: ServerOperator' s -> Text
|
||||
viewOpEnabled ServerOperator {enabled, roles = ServerRoles {storage, proxy}}
|
||||
| enabled && storage && proxy = "enabled"
|
||||
| enabled && storage = "enabled storage"
|
||||
| enabled && proxy = "enabled proxy"
|
||||
| otherwise = "disabled"
|
||||
|
||||
viewConditionsAction :: UsageConditionsAction -> [StyledString]
|
||||
viewConditionsAction = \case
|
||||
UCAReview {operators, deadline, showNotice} | showNotice -> case deadline of
|
||||
Just ts -> [plain $ "New conditions will be accepted at " <> tshow ts <> " for " <> ops]
|
||||
Nothing -> [plain $ "New conditions have to be accepted for " <> ops]
|
||||
where
|
||||
ops = T.intercalate ", " $ map legalName_ operators
|
||||
legalName_ ServerOperator {tradeName, legalName} = fromMaybe tradeName legalName
|
||||
_ -> []
|
||||
|
||||
viewChatItemTTL :: Maybe Int64 -> [StyledString]
|
||||
viewChatItemTTL = \case
|
||||
Nothing -> ["old messages are not being deleted"]
|
||||
@@ -1326,8 +1382,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 DBEntityId) 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
|
||||
@@ -1926,7 +1985,9 @@ viewVersionInfo logLevel CoreVersionInfo {version, simplexmqVersion, simplexmqCo
|
||||
then [versionString version, updateStr, "simplexmq: " <> simplexmqVersion <> parens simplexmqCommit]
|
||||
else [versionString version, updateStr]
|
||||
where
|
||||
parens s = " (" <> s <> ")"
|
||||
|
||||
parens :: (IsString a, Semigroup a) => a -> a
|
||||
parens s = " (" <> s <> ")"
|
||||
|
||||
viewRemoteHosts :: [RemoteHostInfo] -> [StyledString]
|
||||
viewRemoteHosts = \case
|
||||
|
||||
+19
-7
@@ -25,9 +25,10 @@ import Data.Maybe (isNothing)
|
||||
import qualified Data.Text as T
|
||||
import Network.Socket
|
||||
import Simplex.Chat
|
||||
import Simplex.Chat.Controller (ChatCommand (..), ChatConfig (..), ChatController (..), ChatDatabase (..), ChatLogLevel (..), defaultSimpleNetCfg)
|
||||
import Simplex.Chat.Controller (ChatCommand (..), ChatConfig (..), ChatController (..), ChatDatabase (..), ChatLogLevel (..), PresetServers (..), defaultSimpleNetCfg)
|
||||
import Simplex.Chat.Core
|
||||
import Simplex.Chat.Options
|
||||
import Simplex.Chat.Operators (PresetOperator (..), presetServer)
|
||||
import Simplex.Chat.Protocol (currentChatVersion, pqEncryptionCompressionVersion)
|
||||
import Simplex.Chat.Store
|
||||
import Simplex.Chat.Store.Profiles
|
||||
@@ -94,8 +95,8 @@ testCoreOpts =
|
||||
{ dbFilePrefix = "./simplex_v1",
|
||||
dbKey = "",
|
||||
-- dbKey = "this is a pass-phrase to encrypt the database",
|
||||
smpServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001"],
|
||||
xftpServers = ["xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002"],
|
||||
smpServers = [],
|
||||
xftpServers = [],
|
||||
simpleNetCfg = defaultSimpleNetCfg,
|
||||
logLevel = CLLImportant,
|
||||
logConnections = False,
|
||||
@@ -149,6 +150,18 @@ testCfg :: ChatConfig
|
||||
testCfg =
|
||||
defaultChatConfig
|
||||
{ agentConfig = testAgentCfg,
|
||||
presetServers =
|
||||
(presetServers defaultChatConfig)
|
||||
{ operators =
|
||||
[ PresetOperator
|
||||
{ operator = Nothing,
|
||||
smp = map (presetServer True) ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001"],
|
||||
useSMP = 1,
|
||||
xftp = map (presetServer True) ["xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002"],
|
||||
useXFTP = 1
|
||||
}
|
||||
]
|
||||
},
|
||||
showReceipts = False,
|
||||
testView = True,
|
||||
tbqSize = 16
|
||||
@@ -423,11 +436,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,
|
||||
|
||||
+56
-21
@@ -25,7 +25,7 @@ import Database.SQLite.Simple (Only (..))
|
||||
import Simplex.Chat.AppSettings (defaultAppSettings)
|
||||
import qualified Simplex.Chat.AppSettings as AS
|
||||
import Simplex.Chat.Call
|
||||
import Simplex.Chat.Controller (ChatConfig (..), DefaultAgentServers (..))
|
||||
import Simplex.Chat.Controller (ChatConfig (..), PresetServers (..))
|
||||
import Simplex.Chat.Messages (ChatItemId)
|
||||
import Simplex.Chat.Options
|
||||
import Simplex.Chat.Protocol (supportedChatVRange)
|
||||
@@ -332,8 +332,8 @@ testRetryConnectingClientTimeout tmp = do
|
||||
{ quotaExceededTimeout = 1,
|
||||
messageRetryInterval = RetryInterval2 {riFast = fastRetryInterval, riSlow = fastRetryInterval}
|
||||
},
|
||||
defaultServers =
|
||||
let def@DefaultAgentServers {netCfg} = defaultServers testCfg
|
||||
presetServers =
|
||||
let def@PresetServers {netCfg} = presetServers testCfg
|
||||
in def {netCfg = (netCfg :: NetworkConfig) {tcpTimeout = 10}}
|
||||
}
|
||||
opts' =
|
||||
@@ -1109,17 +1109,32 @@ testGetSetSMPServers :: HasCallStack => FilePath -> IO ()
|
||||
testGetSetSMPServers =
|
||||
testChat2 aliceProfile bobProfile $
|
||||
\alice _ -> do
|
||||
alice #$> ("/_servers 1 smp", id, "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001")
|
||||
alice ##> "/_servers 1"
|
||||
alice <## "Your servers"
|
||||
alice <## " SMP servers"
|
||||
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset)"
|
||||
alice <## " XFTP servers"
|
||||
alice <## " xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002 (preset)"
|
||||
alice #$> ("/smp smp://1234-w==@smp1.example.im", id, "ok")
|
||||
alice #$> ("/smp", id, "smp://1234-w==@smp1.example.im")
|
||||
alice ##> "/smp"
|
||||
alice <## "Your servers"
|
||||
alice <## " SMP servers"
|
||||
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset, disabled)"
|
||||
alice <## " smp://1234-w==@smp1.example.im"
|
||||
alice #$> ("/smp smp://1234-w==:password@smp1.example.im", id, "ok")
|
||||
alice #$> ("/smp", id, "smp://1234-w==:password@smp1.example.im")
|
||||
-- alice #$> ("/smp", id, "smp://1234-w==:password@smp1.example.im")
|
||||
alice ##> "/smp"
|
||||
alice <## "Your servers"
|
||||
alice <## " SMP servers"
|
||||
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset, disabled)"
|
||||
alice <## " smp://1234-w==:password@smp1.example.im"
|
||||
alice #$> ("/smp smp://2345-w==@smp2.example.im smp://3456-w==@smp3.example.im:5224", id, "ok")
|
||||
alice ##> "/smp"
|
||||
alice <## "smp://2345-w==@smp2.example.im"
|
||||
alice <## "smp://3456-w==@smp3.example.im:5224"
|
||||
alice #$> ("/smp default", id, "ok")
|
||||
alice #$> ("/smp", id, "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001")
|
||||
alice <## "Your servers"
|
||||
alice <## " SMP servers"
|
||||
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset, disabled)"
|
||||
alice <## " smp://2345-w==@smp2.example.im"
|
||||
alice <## " smp://3456-w==@smp3.example.im:5224"
|
||||
|
||||
testTestSMPServerConnection :: HasCallStack => FilePath -> IO ()
|
||||
testTestSMPServerConnection =
|
||||
@@ -1140,17 +1155,31 @@ testGetSetXFTPServers :: HasCallStack => FilePath -> IO ()
|
||||
testGetSetXFTPServers =
|
||||
testChat2 aliceProfile bobProfile $
|
||||
\alice _ -> withXFTPServer $ do
|
||||
alice #$> ("/_servers 1 xftp", id, "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002")
|
||||
alice ##> "/_servers 1"
|
||||
alice <## "Your servers"
|
||||
alice <## " SMP servers"
|
||||
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset)"
|
||||
alice <## " XFTP servers"
|
||||
alice <## " xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002 (preset)"
|
||||
alice #$> ("/xftp xftp://1234-w==@xftp1.example.im", id, "ok")
|
||||
alice #$> ("/xftp", id, "xftp://1234-w==@xftp1.example.im")
|
||||
alice ##> "/xftp"
|
||||
alice <## "Your servers"
|
||||
alice <## " XFTP servers"
|
||||
alice <## " xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002 (preset, disabled)"
|
||||
alice <## " xftp://1234-w==@xftp1.example.im"
|
||||
alice #$> ("/xftp xftp://1234-w==:password@xftp1.example.im", id, "ok")
|
||||
alice #$> ("/xftp", id, "xftp://1234-w==:password@xftp1.example.im")
|
||||
alice ##> "/xftp"
|
||||
alice <## "Your servers"
|
||||
alice <## " XFTP servers"
|
||||
alice <## " xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002 (preset, disabled)"
|
||||
alice <## " xftp://1234-w==:password@xftp1.example.im"
|
||||
alice #$> ("/xftp xftp://2345-w==@xftp2.example.im xftp://3456-w==@xftp3.example.im:5224", id, "ok")
|
||||
alice ##> "/xftp"
|
||||
alice <## "xftp://2345-w==@xftp2.example.im"
|
||||
alice <## "xftp://3456-w==@xftp3.example.im:5224"
|
||||
alice #$> ("/xftp default", id, "ok")
|
||||
alice #$> ("/xftp", id, "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002")
|
||||
alice <## "Your servers"
|
||||
alice <## " XFTP servers"
|
||||
alice <## " xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002 (preset, disabled)"
|
||||
alice <## " xftp://2345-w==@xftp2.example.im"
|
||||
alice <## " xftp://3456-w==@xftp3.example.im:5224"
|
||||
|
||||
testTestXFTPServer :: HasCallStack => FilePath -> IO ()
|
||||
testTestXFTPServer =
|
||||
@@ -1768,11 +1797,17 @@ testCreateUserSameServers =
|
||||
where
|
||||
checkCustomServers alice = do
|
||||
alice ##> "/smp"
|
||||
alice <## "smp://2345-w==@smp2.example.im"
|
||||
alice <## "smp://3456-w==@smp3.example.im:5224"
|
||||
alice <## "Your servers"
|
||||
alice <## " SMP servers"
|
||||
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset, disabled)"
|
||||
alice <## " smp://2345-w==@smp2.example.im"
|
||||
alice <## " smp://3456-w==@smp3.example.im:5224"
|
||||
alice ##> "/xftp"
|
||||
alice <## "xftp://2345-w==@xftp2.example.im"
|
||||
alice <## "xftp://3456-w==@xftp3.example.im:5224"
|
||||
alice <## "Your servers"
|
||||
alice <## " XFTP servers"
|
||||
alice <## " xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002 (preset, disabled)"
|
||||
alice <## " xftp://2345-w==@xftp2.example.im"
|
||||
alice <## " xftp://3456-w==@xftp3.example.im:5224"
|
||||
|
||||
testDeleteUser :: HasCallStack => FilePath -> IO ()
|
||||
testDeleteUser =
|
||||
|
||||
@@ -1,8 +1,10 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PostfixOperators #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module ChatTests.Groups where
|
||||
|
||||
|
||||
@@ -2,6 +2,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PostfixOperators #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module ChatTests.Profiles where
|
||||
|
||||
@@ -1733,7 +1734,16 @@ testChangePCCUserDiffSrv tmp = do
|
||||
-- Create new user with different servers
|
||||
alice ##> "/create user alisa"
|
||||
showActiveUser alice "alisa"
|
||||
alice #$> ("/smp smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7003", id, "ok")
|
||||
alice ##> "/smp"
|
||||
alice <## "Your servers"
|
||||
alice <## " SMP servers"
|
||||
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset)"
|
||||
alice #$> ("/smp smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@127.0.0.1:7003", id, "ok")
|
||||
alice ##> "/smp"
|
||||
alice <## "Your servers"
|
||||
alice <## " SMP servers"
|
||||
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset, disabled)"
|
||||
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@127.0.0.1:7003"
|
||||
alice ##> "/user alice"
|
||||
showActiveUser alice "alice (Alice)"
|
||||
-- Change connection to newly created user and use the newly created connection
|
||||
|
||||
+33
-20
@@ -1,51 +1,64 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module RandomServers where
|
||||
|
||||
import Control.Monad (replicateM)
|
||||
import Data.Foldable (foldMap')
|
||||
import Data.List (sortOn)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
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 Data.Monoid (Sum (..))
|
||||
import Simplex.Chat (defaultChatConfig, randomPresetServers)
|
||||
import Simplex.Chat.Controller (ChatConfig (..), PresetServers (..))
|
||||
import Simplex.Chat.Operators (DBEntityId' (..), NewUserServer, UserServer' (..), operatorServers, operatorServersToUse)
|
||||
import Simplex.Messaging.Agent.Env.SQLite (ServerRoles (..))
|
||||
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), SProtocolType (..), UserProtocol)
|
||||
import Test.Hspec
|
||||
|
||||
randomServersTests :: Spec
|
||||
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
|
||||
it "should choose 4 + 3 random SMP servers and keep the rest disabled" testRandomSMPServers
|
||||
it "should choose 3 + 3 random XFTP servers and keep the rest disabled" testRandomXFTPServers
|
||||
|
||||
deriving instance Eq (ServerCfg p)
|
||||
deriving instance Eq ServerRoles
|
||||
|
||||
deriving instance Eq (DBEntityId' s)
|
||||
|
||||
deriving instance Eq (UserServer' s p)
|
||||
|
||||
testRandomSMPServers :: IO ()
|
||||
testRandomSMPServers = do
|
||||
[srvs1, srvs2, srvs3] <-
|
||||
replicateM 3 $
|
||||
checkEnabled SPSMP 4 False =<< randomServers SPSMP defaultChatConfig
|
||||
checkEnabled SPSMP 7 False =<< randomPresetServers SPSMP (presetServers defaultChatConfig)
|
||||
(srvs1 == srvs2 && srvs2 == srvs3) `shouldBe` False -- && to avoid rare failures
|
||||
|
||||
testRandomXFTPServers :: IO ()
|
||||
testRandomXFTPServers = do
|
||||
[srvs1, srvs2, srvs3] <-
|
||||
replicateM 3 $
|
||||
checkEnabled SPXFTP 6 True =<< randomServers SPXFTP defaultChatConfig
|
||||
(srvs1 == srvs2 && srvs2 == srvs3) `shouldBe` True
|
||||
checkEnabled SPXFTP 6 False =<< randomPresetServers SPXFTP (presetServers defaultChatConfig)
|
||||
(srvs1 == srvs2 && srvs2 == srvs3) `shouldBe` False -- && to avoid rare failures
|
||||
|
||||
checkEnabled :: UserProtocol p => SProtocolType p -> Int -> Bool -> (L.NonEmpty (ServerCfg p), [ServerCfg p]) -> IO [ServerCfg p]
|
||||
checkEnabled p n allUsed (srvs, _) = do
|
||||
let def = defaultServers defaultChatConfig
|
||||
cfgSrvs = L.sortWith server' $ cfgServers p def
|
||||
toUse = cfgServersToUse p def
|
||||
srvs == cfgSrvs `shouldBe` allUsed
|
||||
L.map enable srvs `shouldBe` L.map enable cfgSrvs
|
||||
let enbldSrvs = L.filter (\ServerCfg {enabled} -> enabled) srvs
|
||||
checkEnabled :: UserProtocol p => SProtocolType p -> Int -> Bool -> NonEmpty (NewUserServer p) -> IO [NewUserServer p]
|
||||
checkEnabled p n allUsed srvs = do
|
||||
let srvs' = sortOn server' $ L.toList srvs
|
||||
PresetServers {operators = presetOps} = presetServers defaultChatConfig
|
||||
presetSrvs = sortOn server' $ concatMap (operatorServers p) presetOps
|
||||
Sum toUse = foldMap' (Sum . operatorServersToUse p) presetOps
|
||||
srvs' == presetSrvs `shouldBe` allUsed
|
||||
map enable srvs' `shouldBe` map enable presetSrvs
|
||||
let enbldSrvs = filter (\UserServer {enabled} -> enabled) srvs'
|
||||
toUse `shouldBe` n
|
||||
length enbldSrvs `shouldBe` n
|
||||
pure enbldSrvs
|
||||
where
|
||||
server' ServerCfg {server = ProtoServerWithAuth srv _} = srv
|
||||
enable :: forall p. ServerCfg p -> ServerCfg p
|
||||
enable srv = (srv :: ServerCfg p) {enabled = False}
|
||||
server' UserServer {server = ProtoServerWithAuth srv _} = srv
|
||||
enable :: forall p. NewUserServer p -> NewUserServer p
|
||||
enable srv = (srv :: NewUserServer p) {enabled = False}
|
||||
|
||||
Reference in New Issue
Block a user