From d0a7e14a96f88fbb814baee8b414c340f1a560ea Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Mon, 11 Nov 2024 15:15:00 +0000 Subject: [PATCH] make preset servers lists potentially empty in some operators, as long as the combined list is not empty --- src/Simplex/Chat.hs | 139 ++++++++++++++++++--------------- src/Simplex/Chat/Controller.hs | 10 +-- src/Simplex/Chat/Mobile.hs | 3 +- src/Simplex/Chat/Operators.hs | 54 +++++++------ src/Simplex/Chat/Options.hs | 10 ++- src/Simplex/Chat/Terminal.hs | 6 +- tests/ChatClient.hs | 20 ++--- tests/ChatTests/Direct.hs | 6 +- tests/ChatTests/Groups.hs | 6 +- tests/ChatTests/Profiles.hs | 6 +- 10 files changed, 135 insertions(+), 125 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index cc70abf864..bcdef12fe2 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -40,12 +40,11 @@ import Data.Constraint (Dict (..)) import Data.Either (fromRight, lefts, partitionEithers, rights) import Data.Fixed (div') import Data.Foldable (foldr') -import Data.Foldable1 (fold1) 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 (..), 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 @@ -180,14 +179,14 @@ defaultChatConfig = PresetServers { operators = [ PresetOperator - { operator = operatorSimpleXChat, + { operator = Just operatorSimpleXChat, smp = simplexChatSMPServers, useSMP = 4, - xftp = L.map (presetServer True) defaultXFTPServers, + xftp = map (presetServer True) $ L.toList defaultXFTPServers, useXFTP = 3 }, PresetOperator - { operator = operatorXYZ, + { operator = Just operatorXYZ, smp = xyzSMPServers, useSMP = 3, xftp = xyzXFTPServers, @@ -197,7 +196,6 @@ defaultChatConfig = ntf = _defaultNtfServers, netCfg = defaultNetworkConfig }, - optionsServers = OptionsServers {smpServers = [], xftpServers = []}, tbqSize = 1024, fileChunkSize = 15780, -- do not change xftpDescrPartSize = 14000, @@ -219,9 +217,9 @@ defaultChatConfig = chatHooks = defaultChatHooks } -simplexChatSMPServers :: NonEmpty (NewUserServer 'PSMP) +simplexChatSMPServers :: [NewUserServer 'PSMP] simplexChatSMPServers = - L.map + map (presetServer True) [ "smp://0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU=@smp8.simplex.im,beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion", "smp://SkIkI6EPd2D63F4xFKfHk7I1UGZVNn6k1QWZ5rcyr6w=@smp9.simplex.im,jssqzccmrcws6bhmn77vgmhfjmhwlyr3u7puw4erkyoosywgl67slqqd.onion", @@ -235,16 +233,16 @@ simplexChatSMPServers = "smp://PtsqghzQKU83kYTlQ1VKg996dW4Cw4x_bvpKmiv8uns=@smp18.simplex.im,lyqpnwbs2zqfr45jqkncwpywpbtq7jrhxnib5qddtr6npjyezuwd3nqd.onion", "smp://N_McQS3F9TGoh4ER0QstUf55kGnNSd-wXfNPZ7HukcM=@smp19.simplex.im,i53bbtoqhlc365k6kxzwdp5w3cdt433s7bwh3y32rcbml2vztiyyz5id.onion" ] - <> L.map + <> 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" ] -xyzSMPServers :: NonEmpty (NewUserServer 'PSMP) +xyzSMPServers :: [NewUserServer 'PSMP] xyzSMPServers = - L.map + map (presetServer True) [ "smp://abcd@smp1.xyz.com", "smp://abcd@smp2.xyz.com", @@ -254,9 +252,9 @@ xyzSMPServers = "smp://abcd@smp6.xyz.com" ] -xyzXFTPServers :: NonEmpty (NewUserServer 'PXFTP) +xyzXFTPServers :: [NewUserServer 'PXFTP] xyzXFTPServers = - L.map + map (presetServer True) [ "xftp://abcd@xftp1.xyz.com", "xftp://abcd@xftp2.xyz.com", @@ -302,17 +300,18 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agentConfig = aCfg, presetServers, inlineFiles, deviceNameForRemote, confirmMigrations} - ChatOpts {coreOptions = CoreChatOpts {optionsServers, simpleNetCfg, logLevel, logConnections, logServerHosts, logFile, tbqSize, highlyAvailable, yesToUpMigrations}, deviceName, optFilesFolder, optTempDirectory, showReactions, allowInstantFiles, autoAcceptFileSize} + 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 - PresetServers {netCfg} = presetServers - presetServers' = (presetServers :: PresetServers) {netCfg = updateNetworkConfig netCfg simpleNetCfg} - config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, presetServers = presetServers', optionsServers, 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 <- withTransaction chatStore $ agentServers config + servers <- withTransaction chatStore $ \db -> agentServers db config randomServers smpAgent <- getSMPAgentClient aCfg {tbqSize} servers agentStore backgroundMode agentAsync <- newTVarIO Nothing random <- liftIO C.newRandom @@ -348,6 +347,7 @@ newChatController ChatController { firstTime, currentUser, + randomServers, currentRemoteHost, smpAgent, agentAsync, @@ -385,8 +385,28 @@ newChatController contactMergeEnabled } where - agentServers :: ChatConfig -> DB.Connection -> IO InitialAgentServers - agentServers ChatConfig {presetServers = PresetServers {operators = presetOps, ntf, netCfg}} db = do + 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 removeSMP operators <> [custom smpSrvs []] + ([], xftpSrvs) -> L.map removeXFTP operators <> [custom [] xftpSrvs] + (smpSrvs, xftpSrvs) -> [custom smpSrvs xftpSrvs] + removeSMP op = (op :: PresetOperator) {smp = []} + removeXFTP op = (op :: PresetOperator) {xftp = []} + custom smpSrvs xftpSrvs = + PresetOperator + { operator = Nothing, + smp = map (presetServer True) smpSrvs, + useSMP = 0, + xftp = map (presetServer True) xftpSrvs, + useXFTP = 0 + } + agentServers :: DB.Connection -> ChatConfig -> RandomServers -> IO InitialAgentServers + agentServers db ChatConfig {presetServers = PresetServers {operators = presetOps, ntf, netCfg}} randomServers = do users <- getUsers db opDomains <- operatorDomains <$> getUpdateServerOperators db presetOps (null users) smp' <- getUserServers SPSMP users opDomains @@ -395,9 +415,9 @@ newChatController where getUserServers :: forall p. (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> [User] -> [(Text, ServerOperator)] -> IO (Map UserId (NonEmpty (ServerCfg p))) getUserServers p users opDomains = do - randomSrvs <- randomPresetServers p presetOps + let randomSrvs = rndServers p randomServers fmap M.fromList $ forM users $ \u -> - (aUserId u,) . serverCfgs opDomains <$> getUpdateUserServers db p presetOps randomSrvs u + (aUserId u,) . agentServerCfgs opDomains <$> getUpdateUserServers db p presetOps randomSrvs u updateNetworkConfig :: NetworkConfig -> SimpleNetCfg -> NetworkConfig updateNetworkConfig cfg SimpleNetCfg {socksProxy, socksMode, hostMode, requiredHostMode, smpProxyMode_, smpProxyFallback_, smpWebPort, tcpTimeout_, logTLSErrors} = @@ -443,31 +463,33 @@ withFileLock name = withEntityLock name . CLFile serverCfg :: ProtoServerWithAuth p -> ServerCfg p serverCfg server = ServerCfg {server, operator = Nothing, enabled = True, roles = allRoles} -useServers :: UserProtocol p => ChatConfig -> SProtocolType p -> [UserServer p] -> [ProtocolServer p] -useServers cfg p = \case - [] -> map protoServer $ optsServers cfg p - srvs -> map (\UserServer {server} -> protoServer server) srvs +-- useServers :: UserProtocol p => ChatConfig -> SProtocolType p -> [UserServer p] -> [ProtocolServer p] +-- useServers cfg p = \case +-- [] -> map protoServer $ optsServers cfg p +-- srvs -> map (\UserServer {server} -> protoServer server) srvs -optsServers :: UserProtocol p => ChatConfig -> SProtocolType p -> [ProtoServerWithAuth p] -optsServers ChatConfig {optionsServers = OptionsServers {smpServers, xftpServers}} = \case +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 -> NonEmpty PresetOperator -> IO (NonEmpty (NewUserServer p)) -randomPresetServers p = fmap fold1 . mapM opSrvs +randomPresetServers :: forall p. UserProtocol p => SProtocolType p -> PresetServers -> IO (NonEmpty (NewUserServer p)) +randomPresetServers p PresetServers {operators} = toJust . L.nonEmpty . concat =<< mapM opSrvs operators where - opSrvs :: PresetOperator -> IO (NonEmpty (NewUserServer p)) + 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 - (enbldSrvs, dsbldSrvs) = L.partition (\UserServer {enabled} -> enabled) srvs toUse = operatorServersToUse p op - if length enbldSrvs <= toUse + (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 - srvs' = sortOn server' $ enbldSrvs' <> dsbldSrvs' <> dsbldSrvs - pure $ fromMaybe srvs $ L.nonEmpty srvs' + pure $ sortOn server' $ enbldSrvs' <> dsbldSrvs' <> dsbldSrvs server' UserServer {server = ProtoServerWithAuth srv _} = srv -- enableSndFiles has no effect when mainApp is True @@ -612,13 +634,15 @@ processChatCommand' vr = \case forM_ profile $ \Profile {displayName} -> checkValidName displayName p@Profile {displayName} <- liftIO $ maybe generateRandomProfile pure profile u <- asks currentUser - opDomains <- operatorDomains . fst <$> withFastStore getServerOperators - (smp, smpServers) <- chooseServers SPSMP opDomains - (xftp, xftpServers) <- chooseServers SPXFTP opDomains + 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 + let smp = agentServerCfgs opDomains smpServers + xftp = agentServerCfgs opDomains 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 @@ -635,21 +659,13 @@ processChatCommand' vr = \case withFastStore $ \db -> do createContact db user simplexStatusContactProfile createContact db user simplexTeamContactProfile - chooseServers :: forall p. (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> [(Text, ServerOperator)] -> CM (NonEmpty (ServerCfg p), NonEmpty (NewUserServer p)) - chooseServers p opDomains = do - cfg <- asks config - case L.nonEmpty $ optsServers cfg p of - Just srvs -> pure (L.map serverCfg srvs, L.map newUserServer srvs) - Nothing -> do - PresetServers {operators = presetOps} <- asks $ presetServers . config - randomSrvs <- liftIO $ randomPresetServers p presetOps - chatReadVar currentUser >>= \case - Nothing -> pure (serverCfgs opDomains randomSrvs, randomSrvs) - Just user -> do - srvs <- withFastStore' $ \db -> getUpdateUserServers db p presetOps randomSrvs user - pure (serverCfgs opDomains srvs, L.map (\srv -> (srv :: UserServer p) {serverId = DBNewEntity}) srvs) - newUserServer :: ProtoServerWithAuth p -> NewUserServer p - newUserServer server = UserServer {serverId = DBNewEntity, server, preset = True, tested = Nothing, enabled = True} + chooseServers :: forall p. (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> CM (NonEmpty (NewUserServer p)) + chooseServers p = + chatReadVar currentUser + $>>= (fmap L.nonEmpty . withFastStore' . flip getProtocolServers) + >>= \case + Nothing -> rndServers p <$> asks randomServers + Just srvs -> pure $ L.map (\srv -> (srv :: UserServer p) {serverId = DBNewEntity}) srvs coupleDaysAgo t = (`addUTCTime` t) . fromInteger . negate . (+ (2 * day)) <$> randomRIO (0, day) day = 86400 ListUsers -> CRUsersList <$> withFastStore' getUsersInfo @@ -1859,8 +1875,7 @@ processChatCommand' vr = \case canKeepLink (CRInvitationUri crData _) newUser = do let ConnReqUriData {crSmpQueues = q :| _} = crData SMPQueueUri {queueAddress = SMPQueueAddress {smpServer}} = q - cfg <- asks config - newUserServers <- useServers cfg SPSMP <$> withFastStore' (`getProtocolServers` newUser) + newUserServers <- map (\UserServer {server} -> protoServer server) <$> withFastStore' (`getProtocolServers` newUser) pure $ smpServer `elem` newUserServers updateConnRecord user@User {userId} conn@PendingContactConnection {customUserProfileId} newUser = do withAgent $ \a -> changeConnectionUser a (aUserId user) (aConnId' conn) (aUserId newUser) @@ -2592,16 +2607,15 @@ processChatCommand' vr = \case pure $ CRAgentSubsTotal user subsTotal hasSession GetAgentServersSummary userId -> withUserId userId $ \user -> do agentServersSummary <- lift $ withAgent' getAgentServersSummary - cfg <- asks config withStore' $ \db -> do users <- getUsers db - smpServers <- getServers db user cfg SPSMP - xftpServers <- getServers db user cfg SPXFTP + 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 -> User -> ChatConfig -> SProtocolType p -> IO [ProtocolServer p] - getServers db user cfg p = useServers cfg p <$> getProtocolServers db user + getServers :: (ProtocolTypeI p, UserProtocol p) => DB.Connection -> User -> SProtocolType p -> IO [ProtocolServer p] + getServers db user _p = map (\UserServer {server} -> protoServer server) <$> getProtocolServers db user ResetAgentServersStats -> withAgent resetAgentServersStats >> ok_ GetAgentWorkers -> lift $ CRAgentWorkersSummary <$> withAgent' getAgentWorkersSummary GetAgentWorkersDetails -> lift $ CRAgentWorkersDetails <$> withAgent' getAgentWorkersDetails @@ -3719,8 +3733,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 <- useServers cfg SPXFTP <$> withStore' (`getProtocolServers` user) + knownSrvs <- map (\UserServer {server} -> protoServer server) <$> withStore' (`getProtocolServers` user) pure $ filter (`notElem` knownSrvs) srvs ipProtectedForSrvs :: [XFTPServer] -> CM Bool ipProtectedForSrvs srvs = do @@ -5025,7 +5038,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 diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index f41ed26e98..2c062f757d 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -84,7 +84,7 @@ import Simplex.Messaging.Crypto.Ratchet (PQEncryption) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfTknStatus) import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, parseAll, parseString, sumTypeJSON) -import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType (..), CorrId, MsgId, NMsgMeta (..), NtfServer, QueueId, XFTPServerWithAuth, SMPMsgMeta (..), SubscriptionMode (..), XFTPServer) +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 +133,6 @@ data ChatConfig = ChatConfig chatVRange :: VersionRangeChat, confirmMigrations :: MigrationConfirmation, presetServers :: PresetServers, - optionsServers :: OptionsServers, tbqSize :: Natural, fileChunkSize :: Integer, xftpDescrPartSize :: Int, @@ -155,9 +154,9 @@ data ChatConfig = ChatConfig chatHooks :: ChatHooks } -data OptionsServers = OptionsServers - { smpServers :: [SMPServerWithAuth], - xftpServers :: [XFTPServerWithAuth] +data RandomServers = RandomServers + { smpServers :: NonEmpty (NewUserServer 'PSMP), + xftpServers :: NonEmpty (NewUserServer 'PXFTP) } -- The hooks can be used to extend or customize chat core in mobile or CLI clients. @@ -206,6 +205,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, diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index f6566c5a6d..57b0ee6c17 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/src/Simplex/Chat/Mobile.hs @@ -189,7 +189,8 @@ mobileChatOpts dbFilePrefix = CoreChatOpts { dbFilePrefix, dbKey = "", -- for API database is already opened, and the key in options is not used - optionsServers = OptionsServers [] [], + smpServers = [], + xftpServers = [], simpleNetCfg = defaultSimpleNetCfg, logLevel = CLLImportant, logConnections = False, diff --git a/src/Simplex/Chat/Operators.hs b/src/Simplex/Chat/Operators.hs index 256654bea8..59b079bcfc 100644 --- a/src/Simplex/Chat/Operators.hs +++ b/src/Simplex/Chat/Operators.hs @@ -22,7 +22,7 @@ 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.Foldable1 (foldMap1) +import Data.Foldable (foldMap') import Data.IORef import Data.Int (Int64) import Data.List (find, foldl') @@ -42,7 +42,7 @@ 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 (..), allRoles) +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 (..), ProtocolTypeI, SProtocolType (..), UserProtocol) @@ -201,14 +201,14 @@ data UserServer' s p = UserServer deriving (Show) data PresetOperator = PresetOperator - { operator :: NewServerOperator, - smp :: NonEmpty (NewUserServer 'PSMP), + { operator :: Maybe NewServerOperator, + smp :: [NewUserServer 'PSMP], useSMP :: Int, - xftp :: NonEmpty (NewUserServer 'PXFTP), + xftp :: [NewUserServer 'PXFTP], useXFTP :: Int } -operatorServers :: UserProtocol p => SProtocolType p -> PresetOperator -> NonEmpty (NewUserServer p) +operatorServers :: UserProtocol p => SProtocolType p -> PresetOperator -> [NewUserServer p] operatorServers p PresetOperator {smp, xftp} = case p of SPSMP -> smp SPXFTP -> xftp @@ -255,36 +255,38 @@ updatedServerOperators presetOps storedOps = <> map (ASO SDBStored) (filter (isNothing . operatorTag) storedOps) where -- TODO remove domains of preset operators from custom - addPreset PresetOperator {operator = 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 + 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 p presetOps randomSrvs = \case - [] -> L.map (AUS SDBNew) randomSrvs - srvs -> - L.map (userServer storedSrvs) presetSrvs - `L.appendList` map (AUS SDBStored) (filter customServer srvs) - where - storedSrvs = foldl' (\ss srv@UserServer {server} -> M.insert server srv ss) M.empty srvs +updatedUserServers _ _ randomSrvs [] = L.map (AUS SDBNew) randomSrvs +updatedUserServers p presetOps randomSrvs srvs = + fromMaybe (L.map (AUS SDBNew) randomSrvs) (L.nonEmpty updatedServers) where + updatedServers = 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 :: NonEmpty (NewUserServer p) - presetSrvs = foldMap1 (operatorServers p) presetOps + presetSrvs :: [NewUserServer p] + presetSrvs = concatMap (operatorServers p) presetOps presetHosts :: Set TransportHost - presetHosts = foldMap1 (S.fromList . L.toList . srvHost) presetSrvs - userServer :: Map (ProtoServerWithAuth p) (UserServer p) -> NewUserServer p -> AUserServer p - userServer storedSrvs srv@UserServer {server} = maybe (AUS SDBNew srv) (AUS SDBStored) (M.lookup server storedSrvs) + 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 -serverCfgs :: [(Text, ServerOperator)] -> NonEmpty (UserServer' s p) -> NonEmpty (ServerCfg p) -serverCfgs opDomains = L.map agentServer +agentServerCfgs :: [(Text, ServerOperator)] -> NonEmpty (UserServer' s p) -> NonEmpty (ServerCfg p) +agentServerCfgs opDomains = L.map agentServer where agentServer :: UserServer' s p -> ServerCfg p agentServer srv@UserServer {server, enabled} = diff --git a/src/Simplex/Chat/Options.hs b/src/Simplex/Chat/Options.hs index cb54f14e0e..16ffe6e28f 100644 --- a/src/Simplex/Chat/Options.hs +++ b/src/Simplex/Chat/Options.hs @@ -27,12 +27,12 @@ import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Numeric.Natural (Natural) import Options.Applicative -import Simplex.Chat.Controller (ChatLogLevel (..), OptionsServers (..), SimpleNetCfg (..), updateStr, versionNumber, versionString) +import Simplex.Chat.Controller (ChatLogLevel (..), SimpleNetCfg (..), updateStr, versionNumber, versionString) import Simplex.FileTransfer.Description (mb) import Simplex.Messaging.Client (HostMode (..), SocksMode (..), textToHostMode) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (parseAll) -import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolTypeI) +import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolTypeI, SMPServerWithAuth, XFTPServerWithAuth) import Simplex.Messaging.Transport.Client (SocksProxyWithAuth (..), SocksAuth (..), defaultSocksProxyWithAuth) import System.FilePath (combine) @@ -56,7 +56,8 @@ data ChatOpts = ChatOpts data CoreChatOpts = CoreChatOpts { dbFilePrefix :: String, dbKey :: ScrubbedBytes, - optionsServers :: OptionsServers, + smpServers :: [SMPServerWithAuth], + xftpServers :: [XFTPServerWithAuth], simpleNetCfg :: SimpleNetCfg, logLevel :: ChatLogLevel, logConnections :: Bool, @@ -243,7 +244,8 @@ coreChatOptsP appDir defaultDbFileName = do CoreChatOpts { dbFilePrefix, dbKey, - optionsServers = OptionsServers {smpServers, xftpServers}, + smpServers, + xftpServers, simpleNetCfg = SimpleNetCfg { socksProxy, diff --git a/src/Simplex/Chat/Terminal.hs b/src/Simplex/Chat/Terminal.hs index 361e61b953..aa6babfcbd 100644 --- a/src/Simplex/Chat/Terminal.hs +++ b/src/Simplex/Chat/Terminal.hs @@ -34,16 +34,16 @@ terminalChatConfig = PresetServers { operators = [ PresetOperator - { operator = operatorSimpleXChat, + { operator = Just operatorSimpleXChat, smp = - L.map + 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 = L.map (presetServer True) defaultXFTPServers, + xftp = map (presetServer True) $ L.toList defaultXFTPServers, useXFTP = 3 } ], diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index cfe8cf60f4..ab47951214 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -21,12 +21,11 @@ import Control.Monad.Reader import Data.ByteArray (ScrubbedBytes) import Data.Functor (($>)) import Data.List (dropWhileEnd, find) -import qualified Data.List.NonEmpty as L 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 (..), OptionsServers (..), PresetServers (..), 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) @@ -96,8 +95,8 @@ testCoreOpts = { dbFilePrefix = "./simplex_v1", dbKey = "", -- dbKey = "this is a pass-phrase to encrypt the database", - -- optionsServers = testOptsServers, - optionsServers = OptionsServers [] [], + smpServers = [], + xftpServers = [], simpleNetCfg = defaultSimpleNetCfg, logLevel = CLLImportant, logConnections = False, @@ -109,13 +108,6 @@ testCoreOpts = yesToUpMigrations = False } -testOptsServers :: OptionsServers -testOptsServers = - OptionsServers - { smpServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001"], - xftpServers = ["xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002"] - } - getTestOpts :: Bool -> ScrubbedBytes -> ChatOpts getTestOpts maintenance dbKey = testOpts {maintenance, coreOptions = testCoreOpts {dbKey}} @@ -162,10 +154,10 @@ testCfg = (presetServers defaultChatConfig) { operators = [ PresetOperator - { operator = operatorSimpleXChat, - smp = L.map (presetServer True) ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001"], + { operator = Just operatorSimpleXChat, + smp = map (presetServer True) ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001"], useSMP = 1, - xftp = L.map (presetServer True) ["xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002"], + xftp = map (presetServer True) ["xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002"], useXFTP = 1 } ] diff --git a/tests/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs index 7b34f19bc2..39e0599150 100644 --- a/tests/ChatTests/Direct.hs +++ b/tests/ChatTests/Direct.hs @@ -25,7 +25,7 @@ import Database.SQLite.Simple (Only (..)) import Simplex.Chat.AppSettings (defaultAppSettings) import qualified Simplex.Chat.AppSettings as AS import Simplex.Chat.Call -import Simplex.Chat.Controller (ChatConfig (..), OptionsServers (..), PresetServers (..)) +import Simplex.Chat.Controller (ChatConfig (..), PresetServers (..)) import Simplex.Chat.Messages (ChatItemId) import Simplex.Chat.Options import Simplex.Chat.Protocol (supportedChatVRange) @@ -271,7 +271,7 @@ testRetryConnecting tmp = testChatCfgOpts2 cfg' opts' aliceProfile bobProfile te testOpts { coreOptions = testCoreOpts - { optionsServers = testOptsServers {smpServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7003"]} + { smpServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7003"] } } @@ -340,7 +340,7 @@ testRetryConnectingClientTimeout tmp = do testOpts { coreOptions = testCoreOpts - { optionsServers = testOptsServers {smpServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7003"]} + { smpServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7003"] } } diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index 979f696d15..5f69b00fba 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -17,7 +17,7 @@ import qualified Data.ByteString.Char8 as B import Data.List (intercalate, isInfixOf) import qualified Data.Text as T import Database.SQLite.Simple (Only (..)) -import Simplex.Chat.Controller (ChatConfig (..), OptionsServers (..)) +import Simplex.Chat.Controller (ChatConfig (..)) import Simplex.Chat.Messages (ChatItemId) import Simplex.Chat.Options import Simplex.Chat.Protocol (supportedChatVRange) @@ -6504,7 +6504,7 @@ testGroupMemberInactive tmp = do opts' = testOpts { coreOptions = - (testCoreOpts :: CoreChatOpts) - { optionsServers = testOptsServers {smpServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7003"]} + testCoreOpts + { smpServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7003"] } } diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index d6ee04baa5..d98a818db4 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -15,7 +15,7 @@ import Control.Monad.Except import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B import qualified Data.Text as T -import Simplex.Chat.Controller (ChatConfig (..), OptionsServers (..)) +import Simplex.Chat.Controller (ChatConfig (..)) import Simplex.Chat.Options import Simplex.Chat.Store.Shared (createContact) import Simplex.Chat.Types (ConnStatus (..), Profile (..)) @@ -314,8 +314,8 @@ testRetryAcceptingViaContactLink tmp = testChatCfgOpts2 cfg' opts' aliceProfile opts' = testOpts { coreOptions = - (testCoreOpts :: CoreChatOpts) - { optionsServers = testOptsServers {smpServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7003"]} + testCoreOpts + { smpServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7003"] } }