mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-03-14 09:45:42 +00:00
core: logging of chat events (#4216)
* core: update simplexmq (persist server errors) * fix * same config * logging * logging 2 * log * log 2 * finally * catch better * more logs * logs * fix * more logging, context from PROHIBITED * warning * more logs * logs3 * logs4 * logs in simplexmq * log locks from simplemq * log queue size * log sendMessagesB in simplexmq * update simplexmq * logs5 * logs6 * logs7 * logs8 * logs8 * logs9 * logs10 * log11 * log12 * fix test * more logs * logging * clean up * refactor * simplify * tags * log level * remove network errors from the log * rename
This commit is contained in:
Evgeny Poberezkin
GitHub
parent
dae0b63c22
commit
291df6e9d0
16 changed files with 139 additions and 63 deletions
|
|
@ -35,8 +35,10 @@ import Simplex.Chat.Messages.CIContent
|
|||
import Simplex.Chat.Protocol (MsgContent (..))
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.Messaging.Agent.Protocol (AgentErrorType (..))
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Util ((<$?>))
|
||||
import Simplex.Messaging.Protocol (BrokerErrorType (..))
|
||||
import Simplex.Messaging.Util (tshow, (<$?>))
|
||||
|
||||
data DirectoryEvent
|
||||
= DEContactConnected Contact
|
||||
|
|
@ -53,6 +55,7 @@ data DirectoryEvent
|
|||
| DEItemEditIgnored Contact
|
||||
| DEItemDeleteIgnored Contact
|
||||
| DEContactCommand Contact ChatItemId ADirectoryCmd
|
||||
| DELogChatResponse Text
|
||||
deriving (Show)
|
||||
|
||||
crDirectoryEvent :: ChatResponse -> Maybe DirectoryEvent
|
||||
|
|
@ -77,6 +80,13 @@ crDirectoryEvent = \case
|
|||
where
|
||||
ciId = chatItemId' ci
|
||||
err = ADC SDRUser DCUnknownCommand
|
||||
CRMessageError {severity, errorMessage} -> Just $ DELogChatResponse $ "message error: " <> severity <> ", " <> errorMessage
|
||||
CRChatCmdError {chatError} -> Just $ DELogChatResponse $ "chat cmd error: " <> tshow chatError
|
||||
CRChatError {chatError} -> case chatError of
|
||||
ChatErrorAgent {agentError = BROKER _ NETWORK} -> Nothing
|
||||
ChatErrorAgent {agentError = BROKER _ TIMEOUT} -> Nothing
|
||||
_ -> Just $ DELogChatResponse $ "chat error: " <> tshow chatError
|
||||
CRChatErrors {chatErrors} -> Just $ DELogChatResponse $ "chat errors: " <> T.intercalate ", " (map tshow chatErrors)
|
||||
_ -> Nothing
|
||||
|
||||
data DirectoryRole = DRUser | DRSuperUser
|
||||
|
|
|
|||
|
|
@ -102,6 +102,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi
|
|||
case sUser of
|
||||
SDRUser -> deUserCommand env ct ciId cmd
|
||||
SDRSuperUser -> deSuperUserCommand ct ciId cmd
|
||||
DELogChatResponse r -> logInfo r
|
||||
where
|
||||
withSuperUsers action = void . forkIO $ forM_ superUsers $ \KnownContact {contactId} -> action contactId
|
||||
notifySuperUsers s = withSuperUsers $ \contactId -> sendMessage' cc contactId s
|
||||
|
|
|
|||
|
|
@ -39,8 +39,8 @@ import Data.Text (Text)
|
|||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Util (ifM)
|
||||
import System.IO (Handle, IOMode (..), openFile, BufferMode (..), hSetBuffering)
|
||||
import System.Directory (renameFile, doesFileExist)
|
||||
import System.Directory (doesFileExist, renameFile)
|
||||
import System.IO (BufferMode (..), Handle, IOMode (..), hSetBuffering, openFile)
|
||||
|
||||
data DirectoryStore = DirectoryStore
|
||||
{ groupRegs :: TVar [GroupReg],
|
||||
|
|
@ -112,7 +112,7 @@ addGroupReg st ct GroupInfo {groupId} grStatus = do
|
|||
let ugrId = 1 + foldl' maxUgrId 0 grs
|
||||
grData' = grData {userGroupRegId_ = ugrId}
|
||||
gr' = gr {userGroupRegId = ugrId}
|
||||
in (grData', gr' : grs)
|
||||
in (grData', gr' : grs)
|
||||
ctId = contactId' ct
|
||||
maxUgrId mx GroupReg {dbContactId, userGroupRegId}
|
||||
| dbContactId == ctId && userGroupRegId > mx = userGroupRegId
|
||||
|
|
@ -311,14 +311,15 @@ readDirectoryData f =
|
|||
Right r -> case r of
|
||||
GRCreate gr@GroupRegData {dbGroupId_ = gId} -> do
|
||||
when (isJust $ M.lookup gId m) $
|
||||
putStrLn $ "Warning: duplicate group with ID " <> show gId <> ", group replaced."
|
||||
putStrLn $
|
||||
"Warning: duplicate group with ID " <> show gId <> ", group replaced."
|
||||
pure $ M.insert gId gr m
|
||||
GRUpdateStatus gId groupRegStatus_ -> case M.lookup gId m of
|
||||
Just gr -> pure $ M.insert gId gr {groupRegStatus_} m
|
||||
Nothing -> m <$ putStrLn ("Warning: no group with ID " <> show gId <>", status update ignored.")
|
||||
Nothing -> m <$ putStrLn ("Warning: no group with ID " <> show gId <> ", status update ignored.")
|
||||
GRUpdateOwner gId grOwnerId -> case M.lookup gId m of
|
||||
Just gr -> pure $ M.insert gId gr {dbOwnerMemberId_ = Just grOwnerId} m
|
||||
Nothing -> m <$ putStrLn ("Warning: no group with ID " <> show gId <>", owner update ignored.")
|
||||
Nothing -> m <$ putStrLn ("Warning: no group with ID " <> show gId <> ", owner update ignored.")
|
||||
|
||||
writeDirectoryData :: FilePath -> [GroupRegData] -> IO Handle
|
||||
writeDirectoryData f grs = do
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ constraints: zip +disable-bzip2 +disable-zstd
|
|||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/simplex-chat/simplexmq.git
|
||||
tag: e7a73a4c89ed02e248e2d77e267037c9d4433820
|
||||
tag: bd67844169d2206d8543c01e6ed966315115b0e3
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
|
|
|
|||
23
package.yaml
23
package.yaml
|
|
@ -152,12 +152,31 @@ tests:
|
|||
ghc-options:
|
||||
# - -haddock
|
||||
- -O2
|
||||
- -Wall
|
||||
- -Weverything
|
||||
- -Wno-missing-exported-signatures
|
||||
- -Wno-missing-import-lists
|
||||
- -Wno-missed-specialisations
|
||||
- -Wno-all-missed-specialisations
|
||||
- -Wno-unsafe
|
||||
- -Wno-safe
|
||||
- -Wno-missing-local-signatures
|
||||
- -Wno-missing-kind-signatures
|
||||
- -Wno-missing-deriving-strategies
|
||||
- -Wno-monomorphism-restriction
|
||||
- -Wno-prepositive-qualified-module
|
||||
- -Wno-unused-packages
|
||||
- -Wno-implicit-prelude
|
||||
- -Wno-missing-safe-haskell-mode
|
||||
- -Wno-missing-export-lists
|
||||
- -Wno-partial-fields
|
||||
- -Wcompat
|
||||
- -Werror=incomplete-record-updates
|
||||
- -Werror=incomplete-patterns
|
||||
- -Werror=missing-methods
|
||||
- -Werror=incomplete-uni-patterns
|
||||
- -Werror=tabs
|
||||
- -Wredundant-constraints
|
||||
- -Wincomplete-record-updates
|
||||
- -Wincomplete-uni-patterns
|
||||
- -Wunused-type-patterns
|
||||
|
||||
default-extensions:
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
{
|
||||
"https://github.com/simplex-chat/simplexmq.git"."e7a73a4c89ed02e248e2d77e267037c9d4433820" = "1zrsvnx8qnkvlxhkikl97bmi5nyian8wq20pn330159cviihfxl1";
|
||||
"https://github.com/simplex-chat/simplexmq.git"."bd67844169d2206d8543c01e6ed966315115b0e3" = "1g218q15hrg21h8gyidavfys5zx8dzmxq7iwfm5bfaw71grpd7pn";
|
||||
"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";
|
||||
|
|
|
|||
|
|
@ -190,7 +190,7 @@ library
|
|||
src
|
||||
default-extensions:
|
||||
StrictData
|
||||
ghc-options: -O2 -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns
|
||||
ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns
|
||||
build-depends:
|
||||
aeson ==2.2.*
|
||||
, ansi-terminal >=0.10 && <0.12
|
||||
|
|
@ -252,7 +252,7 @@ executable simplex-bot
|
|||
apps/simplex-bot
|
||||
default-extensions:
|
||||
StrictData
|
||||
ghc-options: -O2 -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
|
||||
ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -threaded
|
||||
build-depends:
|
||||
aeson ==2.2.*
|
||||
, ansi-terminal >=0.10 && <0.12
|
||||
|
|
@ -315,7 +315,7 @@ executable simplex-bot-advanced
|
|||
apps/simplex-bot-advanced
|
||||
default-extensions:
|
||||
StrictData
|
||||
ghc-options: -O2 -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
|
||||
ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -threaded
|
||||
build-depends:
|
||||
aeson ==2.2.*
|
||||
, ansi-terminal >=0.10 && <0.12
|
||||
|
|
@ -381,7 +381,7 @@ executable simplex-broadcast-bot
|
|||
Broadcast.Bot
|
||||
Broadcast.Options
|
||||
Paths_simplex_chat
|
||||
ghc-options: -O2 -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
|
||||
ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -threaded
|
||||
build-depends:
|
||||
aeson ==2.2.*
|
||||
, ansi-terminal >=0.10 && <0.12
|
||||
|
|
@ -445,7 +445,7 @@ executable simplex-chat
|
|||
apps/simplex-chat
|
||||
default-extensions:
|
||||
StrictData
|
||||
ghc-options: -O2 -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
|
||||
ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -threaded
|
||||
build-depends:
|
||||
aeson ==2.2.*
|
||||
, ansi-terminal >=0.10 && <0.12
|
||||
|
|
@ -515,7 +515,7 @@ executable simplex-directory-service
|
|||
Directory.Service
|
||||
Directory.Store
|
||||
Paths_simplex_chat
|
||||
ghc-options: -O2 -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
|
||||
ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -threaded
|
||||
build-depends:
|
||||
aeson ==2.2.*
|
||||
, ansi-terminal >=0.10 && <0.12
|
||||
|
|
@ -610,7 +610,7 @@ test-suite simplex-chat-test
|
|||
apps/simplex-directory-service/src
|
||||
default-extensions:
|
||||
StrictData
|
||||
ghc-options: -O2 -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded
|
||||
ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -threaded
|
||||
build-depends:
|
||||
QuickCheck ==2.14.*
|
||||
, aeson ==2.2.*
|
||||
|
|
|
|||
|
|
@ -229,6 +229,7 @@ newChatController
|
|||
smpAgent <- getSMPAgentClient aCfg {tbqSize} servers agentStore backgroundMode
|
||||
agentAsync <- newTVarIO Nothing
|
||||
random <- liftIO C.newRandom
|
||||
eventSeq <- newTVarIO 0
|
||||
inputQ <- newTBQueueIO tbqSize
|
||||
outputQ <- newTBQueueIO tbqSize
|
||||
connNetworkStatuses <- atomically TM.empty
|
||||
|
|
@ -266,6 +267,7 @@ newChatController
|
|||
chatStore,
|
||||
chatStoreChanged,
|
||||
random,
|
||||
eventSeq,
|
||||
inputQ,
|
||||
outputQ,
|
||||
connNetworkStatuses,
|
||||
|
|
@ -3317,7 +3319,10 @@ deleteGroupLink_ user gInfo conn = do
|
|||
agentSubscriber :: CM' ()
|
||||
agentSubscriber = do
|
||||
q <- asks $ subQ . smpAgent
|
||||
forever $ atomically (readTBQueue q) >>= process
|
||||
forever (atomically (readTBQueue q) >>= process)
|
||||
`E.catchAny` \e -> do
|
||||
toView' $ CRChatError Nothing $ ChatErrorAgent (CRITICAL True $ "Message reception stopped: " <> show e) Nothing
|
||||
E.throwIO e
|
||||
where
|
||||
process :: (ACorrId, EntityId, APartyCmd 'Agent) -> CM' ()
|
||||
process (corrId, entId, APC e msg) = run $ case e of
|
||||
|
|
@ -3937,7 +3942,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
|||
-- TODO only acknowledge without saving message?
|
||||
-- probably this branch is never executed, so there should be no reason
|
||||
-- to save message if contact hasn't been created yet - chat item isn't created anyway
|
||||
withAckMessage' agentConnId meta $
|
||||
withAckMessage' "new contact msg" agentConnId meta $
|
||||
void $
|
||||
saveDirectRcvMSG conn meta msgBody
|
||||
SENT msgId _proxy ->
|
||||
|
|
@ -3968,14 +3973,18 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
|||
forM_ contData $ \(hostConnId, xGrpMemIntroCont) ->
|
||||
sendXGrpMemInv hostConnId (Just directConnReq) xGrpMemIntroCont
|
||||
CRContactUri _ -> throwChatError $ CECommandError "unexpected ConnectionRequestUri type"
|
||||
MSG msgMeta _msgFlags msgBody ->
|
||||
withAckMessage agentConnId msgMeta True $ do
|
||||
MSG msgMeta _msgFlags msgBody -> do
|
||||
tags <- newTVarIO []
|
||||
withAckMessage "contact msg" agentConnId msgMeta True (Just tags) $ \eInfo -> do
|
||||
let MsgMeta {pqEncryption} = msgMeta
|
||||
(ct', conn') <- updateContactPQRcv user ct conn pqEncryption
|
||||
checkIntegrityCreateItem (CDDirectRcv ct') msgMeta `catchChatError` \_ -> pure ()
|
||||
(conn'', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveDirectRcvMSG conn' msgMeta msgBody
|
||||
let tag = toCMEventTag event
|
||||
atomically $ writeTVar tags [tshow tag]
|
||||
logInfo $ "contact msg=" <> tshow tag <> " " <> eInfo
|
||||
let ct'' = ct' {activeConn = Just conn''} :: Contact
|
||||
assertDirectAllowed user MDRcv ct'' $ toCMEventTag event
|
||||
assertDirectAllowed user MDRcv ct'' tag
|
||||
case event of
|
||||
XMsgNew mc -> newContentMessage ct'' mc msg msgMeta
|
||||
XMsgFileDescr sharedMsgId fileDescr -> messageFileDescription ct'' sharedMsgId fileDescr
|
||||
|
|
@ -4000,9 +4009,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
|||
BFileChunk sharedMsgId chunk -> bFileChunk ct'' sharedMsgId chunk msgMeta
|
||||
_ -> messageError $ "unsupported message: " <> T.pack (show event)
|
||||
let Contact {chatSettings = ChatSettings {sendRcpts}} = ct''
|
||||
pure $ fromMaybe (sendRcptsContacts user) sendRcpts && hasDeliveryReceipt (toCMEventTag event)
|
||||
pure $ fromMaybe (sendRcptsContacts user) sendRcpts && hasDeliveryReceipt tag
|
||||
RCVD msgMeta msgRcpt ->
|
||||
withAckMessage' agentConnId msgMeta $
|
||||
withAckMessage' "contact rcvd" agentConnId msgMeta $
|
||||
directMsgReceived ct conn msgMeta msgRcpt
|
||||
CONF confId pqSupport _ connInfo -> do
|
||||
conn' <- processCONFpqSupport conn pqSupport
|
||||
|
|
@ -4381,19 +4390,26 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
|||
void $ sendDirectMemberMessage imConn (XGrpMemCon memberId) groupId
|
||||
_ -> messageWarning "sendXGrpMemCon: member category GCPreMember or GCPostMember is expected"
|
||||
MSG msgMeta _msgFlags msgBody -> do
|
||||
withAckMessage agentConnId msgMeta True $ do
|
||||
tags <- newTVarIO []
|
||||
withAckMessage "group msg" agentConnId msgMeta True (Just tags) $ \eInfo -> do
|
||||
checkIntegrityCreateItem (CDGroupRcv gInfo m) msgMeta `catchChatError` \_ -> pure ()
|
||||
forM_ aChatMsgs $ \case
|
||||
Right (ACMsg _ chatMsg) ->
|
||||
processEvent chatMsg `catchChatError` \e -> toView $ CRChatError (Just user) e
|
||||
Left e -> toView $ CRChatError (Just user) (ChatError . CEException $ "error parsing chat message: " <> e)
|
||||
forwardMsg_ `catchChatError` \_ -> pure ()
|
||||
processEvent tags eInfo chatMsg `catchChatError` \e -> toView $ CRChatError (Just user) e
|
||||
Left e -> do
|
||||
atomically $ modifyTVar' tags ("error" :)
|
||||
logInfo $ "group msg=error " <> eInfo <> " " <> tshow e
|
||||
toView $ CRChatError (Just user) (ChatError . CEException $ "error parsing chat message: " <> e)
|
||||
forwardMsg_ `catchChatError` (toView . CRChatError (Just user))
|
||||
checkSendRcpt $ rights aChatMsgs
|
||||
where
|
||||
aChatMsgs = parseChatMessages msgBody
|
||||
brokerTs = metaBrokerTs msgMeta
|
||||
processEvent :: MsgEncodingI e => ChatMessage e -> CM ()
|
||||
processEvent chatMsg = do
|
||||
processEvent :: TVar [Text] -> Text -> MsgEncodingI e => ChatMessage e -> CM ()
|
||||
processEvent tags eInfo chatMsg@ChatMessage {chatMsgEvent} = do
|
||||
let tag = toCMEventTag chatMsgEvent
|
||||
atomically $ modifyTVar' tags (tshow tag :)
|
||||
logInfo $ "group msg=" <> tshow tag <> " " <> eInfo
|
||||
(m', conn', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveGroupRcvMsg user groupId m conn msgMeta msgBody chatMsg
|
||||
case event of
|
||||
XMsgNew mc -> memberCanSend m' $ newGroupContentMessage gInfo m' mc msg brokerTs False
|
||||
|
|
@ -4424,7 +4440,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
|||
XInfoProbeCheck probeHash -> xInfoProbeCheck (COMGroupMember m') probeHash
|
||||
XInfoProbeOk probe -> xInfoProbeOk (COMGroupMember m') probe
|
||||
BFileChunk sharedMsgId chunk -> bFileChunkGroup gInfo sharedMsgId chunk msgMeta
|
||||
_ -> messageError $ "unsupported message: " <> T.pack (show event)
|
||||
_ -> messageError $ "unsupported message: " <> tshow event
|
||||
checkSendRcpt :: [AChatMessage] -> CM Bool
|
||||
checkSendRcpt aMsgs = do
|
||||
currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo
|
||||
|
|
@ -4458,7 +4474,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
|||
sendGroupMessage' user gInfo ms msg
|
||||
_ -> pure ()
|
||||
RCVD msgMeta msgRcpt ->
|
||||
withAckMessage' agentConnId msgMeta $
|
||||
withAckMessage' "group rcvd" agentConnId msgMeta $
|
||||
groupMsgReceived gInfo m conn msgMeta msgRcpt
|
||||
SENT msgId proxy -> do
|
||||
sentMsgDeliveryEvent conn msgId
|
||||
|
|
@ -4582,7 +4598,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
|||
lookupChatItemByFileId db vr user fileId
|
||||
toView $ CRSndFileRcvCancelled user ci ft
|
||||
_ -> throwChatError $ CEFileSend fileId err
|
||||
MSG meta _ _ -> withAckMessage' agentConnId meta $ pure ()
|
||||
MSG meta _ _ ->
|
||||
withAckMessage' "file msg" agentConnId meta $ pure ()
|
||||
OK ->
|
||||
-- [async agent commands] continuation on receiving OK
|
||||
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
|
||||
|
|
@ -4658,7 +4675,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
|||
RcvChunkOk ->
|
||||
if B.length chunk /= fromInteger chunkSize
|
||||
then badRcvFileChunk ft "incorrect chunk size"
|
||||
else withAckMessage' agentConnId meta $ appendFileChunk ft chunkNo chunk False
|
||||
else withAckMessage' "file msg" agentConnId meta $ appendFileChunk ft chunkNo chunk False
|
||||
RcvChunkFinal ->
|
||||
if B.length chunk > fromInteger chunkSize
|
||||
then badRcvFileChunk ft "incorrect chunk size"
|
||||
|
|
@ -4672,7 +4689,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
|||
getChatItemByFileId db vr user fileId
|
||||
toView $ CRRcvFileComplete user ci
|
||||
forM_ conn_ $ \conn -> deleteAgentConnectionAsync user (aConnId conn)
|
||||
RcvChunkDuplicate -> withAckMessage' agentConnId meta $ pure ()
|
||||
RcvChunkDuplicate -> withAckMessage' "file msg" agentConnId meta $ pure ()
|
||||
RcvChunkError -> badRcvFileChunk ft $ "incorrect chunk number " <> show chunkNo
|
||||
|
||||
processUserContactRequest :: ACommand 'Agent e -> ConnectionEntity -> Connection -> UserContact -> CM ()
|
||||
|
|
@ -4756,25 +4773,45 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
|||
withStore' $ \db -> updateCommandStatus db user cmdId CSError
|
||||
throwChatError . CEAgentCommandError $ msg
|
||||
|
||||
withAckMessage' :: ConnId -> MsgMeta -> CM () -> CM ()
|
||||
withAckMessage' cId msgMeta action = do
|
||||
withAckMessage cId msgMeta False $ action $> False
|
||||
withAckMessage' :: Text -> ConnId -> MsgMeta -> CM () -> CM ()
|
||||
withAckMessage' label cId msgMeta action = do
|
||||
withAckMessage label cId msgMeta False Nothing $ \_ -> action $> False
|
||||
|
||||
withAckMessage :: ConnId -> MsgMeta -> Bool -> CM Bool -> CM ()
|
||||
withAckMessage cId msgMeta showCritical action =
|
||||
withAckMessage :: Text -> ConnId -> MsgMeta -> Bool -> Maybe (TVar [Text]) -> (Text -> CM Bool) -> CM ()
|
||||
withAckMessage label cId msgMeta showCritical tags action = do
|
||||
-- [async agent commands] command should be asynchronous
|
||||
-- TODO catching error and sending ACK after an error, particularly if it is a database error, will result in the message not processed (and no notification to the user).
|
||||
-- Possible solutions are:
|
||||
-- 1) retry processing several times
|
||||
-- 2) stabilize database
|
||||
-- 3) show screen of death to the user asking to restart
|
||||
tryChatError action >>= \case
|
||||
Right withRcpt -> ackMsg msgMeta $ if withRcpt then Just "" else Nothing
|
||||
eInfo <- eventInfo
|
||||
logInfo $ label <> ": " <> eInfo
|
||||
tryChatError (action eInfo) >>= \case
|
||||
Right withRcpt ->
|
||||
withLog (eInfo <> " ok") $ ackMsg msgMeta $ if withRcpt then Just "" else Nothing
|
||||
-- If showCritical is True, then these errors don't result in ACK and show user visible alert
|
||||
-- This prevents losing the message that failed to be processed.
|
||||
Left (ChatErrorStore SEDBBusyError {message}) | showCritical -> throwError $ ChatErrorAgent (CRITICAL True message) Nothing
|
||||
Left e -> ackMsg msgMeta Nothing >> throwError e
|
||||
Left e -> do
|
||||
withLog (eInfo <> " error: " <> tshow e) $ ackMsg msgMeta Nothing
|
||||
throwError e
|
||||
where
|
||||
eventInfo = do
|
||||
v <- asks eventSeq
|
||||
eId <- atomically $ stateTVar v $ \i -> (i + 1, i + 1)
|
||||
pure $ "conn_id=" <> tshow cId <> " event_id=" <> tshow eId
|
||||
withLog eInfo' ack = do
|
||||
ts <- showTags
|
||||
logInfo $ T.unwords [label, "ack:", ts, eInfo']
|
||||
ack
|
||||
logInfo $ T.unwords [label, "ack=success:", ts, eInfo']
|
||||
showTags = do
|
||||
ts <- maybe (pure []) readTVarIO tags
|
||||
pure $ case ts of
|
||||
[] -> "no_chat_messages"
|
||||
[t] -> "chat_message=" <> t
|
||||
_ -> "chat_message_batch=" <> T.intercalate "," (reverse ts)
|
||||
ackMsg :: MsgMeta -> Maybe MsgReceiptInfo -> CM ()
|
||||
ackMsg MsgMeta {recipient = (msgId, _)} rcpt = withAgent $ \a -> ackMessageAsync a "" cId msgId rcpt
|
||||
|
||||
|
|
@ -6608,6 +6645,8 @@ deliverMessagesB msgReqs = do
|
|||
where
|
||||
updatePQ = updateConnPQSndEnabled db connId pqSndEnabled'
|
||||
|
||||
-- TODO combine profile update and message into one batch
|
||||
-- Take into account that it may not fit, and that we currently don't support sending multiple messages to the same connection in one call.
|
||||
sendGroupMessage :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> CM (SndMessage, [GroupMember])
|
||||
sendGroupMessage user gInfo members chatMsgEvent = do
|
||||
when shouldSendProfileUpdate $
|
||||
|
|
|
|||
|
|
@ -13,6 +13,7 @@
|
|||
{-# LANGUAGE StrictData #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -fno-warn-implicit-lift #-}
|
||||
|
||||
module Simplex.Chat.Controller where
|
||||
|
||||
|
|
@ -205,6 +206,7 @@ data ChatController = ChatController
|
|||
chatStore :: SQLiteStore,
|
||||
chatStoreChanged :: TVar Bool, -- if True, chat should be fully restarted
|
||||
random :: TVar ChaChaDRG,
|
||||
eventSeq :: TVar Int,
|
||||
inputQ :: TBQueue String,
|
||||
outputQ :: TBQueue (Maybe CorrId, Maybe RemoteHostId, ChatResponse),
|
||||
connNetworkStatuses :: TMap AgentConnId NetworkStatus,
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@
|
|||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
{-# OPTIONS_GHC -fno-warn-operator-whitespace #-}
|
||||
|
||||
module Simplex.Chat.Messages where
|
||||
|
||||
|
|
@ -455,10 +456,10 @@ deriving instance Show ACIReaction
|
|||
data JSONCIReaction c d = JSONCIReaction {chatInfo :: ChatInfo c, chatReaction :: CIReaction c d}
|
||||
|
||||
type family ChatTypeQuotable (a :: ChatType) :: Constraint where
|
||||
ChatTypeQuotable CTDirect = ()
|
||||
ChatTypeQuotable CTGroup = ()
|
||||
ChatTypeQuotable 'CTDirect = ()
|
||||
ChatTypeQuotable 'CTGroup = ()
|
||||
ChatTypeQuotable a =
|
||||
(Int ~ Bool, TypeError (Type.Text "ChatType " :<>: ShowType a :<>: Type.Text " cannot be quoted"))
|
||||
(Int ~ Bool, TypeError ('Type.Text "ChatType " ':<>: 'ShowType a ':<>: 'Type.Text " cannot be quoted"))
|
||||
|
||||
data CIQDirection (c :: ChatType) where
|
||||
CIQDirectSnd :: CIQDirection 'CTDirect
|
||||
|
|
|
|||
|
|
@ -838,7 +838,7 @@ toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentTex
|
|||
ciMeta content status =
|
||||
let itemDeleted' = case itemDeleted of
|
||||
DBCINotDeleted -> Nothing
|
||||
_ -> Just (CIDeleted @CTLocal deletedTs)
|
||||
_ -> Just (CIDeleted @'CTLocal deletedTs)
|
||||
itemEdited' = fromMaybe False itemEdited
|
||||
itemForwarded = toCIForwardedFrom forwardedFromRow
|
||||
in mkCIMeta itemId content itemText status sentViaProxy sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs Nothing createdAt updatedAt
|
||||
|
|
@ -1458,7 +1458,7 @@ toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentT
|
|||
ciMeta content status =
|
||||
let itemDeleted' = case itemDeleted of
|
||||
DBCINotDeleted -> Nothing
|
||||
_ -> Just (CIDeleted @CTDirect deletedTs)
|
||||
_ -> Just (CIDeleted @'CTDirect deletedTs)
|
||||
itemEdited' = fromMaybe False itemEdited
|
||||
itemForwarded = toCIForwardedFrom forwardedFromRow
|
||||
in mkCIMeta itemId content itemText status sentViaProxy sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs Nothing createdAt updatedAt
|
||||
|
|
@ -1520,7 +1520,7 @@ toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir,
|
|||
DBCINotDeleted -> Nothing
|
||||
DBCIBlocked -> Just (CIBlocked deletedTs)
|
||||
DBCIBlockedByAdmin -> Just (CIBlockedByAdmin deletedTs)
|
||||
_ -> Just (maybe (CIDeleted @CTGroup deletedTs) (CIModerated deletedTs) deletedByGroupMember_)
|
||||
_ -> Just (maybe (CIDeleted @'CTGroup deletedTs) (CIModerated deletedTs) deletedByGroupMember_)
|
||||
itemEdited' = fromMaybe False itemEdited
|
||||
itemForwarded = toCIForwardedFrom forwardedFromRow
|
||||
in mkCIMeta itemId content itemText status sentViaProxy sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs forwardedByMember createdAt updatedAt
|
||||
|
|
@ -1919,7 +1919,7 @@ markGroupChatItemDeleted db User {userId} GroupInfo {groupId} ci@ChatItem {meta}
|
|||
let itemId = chatItemId' ci
|
||||
(deletedByGroupMemberId, itemDeleted) = case byGroupMember_ of
|
||||
Just m@GroupMember {groupMemberId} -> (Just groupMemberId, Just $ CIModerated (Just deletedTs) m)
|
||||
_ -> (Nothing, Just $ CIDeleted @CTGroup (Just deletedTs))
|
||||
_ -> (Nothing, Just $ CIDeleted @'CTGroup (Just deletedTs))
|
||||
insertChatItemMessage_ db itemId msgId currentTs
|
||||
DB.execute
|
||||
db
|
||||
|
|
|
|||
|
|
@ -2028,14 +2028,16 @@ viewChatError logLevel testView = \case
|
|||
DBErrorOpen e -> ["error opening database after encryption: " <> sqliteError' e]
|
||||
e -> ["chat database error: " <> sShow e]
|
||||
ChatErrorAgent err entity_ -> case err of
|
||||
CMD PROHIBITED -> [withConnEntity <> "error: command is prohibited"]
|
||||
CMD PROHIBITED cxt -> [withConnEntity <> plain ("error: command is prohibited, " <> cxt)]
|
||||
SMP _ SMP.AUTH ->
|
||||
[ withConnEntity
|
||||
<> "error: connection authorization failed - this could happen if connection was deleted,\
|
||||
\ secured with different credentials, or due to a bug - please re-create the connection"
|
||||
]
|
||||
BROKER _ NETWORK -> []
|
||||
BROKER _ TIMEOUT -> []
|
||||
AGENT A_DUPLICATE -> [withConnEntity <> "error: AGENT A_DUPLICATE" | logLevel == CLLDebug]
|
||||
AGENT A_PROHIBITED -> [withConnEntity <> "error: AGENT A_PROHIBITED" | logLevel <= CLLWarning]
|
||||
AGENT (A_PROHIBITED e) -> [withConnEntity <> "error: AGENT A_PROHIBITED, " <> plain e | logLevel <= CLLWarning]
|
||||
CONN NOT_FOUND -> [withConnEntity <> "error: CONN NOT_FOUND" | logLevel <= CLLWarning]
|
||||
CRITICAL restart e -> [plain $ "critical error: " <> e] <> ["please restart the app" | restart]
|
||||
INTERNAL e -> [plain $ "internal error: " <> e]
|
||||
|
|
|
|||
|
|
@ -431,7 +431,8 @@ serverCfg =
|
|||
smpHandshakeTimeout = 1000000,
|
||||
controlPort = Nothing,
|
||||
smpAgentCfg = defaultSMPClientAgentConfig,
|
||||
allowSMPProxy = False
|
||||
allowSMPProxy = False,
|
||||
serverClientConcurrency = 16
|
||||
}
|
||||
|
||||
withSmpServer :: IO () -> IO ()
|
||||
|
|
|
|||
|
|
@ -2310,12 +2310,12 @@ testAbortSwitchContact tmp = do
|
|||
alice <## "bob: you started changing address"
|
||||
-- repeat switch is prohibited
|
||||
alice ##> "/switch bob"
|
||||
alice <## "error: command is prohibited"
|
||||
alice <## "error: command is prohibited, switchConnectionAsync: already switching"
|
||||
-- stop switch
|
||||
alice #$> ("/abort switch bob", id, "switch aborted")
|
||||
-- repeat switch stop is prohibited
|
||||
alice ##> "/abort switch bob"
|
||||
alice <## "error: command is prohibited"
|
||||
alice <## "error: command is prohibited, abortConnectionSwitch: not allowed"
|
||||
withTestChatContactConnected tmp "bob" $ \bob -> do
|
||||
bob <## "alice started changing address for you"
|
||||
-- alice changes address again
|
||||
|
|
@ -2356,12 +2356,12 @@ testAbortSwitchGroupMember tmp = do
|
|||
alice <## "#team: you started changing address for bob"
|
||||
-- repeat switch is prohibited
|
||||
alice ##> "/switch #team bob"
|
||||
alice <## "error: command is prohibited"
|
||||
alice <## "error: command is prohibited, switchConnectionAsync: already switching"
|
||||
-- stop switch
|
||||
alice #$> ("/abort switch #team bob", id, "switch aborted")
|
||||
-- repeat switch stop is prohibited
|
||||
alice ##> "/abort switch #team bob"
|
||||
alice <## "error: command is prohibited"
|
||||
alice <## "error: command is prohibited, abortConnectionSwitch: not allowed"
|
||||
withTestChatContactConnected tmp "bob" $ \bob -> do
|
||||
bob <## "#team: connected to server(s)"
|
||||
bob <## "#team: alice started changing address for you"
|
||||
|
|
@ -2485,7 +2485,7 @@ setupDesynchronizedRatchet tmp alice = do
|
|||
withTestChat tmp "bob_old" $ \bob -> do
|
||||
bob <## "1 contacts connected (use /cs for the list)"
|
||||
bob ##> "/sync alice"
|
||||
bob <## "error: command is prohibited"
|
||||
bob <## "error: command is prohibited, synchronizeRatchet: not allowed"
|
||||
alice #> "@bob 1"
|
||||
bob <## "alice: decryption error (connection out of sync), synchronization required"
|
||||
bob <## "use /sync alice to synchronize"
|
||||
|
|
@ -2495,7 +2495,7 @@ setupDesynchronizedRatchet tmp alice = do
|
|||
bob ##> "/tail @alice 1"
|
||||
bob <# "alice> decryption error, possibly due to the device change (header, 3 messages)"
|
||||
bob ##> "@alice 1"
|
||||
bob <## "error: command is prohibited"
|
||||
bob <## "error: command is prohibited, sendMessagesB: send prohibited"
|
||||
(alice </)
|
||||
where
|
||||
copyDb from to = do
|
||||
|
|
|
|||
|
|
@ -3266,7 +3266,7 @@ setupDesynchronizedRatchet tmp alice = do
|
|||
bob <## "1 contacts connected (use /cs for the list)"
|
||||
bob <## "#team: connected to server(s)"
|
||||
bob ##> "/sync #team alice"
|
||||
bob <## "error: command is prohibited"
|
||||
bob <## "error: command is prohibited, synchronizeRatchet: not allowed"
|
||||
alice #> "#team 1"
|
||||
bob <## "#team alice: decryption error (connection out of sync), synchronization required"
|
||||
bob <## "use /sync #team alice to synchronize"
|
||||
|
|
@ -3294,7 +3294,7 @@ testGroupSyncRatchet tmp =
|
|||
bob <## "1 contacts connected (use /cs for the list)"
|
||||
bob <## "#team: connected to server(s)"
|
||||
bob `send` "#team 1"
|
||||
bob <## "error: command is prohibited" -- silence?
|
||||
bob <## "error: command is prohibited, sendMessagesB: send prohibited" -- silence?
|
||||
bob <# "#team 1"
|
||||
(alice </)
|
||||
-- synchronize bob and alice
|
||||
|
|
|
|||
|
|
@ -294,7 +294,7 @@ testFileCApi fileName tmp = do
|
|||
let sz' = fromIntegral sz
|
||||
contents <- create sz' $ \toPtr -> copyBytes toPtr (ptr' `plusPtr` 5) sz'
|
||||
contents `shouldBe` src
|
||||
sz' `shouldBe` fromIntegral len
|
||||
sz' `shouldBe` len
|
||||
|
||||
testMissingFileCApi :: FilePath -> IO ()
|
||||
testMissingFileCApi tmp = do
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue