From d42cab8e227db171ac4292e2523454fb925529f2 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Thu, 14 Nov 2024 17:43:34 +0000 Subject: [PATCH] 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> --- cabal.project | 2 +- package.yaml | 3 +- scripts/nix/sha256map.nix | 2 +- simplex-chat.cabal | 21 +- src/Simplex/Chat.hs | 449 +++++++++------- src/Simplex/Chat/Controller.hs | 96 ++-- .../Migrations/M20241027_server_operators.hs | 18 +- src/Simplex/Chat/Migrations/chat_schema.sql | 9 +- src/Simplex/Chat/Operators.hs | 396 ++++++++++++--- src/Simplex/Chat/Operators/Conditions.hs | 2 +- src/Simplex/Chat/Stats.hs | 3 +- src/Simplex/Chat/Store/Profiles.hs | 478 ++++++++++-------- src/Simplex/Chat/Store/Shared.hs | 1 + src/Simplex/Chat/Terminal.hs | 37 +- src/Simplex/Chat/Terminal/Main.hs | 4 +- src/Simplex/Chat/View.hs | 115 +++-- tests/ChatClient.hs | 19 +- tests/ChatTests/Direct.hs | 77 ++- tests/ChatTests/Groups.hs | 2 + tests/ChatTests/Profiles.hs | 12 +- tests/RandomServers.hs | 51 +- 21 files changed, 1148 insertions(+), 649 deletions(-) diff --git a/cabal.project b/cabal.project index 61ce04a569..74f944c37d 100644 --- a/cabal.project +++ b/cabal.project @@ -12,7 +12,7 @@ constraints: zip +disable-bzip2 +disable-zstd source-repository-package type: git location: https://github.com/simplex-chat/simplexmq.git - tag: ff05a465ee15ac7ae2c14a9fb703a18564950631 + tag: 93f30c8edf9243ad2291dd6427d87328e282560a source-repository-package type: git diff --git a/package.yaml b/package.yaml index 2fc50a3532..4a95d52044 100644 --- a/package.yaml +++ b/package.yaml @@ -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 diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index 3e0f103641..bd2602c1b6 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -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"; diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 47987cd697..d3ea814011 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -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.* diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index c517aa52d5..86b6a5e51b 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -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 diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 8406e214c9..3c2b8045d7 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -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) diff --git a/src/Simplex/Chat/Migrations/M20241027_server_operators.hs b/src/Simplex/Chat/Migrations/M20241027_server_operators.hs index fc0ca21e54..d84cc5aa73 100644 --- a/src/Simplex/Chat/Migrations/M20241027_server_operators.hs +++ b/src/Simplex/Chat/Migrations/M20241027_server_operators.hs @@ -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; diff --git a/src/Simplex/Chat/Migrations/chat_schema.sql b/src/Simplex/Chat/Migrations/chat_schema.sql index 0eb7f66913..c037a60770 100644 --- a/src/Simplex/Chat/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Migrations/chat_schema.sql @@ -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 ); diff --git a/src/Simplex/Chat/Operators.hs b/src/Simplex/Chat/Operators.hs index b3f92caaf9..55de357090 100644 --- a/src/Simplex/Chat/Operators.hs +++ b/src/Simplex/Chat/Operators.hs @@ -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) diff --git a/src/Simplex/Chat/Operators/Conditions.hs b/src/Simplex/Chat/Operators/Conditions.hs index 55cf8b658d..a314c1901a 100644 --- a/src/Simplex/Chat/Operators/Conditions.hs +++ b/src/Simplex/Chat/Operators/Conditions.hs @@ -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') diff --git a/src/Simplex/Chat/Stats.hs b/src/Simplex/Chat/Stats.hs index 6dd5c79ab1..21ad25b311 100644 --- a/src/Simplex/Chat/Stats.hs +++ b/src/Simplex/Chat/Stats.hs @@ -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 diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index f4f574c3d7..39bd4bb985 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/src/Simplex/Chat/Store/Profiles.hs @@ -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 diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs index 083079e2ea..fcd9896917 100644 --- a/src/Simplex/Chat/Store/Shared.hs +++ b/src/Simplex/Chat/Store/Shared.hs @@ -127,6 +127,7 @@ data StoreError | SERemoteCtrlNotFound {remoteCtrlId :: RemoteCtrlId} | SERemoteCtrlDuplicateCA | SEProhibitedDeleteUser {userId :: UserId, contactId :: ContactId} + | SEOperatorNotFound {serverOperatorId :: Int64} | SEUsageConditionsNotFound deriving (Show, Exception) diff --git a/src/Simplex/Chat/Terminal.hs b/src/Simplex/Chat/Terminal.hs index e38a34d45f..aa6babfcbd 100644 --- a/src/Simplex/Chat/Terminal.hs +++ b/src/Simplex/Chat/Terminal.hs @@ -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, diff --git a/src/Simplex/Chat/Terminal/Main.hs b/src/Simplex/Chat/Terminal/Main.hs index 64703a3a92..b0eb4dac88 100644 --- a/src/Simplex/Chat/Terminal/Main.hs +++ b/src/Simplex/Chat/Terminal/Main.hs @@ -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, diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 1e6986ee03..2f289afe4b 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -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 ") <> " to test " <> pName <> " server connection", - "use " <> highlight (srvCmd <> " ") <> " 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 " <> " to test SMP server connection", + "use " <> highlight' "/smp " <> " 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 diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index d435af186e..b3d8166f9f 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -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 diff --git a/tests/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs index 8756657e59..bd2a267c3a 100644 --- a/tests/ChatTests/Direct.hs +++ b/tests/ChatTests/Direct.hs @@ -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 = diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index a7de42128c..a51f42114b 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -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 diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index 06ed9aa5bc..1d390e1236 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -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 diff --git a/tests/RandomServers.hs b/tests/RandomServers.hs index e0b1939c9e..8b0b94dbd5 100644 --- a/tests/RandomServers.hs +++ b/tests/RandomServers.hs @@ -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}