Export & import storage archive (#726)

* core: import and export of chat archive

* export chat archive

* import archive, support starting chat after it is stopped

* test for maintenance mode

* test/fix archive with files

* prevent starting chat after chat database was deleted or imported

* update simplexmq

src/Simplex/Chat/Archive.hs

@@ -0,0 +1,81 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Simplex.Chat.Archive where
+
+import qualified Codec.Archive.Zip as Z
+import Control.Monad.Reader
+import Simplex.Chat.Controller
+import Simplex.Chat.Util (whenM)
+import Simplex.Messaging.Agent.Client (agentDbPath)
+import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..))
+import System.FilePath
+import UnliftIO.Directory
+import UnliftIO.STM
+import UnliftIO.Temporary
+
+archiveAgentDbFile :: String
+archiveAgentDbFile = "simplex_v1_agent.db"
+
+archiveChatDbFile :: String
+archiveChatDbFile = "simplex_v1_chat.db"
+
+archiveFilesFolder :: String
+archiveFilesFolder = "simplex_v1_files"
+
+exportArchive :: ChatMonad m => ArchiveConfig -> m ()
+exportArchive ArchiveConfig {archivePath, disableCompression} =
+  withSystemTempDirectory "simplex-chat." $ \dir -> do
+    StorageFiles {chatDb, agentDb, filesPath} <- storageFiles
+    copyFile chatDb $ dir </> archiveChatDbFile
+    copyFile agentDb $ dir </> archiveAgentDbFile
+    forM_ filesPath $ \fp ->
+      copyDirectoryFiles fp $ dir </> archiveFilesFolder
+    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 ArchiveConfig {archivePath} =
+  withSystemTempDirectory "simplex-chat." $ \dir -> do
+    Z.withArchive archivePath $ Z.unpackInto dir
+    StorageFiles {chatDb, agentDb, filesPath} <- storageFiles
+    backup chatDb
+    backup agentDb
+    copyFile (dir </> archiveChatDbFile) chatDb
+    copyFile (dir </> archiveAgentDbFile) agentDb
+    let filesDir = dir </> archiveFilesFolder
+    forM_ filesPath $ \fp ->
+      whenM (doesDirectoryExist filesDir) $
+        copyDirectoryFiles filesDir fp
+  where
+    backup f = whenM (doesFileExist f) $ copyFile f $ f <> ".bak"
+
+copyDirectoryFiles :: MonadIO m => FilePath -> FilePath -> m ()
+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
+
+deleteStorage :: ChatMonad m => m ()
+deleteStorage = do
+  StorageFiles {chatDb, agentDb, filesPath} <- storageFiles
+  removeFile chatDb
+  removeFile agentDb
+  mapM_ removePathForcibly filesPath
+
+data StorageFiles = StorageFiles
+  { chatDb :: FilePath,
+    agentDb :: FilePath,
+    filesPath :: Maybe FilePath
+  }
+
+storageFiles :: ChatMonad m => m StorageFiles
+storageFiles = do
+  ChatController {chatStore, filesFolder, smpAgent} <- ask
+  let SQLiteStore {dbFilePath = chatDb} = chatStore
+      agentDb = agentDbPath smpAgent
+  filesPath <- readTVarIO filesFolder
+  pure StorageFiles {chatDb, agentDb, filesPath}

src/Simplex/Chat/Controller.hs

@@ -76,6 +76,7 @@ data ChatController = ChatController
     smpAgent :: AgentClient,
     agentAsync :: TVar (Maybe (Async ())),
     chatStore :: SQLiteStore,
+    chatStoreChanged :: TVar Bool, -- if True, chat should be fully restarted
     idsDrg :: TVar ChaChaDRG,
     inputQ :: TBQueue String,
     outputQ :: TBQueue (Maybe CorrId, ChatResponse),
@@ -100,8 +101,12 @@ data ChatCommand
   = ShowActiveUser
   | CreateActiveUser Profile
   | StartChat
+  | APIStopChat
   | ResubscribeAllConnections
   | SetFilesFolder FilePath
+  | APIExportArchive ArchiveConfig
+  | APIImportArchive ArchiveConfig
+  | APIDeleteStorage
   | APIGetChats {pendingConnections :: Bool}
   | APIGetChat ChatRef ChatPagination
   | APIGetChatItems Int
@@ -178,6 +183,7 @@ data ChatResponse
   = CRActiveUser {user :: User}
   | CRChatStarted
   | CRChatRunning
+  | CRChatStopped
   | CRApiChats {chats :: [AChat]}
   | CRApiChat {chat :: AChat}
   | CRLastMessages {chatItems :: [AChatItem]}
@@ -279,6 +285,9 @@ instance ToJSON ChatResponse where
   toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CR"
   toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CR"
 
