dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-03-30 18:35:49 +00:00
Code Issues Packages Projects Releases Wiki Activity

core: print error context on store internal errors (#1699)

Browse Source
This commit is contained in:
JRoberts
2023-01-06 14:22:16 +04:00
committed by GitHub
parent ae5deab8d3
commit 58f06aa821
2 changed files with 23 additions and 10 deletions
Download Patch File Download Diff File Expand all files Collapse all files

31
src/Simplex/Chat.hs
View File

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

2
src/Simplex/Chat/Messages.hs
View File

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