mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-10-23 04:22:13 +00:00
core: update simplexmq (error handling) (#6231)
* core: update simplexmq (error handling) * update simplexmq
This commit is contained in:
Evgeny authored and GitHub committed
1 parent
e6e99ab709
commit
f6c699f3a5
10 files changed
+110
-141
No files matched your search
@@ -230,7 +230,7 @@ startReceiveUserFiles :: User -> CM ()
|
||||
startReceiveUserFiles user = do
|
||||
filesToReceive <- withStore' (`getRcvFilesToReceive` user)
|
||||
forM_ filesToReceive $ \ft ->
|
||||
flip catchChatError eToView $
|
||||
flip catchAllErrors eToView $
|
||||
toView =<< receiveFileEvt' user ft False Nothing Nothing
|
||||
|
||||
restoreCalls :: CM' ()
|
||||
@@ -300,7 +300,7 @@ handleCommandError a = runExceptT a `E.catches` ioErrors
|
||||
where
|
||||
ioErrors =
|
||||
[ E.Handler $ \(e :: ExitCode) -> E.throwIO e,
|
||||
E.Handler $ pure . Left . mkChatError
|
||||
E.Handler $ pure . Left . fromSomeException
|
||||
]
|
||||
|
||||
parseChatCommand :: ByteString -> Either String ChatCommand
|
||||
@@ -324,7 +324,7 @@ processChatCommand vr nm = \case
|
||||
user <- withFastStore $ \db -> do
|
||||
user <- createUserRecordAt db (AgentUserId auId) p True ts
|
||||
mapM_ (setUserServers db user ts) uss
|
||||
createPresetContactCards db user `catchStoreError` \_ -> pure ()
|
||||
createPresetContactCards db user `catchAllErrors` \_ -> pure ()
|
||||
createNoteFolder db user
|
||||
pure user
|
||||
atomically . writeTVar u $ Just user
|
||||
@@ -363,7 +363,7 @@ processChatCommand vr nm = \case
|
||||
chatWriteVar currentUser $ Just user''
|
||||
pure $ CRActiveUser user''
|
||||
SetActiveUser uName viewPwd_ -> do
|
||||
tryChatError (withFastStore (`getUserIdByName` uName)) >>= \case
|
||||
tryAllErrors (withFastStore (`getUserIdByName` uName)) >>= \case
|
||||
Left _ -> throwChatError CEUserUnknown
|
||||
Right userId -> processChatCommand vr nm $ APISetActiveUser userId viewPwd_
|
||||
SetAllContactReceipts onOff -> withUser $ \_ -> withFastStore' (`updateAllContactReceipts` onOff) >> ok_
|
||||
@@ -1101,7 +1101,7 @@ processChatCommand vr nm = \case
|
||||
where
|
||||
sendDelDeleteConns ct notify = do
|
||||
let doSendDel = contactReady ct && contactActive ct && notify
|
||||
when doSendDel $ void (sendDirectContactMessage user ct XDirectDel) `catchChatError` const (pure ())
|
||||
when doSendDel $ void (sendDirectContactMessage user ct XDirectDel) `catchAllErrors` const (pure ())
|
||||
contactConnIds <- map aConnId <$> withFastStore' (\db -> getContactConnections db vr userId ct)
|
||||
deleteAgentConnectionsAsync' contactConnIds doSendDel
|
||||
CTContactConnection -> withConnectionLock "deleteChat contactConnection" chatId $ do
|
||||
@@ -1123,7 +1123,7 @@ processChatCommand vr nm = \case
|
||||
when doSendDel . void $ sendGroupMessage' user gInfo recipients XGrpDel
|
||||
deleteGroupLinkIfExists user gInfo
|
||||
deleteMembersConnections' user members doSendDel
|
||||
updateCIGroupInvitationStatus user gInfo CIGISRejected `catchChatError` \_ -> pure ()
|
||||
updateCIGroupInvitationStatus user gInfo CIGISRejected `catchAllErrors` \_ -> pure ()
|
||||
withFastStore' $ \db -> deleteGroupChatItems db user gInfo
|
||||
withFastStore' $ \db -> cleanupHostGroupLinkConn db user gInfo
|
||||
withFastStore' $ \db -> deleteGroupMembers db user gInfo
|
||||
@@ -1467,7 +1467,7 @@ processChatCommand vr nm = \case
|
||||
oldTTL = fromMaybe globalTTL oldTTL_
|
||||
when (newTTL > 0 && (newTTL < oldTTL || oldTTL == 0)) $ do
|
||||
lift $ setExpireCIFlag user False
|
||||
expireChat user globalTTL `catchChatError` eToView
|
||||
expireChat user globalTTL `catchAllErrors` eToView
|
||||
lift $ setChatItemsExpiration user globalTTL ttlCount
|
||||
ok user
|
||||
where
|
||||
@@ -1538,7 +1538,7 @@ processChatCommand vr nm = \case
|
||||
liftIO $ updateGroupSettings db user chatId chatSettings
|
||||
pure ms
|
||||
forM_ (filter memberActive ms) $ \m -> forM_ (memberConnId m) $ \connId ->
|
||||
withAgent (\a -> toggleConnectionNtfs a connId $ chatHasNtfs chatSettings) `catchChatError` eToView
|
||||
withAgent (\a -> toggleConnectionNtfs a connId $ chatHasNtfs chatSettings) `catchAllErrors` eToView
|
||||
ok user
|
||||
_ -> throwCmdError "not supported"
|
||||
APISetMemberSettings gId gMemberId settings -> withUser $ \user -> do
|
||||
@@ -1829,7 +1829,7 @@ processChatCommand vr nm = \case
|
||||
case preparedContact of
|
||||
Nothing -> throwCmdError "contact doesn't have link to connect"
|
||||
Just PreparedContact {connLinkToConnect = ACCL SCMInvitation ccLink} -> do
|
||||
(_, customUserProfile) <- connectViaInvitation user incognito ccLink (Just contactId) `catchChatError` \e -> do
|
||||
(_, customUserProfile) <- connectViaInvitation user incognito ccLink (Just contactId) `catchAllErrors` \e -> do
|
||||
-- get updated contact, in case connection was started - in UI it would lock ability to change
|
||||
-- user or incognito profile for contact, in case server received request while client got network error
|
||||
ct' <- withFastStore $ \db -> getContact db vr user contactId
|
||||
@@ -1852,7 +1852,7 @@ processChatCommand vr nm = \case
|
||||
smId <- getSharedMsgId
|
||||
withFastStore' $ \db -> setRequestSharedMsgIdForContact db contactId smId
|
||||
pure (smId, mc)
|
||||
r <- connectViaContact user (Just $ PCEContact ct) incognito ccLink welcomeSharedMsgId msg_ `catchChatError` \e -> do
|
||||
r <- connectViaContact user (Just $ PCEContact ct) incognito ccLink welcomeSharedMsgId msg_ `catchAllErrors` \e -> do
|
||||
-- get updated contact, in case connection was started - in UI it would lock ability to change
|
||||
-- user or incognito profile for contact, in case server received request while client got network error
|
||||
ct' <- withFastStore $ \db -> getContact db vr user contactId
|
||||
@@ -1880,7 +1880,7 @@ processChatCommand vr nm = \case
|
||||
smId <- getSharedMsgId
|
||||
withFastStore' $ \db -> setRequestSharedMsgIdForGroup db groupId smId
|
||||
pure (smId, mc)
|
||||
r <- connectViaContact user (Just $ PCEGroup gInfo hostMember) incognito connLinkToConnect welcomeSharedMsgId msg_ `catchChatError` \e -> do
|
||||
r <- connectViaContact user (Just $ PCEGroup gInfo hostMember) incognito connLinkToConnect welcomeSharedMsgId msg_ `catchAllErrors` \e -> do
|
||||
-- get updated group info, in case connection was started (connLinkPreparedConnection) - in UI it would lock ability to change
|
||||
-- user or incognito profile for group or business chat, in case server received request while client got network error
|
||||
gInfo' <- withFastStore $ \db -> getGroupInfo db vr user groupId
|
||||
@@ -1908,7 +1908,7 @@ processChatCommand vr nm = \case
|
||||
CVRSentInvitation conn incognitoProfile -> pure $ CRSentInvitation user (mkPendingContactConnection conn Nothing) incognitoProfile
|
||||
APIConnect _ _ Nothing -> throwChatError CEInvalidConnReq
|
||||
Connect incognito (Just cLink@(ACL m cLink')) -> withUser $ \user -> do
|
||||
(ccLink, plan) <- connectPlan user cLink `catchChatError` \e -> case cLink' of CLFull cReq -> pure (ACCL m (CCLink cReq Nothing), CPInvitationLink (ILPOk Nothing)); _ -> throwError e
|
||||
(ccLink, plan) <- connectPlan user cLink `catchAllErrors` \e -> case cLink' of CLFull cReq -> pure (ACCL m (CCLink cReq Nothing), CPInvitationLink (ILPOk Nothing)); _ -> throwError e
|
||||
connectWithPlan user incognito ccLink plan
|
||||
Connect _ Nothing -> throwChatError CEInvalidConnReq
|
||||
APIConnectContactViaAddress userId incognito contactId -> withUserId userId $ \user -> do
|
||||
@@ -1919,14 +1919,14 @@ processChatCommand vr nm = \case
|
||||
(cReq, _cData) <- getShortLinkConnReq user sLnk
|
||||
pure $ CCLink cReq $ Just sLnk
|
||||
Nothing -> throwCmdError "no address in contact profile"
|
||||
connectContactViaAddress user incognito ct ccLink `catchChatError` \e -> do
|
||||
connectContactViaAddress user incognito ct ccLink `catchAllErrors` \e -> do
|
||||
-- get updated contact, in case connection was started - in UI it would lock ability to change incognito choice
|
||||
-- on next connection attempt, in case server received request while client got network error
|
||||
ct' <- withFastStore $ \db -> getContact db vr user contactId
|
||||
toView $ CEvtChatInfoUpdated user (AChatInfo SCTDirect $ DirectChat ct')
|
||||
throwError e
|
||||
ConnectSimplex incognito -> withUser $ \user -> do
|
||||
plan <- contactRequestPlan user adminContactReq Nothing `catchChatError` const (pure $ CPContactAddress (CAPOk Nothing))
|
||||
plan <- contactRequestPlan user adminContactReq Nothing `catchAllErrors` const (pure $ CPContactAddress (CAPOk Nothing))
|
||||
connectWithPlan user incognito (ACCL SCMContact (CCLink adminContactReq Nothing)) plan
|
||||
DeleteContact cName cdm -> withContactName cName $ \ctId -> APIDeleteChat (ChatRef CTDirect ctId Nothing) cdm
|
||||
ClearContact cName -> withContactName cName $ \chatId -> APIClearChat $ ChatRef CTDirect chatId Nothing
|
||||
@@ -2200,12 +2200,12 @@ processChatCommand vr nm = \case
|
||||
-- MFAll is default for new groups
|
||||
unless (enableNtfs == MFAll) $ updateGroupSettings db user groupId chatSettings {enableNtfs}
|
||||
void (withAgent $ \a -> joinConnection a nm (aUserId user) agentConnId (enableNtfs /= MFNone) connRequest dm PQSupportOff subMode)
|
||||
`catchChatError` \e -> do
|
||||
`catchAllErrors` \e -> do
|
||||
withFastStore' $ \db -> do
|
||||
updateGroupMemberStatus db userId fromMember GSMemInvited
|
||||
updateGroupMemberStatus db userId membership GSMemInvited
|
||||
throwError e
|
||||
updateCIGroupInvitationStatus user g CIGISAccepted `catchChatError` eToView
|
||||
updateCIGroupInvitationStatus user g CIGISAccepted `catchAllErrors` eToView
|
||||
pure $ CRUserAcceptedGroupSent user g {membership = membership {memberStatus = GSMemAccepted}} Nothing
|
||||
Nothing -> throwChatError $ CEContactNotActive ct
|
||||
APIAcceptMember groupId gmId role -> withUser $ \user@User {userId} -> do
|
||||
@@ -2308,7 +2308,7 @@ processChatCommand vr nm = \case
|
||||
changeRoleInvitedMems :: User -> GroupInfo -> [GroupMember] -> CM ([ChatError], [GroupMember])
|
||||
changeRoleInvitedMems user gInfo memsToChange = do
|
||||
-- not batched, as we need to send different invitations to different connections anyway
|
||||
mems_ <- forM memsToChange $ \m -> (Right <$> changeRole m) `catchChatError` (pure . Left)
|
||||
mems_ <- forM memsToChange $ \m -> (Right <$> changeRole m) `catchAllErrors` (pure . Left)
|
||||
pure $ partitionEithers mems_
|
||||
where
|
||||
changeRole :: GroupMember -> CM GroupMember
|
||||
@@ -2620,7 +2620,7 @@ processChatCommand vr nm = \case
|
||||
APIAcceptMemberContact contactId -> withUser $ \user -> do
|
||||
(g, mConn, ct, groupDirectInv) <- withFastStore $ \db -> getMemberContactInvited db vr user contactId
|
||||
when (groupDirectInvStartedConnection groupDirectInv) $ throwCmdError "connection already started"
|
||||
connectMemberContact user g mConn ct groupDirectInv `catchChatError` \e -> do
|
||||
connectMemberContact user g mConn ct groupDirectInv `catchAllErrors` \e -> do
|
||||
-- get updated contact, in case connection was started
|
||||
ct' <- withFastStore $ \db -> getContact db vr user contactId
|
||||
toView $ CEvtChatInfoUpdated user (AChatInfo SCTDirect $ DirectChat ct')
|
||||
@@ -3233,7 +3233,7 @@ processChatCommand vr nm = \case
|
||||
mergedProfile' = userProfileDirect user (fromLocalProfile <$> incognitoProfile) (Just ct') False
|
||||
when (mergedProfile' /= mergedProfile) $
|
||||
withContactLock "updateContactPrefs" (contactId' ct) $ do
|
||||
void (sendDirectContactMessage user ct' $ XInfo mergedProfile') `catchChatError` eToView
|
||||
void (sendDirectContactMessage user ct' $ XInfo mergedProfile') `catchAllErrors` eToView
|
||||
lift . when (directOrUsed ct') $ createSndFeatureItems user ct ct'
|
||||
pure $ CRContactPrefsUpdated user ct ct'
|
||||
runUpdateGroupProfile :: User -> Group -> GroupProfile -> CM ChatResponse
|
||||
@@ -3411,7 +3411,7 @@ processChatCommand vr nm = \case
|
||||
drgRandomBytes n = asks random >>= atomically . C.randomBytes n
|
||||
privateGetUser :: UserId -> CM User
|
||||
privateGetUser userId =
|
||||
tryChatError (withStore (`getUser` userId)) >>= \case
|
||||
tryAllErrors (withStore (`getUser` userId)) >>= \case
|
||||
Left _ -> throwChatError CEUserUnknown
|
||||
Right user -> pure user
|
||||
validateUserPassword :: User -> User -> Maybe UserPwd -> CM ()
|
||||
@@ -3452,7 +3452,7 @@ processChatCommand vr nm = \case
|
||||
filesInfo <- withFastStore' (`getUserFileInfo` user)
|
||||
deleteCIFiles user filesInfo
|
||||
withAgent (\a -> deleteUser a (aUserId user) delSMPQueues)
|
||||
`catchChatError` \case
|
||||
`catchAllErrors` \case
|
||||
e@(ChatErrorAgent NO_USER _) -> eToView e
|
||||
e -> throwError e
|
||||
withFastStore' (`deleteUserRecord` user)
|
||||
@@ -3491,11 +3491,11 @@ processChatCommand vr nm = \case
|
||||
-- deleted contact is returned as known, as invitation link cannot be re-used too connect anyway
|
||||
Nothing -> bimap inv (CPInvitationLink . ILPKnown) <$$> getContactViaShortLinkToConnect db vr user l'
|
||||
invitationReqAndPlan cReq sLnk_ contactSLinkData_ = do
|
||||
plan <- invitationRequestPlan user cReq contactSLinkData_ `catchChatError` (pure . CPError)
|
||||
plan <- invitationRequestPlan user cReq contactSLinkData_ `catchAllErrors` (pure . CPError)
|
||||
pure (ACCL SCMInvitation (CCLink cReq sLnk_), plan)
|
||||
connectPlan user (ACL SCMContact cLink) = case cLink of
|
||||
CLFull cReq -> do
|
||||
plan <- contactOrGroupRequestPlan user cReq `catchChatError` (pure . CPError)
|
||||
plan <- contactOrGroupRequestPlan user cReq `catchAllErrors` (pure . CPError)
|
||||
pure (ACCL SCMContact $ CCLink cReq Nothing, plan)
|
||||
CLShort l@(CSLContact _ ct _ _) -> do
|
||||
let l' = serverShortLink l
|
||||
@@ -3875,7 +3875,7 @@ processChatCommand vr nm = \case
|
||||
case contactOrGroup of
|
||||
CGContact Contact {activeConn} -> forM_ activeConn $ \conn ->
|
||||
withFastStore' $ \db -> createSndFTDescrXFTP db user Nothing conn ft dummyFileDescr
|
||||
CGGroup _ ms -> forM_ ms $ \m -> saveMemberFD m `catchChatError` eToView
|
||||
CGGroup _ ms -> forM_ ms $ \m -> saveMemberFD m `catchAllErrors` eToView
|
||||
where
|
||||
-- we are not sending files to pending members, same as with inline files
|
||||
saveMemberFD m@GroupMember {activeConn = Just conn@Connection {connStatus}} =
|
||||
@@ -4061,7 +4061,7 @@ startExpireCIThread user@User {userId} = do
|
||||
liftIO $ threadDelay' delay
|
||||
interval <- asks $ ciExpirationInterval . config
|
||||
forever $ do
|
||||
flip catchChatError' (eToView') $ do
|
||||
flip catchAllErrors' (eToView') $ do
|
||||
expireFlags <- asks expireCIFlags
|
||||
atomically $ TM.lookup userId expireFlags >>= \b -> unless (b == Just True) retry
|
||||
lift waitChatStartedAndActivated
|
||||
@@ -4103,7 +4103,7 @@ agentSubscriber = do
|
||||
SAERcvFile -> processAgentMsgRcvFile corrId entId msg
|
||||
SAESndFile -> processAgentMsgSndFile corrId entId msg
|
||||
where
|
||||
run action = action `catchChatError'` (eToView')
|
||||
run action = action `catchAllErrors'` (eToView')
|
||||
|
||||
type AgentBatchSubscribe = AgentClient -> [ConnId] -> ExceptT AgentErrorType IO (Map ConnId (Either AgentErrorType (Maybe ClientServiceId)))
|
||||
|
||||
@@ -4251,7 +4251,7 @@ subscribeUserConnections vr onlyNeeded agentBatchSubscribe user = do
|
||||
pendingConnSubsToView :: Map ConnId (Either AgentErrorType (Maybe ClientServiceId)) -> Map ConnId PendingContactConnection -> CM ()
|
||||
pendingConnSubsToView rs = toViewTE . TEPendingSubSummary user . map (uncurry PendingSubStatus) . resultsFor rs
|
||||
withStore_ :: (DB.Connection -> User -> IO [a]) -> CM [a]
|
||||
withStore_ a = withStore' (`a` user) `catchChatError` \e -> eToView e $> []
|
||||
withStore_ a = withStore' (`a` user) `catchAllErrors` \e -> eToView e $> []
|
||||
filterErrors :: [(a, Maybe ChatError)] -> [(a, ChatError)]
|
||||
filterErrors = mapMaybe (\(a, e_) -> (a,) <$> e_)
|
||||
resultsFor :: Map ConnId (Either AgentErrorType (Maybe ClientServiceId)) -> Map ConnId a -> [(a, Maybe ChatError)]
|
||||
@@ -4273,40 +4273,40 @@ cleanupManager = do
|
||||
liftIO $ threadDelay' initialDelay
|
||||
stepDelay <- asks (cleanupManagerStepDelay . config)
|
||||
forever $ do
|
||||
flip catchChatError eToView $ do
|
||||
flip catchAllErrors eToView $ do
|
||||
lift waitChatStartedAndActivated
|
||||
users <- withStore' getUsers
|
||||
let (us, us') = partition activeUser users
|
||||
forM_ us $ cleanupUser interval stepDelay
|
||||
forM_ us' $ cleanupUser interval stepDelay
|
||||
cleanupMessages `catchChatError` eToView
|
||||
cleanupMessages `catchAllErrors` eToView
|
||||
-- TODO possibly, also cleanup async commands
|
||||
cleanupProbes `catchChatError` eToView
|
||||
cleanupProbes `catchAllErrors` eToView
|
||||
liftIO $ threadDelay' $ diffToMicroseconds interval
|
||||
where
|
||||
runWithoutInitialDelay cleanupInterval = flip catchChatError eToView $ do
|
||||
runWithoutInitialDelay cleanupInterval = flip catchAllErrors eToView $ do
|
||||
lift waitChatStartedAndActivated
|
||||
users <- withStore' getUsers
|
||||
let (us, us') = partition activeUser users
|
||||
forM_ us $ \u -> cleanupTimedItems cleanupInterval u `catchChatError` eToView
|
||||
forM_ us' $ \u -> cleanupTimedItems cleanupInterval u `catchChatError` eToView
|
||||
forM_ us $ \u -> cleanupTimedItems cleanupInterval u `catchAllErrors` eToView
|
||||
forM_ us' $ \u -> cleanupTimedItems cleanupInterval u `catchAllErrors` eToView
|
||||
cleanupUser cleanupInterval stepDelay user = do
|
||||
cleanupTimedItems cleanupInterval user `catchChatError` eToView
|
||||
cleanupTimedItems cleanupInterval user `catchAllErrors` eToView
|
||||
liftIO $ threadDelay' stepDelay
|
||||
-- TODO remove in future versions: legacy step - contacts are no longer marked as deleted
|
||||
cleanupDeletedContacts user `catchChatError` eToView
|
||||
cleanupDeletedContacts user `catchAllErrors` eToView
|
||||
liftIO $ threadDelay' stepDelay
|
||||
cleanupTimedItems cleanupInterval user = do
|
||||
ts <- liftIO getCurrentTime
|
||||
let startTimedThreadCutoff = addUTCTime cleanupInterval ts
|
||||
timedItems <- withStore' $ \db -> getTimedItems db user startTimedThreadCutoff
|
||||
forM_ timedItems $ \(itemRef, deleteAt) -> startTimedItemThread user itemRef deleteAt `catchChatError` const (pure ())
|
||||
forM_ timedItems $ \(itemRef, deleteAt) -> startTimedItemThread user itemRef deleteAt `catchAllErrors` const (pure ())
|
||||
cleanupDeletedContacts user = do
|
||||
vr <- chatVersionRange
|
||||
contacts <- withStore' $ \db -> getDeletedContacts db vr user
|
||||
forM_ contacts $ \ct ->
|
||||
withStore (\db -> deleteContactWithoutGroups db user ct)
|
||||
`catchChatError` eToView
|
||||
`catchAllErrors` eToView
|
||||
cleanupMessages = do
|
||||
ts <- liftIO getCurrentTime
|
||||
let cutoffTs = addUTCTime (-(30 * nominalDay)) ts
|
||||
@@ -4332,7 +4332,7 @@ expireChatItems user@User {userId} globalTTL sync = do
|
||||
loop :: [Int64] -> (Int64 -> CM ()) -> CM ()
|
||||
loop [] _ = pure ()
|
||||
loop (a : as) process = continue $ do
|
||||
process a `catchChatError` eToView
|
||||
process a `catchAllErrors` eToView
|
||||
loop as process
|
||||
continue :: CM () -> CM ()
|
||||
continue a =
|
||||
@@ -4347,7 +4347,7 @@ expireContactChatItems :: User -> VersionRangeChat -> Int64 -> ContactId -> CM (
|
||||
expireContactChatItems user vr globalTTL ctId =
|
||||
-- reading contacts and groups inside the loop,
|
||||
-- to allow ttl changing while processing and to reduce memory usage
|
||||
tryChatError (withStore $ \db -> getContact db vr user ctId) >>= mapM_ process
|
||||
tryAllErrors (withStore $ \db -> getContact db vr user ctId) >>= mapM_ process
|
||||
where
|
||||
process ct@Contact {chatItemTTL} =
|
||||
withExpirationDate globalTTL chatItemTTL $ \expirationDate -> do
|
||||
@@ -4358,7 +4358,7 @@ expireContactChatItems user vr globalTTL ctId =
|
||||
|
||||
expireGroupChatItems :: User -> VersionRangeChat -> Int64 -> UTCTime -> GroupId -> CM ()
|
||||
expireGroupChatItems user vr globalTTL createdAtCutoff groupId =
|
||||
tryChatError (withStore $ \db -> getGroupInfo db vr user groupId) >>= mapM_ process
|
||||
tryAllErrors (withStore $ \db -> getGroupInfo db vr user groupId) >>= mapM_ process
|
||||
where
|
||||
process gInfo@GroupInfo {chatItemTTL} =
|
||||
withExpirationDate globalTTL chatItemTTL $ \expirationDate -> do
|
||||
|
||||
@@ -193,7 +193,7 @@ toggleNtf :: GroupMember -> Bool -> CM ()
|
||||
toggleNtf m ntfOn =
|
||||
when (memberActive m) $
|
||||
forM_ (memberConnId m) $ \connId ->
|
||||
withAgent (\a -> toggleConnectionNtfs a connId ntfOn) `catchChatError` eToView
|
||||
withAgent (\a -> toggleConnectionNtfs a connId ntfOn) `catchAllErrors` eToView
|
||||
|
||||
prepareGroupMsg :: DB.Connection -> User -> GroupInfo -> Maybe MsgScope -> MsgContent -> Map MemberName MsgMention -> Maybe ChatItemId -> Maybe CIForwardedFrom -> Maybe FileInvitation -> Maybe CITimed -> Bool -> ExceptT StoreError IO (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup))
|
||||
prepareGroupMsg db user g@GroupInfo {membership} msgScope mc mentions quotedItemId_ itemForwarded fInv_ timed_ live = case (quotedItemId_, itemForwarded) of
|
||||
@@ -385,7 +385,7 @@ cancelFilesInProgress :: User -> [CIFileInfo] -> CM ()
|
||||
cancelFilesInProgress user filesInfo = do
|
||||
let filesInfo' = filter (not . fileEnded) filesInfo
|
||||
(sfs, rfs) <- lift $ splitFTTypes <$> withStoreBatch (\db -> map (getFT db) filesInfo')
|
||||
forM_ rfs $ \RcvFileTransfer {fileId} -> lift (closeFileHandle fileId rcvFiles) `catchChatError` \_ -> pure ()
|
||||
forM_ rfs $ \RcvFileTransfer {fileId} -> lift (closeFileHandle fileId rcvFiles) `catchAllErrors` \_ -> pure ()
|
||||
lift . void . withStoreBatch' $ \db -> map (updateSndFileCancelled db) sfs
|
||||
lift . void . withStoreBatch' $ \db -> map (updateRcvFileCancelled db) rfs
|
||||
let xsfIds = mapMaybe (\(FileTransferMeta {fileId, xftpSndFile}, _) -> (,fileId) <$> xftpSndFile) sfs
|
||||
@@ -655,7 +655,7 @@ setFileToEncrypt ft@RcvFileTransfer {fileId} = do
|
||||
|
||||
receiveFile' :: User -> RcvFileTransfer -> Bool -> Maybe Bool -> Maybe FilePath -> CM ChatResponse
|
||||
receiveFile' user ft userApprovedRelays rcvInline_ filePath_ = do
|
||||
(CRRcvFileAccepted user <$> acceptFileReceive user ft userApprovedRelays rcvInline_ filePath_) `catchChatError` processError
|
||||
(CRRcvFileAccepted user <$> acceptFileReceive user ft userApprovedRelays rcvInline_ filePath_) `catchAllErrors` processError
|
||||
where
|
||||
-- TODO AChatItem in Cancelled events
|
||||
processError e
|
||||
@@ -664,7 +664,7 @@ receiveFile' user ft userApprovedRelays rcvInline_ filePath_ = do
|
||||
|
||||
receiveFileEvt' :: User -> RcvFileTransfer -> Bool -> Maybe Bool -> Maybe FilePath -> CM ChatEvent
|
||||
receiveFileEvt' user ft userApprovedRelays rcvInline_ filePath_ = do
|
||||
(CEvtRcvFileAccepted user <$> acceptFileReceive user ft userApprovedRelays rcvInline_ filePath_) `catchChatError` processError
|
||||
(CEvtRcvFileAccepted user <$> acceptFileReceive user ft userApprovedRelays rcvInline_ filePath_) `catchAllErrors` processError
|
||||
where
|
||||
-- TODO AChatItem in Cancelled events
|
||||
processError e
|
||||
@@ -788,7 +788,7 @@ receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete}
|
||||
cleanupACIFile :: AChatItem -> CM ()
|
||||
cleanupACIFile (AChatItem _ _ _ ChatItem {file = Just CIFile {fileSource = Just CryptoFile {filePath}}}) = do
|
||||
fsFilePath <- lift $ toFSFilePath filePath
|
||||
removeFile fsFilePath `catchChatError` \_ -> pure ()
|
||||
removeFile fsFilePath `catchAllErrors` \_ -> pure ()
|
||||
cleanupACIFile _ = pure ()
|
||||
|
||||
getKnownAgentServers :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> User -> CM (NonEmpty (ServerCfg p))
|
||||
@@ -1089,7 +1089,7 @@ introduceMember vr user gInfo@GroupInfo {groupId} m@GroupMember {activeConn = Ju
|
||||
forM_ (L.nonEmpty events) $ \events' ->
|
||||
sendGroupMemberMessages user conn events' groupId
|
||||
else forM_ shuffledIntros $ \intro ->
|
||||
processIntro intro `catchChatError` eToView
|
||||
processIntro intro `catchAllErrors` eToView
|
||||
memberIntro :: GroupMember -> ChatMsgEvent 'Json
|
||||
memberIntro reMember =
|
||||
let mInfo = memberInfo reMember
|
||||
@@ -1113,7 +1113,7 @@ sendHistory _ _ GroupMember {activeConn = Nothing} = throwChatError $ CEInternal
|
||||
sendHistory user gInfo@GroupInfo {groupId, membership} m@GroupMember {activeConn = Just conn} =
|
||||
when (m `supportsVersion` batchSendVersion) $ do
|
||||
(errs, items) <- partitionEithers <$> withStore' (\db -> getGroupHistoryItems db user gInfo m 100)
|
||||
(errs', events) <- partitionEithers <$> mapM (tryChatError . itemForwardEvents) items
|
||||
(errs', events) <- partitionEithers <$> mapM (tryAllErrors . itemForwardEvents) items
|
||||
let errors = map ChatErrorStore errs <> errs'
|
||||
unless (null errors) $ toView $ CEvtChatErrors errors
|
||||
let events' = concat events
|
||||
@@ -1286,7 +1286,7 @@ metaBrokerTs MsgMeta {broker = (_, brokerTs)} = brokerTs
|
||||
|
||||
createContactPQSndItem :: User -> Contact -> Connection -> PQEncryption -> CM (Contact, Connection)
|
||||
createContactPQSndItem user ct conn@Connection {pqSndEnabled} pqSndEnabled' =
|
||||
flip catchChatError (const $ pure (ct, conn)) $ case (pqSndEnabled, pqSndEnabled') of
|
||||
flip catchAllErrors (const $ pure (ct, conn)) $ case (pqSndEnabled, pqSndEnabled') of
|
||||
(Just b, b') | b' /= b -> createPQItem $ CISndConnEvent (SCEPqEnabled pqSndEnabled')
|
||||
(Nothing, PQEncOn) -> createPQItem $ CISndDirectE2EEInfo (E2EInfo $ Just pqSndEnabled')
|
||||
_ -> pure (ct, conn)
|
||||
@@ -1301,7 +1301,7 @@ createContactPQSndItem user ct conn@Connection {pqSndEnabled} pqSndEnabled' =
|
||||
|
||||
updateContactPQRcv :: User -> Contact -> Connection -> PQEncryption -> CM (Contact, Connection)
|
||||
updateContactPQRcv user ct conn@Connection {connId, pqRcvEnabled} pqRcvEnabled' =
|
||||
flip catchChatError (const $ pure (ct, conn)) $ case (pqRcvEnabled, pqRcvEnabled') of
|
||||
flip catchAllErrors (const $ pure (ct, conn)) $ case (pqRcvEnabled, pqRcvEnabled') of
|
||||
(Just b, b') | b' /= b -> updatePQ $ CIRcvConnEvent (RCEPqEnabled pqRcvEnabled')
|
||||
(Nothing, PQEncOn) -> updatePQ $ CIRcvDirectE2EEInfo (E2EInfo $ Just pqRcvEnabled')
|
||||
_ -> pure (ct, conn)
|
||||
@@ -1539,13 +1539,13 @@ appendFileChunk ft@RcvFileTransfer {fileId, fileStatus, cryptoArgs, fileInvitati
|
||||
lift $ closeFileHandle fileId rcvFiles
|
||||
forM_ cryptoArgs $ \cfArgs -> do
|
||||
tmpFile <- lift getChatTempDirectory >>= liftIO . (`uniqueCombine` fileName)
|
||||
tryChatError (liftError encryptErr $ encryptFile fsFilePath tmpFile cfArgs) >>= \case
|
||||
tryAllErrors (liftError encryptErr $ encryptFile fsFilePath tmpFile cfArgs) >>= \case
|
||||
Right () -> do
|
||||
removeFile fsFilePath `catchChatError` \_ -> pure ()
|
||||
removeFile fsFilePath `catchAllErrors` \_ -> pure ()
|
||||
renameFile tmpFile fsFilePath
|
||||
Left e -> do
|
||||
eToView e
|
||||
removeFile tmpFile `catchChatError` \_ -> pure ()
|
||||
removeFile tmpFile `catchAllErrors` \_ -> pure ()
|
||||
withStore' (`removeFileCryptoArgs` fileId)
|
||||
where
|
||||
encryptErr e = fileErr $ e <> ", received file not encrypted"
|
||||
@@ -1569,7 +1569,7 @@ isFileActive fileId files = do
|
||||
|
||||
cancelRcvFileTransfer :: User -> RcvFileTransfer -> CM (Maybe ConnId)
|
||||
cancelRcvFileTransfer user ft@RcvFileTransfer {fileId, xftpRcvFile, rcvFileInline} =
|
||||
cancel' `catchChatError` (\e -> eToView e $> fileConnId)
|
||||
cancel' `catchAllErrors` (\e -> eToView e $> fileConnId)
|
||||
where
|
||||
cancel' = do
|
||||
lift $ closeFileHandle fileId rcvFiles
|
||||
@@ -1587,13 +1587,13 @@ cancelRcvFileTransfer user ft@RcvFileTransfer {fileId, xftpRcvFile, rcvFileInlin
|
||||
cancelSndFile :: User -> FileTransferMeta -> [SndFileTransfer] -> Bool -> CM [ConnId]
|
||||
cancelSndFile user FileTransferMeta {fileId, xftpSndFile} fts sendCancel = do
|
||||
withStore' (\db -> updateFileCancelled db user fileId CIFSSndCancelled)
|
||||
`catchChatError` eToView
|
||||
`catchAllErrors` eToView
|
||||
case xftpSndFile of
|
||||
Nothing ->
|
||||
catMaybes <$> forM fts (\ft -> cancelSndFileTransfer user ft sendCancel)
|
||||
Just xsf -> do
|
||||
forM_ fts (\ft -> cancelSndFileTransfer user ft False)
|
||||
lift (agentXFTPDeleteSndFileRemote user xsf fileId) `catchChatError` eToView
|
||||
lift (agentXFTPDeleteSndFileRemote user xsf fileId) `catchAllErrors` eToView
|
||||
pure []
|
||||
|
||||
-- TODO v6.0 remove
|
||||
@@ -1601,7 +1601,7 @@ cancelSndFileTransfer :: User -> SndFileTransfer -> Bool -> CM (Maybe ConnId)
|
||||
cancelSndFileTransfer user@User {userId} ft@SndFileTransfer {fileId, connId, agentConnId = AgentConnId acId, fileStatus, fileInline} sendCancel =
|
||||
if fileStatus == FSCancelled || fileStatus == FSComplete
|
||||
then pure Nothing
|
||||
else cancel' `catchChatError` (\e -> eToView e $> fileConnId)
|
||||
else cancel' `catchAllErrors` (\e -> eToView e $> fileConnId)
|
||||
where
|
||||
cancel' = do
|
||||
withStore' $ \db -> do
|
||||
@@ -1661,7 +1661,7 @@ sendDirectContactMessages user ct events = do
|
||||
if v >= batchSend2Version
|
||||
then sendDirectContactMessages' user ct events
|
||||
else forM (L.toList events) $ \evt ->
|
||||
(Right . fst <$> sendDirectContactMessage user ct evt) `catchChatError` \e -> pure (Left e)
|
||||
(Right . fst <$> sendDirectContactMessage user ct evt) `catchAllErrors` \e -> pure (Left e)
|
||||
|
||||
sendDirectContactMessages' :: MsgEncodingI e => User -> Contact -> NonEmpty (ChatMsgEvent e) -> CM [Either ChatError SndMessage]
|
||||
sendDirectContactMessages' user ct events = do
|
||||
@@ -1856,7 +1856,7 @@ sendGroupMessages :: MsgEncodingI e => User -> GroupInfo -> Maybe GroupChatScope
|
||||
sendGroupMessages user gInfo scope members events = do
|
||||
-- TODO [knocking] send current profile to pending member after approval?
|
||||
when shouldSendProfileUpdate $
|
||||
sendProfileUpdate `catchChatError` eToView
|
||||
sendProfileUpdate `catchAllErrors` eToView
|
||||
sendGroupMessages_ user gInfo members events
|
||||
where
|
||||
User {profile = p, userMemberProfileUpdatedAt} = user
|
||||
@@ -2013,7 +2013,7 @@ memberSendAction gInfo events members m@GroupMember {memberRole, memberStatus} =
|
||||
sendGroupMemberMessage :: MsgEncodingI e => GroupInfo -> GroupMember -> ChatMsgEvent e -> Maybe Int64 -> CM () -> CM ()
|
||||
sendGroupMemberMessage gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId} chatMsgEvent introId_ postDeliver = do
|
||||
msg <- createSndMessage chatMsgEvent (GroupId groupId)
|
||||
messageMember msg `catchChatError` eToView
|
||||
messageMember msg `catchAllErrors` eToView
|
||||
where
|
||||
messageMember :: SndMessage -> CM ()
|
||||
messageMember SndMessage {msgId, msgBody} = forM_ (memberSendAction gInfo (chatMsgEvent :| []) [m] m) $ \case
|
||||
@@ -2054,7 +2054,7 @@ saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta
|
||||
rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta}
|
||||
msg <-
|
||||
withStore (\db -> createNewMessageAndRcvMsgDelivery db (GroupId groupId) newMsg sharedMsgId_ rcvMsgDelivery $ Just amGroupMemId)
|
||||
`catchChatError` \e -> case e of
|
||||
`catchAllErrors` \e -> case e of
|
||||
ChatErrorStore (SEDuplicateGroupMessage _ _ _ (Just forwardedByGroupMemberId)) -> do
|
||||
vr <- chatVersionRange
|
||||
fm <- withStore $ \db -> getGroupMember db vr user groupId forwardedByGroupMemberId
|
||||
@@ -2070,7 +2070,7 @@ saveGroupFwdRcvMsg user groupId forwardingMember refAuthorMember@GroupMember {me
|
||||
fwdMemberId = Just $ groupMemberId' forwardingMember
|
||||
refAuthorId = Just $ groupMemberId' refAuthorMember
|
||||
withStore (\db -> createNewRcvMessage db (GroupId groupId) newMsg sharedMsgId_ refAuthorId fwdMemberId)
|
||||
`catchChatError` \e -> case e of
|
||||
`catchAllErrors` \e -> case e of
|
||||
ChatErrorStore (SEDuplicateGroupMessage _ _ (Just authorGroupMemberId) Nothing) -> do
|
||||
vr <- chatVersionRange
|
||||
am@GroupMember {memberId = amMemberId} <- withStore $ \db -> getGroupMember db vr user groupId authorGroupMemberId
|
||||
@@ -2213,7 +2213,7 @@ deleteAgentConnectionAsync acId = deleteAgentConnectionAsync' acId False
|
||||
|
||||
deleteAgentConnectionAsync' :: ConnId -> Bool -> CM ()
|
||||
deleteAgentConnectionAsync' acId waitDelivery = do
|
||||
withAgent (\a -> deleteConnectionAsync a waitDelivery acId) `catchChatError` eToView
|
||||
withAgent (\a -> deleteConnectionAsync a waitDelivery acId) `catchAllErrors` eToView
|
||||
|
||||
deleteAgentConnectionsAsync :: [ConnId] -> CM ()
|
||||
deleteAgentConnectionsAsync acIds = deleteAgentConnectionsAsync' acIds False
|
||||
@@ -2222,7 +2222,7 @@ deleteAgentConnectionsAsync acIds = deleteAgentConnectionsAsync' acIds False
|
||||
deleteAgentConnectionsAsync' :: [ConnId] -> Bool -> CM ()
|
||||
deleteAgentConnectionsAsync' [] _ = pure ()
|
||||
deleteAgentConnectionsAsync' acIds waitDelivery = do
|
||||
withAgent (\a -> deleteConnectionsAsync a waitDelivery acIds) `catchChatError` eToView
|
||||
withAgent (\a -> deleteConnectionsAsync a waitDelivery acIds) `catchAllErrors` eToView
|
||||
|
||||
agentXFTPDeleteRcvFile :: RcvFileId -> FileTransferId -> CM ()
|
||||
agentXFTPDeleteRcvFile aFileId fileId = do
|
||||
@@ -2271,7 +2271,7 @@ agentXFTPDeleteSndFilesRemote user sndFiles = do
|
||||
case privateSndFileDescr of
|
||||
Nothing -> partitionSndDescr xsfs (aFileId : filesWithoutDescr) filesWithDescr
|
||||
Just sfdText ->
|
||||
tryChatError' (parseFileDescription sfdText) >>= \case
|
||||
tryAllErrors' (parseFileDescription sfdText) >>= \case
|
||||
Left _ -> partitionSndDescr xsfs (aFileId : filesWithoutDescr) filesWithDescr
|
||||
Right sfd -> partitionSndDescr xsfs filesWithoutDescr ((aFileId, sfd) : filesWithDescr)
|
||||
|
||||
|
||||
@@ -103,7 +103,7 @@ processAgentMessage corrId connId msg = do
|
||||
vr <- chatVersionRange
|
||||
-- getUserByAConnId never throws logical errors, only SEDBBusyError can be thrown here
|
||||
critical (withStore' (`getUserByAConnId` AgentConnId connId)) >>= \case
|
||||
Just user -> processAgentMessageConn vr user corrId connId msg `catchChatError` eToView
|
||||
Just user -> processAgentMessageConn vr user corrId connId msg `catchAllErrors` eToView
|
||||
_ -> throwChatError $ CENoConnectionUser (AgentConnId connId)
|
||||
|
||||
-- CRITICAL error will be shown to the user as alert with restart button in Android/desktop apps.
|
||||
@@ -115,7 +115,7 @@ processAgentMessage corrId connId msg = do
|
||||
-- Full app restart is likely to resolve database condition and the message will be received and processed again.
|
||||
critical :: CM a -> CM a
|
||||
critical a =
|
||||
a `catchChatError` \case
|
||||
a `catchAllErrors` \case
|
||||
ChatErrorStore SEDBBusyError {message} -> throwError $ ChatErrorAgent (CRITICAL True message) Nothing
|
||||
e -> throwError e
|
||||
|
||||
@@ -156,7 +156,7 @@ processAgentMsgSndFile _corrId aFileId msg = do
|
||||
(cRef_, fileId) <- withStore (`getXFTPSndFileDBIds` AgentSndFileId aFileId)
|
||||
withEntityLock_ cRef_ . withFileLock "processAgentMsgSndFile" fileId $
|
||||
withStore' (`getUserByASndFileId` AgentSndFileId aFileId) >>= \case
|
||||
Just user -> process user fileId `catchChatError` eToView
|
||||
Just user -> process user fileId `catchAllErrors` eToView
|
||||
_ -> do
|
||||
lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId)
|
||||
throwChatError $ CENoSndFileUser $ AgentSndFileId aFileId
|
||||
@@ -298,7 +298,7 @@ processAgentMsgRcvFile _corrId aFileId msg = do
|
||||
(cRef_, fileId) <- withStore (`getXFTPRcvFileDBIds` AgentRcvFileId aFileId)
|
||||
withEntityLock_ cRef_ . withFileLock "processAgentMsgRcvFile" fileId $
|
||||
withStore' (`getUserByARcvFileId` AgentRcvFileId aFileId) >>= \case
|
||||
Just user -> process user fileId `catchChatError` eToView
|
||||
Just user -> process user fileId `catchAllErrors` eToView
|
||||
_ -> do
|
||||
lift $ withAgent' (`xftpDeleteRcvFile` aFileId)
|
||||
throwChatError $ CENoRcvFileUser $ AgentRcvFileId aFileId
|
||||
@@ -472,10 +472,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
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 ()
|
||||
checkIntegrityCreateItem (CDDirectRcv ct') msgMeta `catchAllErrors` \_ -> pure ()
|
||||
forM_ aChatMsgs $ \case
|
||||
Right (ACMsg _ chatMsg) ->
|
||||
processEvent ct' conn' tags eInfo chatMsg `catchChatError` \e -> eToView e
|
||||
processEvent ct' conn' tags eInfo chatMsg `catchAllErrors` \e -> eToView e
|
||||
Left e -> do
|
||||
atomically $ modifyTVar' tags ("error" :)
|
||||
logInfo $ "contact msg=error " <> eInfo <> " " <> tshow e
|
||||
@@ -537,7 +537,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
|
||||
allowAgentConnectionAsync user conn'' confId XOk
|
||||
XInfo profile -> do
|
||||
ct' <- processContactProfileUpdate ct profile False `catchChatError` const (pure ct)
|
||||
ct' <- processContactProfileUpdate ct profile False `catchAllErrors` const (pure ct)
|
||||
-- [incognito] send incognito profile
|
||||
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore $ \db -> getProfileById db userId profileId
|
||||
let p = userProfileDirect user (fromLocalProfile <$> incognitoProfile) (Just ct') True
|
||||
@@ -897,12 +897,12 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
withAckMessage "group msg" agentConnId msgMeta True (Just tags) $ \eInfo -> do
|
||||
-- possible improvement is to choose scope based on event (some events specify scope)
|
||||
(gInfo', m', scopeInfo) <- mkGroupChatScope gInfo m
|
||||
checkIntegrityCreateItem (CDGroupRcv gInfo' scopeInfo m') msgMeta `catchChatError` \_ -> pure ()
|
||||
checkIntegrityCreateItem (CDGroupRcv gInfo' scopeInfo m') msgMeta `catchAllErrors` \_ -> pure ()
|
||||
(fwdScopesMsgs, shouldDelConns) <- foldM (processAChatMsg gInfo' m' tags eInfo) (M.empty, False) aChatMsgs
|
||||
when (isUserGrpFwdRelay gInfo') $ do
|
||||
unless (blockedByAdmin m) $
|
||||
forM_ (M.assocs fwdScopesMsgs) $ \(groupForwardScope, fwdMsgs) ->
|
||||
forwardMsgs groupForwardScope (L.reverse fwdMsgs) `catchChatError` eToView
|
||||
forwardMsgs groupForwardScope (L.reverse fwdMsgs) `catchAllErrors` eToView
|
||||
when shouldDelConns $ deleteGroupConnections gInfo' True
|
||||
withRcpt <- checkSendRcpt $ rights aChatMsgs
|
||||
pure (withRcpt, shouldDelConns)
|
||||
@@ -920,7 +920,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
processAChatMsg gInfo' m' tags eInfo (fwdScopeMap, shouldDelConns) = \case
|
||||
Right (ACMsg SJson chatMsg) -> do
|
||||
(cmFwdScope_, cmShouldDelConns) <-
|
||||
processEvent gInfo' m' tags eInfo chatMsg `catchChatError` \e -> eToView e $> (Nothing, False)
|
||||
processEvent gInfo' m' tags eInfo chatMsg `catchAllErrors` \e -> eToView e $> (Nothing, False)
|
||||
let fwdScopeMap' =
|
||||
case cmFwdScope_ of
|
||||
Nothing -> fwdScopeMap
|
||||
@@ -928,7 +928,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
shouldDelConns' = shouldDelConns || cmShouldDelConns
|
||||
pure (fwdScopeMap', shouldDelConns')
|
||||
Right (ACMsg SBinary chatMsg) -> do
|
||||
void (processEvent gInfo' m' tags eInfo chatMsg) `catchChatError` \e -> eToView e
|
||||
void (processEvent gInfo' m' tags eInfo chatMsg) `catchAllErrors` \e -> eToView e
|
||||
pure (fwdScopeMap, shouldDelConns)
|
||||
Left e -> do
|
||||
atomically $ modifyTVar' tags ("error" :)
|
||||
@@ -1559,7 +1559,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
-- 3) show screen of death to the user asking to restart
|
||||
eInfo <- eventInfo
|
||||
logInfo $ label <> ": " <> eInfo
|
||||
tryChatError (action eInfo) >>= \case
|
||||
tryAllErrors (action eInfo) >>= \case
|
||||
Right (withRcpt, shouldDelConns) ->
|
||||
unless shouldDelConns $ 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
|
||||
@@ -1666,7 +1666,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
|
||||
sendProbeHashes :: [ContactOrMember] -> Probe -> Int64 -> CM ()
|
||||
sendProbeHashes cgms probe probeId =
|
||||
forM_ cgms $ \cgm -> sendProbeHash cgm `catchChatError` \_ -> pure ()
|
||||
forM_ cgms $ \cgm -> sendProbeHash cgm `catchAllErrors` \_ -> pure ()
|
||||
where
|
||||
probeHash = ProbeHash $ C.sha256Hash (unProbe probe)
|
||||
sendProbeHash :: ContactOrMember -> CM ()
|
||||
@@ -1738,7 +1738,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
-- in processFDMessage some paths are programmed as errors,
|
||||
-- for example failure on not approved relays (CEFileNotApproved).
|
||||
-- we catch error, so that even if processFDMessage fails, message can still be forwarded.
|
||||
processFDMessage fileId aci fileDescr `catchChatError` \_ -> pure ()
|
||||
processFDMessage fileId aci fileDescr `catchAllErrors` \_ -> pure ()
|
||||
pure $ Just $ toGroupForwardScope g scopeInfo
|
||||
else
|
||||
messageError "x.msg.file.descr: file of another member" $> Nothing
|
||||
@@ -1900,7 +1900,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
|
||||
catchCINotFound :: CM a -> (SharedMsgId -> CM a) -> CM a
|
||||
catchCINotFound f handle =
|
||||
f `catchChatError` \case
|
||||
f `catchAllErrors` \case
|
||||
ChatErrorStore (SEChatItemSharedMsgIdNotFound sharedMsgId) -> handle sharedMsgId
|
||||
e -> throwError e
|
||||
|
||||
@@ -2497,7 +2497,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
probeMatches :: [ContactOrMember] -> ContactOrMember -> CM ()
|
||||
probeMatches [] _ = pure ()
|
||||
probeMatches (cgm1' : cgm1s') cgm2' = do
|
||||
cgm2''_ <- probeMatch cgm1' cgm2' probe `catchChatError` \_ -> pure (Just cgm2')
|
||||
cgm2''_ <- probeMatch cgm1' cgm2' probe `catchAllErrors` \_ -> pure (Just cgm2')
|
||||
let cgm2'' = fromMaybe cgm2' cgm2''_
|
||||
probeMatches cgm1s' cgm2''
|
||||
|
||||
@@ -3225,7 +3225,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
|
||||
directMsgReceived :: Contact -> Connection -> MsgMeta -> NonEmpty MsgReceipt -> CM ()
|
||||
directMsgReceived ct conn@Connection {connId} msgMeta msgRcpts = do
|
||||
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta `catchChatError` \_ -> pure ()
|
||||
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta `catchAllErrors` \_ -> pure ()
|
||||
forM_ msgRcpts $ \MsgReceipt {agentMsgId, msgRcptStatus} -> do
|
||||
withStore' $ \db -> updateSndMsgDeliveryStatus db connId agentMsgId $ MDSSndRcvd msgRcptStatus
|
||||
updateDirectItemStatus ct conn agentMsgId $ CISSndRcvd msgRcptStatus SSPComplete
|
||||
@@ -3233,7 +3233,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
groupMsgReceived :: GroupInfo -> GroupMember -> Connection -> MsgMeta -> NonEmpty MsgReceipt -> CM ()
|
||||
groupMsgReceived gInfo m conn@Connection {connId} msgMeta msgRcpts = do
|
||||
(gInfo', m', scopeInfo) <- mkGroupChatScope gInfo m
|
||||
checkIntegrityCreateItem (CDGroupRcv gInfo' scopeInfo m') msgMeta `catchChatError` \_ -> pure ()
|
||||
checkIntegrityCreateItem (CDGroupRcv gInfo' scopeInfo m') msgMeta `catchAllErrors` \_ -> pure ()
|
||||
forM_ msgRcpts $ \MsgReceipt {agentMsgId, msgRcptStatus} -> do
|
||||
withStore' $ \db -> updateSndMsgDeliveryStatus db connId agentMsgId $ MDSSndRcvd msgRcptStatus
|
||||
updateGroupItemsStatus gInfo' m' conn agentMsgId (GSSRcvd msgRcptStatus) Nothing
|
||||
|
||||
Reference in new issue
Block a user