mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-05-14 03:55:20 +00:00
core: preset operators and servers (#5142)
* core: preset servers and operators (WIP) * usageConditionsToAdd * simplify * WIP * database entity IDs * preset operators and servers (compiles) * update (most tests pass) * remove imports * fix * update * make preset servers lists potentially empty in some operators, as long as the combined list is not empty * CLI API in progress, validateUserServers * make servers of disabled operators "unknown", consider only enabled servers when switching profile links * exclude disabled operators when receiving files * fix TH in ghc 8.10.7 * add type for ghc 8.10.7 * pattern match for ghc 8.10.7 * ghc 8.10.7 fix attempt * remove additional pattern, update servers * do not strip title from conditions * remove space --------- Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
This commit is contained in:
+1
-1
@@ -12,7 +12,7 @@ constraints: zip +disable-bzip2 +disable-zstd
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/simplex-chat/simplexmq.git
|
||||
tag: ff05a465ee15ac7ae2c14a9fb703a18564950631
|
||||
tag: 93f30c8edf9243ad2291dd6427d87328e282560a
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
|
||||
+2
-1
@@ -39,6 +39,7 @@ dependencies:
|
||||
- optparse-applicative >= 0.15 && < 0.17
|
||||
- random >= 1.1 && < 1.3
|
||||
- record-hasfield == 1.0.*
|
||||
- scientific ==0.3.7.*
|
||||
- simple-logger == 0.1.*
|
||||
- simplexmq >= 5.0
|
||||
- socks == 0.6.*
|
||||
@@ -73,7 +74,7 @@ when:
|
||||
- bytestring == 0.10.*
|
||||
- process >= 1.6 && < 1.6.18
|
||||
- template-haskell == 2.16.*
|
||||
- text >= 1.2.3.0 && < 1.3
|
||||
- text >= 1.2.4.0 && < 1.3
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
|
||||
@@ -1,5 +1,5 @@
|
||||
{
|
||||
"https://github.com/simplex-chat/simplexmq.git"."ff05a465ee15ac7ae2c14a9fb703a18564950631" = "1gv4nwqzbqkj7y3ffkiwkr4qwv52vdzppsds5vsfqaayl14rzmgp";
|
||||
"https://github.com/simplex-chat/simplexmq.git"."93f30c8edf9243ad2291dd6427d87328e282560a" = "1zf0sp9dy6kz4zvyz6mdgmhydps7khcq84n30irp983w1xh7gzs7";
|
||||
"https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
|
||||
"https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d";
|
||||
"https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl";
|
||||
|
||||
+14
-7
@@ -228,6 +228,7 @@ library
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
, random >=1.1 && <1.3
|
||||
, record-hasfield ==1.0.*
|
||||
, scientific ==0.3.7.*
|
||||
, simple-logger ==0.1.*
|
||||
, simplexmq >=5.0
|
||||
, socks ==0.6.*
|
||||
@@ -254,7 +255,7 @@ library
|
||||
bytestring ==0.10.*
|
||||
, process >=1.6 && <1.6.18
|
||||
, template-haskell ==2.16.*
|
||||
, text >=1.2.3.0 && <1.3
|
||||
, text >=1.2.4.0 && <1.3
|
||||
|
||||
executable simplex-bot
|
||||
main-is: Main.hs
|
||||
@@ -292,6 +293,7 @@ executable simplex-bot
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
, random >=1.1 && <1.3
|
||||
, record-hasfield ==1.0.*
|
||||
, scientific ==0.3.7.*
|
||||
, simple-logger ==0.1.*
|
||||
, simplex-chat
|
||||
, simplexmq >=5.0
|
||||
@@ -319,7 +321,7 @@ executable simplex-bot
|
||||
bytestring ==0.10.*
|
||||
, process >=1.6 && <1.6.18
|
||||
, template-haskell ==2.16.*
|
||||
, text >=1.2.3.0 && <1.3
|
||||
, text >=1.2.4.0 && <1.3
|
||||
|
||||
executable simplex-bot-advanced
|
||||
main-is: Main.hs
|
||||
@@ -357,6 +359,7 @@ executable simplex-bot-advanced
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
, random >=1.1 && <1.3
|
||||
, record-hasfield ==1.0.*
|
||||
, scientific ==0.3.7.*
|
||||
, simple-logger ==0.1.*
|
||||
, simplex-chat
|
||||
, simplexmq >=5.0
|
||||
@@ -384,7 +387,7 @@ executable simplex-bot-advanced
|
||||
bytestring ==0.10.*
|
||||
, process >=1.6 && <1.6.18
|
||||
, template-haskell ==2.16.*
|
||||
, text >=1.2.3.0 && <1.3
|
||||
, text >=1.2.4.0 && <1.3
|
||||
|
||||
executable simplex-broadcast-bot
|
||||
main-is: Main.hs
|
||||
@@ -425,6 +428,7 @@ executable simplex-broadcast-bot
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
, random >=1.1 && <1.3
|
||||
, record-hasfield ==1.0.*
|
||||
, scientific ==0.3.7.*
|
||||
, simple-logger ==0.1.*
|
||||
, simplex-chat
|
||||
, simplexmq >=5.0
|
||||
@@ -452,7 +456,7 @@ executable simplex-broadcast-bot
|
||||
bytestring ==0.10.*
|
||||
, process >=1.6 && <1.6.18
|
||||
, template-haskell ==2.16.*
|
||||
, text >=1.2.3.0 && <1.3
|
||||
, text >=1.2.4.0 && <1.3
|
||||
|
||||
executable simplex-chat
|
||||
main-is: Main.hs
|
||||
@@ -491,6 +495,7 @@ executable simplex-chat
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
, random >=1.1 && <1.3
|
||||
, record-hasfield ==1.0.*
|
||||
, scientific ==0.3.7.*
|
||||
, simple-logger ==0.1.*
|
||||
, simplex-chat
|
||||
, simplexmq >=5.0
|
||||
@@ -519,7 +524,7 @@ executable simplex-chat
|
||||
bytestring ==0.10.*
|
||||
, process >=1.6 && <1.6.18
|
||||
, template-haskell ==2.16.*
|
||||
, text >=1.2.3.0 && <1.3
|
||||
, text >=1.2.4.0 && <1.3
|
||||
|
||||
executable simplex-directory-service
|
||||
main-is: Main.hs
|
||||
@@ -563,6 +568,7 @@ executable simplex-directory-service
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
, random >=1.1 && <1.3
|
||||
, record-hasfield ==1.0.*
|
||||
, scientific ==0.3.7.*
|
||||
, simple-logger ==0.1.*
|
||||
, simplex-chat
|
||||
, simplexmq >=5.0
|
||||
@@ -590,7 +596,7 @@ executable simplex-directory-service
|
||||
bytestring ==0.10.*
|
||||
, process >=1.6 && <1.6.18
|
||||
, template-haskell ==2.16.*
|
||||
, text >=1.2.3.0 && <1.3
|
||||
, text >=1.2.4.0 && <1.3
|
||||
|
||||
test-suite simplex-chat-test
|
||||
type: exitcode-stdio-1.0
|
||||
@@ -664,6 +670,7 @@ test-suite simplex-chat-test
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
, random >=1.1 && <1.3
|
||||
, record-hasfield ==1.0.*
|
||||
, scientific ==0.3.7.*
|
||||
, silently ==1.2.*
|
||||
, simple-logger ==0.1.*
|
||||
, simplex-chat
|
||||
@@ -692,7 +699,7 @@ test-suite simplex-chat-test
|
||||
bytestring ==0.10.*
|
||||
, process >=1.6 && <1.6.18
|
||||
, template-haskell ==2.16.*
|
||||
, text >=1.2.3.0 && <1.3
|
||||
, text >=1.2.4.0 && <1.3
|
||||
if impl(ghc >= 9.6.2)
|
||||
build-depends:
|
||||
hspec ==2.11.*
|
||||
|
||||
+273
-176
@@ -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
|
||||
|
||||
@@ -35,7 +35,6 @@ import qualified Data.ByteArray as BA
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Char (ord)
|
||||
import Data.Constraint (Dict (..))
|
||||
import Data.Int (Int64)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Map.Strict (Map)
|
||||
@@ -71,7 +70,7 @@ import Simplex.Chat.Util (liftIOEither)
|
||||
import Simplex.FileTransfer.Description (FileDescriptionURI)
|
||||
import Simplex.Messaging.Agent (AgentClient, SubscriptionsInfo)
|
||||
import Simplex.Messaging.Agent.Client (AgentLocks, AgentQueuesInfo (..), AgentWorkersDetails (..), AgentWorkersSummary (..), ProtocolTestFailure, SMPServerSubs, ServerQueueInfo, UserNetworkInfo)
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, NetworkConfig, ServerCfg)
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, NetworkConfig)
|
||||
import Simplex.Messaging.Agent.Lock
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation, SQLiteStore, UpMigration, withTransaction, withTransactionPriority)
|
||||
@@ -85,7 +84,7 @@ import Simplex.Messaging.Crypto.Ratchet (PQEncryption)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfTknStatus)
|
||||
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, parseAll, parseString, sumTypeJSON)
|
||||
import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType (..), CorrId, MsgId, NMsgMeta (..), NtfServer, ProtocolType (..), ProtocolTypeI, QueueId, SMPMsgMeta (..), SProtocolType, SubscriptionMode (..), UserProtocol, XFTPServer, userProtocol)
|
||||
import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType (..), CorrId, MsgId, NMsgMeta (..), NtfServer, ProtocolType (..), QueueId, SMPMsgMeta (..), SubscriptionMode (..), XFTPServer)
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import Simplex.Messaging.Transport (TLS, simplexMQVersion)
|
||||
import Simplex.Messaging.Transport.Client (SocksProxyWithAuth, TransportHost)
|
||||
@@ -133,7 +132,7 @@ data ChatConfig = ChatConfig
|
||||
{ agentConfig :: AgentConfig,
|
||||
chatVRange :: VersionRangeChat,
|
||||
confirmMigrations :: MigrationConfirmation,
|
||||
defaultServers :: DefaultAgentServers,
|
||||
presetServers :: PresetServers,
|
||||
tbqSize :: Natural,
|
||||
fileChunkSize :: Integer,
|
||||
xftpDescrPartSize :: Int,
|
||||
@@ -155,6 +154,12 @@ data ChatConfig = ChatConfig
|
||||
chatHooks :: ChatHooks
|
||||
}
|
||||
|
||||
data RandomServers = RandomServers
|
||||
{ smpServers :: NonEmpty (NewUserServer 'PSMP),
|
||||
xftpServers :: NonEmpty (NewUserServer 'PXFTP)
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- The hooks can be used to extend or customize chat core in mobile or CLI clients.
|
||||
data ChatHooks = ChatHooks
|
||||
{ -- preCmdHook can be used to process or modify the commands before they are processed.
|
||||
@@ -173,12 +178,9 @@ defaultChatHooks =
|
||||
eventHook = \_ -> pure
|
||||
}
|
||||
|
||||
data DefaultAgentServers = DefaultAgentServers
|
||||
{ smp :: NonEmpty (ServerCfg 'PSMP),
|
||||
useSMP :: Int,
|
||||
data PresetServers = PresetServers
|
||||
{ operators :: NonEmpty PresetOperator,
|
||||
ntf :: [NtfServer],
|
||||
xftp :: NonEmpty (ServerCfg 'PXFTP),
|
||||
useXFTP :: Int,
|
||||
netCfg :: NetworkConfig
|
||||
}
|
||||
|
||||
@@ -204,6 +206,7 @@ data ChatDatabase = ChatDatabase {chatStore :: SQLiteStore, agentStore :: SQLite
|
||||
|
||||
data ChatController = ChatController
|
||||
{ currentUser :: TVar (Maybe User),
|
||||
randomServers :: RandomServers,
|
||||
currentRemoteHost :: TVar (Maybe RemoteHostId),
|
||||
firstTime :: Bool,
|
||||
smpAgent :: AgentClient,
|
||||
@@ -347,20 +350,18 @@ data ChatCommand
|
||||
| APIGetGroupLink GroupId
|
||||
| APICreateMemberContact GroupId GroupMemberId
|
||||
| APISendMemberContactInvitation {contactId :: ContactId, msgContent_ :: Maybe MsgContent}
|
||||
| APIGetUserProtoServers UserId AProtocolType
|
||||
| GetUserProtoServers AProtocolType
|
||||
| APISetUserProtoServers UserId AProtoServersConfig
|
||||
| SetUserProtoServers AProtoServersConfig
|
||||
| SetUserProtoServers AProtocolType [AProtoServerWithAuth]
|
||||
| APITestProtoServer UserId AProtoServerWithAuth
|
||||
| TestProtoServer AProtoServerWithAuth
|
||||
| APIGetServerOperators
|
||||
| APISetServerOperators (NonEmpty OperatorEnabled)
|
||||
| APISetServerOperators (NonEmpty ServerOperator)
|
||||
| APIGetUserServers UserId
|
||||
| APISetUserServers UserId (NonEmpty UserServers)
|
||||
| APIValidateServers (NonEmpty UserServers) -- response is CRUserServersValidation
|
||||
| APISetUserServers UserId (NonEmpty UpdatedUserOperatorServers)
|
||||
| APIValidateServers (NonEmpty UpdatedUserOperatorServers) -- response is CRUserServersValidation
|
||||
| APIGetUsageConditions
|
||||
| APISetConditionsNotified Int64
|
||||
| APIAcceptConditions Int64 (NonEmpty ServerOperator)
|
||||
| APIAcceptConditions Int64 (NonEmpty Int64)
|
||||
| APISetChatItemTTL UserId (Maybe Int64)
|
||||
| SetChatItemTTL (Maybe Int64)
|
||||
| APIGetChatItemTTL UserId
|
||||
@@ -586,10 +587,9 @@ data ChatResponse
|
||||
| CRChatItemInfo {user :: User, chatItem :: AChatItem, chatItemInfo :: ChatItemInfo}
|
||||
| CRChatItemId User (Maybe ChatItemId)
|
||||
| CRApiParsedMarkdown {formattedText :: Maybe MarkdownList}
|
||||
| CRUserProtoServers {user :: User, servers :: AUserProtoServers, operators :: [ServerOperator]}
|
||||
| CRServerTestResult {user :: User, testServer :: AProtoServerWithAuth, testFailure :: Maybe ProtocolTestFailure}
|
||||
| CRServerOperators {operators :: [ServerOperator], conditionsAction :: Maybe UsageConditionsAction}
|
||||
| CRUserServers {user :: User, userServers :: [UserServers]}
|
||||
| CRUserServers {user :: User, userServers :: [UserOperatorServers]}
|
||||
| CRUserServersValidation {serverErrors :: [UserServersError]}
|
||||
| CRUsageConditions {usageConditions :: UsageConditions, conditionsText :: Text, acceptedConditions :: Maybe UsageConditions}
|
||||
| CRChatItemTTL {user :: User, chatItemTTL :: Maybe Int64}
|
||||
@@ -956,23 +956,23 @@ instance ToJSON AgentQueueId where
|
||||
toJSON = strToJSON
|
||||
toEncoding = strToJEncoding
|
||||
|
||||
data ProtoServersConfig p = ProtoServersConfig {servers :: [ServerCfg p]}
|
||||
deriving (Show)
|
||||
-- data ProtoServersConfig p = ProtoServersConfig {servers :: [ServerCfg p]}
|
||||
-- deriving (Show)
|
||||
|
||||
data AProtoServersConfig = forall p. ProtocolTypeI p => APSC (SProtocolType p) (ProtoServersConfig p)
|
||||
-- data AProtoServersConfig = forall p. ProtocolTypeI p => APSC (SProtocolType p) (ProtoServersConfig p)
|
||||
|
||||
deriving instance Show AProtoServersConfig
|
||||
-- deriving instance Show AProtoServersConfig
|
||||
|
||||
data UserProtoServers p = UserProtoServers
|
||||
{ serverProtocol :: SProtocolType p,
|
||||
protoServers :: NonEmpty (ServerCfg p),
|
||||
presetServers :: NonEmpty (ServerCfg p)
|
||||
}
|
||||
deriving (Show)
|
||||
-- data UserProtoServers p = UserProtoServers
|
||||
-- { serverProtocol :: SProtocolType p,
|
||||
-- protoServers :: NonEmpty (ServerCfg p),
|
||||
-- presetServers :: NonEmpty (ServerCfg p)
|
||||
-- }
|
||||
-- deriving (Show)
|
||||
|
||||
data AUserProtoServers = forall p. (ProtocolTypeI p, UserProtocol p) => AUPS (UserProtoServers p)
|
||||
-- data AUserProtoServers = forall p. (ProtocolTypeI p, UserProtocol p) => AUPS (UserProtoServers p)
|
||||
|
||||
deriving instance Show AUserProtoServers
|
||||
-- deriving instance Show AUserProtoServers
|
||||
|
||||
data ArchiveConfig = ArchiveConfig {archivePath :: FilePath, disableCompression :: Maybe Bool, parentTempDirectory :: Maybe FilePath}
|
||||
deriving (Show)
|
||||
@@ -1575,28 +1575,28 @@ $(JQ.deriveJSON defaultJSON ''CoreVersionInfo)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''SlowSQLQuery)
|
||||
|
||||
instance ProtocolTypeI p => FromJSON (ProtoServersConfig p) where
|
||||
parseJSON = $(JQ.mkParseJSON defaultJSON ''ProtoServersConfig)
|
||||
-- instance ProtocolTypeI p => FromJSON (ProtoServersConfig p) where
|
||||
-- parseJSON = $(JQ.mkParseJSON defaultJSON ''ProtoServersConfig)
|
||||
|
||||
instance ProtocolTypeI p => FromJSON (UserProtoServers p) where
|
||||
parseJSON = $(JQ.mkParseJSON defaultJSON ''UserProtoServers)
|
||||
-- instance ProtocolTypeI p => FromJSON (UserProtoServers p) where
|
||||
-- parseJSON = $(JQ.mkParseJSON defaultJSON ''UserProtoServers)
|
||||
|
||||
instance ProtocolTypeI p => ToJSON (UserProtoServers p) where
|
||||
toJSON = $(JQ.mkToJSON defaultJSON ''UserProtoServers)
|
||||
toEncoding = $(JQ.mkToEncoding defaultJSON ''UserProtoServers)
|
||||
-- instance ProtocolTypeI p => ToJSON (UserProtoServers p) where
|
||||
-- toJSON = $(JQ.mkToJSON defaultJSON ''UserProtoServers)
|
||||
-- toEncoding = $(JQ.mkToEncoding defaultJSON ''UserProtoServers)
|
||||
|
||||
instance FromJSON AUserProtoServers where
|
||||
parseJSON v = J.withObject "AUserProtoServers" parse v
|
||||
where
|
||||
parse o = do
|
||||
AProtocolType (p :: SProtocolType p) <- o .: "serverProtocol"
|
||||
case userProtocol p of
|
||||
Just Dict -> AUPS <$> J.parseJSON @(UserProtoServers p) v
|
||||
Nothing -> fail $ "AUserProtoServers: unsupported protocol " <> show p
|
||||
-- instance FromJSON AUserProtoServers where
|
||||
-- parseJSON v = J.withObject "AUserProtoServers" parse v
|
||||
-- where
|
||||
-- parse o = do
|
||||
-- AProtocolType (p :: SProtocolType p) <- o .: "serverProtocol"
|
||||
-- case userProtocol p of
|
||||
-- Just Dict -> AUPS <$> J.parseJSON @(UserProtoServers p) v
|
||||
-- Nothing -> fail $ "AUserProtoServers: unsupported protocol " <> show p
|
||||
|
||||
instance ToJSON AUserProtoServers where
|
||||
toJSON (AUPS s) = $(JQ.mkToJSON defaultJSON ''UserProtoServers) s
|
||||
toEncoding (AUPS s) = $(JQ.mkToEncoding defaultJSON ''UserProtoServers) s
|
||||
-- instance ToJSON AUserProtoServers where
|
||||
-- toJSON (AUPS s) = $(JQ.mkToJSON defaultJSON ''UserProtoServers) s
|
||||
-- toEncoding (AUPS s) = $(JQ.mkToEncoding defaultJSON ''UserProtoServers) s
|
||||
|
||||
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RCS") ''RemoteCtrlSessionState)
|
||||
|
||||
|
||||
@@ -11,7 +11,6 @@ m20241027_server_operators =
|
||||
CREATE TABLE server_operators (
|
||||
server_operator_id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
server_operator_tag TEXT,
|
||||
app_vendor INTEGER NOT NULL,
|
||||
trade_name TEXT NOT NULL,
|
||||
legal_name TEXT,
|
||||
server_domains TEXT,
|
||||
@@ -22,8 +21,6 @@ CREATE TABLE server_operators (
|
||||
updated_at TEXT NOT NULL DEFAULT (datetime('now'))
|
||||
);
|
||||
|
||||
ALTER TABLE protocol_servers ADD COLUMN server_operator_id INTEGER REFERENCES server_operators ON DELETE SET NULL;
|
||||
|
||||
CREATE TABLE usage_conditions (
|
||||
usage_conditions_id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
conditions_commit TEXT NOT NULL UNIQUE,
|
||||
@@ -41,18 +38,8 @@ CREATE TABLE operator_usage_conditions (
|
||||
created_at TEXT NOT NULL DEFAULT (datetime('now'))
|
||||
);
|
||||
|
||||
CREATE INDEX idx_protocol_servers_server_operator_id ON protocol_servers(server_operator_id);
|
||||
CREATE INDEX idx_operator_usage_conditions_server_operator_id ON operator_usage_conditions(server_operator_id);
|
||||
CREATE UNIQUE INDEX idx_operator_usage_conditions_conditions_commit ON operator_usage_conditions(server_operator_id, conditions_commit);
|
||||
|
||||
INSERT INTO server_operators
|
||||
(server_operator_id, server_operator_tag, app_vendor, trade_name, legal_name, server_domains, enabled)
|
||||
VALUES (1, 'simplex', 1, 'SimpleX Chat', 'SimpleX Chat Ltd', 'simplex.im', 1);
|
||||
INSERT INTO server_operators
|
||||
(server_operator_id, server_operator_tag, app_vendor, trade_name, legal_name, server_domains, enabled)
|
||||
VALUES (2, 'xyz', 0, 'XYZ', 'XYZ Ltd', 'xyz.com', 0);
|
||||
|
||||
-- UPDATE protocol_servers SET server_operator_id = 1 WHERE host LIKE "%.simplex.im" OR host LIKE "%.simplex.im,%";
|
||||
CREATE UNIQUE INDEX idx_operator_usage_conditions_conditions_commit ON operator_usage_conditions(conditions_commit, server_operator_id);
|
||||
|]
|
||||
|
||||
down_m20241027_server_operators :: Query
|
||||
@@ -60,9 +47,6 @@ down_m20241027_server_operators =
|
||||
[sql|
|
||||
DROP INDEX idx_operator_usage_conditions_conditions_commit;
|
||||
DROP INDEX idx_operator_usage_conditions_server_operator_id;
|
||||
DROP INDEX idx_protocol_servers_server_operator_id;
|
||||
|
||||
ALTER TABLE protocol_servers DROP COLUMN server_operator_id;
|
||||
|
||||
DROP TABLE operator_usage_conditions;
|
||||
DROP TABLE usage_conditions;
|
||||
|
||||
@@ -450,7 +450,6 @@ CREATE TABLE IF NOT EXISTS "protocol_servers"(
|
||||
created_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
updated_at TEXT NOT NULL DEFAULT(datetime('now')),
|
||||
protocol TEXT NOT NULL DEFAULT 'smp',
|
||||
server_operator_id INTEGER REFERENCES server_operators ON DELETE SET NULL,
|
||||
UNIQUE(user_id, host, port)
|
||||
);
|
||||
CREATE TABLE xftp_file_descriptions(
|
||||
@@ -593,7 +592,6 @@ CREATE TABLE app_settings(app_settings TEXT NOT NULL);
|
||||
CREATE TABLE server_operators(
|
||||
server_operator_id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
server_operator_tag TEXT,
|
||||
app_vendor INTEGER NOT NULL,
|
||||
trade_name TEXT NOT NULL,
|
||||
legal_name TEXT,
|
||||
server_domains TEXT,
|
||||
@@ -919,13 +917,10 @@ CREATE INDEX idx_received_probes_group_member_id on received_probes(
|
||||
group_member_id
|
||||
);
|
||||
CREATE INDEX idx_contact_requests_contact_id ON contact_requests(contact_id);
|
||||
CREATE INDEX idx_protocol_servers_server_operator_id ON protocol_servers(
|
||||
server_operator_id
|
||||
);
|
||||
CREATE INDEX idx_operator_usage_conditions_server_operator_id ON operator_usage_conditions(
|
||||
server_operator_id
|
||||
);
|
||||
CREATE UNIQUE INDEX idx_operator_usage_conditions_conditions_commit ON operator_usage_conditions(
|
||||
server_operator_id,
|
||||
conditions_commit
|
||||
conditions_commit,
|
||||
server_operator_id
|
||||
);
|
||||
|
||||
+315
-81
@@ -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)
|
||||
|
||||
@@ -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')
|
||||
|
||||
@@ -7,7 +7,6 @@ module Simplex.Chat.Stats where
|
||||
|
||||
import qualified Data.Aeson.TH as J
|
||||
import Data.List (partition)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (fromMaybe, isJust)
|
||||
@@ -131,7 +130,7 @@ data NtfServerSummary = NtfServerSummary
|
||||
-- - users are passed to exclude hidden users from totalServersSummary;
|
||||
-- - if currentUser is hidden, it should be accounted in totalServersSummary;
|
||||
-- - known is set only in user level summaries based on passed userSMPSrvs and userXFTPSrvs
|
||||
toPresentedServersSummary :: AgentServersSummary -> [User] -> User -> NonEmpty SMPServer -> NonEmpty XFTPServer -> [NtfServer] -> PresentedServersSummary
|
||||
toPresentedServersSummary :: AgentServersSummary -> [User] -> User -> [SMPServer] -> [XFTPServer] -> [NtfServer] -> PresentedServersSummary
|
||||
toPresentedServersSummary agentSummary users currentUser userSMPSrvs userXFTPSrvs userNtfSrvs = do
|
||||
let (userSMPSrvsSumms, allSMPSrvsSumms) = accSMPSrvsSummaries
|
||||
(userSMPCurr, userSMPPrev, userSMPProx) = smpSummsIntoCategories userSMPSrvsSumms
|
||||
|
||||
+265
-213
@@ -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
|
||||
|
||||
@@ -127,6 +127,7 @@ data StoreError
|
||||
| SERemoteCtrlNotFound {remoteCtrlId :: RemoteCtrlId}
|
||||
| SERemoteCtrlDuplicateCA
|
||||
| SEProhibitedDeleteUser {userId :: UserId, contactId :: ContactId}
|
||||
| SEOperatorNotFound {serverOperatorId :: Int64}
|
||||
| SEUsageConditionsNotFound
|
||||
deriving (Show, Exception)
|
||||
|
||||
|
||||
@@ -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,
|
||||
|
||||
@@ -10,7 +10,7 @@ import Data.Maybe (fromMaybe)
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import Data.Time.LocalTime (getCurrentTimeZone)
|
||||
import Network.Socket
|
||||
import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatResponse (..), DefaultAgentServers (DefaultAgentServers, netCfg), SimpleNetCfg (..), currentRemoteHost, versionNumber, versionString)
|
||||
import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatResponse (..), PresetServers (..), SimpleNetCfg (..), currentRemoteHost, versionNumber, versionString)
|
||||
import Simplex.Chat.Core
|
||||
import Simplex.Chat.Options
|
||||
import Simplex.Chat.Terminal
|
||||
@@ -56,7 +56,7 @@ simplexChatCLI' cfg opts@ChatOpts {chatCmd, chatCmdLog, chatCmdDelay, chatServer
|
||||
putStrLn $ serializeChatResponse (rh, Just user) ts tz rh r
|
||||
|
||||
welcome :: ChatConfig -> ChatOpts -> IO ()
|
||||
welcome ChatConfig {defaultServers = DefaultAgentServers {netCfg}} ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, simpleNetCfg = SimpleNetCfg {socksProxy, socksMode, smpProxyMode_, smpProxyFallback_}}} =
|
||||
welcome ChatConfig {presetServers = PresetServers {netCfg}} ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, simpleNetCfg = SimpleNetCfg {socksProxy, socksMode, smpProxyMode_, smpProxyFallback_}}} =
|
||||
mapM_
|
||||
putStrLn
|
||||
[ versionString versionNumber,
|
||||
|
||||
+84
-31
@@ -19,12 +19,13 @@ import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Char (isSpace, toUpper)
|
||||
import Data.Function (on)
|
||||
import Data.Int (Int64)
|
||||
import Data.List (foldl', groupBy, intercalate, intersperse, partition, sortOn)
|
||||
import Data.List (groupBy, intercalate, intersperse, partition, sortOn)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
|
||||
import Data.String
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeLatin1)
|
||||
@@ -54,7 +55,7 @@ import Simplex.Chat.Types.Shared
|
||||
import Simplex.Chat.Types.UITheme
|
||||
import qualified Simplex.FileTransfer.Transport as XFTP
|
||||
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), SubscriptionsInfo (..))
|
||||
import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..), ServerCfg (..))
|
||||
import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..), ServerRoles (..))
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..))
|
||||
import Simplex.Messaging.Client (SMPProxyFallback, SMPProxyMode (..), SocksMode (..))
|
||||
@@ -96,10 +97,9 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
|
||||
CRChats chats -> viewChats ts tz chats
|
||||
CRApiChat u chat _ -> ttyUser u $ if testView then testViewChat chat else [viewJSON chat]
|
||||
CRApiParsedMarkdown ft -> [viewJSON ft]
|
||||
CRUserProtoServers u userServers operators -> ttyUser u $ viewUserServers userServers operators testView
|
||||
CRServerTestResult u srv testFailure -> ttyUser u $ viewServerTestResult srv testFailure
|
||||
CRServerOperators {} -> []
|
||||
CRUserServers {} -> []
|
||||
CRServerOperators ops ca -> viewServerOperators ops ca
|
||||
CRUserServers u uss -> ttyUser u $ concatMap viewUserServers uss <> (if testView then [] else serversUserHelp)
|
||||
CRUserServersValidation _ -> []
|
||||
CRUsageConditions {} -> []
|
||||
CRChatItemTTL u ttl -> ttyUser u $ viewChatItemTTL ttl
|
||||
@@ -1214,27 +1214,31 @@ viewUserPrivacy User {userId} User {userId = userId', localDisplayName = n', sho
|
||||
"profile is " <> if isJust viewPwdHash then "hidden" else "visible"
|
||||
]
|
||||
|
||||
viewUserServers :: AUserProtoServers -> [ServerOperator] -> Bool -> [StyledString]
|
||||
viewUserServers (AUPS UserProtoServers {serverProtocol = p, protoServers, presetServers}) operators testView =
|
||||
customServers
|
||||
<> if testView
|
||||
then []
|
||||
else
|
||||
[ "",
|
||||
"use " <> highlight (srvCmd <> " test <srv>") <> " to test " <> pName <> " server connection",
|
||||
"use " <> highlight (srvCmd <> " <srv1[,srv2,...]>") <> " to configure " <> pName <> " servers",
|
||||
"use " <> highlight (srvCmd <> " default") <> " to remove configured " <> pName <> " servers and use presets"
|
||||
]
|
||||
<> case p of
|
||||
SPSMP -> ["(chat option " <> highlight' "-s" <> " (" <> highlight' "--server" <> ") has precedence over saved SMP servers for chat session)"]
|
||||
SPXFTP -> ["(chat option " <> highlight' "-xftp-servers" <> " has precedence over saved XFTP servers for chat session)"]
|
||||
viewUserServers :: UserOperatorServers -> [StyledString]
|
||||
viewUserServers (UserOperatorServers _ [] []) = []
|
||||
viewUserServers UserOperatorServers {operator, smpServers, xftpServers} =
|
||||
[plain $ maybe "Your servers" shortViewOperator operator]
|
||||
<> viewServers SPSMP smpServers
|
||||
<> viewServers SPXFTP xftpServers
|
||||
where
|
||||
srvCmd = "/" <> strEncode p
|
||||
pName = protocolName p
|
||||
customServers =
|
||||
if null protoServers
|
||||
then ("no " <> pName <> " servers saved, using presets: ") : viewServers operators presetServers
|
||||
else viewServers operators protoServers
|
||||
viewServers :: ProtocolTypeI p => SProtocolType p -> [UserServer p] -> [StyledString]
|
||||
viewServers _ [] = []
|
||||
viewServers p srvs = [" " <> protocolName p <> " servers"] <> map (plain . (" " <> ) . viewServer) srvs
|
||||
where
|
||||
viewServer UserServer {server, preset, tested, enabled} = safeDecodeUtf8 (strEncode server) <> serverInfo
|
||||
where
|
||||
serverInfo = if null serverInfo_ then "" else parens $ T.intercalate ", " serverInfo_
|
||||
serverInfo_ = ["preset" | preset] <> testedInfo <> ["disabled" | not enabled]
|
||||
testedInfo = maybe [] (\t -> ["test: " <> if t then "passed" else "failed"]) tested
|
||||
|
||||
serversUserHelp :: [StyledString]
|
||||
serversUserHelp =
|
||||
[ "",
|
||||
"use " <> highlight' "/smp test <srv>" <> " to test SMP server connection",
|
||||
"use " <> highlight' "/smp <srv1[,srv2,...]>" <> " to configure SMP servers",
|
||||
"or the same commands starting from /xftp for XFTP servers",
|
||||
"chat options " <> highlight' "-s" <> " (" <> highlight' "--server" <> ") and " <> highlight' "--xftp-servers" <> " have precedence over preset servers for new user profiles"
|
||||
]
|
||||
|
||||
protocolName :: ProtocolTypeI p => SProtocolType p -> StyledString
|
||||
protocolName = plain . map toUpper . T.unpack . decodeLatin1 . strEncode
|
||||
@@ -1255,6 +1259,53 @@ viewServerTestResult (AProtoServerWithAuth p _) = \case
|
||||
where
|
||||
pName = protocolName p
|
||||
|
||||
viewServerOperators :: [ServerOperator] -> Maybe UsageConditionsAction -> [StyledString]
|
||||
viewServerOperators ops ca = map (plain . viewOperator) ops <> maybe [] viewConditionsAction ca
|
||||
|
||||
viewOperator :: ServerOperator' s -> Text
|
||||
viewOperator op@ServerOperator {tradeName, legalName, serverDomains, conditionsAcceptance} =
|
||||
viewOpIdTag op
|
||||
<> tradeName
|
||||
<> maybe "" parens legalName
|
||||
<> (", domains: " <> T.intercalate ", " serverDomains)
|
||||
<> (", conditions: " <> viewOpConditions conditionsAcceptance)
|
||||
<> (", " <> viewOpEnabled op)
|
||||
|
||||
shortViewOperator :: ServerOperator -> Text
|
||||
shortViewOperator op@ServerOperator {operatorId = DBEntityId opId, tradeName} =
|
||||
tshow opId <> ". " <> tradeName <> parens (viewOpEnabled op)
|
||||
|
||||
viewOpIdTag :: ServerOperator' s -> Text
|
||||
viewOpIdTag ServerOperator {operatorId, operatorTag} = case operatorId of
|
||||
DBEntityId i -> tshow i <> " - " <> tag
|
||||
DBNewEntity -> tag
|
||||
where
|
||||
tag = maybe "" textEncode operatorTag <> ". "
|
||||
|
||||
viewOpConditions :: ConditionsAcceptance -> Text
|
||||
viewOpConditions = \case
|
||||
CAAccepted ts -> viewCond "accepted" ts
|
||||
CARequired ts -> viewCond "required" ts
|
||||
where
|
||||
viewCond w ts = w <> maybe "" (parens . tshow) ts
|
||||
|
||||
viewOpEnabled :: ServerOperator' s -> Text
|
||||
viewOpEnabled ServerOperator {enabled, roles = ServerRoles {storage, proxy}}
|
||||
| enabled && storage && proxy = "enabled"
|
||||
| enabled && storage = "enabled storage"
|
||||
| enabled && proxy = "enabled proxy"
|
||||
| otherwise = "disabled"
|
||||
|
||||
viewConditionsAction :: UsageConditionsAction -> [StyledString]
|
||||
viewConditionsAction = \case
|
||||
UCAReview {operators, deadline, showNotice} | showNotice -> case deadline of
|
||||
Just ts -> [plain $ "New conditions will be accepted at " <> tshow ts <> " for " <> ops]
|
||||
Nothing -> [plain $ "New conditions have to be accepted for " <> ops]
|
||||
where
|
||||
ops = T.intercalate ", " $ map legalName_ operators
|
||||
legalName_ ServerOperator {tradeName, legalName} = fromMaybe tradeName legalName
|
||||
_ -> []
|
||||
|
||||
viewChatItemTTL :: Maybe Int64 -> [StyledString]
|
||||
viewChatItemTTL = \case
|
||||
Nothing -> ["old messages are not being deleted"]
|
||||
@@ -1331,11 +1382,11 @@ viewConnectionStats ConnectionStats {rcvQueuesInfo, sndQueuesInfo} =
|
||||
["receiving messages via: " <> viewRcvQueuesInfo rcvQueuesInfo | not $ null rcvQueuesInfo]
|
||||
<> ["sending messages via: " <> viewSndQueuesInfo sndQueuesInfo | not $ null sndQueuesInfo]
|
||||
|
||||
viewServers :: ProtocolTypeI p => [ServerOperator] -> NonEmpty (ServerCfg p) -> [StyledString]
|
||||
viewServers operators = map (plain . (\ServerCfg {server, operator} -> B.unpack (strEncode server) <> viewOperator operator)) . L.toList
|
||||
where
|
||||
ops :: Map (Maybe Int64) Text = foldl' (\m ServerOperator {operatorId, tradeName} -> M.insert (Just operatorId) tradeName m) M.empty operators
|
||||
viewOperator = maybe "" $ \op -> " (operator " <> maybe (show op) T.unpack (M.lookup (Just op) ops) <> ")"
|
||||
-- viewServers :: ProtocolTypeI p => [ServerOperator] -> NonEmpty (ServerCfg p) -> [StyledString]
|
||||
-- viewServers operators = map (plain . (\ServerCfg {server, operator} -> B.unpack (strEncode server) <> viewOperator operator)) . L.toList
|
||||
-- where
|
||||
-- ops :: Map (Maybe DBEntityId) Text = foldl' (\m ServerOperator {operatorId, tradeName} -> M.insert (Just operatorId) tradeName m) M.empty operators
|
||||
-- viewOperator = maybe "" $ \op -> " (operator " <> maybe (show op) T.unpack (M.lookup (Just op) ops) <> ")"
|
||||
|
||||
viewRcvQueuesInfo :: [RcvQueueInfo] -> StyledString
|
||||
viewRcvQueuesInfo = plain . intercalate ", " . map showQueueInfo
|
||||
@@ -1934,7 +1985,9 @@ viewVersionInfo logLevel CoreVersionInfo {version, simplexmqVersion, simplexmqCo
|
||||
then [versionString version, updateStr, "simplexmq: " <> simplexmqVersion <> parens simplexmqCommit]
|
||||
else [versionString version, updateStr]
|
||||
where
|
||||
parens s = " (" <> s <> ")"
|
||||
|
||||
parens :: (IsString a, Semigroup a) => a -> a
|
||||
parens s = " (" <> s <> ")"
|
||||
|
||||
viewRemoteHosts :: [RemoteHostInfo] -> [StyledString]
|
||||
viewRemoteHosts = \case
|
||||
|
||||
+16
-3
@@ -25,9 +25,10 @@ import Data.Maybe (isNothing)
|
||||
import qualified Data.Text as T
|
||||
import Network.Socket
|
||||
import Simplex.Chat
|
||||
import Simplex.Chat.Controller (ChatCommand (..), ChatConfig (..), ChatController (..), ChatDatabase (..), ChatLogLevel (..), defaultSimpleNetCfg)
|
||||
import Simplex.Chat.Controller (ChatCommand (..), ChatConfig (..), ChatController (..), ChatDatabase (..), ChatLogLevel (..), PresetServers (..), defaultSimpleNetCfg)
|
||||
import Simplex.Chat.Core
|
||||
import Simplex.Chat.Options
|
||||
import Simplex.Chat.Operators (PresetOperator (..), presetServer)
|
||||
import Simplex.Chat.Protocol (currentChatVersion, pqEncryptionCompressionVersion)
|
||||
import Simplex.Chat.Store
|
||||
import Simplex.Chat.Store.Profiles
|
||||
@@ -94,8 +95,8 @@ testCoreOpts =
|
||||
{ dbFilePrefix = "./simplex_v1",
|
||||
dbKey = "",
|
||||
-- dbKey = "this is a pass-phrase to encrypt the database",
|
||||
smpServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001"],
|
||||
xftpServers = ["xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002"],
|
||||
smpServers = [],
|
||||
xftpServers = [],
|
||||
simpleNetCfg = defaultSimpleNetCfg,
|
||||
logLevel = CLLImportant,
|
||||
logConnections = False,
|
||||
@@ -149,6 +150,18 @@ testCfg :: ChatConfig
|
||||
testCfg =
|
||||
defaultChatConfig
|
||||
{ agentConfig = testAgentCfg,
|
||||
presetServers =
|
||||
(presetServers defaultChatConfig)
|
||||
{ operators =
|
||||
[ PresetOperator
|
||||
{ operator = Nothing,
|
||||
smp = map (presetServer True) ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001"],
|
||||
useSMP = 1,
|
||||
xftp = map (presetServer True) ["xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002"],
|
||||
useXFTP = 1
|
||||
}
|
||||
]
|
||||
},
|
||||
showReceipts = False,
|
||||
testView = True,
|
||||
tbqSize = 16
|
||||
|
||||
+56
-21
@@ -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 =
|
||||
|
||||
@@ -1,8 +1,10 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PostfixOperators #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module ChatTests.Groups where
|
||||
|
||||
|
||||
@@ -2,6 +2,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PostfixOperators #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module ChatTests.Profiles where
|
||||
|
||||
@@ -1733,7 +1734,16 @@ testChangePCCUserDiffSrv tmp = do
|
||||
-- Create new user with different servers
|
||||
alice ##> "/create user alisa"
|
||||
showActiveUser alice "alisa"
|
||||
alice #$> ("/smp smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7003", id, "ok")
|
||||
alice ##> "/smp"
|
||||
alice <## "Your servers"
|
||||
alice <## " SMP servers"
|
||||
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset)"
|
||||
alice #$> ("/smp smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@127.0.0.1:7003", id, "ok")
|
||||
alice ##> "/smp"
|
||||
alice <## "Your servers"
|
||||
alice <## " SMP servers"
|
||||
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset, disabled)"
|
||||
alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@127.0.0.1:7003"
|
||||
alice ##> "/user alice"
|
||||
showActiveUser alice "alice (Alice)"
|
||||
-- Change connection to newly created user and use the newly created connection
|
||||
|
||||
+31
-20
@@ -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}
|
||||
|
||||
Reference in New Issue
Block a user