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

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

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

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)
 

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 <> " <srv1[,srv2,...]>") <> " 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