IntenseFinance/simplex-chat
3
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'master' into master-ghc9

Browse Source
This commit is contained in:
Evgeny Poberezkin
2023-08-25 14:13:30 +01:00
parent fde39e74ee 3a93954c50
commit 9134624e2a
6 changed files with 42 additions and 9 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
cabal.project
View File

@@ -9,7 +9,7 @@ constraints: zip +disable-bzip2 +disable-zstd
source-repository-package
type: git
location: https://github.com/simplex-chat/simplexmq.git
tag: 002f36dde042b8957507ec2ca348a0f4494a4cd6
tag: ed0542822749a871d00ac028582ec45a256ba53c
source-repository-package
type: git

2
scripts/nix/sha256map.nix
View File

@@ -1,5 +1,5 @@
{
"https://github.com/simplex-chat/simplexmq.git"."002f36dde042b8957507ec2ca348a0f4494a4cd6" = "1gp1z9i1glvkq8vgy1damy7g562a5cz47f8sichjmfg2ngly8zpl";
"https://github.com/simplex-chat/simplexmq.git"."ed0542822749a871d00ac028582ec45a256ba53c" = "13lk8vkwiv2c37ab6q6myyh3cbnjmiircjyd2llz7fc03gp9qzzh";
"https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
"https://github.com/kazu-yamamoto/http2.git"."b5a1b7200cf5bc7044af34ba325284271f6dff25" = "0dqb50j57an64nf4qcf5vcz4xkd1vzvghvf8bk529c1k30r9nfzb";
"https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "0kiwhvml42g9anw4d2v0zd1fpc790pj9syg5x3ik4l97fnkbbwpp";

25
src/Simplex/Chat.hs
View File

@@ -30,7 +30,7 @@ import Crypto.Random (drgNew)
import qualified Data.Aeson as J
import Data.Attoparsec.ByteString.Char8 (Parser)
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Bifunctor (bimap, first)
import Data.Bifunctor (bimap, first, second)
import qualified Data.ByteString.Base64 as B64
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
@@ -40,12 +40,13 @@ import Data.Either (fromRight, rights)
import Data.Fixed (div')
import Data.Functor (($>))
import Data.Int (Int64)
import Data.List (find, isSuffixOf, partition, sortOn)
import Data.List (find, foldl', isSuffixOf, partition, sortOn)
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybeToList)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
@@ -79,7 +80,7 @@ import Simplex.FileTransfer.Client.Presets (defaultXFTPServers)
import Simplex.FileTransfer.Description (ValidFileDescription, gb, kb, mb)
import Simplex.FileTransfer.Protocol (FileParty (..), FilePartyI)
import Simplex.Messaging.Agent as Agent
import Simplex.Messaging.Agent.Client (AgentStatsKey (..), agentClientStore, temporaryAgentError)
import Simplex.Messaging.Agent.Client (AgentStatsKey (..), SubInfo (..), agentClientStore, temporaryAgentError)
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), createAgentStore, defaultAgentConfig)
import Simplex.Messaging.Agent.Lock
import Simplex.Messaging.Agent.Protocol
@@ -1741,6 +1742,20 @@ processChatCommand = \case
stat (AgentStatsKey {host, clientTs, cmd, res}, count) =
map B.unpack [host, clientTs, cmd, res, bshow count]
ResetAgentStats -> withAgent resetAgentStats >> ok_
GetAgentSubs -> summary <$> withAgent getAgentSubscriptions
where
summary SubscriptionsInfo {activeSubscriptions, pendingSubscriptions} =
CRAgentSubs {activeSubs, distinctActiveSubs, pendingSubs, distinctPendingSubs}
where
(activeSubs, distinctActiveSubs) = foldSubs activeSubscriptions
(pendingSubs, distinctPendingSubs) = foldSubs pendingSubscriptions
foldSubs :: [SubInfo] -> (Map Text Int, Map Text Int)
foldSubs = second (M.map S.size) . foldl' acc (M.empty, M.empty)
acc (m, m') SubInfo {server, rcvId} =
( M.alter (Just . maybe 1 (+ 1)) server m,
M.alter (Just . maybe (S.singleton rcvId) (S.insert rcvId)) server m'
)
GetAgentSubsDetails -> CRAgentSubsDetails <$> withAgent getAgentSubscriptions
where
withChatLock name action = asks chatLock >>= \l -> withLock l name action
-- below code would make command responses asynchronous where they can be slow
@@ -5270,7 +5285,9 @@ chatCommandP =
("/version" <|> "/v") $> ShowVersion,
"/debug locks" $> DebugLocks,
"/get stats" $> GetAgentStats,
"/reset stats" $> ResetAgentStats
"/reset stats" $> ResetAgentStats,
"/get subs" $> GetAgentSubs,
"/get subs details" $> GetAgentSubsDetails
]
where
choice = A.choice . map (\p -> p <* A.takeWhile (== ' ') <* A.endOfInput)

