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

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

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

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 (doesFileExist, renameFile)
-import System.Directory (renameFile, doesFileExist)
+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

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

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:

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";

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.*

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 ->
+        MSG msgMeta _msgFlags msgBody -> do
-          withAckMessage agentConnId msgMeta True $ 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
+              processEvent tags eInfo chatMsg `catchChatError` \e -> toView $ CRChatError (Just user) e
-            Left e -> toView $ CRChatError (Just user) (ChatError . CEException $ "error parsing chat message: " <> e)
+            Left e -> do
-          forwardMsg_ `catchChatError` \_ -> pure ()
+              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 :: TVar [Text] -> Text -> MsgEncodingI e => ChatMessage e -> CM ()
-          processEvent chatMsg = do
+          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' :: Text -> ConnId -> MsgMeta -> CM () -> CM ()
-    withAckMessage' cId msgMeta action = do
+    withAckMessage' label cId msgMeta action = do
-      withAckMessage cId msgMeta False $ action $> False
+      withAckMessage label cId msgMeta False Nothing $ \_ -> action $> False
 
-    withAckMessage :: ConnId -> MsgMeta -> Bool -> CM Bool -> CM ()
+    withAckMessage :: Text -> ConnId -> MsgMeta -> Bool -> Maybe (TVar [Text]) -> (Text -> CM Bool) -> CM ()
-    withAckMessage cId msgMeta showCritical action =
+    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
+      eInfo <- eventInfo
-        Right withRcpt -> ackMsg msgMeta $ if withRcpt then Just "" else Nothing
+      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 $

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,

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 'CTDirect = ()
-  ChatTypeQuotable CTGroup = ()
+  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

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

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]

tests/ChatClient.hs

@@ -431,7 +431,8 @@ serverCfg =
       smpHandshakeTimeout = 1000000,
       controlPort = Nothing,
       smpAgentCfg = defaultSMPClientAgentConfig,
-      allowSMPProxy = False
+      allowSMPProxy = False,
+      serverClientConcurrency = 16
     }
 
 withSmpServer :: IO () -> IO ()

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 </)
   where
     copyDb from to = do

tests/ChatTests/Groups.hs

@@ -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

tests/MobileTests.hs

@@ -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