From 291df6e9d0bd75c2b6e1d06a7fce5e4574c8c865 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Fri, 24 May 2024 21:09:21 +0100 Subject: [PATCH] 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 --- .../src/Directory/Events.hs | 12 ++- .../src/Directory/Service.hs | 1 + .../src/Directory/Store.hs | 13 +-- cabal.project | 2 +- package.yaml | 23 ++++- scripts/nix/sha256map.nix | 2 +- simplex-chat.cabal | 14 +-- src/Simplex/Chat.hs | 91 +++++++++++++------ src/Simplex/Chat/Controller.hs | 2 + src/Simplex/Chat/Messages.hs | 7 +- src/Simplex/Chat/Store/Messages.hs | 8 +- src/Simplex/Chat/View.hs | 6 +- tests/ChatClient.hs | 3 +- tests/ChatTests/Direct.hs | 12 +-- tests/ChatTests/Groups.hs | 4 +- tests/MobileTests.hs | 2 +- 16 files changed, 139 insertions(+), 63 deletions(-) diff --git a/apps/simplex-directory-service/src/Directory/Events.hs b/apps/simplex-directory-service/src/Directory/Events.hs index 87950ecce7..31a7e94aad 100644 --- a/apps/simplex-directory-service/src/Directory/Events.hs +++ b/apps/simplex-directory-service/src/Directory/Events.hs @@ -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 diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index eefb1f77a4..a61e405cb8 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -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 diff --git a/apps/simplex-directory-service/src/Directory/Store.hs b/apps/simplex-directory-service/src/Directory/Store.hs index 5082cab2ce..c810102e08 100644 --- a/apps/simplex-directory-service/src/Directory/Store.hs +++ b/apps/simplex-directory-service/src/Directory/Store.hs @@ -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 diff --git a/cabal.project b/cabal.project index 859f5ac1ac..a68df42bf7 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: e7a73a4c89ed02e248e2d77e267037c9d4433820 + tag: bd67844169d2206d8543c01e6ed966315115b0e3 source-repository-package type: git diff --git a/package.yaml b/package.yaml index df815e75a8..d31a3086a4 100644 --- a/package.yaml +++ b/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: diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index b4c90d8980..468ca71307 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -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"; diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 96689b9f30..691baa7264 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -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.* diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 1165c7ccff..e259629d2b 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -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 $ diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 9ff903514f..2c4c09c79c 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -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, diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 449731b91c..9742439fb3 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -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 diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index b0a0495c16..0487b80c17 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -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 diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 1c2b0b2cc1..08980f21d2 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -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] diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index 2bcd52ab3f..83ac69ebe9 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -431,7 +431,8 @@ serverCfg = smpHandshakeTimeout = 1000000, controlPort = Nothing, smpAgentCfg = defaultSMPClientAgentConfig, - allowSMPProxy = False + allowSMPProxy = False, + serverClientConcurrency = 16 } withSmpServer :: IO () -> IO () diff --git a/tests/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs index 2e549d9dd1..24281ae830 100644 --- a/tests/ChatTests/Direct.hs +++ b/tests/ChatTests/Direct.hs @@ -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 "/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 copyBytes toPtr (ptr' `plusPtr` 5) sz' contents `shouldBe` src - sz' `shouldBe` fromIntegral len + sz' `shouldBe` len testMissingFileCApi :: FilePath -> IO () testMissingFileCApi tmp = do