From bcbfc1758e9e2eb4d451f143457cfa1a7ea51b78 Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Tue, 23 May 2023 13:51:23 +0400 Subject: [PATCH] core: catch errors on archive import (#2486) * core: catch errors on archive import * return list * refactor * rename * rename * refactor * Update src/Simplex/Chat/Archive.hs Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> * fix syntax * refactor * CRArchiveImported --------- Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> --- src/Simplex/Chat.hs | 7 +++++-- src/Simplex/Chat/Archive.hs | 32 +++++++++++++++++++++----------- src/Simplex/Chat/Controller.hs | 1 + src/Simplex/Chat/View.hs | 13 +++++++------ 4 files changed, 34 insertions(+), 19 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 6a40d5190..54d7bddbf 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -448,7 +448,10 @@ processChatCommand = \case ts <- liftIO getCurrentTime let filePath = "simplex-chat." <> formatTime defaultTimeLocale "%FT%H%M%SZ" ts <> ".zip" processChatCommand $ APIExportArchive $ ArchiveConfig filePath Nothing Nothing - APIImportArchive cfg -> withStoreChanged $ importArchive cfg + APIImportArchive cfg -> checkChatStopped $ do + fileErrs <- importArchive cfg + setStoreChanged + pure $ CRArchiveImported fileErrs APIDeleteStorage -> withStoreChanged deleteStorage APIStorageEncryption cfg -> withStoreChanged $ sqlCipherExport cfg ExecChatStoreSQL query -> CRSQLResult <$> withStore' (`execSQL` query) @@ -1276,7 +1279,7 @@ processChatCommand = \case chatRef <- getChatRef user chatName let mc = MCText msg processChatCommand $ APIUpdateChatItem chatRef chatItemId live mc - ReactToMessage add reaction chatName msg -> withUser $ \user -> do + ReactToMessage add reaction chatName msg -> withUser $ \user -> do chatRef <- getChatRef user chatName chatItemId <- getChatItemIdByText user chatRef msg processChatCommand $ APIChatItemReaction chatRef chatItemId add reaction diff --git a/src/Simplex/Chat/Archive.hs b/src/Simplex/Chat/Archive.hs index fab53753c..d05fccfcf 100644 --- a/src/Simplex/Chat/Archive.hs +++ b/src/Simplex/Chat/Archive.hs @@ -48,7 +48,7 @@ exportArchive cfg@ArchiveConfig {archivePath, disableCompression} = let method = if disableCompression == Just True then Z.Store else Z.Deflate Z.createArchive archivePath $ Z.packDirRecur method Z.mkEntrySelector dir -importArchive :: ChatMonad m => ArchiveConfig -> m () +importArchive :: ChatMonad m => ArchiveConfig -> m [(Maybe String, ChatError)] importArchive cfg@ArchiveConfig {archivePath} = withTempDir cfg "simplex-chat." $ \dir -> do Z.withArchive archivePath $ Z.unpackInto dir @@ -57,26 +57,36 @@ importArchive cfg@ArchiveConfig {archivePath} = backup agentDb copyFile (dir archiveChatDbFile) chatDb copyFile (dir archiveAgentDbFile) agentDb - let filesDir = dir archiveFilesFolder - forM_ filesPath $ \fp -> - whenM (doesDirectoryExist filesDir) $ - copyDirectoryFiles filesDir fp + copyFiles dir filesPath `catchError` \e -> pure [(Nothing, e)] where backup f = whenM (doesFileExist f) $ copyFile f $ f <> ".bak" + copyFiles dir filesPath = do + let filesDir = dir archiveFilesFolder + case filesPath of + Just fp -> + ifM + (doesDirectoryExist filesDir) + (copyDirectoryFiles filesDir fp) + (pure []) + _ -> pure [] -withTempDir :: ChatMonad m => ArchiveConfig -> (String -> (FilePath -> m ()) -> m ()) +withTempDir :: ChatMonad m => ArchiveConfig -> (String -> (FilePath -> m a) -> m a) withTempDir cfg = case parentTempDirectory (cfg :: ArchiveConfig) of Just tmpDir -> withTempDirectory tmpDir _ -> withSystemTempDirectory -copyDirectoryFiles :: MonadIO m => FilePath -> FilePath -> m () +copyDirectoryFiles :: ChatMonad m => FilePath -> FilePath -> m [(Maybe String, ChatError)] copyDirectoryFiles fromDir toDir = do createDirectoryIfMissing False toDir fs <- listDirectory fromDir - forM_ fs $ \f -> do - let fn = takeFileName f - f' = fromDir fn - whenM (doesFileExist f') $ copyFile f' $ toDir fn + foldM copyFileCatchError [] fs + where + copyFileCatchError fileErrs f = + (copyDirectoryFile f $> fileErrs) `catchError` \e -> pure ((Just f, e) : fileErrs) + copyDirectoryFile f = do + let fn = takeFileName f + f' = fromDir fn + whenM (doesFileExist f') $ copyFile f' $ toDir fn deleteStorage :: ChatMonad m => m () deleteStorage = do diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 5ec15ee6c..6a73432c1 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -524,6 +524,7 @@ data ChatResponse | CRMessageError {user :: User, severity :: Text, errorMessage :: Text} | CRChatCmdError {user_ :: Maybe User, chatError :: ChatError} | CRChatError {user_ :: Maybe User, chatError :: ChatError} + | CRArchiveImported {fileErrors :: [(Maybe String, ChatError)]} | CRTimedAction {action :: String, durationMilliseconds :: Int64} deriving (Show, Generic) diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 88f11256f..25a4b55ca 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -49,7 +49,7 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (dropPrefix, taggedObjectJSON) -import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType, ProtocolServer (..), ProtoServerWithAuth, ProtocolTypeI, SProtocolType (..)) +import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType, ProtoServerWithAuth, ProtocolServer (..), ProtocolTypeI, SProtocolType (..)) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Util (bshow, tshow) @@ -248,6 +248,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, testView} liveItems ts CRMessageError u prefix err -> ttyUser u [plain prefix <> ": " <> plain err | prefix == "error" || logLevel <= CLLWarning] CRChatCmdError u e -> ttyUserPrefix' u $ viewChatError logLevel e CRChatError u e -> ttyUser' u $ viewChatError logLevel e + CRArchiveImported fileErrs -> if null fileErrs then ["ok"] else ["archive import file errors: " <> plain (show fileErrs)] CRTimedAction _ _ -> [] where ttyUser :: User -> [StyledString] -> [StyledString] @@ -833,8 +834,8 @@ viewUserPrivacy User {userId} User {userId = userId', localDisplayName = n', sho viewUserServers :: AUserProtoServers -> Bool -> [StyledString] viewUserServers (AUPS UserProtoServers {serverProtocol = p, protoServers, presetServers}) testView = - customServers <> - if testView + customServers + <> if testView then [] else [ "", @@ -842,9 +843,9 @@ viewUserServers (AUPS UserProtoServers {serverProtocol = p, protoServers, preset "use " <> highlight (srvCmd <> " ") <> " to configure " <> pName <> " servers", "use " <> highlight (srvCmd <> " default") <> " to remove configured " <> pName <> " servers and use presets" ] - <> case p of - SPSMP -> ["(chat option " <> highlight' "-s" <> " (" <> highlight' "--server" <> ") has precedence over saved SMP servers for chat session)"] - SPXFTP -> ["(chat option " <> highlight' "-xftp-servers" <> " has precedence over saved XFTP servers for chat session)"] + <> case p of + SPSMP -> ["(chat option " <> highlight' "-s" <> " (" <> highlight' "--server" <> ") has precedence over saved SMP servers for chat session)"] + SPXFTP -> ["(chat option " <> highlight' "-xftp-servers" <> " has precedence over saved XFTP servers for chat session)"] where srvCmd = "/" <> strEncode p pName = protocolName p