blade/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2024-12-17 17:20:21 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

core: servers summary api (#4319)

Browse Source 
* core: servers summary api

* rework

* server known types

* set stats file path

* rename

* local simplexmq

* update

* rfc

* update

* update

* get servers

* compile summary

* remove sort

* rename

* rename, refactor

* refactor attempt

* refactor attempt 2

* refactor

* fix

* fix2

* remove space

* refactor xftp

* update

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
This commit is contained in:
spaced4ndy
2024-06-25 09:51:55 +04:00
committed by GitHub
parent 1af513c548
commit d951003191
18 changed files with 432 additions and 35 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat.hs
+21 -5
View File
@@ -20,6 +20,7 @@ import Control.Applicative (optional, (<|>))
import Control.Concurrent.STM (retry)
import Control.Logger.Simple
import Control.Monad
import Simplex.Chat.Stats
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Reader
@@ -84,7 +85,6 @@ import Simplex.Chat.Store.Shared
import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences
import Simplex.Chat.Types.Shared
import Simplex.Chat.Types.Util
import Simplex.Chat.Util (encryptFile, liftIOEither, shuffle)
import qualified Simplex.Chat.Util as U
import Simplex.FileTransfer.Client.Main (maxFileSize, maxFileSizeHard)
@@ -113,7 +113,7 @@ import qualified Simplex.Messaging.Crypto.Ratchet as CR
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (base64P)
import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType (..), EntityId, ErrorType (..), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth (..), ProtocolTypeI, SProtocolType (..), SubscriptionMode (..), UserProtocol, XFTPServer, userProtocol)
import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType (..), EntityId, ErrorType (..), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth (..), ProtocolTypeI, SProtocolType (..), SubscriptionMode (..), UserProtocol, XFTPServer, userProtocol, ProtocolServer)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.ServiceScheme (ServiceScheme (..))
import qualified Simplex.Messaging.TMap as TM
@@ -369,7 +369,7 @@ activeAgentServers ChatConfig {defaultServers} p =
fromMaybe (cfgServers p defaultServers)
. nonEmpty
. map (\ServerCfg {server} -> server)
. filter (\ServerCfg {enabled} -> enabled)
. filter (\ServerCfg {enabled} -> enabled == SEEnabled)
cfgServers :: UserProtocol p => SProtocolType p -> (DefaultAgentServers -> NonEmpty (ProtoServerWithAuth p))
cfgServers p DefaultAgentServers {smp, xftp} = case p of
@@ -1315,7 +1315,7 @@ processChatCommand' vr = \case
servers' = fromMaybe (L.map toServerCfg defServers) $ nonEmpty servers
pure $ CRUserProtoServers user $ AUPS $ UserProtoServers p servers' defServers
where
toServerCfg server = ServerCfg {server, preset = True, tested = Nothing, enabled = True}
toServerCfg server = ServerCfg {server, preset = True, tested = Nothing, enabled = SEEnabled}
GetUserProtoServers aProtocol -> withUser $ \User {userId} ->
processChatCommand $ APIGetUserProtoServers userId aProtocol
APISetUserProtoServers userId (APSC p (ProtoServersConfig servers)) -> withUserId userId $ \user -> withServerProtocol p $ do
@@ -2253,6 +2253,21 @@ processChatCommand' vr = \case
CLUserContact ucId -> "UserContact " <> show ucId
CLFile fId -> "File " <> show fId
DebugEvent event -> toView event >> ok_
GetAgentServersSummary userId -> withUserId userId $ \user -> do
agentServersSummary <- lift $ withAgent' getAgentServersSummary
users <- withStore' getUsers
smpServers <- getUserServers user SPSMP
xftpServers <- getUserServers user SPXFTP
let presentedServersSummary = toPresentedServersSummary agentServersSummary users user smpServers xftpServers
pure $ CRAgentServersSummary user presentedServersSummary
where
getUserServers :: forall p. (ProtocolTypeI p, UserProtocol p) => User -> SProtocolType p -> CM [ProtocolServer p]
getUserServers users protocol = do
ChatConfig {defaultServers} <- asks config
let defServers = cfgServers protocol defaultServers
servers <- map (\ServerCfg {server} -> server) <$> withStore' (`getProtocolServers` users)
let srvs = if null servers then L.toList defServers else servers
pure $ map protoServer srvs
GetAgentWorkers -> lift $ CRAgentWorkersSummary <$> withAgent' getAgentWorkersSummary
GetAgentWorkersDetails -> lift $ CRAgentWorkersDetails <$> withAgent' getAgentWorkersDetails
GetAgentStats -> lift $ CRAgentStats . map stat <$> withAgent' getAgentStats
@@ -7611,6 +7626,7 @@ chatCommandP =
("/version" <|> "/v") $> ShowVersion,
"/debug locks" $> DebugLocks,
"/debug event " *> (DebugEvent <$> jsonP),
"/get servers summary " *> (GetAgentServersSummary <$> A.decimal),
"/get stats" $> GetAgentStats,
"/reset stats" $> ResetAgentStats,
"/get subs" $> GetAgentSubs,
@@ -7755,7 +7771,7 @@ chatCommandP =
(Just <$> (AutoAccept <$> (" incognito=" *> onOffP <|> pure False) <*> optional (A.space *> msgContentP)))
(pure Nothing)
srvCfgP = strP >>= \case AProtocolType p -> APSC p <$> (A.space *> jsonP)
toServerCfg server = ServerCfg {server, preset = False, tested = Nothing, enabled = True}
toServerCfg server = ServerCfg {server, preset = False, tested = Nothing, enabled = SEEnabled}
rcCtrlAddressP = RCCtrlAddress <$> ("addr=" *> strP) <*> (" iface=" *> (jsonP <|> text1P))
text1P = safeDecodeUtf8 <$> A.takeTill (== ' ')
char_ = optional . A.char