IntenseFinance/simplex-chat
3
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

core: catch IO exceptions in ExceptT (#2669)

Browse Source 
* core: catch IO exceptions in ExceptT

* catch IO exceptions for ACK

* simplify, remove unnecessary changes

* fix, update simplexmq

* update simplexmq, enable all tests

* fix

* update simplexmq (fix finally)

* update sha256map.nix
This commit is contained in:
Evgeny Poberezkin 2023-07-09 23:24:38 +01:00 committed by GitHub
parent e24564d7d6
commit 7a8db16791
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
9 changed files with 106 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
cabal.project
View File

@ -7,7 +7,7 @@ constraints: zip +disable-bzip2 +disable-zstd
source-repository-package source-repository-package
type: git type: git
location: https://github.com/simplex-chat/simplexmq.git location: https://github.com/simplex-chat/simplexmq.git
tag: f2657f9c0b954f952aaf381bb9b55ac34ea59ed7 tag: 532cd2f39c7c22da19a47424eaefa7eafb0aeff8
source-repository-package source-repository-package
type: git type: git

2
scripts/nix/sha256map.nix
View File

@ -1,5 +1,5 @@
{ {
"https://github.com/simplex-chat/simplexmq.git"."f2657f9c0b954f952aaf381bb9b55ac34ea59ed7" = "04qhadd0shs4hj5b62i78jhnq5c620b72naqavqirvjc7pymyq5g"; "https://github.com/simplex-chat/simplexmq.git"."532cd2f39c7c22da19a47424eaefa7eafb0aeff8" = "0qqx0pjxbjjxqg27403nvf4db6yb2qc73mhlk77mqipq7x3h6hjp";
"https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38"; "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
"https://github.com/kazu-yamamoto/http2.git"."b5a1b7200cf5bc7044af34ba325284271f6dff25" = "0dqb50j57an64nf4qcf5vcz4xkd1vzvghvf8bk529c1k30r9nfzb"; "https://github.com/kazu-yamamoto/http2.git"."b5a1b7200cf5bc7044af34ba325284271f6dff25" = "0dqb50j57an64nf4qcf5vcz4xkd1vzvghvf8bk529c1k30r9nfzb";
"https://github.com/simplex-chat/direct-sqlcipher.git"."34309410eb2069b029b8fc1872deb1e0db123294" = "0kwkmhyfsn2lixdlgl15smgr1h5gjk7fky6abzh8rng2h5ymnffd"; "https://github.com/simplex-chat/direct-sqlcipher.git"."34309410eb2069b029b8fc1872deb1e0db123294" = "0kwkmhyfsn2lixdlgl15smgr1h5gjk7fky6abzh8rng2h5ymnffd";

137
src/Simplex/Chat.hs
View File

@ -16,6 +16,7 @@ module Simplex.Chat where
import Control.Applicative (optional, (<|>)) import Control.Applicative (optional, (<|>))
import Control.Concurrent.STM (retry, stateTVar) import Control.Concurrent.STM (retry, stateTVar)
import qualified Control.Exception as E
import Control.Logger.Simple import Control.Logger.Simple
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.IO.Unlift import Control.Monad.IO.Unlift
@ -89,14 +90,14 @@ import Simplex.Messaging.Transport.Client (defaultSocksProxy)
import Simplex.Messaging.Util import Simplex.Messaging.Util
import System.Exit (exitFailure, exitSuccess) import System.Exit (exitFailure, exitSuccess)
import System.FilePath (combine, splitExtensions, takeFileName, (</>)) import System.FilePath (combine, splitExtensions, takeFileName, (</>))
import System.IO (Handle, IOMode (..), SeekMode (..), hFlush, openFile, stdout) import System.IO (Handle, IOMode (..), SeekMode (..), hFlush, stdout)
import System.Random (randomRIO) import System.Random (randomRIO)
import Text.Read (readMaybe) import Text.Read (readMaybe)
import UnliftIO.Async import UnliftIO.Async
import UnliftIO.Concurrent (forkFinally, forkIO, mkWeakThreadId, threadDelay) import UnliftIO.Concurrent (forkFinally, forkIO, mkWeakThreadId, threadDelay)
import UnliftIO.Directory import UnliftIO.Directory
import qualified UnliftIO.Exception as E import qualified UnliftIO.Exception as UE
import UnliftIO.IO (hClose, hSeek, hTell) import UnliftIO.IO (hClose, hSeek, hTell, openFile)
import UnliftIO.STM import UnliftIO.STM
defaultChatConfig :: ChatConfig defaultChatConfig :: ChatConfig
@ -288,11 +289,11 @@ startFilesToReceive users = do
startReceive :: [User] -> m () startReceive :: [User] -> m ()
startReceive = mapM_ $ runExceptT . startReceiveUserFiles startReceive = mapM_ $ runExceptT . startReceiveUserFiles
startReceiveUserFiles :: forall m. ChatMonad m => User -> m () startReceiveUserFiles :: ChatMonad m => User -> m ()
startReceiveUserFiles user = do startReceiveUserFiles user = do
filesToReceive <- withStoreCtx' (Just "startReceiveUserFiles, getRcvFilesToReceive") (`getRcvFilesToReceive` user) filesToReceive <- withStoreCtx' (Just "startReceiveUserFiles, getRcvFilesToReceive") (`getRcvFilesToReceive` user)
forM_ filesToReceive $ \ft -> forM_ filesToReceive $ \ft ->
flip catchError (toView . CRChatError (Just user)) $ flip catchChatError (toView . CRChatError (Just user)) $
toView =<< receiveFile' user ft Nothing Nothing toView =<< receiveFile' user ft Nothing Nothing
restoreCalls :: ChatMonad' m => m () restoreCalls :: ChatMonad' m => m ()
@ -590,7 +591,7 @@ processChatCommand = \case
sendGroupFileInline :: [GroupMember] -> SharedMsgId -> FileTransferMeta -> m () sendGroupFileInline :: [GroupMember] -> SharedMsgId -> FileTransferMeta -> m ()
sendGroupFileInline ms sharedMsgId ft@FileTransferMeta {fileInline} = sendGroupFileInline ms sharedMsgId ft@FileTransferMeta {fileInline} =
when (fileInline == Just IFMSent) . forM_ ms $ \m -> when (fileInline == Just IFMSent) . forM_ ms $ \m ->
processMember m `catchError` (toView . CRChatError (Just user)) processMember m `catchChatError` (toView . CRChatError (Just user))
where where
processMember m@GroupMember {activeConn = Just conn@Connection {connStatus}} = processMember m@GroupMember {activeConn = Just conn@Connection {connStatus}} =
when (connStatus == ConnReady || connStatus == ConnSndReady) $ do when (connStatus == ConnReady || connStatus == ConnSndReady) $ do
@ -653,7 +654,7 @@ processChatCommand = \case
let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus = CIFSSndStored, fileProtocol = FPXFTP} let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus = CIFSSndStored, fileProtocol = FPXFTP}
case contactOrGroup of case contactOrGroup of
CGContact Contact {activeConn} -> withStore' $ \db -> createSndFTDescrXFTP db user Nothing activeConn ft fileDescr CGContact Contact {activeConn} -> withStore' $ \db -> createSndFTDescrXFTP db user Nothing activeConn ft fileDescr
CGGroup (Group _ ms) -> forM_ ms $ \m -> saveMemberFD m `catchError` (toView . CRChatError (Just user)) CGGroup (Group _ ms) -> forM_ ms $ \m -> saveMemberFD m `catchChatError` (toView . CRChatError (Just user))
where where
-- we are not sending files to pending members, same as with inline files -- we are not sending files to pending members, same as with inline files
saveMemberFD m@GroupMember {activeConn = Just conn@Connection {connStatus}} = saveMemberFD m@GroupMember {activeConn = Just conn@Connection {connStatus}} =
@ -870,7 +871,7 @@ processChatCommand = \case
deleteUnusedContact :: ContactId -> m [ConnId] deleteUnusedContact :: ContactId -> m [ConnId]
deleteUnusedContact contactId = deleteUnusedContact contactId =
(withStore (\db -> getContact db user contactId) >>= delete) (withStore (\db -> getContact db user contactId) >>= delete)
`catchError` (\e -> toView (CRChatError (Just user) e) $> []) `catchChatError` (\e -> toView (CRChatError (Just user) e) $> [])
where where
delete ct delete ct
| directOrUsed ct = pure [] | directOrUsed ct = pure []
@ -880,7 +881,7 @@ processChatCommand = \case
Nothing -> do Nothing -> do
conns <- withStore $ \db -> getContactConnections db userId ct conns <- withStore $ \db -> getContactConnections db userId ct
withStore' (\db -> setContactDeleted db user ct) withStore' (\db -> setContactDeleted db user ct)
`catchError` (toView . CRChatError (Just user)) `catchChatError` (toView . CRChatError (Just user))
pure $ map aConnId conns pure $ map aConnId conns
CTContactRequest -> pure $ chatCmdError (Just user) "not supported" CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
APIClearChat (ChatRef cType chatId) -> withUser $ \user -> case cType of APIClearChat (ChatRef cType chatId) -> withUser $ \user -> case cType of
@ -911,7 +912,7 @@ processChatCommand = \case
cReq@UserContactRequest {agentContactConnId = AgentConnId connId, agentInvitationId = AgentInvId invId} <- cReq@UserContactRequest {agentContactConnId = AgentConnId connId, agentInvitationId = AgentInvId invId} <-
withStore $ \db -> withStore $ \db ->
getContactRequest db user connReqId getContactRequest db user connReqId
`E.finally` liftIO (deleteContactRequest db user connReqId) `storeFinally` liftIO (deleteContactRequest db user connReqId)
withAgent $ \a -> rejectContact a connId invId withAgent $ \a -> rejectContact a connId invId
pure $ CRContactRequestRejected user cReq pure $ CRContactRequestRejected user cReq
APISendCallInvitation contactId callType -> withUser $ \user -> do APISendCallInvitation contactId callType -> withUser $ \user -> do
@ -1032,7 +1033,7 @@ processChatCommand = \case
user_ <- withStore' (`getUserByAConnId` agentConnId) user_ <- withStore' (`getUserByAConnId` agentConnId)
connEntity <- connEntity <-
pure user_ $>>= \user -> pure user_ $>>= \user ->
withStore (\db -> Just <$> getConnectionEntity db user agentConnId) `catchError` (\e -> toView (CRChatError (Just user) e) $> Nothing) withStore (\db -> Just <$> getConnectionEntity db user agentConnId) `catchChatError` (\e -> toView (CRChatError (Just user) e) $> Nothing)
pure CRNtfMessages {user_, connEntity, msgTs = msgTs', ntfMessages} pure CRNtfMessages {user_, connEntity, msgTs = msgTs', ntfMessages}
APIGetUserProtoServers userId (AProtocolType p) -> withUserId userId $ \user -> withServerProtocol p $ do APIGetUserProtoServers userId (AProtocolType p) -> withUserId userId $ \user -> withServerProtocol p $ do
ChatConfig {defaultServers} <- asks config ChatConfig {defaultServers} <- asks config
@ -1099,7 +1100,7 @@ processChatCommand = \case
liftIO $ updateGroupSettings db user chatId chatSettings liftIO $ updateGroupSettings db user chatId chatSettings
pure ms pure ms
forM_ (filter memberActive ms) $ \m -> forM_ (memberConnId m) $ \connId -> forM_ (filter memberActive ms) $ \m -> forM_ (memberConnId m) $ \connId ->
withAgent (\a -> toggleConnectionNtfs a connId $ enableNtfs chatSettings) `catchError` (toView . CRChatError (Just user)) withAgent (\a -> toggleConnectionNtfs a connId $ enableNtfs chatSettings) `catchChatError` (toView . CRChatError (Just user))
ok user ok user
_ -> pure $ chatCmdError (Just user) "not supported" _ -> pure $ chatCmdError (Just user) "not supported"
APIContactInfo contactId -> withUser $ \user@User {userId} -> do APIContactInfo contactId -> withUser $ \user@User {userId} -> do
@ -1307,7 +1308,7 @@ processChatCommand = \case
where where
mc = MCText msg mc = MCText msg
sendAndCount user ll (s, f) ct = sendAndCount user ll (s, f) ct =
(sendToContact user ct $> (s + 1, f)) `catchError` \e -> when (ll <= CLLInfo) (toView $ CRChatError (Just user) e) $> (s, f + 1) (sendToContact user ct $> (s + 1, f)) `catchChatError` \e -> when (ll <= CLLInfo) (toView $ CRChatError (Just user) e) $> (s, f + 1)
sendToContact user ct = do sendToContact user ct = do
(sndMsg, _) <- sendDirectContactMessage ct (XMsgNew $ MCSimple (extMsgContent mc Nothing)) (sndMsg, _) <- sendDirectContactMessage ct (XMsgNew $ MCSimple (extMsgContent mc Nothing))
void $ saveSndChatItem user (CDDirectSnd ct) sndMsg (CISndMsgContent mc) void $ saveSndChatItem user (CDDirectSnd ct) sndMsg (CISndMsgContent mc)
@ -1607,7 +1608,7 @@ processChatCommand = \case
Just XFTPRcvFile {agentRcvFileId} -> do Just XFTPRcvFile {agentRcvFileId} -> do
forM_ (liveRcvFileTransferPath ftr) $ \filePath -> do forM_ (liveRcvFileTransferPath ftr) $ \filePath -> do
fsFilePath <- toFSFilePath filePath fsFilePath <- toFSFilePath filePath
removeFile fsFilePath `E.catch` \(_ :: E.SomeException) -> pure () liftIO $ removeFile fsFilePath `catchAll_` pure ()
forM_ agentRcvFileId $ \(AgentRcvFileId aFileId) -> forM_ agentRcvFileId $ \(AgentRcvFileId aFileId) ->
withAgent (`xftpDeleteRcvFile` aFileId) withAgent (`xftpDeleteRcvFile` aFileId)
ci <- withStore $ \db -> do ci <- withStore $ \db -> do
@ -1683,7 +1684,7 @@ processChatCommand = \case
-- corrId <- liftIO $ SMP.CorrId <$> randomBytes gVar 8 -- corrId <- liftIO $ SMP.CorrId <$> randomBytes gVar 8
-- void . forkIO $ -- void . forkIO $
-- withAgentLock a . withLock l name $ -- withAgentLock a . withLock l name $
-- (atomically . writeTBQueue q) . (Just corrId,) =<< (action `catchError` (pure . CRChatError)) -- (atomically . writeTBQueue q) . (Just corrId,) =<< (action `catchChatError` (pure . CRChatError))
-- pure $ CRCmdAccepted corrId -- pure $ CRCmdAccepted corrId
-- use function below to make commands "synchronous" -- use function below to make commands "synchronous"
procCmd :: m ChatResponse -> m ChatResponse procCmd :: m ChatResponse -> m ChatResponse
@ -1797,7 +1798,7 @@ processChatCommand = \case
(successes, failures) <- foldM (processAndCount user' logLevel) (0, 0) contacts (successes, failures) <- foldM (processAndCount user' logLevel) (0, 0) contacts
pure $ CRUserProfileUpdated user' (fromLocalProfile p) p' successes failures pure $ CRUserProfileUpdated user' (fromLocalProfile p) p' successes failures
where where
processAndCount user' ll (s, f) ct = (processContact user' ct $> (s + 1, f)) `catchError` \e -> when (ll <= CLLInfo) (toView $ CRChatError (Just user) e) $> (s, f + 1) processAndCount user' ll (s, f) ct = (processContact user' ct $> (s + 1, f)) `catchChatError` \e -> when (ll <= CLLInfo) (toView $ CRChatError (Just user) e) $> (s, f + 1)
processContact user' ct = do processContact user' ct = do
let mergedProfile = userProfileToSend user Nothing $ Just ct let mergedProfile = userProfileToSend user Nothing $ Just ct
ct' = updateMergedPreferences user' ct ct' = updateMergedPreferences user' ct
@ -1816,7 +1817,7 @@ processChatCommand = \case
mergedProfile' = userProfileToSend user (fromLocalProfile <$> incognitoProfile) (Just ct') mergedProfile' = userProfileToSend user (fromLocalProfile <$> incognitoProfile) (Just ct')
when (mergedProfile' /= mergedProfile) $ when (mergedProfile' /= mergedProfile) $
withChatLock "updateProfile" $ do withChatLock "updateProfile" $ do
void (sendDirectContactMessage ct' $ XInfo mergedProfile') `catchError` (toView . CRChatError (Just user)) void (sendDirectContactMessage ct' $ XInfo mergedProfile') `catchChatError` (toView . CRChatError (Just user))
when (directOrUsed ct') $ createSndFeatureItems user ct ct' when (directOrUsed ct') $ createSndFeatureItems user ct ct'
pure $ CRContactPrefsUpdated user ct ct' pure $ CRContactPrefsUpdated user ct ct'
runUpdateGroupProfile :: User -> Group -> GroupProfile -> m ChatResponse runUpdateGroupProfile :: User -> Group -> GroupProfile -> m ChatResponse
@ -1996,7 +1997,7 @@ startExpireCIThread user@User {userId} = do
liftIO $ threadDelay' delay liftIO $ threadDelay' delay
interval <- asks $ ciExpirationInterval . config interval <- asks $ ciExpirationInterval . config
forever $ do forever $ do
flip catchError (toView . CRChatError (Just user)) $ do flip catchChatError (toView . CRChatError (Just user)) $ do
expireFlags <- asks expireCIFlags expireFlags <- asks expireCIFlags
atomically $ TM.lookup userId expireFlags >>= \b -> unless (b == Just True) retry atomically $ TM.lookup userId expireFlags >>= \b -> unless (b == Just True) retry
ttl <- withStoreCtx' (Just "startExpireCIThread, getChatItemTTL") (`getChatItemTTL` user) ttl <- withStoreCtx' (Just "startExpireCIThread, getChatItemTTL") (`getChatItemTTL` user)
@ -2015,26 +2016,26 @@ setAllExpireCIFlags b = do
keys <- M.keys <$> readTVar expireFlags keys <- M.keys <$> readTVar expireFlags
forM_ keys $ \k -> TM.insert k b expireFlags forM_ keys $ \k -> TM.insert k b expireFlags
deleteFilesAndConns :: forall m. ChatMonad m => User -> [CIFileInfo] -> m () deleteFilesAndConns :: ChatMonad m => User -> [CIFileInfo] -> m ()
deleteFilesAndConns user filesInfo = do deleteFilesAndConns user filesInfo = do
connIds <- mapM (deleteFile user) filesInfo connIds <- mapM (deleteFile user) filesInfo
deleteAgentConnectionsAsync user $ concat connIds deleteAgentConnectionsAsync user $ concat connIds
deleteFile :: forall m. ChatMonad m => User -> CIFileInfo -> m [ConnId] deleteFile :: ChatMonad m => User -> CIFileInfo -> m [ConnId]
deleteFile user fileInfo = deleteFile' user fileInfo False deleteFile user fileInfo = deleteFile' user fileInfo False
deleteFile' :: forall m. ChatMonad m => User -> CIFileInfo -> Bool -> m [ConnId] deleteFile' :: forall m. ChatMonad m => User -> CIFileInfo -> Bool -> m [ConnId]
deleteFile' user ciFileInfo@CIFileInfo {filePath} sendCancel = do deleteFile' user ciFileInfo@CIFileInfo {filePath} sendCancel = do
aConnIds <- cancelFile' user ciFileInfo sendCancel aConnIds <- cancelFile' user ciFileInfo sendCancel
delete `catchError` (toView . CRChatError (Just user)) delete `catchChatError` (toView . CRChatError (Just user))
pure aConnIds pure aConnIds
where where
delete :: m () delete :: m ()
delete = withFilesFolder $ \filesFolder -> delete = withFilesFolder $ \filesFolder ->
forM_ filePath $ \fPath -> do liftIO . forM_ filePath $ \fPath -> do
let fsFilePath = filesFolder </> fPath let fsFilePath = filesFolder </> fPath
removeFile fsFilePath `E.catch` \(_ :: E.SomeException) -> removeFile fsFilePath `catchAll` \_ ->
removePathForcibly fsFilePath `E.catch` \(_ :: E.SomeException) -> pure () removePathForcibly fsFilePath `catchAll_` pure ()
-- perform an action only if filesFolder is set (i.e. on mobile devices) -- perform an action only if filesFolder is set (i.e. on mobile devices)
withFilesFolder :: (FilePath -> m ()) -> m () withFilesFolder :: (FilePath -> m ()) -> m ()
withFilesFolder action = asks filesFolder >>= readTVarIO >>= mapM_ action withFilesFolder action = asks filesFolder >>= readTVarIO >>= mapM_ action
@ -2042,7 +2043,7 @@ deleteFile' user ciFileInfo@CIFileInfo {filePath} sendCancel = do
cancelFile' :: forall m. ChatMonad m => User -> CIFileInfo -> Bool -> m [ConnId] cancelFile' :: forall m. ChatMonad m => User -> CIFileInfo -> Bool -> m [ConnId]
cancelFile' user CIFileInfo {fileId, fileStatus} sendCancel = cancelFile' user CIFileInfo {fileId, fileStatus} sendCancel =
case fileStatus of case fileStatus of
Just fStatus -> cancel' fStatus `catchError` (\e -> toView (CRChatError (Just user) e) $> []) Just fStatus -> cancel' fStatus `catchChatError` (\e -> toView (CRChatError (Just user) e) $> [])
Nothing -> pure [] Nothing -> pure []
where where
cancel' :: ACIFileStatus -> m [ConnId] cancel' :: ACIFileStatus -> m [ConnId]
@ -2099,13 +2100,13 @@ callStatusItemContent user Contact {contactId} chatItemId receivedStatus = do
-- mobile clients use file paths relative to app directory (e.g. for the reason ios app directory changes on updates), -- mobile clients use file paths relative to app directory (e.g. for the reason ios app directory changes on updates),
-- so we have to differentiate between the file path stored in db and communicated with frontend, and the file path -- so we have to differentiate between the file path stored in db and communicated with frontend, and the file path
-- used during file transfer for actual operations with file system -- used during file transfer for actual operations with file system
toFSFilePath :: ChatMonad m => FilePath -> m FilePath toFSFilePath :: ChatMonad' m => FilePath -> m FilePath
toFSFilePath f = toFSFilePath f =
maybe f (</> f) <$> (readTVarIO =<< asks filesFolder) maybe f (</> f) <$> (readTVarIO =<< asks filesFolder)
receiveFile' :: ChatMonad m => User -> RcvFileTransfer -> Maybe Bool -> Maybe FilePath -> m ChatResponse receiveFile' :: ChatMonad m => User -> RcvFileTransfer -> Maybe Bool -> Maybe FilePath -> m ChatResponse
receiveFile' user ft rcvInline_ filePath_ = do receiveFile' user ft rcvInline_ filePath_ = do
(CRRcvFileAccepted user <$> acceptFileReceive user ft rcvInline_ filePath_) `catchError` processError (CRRcvFileAccepted user <$> acceptFileReceive user ft rcvInline_ filePath_) `catchChatError` processError
where where
processError = \case processError = \case
-- TODO AChatItem in Cancelled events -- TODO AChatItem in Cancelled events
@ -2215,7 +2216,7 @@ getRcvFilePath fileId fPath_ fn keepHandle = case fPath_ of
(createEmptyFile fPath) (createEmptyFile fPath)
where where
createEmptyFile :: FilePath -> m FilePath createEmptyFile :: FilePath -> m FilePath
createEmptyFile fPath = emptyFile fPath `E.catch` (throwChatError . CEFileWrite fPath . (show :: E.SomeException -> String)) createEmptyFile fPath = emptyFile fPath `catchThrow` (ChatError . CEFileWrite fPath . show)
emptyFile :: FilePath -> m FilePath emptyFile :: FilePath -> m FilePath
emptyFile fPath = do emptyFile fPath = do
h <- h <-
@ -2225,8 +2226,7 @@ getRcvFilePath fileId fPath_ fn keepHandle = case fPath_ of
liftIO $ B.hPut h "" >> hFlush h liftIO $ B.hPut h "" >> hFlush h
pure fPath pure fPath
getTmpHandle :: FilePath -> m Handle getTmpHandle :: FilePath -> m Handle
getTmpHandle fPath = getTmpHandle fPath = openFile fPath AppendMode `catchThrow` (ChatError . CEFileInternal . show)
liftIO (openFile fPath AppendMode) `E.catch` (throwChatError . CEFileInternal . (show :: E.SomeException -> String))
uniqueCombine :: FilePath -> String -> m FilePath uniqueCombine :: FilePath -> String -> m FilePath
uniqueCombine filePath fileName = tryCombine (0 :: Int) uniqueCombine filePath fileName = tryCombine (0 :: Int)
where where
@ -2288,7 +2288,7 @@ agentSubscriber = do
where where
run action = do run action = do
let name = "agentSubscriber entity=" <> show e <> " entId=" <> str entId <> " msg=" <> str (aCommandTag msg) let name = "agentSubscriber entity=" <> show e <> " entId=" <> str entId <> " msg=" <> str (aCommandTag msg)
withLock l name $ runExceptT $ action `catchError` (toView . CRChatError Nothing) withLock l name $ runExceptT $ action `catchChatError` (toView . CRChatError Nothing)
str :: StrEncoding a => a -> String str :: StrEncoding a => a -> String
str = B.unpack . strEncode str = B.unpack . strEncode
@ -2393,7 +2393,7 @@ subscribeUserConnections agentBatchSubscribe user@User {userId} = do
pendingConnSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId PendingContactConnection -> m () pendingConnSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId PendingContactConnection -> m ()
pendingConnSubsToView rs = toView . CRPendingSubSummary user . map (uncurry PendingSubStatus) . resultsFor rs pendingConnSubsToView rs = toView . CRPendingSubSummary user . map (uncurry PendingSubStatus) . resultsFor rs
withStore_ :: String -> (DB.Connection -> User -> IO [a]) -> m [a] withStore_ :: String -> (DB.Connection -> User -> IO [a]) -> m [a]
withStore_ ctx a = withStoreCtx' (Just ctx) (`a` user) `catchError` \e -> toView (CRChatError (Just user) e) $> [] withStore_ ctx a = withStoreCtx' (Just ctx) (`a` user) `catchChatError` \e -> toView (CRChatError (Just user) e) $> []
filterErrors :: [(a, Maybe ChatError)] -> [(a, ChatError)] filterErrors :: [(a, Maybe ChatError)] -> [(a, ChatError)]
filterErrors = mapMaybe (\(a, e_) -> (a,) <$> e_) filterErrors = mapMaybe (\(a, e_) -> (a,) <$> e_)
resultsFor :: Map ConnId (Either AgentErrorType ()) -> Map ConnId a -> [(a, Maybe ChatError)] resultsFor :: Map ConnId (Either AgentErrorType ()) -> Map ConnId a -> [(a, Maybe ChatError)]
@ -2415,36 +2415,36 @@ cleanupManager = do
liftIO $ threadDelay' initialDelay liftIO $ threadDelay' initialDelay
stepDelay <- asks (cleanupManagerStepDelay . config) stepDelay <- asks (cleanupManagerStepDelay . config)
forever $ do forever $ do
flip catchError (toView . CRChatError Nothing) $ do flip catchChatError (toView . CRChatError Nothing) $ do
waitChatStarted waitChatStarted
users <- withStoreCtx' (Just "cleanupManager, getUsers 1") getUsers users <- withStoreCtx' (Just "cleanupManager, getUsers 1") getUsers
let (us, us') = partition activeUser users let (us, us') = partition activeUser users
forM_ us $ cleanupUser interval stepDelay forM_ us $ cleanupUser interval stepDelay
forM_ us' $ cleanupUser interval stepDelay forM_ us' $ cleanupUser interval stepDelay
cleanupMessages `catchError` (toView . CRChatError Nothing) cleanupMessages `catchChatError` (toView . CRChatError Nothing)
liftIO $ threadDelay' $ diffToMicroseconds interval liftIO $ threadDelay' $ diffToMicroseconds interval
where where
runWithoutInitialDelay cleanupInterval = flip catchError (toView . CRChatError Nothing) $ do runWithoutInitialDelay cleanupInterval = flip catchChatError (toView . CRChatError Nothing) $ do
waitChatStarted waitChatStarted
users <- withStoreCtx' (Just "cleanupManager, getUsers 2") getUsers users <- withStoreCtx' (Just "cleanupManager, getUsers 2") getUsers
let (us, us') = partition activeUser users let (us, us') = partition activeUser users
forM_ us $ \u -> cleanupTimedItems cleanupInterval u `catchError` (toView . CRChatError (Just u)) forM_ us $ \u -> cleanupTimedItems cleanupInterval u `catchChatError` (toView . CRChatError (Just u))
forM_ us' $ \u -> cleanupTimedItems cleanupInterval u `catchError` (toView . CRChatError (Just u)) forM_ us' $ \u -> cleanupTimedItems cleanupInterval u `catchChatError` (toView . CRChatError (Just u))
cleanupUser cleanupInterval stepDelay user = do cleanupUser cleanupInterval stepDelay user = do
cleanupTimedItems cleanupInterval user `catchError` (toView . CRChatError (Just user)) cleanupTimedItems cleanupInterval user `catchChatError` (toView . CRChatError (Just user))
liftIO $ threadDelay' stepDelay liftIO $ threadDelay' stepDelay
cleanupDeletedContacts user `catchError` (toView . CRChatError (Just user)) cleanupDeletedContacts user `catchChatError` (toView . CRChatError (Just user))
liftIO $ threadDelay' stepDelay liftIO $ threadDelay' stepDelay
cleanupTimedItems cleanupInterval user = do cleanupTimedItems cleanupInterval user = do
ts <- liftIO getCurrentTime ts <- liftIO getCurrentTime
let startTimedThreadCutoff = addUTCTime cleanupInterval ts let startTimedThreadCutoff = addUTCTime cleanupInterval ts
timedItems <- withStoreCtx' (Just "cleanupManager, getTimedItems") $ \db -> getTimedItems db user startTimedThreadCutoff timedItems <- withStoreCtx' (Just "cleanupManager, getTimedItems") $ \db -> getTimedItems db user startTimedThreadCutoff
forM_ timedItems $ \(itemRef, deleteAt) -> startTimedItemThread user itemRef deleteAt `catchError` const (pure ()) forM_ timedItems $ \(itemRef, deleteAt) -> startTimedItemThread user itemRef deleteAt `catchChatError` const (pure ())
cleanupDeletedContacts user = do cleanupDeletedContacts user = do
contacts <- withStore' (`getDeletedContacts` user) contacts <- withStore' (`getDeletedContacts` user)
forM_ contacts $ \ct -> forM_ contacts $ \ct ->
withStore' (\db -> deleteContactWithoutGroups db user ct) withStore' (\db -> deleteContactWithoutGroups db user ct)
`catchError` (toView . CRChatError (Just user)) `catchChatError` (toView . CRChatError (Just user))
cleanupMessages = do cleanupMessages = do
ts <- liftIO getCurrentTime ts <- liftIO getCurrentTime
let cutoffTs = addUTCTime (- (30 * nominalDay)) ts let cutoffTs = addUTCTime (- (30 * nominalDay)) ts
@ -2508,7 +2508,7 @@ expireChatItems user@User {userId} ttl sync = do
loop :: [a] -> (a -> m ()) -> m () loop :: [a] -> (a -> m ()) -> m ()
loop [] _ = pure () loop [] _ = pure ()
loop (a : as) process = continue $ do loop (a : as) process = continue $ do
process a `catchError` (toView . CRChatError (Just user)) process a `catchChatError` (toView . CRChatError (Just user))
loop as process loop as process
continue :: m () -> m () continue :: m () -> m ()
continue a = continue a =
@ -2538,7 +2538,7 @@ processAgentMessage _ connId DEL_CONN =
toView $ CRAgentConnDeleted (AgentConnId connId) toView $ CRAgentConnDeleted (AgentConnId connId)
processAgentMessage corrId connId msg = processAgentMessage corrId connId msg =
withStore' (`getUserByAConnId` AgentConnId connId) >>= \case withStore' (`getUserByAConnId` AgentConnId connId) >>= \case
Just user -> processAgentMessageConn user corrId connId msg `catchError` (toView . CRChatError (Just user)) Just user -> processAgentMessageConn user corrId connId msg `catchChatError` (toView . CRChatError (Just user))
_ -> throwChatError $ CENoConnectionUser (AgentConnId connId) _ -> throwChatError $ CENoConnectionUser (AgentConnId connId)
processAgentMessageNoConn :: forall m. ChatMonad m => ACommand 'Agent 'AENone -> m () processAgentMessageNoConn :: forall m. ChatMonad m => ACommand 'Agent 'AENone -> m ()
@ -2560,7 +2560,7 @@ processAgentMessageNoConn = \case
processAgentMsgSndFile :: forall m. ChatMonad m => ACorrId -> SndFileId -> ACommand 'Agent 'AESndFile -> m () processAgentMsgSndFile :: forall m. ChatMonad m => ACorrId -> SndFileId -> ACommand 'Agent 'AESndFile -> m ()
processAgentMsgSndFile _corrId aFileId msg = processAgentMsgSndFile _corrId aFileId msg =
withStore' (`getUserByASndFileId` AgentSndFileId aFileId) >>= \case withStore' (`getUserByASndFileId` AgentSndFileId aFileId) >>= \case
Just user -> process user `catchError` (toView . CRChatError (Just user)) Just user -> process user `catchChatError` (toView . CRChatError (Just user))
_ -> do _ -> do
withAgent (`xftpDeleteSndFileInternal` aFileId) withAgent (`xftpDeleteSndFileInternal` aFileId)
throwChatError $ CENoSndFileUser $ AgentSndFileId aFileId throwChatError $ CENoSndFileUser $ AgentSndFileId aFileId
@ -2597,7 +2597,7 @@ processAgentMsgSndFile _corrId aFileId msg =
let rfdsMemberFTs = zip rfds $ memberFTs ms let rfdsMemberFTs = zip rfds $ memberFTs ms
extraRFDs = drop (length rfdsMemberFTs) rfds extraRFDs = drop (length rfdsMemberFTs) rfds
withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText extraRFDs) withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText extraRFDs)
forM_ rfdsMemberFTs $ \mt -> sendToMember mt `catchError` (toView . CRChatError (Just user)) forM_ rfdsMemberFTs $ \mt -> sendToMember mt `catchChatError` (toView . CRChatError (Just user))
ci' <- withStore $ \db -> do ci' <- withStore $ \db -> do
liftIO $ updateCIFileStatus db user fileId CIFSSndComplete liftIO $ updateCIFileStatus db user fileId CIFSSndComplete
getChatItemByFileId db user fileId getChatItemByFileId db user fileId
@ -2649,7 +2649,7 @@ processAgentMsgSndFile _corrId aFileId msg =
processAgentMsgRcvFile :: forall m. ChatMonad m => ACorrId -> RcvFileId -> ACommand 'Agent 'AERcvFile -> m () processAgentMsgRcvFile :: forall m. ChatMonad m => ACorrId -> RcvFileId -> ACommand 'Agent 'AERcvFile -> m ()
processAgentMsgRcvFile _corrId aFileId msg = processAgentMsgRcvFile _corrId aFileId msg =
withStore' (`getUserByARcvFileId` AgentRcvFileId aFileId) >>= \case withStore' (`getUserByARcvFileId` AgentRcvFileId aFileId) >>= \case
Just user -> process user `catchError` (toView . CRChatError (Just user)) Just user -> process user `catchChatError` (toView . CRChatError (Just user))
_ -> do _ -> do
withAgent (`xftpDeleteRcvFile` aFileId) withAgent (`xftpDeleteRcvFile` aFileId)
throwChatError $ CENoRcvFileUser $ AgentRcvFileId aFileId throwChatError $ CENoRcvFileUser $ AgentRcvFileId aFileId
@ -3004,7 +3004,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
intros <- withStore' $ \db -> createIntroductions db members m intros <- withStore' $ \db -> createIntroductions db members m
void . sendGroupMessage user gInfo members . XGrpMemNew $ memberInfo m void . sendGroupMessage user gInfo members . XGrpMemNew $ memberInfo m
forM_ intros $ \intro -> forM_ intros $ \intro ->
processIntro intro `catchError` (toView . CRChatError (Just user)) processIntro intro `catchChatError` (toView . CRChatError (Just user))
where where
processIntro intro@GroupMemberIntro {introId} = do processIntro intro@GroupMemberIntro {introId} = do
void $ sendDirectMessage conn (XGrpMemIntro . memberInfo $ reMember intro) (GroupId groupId) void $ sendDirectMessage conn (XGrpMemIntro . memberInfo $ reMember intro) (GroupId groupId)
@ -3337,9 +3337,9 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
withStore' $ \db -> createCommand db user (Just connId) CFAckMessage withStore' $ \db -> createCommand db user (Just connId) CFAckMessage
withAckMessage :: ConnId -> CommandId -> MsgMeta -> m () -> m () withAckMessage :: ConnId -> CommandId -> MsgMeta -> m () -> m ()
withAckMessage cId cmdId MsgMeta {recipient = (msgId, _)} action = withAckMessage cId cmdId MsgMeta {recipient = (msgId, _)} action = do
-- [async agent commands] command should be asynchronous, continuation is ackMsgDeliveryEvent -- [async agent commands] command should be asynchronous, continuation is ackMsgDeliveryEvent
action `E.finally` withAgent (\a -> ackMessageAsync a (aCorrId cmdId) cId msgId) action `chatFinally` withAgent (\a -> ackMessageAsync a (aCorrId cmdId) cId msgId)
ackMsgDeliveryEvent :: Connection -> CommandId -> m () ackMsgDeliveryEvent :: Connection -> CommandId -> m ()
ackMsgDeliveryEvent Connection {connId} ackCmdId = ackMsgDeliveryEvent Connection {connId} ackCmdId =
@ -3391,7 +3391,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
else do else do
cs <- withStore' $ \db -> getMatchingContacts db user ct cs <- withStore' $ \db -> getMatchingContacts db user ct
let probeHash = ProbeHash $ C.sha256Hash (unProbe probe) let probeHash = ProbeHash $ C.sha256Hash (unProbe probe)
forM_ cs $ \c -> sendProbeHash c probeHash probeId `catchError` const (pure ()) forM_ cs $ \c -> sendProbeHash c probeHash probeId `catchChatError` \_ -> pure ()
where where
sendProbeHash :: Contact -> ProbeHash -> Int64 -> m () sendProbeHash :: Contact -> ProbeHash -> Int64 -> m ()
sendProbeHash c probeHash probeId = do sendProbeHash c probeHash probeId = do
@ -3409,6 +3409,12 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
let ExtMsgContent content fInv_ _ _ = mcExtMsgContent mc let ExtMsgContent content fInv_ _ _ = mcExtMsgContent mc
-- Uncomment to test stuck delivery on errors - see test testDirectMessageDelete
-- case content of
-- MCText "hello 111" ->
-- UE.throwIO $ userError "#####################"
-- -- throwChatError $ CECommandError "#####################"
-- _ -> pure ()
if isVoice content && not (featureAllowed SCFVoice forContact ct) if isVoice content && not (featureAllowed SCFVoice forContact ct)
then do then do
void $ newChatItem (CIRcvChatFeatureRejected CFVoice) Nothing Nothing False void $ newChatItem (CIRcvChatFeatureRejected CFVoice) Nothing Nothing False
@ -3580,7 +3586,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
catchCINotFound :: m a -> (SharedMsgId -> m a) -> m a catchCINotFound :: m a -> (SharedMsgId -> m a) -> m a
catchCINotFound f handle = catchCINotFound f handle =
f `catchError` \case f `catchChatError` \case
ChatErrorStore (SEChatItemSharedMsgIdNotFound sharedMsgId) -> handle sharedMsgId ChatErrorStore (SEChatItemSharedMsgIdNotFound sharedMsgId) -> handle sharedMsgId
e -> throwError e e -> throwError e
@ -4316,7 +4322,7 @@ sendFileChunkNo ft@SndFileTransfer {agentConnId = AgentConnId acId} chunkNo = do
readFileChunk :: ChatMonad m => SndFileTransfer -> Integer -> m ByteString readFileChunk :: ChatMonad m => SndFileTransfer -> Integer -> m ByteString
readFileChunk SndFileTransfer {fileId, filePath, chunkSize} chunkNo = do readFileChunk SndFileTransfer {fileId, filePath, chunkSize} chunkNo = do
fsFilePath <- toFSFilePath filePath fsFilePath <- toFSFilePath filePath
read_ fsFilePath `E.catch` (throwChatError . CEFileRead filePath . (show :: E.SomeException -> String)) read_ fsFilePath `catchThrow` (ChatError . CEFileRead filePath . show)
where where
read_ fsFilePath = do read_ fsFilePath = do
h <- getFileHandle fileId fsFilePath sndFiles ReadMode h <- getFileHandle fileId fsFilePath sndFiles ReadMode
@ -4341,9 +4347,8 @@ appendFileChunk ft@RcvFileTransfer {fileId, fileStatus} chunkNo chunk =
append_ filePath = do append_ filePath = do
fsFilePath <- toFSFilePath filePath fsFilePath <- toFSFilePath filePath
h <- getFileHandle fileId fsFilePath rcvFiles AppendMode h <- getFileHandle fileId fsFilePath rcvFiles AppendMode
E.try (liftIO $ B.hPut h chunk >> hFlush h) >>= \case liftIO (B.hPut h chunk >> hFlush h) `catchThrow` (ChatError . CEFileWrite filePath . show)
Left (e :: E.SomeException) -> throwChatError . CEFileWrite fsFilePath $ show e withStore' $ \db -> updatedRcvFileChunkStored db ft chunkNo
Right () -> withStore' $ \db -> updatedRcvFileChunkStored db ft chunkNo
getFileHandle :: ChatMonad m => Int64 -> FilePath -> (ChatController -> TVar (Map Int64 Handle)) -> IOMode -> m Handle getFileHandle :: ChatMonad m => Int64 -> FilePath -> (ChatController -> TVar (Map Int64 Handle)) -> IOMode -> m Handle
getFileHandle fileId filePath files ioMode = do getFileHandle fileId filePath files ioMode = do
@ -4352,7 +4357,7 @@ getFileHandle fileId filePath files ioMode = do
maybe (newHandle fs) pure h_ maybe (newHandle fs) pure h_
where where
newHandle fs = do newHandle fs = do
h <- liftIO (openFile filePath ioMode) `E.catch` (throwChatError . CEFileInternal . (show :: E.SomeException -> String)) h <- openFile filePath ioMode `catchThrow` (ChatError . CEFileInternal . show)
atomically . modifyTVar fs $ M.insert fileId h atomically . modifyTVar fs $ M.insert fileId h
pure h pure h
@ -4363,7 +4368,7 @@ isFileActive fileId files = do
cancelRcvFileTransfer :: ChatMonad m => User -> RcvFileTransfer -> m (Maybe ConnId) cancelRcvFileTransfer :: ChatMonad m => User -> RcvFileTransfer -> m (Maybe ConnId)
cancelRcvFileTransfer user ft@RcvFileTransfer {fileId, xftpRcvFile, rcvFileInline} = cancelRcvFileTransfer user ft@RcvFileTransfer {fileId, xftpRcvFile, rcvFileInline} =
cancel' `catchError` (\e -> toView (CRChatError (Just user) e) $> fileConnId) cancel' `catchChatError` (\e -> toView (CRChatError (Just user) e) $> fileConnId)
where where
cancel' = do cancel' = do
closeFileHandle fileId rcvFiles closeFileHandle fileId rcvFiles
@ -4381,20 +4386,20 @@ cancelRcvFileTransfer user ft@RcvFileTransfer {fileId, xftpRcvFile, rcvFileInlin
cancelSndFile :: ChatMonad m => User -> FileTransferMeta -> [SndFileTransfer] -> Bool -> m [ConnId] cancelSndFile :: ChatMonad m => User -> FileTransferMeta -> [SndFileTransfer] -> Bool -> m [ConnId]
cancelSndFile user FileTransferMeta {fileId, xftpSndFile} fts sendCancel = do cancelSndFile user FileTransferMeta {fileId, xftpSndFile} fts sendCancel = do
withStore' (\db -> updateFileCancelled db user fileId CIFSSndCancelled) withStore' (\db -> updateFileCancelled db user fileId CIFSSndCancelled)
`catchError` (toView . CRChatError (Just user)) `catchChatError` (toView . CRChatError (Just user))
case xftpSndFile of case xftpSndFile of
Nothing -> Nothing ->
catMaybes <$> forM fts (\ft -> cancelSndFileTransfer user ft sendCancel) catMaybes <$> forM fts (\ft -> cancelSndFileTransfer user ft sendCancel)
Just xsf -> do Just xsf -> do
forM_ fts (\ft -> cancelSndFileTransfer user ft False) forM_ fts (\ft -> cancelSndFileTransfer user ft False)
agentXFTPDeleteSndFileRemote user xsf fileId `catchError` (toView . CRChatError (Just user)) agentXFTPDeleteSndFileRemote user xsf fileId `catchChatError` (toView . CRChatError (Just user))
pure [] pure []
cancelSndFileTransfer :: ChatMonad m => User -> SndFileTransfer -> Bool -> m (Maybe ConnId) cancelSndFileTransfer :: ChatMonad m => User -> SndFileTransfer -> Bool -> m (Maybe ConnId)
cancelSndFileTransfer user@User {userId} ft@SndFileTransfer {fileId, connId, agentConnId = AgentConnId acId, fileStatus, fileInline} sendCancel = cancelSndFileTransfer user@User {userId} ft@SndFileTransfer {fileId, connId, agentConnId = AgentConnId acId, fileStatus, fileInline} sendCancel =
if fileStatus == FSCancelled || fileStatus == FSComplete if fileStatus == FSCancelled || fileStatus == FSComplete
then pure Nothing then pure Nothing
else cancel' `catchError` (\e -> toView (CRChatError (Just user) e) $> fileConnId) else cancel' `catchChatError` (\e -> toView (CRChatError (Just user) e) $> fileConnId)
where where
cancel' = do cancel' = do
withStore' $ \db -> do withStore' $ \db -> do
@ -4412,7 +4417,7 @@ closeFileHandle :: ChatMonad m => Int64 -> (ChatController -> TVar (Map Int64 Ha
closeFileHandle fileId files = do closeFileHandle fileId files = do
fs <- asks files fs <- asks files
h_ <- atomically . stateTVar fs $ \m -> (M.lookup fileId m, M.delete fileId m) h_ <- atomically . stateTVar fs $ \m -> (M.lookup fileId m, M.delete fileId m)
mapM_ hClose h_ `E.catch` \(_ :: E.SomeException) -> pure () liftIO $ mapM_ hClose h_ `catchAll_` pure ()
throwChatError :: ChatMonad m => ChatErrorType -> m a throwChatError :: ChatMonad m => ChatErrorType -> m a
throwChatError = throwError . ChatError throwChatError = throwError . ChatError
@ -4478,7 +4483,7 @@ sendGroupMessage' user members chatMsgEvent groupId introId_ postDeliver = do
msg <- createSndMessage chatMsgEvent (GroupId groupId) msg <- createSndMessage chatMsgEvent (GroupId groupId)
-- TODO collect failed deliveries into a single error -- TODO collect failed deliveries into a single error
forM_ (filter memberCurrent members) $ \m -> forM_ (filter memberCurrent members) $ \m ->
messageMember m msg `catchError` (toView . CRChatError (Just user)) messageMember m msg `catchChatError` (toView . CRChatError (Just user))
pure msg pure msg
where where
messageMember m@GroupMember {groupMemberId} SndMessage {msgId, msgBody} = case memberConn m of messageMember m@GroupMember {groupMemberId} SndMessage {msgId, msgBody} = case memberConn m of
@ -4495,7 +4500,7 @@ sendPendingGroupMessages user GroupMember {groupMemberId, localDisplayName} conn
pendingMessages <- withStore' $ \db -> getPendingGroupMessages db groupMemberId pendingMessages <- withStore' $ \db -> getPendingGroupMessages db groupMemberId
-- TODO ensure order - pending messages interleave with user input messages -- TODO ensure order - pending messages interleave with user input messages
forM_ pendingMessages $ \pgm -> forM_ pendingMessages $ \pgm ->
processPendingMessage pgm `catchError` (toView . CRChatError (Just user)) processPendingMessage pgm `catchChatError` (toView . CRChatError (Just user))
where where
processPendingMessage PendingGroupMessage {msgId, cmEventTag = ACMEventTag _ tag, msgBody, introId_} = do processPendingMessage PendingGroupMessage {msgId, cmEventTag = ACMEventTag _ tag, msgBody, introId_} = do
void $ deliverMessage conn tag msgBody msgId void $ deliverMessage conn tag msgBody msgId
@ -4625,12 +4630,12 @@ agentAcceptContactAsync user enableNtfs invId msg = do
deleteAgentConnectionAsync :: ChatMonad m => User -> ConnId -> m () deleteAgentConnectionAsync :: ChatMonad m => User -> ConnId -> m ()
deleteAgentConnectionAsync user acId = deleteAgentConnectionAsync user acId =
withAgent (`deleteConnectionAsync` acId) `catchError` (toView . CRChatError (Just user)) withAgent (`deleteConnectionAsync` acId) `catchChatError` (toView . CRChatError (Just user))
deleteAgentConnectionsAsync :: ChatMonad m => User -> [ConnId] -> m () deleteAgentConnectionsAsync :: ChatMonad m => User -> [ConnId] -> m ()
deleteAgentConnectionsAsync _ [] = pure () deleteAgentConnectionsAsync _ [] = pure ()
deleteAgentConnectionsAsync user acIds = deleteAgentConnectionsAsync user acIds =
withAgent (`deleteConnectionsAsync` acIds) `catchError` (toView . CRChatError (Just user)) withAgent (`deleteConnectionsAsync` acIds) `catchChatError` (toView . CRChatError (Just user))
agentXFTPDeleteRcvFile :: ChatMonad m => RcvFileId -> FileTransferId -> m () agentXFTPDeleteRcvFile :: ChatMonad m => RcvFileId -> FileTransferId -> m ()
agentXFTPDeleteRcvFile aFileId fileId = do agentXFTPDeleteRcvFile aFileId fileId = do
@ -4803,7 +4808,7 @@ withUser' action =
>>= readTVarIO >>= readTVarIO
>>= maybe (throwChatError CENoActiveUser) run >>= maybe (throwChatError CENoActiveUser) run
where where
run u = action u `catchError` (pure . CRChatCmdError (Just u)) run u = action u `catchChatError` (pure . CRChatCmdError (Just u))
withUser :: ChatMonad m => (User -> m ChatResponse) -> m ChatResponse withUser :: ChatMonad m => (User -> m ChatResponse) -> m ChatResponse
withUser action = withUser' $ \user -> withUser action = withUser' $ \user ->

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

@ -123,7 +123,7 @@ sqlCipherExport DBEncryptionConfig {currentKey = DBEncryptionKey key, newKey = D
checkFile `with` fs checkFile `with` fs
backup `with` fs backup `with` fs
(export chatDb chatEncrypted >> export agentDb agentEncrypted) (export chatDb chatEncrypted >> export agentDb agentEncrypted)
`catchError` \e -> (restore `with` fs) >> throwError e `catchChatError` \e -> (restore `with` fs) >> throwError e
where where
action `with` StorageFiles {chatDb, agentDb} = action chatDb >> action agentDb action `with` StorageFiles {chatDb, agentDb} = action chatDb >> action agentDb
backup f = copyFile f (f <> ".bak") backup f = copyFile f (f <> ".bak")

14
src/Simplex/Chat/Controller.hs
View File

@ -8,6 +8,7 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StrictData #-} {-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
@ -60,6 +61,7 @@ import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType, CorrId,
import Simplex.Messaging.TMap (TMap) import Simplex.Messaging.TMap (TMap)
import Simplex.Messaging.Transport (simplexMQVersion) import Simplex.Messaging.Transport (simplexMQVersion)
import Simplex.Messaging.Transport.Client (TransportHost) import Simplex.Messaging.Transport.Client (TransportHost)
import Simplex.Messaging.Util (catchAllErrors, allFinally)
import System.IO (Handle) import System.IO (Handle)
import System.Mem.Weak (Weak) import System.Mem.Weak (Weak)
import UnliftIO.STM import UnliftIO.STM
@ -900,6 +902,18 @@ type ChatMonad' m = (MonadUnliftIO m, MonadReader ChatController m)
type ChatMonad m = (ChatMonad' m, MonadError ChatError m) type ChatMonad m = (ChatMonad' m, MonadError ChatError m)
catchChatError :: ChatMonad m => m a -> (ChatError -> m a) -> m a
catchChatError = catchAllErrors mkChatError
{-# INLINE catchChatError #-}
chatFinally :: ChatMonad m => m a -> m b -> m a
chatFinally = allFinally mkChatError
{-# INLINE chatFinally #-}
mkChatError :: SomeException -> ChatError
mkChatError = ChatError . CEException . show
{-# INLINE mkChatError #-}
chatCmdError :: Maybe User -> String -> ChatResponse chatCmdError :: Maybe User -> String -> ChatResponse
chatCmdError user = CRChatCmdError user . ChatError . CECommandError chatCmdError user = CRChatCmdError user . ChatError . CECommandError

9
src/Simplex/Chat/Store/Shared.hs
View File

@ -34,6 +34,7 @@ import Simplex.Chat.Types
import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, UserId) import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, UserId)
import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON) import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
import Simplex.Messaging.Util (allFinally)
import UnliftIO.STM import UnliftIO.STM
-- These error type constructors must be added to mobile apps -- These error type constructors must be added to mobile apps
@ -107,6 +108,14 @@ handleSQLError err e
| DB.sqlError e == DB.ErrorConstraint = err | DB.sqlError e == DB.ErrorConstraint = err
| otherwise = SEInternalError $ show e | otherwise = SEInternalError $ show e
storeFinally :: ExceptT StoreError IO a -> ExceptT StoreError IO b -> ExceptT StoreError IO a
storeFinally = allFinally mkStoreError
{-# INLINE storeFinally #-}
mkStoreError :: E.SomeException -> StoreError
mkStoreError = SEInternalError . show
{-# INLINE mkStoreError #-}
fileInfoQuery :: Query fileInfoQuery :: Query
fileInfoQuery = fileInfoQuery =
[sql| [sql|

4
src/Simplex/Chat/Terminal/Notification.hs
View File

@ -6,7 +6,6 @@
module Simplex.Chat.Terminal.Notification (Notification (..), initializeNotifications) where module Simplex.Chat.Terminal.Notification (Notification (..), initializeNotifications) where
import Control.Exception
import Control.Monad (void) import Control.Monad (void)
import Data.List (isInfixOf) import Data.List (isInfixOf)
import Data.Map (Map, fromList) import Data.Map (Map, fromList)
@ -15,6 +14,7 @@ import Data.Maybe (fromMaybe, isJust)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Simplex.Chat.Types import Simplex.Chat.Types
import Simplex.Messaging.Util (catchAll_)
import System.Directory (createDirectoryIfMissing, doesFileExist, findExecutable, getAppUserDataDirectory) import System.Directory (createDirectoryIfMissing, doesFileExist, findExecutable, getAppUserDataDirectory)
import System.FilePath (combine) import System.FilePath (combine)
import System.Info (os) import System.Info (os)
@ -39,7 +39,7 @@ noNotifications :: Notification -> IO ()
noNotifications _ = pure () noNotifications _ = pure ()
hideException :: (a -> IO ()) -> (a -> IO ()) hideException :: (a -> IO ()) -> (a -> IO ())
hideException f a = f a `catch` \(_ :: SomeException) -> pure () hideException f a = f a `catchAll_` pure ()
initLinuxNotify :: IO (Notification -> IO ()) initLinuxNotify :: IO (Notification -> IO ())
initLinuxNotify = do initLinuxNotify = do

2
stack.yaml
View File

@ -49,7 +49,7 @@ extra-deps:
# - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561 # - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561
# - ../simplexmq # - ../simplexmq
- github: simplex-chat/simplexmq - github: simplex-chat/simplexmq
commit: f2657f9c0b954f952aaf381bb9b55ac34ea59ed7 commit: 532cd2f39c7c22da19a47424eaefa7eafb0aeff8
- github: kazu-yamamoto/http2 - github: kazu-yamamoto/http2
commit: b5a1b7200cf5bc7044af34ba325284271f6dff25 commit: b5a1b7200cf5bc7044af34ba325284271f6dff25
# - ../direct-sqlcipher # - ../direct-sqlcipher

6
tests/ChatTests/Direct.hs
View File

@ -356,6 +356,12 @@ testDirectMessageDelete =
\alice bob -> do \alice bob -> do
connectUsers alice bob connectUsers alice bob
-- Test for exception not interrupting the delivery - uncomment lines in newContentMessage
-- alice #> "@bob hello 111"
-- bob <## "exception: user error (#####################)"
-- -- bob <## "bad chat command: #####################"
-- -- bob <# "alice> hello 111"
-- alice, bob: msg id 1 -- alice, bob: msg id 1
alice #> "@bob hello 🙂" alice #> "@bob hello 🙂"
bob <# "alice> hello 🙂" bob <# "alice> hello 🙂"