diff --git a/cabal.project b/cabal.project index 5a607b257d..be95820371 100644 --- a/cabal.project +++ b/cabal.project @@ -12,7 +12,7 @@ constraints: zip +disable-bzip2 +disable-zstd source-repository-package type: git location: https://github.com/simplex-chat/simplexmq.git - tag: 8a3b72458f917e9867f4e3640dda0fa1827ff6cf + tag: c7886926870e97fa592d51fa36a2cdec49296388 source-repository-package type: git diff --git a/docs/rfcs/2024-06-17-agent-stats-persistence.md b/docs/rfcs/2024-06-17-agent-stats-persistence.md new file mode 100644 index 0000000000..2f5d641769 --- /dev/null +++ b/docs/rfcs/2024-06-17-agent-stats-persistence.md @@ -0,0 +1,87 @@ +# Agent stats persistence + +## Problem + +State/state tracked in agent are lost on app restart, which makes it difficult to debug user bugs. + +## Solution + +Persist stats between sessions. + +App terminal signals may vary per platform / be absent (?) -> persist stats periodically. + +Stats would have `` key, so we don't want to store them in a plaintext file to not leak used servers locally -> persist in encrypted db. + +There's couple of orthogonal design decision to be made: +- persist in chat or in agent db + - pros for chat: + - possibly less contention for db than agent + - pros for agent: + - no unnecessary back and forth, especially if agent starts accumulating from past sessions and has to be parameterized with past stats (see below) +- agent to start accumulating from past sessions stats, or keep past separately and only accumulate for current session from zeros + - pros for accumulating from past sessions: + - easier to maintain stats - e.g. user deletion has to remove keys, which is more convoluted if past stats are not stored in memory + - simpler UI - overall stats, no differentiation for past/current session (or less logic in backend preparing presentation data) + - pros for accumulating from zeros: + - simpler start logic - no need to restore stats from agent db / pass initial stats from chat db + - can differentiate between past sessions and current session stats in UI + +### Option 1 - Persist in chat db, agent to track only current session + +- Chat stores stats in such table: + +```sql +CREATE TABLE agent_stats( + agent_stats_id INTEGER PRIMARY KEY, -- dummy id, there will only be one record + past_stats TEXT, -- accumulated from previous sessions + session_stats TEXT, -- current session + past_started_at TEXT NOT NULL DEFAULT(datetime('now')), -- starting point of tracking stats, reset on stats reset + session_started_at TEXT NOT NULL DEFAULT(datetime('now')), -- starting point of current session + session_updated_at TEXT NOT NULL DEFAULT(datetime('now')) -- last update of current session stats (periodic, frequent updates) +); +``` + +- Chat periodically calls getAgentServersStats api and updates `session_stats`. + - interval? should be short to not lose too much data, 5-30 seconds? +- On start `session_stats` are accumulated into `past_stats` and set to null. +- On user deletion, agent updates current session stats in memory (removes keys), chat has to do same for both stats fields in db. + - other cases where stats have to be manipulated in similar way? + +### Option 2 - Persist in chat db, agent to accumulate stats from past sessions + +- Table is only used for persistence of overall stats: + +```sql +CREATE TABLE agent_stats( + agent_stats_id INTEGER PRIMARY KEY, -- dummy id, there will only be one record + agent_stats TEXT, -- overall stats - past and session + started_tracking_at TEXT NOT NULL DEFAULT(datetime('now')), -- starting point of tracking stats, reset on stats reset + updated_at TEXT NOT NULL DEFAULT(datetime('now')) +); +``` + +- Chat to parameterize creation of agent client with initial stats. + +### Option 3 - Persist in agent db, agent to differentiate past stats and session stats + +- Table in agent db similar to option 1. +- Agent is responsible for periodic updates in session, as well as accumulating into "past" and resetting session stats on start. +- Agent only communicates stats to chat on request. +- On user deletion agent is fully responsible for maintaining both in-memory session stats, and updating db records. + +### Option 4 - Persist in agent db, agent to accumulate stats from past sessions + +- Table in agent db similar to option 2. +- On start agent restores initial stats into memory by itself. +- Since all stats are in memory, on user deletion it's enough to update in memory without updating db. + - there is a race possible where agent crashes after updating stats (removing user keys) in memory before database stats have been overwritten by a periodic update, so it may be better to immediately overwrite and not wait for periodic update. + - still at least there's at least no additional logic to update past stats. + +### Other considerations + +Why is it important to timely remove user keys from past stats? +- stats not being saved for past users: + - important both privacy-wise and to not cause confusion when showing "All" stats (e.g. user summing up across users stats would have smaller total than total stats). + - to avoid accidentally mixing up with newer users. + - though we do have an AUTOINCREMENT user_id in agent so probably it wouldn't be a problem. +- on the other hand maybe we don't want to "forget" stats on user deletion so that stats would reflect networking more accurately? diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index fc8833ee31..3a8284a74b 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -1,5 +1,5 @@ { - "https://github.com/simplex-chat/simplexmq.git"."8a3b72458f917e9867f4e3640dda0fa1827ff6cf" = "1mmxdaj563kjmlkacxdnq62n6mzw9khampzaqghnk6iiwzdig0qy"; + "https://github.com/simplex-chat/simplexmq.git"."c7886926870e97fa592d51fa36a2cdec49296388" = "1r3nibcgw3whl0q3ssyr1606x4ilqphhzqyihi3aw4nw5fmz226h"; "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38"; "https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d"; "https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl"; diff --git a/simplex-chat.cabal b/simplex-chat.cabal index f8ab75568b..3b9d2681d9 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -160,6 +160,7 @@ library Simplex.Chat.Remote.RevHTTP Simplex.Chat.Remote.Transport Simplex.Chat.Remote.Types + Simplex.Chat.Stats Simplex.Chat.Store Simplex.Chat.Store.AppSettings Simplex.Chat.Store.Connections diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index c46eed70e1..539ad003ba 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -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 diff --git a/src/Simplex/Chat/Call.hs b/src/Simplex/Chat/Call.hs index 115cd839e4..9968d170aa 100644 --- a/src/Simplex/Chat/Call.hs +++ b/src/Simplex/Chat/Call.hs @@ -21,10 +21,10 @@ import Data.Time.Clock (UTCTime) import Database.SQLite.Simple.FromField (FromField (..)) import Database.SQLite.Simple.ToField (ToField (..)) import Simplex.Chat.Types (Contact, ContactId, User) -import Simplex.Chat.Types.Util (decodeJSON, encodeJSON) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, fstToLower, singleFieldJSON) +import Simplex.Messaging.Util (decodeJSON, encodeJSON) data Call = Call { contactId :: ContactId, diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 04f360cc3e..4404360c2a 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -60,6 +60,7 @@ import Simplex.Chat.Messages.CIContent import Simplex.Chat.Protocol import Simplex.Chat.Remote.AppVersion import Simplex.Chat.Remote.Types +import Simplex.Chat.Stats (PresentedServersSummary) import Simplex.Chat.Store (AutoAccept, ChatLockEntity, StoreError (..), UserContactLink, UserMsgReceiptSettings) import Simplex.Chat.Types import Simplex.Chat.Types.Preferences @@ -75,7 +76,7 @@ import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation, SQLiteStore, UpMigration, withTransaction) import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..)) import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB -import Simplex.Messaging.Client (SMPProxyMode (..), SMPProxyFallback (..)) +import Simplex.Messaging.Client (SMPProxyFallback (..), SMPProxyMode (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..)) import qualified Simplex.Messaging.Crypto.File as CF @@ -505,6 +506,7 @@ data ChatCommand | ShowVersion | DebugLocks | DebugEvent ChatResponse + | GetAgentServersSummary UserId | GetAgentStats | ResetAgentStats | GetAgentSubs @@ -756,6 +758,7 @@ data ChatResponse | CRSQLResult {rows :: [Text]} | CRSlowSQLQueries {chatQueries :: [SlowSQLQuery], agentQueries :: [SlowSQLQuery]} | CRDebugLocks {chatLockName :: Maybe String, chatEntityLocks :: Map String String, agentLocks :: AgentLocks} + | CRAgentServersSummary {user :: User, serversSummary :: PresentedServersSummary} | CRAgentStats {agentStats :: [[String]]} | CRAgentWorkersDetails {agentWorkersDetails :: AgentWorkersDetails} | CRAgentWorkersSummary {agentWorkersSummary :: AgentWorkersSummary} diff --git a/src/Simplex/Chat/Markdown.hs b/src/Simplex/Chat/Markdown.hs index d7c6d31fc8..688ffa6b1d 100644 --- a/src/Simplex/Chat/Markdown.hs +++ b/src/Simplex/Chat/Markdown.hs @@ -29,13 +29,12 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Simplex.Chat.Types -import Simplex.Chat.Types.Util import Simplex.Messaging.Agent.Protocol (AConnectionRequestUri (..), ConnReqUriData (..), ConnectionRequestUri (..), SMPQueue (..)) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fstToLower, sumTypeJSON) import Simplex.Messaging.Protocol (ProtocolServer (..)) import Simplex.Messaging.ServiceScheme (ServiceScheme (..)) -import Simplex.Messaging.Util (safeDecodeUtf8) +import Simplex.Messaging.Util (decodeJSON, safeDecodeUtf8) import System.Console.ANSI.Types import qualified Text.Email.Validate as Email @@ -146,7 +145,7 @@ parseMarkdown s = fromRight (unmarked s) $ A.parseOnly (markdownP <* A.endOfInpu isSimplexLink :: Format -> Bool isSimplexLink = \case - SimplexLink {} -> True; + SimplexLink {} -> True _ -> False markdownP :: Parser Markdown diff --git a/src/Simplex/Chat/Messages/CIContent.hs b/src/Simplex/Chat/Messages/CIContent.hs index 3d71047d57..e198183b06 100644 --- a/src/Simplex/Chat/Messages/CIContent.hs +++ b/src/Simplex/Chat/Messages/CIContent.hs @@ -29,12 +29,11 @@ import Simplex.Chat.Protocol import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared -import Simplex.Chat.Types.Util import Simplex.Messaging.Agent.Protocol (MsgErrorType (..), RatchetSyncState (..), SwitchPhase (..)) -import Simplex.Messaging.Crypto.Ratchet (PQEncryption, pattern PQEncOn, pattern PQEncOff) +import Simplex.Messaging.Crypto.Ratchet (PQEncryption, pattern PQEncOff, pattern PQEncOn) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fstToLower, singleFieldJSON, sumTypeJSON) -import Simplex.Messaging.Util (safeDecodeUtf8, tshow, (<$?>)) +import Simplex.Messaging.Util (encodeJSON, safeDecodeUtf8, tshow, (<$?>)) data MsgDirection = MDRcv | MDSnd deriving (Eq, Show) diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 8c5a9e1905..d611760fbf 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -46,14 +46,13 @@ import Database.SQLite.Simple.ToField (ToField (..)) import Simplex.Chat.Call import Simplex.Chat.Types import Simplex.Chat.Types.Shared -import Simplex.Chat.Types.Util import Simplex.Messaging.Agent.Protocol (VersionSMPA, pqdrSMPAgentVersion) import Simplex.Messaging.Compression (Compressed, compress1, decompress1) import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, fstToLower, parseAll, sumTypeJSON, taggedObjectJSON) import Simplex.Messaging.Protocol (MsgBody) -import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>)) +import Simplex.Messaging.Util (decodeJSON, eitherToMaybe, encodeJSON, safeDecodeUtf8, (<$?>)) import Simplex.Messaging.Version hiding (version) -- Chat version history: diff --git a/src/Simplex/Chat/Stats.hs b/src/Simplex/Chat/Stats.hs new file mode 100644 index 0000000000..f6ea195e1c --- /dev/null +++ b/src/Simplex/Chat/Stats.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} + +module Simplex.Chat.Stats where + +import Control.Applicative ((<|>)) +import qualified Data.Aeson.TH as J +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe, isJust) +import Data.Time.Clock (UTCTime) +import Simplex.Chat.Types +import Simplex.Messaging.Agent.Client +import Simplex.Messaging.Agent.Protocol (UserId) +import Simplex.Messaging.Agent.Stats +import Simplex.Messaging.Parsers (defaultJSON) +import Simplex.Messaging.Protocol + +data PresentedServersSummary = PresentedServersSummary + { statsStartedAt :: UTCTime, + currentUserServers :: ServersSummary, + allUsersServers :: ServersSummary + } + deriving (Show) + +-- Presentation of servers will be split into separate categories, +-- so users can differentiate currently used (connected) servers, +-- previously connected servers that were in use in previous sessions, +-- and servers that are only proxied (not connected directly). +data ServersSummary = ServersSummary + { -- currently used SMP servers are those with Just in sessions and/or subs in SMPServerSummary; + -- all other servers would fall either into previously used or only proxied servers category + currentlyUsedSMPServers :: [SMPServerSummary], + -- previously used SMP servers are those with Nothing in sessions and subs, + -- and have any of sentDirect, sentProxied, recvMsgs, etc. > 0 in server stats (see toPresentedServersSummary); + -- remaining servers would fall into only proxied servers category + previouslyUsedSMPServers :: [SMPServerSummary], + -- only proxied SMP servers are those that aren't (according to current state - sessions and subs) + -- and weren't (according to stats) connected directly; they would have Nothing in sessions and subs, + -- and have all of sentDirect, sentProxied, recvMsgs, etc. = 0 in server stats + onlyProxiedSMPServers :: [SMPServerSummary], + -- currently used XFTP servers are those with Just in sessions in XFTPServerSummary, + -- and/or have upload/download/deletion in progress; + -- all other servers would fall into previously used servers category + currentlyUsedXFTPServers :: [XFTPServerSummary], + -- previously used XFTP servers are those with Nothing in sessions and don't have any process in progress + previouslyUsedXFTPServers :: [XFTPServerSummary] + } + deriving (Show) + +data SMPServerSummary = SMPServerSummary + { smpServer :: SMPServer, + -- known: + -- for simplicity always Nothing in totalServersSummary - allows us to load configured servers only for current user, + -- and also unnecessary unless we want to add navigation to other users servers settings; + -- always Just in currentUserServers - True if server is in list of user servers, otherwise False; + -- True - allows to navigate to server settings, False - allows to add server to configured as known (SEKnown) + known :: Maybe Bool, + sessions :: Maybe ServerSessions, + subs :: Maybe SMPServerSubs, + -- stats: + -- even if sessions and subs are Nothing, stats can be Just - server could be used earlier in session, + -- or in previous sessions and stats for it were restored; server would fall into a category of + -- previously used or only proxied servers - see ServersSummary above + stats :: Maybe AgentSMPServerStatsData + } + deriving (Show) + +data XFTPServerSummary = XFTPServerSummary + { xftpServer :: XFTPServer, + known :: Maybe Bool, -- same as for SMPServerSummary + sessions :: Maybe ServerSessions, + stats :: Maybe AgentXFTPServerStatsData, + rcvInProgress :: Bool, + sndInProgress :: Bool, + delInProgress :: Bool + } + deriving (Show) + +-- Maps AgentServersSummary to PresentedServersSummary: +-- - currentUserServers is for currentUser; +-- - 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 -> [SMPServer] -> [XFTPServer] -> PresentedServersSummary +toPresentedServersSummary agentSummary users currentUser userSMPSrvs userXFTPSrvs = do + let (userSMPSrvsSumms, allSMPSrvsSumms) = accSMPSrvsSummaries + (userSMPCurr, userSMPPrev, userSMPProx) = smpSummsIntoCategories userSMPSrvsSumms + (allSMPCurr, allSMPPrev, allSMPProx) = smpSummsIntoCategories allSMPSrvsSumms + (userXFTPSrvsSumms, allXFTPSrvsSumms) = accXFTPSrvsSummaries + (userXFTPCurr, userXFTPPrev) = xftpSummsIntoCategories userXFTPSrvsSumms + (allXFTPCurr, allXFTPPrev) = xftpSummsIntoCategories allXFTPSrvsSumms + PresentedServersSummary + { statsStartedAt, + currentUserServers = + ServersSummary + { currentlyUsedSMPServers = userSMPCurr, + previouslyUsedSMPServers = userSMPPrev, + onlyProxiedSMPServers = userSMPProx, + currentlyUsedXFTPServers = userXFTPCurr, + previouslyUsedXFTPServers = userXFTPPrev + }, + allUsersServers = + ServersSummary + { currentlyUsedSMPServers = allSMPCurr, + previouslyUsedSMPServers = allSMPPrev, + onlyProxiedSMPServers = allSMPProx, + currentlyUsedXFTPServers = allXFTPCurr, + previouslyUsedXFTPServers = allXFTPPrev + } + } + where + AgentServersSummary {statsStartedAt, smpServersSessions, smpServersSubs, smpServersStats, xftpServersSessions, xftpServersStats, xftpRcvInProgress, xftpSndInProgress, xftpDelInProgress} = agentSummary + countUserInAll auId = auId == aUserId currentUser || auId `notElem` hiddenUserIds + hiddenUserIds = map aUserId $ filter (isJust . viewPwdHash) users + smpSummsIntoCategories :: Map SMPServer SMPServerSummary -> ([SMPServerSummary], [SMPServerSummary], [SMPServerSummary]) + smpSummsIntoCategories = foldr partitionSummary ([], [], []) + where + partitionSummary srvSumm (curr, prev, prox) + | isCurrentlyUsed srvSumm = (srvSumm : curr, prev, prox) + | isPreviouslyUsed srvSumm = (curr, srvSumm : prev, prox) + | otherwise = (curr, prev, srvSumm : prox) + isCurrentlyUsed SMPServerSummary {sessions, subs} = isJust sessions || isJust subs + isPreviouslyUsed SMPServerSummary {stats} = case stats of + Nothing -> False + -- add connCompleted, connDeleted? + -- check: should connCompleted be counted for proxy? is it? + Just AgentSMPServerStatsData {_sentDirect, _sentProxied, _sentDirectAttempts, _sentProxiedAttempts, _recvMsgs, _connCreated, _connSecured, _connSubscribed, _connSubAttempts} -> + _sentDirect > 0 || _sentProxied > 0 || _sentDirectAttempts > 0 || _sentProxiedAttempts > 0 || _recvMsgs > 0 || _connCreated > 0 || _connSecured > 0 || _connSubscribed > 0 || _connSubAttempts > 0 + xftpSummsIntoCategories :: Map XFTPServer XFTPServerSummary -> ([XFTPServerSummary], [XFTPServerSummary]) + xftpSummsIntoCategories = foldr partitionSummary ([], []) + where + partitionSummary srvSumm (curr, prev) + | isCurrentlyUsed srvSumm = (srvSumm : curr, prev) + | otherwise = (curr, srvSumm : prev) + isCurrentlyUsed XFTPServerSummary {sessions, rcvInProgress, sndInProgress, delInProgress} = + isJust sessions || rcvInProgress || sndInProgress || delInProgress + accSMPSrvsSummaries :: (Map SMPServer SMPServerSummary, Map SMPServer SMPServerSummary) + accSMPSrvsSummaries = M.foldrWithKey' (addServerData addStats) summs2 smpServersStats + where + summs1 = M.foldrWithKey' (addServerData addSessions) (M.empty, M.empty) smpServersSessions + summs2 = M.foldrWithKey' (addServerData addSubs) summs1 smpServersSubs + addServerData :: + (a -> SMPServerSummary -> SMPServerSummary) -> + (UserId, SMPServer) -> + a -> + (Map SMPServer SMPServerSummary, Map SMPServer SMPServerSummary) -> + (Map SMPServer SMPServerSummary, Map SMPServer SMPServerSummary) + addServerData addData (userId, srv) d (userSumms, allUsersSumms) = (userSumms', allUsersSumms') + where + userSumms' + | userId == aUserId currentUser = alterSumms newUserSummary userSumms + | otherwise = userSumms + allUsersSumms' + | countUserInAll userId = alterSumms newSummary allUsersSumms + | otherwise = allUsersSumms + alterSumms n = M.alter (Just . addData d . fromMaybe n) srv + newUserSummary = (newSummary :: SMPServerSummary) {known = Just $ srv `elem` userSMPSrvs} + newSummary = + SMPServerSummary + { smpServer = srv, + known = Nothing, + sessions = Nothing, + subs = Nothing, + stats = Nothing + } + addSessions :: ServerSessions -> SMPServerSummary -> SMPServerSummary + addSessions s summ@SMPServerSummary {sessions} = summ {sessions = Just $ maybe s (s `addServerSessions`) sessions} + addSubs :: SMPServerSubs -> SMPServerSummary -> SMPServerSummary + addSubs s summ@SMPServerSummary {subs} = summ {subs = Just $ maybe s (s `addSMPSubs`) subs} + addStats :: AgentSMPServerStatsData -> SMPServerSummary -> SMPServerSummary + addStats s summ@SMPServerSummary {stats} = summ {stats = Just $ maybe s (s `addSMPStats`) stats} + accXFTPSrvsSummaries :: (Map XFTPServer XFTPServerSummary, Map XFTPServer XFTPServerSummary) + accXFTPSrvsSummaries = M.foldrWithKey' (addServerData addStats) summs1 xftpServersStats + where + summs1 = M.foldrWithKey' (addServerData addSessions) (M.empty, M.empty) xftpServersSessions + addServerData :: + (a -> XFTPServerSummary -> XFTPServerSummary) -> + (UserId, XFTPServer) -> + a -> + (Map XFTPServer XFTPServerSummary, Map XFTPServer XFTPServerSummary) -> + (Map XFTPServer XFTPServerSummary, Map XFTPServer XFTPServerSummary) + addServerData addData (userId, srv) d (userSumms, allUsersSumms) = (userSumms', allUsersSumms') + where + userSumms' + | userId == aUserId currentUser = alterSumms newUserSummary userSumms + | otherwise = userSumms + allUsersSumms' + | countUserInAll userId = alterSumms newSummary allUsersSumms + | otherwise = allUsersSumms + alterSumms n = M.alter (Just . addData d . fromMaybe n) srv + newUserSummary = (newSummary :: XFTPServerSummary) {known = Just $ srv `elem` userXFTPSrvs} + newSummary = + XFTPServerSummary + { xftpServer = srv, + known = Nothing, + sessions = Nothing, + stats = Nothing, + rcvInProgress = srv `elem` xftpRcvInProgress, + sndInProgress = srv `elem` xftpSndInProgress, + delInProgress = srv `elem` xftpDelInProgress + } + addSessions :: ServerSessions -> XFTPServerSummary -> XFTPServerSummary + addSessions s summ@XFTPServerSummary {sessions} = summ {sessions = Just $ maybe s (s `addServerSessions`) sessions} + addStats :: AgentXFTPServerStatsData -> XFTPServerSummary -> XFTPServerSummary + addStats s summ@XFTPServerSummary {stats} = summ {stats = Just $ maybe s (s `addXFTPStats`) stats} + addServerSessions :: ServerSessions -> ServerSessions -> ServerSessions + addServerSessions ss1 ss2 = + ServerSessions + { ssConnected = ssConnected ss1 + ssConnected ss2, + ssErrors = ssErrors ss1 + ssErrors ss2, + ssConnecting = ssConnecting ss1 + ssConnecting ss2 + } + addSMPSubs :: SMPServerSubs -> SMPServerSubs -> SMPServerSubs + addSMPSubs ss1 ss2 = + SMPServerSubs + { ssActive = ssActive ss1 + ssActive ss2, + ssPending = ssPending ss1 + ssPending ss2 + } + addSMPStats :: AgentSMPServerStatsData -> AgentSMPServerStatsData -> AgentSMPServerStatsData + addSMPStats sd1 sd2 = + AgentSMPServerStatsData + { _sentDirect = _sentDirect sd1 + _sentDirect sd2, + _sentViaProxy = _sentViaProxy sd1 + _sentViaProxy sd2, + _sentProxied = _sentProxied sd1 + _sentProxied sd2, + _sentDirectAttempts = _sentDirectAttempts sd1 + _sentDirectAttempts sd2, + _sentViaProxyAttempts = _sentViaProxyAttempts sd1 + _sentViaProxyAttempts sd2, + _sentProxiedAttempts = _sentProxiedAttempts sd1 + _sentProxiedAttempts sd2, + _sentAuthErrs = _sentAuthErrs sd1 + _sentAuthErrs sd2, + _sentQuotaErrs = _sentQuotaErrs sd1 + _sentQuotaErrs sd2, + _sentExpiredErrs = _sentExpiredErrs sd1 + _sentExpiredErrs sd2, + _sentOtherErrs = _sentOtherErrs sd1 + _sentOtherErrs sd2, + _recvMsgs = _recvMsgs sd1 + _recvMsgs sd2, + _recvDuplicates = _recvDuplicates sd1 + _recvDuplicates sd2, + _recvCryptoErrs = _recvCryptoErrs sd1 + _recvCryptoErrs sd2, + _recvErrs = _recvErrs sd1 + _recvErrs sd2, + _connCreated = _connCreated sd1 + _connCreated sd2, + _connSecured = _connSecured sd1 + _connSecured sd2, + _connCompleted = _connCompleted sd1 + _connCompleted sd2, + _connDeleted = _connDeleted sd1 + _connDeleted sd2, + _connSubscribed = _connSubscribed sd1 + _connSubscribed sd2, + _connSubAttempts = _connSubAttempts sd1 + _connSubAttempts sd2, + _connSubErrs = _connSubErrs sd1 + _connSubErrs sd2 + } + addXFTPStats :: AgentXFTPServerStatsData -> AgentXFTPServerStatsData -> AgentXFTPServerStatsData + addXFTPStats sd1 sd2 = + AgentXFTPServerStatsData + { _uploads = _uploads sd1 + _uploads sd2, + _uploadAttempts = _uploadAttempts sd1 + _uploadAttempts sd2, + _uploadErrs = _uploadErrs sd1 + _uploadErrs sd2, + _downloads = _downloads sd1 + _downloads sd2, + _downloadAttempts = _downloadAttempts sd1 + _downloadAttempts sd2, + _downloadAuthErrs = _downloadAuthErrs sd1 + _downloadAuthErrs sd2, + _downloadErrs = _downloadErrs sd1 + _downloadErrs sd2, + _deletions = _deletions sd1 + _deletions sd2, + _deleteAttempts = _deleteAttempts sd1 + _deleteAttempts sd2, + _deleteErrs = _deleteErrs sd1 + _deleteErrs sd2 + } + +$(J.deriveJSON defaultJSON ''SMPServerSummary) + +$(J.deriveJSON defaultJSON ''XFTPServerSummary) + +$(J.deriveJSON defaultJSON ''ServersSummary) + +$(J.deriveJSON defaultJSON ''PresentedServersSummary) diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index be06ea8878..a740389c6a 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/src/Simplex/Chat/Store/Profiles.hs @@ -523,9 +523,10 @@ getProtocolServers db User {userId} = (userId, decodeLatin1 $ strEncode protocol) where protocol = protocolTypeI @p - toServerCfg :: (NonEmpty TransportHost, String, C.KeyHash, Maybe Text, Bool, Maybe Bool, Bool) -> ServerCfg p - toServerCfg (host, port, keyHash, auth_, preset, tested, enabled) = + toServerCfg :: (NonEmpty TransportHost, String, C.KeyHash, Maybe Text, Bool, Maybe Bool, Int) -> ServerCfg p + toServerCfg (host, port, keyHash, auth_, preset, tested, enabledInt) = let server = ProtoServerWithAuth (ProtocolServer protocol host port keyHash) (BasicAuth . encodeUtf8 <$> auth_) + enabled = toServerEnabled enabledInt in ServerCfg {server, preset, tested, enabled} overwriteProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> [ServerCfg p] -> ExceptT StoreError IO () @@ -542,7 +543,7 @@ overwriteProtocolServers db User {userId} servers = (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)) + ((protocol, host, port, keyHash, safeDecodeUtf8 . unBasicAuth <$> auth_) :. (preset, tested, fromServerEnabled enabled, userId, currentTs, currentTs)) pure $ Right () where protocol = decodeLatin1 $ strEncode $ protocolTypeI @p diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 106c4b3373..07c9afa2e2 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -1632,10 +1632,42 @@ data ServerCfg p = ServerCfg { server :: ProtoServerWithAuth p, preset :: Bool, tested :: Maybe Bool, - enabled :: Bool + enabled :: ServerEnabled } deriving (Show) +data ServerEnabled + = SEDisabled + | SEEnabled + | -- server is marked as known, but it's not in the list of configured servers; + -- e.g., it may be added via an unknown server dialogue and user didn't manually configure it, + -- meaning server wasn't tested (or at least such option wasn't presented in UI) + -- and it may be inoperable for user due to server password + SEKnown + deriving (Eq, Show) + +pattern DBSEDisabled :: Int +pattern DBSEDisabled = 0 + +pattern DBSEEnabled :: Int +pattern DBSEEnabled = 1 + +pattern DBSEKnown :: Int +pattern DBSEKnown = 2 + +toServerEnabled :: Int -> ServerEnabled +toServerEnabled = \case + DBSEDisabled -> SEDisabled + DBSEEnabled -> SEEnabled + DBSEKnown -> SEKnown + _ -> SEDisabled + +fromServerEnabled :: ServerEnabled -> Int +fromServerEnabled = \case + SEDisabled -> DBSEDisabled + SEEnabled -> DBSEEnabled + SEKnown -> DBSEKnown + data ChatVersion instance VersionScope ChatVersion @@ -1764,6 +1796,8 @@ $(JQ.deriveJSON defaultJSON ''ContactRef) $(JQ.deriveJSON defaultJSON ''NoteFolder) +$(JQ.deriveJSON (enumJSON $ dropPrefix "SE") ''ServerEnabled) + instance ProtocolTypeI p => ToJSON (ServerCfg p) where toEncoding = $(JQ.mkToEncoding defaultJSON ''ServerCfg) toJSON = $(JQ.mkToJSON defaultJSON ''ServerCfg) diff --git a/src/Simplex/Chat/Types/Preferences.hs b/src/Simplex/Chat/Types/Preferences.hs index 4cf9f862d2..bccfd4bdce 100644 --- a/src/Simplex/Chat/Types/Preferences.hs +++ b/src/Simplex/Chat/Types/Preferences.hs @@ -36,7 +36,7 @@ import Simplex.Chat.Types.Shared import Simplex.Chat.Types.Util import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, sumTypeJSON) -import Simplex.Messaging.Util (safeDecodeUtf8, (<$?>)) +import Simplex.Messaging.Util (decodeJSON, encodeJSON, safeDecodeUtf8, (<$?>)) data ChatFeature = CFTimedMessages diff --git a/src/Simplex/Chat/Types/UITheme.hs b/src/Simplex/Chat/Types/UITheme.hs index ef445c5a7c..cc5290aa69 100644 --- a/src/Simplex/Chat/Types/UITheme.hs +++ b/src/Simplex/Chat/Types/UITheme.hs @@ -18,6 +18,7 @@ import Database.SQLite.Simple.ToField (ToField (..)) import Simplex.Chat.Types.Util import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_) +import Simplex.Messaging.Util (decodeJSON, encodeJSON) data UITheme = UITheme { themeId :: Text, diff --git a/src/Simplex/Chat/Types/Util.hs b/src/Simplex/Chat/Types/Util.hs index e19d48caba..47edf8eaf8 100644 --- a/src/Simplex/Chat/Types/Util.hs +++ b/src/Simplex/Chat/Types/Util.hs @@ -2,26 +2,15 @@ module Simplex.Chat.Types.Util where -import Data.Aeson (FromJSON, ToJSON) import qualified Data.Aeson as J import qualified Data.Aeson.Types as JT import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy.Char8 as LB -import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) import Data.Typeable import Database.SQLite.Simple (ResultError (..), SQLData (..)) import Database.SQLite.Simple.FromField (FieldParser, returnError) import Database.SQLite.Simple.Internal (Field (..)) import Database.SQLite.Simple.Ok (Ok (Ok)) import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Util (safeDecodeUtf8) - -encodeJSON :: ToJSON a => a -> Text -encodeJSON = safeDecodeUtf8 . LB.toStrict . J.encode - -decodeJSON :: FromJSON a => Text -> Maybe a -decodeJSON = J.decode . LB.fromStrict . encodeUtf8 textParseJSON :: TextEncoding a => String -> J.Value -> JT.Parser a textParseJSON name = J.withText name $ maybe (fail $ "bad " <> name) pure . textDecode diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index d1f3625e18..5b14084552 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -54,7 +54,6 @@ import qualified Simplex.FileTransfer.Transport as XFTP import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), SubscriptionsInfo (..)) import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..)) import Simplex.Messaging.Agent.Protocol -import Simplex.Messaging.Agent.Protocol (AgentErrorType (RCP)) import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..)) import Simplex.Messaging.Client (SMPProxyFallback, SMPProxyMode (..)) import qualified Simplex.Messaging.Crypto as C @@ -366,6 +365,7 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe "chat entity locks: " <> viewJSON chatEntityLocks, "agent locks: " <> viewJSON agentLocks ] + CRAgentServersSummary u serversSummary -> ttyUser u ["agent servers summary: " <> viewJSON serversSummary] CRAgentStats stats -> map (plain . intercalate ",") stats CRAgentSubs {activeSubs, pendingSubs, removedSubs} -> [plain $ "Subscriptions: active = " <> show (sum activeSubs) <> ", pending = " <> show (sum pendingSubs) <> ", removed = " <> show (sum $ M.map length removedSubs)] diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index c1388072ab..f29d6d848a 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -17,7 +17,7 @@ import Simplex.Chat.Store.Shared (createContact) import Simplex.Chat.Types (ConnStatus (..), Profile (..)) import Simplex.Chat.Types.Shared (GroupMemberRole (..)) import Simplex.Chat.Types.UITheme -import Simplex.Chat.Types.Util (encodeJSON) +import Simplex.Messaging.Util (encodeJSON) import Simplex.Messaging.Encoding.String (StrEncoding (..)) import System.Directory (copyFile, createDirectoryIfMissing) import Test.Hspec hiding (it)