core: preset operators and servers (#5142)

* core: preset servers and operators (WIP)

* usageConditionsToAdd

* simplify

* WIP

* database entity IDs

* preset operators and servers (compiles)

* update (most tests pass)

* remove imports

* fix

* update

* make preset servers lists potentially empty in some operators, as long as the combined list is not empty

* CLI API in progress, validateUserServers

* make servers of disabled operators "unknown", consider only enabled servers when switching profile links

* exclude disabled operators when receiving files

* fix TH in ghc 8.10.7

* add type for ghc 8.10.7

* pattern match for ghc 8.10.7

* ghc 8.10.7 fix attempt

* remove additional pattern, update servers

* do not strip title from conditions

* remove space

---------

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
This commit is contained in:
Evgeny
2024-11-14 17:43:34 +00:00
committed by GitHub
parent 807f698cf2
commit d42cab8e22
21 changed files with 1148 additions and 649 deletions
+1 -1
View File
@@ -12,7 +12,7 @@ constraints: zip +disable-bzip2 +disable-zstd
source-repository-package
type: git
location: https://github.com/simplex-chat/simplexmq.git
tag: ff05a465ee15ac7ae2c14a9fb703a18564950631
tag: 93f30c8edf9243ad2291dd6427d87328e282560a
source-repository-package
type: git
+2 -1
View File
@@ -39,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.*
@@ -73,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 -1
View File
@@ -1,5 +1,5 @@
{
"https://github.com/simplex-chat/simplexmq.git"."ff05a465ee15ac7ae2c14a9fb703a18564950631" = "1gv4nwqzbqkj7y3ffkiwkr4qwv52vdzppsds5vsfqaayl14rzmgp";
"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";
+14 -7
View File
@@ -228,6 +228,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.*
@@ -254,7 +255,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
@@ -292,6 +293,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
@@ -319,7 +321,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
@@ -357,6 +359,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
@@ -384,7 +387,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
@@ -425,6 +428,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
@@ -452,7 +456,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
@@ -491,6 +495,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
@@ -519,7 +524,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
@@ -563,6 +568,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
@@ -590,7 +596,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
@@ -664,6 +670,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
@@ -692,7 +699,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.*
+273 -176
View File
@@ -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)
@@ -98,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 (..), OperatorId, ServerCfg (..), allRoles, 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 (..))
@@ -138,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
}
operatorFlux :: NewServerOperator
operatorFlux =
ServerOperator
{ operatorId = DBNewEntity,
operatorTag = Just OTFlux,
tradeName = "Flux",
legalName = Just "InFlux Technologies Limited",
serverDomains = ["simplexonflux.com"],
conditionsAcceptance = CARequired Nothing,
enabled = False,
roles = ServerRoles {storage = False, proxy = True}
}
defaultChatConfig :: ChatConfig
defaultChatConfig =
ChatConfig
@@ -148,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 operatorFlux,
smp = fluxSMPServers,
useSMP = 3,
xftp = fluxXFTPServers,
useXFTP = 3
}
],
ntf = _defaultNtfServers,
xftp = L.map (presetServerCfg True allRoles operatorSimpleXChat) defaultXFTPServers,
useXFTP = L.length defaultXFTPServers,
netCfg = defaultNetworkConfig
},
tbqSize = 1024,
@@ -178,32 +218,52 @@ defaultChatConfig =
chatHooks = defaultChatHooks
}
_defaultSMPServers :: NonEmpty (ServerCfg 'PSMP)
_defaultSMPServers =
L.fromList $
map
(presetServerCfg True allRoles operatorSimpleXChat)
[ "smp://0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU=@smp8.simplex.im,beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion",
"smp://SkIkI6EPd2D63F4xFKfHk7I1UGZVNn6k1QWZ5rcyr6w=@smp9.simplex.im,jssqzccmrcws6bhmn77vgmhfjmhwlyr3u7puw4erkyoosywgl67slqqd.onion",
"smp://6iIcWT_dF2zN_w5xzZEY7HI2Prbh3ldP07YTyDexPjE=@smp10.simplex.im,rb2pbttocvnbrngnwziclp2f4ckjq65kebafws6g4hy22cdaiv5dwjqd.onion",
"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 allRoles operatorSimpleXChat)
[ "smp://u2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU=@smp4.simplex.im,o5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion",
"smp://hpq7_4gGJiilmz5Rf-CswuU5kZGkm_zOIooSw6yALRg=@smp5.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion",
"smp://PQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo=@smp6.simplex.im,bylepyau3ty4czmn77q4fglvperknl4bi2eb2fdy2bh4jxtf32kf73yd.onion"
]
operatorSimpleXChat :: Maybe OperatorId
operatorSimpleXChat = Just 1
fluxSMPServers :: [NewUserServer 'PSMP]
fluxSMPServers =
map
(presetServer True)
[ "smp://xQW_ufMkGE20UrTlBl8QqceG1tbuylXhr9VOLPyRJmw=@smp1.simplexonflux.com,qb4yoanyl4p7o33yrknv4rs6qo7ugeb2tu2zo66sbebezs4cpyosarid.onion",
"smp://LDnWZVlAUInmjmdpQQoIo6FUinRXGe0q3zi5okXDE4s=@smp2.simplexonflux.com,yiqtuh3q4x7hgovkomafsod52wvfjucdljqbbipg5sdssnklgongxbqd.onion",
"smp://1jne379u7IDJSxAvXbWb_JgoE7iabcslX0LBF22Rej0=@smp3.simplexonflux.com,a5lm4k7ufei66cdck6fy63r4lmkqy3dekmmb7jkfdm5ivi6kfaojshad.onion",
"smp://xmAmqj75I9mWrUihLUlI0ZuNLXlIwFIlHRq5Pb6cHAU=@smp4.simplexonflux.com,qpcz2axyy66u26hfdd2e23uohcf3y6c36mn7dcuilcgnwjasnrvnxjqd.onion",
"smp://rWvBYyTamuRCBYb_KAn-nsejg879ndhiTg5Sq3k0xWA=@smp5.simplexonflux.com,4ao347qwiuluyd45xunmii4skjigzuuox53hpdsgbwxqafd4yrticead.onion",
"smp://PN7-uqLBToqlf1NxHEaiL35lV2vBpXq8Nj8BW11bU48=@smp6.simplexonflux.com,hury6ot3ymebbr2535mlp7gcxzrjpc6oujhtfxcfh2m4fal4xw5fq6qd.onion"
]
fluxXFTPServers :: [NewUserServer 'PXFTP]
fluxXFTPServers =
map
(presetServer True)
[ "xftp://92Sctlc09vHl_nAqF2min88zKyjdYJ9mgxRCJns5K2U=@xftp1.simplexonflux.com,apl3pumq3emwqtrztykyyoomdx4dg6ysql5zek2bi3rgznz7ai3odkid.onion",
"xftp://YBXy4f5zU1CEhnbbCzVWTNVNsaETcAGmYqGNxHntiE8=@xftp2.simplexonflux.com,c5jjecisncnngysah3cz2mppediutfelco4asx65mi75d44njvua3xid.onion",
"xftp://ARQO74ZSvv2OrulRF3CdgwPz_AMy27r0phtLSq5b664=@xftp3.simplexonflux.com,dc4mohiubvbnsdfqqn7xhlhpqs5u4tjzp7xpz6v6corwvzvqjtaqqiqd.onion",
"xftp://ub2jmAa9U0uQCy90O-fSUNaYCj6sdhl49Jh3VpNXP58=@xftp4.simplexonflux.com,4qq5pzier3i4yhpuhcrhfbl6j25udc4czoyascrj4yswhodhfwev3nyd.onion",
"xftp://Rh19D5e4Eez37DEE9hAlXDB3gZa1BdFYJTPgJWPO9OI=@xftp5.simplexonflux.com,q7itltdn32hjmgcqwhow4tay5ijetng3ur32bolssw32fvc5jrwvozad.onion",
"xftp://0AznwoyfX8Od9T_acp1QeeKtxUi676IBIiQjXVwbdyU=@xftp6.simplexonflux.com,upvzf23ou6nrmaf3qgnhd6cn3d74tvivlmz3p7wdfwq6fhthjrjiiqid.onion"
]
_defaultNtfServers :: [NtfServer]
_defaultNtfServers =
@@ -240,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
@@ -285,6 +348,7 @@ newChatController
ChatController
{ firstTime,
currentUser,
randomServers,
currentRemoteHost,
smpAgent,
agentAsync,
@@ -322,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} =
@@ -386,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 ())
@@ -556,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
@@ -577,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
@@ -1486,57 +1564,67 @@ 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
srvs <- withFastStore' (`getProtocolServers` user)
(operators, _) <- withFastStore $ \db -> getServerOperators db
let servers = AUPS $ UserProtoServers p (useServers cfg p srvs) (cfgServers p defaultServers)
pure $ CRUserProtoServers {user, servers, operators}
GetUserProtoServers aProtocol -> withUser $ \User {userId} ->
processChatCommand $ APIGetUserProtoServers userId aProtocol
APISetUserProtoServers userId (APSC p (ProtoServersConfig servers))
| 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
srvs <- withFastStore (`getUserServers` user)
CRUserServers user <$> liftIO (groupedServers srvs p)
where
groupedServers :: UserProtocol p => ([ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP]) -> SProtocolType p -> IO [UserOperatorServers]
groupedServers (operators, smpServers, xftpServers) = \case
SPSMP -> groupByOperator (operators, smpServers, [])
SPXFTP -> groupByOperator (operators, [], xftpServers)
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 p) userServers
where
-- disable preset and replace custom servers (groupByOperator always adds custom)
updatedSrvs :: UserProtocol p => SProtocolType p -> UserOperatorServers -> UpdatedUserOperatorServers
updatedSrvs p' 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 -> do
(operators, conditionsAction) <- withFastStore $ \db -> getServerOperators db
pure $ CRServerOperators operators conditionsAction
APISetServerOperators operatorsEnabled -> do
(operators, conditionsAction) <- withFastStore $ \db -> setServerOperators db operatorsEnabled
pure $ CRServerOperators operators conditionsAction
APIGetUserServers userId -> withUserId userId $ \user -> do
(operators, smpServers, xftpServers) <- withFastStore $ \db -> do
(operators, _) <- getServerOperators db
smpServers <- liftIO $ getServers db user SPSMP
xftpServers <- liftIO $ getServers db user SPXFTP
pure (operators, smpServers, xftpServers)
let userServers = groupByOperator operators smpServers xftpServers
pure $ CRUserServers user userServers
where
getServers :: ProtocolTypeI p => DB.Connection -> User -> SProtocolType p -> IO [ServerCfg p]
getServers db user _p = getProtocolServers db user
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)
withFastStore $ \db -> setUserServers db user userServers
-- TODO set protocol servers for agent
(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 -> do
let errors = validateUserServers userServers
pure $ CRUserServersValidation errors
APIValidateServers userServers -> pure $ CRUserServersValidation $ validateUserServers userServers
APIGetUsageConditions -> do
(usageConditions, acceptedConditions) <- withFastStore $ \db -> do
usageConditions <- getCurrentUsageConditions db
acceptedConditions <- getLatestAcceptedConditions db
acceptedConditions <- liftIO $ getLatestAcceptedConditions db
pure (usageConditions, acceptedConditions)
-- TODO if db commit is different from source commit, conditionsText should be nothing in response
pure
@@ -1545,14 +1633,14 @@ processChatCommand' vr = \case
conditionsText = usageConditionsText,
acceptedConditions
}
APISetConditionsNotified conditionsId -> do
APISetConditionsNotified condId -> do
currentTs <- liftIO getCurrentTime
withFastStore' $ \db -> setConditionsNotified db conditionsId currentTs
withFastStore' $ \db -> setConditionsNotified db condId currentTs
ok_
APIAcceptConditions conditionsId operators -> do
APIAcceptConditions condId opIds -> withFastStore $ \db -> do
currentTs <- liftIO getCurrentTime
(operators', conditionsAction) <- withFastStore $ \db -> acceptConditions db conditionsId operators currentTs
pure $ CRServerOperators operators' conditionsAction
acceptConditions db condId opIds currentTs
uncurry CRServerOperators <$> getServerOperators db
APISetChatItemTTL userId newTTL_ -> withUserId userId $ \user ->
checkStoreNotChanged $
withChatLock "setChatItemTTL" $ do
@@ -1805,8 +1893,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)
@@ -2140,7 +2229,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
@@ -2538,14 +2627,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
@@ -3663,8 +3753,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
@@ -3678,6 +3767,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
@@ -3876,7 +3976,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
@@ -4684,7 +4784,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 ->
@@ -4969,7 +5069,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
@@ -5095,7 +5195,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 ->
@@ -6659,15 +6759,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 ()
@@ -8132,22 +8234,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),
"/_user_servers " *> (APIGetUserServers <$> A.decimal),
"/_user_servers " *> (APISetUserServers <$> A.decimal <* A.space <*> 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 <* A.space <*> jsonP),
"/_accept_conditions " *> (APIAcceptConditions <$> A.decimal <*> _strP),
"/_ttl " *> (APISetChatItemTTL <$> A.decimal <* A.space <*> ciTTLDecimal),
"/ttl " *> (SetChatItemTTL <$> ciTTL),
"/_ttl " *> (APIGetChatItemTTL <$> A.decimal),
@@ -8491,7 +8589,6 @@ chatCommandP =
onOffP
(Just <$> (AutoAccept <$> (" incognito=" *> onOffP <|> pure False) <*> optional (A.space *> msgContentP)))
(pure Nothing)
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
+48 -48
View File
@@ -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)
@@ -71,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)
@@ -85,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)
@@ -133,7 +132,7 @@ data ChatConfig = ChatConfig
{ agentConfig :: AgentConfig,
chatVRange :: VersionRangeChat,
confirmMigrations :: MigrationConfirmation,
defaultServers :: DefaultAgentServers,
presetServers :: PresetServers,
tbqSize :: Natural,
fileChunkSize :: Integer,
xftpDescrPartSize :: Int,
@@ -155,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.
@@ -173,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
}
@@ -204,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,
@@ -347,20 +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 OperatorEnabled)
| APISetServerOperators (NonEmpty ServerOperator)
| APIGetUserServers UserId
| APISetUserServers UserId (NonEmpty UserServers)
| APIValidateServers (NonEmpty UserServers) -- response is CRUserServersValidation
| APISetUserServers UserId (NonEmpty UpdatedUserOperatorServers)
| APIValidateServers (NonEmpty UpdatedUserOperatorServers) -- response is CRUserServersValidation
| APIGetUsageConditions
| APISetConditionsNotified Int64
| APIAcceptConditions Int64 (NonEmpty ServerOperator)
| APIAcceptConditions Int64 (NonEmpty Int64)
| APISetChatItemTTL UserId (Maybe Int64)
| SetChatItemTTL (Maybe Int64)
| APIGetChatItemTTL UserId
@@ -586,10 +587,9 @@ data ChatResponse
| CRChatItemInfo {user :: User, chatItem :: AChatItem, chatItemInfo :: ChatItemInfo}
| CRChatItemId User (Maybe ChatItemId)
| CRApiParsedMarkdown {formattedText :: Maybe MarkdownList}
| CRUserProtoServers {user :: User, servers :: AUserProtoServers, operators :: [ServerOperator]}
| CRServerTestResult {user :: User, testServer :: AProtoServerWithAuth, testFailure :: Maybe ProtocolTestFailure}
| CRServerOperators {operators :: [ServerOperator], conditionsAction :: Maybe UsageConditionsAction}
| CRUserServers {user :: User, userServers :: [UserServers]}
| CRUserServers {user :: User, userServers :: [UserOperatorServers]}
| CRUserServersValidation {serverErrors :: [UserServersError]}
| CRUsageConditions {usageConditions :: UsageConditions, conditionsText :: Text, acceptedConditions :: Maybe UsageConditions}
| CRChatItemTTL {user :: User, chatItemTTL :: Maybe Int64}
@@ -956,23 +956,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)
@@ -1575,28 +1575,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)
@@ -11,7 +11,6 @@ m20241027_server_operators =
CREATE TABLE server_operators (
server_operator_id INTEGER PRIMARY KEY AUTOINCREMENT,
server_operator_tag TEXT,
app_vendor INTEGER NOT NULL,
trade_name TEXT NOT NULL,
legal_name TEXT,
server_domains TEXT,
@@ -22,8 +21,6 @@ CREATE TABLE server_operators (
updated_at TEXT NOT NULL DEFAULT (datetime('now'))
);
ALTER TABLE protocol_servers ADD COLUMN server_operator_id INTEGER REFERENCES server_operators ON DELETE SET NULL;
CREATE TABLE usage_conditions (
usage_conditions_id INTEGER PRIMARY KEY AUTOINCREMENT,
conditions_commit TEXT NOT NULL UNIQUE,
@@ -41,18 +38,8 @@ CREATE TABLE operator_usage_conditions (
created_at TEXT NOT NULL DEFAULT (datetime('now'))
);
CREATE INDEX idx_protocol_servers_server_operator_id ON protocol_servers(server_operator_id);
CREATE INDEX idx_operator_usage_conditions_server_operator_id ON operator_usage_conditions(server_operator_id);
CREATE UNIQUE INDEX idx_operator_usage_conditions_conditions_commit ON operator_usage_conditions(server_operator_id, conditions_commit);
INSERT INTO server_operators
(server_operator_id, server_operator_tag, app_vendor, trade_name, legal_name, server_domains, enabled)
VALUES (1, 'simplex', 1, 'SimpleX Chat', 'SimpleX Chat Ltd', 'simplex.im', 1);
INSERT INTO server_operators
(server_operator_id, server_operator_tag, app_vendor, trade_name, legal_name, server_domains, enabled)
VALUES (2, 'xyz', 0, 'XYZ', 'XYZ Ltd', 'xyz.com', 0);
-- UPDATE protocol_servers SET server_operator_id = 1 WHERE host LIKE "%.simplex.im" OR host LIKE "%.simplex.im,%";
CREATE UNIQUE INDEX idx_operator_usage_conditions_conditions_commit ON operator_usage_conditions(conditions_commit, server_operator_id);
|]
down_m20241027_server_operators :: Query
@@ -60,9 +47,6 @@ down_m20241027_server_operators =
[sql|
DROP INDEX idx_operator_usage_conditions_conditions_commit;
DROP INDEX idx_operator_usage_conditions_server_operator_id;
DROP INDEX idx_protocol_servers_server_operator_id;
ALTER TABLE protocol_servers DROP COLUMN server_operator_id;
DROP TABLE operator_usage_conditions;
DROP TABLE usage_conditions;
+2 -7
View File
@@ -450,7 +450,6 @@ CREATE TABLE IF NOT EXISTS "protocol_servers"(
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now')),
protocol TEXT NOT NULL DEFAULT 'smp',
server_operator_id INTEGER REFERENCES server_operators ON DELETE SET NULL,
UNIQUE(user_id, host, port)
);
CREATE TABLE xftp_file_descriptions(
@@ -593,7 +592,6 @@ CREATE TABLE app_settings(app_settings TEXT NOT NULL);
CREATE TABLE server_operators(
server_operator_id INTEGER PRIMARY KEY AUTOINCREMENT,
server_operator_tag TEXT,
app_vendor INTEGER NOT NULL,
trade_name TEXT NOT NULL,
legal_name TEXT,
server_domains TEXT,
@@ -919,13 +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_protocol_servers_server_operator_id ON protocol_servers(
server_operator_id
);
CREATE INDEX idx_operator_usage_conditions_server_operator_id ON operator_usage_conditions(
server_operator_id
);
CREATE UNIQUE INDEX idx_operator_usage_conditions_conditions_commit ON operator_usage_conditions(
server_operator_id,
conditions_commit
conditions_commit,
server_operator_id
);
+315 -81
View File
@@ -1,24 +1,42 @@
{-# 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)
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 (..))
@@ -26,23 +44,51 @@ import Database.SQLite.Simple.ToField (ToField (..))
import Language.Haskell.TH.Syntax (lift)
import Simplex.Chat.Operators.Conditions
import Simplex.Chat.Types.Util (textParseJSON)
import Simplex.Messaging.Agent.Env.SQLite (OperatorId, ServerCfg (..), ServerRoles (..))
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 (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), SProtocolType (..))
import Simplex.Messaging.Util (safeDecodeUtf8)
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"
usageConditionsCommit = "a5061f3147165a05979d6ace33960aced2d6ac03"
previousConditionsCommit :: Text
previousConditionsCommit = "11a44dc1fd461a93079f897048b46998db55da5c"
usageConditionsText :: Text
usageConditionsText =
$( let s = $(embedFile =<< makeRelativeToProject "PRIVACY.md")
in [|stripFrontMatter (safeDecodeUtf8 $(lift s))|]
in [|stripFrontMatter $(lift (safeDecodeUtf8 s))|]
)
data OperatorTag = OTSimplex | OTXyz
deriving (Show)
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 | OTFlux
deriving (Eq, Ord, Show)
instance FromField OperatorTag where fromField = fromTextField_ textDecode
@@ -58,11 +104,17 @@ instance ToJSON OperatorTag where
instance TextEncoding OperatorTag where
textDecode = \case
"simplex" -> Just OTSimplex
"xyz" -> Just OTXyz
"flux" -> Just OTFlux
_ -> Nothing
textEncode = \case
OTSimplex -> "simplex"
OTXyz -> "xyz"
OTFlux -> "flux"
-- 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,
@@ -80,18 +132,16 @@ data UsageConditionsAction
usageConditionsAction :: [ServerOperator] -> UsageConditions -> UTCTime -> Maybe UsageConditionsAction
usageConditionsAction operators UsageConditions {createdAt, notifiedAt} now = do
let enabledOperators = filter (\ServerOperator {enabled} -> enabled) operators
if null enabledOperators
then Nothing
else
if all conditionsAccepted enabledOperators
then
let acceptedForOperators = filter conditionsAccepted operators
in Just $ UCAAccepted acceptedForOperators
else
let acceptForOperators = filter (not . conditionsAccepted) enabledOperators
deadline = conditionsRequiredOrDeadline createdAt (fromMaybe now notifiedAt)
showNotice = isNothing notifiedAt
in Just $ UCAReview acceptForOperators deadline showNotice
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 =
@@ -107,8 +157,16 @@ data ConditionsAcceptance
| CARequired {deadline :: Maybe UTCTime}
deriving (Show)
data ServerOperator = ServerOperator
{ operatorId :: OperatorId,
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,
@@ -124,81 +182,257 @@ conditionsAccepted ServerOperator {conditionsAcceptance} = case conditionsAccept
CAAccepted {} -> True
_ -> False
data OperatorEnabled = OperatorEnabled
{ operatorId :: OperatorId,
enabled :: Bool,
roles :: ServerRoles
}
deriving (Show)
data UserServers = UserServers
data UserOperatorServers = UserOperatorServers
{ operator :: Maybe ServerOperator,
smpServers :: [ServerCfg 'PSMP],
xftpServers :: [ServerCfg 'PXFTP]
smpServers :: [UserServer 'PSMP],
xftpServers :: [UserServer 'PXFTP]
}
deriving (Show)
groupByOperator :: [ServerOperator] -> [ServerCfg 'PSMP] -> [ServerCfg 'PXFTP] -> [UserServers]
groupByOperator srvOperators smpSrvs xftpSrvs =
map createOperatorServers (M.toList combinedMap)
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
srvOperatorId ServerCfg {operator} = operator
opId ServerOperator {operatorId} = operatorId
operatorMap :: Map (Maybe Int64) (Maybe ServerOperator)
operatorMap = M.fromList [(Just (opId op), Just op) | op <- srvOperators] `M.union` M.singleton Nothing Nothing
initialMap :: Map (Maybe Int64) ([ServerCfg 'PSMP], [ServerCfg 'PXFTP])
initialMap = M.fromList [(key, ([], [])) | key <- M.keys operatorMap]
smpsMap = foldr (\server acc -> M.adjust (\(smps, xftps) -> (server : smps, xftps)) (srvOperatorId server) acc) initialMap smpSrvs
combinedMap = foldr (\server acc -> M.adjust (\(smps, xftps) -> (smps, server : xftps)) (srvOperatorId server) acc) smpsMap xftpSrvs
createOperatorServers (key, (groupedSmps, groupedXftps)) =
UserServers
{ operator = fromMaybe Nothing (M.lookup key operatorMap),
smpServers = groupedSmps,
xftpServers = groupedXftps
}
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
| USEProxyMissing
| USEDuplicateSMP {server :: AProtoServerWithAuth}
| USEDuplicateXFTP {server :: AProtoServerWithAuth}
= USEStorageMissing {protocol :: AProtocolType}
| USEProxyMissing {protocol :: AProtocolType}
| USEDuplicateServer {protocol :: AProtocolType, duplicateServer :: AProtoServerWithAuth, duplicateHost :: TransportHost}
deriving (Show)
validateUserServers :: NonEmpty UserServers -> [UserServersError]
validateUserServers userServers =
let storageMissing_ = if any (canUseForRole storage) userServers then [] else [USEStorageMissing]
proxyMissing_ = if any (canUseForRole proxy) userServers then [] else [USEProxyMissing]
allSMPServers = map (\ServerCfg {server} -> server) $ concatMap (\UserServers {smpServers} -> smpServers) userServers
duplicateSMPServers = findDuplicatesByHost allSMPServers
duplicateSMPErrors = map (USEDuplicateSMP . AProtoServerWithAuth SPSMP) duplicateSMPServers
allXFTPServers = map (\ServerCfg {server} -> server) $ concatMap (\UserServers {xftpServers} -> xftpServers) userServers
duplicateXFTPServers = findDuplicatesByHost allXFTPServers
duplicateXFTPErrors = map (USEDuplicateXFTP . AProtoServerWithAuth SPXFTP) duplicateXFTPServers
in storageMissing_ <> proxyMissing_ <> duplicateSMPErrors <> duplicateXFTPErrors
validateUserServers :: NonEmpty UpdatedUserOperatorServers -> [UserServersError]
validateUserServers uss =
missingRolesErr SPSMP storage USEStorageMissing
<> missingRolesErr SPSMP proxy USEProxyMissing
<> missingRolesErr SPXFTP storage USEStorageMissing
<> duplicatServerErrs SPSMP
<> duplicatServerErrs SPXFTP
where
canUseForRole :: (ServerRoles -> Bool) -> UserServers -> Bool
canUseForRole roleSel UserServers {operator, smpServers, xftpServers} = case operator of
Just ServerOperator {roles} -> roleSel roles
Nothing -> not (null smpServers) && not (null xftpServers)
findDuplicatesByHost :: [ProtoServerWithAuth p] -> [ProtoServerWithAuth p]
findDuplicatesByHost servers =
let allHosts = concatMap (L.toList . host . protoServer) servers
hostCounts = M.fromListWith (+) [(host, 1 :: Int) | host <- allHosts]
duplicateHosts = M.keys $ M.filter (> 1) hostCounts
in filter (\srv -> any (`elem` duplicateHosts) (L.toList $ host . protoServer $ srv)) servers
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)
$(JQ.deriveJSON defaultJSON ''ServerOperator)
instance ToJSON (ServerOperator' s) where
toEncoding = $(JQ.mkToEncoding defaultJSON ''ServerOperator')
toJSON = $(JQ.mkToJSON defaultJSON ''ServerOperator')
$(JQ.deriveJSON defaultJSON ''OperatorEnabled)
instance DBStoredI s => FromJSON (ServerOperator' s) where
parseJSON = $(JQ.mkParseJSON defaultJSON ''ServerOperator')
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "UCA") ''UsageConditionsAction)
$(JQ.deriveJSON defaultJSON ''UserServers)
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)
+1 -1
View File
@@ -9,7 +9,7 @@ import qualified Data.Text as T
stripFrontMatter :: Text -> Text
stripFrontMatter =
T.unlines
. dropWhile ("# " `T.isPrefixOf`) -- strip title
-- . 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')
+1 -2
View File
@@ -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
+265 -213
View File
@@ -1,5 +1,8 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
@@ -47,9 +50,13 @@ module Simplex.Chat.Store.Profiles
getContactWithoutConnViaAddress,
updateUserAddressAutoAccept,
getProtocolServers,
getUpdateUserServers,
-- overwriteOperatorsAndServers,
overwriteProtocolServers,
insertProtocolServer,
getUpdateServerOperators,
getServerOperators,
getUserServers,
setServerOperators,
getCurrentUsageConditions,
getLatestAcceptedConditions,
@@ -77,10 +84,11 @@ import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Maybe (fromMaybe)
import Data.Text (Text, splitOn)
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
@@ -92,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 (OperatorId, ServerCfg (..), ServerRoles (..))
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
@@ -100,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)
@@ -524,177 +532,282 @@ 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 s.host, s.port, s.key_hash, s.basic_auth, s.server_operator_id, s.preset, s.tested, s.enabled, o.role_storage, o.role_proxy
FROM protocol_servers s
LEFT JOIN server_operators o USING (server_operator_id)
WHERE s.user_id = ? AND s.protocol = ?
SELECT smp_server_id, host, port, key_hash, basic_auth, preset, tested, enabled
FROM protocol_servers
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, Maybe OperatorId, Bool, Maybe Bool, Bool, Maybe Bool, Maybe Bool) -> ServerCfg p
toServerCfg (host, port, keyHash, auth_, operator, preset, tested, enabled, storage_, proxy_) =
let server = ProtoServerWithAuth (ProtocolServer protocol host port keyHash) (BasicAuth . encodeUtf8 <$> auth_)
roles = ServerRoles {storage = fromMaybe True storage_, proxy = fromMaybe True proxy_}
in ServerCfg {server, operator, preset, tested, enabled, roles}
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}
-- 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 :: forall p. ProtocolTypeI p => DB.Connection -> User -> [ServerCfg p] -> ExceptT StoreError IO ()
overwriteProtocolServers db User {userId} servers =
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))
-- Right <$> getProtocolServers db user
(Only serverId :. serverColumns p server :. (preset, tested, enabled, userId, currentTs, currentTs))
pure $ Right ()
where
protocol = decodeLatin1 $ strEncode $ protocolTypeI @p
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
now <- liftIO getCurrentTime
currentConditions <- getCurrentUsageConditions db
latestAcceptedConditions <- getLatestAcceptedConditions db
operators <-
liftIO $
map (toOperator now currentConditions latestAcceptedConditions)
<$> DB.query_
db
[sql|
SELECT
so.server_operator_id, so.server_operator_tag, so.trade_name, so.legal_name,
so.server_domains, so.enabled, so.role_storage, so.role_proxy,
AcceptedConditions.conditions_commit, AcceptedConditions.accepted_at
FROM server_operators so
LEFT JOIN (
SELECT server_operator_id, conditions_commit, accepted_at, MAX(operator_usage_conditions_id)
FROM operator_usage_conditions
GROUP BY server_operator_id
) AcceptedConditions ON AcceptedConditions.server_operator_id = so.server_operator_id
|]
pure (operators, usageConditionsAction operators currentConditions now)
where
toOperator ::
UTCTime ->
UsageConditions ->
Maybe UsageConditions ->
( (OperatorId, Maybe OperatorTag, Text, Maybe Text, Text, Bool, Bool, Bool)
:. (Maybe Text, Maybe UTCTime)
) ->
ServerOperator
toOperator
now
UsageConditions {conditionsCommit = currentCommit, createdAt, notifiedAt}
latestAcceptedConditions_
( (operatorId, operatorTag, tradeName, legalName, domains, enabled, storage, proxy)
:. (operatorCommit_, acceptedAt_)
) =
let roles = ServerRoles {storage, proxy}
serverDomains = splitOn "," domains
conditionsAcceptance = case (latestAcceptedConditions_, operatorCommit_) of
-- no conditions were ever accepted for any operator(s)
-- (shouldn't happen as there should always be record for SimpleX Chat)
(Nothing, _) -> CARequired Nothing
-- no conditions were ever accepted for this operator
(_, Nothing) -> CARequired Nothing
(Just UsageConditions {conditionsCommit = latestAcceptedCommit}, Just operatorCommit)
| latestAcceptedCommit == currentCommit ->
if operatorCommit == latestAcceptedCommit
then -- current conditions were accepted for operator
CAAccepted acceptedAt_
else -- current conditions were NOT accepted for operator, but were accepted for other operator(s)
CARequired Nothing
| otherwise ->
if operatorCommit == latestAcceptedCommit
then -- new conditions available, latest accepted conditions were accepted for operator
CARequired $ conditionsRequiredOrDeadline createdAt (fromMaybe now notifiedAt)
else -- new conditions available, latest accepted conditions were NOT accepted for operator (were accepted for other operator(s))
CARequired Nothing
in ServerOperator {operatorId, operatorTag, tradeName, legalName, serverDomains, conditionsAcceptance, enabled, roles}
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)
setServerOperators :: DB.Connection -> NonEmpty OperatorEnabled -> ExceptT StoreError IO ([ServerOperator], Maybe UsageConditionsAction)
setServerOperators db operatorsEnabled = do
liftIO $ forM_ operatorsEnabled $ \OperatorEnabled {operatorId, enabled, roles = ServerRoles {storage, proxy}} ->
DB.execute
db
"UPDATE server_operators SET enabled = ?, role_storage = ?, role_proxy = ? WHERE server_operator_id = ?"
(enabled, storage, proxy, operatorId)
getServerOperators db
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
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
[sql|
SELECT usage_conditions_id, conditions_commit, notified_at, created_at
FROM usage_conditions
ORDER BY usage_conditions_id DESC LIMIT 1
|]
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 -> ExceptT StoreError IO (Maybe UsageConditions)
getLatestAcceptedConditions db = do
(latestAcceptedCommit_ :: Maybe Text) <-
liftIO $
maybeFirstRow fromOnly $
DB.query_
db
[sql|
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
|]
forM latestAcceptedCommit_ $ \latestAcceptedCommit ->
ExceptT . firstRow toUsageConditions SEUsageConditionsNotFound $
DB.query
db
[sql|
SELECT usage_conditions_id, conditions_commit, notified_at, created_at
FROM usage_conditions
WHERE conditions_commit = ?
|]
(Only latestAcceptedCommit)
)
|]
setConditionsNotified :: DB.Connection -> Int64 -> UTCTime -> IO ()
setConditionsNotified db conditionsId notifiedAt =
DB.execute db "UPDATE usage_conditions SET notified_at = ? WHERE usage_conditions_id = ?" (notifiedAt, conditionsId)
setConditionsNotified db condId notifiedAt =
DB.execute db "UPDATE usage_conditions SET notified_at = ? WHERE usage_conditions_id = ?" (notifiedAt, condId)
acceptConditions :: DB.Connection -> Int64 -> NonEmpty ServerOperator -> UTCTime -> ExceptT StoreError IO ([ServerOperator], Maybe UsageConditionsAction)
acceptConditions db conditionsId operators acceptedAt = do
UsageConditions {conditionsCommit} <- getUsageConditionsById_ db conditionsId
liftIO $ forM_ operators $ \ServerOperator {operatorId, operatorTag} ->
DB.execute
db
[sql|
INSERT INTO operator_usage_conditions
(server_operator_id, server_operator_tag, conditions_commit, accepted_at)
VALUES (?,?,?,?)
|]
(operatorId, operatorTag, conditionsCommit, acceptedAt)
getServerOperators db
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 =
@@ -708,83 +821,22 @@ getUsageConditionsById_ db conditionsId =
|]
(Only conditionsId)
setUserServers :: DB.Connection -> User -> NonEmpty UserServers -> ExceptT StoreError IO ()
setUserServers db User {userId} userServers = do
currentTs <- liftIO getCurrentTime
forM_ userServers $ do
\UserServers {operator, smpServers, xftpServers} -> do
forM_ operator $ \op -> liftIO $ updateOperator currentTs op
overwriteServers currentTs operator smpServers
overwriteServers currentTs operator xftpServers
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
updateOperator :: UTCTime -> ServerOperator -> IO ()
updateOperator 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)
overwriteServers :: forall p. ProtocolTypeI p => UTCTime -> Maybe ServerOperator -> [ServerCfg p] -> ExceptT StoreError IO ()
overwriteServers currentTs serverOperator servers =
checkConstraint SEUniqueID . ExceptT $ do
case serverOperator of
Nothing ->
DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND server_operator_id IS NULL AND protocol = ?" (userId, protocol)
Just ServerOperator {operatorId} ->
DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND server_operator_id = ? AND protocol = ?" (userId, operatorId, protocol)
forM_ servers $ \ServerCfg {server, operator, preset, tested, enabled} -> do
let ProtoServerWithAuth ProtocolServer {host, port, keyHash} auth_ = server
DB.execute
db
[sql|
INSERT INTO protocol_servers
(protocol, host, port, key_hash, basic_auth, operator, preset, tested, enabled, user_id, created_at, updated_at)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
|]
((protocol, host, port, keyHash, safeDecodeUtf8 . unBasicAuth <$> auth_, operator) :. (preset, tested, enabled, userId, currentTs, currentTs))
pure $ Right ()
where
protocol = decodeLatin1 $ strEncode $ protocolTypeI @p
-- updateServerOperators_ :: DB.Connection -> [ServerOperator] -> IO [ServerOperator]
-- updateServerOperators_ db operators = do
-- DB.execute_ db "DELETE FROM server_operators WHERE preset = 0"
-- let (existing, new) = partition (isJust . operatorId) operators
-- existing' <- mapM (\op -> upsertExisting op $> op) existing
-- new' <- mapM insertNew new
-- pure $ existing' <> new'
-- where
-- upsertExisting ServerOperator {operatorId, name, preset, enabled, roles = ServerRoles {storage, proxy}}
-- | preset =
-- DB.execute
-- db
-- [sql|
-- UPDATE server_operators
-- SET enabled = ?, role_storage = ?, role_proxy = ?
-- WHERE server_operator_id = ?
-- |]
-- (enabled, storage, proxy, operatorId)
-- | otherwise =
-- DB.execute
-- db
-- [sql|
-- INSERT INTO server_operators (server_operator_id, name, preset, enabled, role_storage, role_proxy)
-- VALUES (?,?,?,?,?,?)
-- |]
-- (operatorId, name, preset, enabled, storage, proxy)
-- insertNew op@ServerOperator {name, preset, enabled, roles = ServerRoles {storage, proxy}} = do
-- DB.execute
-- db
-- [sql|
-- INSERT INTO server_operators (name, preset, enabled, role_storage, role_proxy)
-- VALUES (?,?,?,?,?)
-- |]
-- (name, preset, enabled, storage, proxy)
-- opId <- insertedRowId db
-- pure op {operatorId = Just opId}
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
+1
View File
@@ -127,6 +127,7 @@ data StoreError
| SERemoteCtrlNotFound {remoteCtrlId :: RemoteCtrlId}
| SERemoteCtrlDuplicateCA
| SEProhibitedDeleteUser {userId :: UserId, contactId :: ContactId}
| SEOperatorNotFound {serverOperatorId :: Int64}
| SEUsageConditionsNotFound
deriving (Show, Exception)
+21 -16
View File
@@ -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, operatorSimpleXChat)
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 (allRoles, 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 allRoles operatorSimpleXChat)
[ "smp://u2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU=@smp4.simplex.im,o5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion",
"smp://hpq7_4gGJiilmz5Rf-CswuU5kZGkm_zOIooSw6yALRg=@smp5.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion",
"smp://PQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo=@smp6.simplex.im,bylepyau3ty4czmn77q4fglvperknl4bi2eb2fdy2bh4jxtf32kf73yd.onion"
],
useSMP = 3,
ntf = ["ntf://FB-Uop7RTaZZEG0ZLD2CIaTjsPh-Fw0zFAnb7QyA8Ks=@ntf2.simplex.im,ntg7jdjy2i3qbib3sykiho3enekwiaqg3icctliqhtqcg6jmoh6cxiad.onion"],
xftp = L.map (presetServerCfg True allRoles operatorSimpleXChat) 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,
+2 -2
View File
@@ -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,
+84 -31
View File
@@ -19,12 +19,13 @@ import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Char (isSpace, toUpper)
import Data.Function (on)
import Data.Int (Int64)
import Data.List (foldl', groupBy, intercalate, intersperse, partition, sortOn)
import Data.List (groupBy, intercalate, intersperse, partition, sortOn)
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, isJust, isNothing, mapMaybe)
import Data.String
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1)
@@ -54,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 (..))
@@ -96,10 +97,9 @@ 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 operators -> ttyUser u $ viewUserServers userServers operators testView
CRServerTestResult u srv testFailure -> ttyUser u $ viewServerTestResult srv testFailure
CRServerOperators {} -> []
CRUserServers {} -> []
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
@@ -1214,27 +1214,31 @@ viewUserPrivacy User {userId} User {userId = userId', localDisplayName = n', sho
"profile is " <> if isJust viewPwdHash then "hidden" else "visible"
]
viewUserServers :: AUserProtoServers -> [ServerOperator] -> Bool -> [StyledString]
viewUserServers (AUPS UserProtoServers {serverProtocol = p, protoServers, presetServers}) operators 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 operators presetServers
else viewServers operators 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
@@ -1255,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"]
@@ -1331,11 +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 => [ServerOperator] -> NonEmpty (ServerCfg p) -> [StyledString]
viewServers operators = map (plain . (\ServerCfg {server, operator} -> B.unpack (strEncode server) <> viewOperator operator)) . L.toList
where
ops :: Map (Maybe Int64) Text = foldl' (\m ServerOperator {operatorId, tradeName} -> M.insert (Just operatorId) tradeName m) M.empty operators
viewOperator = maybe "" $ \op -> " (operator " <> maybe (show op) T.unpack (M.lookup (Just op) ops) <> ")"
-- 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
@@ -1934,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
+16 -3
View File
@@ -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
+56 -21
View File
@@ -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)
@@ -334,8 +334,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' =
@@ -1141,17 +1141,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 =
@@ -1172,17 +1187,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 =
@@ -1800,11 +1829,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 =
+2
View File
@@ -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
+11 -1
View File
@@ -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
+31 -20
View File
@@ -1,53 +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 (..), ServerRoles (..))
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 ServerRoles
deriving instance Eq (ServerCfg p)
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}