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.hs

@@ -41,6 +41,7 @@ import qualified Data.Text as T
 import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds)
 import Data.Time.LocalTime (getCurrentTimeZone, getZonedTime)
 import Data.Word (Word32)
+import Simplex.Chat.Archive
 import Simplex.Chat.Call
 import Simplex.Chat.Controller
 import Simplex.Chat.Markdown
@@ -134,7 +135,8 @@ newChatController chatStore user cfg@ChatConfig {agentConfig = aCfg, tbqSize, de
   rcvFiles <- newTVarIO M.empty
   currentCalls <- atomically TM.empty
   filesFolder <- newTVarIO Nothing
-  pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, currentCalls, config, sendNotification, filesFolder}
+  chatStoreChanged <- newTVarIO False
+  pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, chatStoreChanged, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, currentCalls, config, sendNotification, filesFolder}
   where
     resolveServers :: InitialAgentServers -> IO InitialAgentServers
     resolveServers ss@InitialAgentServers {smp = defaultSMPServers} = case nonEmpty smpServers of
@@ -150,6 +152,7 @@ runChatController = race_ notificationSubscriber . agentSubscriber
 
 startChatController :: (MonadUnliftIO m, MonadReader ChatController m) => User -> m (Async ())
 startChatController user = do
+  asks smpAgent >>= resumeAgentClient
   s <- asks agentAsync
   readTVarIO s >>= maybe (start s) pure
   where
@@ -194,13 +197,23 @@ processChatCommand = \case
   StartChat -> withUser' $ \user ->
     asks agentAsync >>= readTVarIO >>= \case
       Just _ -> pure CRChatRunning
-      _ -> startChatController user $> CRChatStarted
+      _ ->
+        ifM
+          (asks chatStoreChanged >>= readTVarIO)
+          (throwChatError CEChatStoreChanged)
+          (startChatController user $> CRChatStarted)
+  APIStopChat -> do
+    ask >>= stopChatController
+    pure CRChatStopped
   ResubscribeAllConnections -> withUser (subscribeUserConnections resubscribeConnection) $> CRCmdOk
   SetFilesFolder filesFolder' -> withUser $ \_ -> do
     createDirectoryIfMissing True filesFolder'
     ff <- asks filesFolder
     atomically . writeTVar ff $ Just filesFolder'
     pure CRCmdOk
+  APIExportArchive cfg -> checkChatStopped $ exportArchive cfg $> CRCmdOk
+  APIImportArchive cfg -> checkChatStopped $ importArchive cfg >> setStoreChanged $> CRCmdOk
+  APIDeleteStorage -> checkChatStopped $ deleteStorage >> setStoreChanged $> CRCmdOk
   APIGetChats withPCC -> CRApiChats <$> withUser (\user -> withStore $ \st -> getChatPreviews st user withPCC)
   APIGetChat (ChatRef cType cId) pagination -> withUser $ \user -> case cType of
     CTDirect -> CRApiChat . AChat SCTDirect <$> withStore (\st -> getDirectChat st user cId pagination)
@@ -770,6 +783,10 @@ processChatCommand = \case
         CTDirect -> withStore $ \st -> getContactIdByName st userId name
         CTGroup -> withStore $ \st -> getGroupIdByName st user name
         _ -> throwChatError $ CECommandError "not supported"
+    checkChatStopped :: m ChatResponse -> m ChatResponse
+    checkChatStopped a = asks agentAsync >>= readTVarIO >>= maybe a (const $ throwChatError CEChatNotStopped)
+    setStoreChanged :: m ()
+    setStoreChanged = asks chatStoreChanged >>= atomically . (`writeTVar` True)
     getSentChatItemIdByText :: User -> ChatRef -> ByteString -> m Int64
     getSentChatItemIdByText user@User {userId, localDisplayName} (ChatRef cType cId) msg = case cType of
       CTDirect -> withStore $ \st -> getDirectChatItemIdByText st userId cId SMDSnd (safeDecodeUtf8 msg)
@@ -2212,8 +2229,12 @@ chatCommandP =
   ("/user " <|> "/u ") *> (CreateActiveUser <$> userProfile)
     <|> ("/user" <|> "/u") $> ShowActiveUser
     <|> "/_start" $> StartChat
+    <|> "/_stop" $> APIStopChat
     <|> "/_resubscribe all" $> ResubscribeAllConnections
     <|> "/_files_folder " *> (SetFilesFolder <$> filePath)
+    <|> "/_db export " *> (APIExportArchive <$> jsonP)
+    <|> "/_db import " *> (APIImportArchive <$> jsonP)
+    <|> "/_db delete" $> APIDeleteStorage
     <|> "/_get chats" *> (APIGetChats <$> (" pcc=on" $> True <|> " pcc=off" $> False <|> pure False))
     <|> "/_get chat " *> (APIGetChat <$> chatRefP <* A.space <*> chatPaginationP)
     <|> "/_get items count=" *> (APIGetChatItems <$> A.decimal)

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"]