+data ArchiveConfig = ArchiveConfig {archivePath :: FilePath, disableCompression :: Maybe Bool}
+  deriving (Show, Generic, FromJSON)
+
 data ContactSubStatus = ContactSubStatus
   { contact :: Contact,
     contactError :: Maybe ChatError
@@ -329,6 +338,8 @@ data ChatErrorType
   = CENoActiveUser
   | CEActiveUserExists
   | CEChatNotStarted
+  | CEChatNotStopped
+  | CEChatStoreChanged
   | CEInvalidConnReq
   | CEInvalidChatMessage {message :: String}
   | CEContactNotReady {contact :: Contact}

src/Simplex/Chat/Core.hs

@@ -26,13 +26,15 @@ simplexChatCore cfg@ChatConfig {dbPoolSize, yesToMigrations} opts sendToast chat
       st <- createStore f dbPoolSize yesToMigrations
       u <- getCreateActiveUser st
       cc <- newChatController st (Just u) cfg opts sendToast
-      runSimplexChat u cc chat
+      runSimplexChat opts u cc chat
 
-runSimplexChat :: User -> ChatController -> (User -> ChatController -> IO ()) -> IO ()
-runSimplexChat u cc chat = do
-  a1 <- async $ chat u cc
-  a2 <- runReaderT (startChatController u) cc
-  waitEither_ a1 a2
+runSimplexChat :: ChatOpts -> User -> ChatController -> (User -> ChatController -> IO ()) -> IO ()
+runSimplexChat ChatOpts {maintenance} u cc chat
+  | maintenance = wait =<< async (chat u cc)
+  | otherwise = do
+    a1 <- async $ chat u cc
+    a2 <- runReaderT (startChatController u) cc
+    waitEither_ a1 a2
 
 sendChatCmd :: ChatController -> String -> IO ChatResponse
 sendChatCmd cc s = runReaderT (execChatCommand . encodeUtf8 $ T.pack s) cc

src/Simplex/Chat/Mobile.hs

@@ -54,7 +54,8 @@ mobileChatOpts =
       logAgent = False,
       chatCmd = "",
       chatCmdDelay = 3,
-      chatServerPort = Nothing
+      chatServerPort = Nothing,
+      maintenance = True
     }
 
 defaultMobileConfig :: ChatConfig

src/Simplex/Chat/Options.hs

@@ -25,7 +25,8 @@ data ChatOpts = ChatOpts
     logAgent :: Bool,
     chatCmd :: String,
     chatCmdDelay :: Int,
-    chatServerPort :: Maybe String
+    chatServerPort :: Maybe String,
+    maintenance :: Bool
   }
 
 chatOpts :: FilePath -> FilePath -> Parser ChatOpts
@@ -88,7 +89,13 @@ chatOpts appDir defaultDbFileName = do
           <> help "Run chat server on specified port"
           <> value Nothing
       )
-  pure ChatOpts {dbFilePrefix, smpServers, logConnections, logAgent, chatCmd, chatCmdDelay, chatServerPort}
+  maintenance <-
+    switch
+      ( long "maintenance"
+          <> short 'm'
+          <> help "Run in maintenance mode (/_start to start chat)"
+      )
+  pure ChatOpts {dbFilePrefix, smpServers, logConnections, logAgent, chatCmd, chatCmdDelay, chatServerPort, maintenance}
   where
     defaultDbFilePath = combine appDir defaultDbFileName
 

src/Simplex/Chat/View.hs

@@ -53,7 +53,8 @@ responseToView :: Bool -> ChatResponse -> [StyledString]
 responseToView testView = \case
   CRActiveUser User {profile} -> viewUserProfile profile
   CRChatStarted -> ["chat started"]
-  CRChatRunning -> []
+  CRChatRunning -> ["chat is running"]
+  CRChatStopped -> ["chat stopped"]
   CRApiChats chats -> if testView then testViewChats chats else [plain . bshow $ J.encode chats]
   CRApiChat chat -> if testView then testViewChat chat else [plain . bshow $ J.encode chat]
   CRApiParsedMarkdown ft -> [plain . bshow $ J.encode ft]
@@ -721,6 +722,8 @@ viewChatError = \case
     CENoActiveUser -> ["error: active user is required"]
     CEActiveUserExists -> ["error: active user already exists"]
     CEChatNotStarted -> ["error: chat not started"]
+    CEChatNotStopped -> ["error: chat not stopped"]
+    CEChatStoreChanged -> ["error: chat store changed"]
     CEInvalidConnReq -> viewInvalidConnReq
     CEInvalidChatMessage e -> ["chat message error: " <> sShow e]
     CEContactNotReady c -> [ttyContact' c <> ": not ready"]