cli: options for private message routing and fallback mode (#4256)

* cli: options for private message routing and fallback mode

* remove short options

* fix tests

* encoding

* fix
This commit is contained in:
Evgeny Poberezkin
2024-05-31 23:41:20 +01:00
committed by GitHub
parent c52e5349db
commit ef30fcf5e2
8 changed files with 95 additions and 43 deletions
+26 -10
View File
@@ -94,7 +94,7 @@ import qualified Simplex.FileTransfer.Description as FD
import Simplex.FileTransfer.Protocol (FileParty (..), FilePartyI)
import qualified Simplex.FileTransfer.Transport as XFTP
import Simplex.Messaging.Agent as Agent
import Simplex.Messaging.Agent.Client (AgentStatsKey (..), SubInfo (..), agentClientStore, getAgentQueuesInfo, getAgentWorkersDetails, getAgentWorkersSummary, ipAddressProtected, temporaryAgentError, withLockMap)
import Simplex.Messaging.Agent.Client (AgentStatsKey (..), SubInfo (..), agentClientStore, getAgentQueuesInfo, getAgentWorkersDetails, getAgentWorkersSummary, getNetworkConfig', ipAddressProtected, temporaryAgentError, withLockMap)
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), createAgentStore, defaultAgentConfig)
import Simplex.Messaging.Agent.Lock (withLock)
import Simplex.Messaging.Agent.Protocol
@@ -103,7 +103,7 @@ import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), Migrati
import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..))
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
import Simplex.Messaging.Client (ProxyClientError (..), defaultNetworkConfig)
import Simplex.Messaging.Client (ProxyClientError (..), NetworkConfig (..), defaultNetworkConfig)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import qualified Simplex.Messaging.Crypto.File as CF
@@ -218,7 +218,7 @@ newChatController
ChatDatabase {chatStore, agentStore}
user
cfg@ChatConfig {agentConfig = aCfg, defaultServers, inlineFiles, deviceNameForRemote}
ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, networkConfig, logLevel, logConnections, logServerHosts, logFile, tbqSize, highlyAvailable}, deviceName, optFilesFolder, optTempDirectory, showReactions, allowInstantFiles, autoAcceptFileSize}
ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, simpleNetCfg, logLevel, logConnections, logServerHosts, logFile, tbqSize, highlyAvailable}, deviceName, optFilesFolder, optTempDirectory, showReactions, allowInstantFiles, autoAcceptFileSize}
backgroundMode = do
let inlineFiles' = if allowInstantFiles || autoAcceptFileSize > 0 then inlineFiles else inlineFiles {sendChunks = 0, receiveInstant = False}
config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, defaultServers = configServers, inlineFiles = inlineFiles', autoAcceptFileSize, highlyAvailable}
@@ -303,7 +303,7 @@ newChatController
let DefaultAgentServers {smp = defSmp, xftp = defXftp} = defaultServers
smp' = fromMaybe defSmp (nonEmpty smpServers)
xftp' = fromMaybe defXftp (nonEmpty xftpServers)
in defaultServers {smp = smp', xftp = xftp', netCfg = networkConfig}
in defaultServers {smp = smp', xftp = xftp', netCfg = updateNetworkConfig defaultNetworkConfig simpleNetCfg}
agentServers :: ChatConfig -> IO InitialAgentServers
agentServers config@ChatConfig {defaultServers = defServers@DefaultAgentServers {ntf, netCfg}} = do
users <- withTransaction chatStore getUsers
@@ -321,6 +321,13 @@ newChatController
userServers :: User -> IO (NonEmpty (ProtoServerWithAuth p))
userServers user' = activeAgentServers config protocol <$> withTransaction chatStore (`getProtocolServers` user')
updateNetworkConfig :: NetworkConfig -> SimpleNetCfg -> NetworkConfig
updateNetworkConfig cfg SimpleNetCfg {socksProxy, smpProxyMode_, smpProxyFallback_, tcpTimeout_, logTLSErrors} =
let cfg1 = maybe cfg (\smpProxyMode -> cfg {smpProxyMode}) smpProxyMode_
cfg2 = maybe cfg1 (\smpProxyFallback -> cfg1 {smpProxyFallback}) smpProxyFallback_
cfg3 = maybe cfg2 (\tcpTimeout -> cfg2 {tcpTimeout, tcpConnectTimeout = (tcpTimeout * 3) `div` 2}) tcpTimeout_
in cfg3 {socksProxy, logTLSErrors}
withChatLock :: String -> CM a -> CM a
withChatLock name action = asks chatLock >>= \l -> withLock l name action
@@ -1342,7 +1349,11 @@ processChatCommand' vr = \case
processChatCommand $ APIGetChatItemTTL userId
APISetNetworkConfig cfg -> withUser' $ \_ -> lift (withAgent' (`setNetworkConfig` cfg)) >> ok_
APIGetNetworkConfig -> withUser' $ \_ ->
lift $ CRNetworkConfig <$> withAgent' getNetworkConfig
CRNetworkConfig <$> lift getNetworkConfig
SetNetworkConfig netCfg -> do
cfg <- lift getNetworkConfig
void . processChatCommand $ APISetNetworkConfig $ updateNetworkConfig cfg netCfg
pure $ CRNetworkConfig cfg
APISetNetworkInfo info -> lift (withAgent' (`setUserNetworkInfo` info)) >> ok_
ReconnectAllServers -> withUser' $ \_ -> lift (withAgent' reconnectAllServers) >> ok_
APISetChatSettings (ChatRef cType chatId) chatSettings -> withUser $ \user -> case cType of
@@ -3194,7 +3205,7 @@ receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete}
pure $ filter (`notElem` knownSrvs) srvs
ipProtectedForSrvs :: [XFTPServer] -> CM Bool
ipProtectedForSrvs srvs = do
netCfg <- lift $ withAgent' getNetworkConfig
netCfg <- lift getNetworkConfig
pure $ all (ipAddressProtected netCfg) srvs
relaysNotApproved :: [XFTPServer] -> CM ()
relaysNotApproved unknownSrvs = do
@@ -3202,6 +3213,9 @@ receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete}
forM_ aci_ $ \aci -> toView $ CRChatItemUpdated user aci
throwChatError $ CEFileNotApproved fileId unknownSrvs
getNetworkConfig :: CM' NetworkConfig
getNetworkConfig = withAgent' $ liftIO . getNetworkConfig'
resetRcvCIFileStatus :: User -> FileTransferId -> CIFileStatus 'MDRcv -> CM (Maybe AChatItem)
resetRcvCIFileStatus user fileId ciFileStatus = do
vr <- chatVersionRange
@@ -7365,7 +7379,7 @@ chatCommandP =
"/ttl" $> GetChatItemTTL,
"/_network info " *> (APISetNetworkInfo <$> jsonP),
"/_network " *> (APISetNetworkConfig <$> jsonP),
("/network " <|> "/net ") *> (APISetNetworkConfig <$> netCfgP),
("/network " <|> "/net ") *> (SetNetworkConfig <$> netCfgP),
("/network" <|> "/net") $> APIGetNetworkConfig,
"/reconnect" $> ReconnectAllServers,
"/_settings " *> (APISetChatSettings <$> chatRefP <* A.space <*> jsonP),
@@ -7678,10 +7692,12 @@ chatCommandP =
<|> ("no" $> TMEDisableKeepTTL)
netCfgP = do
socksProxy <- "socks=" *> ("off" $> Nothing <|> "on" $> Just defaultSocksProxy <|> Just <$> strP)
smpProxyMode_ <- optional $ " smp-proxy=" *> strP
smpProxyFallback_ <- optional $ " smp-proxy-fallback=" *> strP
t_ <- optional $ " timeout=" *> A.decimal
logErrors <- " log=" *> onOffP <|> pure False
let tcpTimeout = 1000000 * fromMaybe (maybe 5 (const 10) socksProxy) t_
pure $ fullNetworkConfig socksProxy tcpTimeout logErrors
logTLSErrors <- " log=" *> onOffP <|> pure False
let tcpTimeout_ = (1000000 *) <$> t_
pure $ SimpleNetCfg {socksProxy, smpProxyMode_, smpProxyFallback_, tcpTimeout_, logTLSErrors}
dbKeyP = nonEmptyKey <$?> strP
nonEmptyKey k@(DBEncryptionKey s) = if BA.null s then Left "empty key" else Right k
dbEncryptionConfig currentKey newKey = DBEncryptionConfig {currentKey, newKey, keepKey = Just False}