From 58f06aa8216c2dfadf5be0c4c115e04497363d71 Mon Sep 17 00:00:00 2001
From: JRoberts <8711996+jr-simplex@users.noreply.github.com>
Date: Fri, 6 Jan 2023 14:22:16 +0400
Subject: [PATCH] core: print error context on store internal errors (#1699)

---
 src/Simplex/Chat.hs          | 31 +++++++++++++++++++++----------
 src/Simplex/Chat/Messages.hs |  2 ++
 2 files changed, 23 insertions(+), 10 deletions(-)

diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs
index 7664ddaf75..d68177d199 100644
--- a/src/Simplex/Chat.hs
+++ b/src/Simplex/Chat.hs
@@ -2400,11 +2400,15 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
 
     ackMsgDeliveryEvent :: Connection -> CommandId -> m ()
     ackMsgDeliveryEvent Connection {connId} ackCmdId =
-      withStore' $ \db -> createRcvMsgDeliveryEvent db connId ackCmdId MDSRcvAcknowledged
+      withStoreCtx'
+        (Just $ "createRcvMsgDeliveryEvent, connId: " <> show connId <> ", ackCmdId: " <> show ackCmdId <> ", msgDeliveryStatus: MDSRcvAcknowledged")
+        $ \db -> createRcvMsgDeliveryEvent db connId ackCmdId MDSRcvAcknowledged
 
     sentMsgDeliveryEvent :: Connection -> AgentMsgId -> m ()
     sentMsgDeliveryEvent Connection {connId} msgId =
-      withStore $ \db -> createSndMsgDeliveryEvent db connId msgId MDSSndSent
+      withStoreCtx
+        (Just $ "createSndMsgDeliveryEvent, connId: " <> show connId <> ", msgId: " <> show msgId <> ", msgDeliveryStatus: MDSSndSent")
+        $ \db -> createSndMsgDeliveryEvent db connId msgId MDSSndSent
 
     agentErrToItemStatus :: AgentErrorType -> CIStatus 'MDSnd
     agentErrToItemStatus (SMP AUTH) = CISSndErrorAuth
@@ -3303,7 +3307,9 @@ deliverMessage conn@Connection {connId} cmEventTag msgBody msgId = do
   let msgFlags = MsgFlags {notification = hasNotification cmEventTag}
   agentMsgId <- withAgent $ \a -> sendMessage a (aConnId conn) msgFlags msgBody
   let sndMsgDelivery = SndMsgDelivery {connId, agentMsgId}
-  withStore' $ \db -> createSndMsgDelivery db sndMsgDelivery msgId
+  withStoreCtx'
+    (Just $ "createSndMsgDelivery, sndMsgDelivery: " <> show sndMsgDelivery <> ", msgId: " <> show msgId <> ", cmEventTag: " <> show cmEventTag <> ", msgDeliveryStatus: MDSSndAgent")
+    $ \db -> createSndMsgDelivery db sndMsgDelivery msgId
 
 sendGroupMessage :: (MsgEncodingI e, ChatMonad m) => GroupInfo -> [GroupMember] -> ChatMsgEvent e -> m SndMessage
 sendGroupMessage GroupInfo {groupId} members chatMsgEvent =
@@ -3343,7 +3349,9 @@ saveRcvMSG Connection {connId} connOrGroupId agentMsgMeta msgBody agentAckCmdId
   let agentMsgId = fst $ recipient agentMsgMeta
       newMsg = NewMessage {chatMsgEvent, msgBody}
       rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId}
-  withStore' $ \db -> createNewMessageAndRcvMsgDelivery db connOrGroupId newMsg sharedMsgId_ rcvMsgDelivery
+  withStoreCtx'
+    (Just $ "createNewMessageAndRcvMsgDelivery, rcvMsgDelivery: " <> show rcvMsgDelivery <> ", sharedMsgId_: " <> show sharedMsgId_ <> ", msgDeliveryStatus: MDSRcvAgent")
+    $ \db -> createNewMessageAndRcvMsgDelivery db connOrGroupId newMsg sharedMsgId_ rcvMsgDelivery
 
 saveSndChatItem :: ChatMonad m => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> m (ChatItem c 'MDSnd)
 saveSndChatItem user cd msg content = saveSndChatItem' user cd msg content Nothing Nothing Nothing False
@@ -3611,17 +3619,20 @@ withAgent action =
 withStore' :: ChatMonad m => (DB.Connection -> IO a) -> m a
 withStore' action = withStore $ liftIO . action
 
-withStore ::
-  ChatMonad m =>
-  (DB.Connection -> ExceptT StoreError IO a) ->
-  m a
-withStore action = do
+withStore :: ChatMonad m => (DB.Connection -> ExceptT StoreError IO a) -> m a
+withStore = withStoreCtx Nothing
+
+withStoreCtx' :: ChatMonad m => Maybe String -> (DB.Connection -> IO a) -> m a
+withStoreCtx' ctx_ action = withStoreCtx ctx_ $ liftIO . action
+
+withStoreCtx :: ChatMonad m => Maybe String -> (DB.Connection -> ExceptT StoreError IO a) -> m a
+withStoreCtx ctx_ action = do
   ChatController {chatStore} <- ask
   liftEitherError ChatErrorStore $
     withTransaction chatStore (runExceptT . action) `E.catch` handleInternal
   where
     handleInternal :: E.SomeException -> IO (Either StoreError a)
-    handleInternal = pure . Left . SEInternalError . show
+    handleInternal e = pure . Left . SEInternalError $ show e <> maybe "" (\ctx -> " (" <> ctx <> ")") ctx_
 
 chatCommandP :: Parser ChatCommand
 chatCommandP =
diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs
index e28d492480..497ce7bb63 100644
--- a/src/Simplex/Chat/Messages.hs
+++ b/src/Simplex/Chat/Messages.hs
@@ -1157,6 +1157,7 @@ data SndMsgDelivery = SndMsgDelivery
   { connId :: Int64,
     agentMsgId :: AgentMsgId
   }
+  deriving (Show)
 
 data RcvMsgDelivery = RcvMsgDelivery
   { connId :: Int64,
@@ -1164,6 +1165,7 @@ data RcvMsgDelivery = RcvMsgDelivery
     agentMsgMeta :: MsgMeta,
     agentAckCmdId :: CommandId
   }
+  deriving (Show)
 
 data MsgMetaJSON = MsgMetaJSON
   { integrity :: Text,