From f6c699f3a56ec60fda3be048308ccaeccd6636cd Mon Sep 17 00:00:00 2001 From: Evgeny Date: Fri, 29 Aug 2025 10:05:20 +0100 Subject: [PATCH] core: update simplexmq (error handling) (#6231) * core: update simplexmq (error handling) * update simplexmq --- cabal.project | 2 +- scripts/nix/sha256map.nix | 2 +- src/Simplex/Chat/Archive.hs | 2 +- src/Simplex/Chat/Controller.hs | 46 +++------------ src/Simplex/Chat/Library/Commands.hs | 80 +++++++++++++------------- src/Simplex/Chat/Library/Internal.hs | 48 ++++++++-------- src/Simplex/Chat/Library/Subscriber.hs | 36 ++++++------ src/Simplex/Chat/Remote.hs | 26 +++------ src/Simplex/Chat/Remote/Types.hs | 4 ++ src/Simplex/Chat/Store/Shared.hs | 5 ++ 10 files changed, 110 insertions(+), 141 deletions(-) diff --git a/cabal.project b/cabal.project index 07a0b427e8..6618c088c5 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: a2d777bda0af2a7ee7cd68952eaf7c86329427ad + tag: beafac1f73f7d61b99c79d609731f94a05ced97f source-repository-package type: git diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index 6558a66e31..25784e181c 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -1,5 +1,5 @@ { - "https://github.com/simplex-chat/simplexmq.git"."a2d777bda0af2a7ee7cd68952eaf7c86329427ad" = "04h8vdxf732jwsim2fcrql47gsmv680lgg2kylgmfk4al0pnpkdk"; + "https://github.com/simplex-chat/simplexmq.git"."beafac1f73f7d61b99c79d609731f94a05ced97f" = "11f1d0h5n7lkwsjz1csyxkrrcxqsyf2rv7339qcfbpdmqhq6k3ni"; "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/src/Simplex/Chat/Archive.hs b/src/Simplex/Chat/Archive.hs index 2cbc941b44..b54c23959b 100644 --- a/src/Simplex/Chat/Archive.hs +++ b/src/Simplex/Chat/Archive.hs @@ -158,7 +158,7 @@ sqlCipherExport DBEncryptionConfig {currentKey = DBEncryptionKey key, newKey = D -- closing after encryption prevents closing in case wrong encryption key was passed liftIO $ closeDBStore `withStores` fs (moveExported `withStores` fs) - `catchChatError` \e -> (restore `withDBs` fs) >> throwError e + `catchAllErrors` \e -> (restore `withDBs` fs) >> throwError e where backup f = copyFile f (f <> ".bak") restore f = copyFile (f <> ".bak") f diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 53d3839f42..919274f4d2 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -19,7 +19,7 @@ module Simplex.Chat.Controller where import Control.Concurrent (ThreadId) import Control.Concurrent.Async (Async) -import Control.Exception (Exception, SomeException) +import Control.Exception (Exception) import qualified Control.Exception as E import Control.Monad.Except import Control.Monad.IO.Unlift @@ -88,7 +88,7 @@ import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType (..), Msg import Simplex.Messaging.TMap (TMap) import Simplex.Messaging.Transport (TLS, TransportPeer (..), simplexMQVersion) import Simplex.Messaging.Transport.Client (SocksProxyWithAuth, TransportHost) -import Simplex.Messaging.Util (allFinally, catchAllErrors, catchAllErrors', tryAllErrors, tryAllErrors', (<$$>)) +import Simplex.Messaging.Util (AnyError (..), catchAllErrors, (<$$>)) import Simplex.RemoteControl.Client import Simplex.RemoteControl.Invitation (RCSignedInvitation, RCVerifiedInvitation) import Simplex.RemoteControl.Types @@ -1419,6 +1419,10 @@ data ArchiveError | AEFileError {file :: String, fileError :: String} deriving (Show, Exception) +instance AnyError ChatError where + fromSomeException = ChatError . CEException . show + {-# INLINE fromSomeException #-} + -- | Host (mobile) side of transport to process remote commands and forward notifications data RemoteCtrlSession = RCSessionStarting @@ -1505,46 +1509,10 @@ setContactNetworkStatus :: Contact -> NetworkStatus -> CM' () setContactNetworkStatus Contact {activeConn = Nothing} _ = pure () setContactNetworkStatus Contact {activeConn = Just Connection {agentConnId}} status = chatModifyVar' connNetworkStatuses $ M.insert agentConnId status -tryChatError :: CM a -> CM (Either ChatError a) -tryChatError = tryAllErrors mkChatError -{-# INLINE tryChatError #-} - -tryChatError' :: CM a -> CM' (Either ChatError a) -tryChatError' = tryAllErrors' mkChatError -{-# INLINE tryChatError' #-} - -catchChatError :: CM a -> (ChatError -> CM a) -> CM a -catchChatError = catchAllErrors mkChatError -{-# INLINE catchChatError #-} - -catchChatError' :: CM a -> (ChatError -> CM' a) -> CM' a -catchChatError' = catchAllErrors' mkChatError -{-# INLINE catchChatError' #-} - -chatFinally :: CM a -> CM b -> CM a -chatFinally = allFinally mkChatError -{-# INLINE chatFinally #-} - onChatError :: CM a -> CM b -> CM a -a `onChatError` onErr = a `catchChatError` \e -> onErr >> throwError e +a `onChatError` onErr = a `catchAllErrors` \e -> onErr >> throwError e {-# INLINE onChatError #-} -mkChatError :: SomeException -> ChatError -mkChatError = ChatError . CEException . show -{-# INLINE mkChatError #-} - -catchStoreError :: ExceptT StoreError IO a -> (StoreError -> ExceptT StoreError IO a) -> ExceptT StoreError IO a -catchStoreError = catchAllErrors mkStoreError -{-# INLINE catchStoreError #-} - -tryStoreError' :: ExceptT StoreError IO a -> IO (Either StoreError a) -tryStoreError' = tryAllErrors' mkStoreError -{-# INLINE tryStoreError' #-} - -mkStoreError :: SomeException -> StoreError -mkStoreError = SEInternalError . show -{-# INLINE mkStoreError #-} - throwCmdError :: String -> CM a throwCmdError = throwError . ChatError . CECommandError {-# INLINE throwCmdError #-} diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 4ae58d8a29..b6b7dbe87c 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -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 diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index 413a36f567..e3885a3c9a 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -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) diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index 3517f76152..3109fd5fe9 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -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 diff --git a/src/Simplex/Chat/Remote.hs b/src/Simplex/Chat/Remote.hs index 7c25890bf2..3e5e25e430 100644 --- a/src/Simplex/Chat/Remote.hs +++ b/src/Simplex/Chat/Remote.hs @@ -175,13 +175,13 @@ startRemoteHost rh_ rcAddrPrefs_ port_ = do pure hostInfo handleConnectError :: RHKey -> SessionSeq -> CM a -> CM a handleConnectError rhKey sessSeq action = - action `catchChatError` \err -> do + action `catchAllErrors` \err -> do logError $ "startRemoteHost.rcConnectHost crashed: " <> tshow err cancelRemoteHostSession (Just (sessSeq, RHSRConnectionFailed err)) rhKey throwError err handleHostError :: SessionSeq -> TVar RHKey -> CM () -> CM () handleHostError sessSeq rhKeyVar action = - action `catchChatError` \err -> do + action `catchAllErrors` \err -> do logError $ "startRemoteHost.waitForHostSession crashed: " <> tshow err readTVarIO rhKeyVar >>= cancelRemoteHostSession (Just (sessSeq, RHSRCrashed err)) waitForHostSession :: Maybe RemoteHostInfo -> RHKey -> SessionSeq -> Maybe RCCtrlAddress -> TVar RHKey -> RCStepTMVar (ByteString, TLS 'TServer, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> CM () @@ -411,7 +411,7 @@ findKnownRemoteCtrl = do atomically $ takeTMVar cmdOk (RCCtrlPairing {ctrlFingerprint}, inv@(RCVerifiedInvitation RCInvitation {app})) <- timeoutThrow (ChatErrorRemoteCtrl RCETimeout) discoveryTimeout . withAgent $ \a -> rcDiscoverCtrl a pairings - ctrlAppInfo_ <- (Just <$> parseCtrlAppInfo app) `catchChatError` const (pure Nothing) + ctrlAppInfo_ <- (Just <$> parseCtrlAppInfo app) `catchAllErrors` const (pure Nothing) rc <- withStore' (`getRemoteCtrlByFingerprint` ctrlFingerprint) >>= \case Nothing -> throwChatError $ CEInternalError "connecting with a stored ctrl" @@ -500,11 +500,11 @@ parseCtrlAppInfo ctrlAppInfo = do handleRemoteCommand :: (ByteString -> Int -> CM' (Either ChatError ChatResponse)) -> RemoteCrypto -> TBQueue (Either ChatError ChatEvent) -> HTTP2Request -> CM' () handleRemoteCommand execCC encryption remoteOutputQ HTTP2Request {request, reqBody, sendResponse} = do logDebug "handleRemoteCommand" - liftIO (tryRemoteError' parseRequest) >>= \case + liftIO (tryAllErrors' parseRequest) >>= \case Right (rfKN, getNext, rc) -> do chatReadVar' currentUser >>= \case Nothing -> replyError $ ChatError CENoActiveUser - Just user -> processCommand user rfKN getNext rc `catchChatError'` replyError + Just user -> processCommand user rfKN getNext rc `catchAllErrors'` replyError Left e -> reply $ RRProtocolError e where parseRequest :: ExceptT RemoteProtocolError IO (C.SbKeyNonce, GetChunk, RemoteCommand) @@ -523,7 +523,7 @@ handleRemoteCommand execCC encryption remoteOutputQ HTTP2Request {request, reqBo replyWith :: Respond replyWith rr attach = do (corrId, cmdKN, sfKN) <- atomically $ getRemoteSndKeys encryption - liftIO (tryRemoteError' . encryptEncodeHTTP2Body corrId cmdKN encryption $ J.encode rr) >>= \case + liftIO (tryAllErrors' . encryptEncodeHTTP2Body corrId cmdKN encryption $ J.encode rr) >>= \case Right resp -> liftIO . sendResponse . responseStreaming N.status200 [] $ \send flush -> do send resp attach sfKN send @@ -542,14 +542,6 @@ type Respond = RemoteResponse -> (C.SbKeyNonce -> SendChunk -> IO ()) -> CM' () liftRC :: ExceptT RemoteProtocolError IO a -> CM a liftRC = liftError (ChatErrorRemoteCtrl . RCEProtocolError) -tryRemoteError :: ExceptT RemoteProtocolError IO a -> ExceptT RemoteProtocolError IO (Either RemoteProtocolError a) -tryRemoteError = tryAllErrors (RPEException . tshow) -{-# INLINE tryRemoteError #-} - -tryRemoteError' :: ExceptT RemoteProtocolError IO a -> IO (Either RemoteProtocolError a) -tryRemoteError' = tryAllErrors' (RPEException . tshow) -{-# INLINE tryRemoteError' #-} - handleSend :: (ByteString -> Int -> CM' (Either ChatError ChatResponse)) -> Text -> Int -> CM' RemoteResponse handleSend execCC command retryNum = do logDebug $ "Send: " <> tshow command @@ -573,7 +565,7 @@ handleStoreFile rfKN fileName fileSize fileDigest getChunk = Just ff -> takeFileName <$$> storeFileTo ff Nothing -> storeFileTo =<< getDefaultFilesFolder storeFileTo :: FilePath -> CM' (Either RemoteProtocolError FilePath) - storeFileTo dir = liftIO . tryRemoteError' $ do + storeFileTo dir = liftIO . tryAllErrors' $ do filePath <- liftIO $ dir `uniqueCombine` fileName receiveEncryptedFile rfKN getChunk fileSize fileDigest filePath pure filePath @@ -586,7 +578,7 @@ handleGetFile User {userId} RemoteFile {userId = commandUserId, fileId, sent, fi withStore $ \db -> do cf <- getLocalCryptoFile db commandUserId fileId sent unless (cf == cf') $ throwError $ SEFileNotFound fileId - liftRC (tryRemoteError $ getFileInfo path) >>= \case + liftRC (tryAllErrors $ getFileInfo path) >>= \case Left e -> lift $ reply (RRProtocolError e) $ \_ _ -> pure () Right (fileSize, fileDigest) -> lift . withFile path ReadMode $ \h -> do @@ -658,7 +650,7 @@ stopRemoteCtrl = cancelActiveRemoteCtrl Nothing handleCtrlError :: SessionSeq -> (ChatError -> RemoteCtrlStopReason) -> Text -> CM a -> CM a handleCtrlError sseq mkReason name action = - action `catchChatError` \e -> do + action `catchAllErrors` \e -> do logError $ name <> " remote ctrl error: " <> tshow e cancelActiveRemoteCtrl $ Just (sseq, mkReason e) throwError e diff --git a/src/Simplex/Chat/Remote/Types.hs b/src/Simplex/Chat/Remote/Types.hs index defbe7e72c..b7af624e9e 100644 --- a/src/Simplex/Chat/Remote/Types.hs +++ b/src/Simplex/Chat/Remote/Types.hs @@ -28,6 +28,7 @@ import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON import Simplex.Messaging.Transport (TLS (..), TSbChainKeys (..), TransportPeer (..)) import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client) import qualified Simplex.Messaging.TMap as TM +import Simplex.Messaging.Util (AnyError (..), tshow) import Simplex.RemoteControl.Client import Simplex.RemoteControl.Types @@ -155,6 +156,9 @@ data RemoteProtocolError | RPEException {someException :: Text} deriving (Show, Exception) +instance AnyError RemoteProtocolError where + fromSomeException = RPEException . tshow + type RemoteHostId = Int64 data RHKey = RHNew | RHId {remoteHostId :: RemoteHostId} diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs index 1caf034f2a..745f1b4b9a 100644 --- a/src/Simplex/Chat/Store/Shared.hs +++ b/src/Simplex/Chat/Store/Shared.hs @@ -46,6 +46,7 @@ import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..)) import qualified Simplex.Messaging.Crypto.Ratchet as CR import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON) import Simplex.Messaging.Protocol (SubscriptionMode (..)) +import Simplex.Messaging.Util (AnyError (..)) import Simplex.Messaging.Version import UnliftIO.STM #if defined(dbPostgres) @@ -149,6 +150,10 @@ data StoreError | SEInvalidMention deriving (Show, Exception) +instance AnyError StoreError where + fromSomeException = SEInternalError . show + {-# INLINE fromSomeException #-} + $(J.deriveJSON (sumTypeJSON $ dropPrefix "SE") ''StoreError) insertedRowId :: DB.Connection -> IO Int64