6
src/Simplex/Chat/Controller.hs
View File

@@ -48,7 +48,7 @@ import Simplex.Chat.Protocol
import Simplex.Chat.Store (AutoAccept, StoreError, UserContactLink, UserMsgReceiptSettings)
import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences
import Simplex.Messaging.Agent (AgentClient)
import Simplex.Messaging.Agent (AgentClient, SubscriptionsInfo)
import Simplex.Messaging.Agent.Client (AgentLocks, ProtocolTestFailure)
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, NetworkConfig)
import Simplex.Messaging.Agent.Lock
@@ -406,6 +406,8 @@ data ChatCommand
| DebugLocks
| GetAgentStats
| ResetAgentStats
| GetAgentSubs
| GetAgentSubsDetails
deriving (Show)
data ChatResponse
@@ -568,6 +570,8 @@ data ChatResponse
| CRSlowSQLQueries {chatQueries :: [SlowSQLQuery], agentQueries :: [SlowSQLQuery]}
| CRDebugLocks {chatLockName :: Maybe String, agentLocks :: AgentLocks}
| CRAgentStats {agentStats :: [[String]]}
| CRAgentSubs {activeSubs :: Map Text Int, distinctActiveSubs :: Map Text Int, pendingSubs :: Map Text Int, distinctPendingSubs :: Map Text Int}
| CRAgentSubsDetails {agentSubs :: SubscriptionsInfo}
| CRConnectionDisabled {connectionEntity :: ConnectionEntity}
| CRAgentRcvQueueDeleted {agentConnId :: AgentConnId, server :: SMPServer, agentQueueId :: AgentQueueId, agentError_ :: Maybe AgentErrorType}
| CRAgentConnDeleted {agentConnId :: AgentConnId}

14
src/Simplex/Chat/View.hs
View File

@@ -21,6 +21,7 @@ import Data.Int (Int64)
import Data.List (groupBy, intercalate, intersperse, partition, sortOn)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
@@ -45,7 +46,7 @@ import Simplex.Chat.Styled
import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences
import qualified Simplex.FileTransfer.Protocol as XFTP
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..))
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), SubscriptionsInfo (..))
import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..))
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..))
@@ -261,6 +262,17 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
plain $ "agent locks: " <> LB.unpack (J.encode agentLocks)
]
CRAgentStats stats -> map (plain . intercalate ",") stats
CRAgentSubs {activeSubs, distinctActiveSubs, pendingSubs, distinctPendingSubs} ->
[plain $ "Subscriptions: active = " <> show (sum activeSubs) <> ", distinct active = " <> show (sum distinctActiveSubs) <> ", pending = " <> show (sum pendingSubs) <> ", distinct pending = " <> show (sum distinctPendingSubs)]
<> ("active subscriptions:" : listSubs activeSubs)
<> ("distinct active subscriptions:" : listSubs distinctActiveSubs)
<> ("pending subscriptions:" : listSubs pendingSubs)
<> ("distinct pending subscriptions:" : listSubs distinctPendingSubs)
where
listSubs = map (\(srv, count) -> plain $ srv <> ": " <> tshow count) . M.assocs
CRAgentSubsDetails SubscriptionsInfo {activeSubscriptions, pendingSubscriptions} ->
("active subscriptions:" : map sShow activeSubscriptions)
<> ("pending subscriptions: " : map sShow pendingSubscriptions)
CRConnectionDisabled entity -> viewConnectionEntityDisabled entity
CRAgentRcvQueueDeleted acId srv aqId err_ ->
[ "completed deleting rcv queue, agent connection id: " <> sShow acId

2
stack.yaml
View File

@@ -49,7 +49,7 @@ extra-deps:
# - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561
# - ../simplexmq
- github: simplex-chat/simplexmq
commit: 002f36dde042b8957507ec2ca348a0f4494a4cd6
commit: ed0542822749a871d00ac028582ec45a256ba53c
- github: kazu-yamamoto/http2
commit: b5a1b7200cf5bc7044af34ba325284271f6dff25
# - ../direct-sqlcipher