mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-04-15 05:05:56 +00:00
224 lines
8.3 KiB
Haskell
224 lines
8.3 KiB
Haskell
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
module Simplex.Chat.Archive
|
|
( exportArchive,
|
|
importArchive,
|
|
deleteStorage,
|
|
sqlCipherExport,
|
|
sqlCipherTestKey,
|
|
)
|
|
where
|
|
|
|
import qualified Codec.Archive.Zip as Z
|
|
import Control.Monad
|
|
import Control.Monad.Except
|
|
import Control.Monad.Reader
|
|
import qualified Data.ByteArray as BA
|
|
import Data.Functor (($>))
|
|
import Data.Maybe (fromMaybe)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import qualified Database.SQLite3 as SQL
|
|
import Simplex.Chat.Controller
|
|
import Simplex.Chat.Util ()
|
|
import Simplex.Messaging.Agent.Client (agentClientStore)
|
|
import Simplex.Messaging.Agent.Store.SQLite (closeDBStore, keyString, sqlString, storeKey)
|
|
import Simplex.Messaging.Agent.Store.SQLite.Common (DBStore (..))
|
|
import Simplex.Messaging.Util
|
|
import System.FilePath
|
|
import UnliftIO.Directory
|
|
import UnliftIO.Exception (SomeException, bracket, catch)
|
|
import qualified UnliftIO.Exception as E
|
|
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"
|
|
|
|
archiveAssetsFolder :: String
|
|
archiveAssetsFolder = "simplex_v1_assets"
|
|
|
|
wallpapersFolder :: String
|
|
wallpapersFolder = "wallpapers"
|
|
|
|
exportArchive :: ArchiveConfig -> CM' [ArchiveError]
|
|
exportArchive cfg@ArchiveConfig {archivePath, disableCompression} =
|
|
withTempDir cfg "simplex-chat." $ \dir -> do
|
|
StorageFiles {chatStore, agentStore, filesPath, assetsPath} <- storageFiles
|
|
copyFile (dbFilePath chatStore) $ dir </> archiveChatDbFile
|
|
copyFile (dbFilePath agentStore) $ dir </> archiveAgentDbFile
|
|
errs <-
|
|
forM filesPath $ \fp ->
|
|
copyValidDirectoryFiles entrySelectorError fp $ dir </> archiveFilesFolder
|
|
forM_ assetsPath $ \fp ->
|
|
copyDirectoryFiles (fp </> wallpapersFolder) $ dir </> archiveAssetsFolder </> wallpapersFolder
|
|
let method = if disableCompression == Just True then Z.Store else Z.Deflate
|
|
Z.createArchive archivePath $ Z.packDirRecur method Z.mkEntrySelector dir
|
|
pure $ fromMaybe [] errs
|
|
where
|
|
entrySelectorError f = (Z.mkEntrySelector f $> Nothing) `E.catchAny` (pure . Just . show)
|
|
|
|
importArchive :: ArchiveConfig -> CM' [ArchiveError]
|
|
importArchive cfg@ArchiveConfig {archivePath} =
|
|
withTempDir cfg "simplex-chat." $ \dir -> do
|
|
Z.withArchive archivePath $ Z.unpackInto dir
|
|
fs@StorageFiles {chatStore, agentStore, filesPath, assetsPath} <- storageFiles
|
|
liftIO $ closeDBStore `withStores` fs
|
|
backup `withDBs` fs
|
|
copyFile (dir </> archiveChatDbFile) $ dbFilePath chatStore
|
|
copyFile (dir </> archiveAgentDbFile) $ dbFilePath agentStore
|
|
errs <- copyFiles (dir </> archiveFilesFolder) filesPath
|
|
errs' <- copyFiles (dir </> archiveAssetsFolder </> wallpapersFolder) ((</> wallpapersFolder) <$> assetsPath)
|
|
pure $ errs <> errs'
|
|
where
|
|
backup f = whenM (doesFileExist f) $ copyFile f $ f <> ".bak"
|
|
copyFiles fromDir = \case
|
|
Just fp ->
|
|
ifM
|
|
(doesDirectoryExist fromDir)
|
|
(copyDirectoryFiles fromDir fp)
|
|
(pure [])
|
|
`E.catch` \(e :: E.SomeException) -> pure [AEImport $ show e]
|
|
_ -> pure []
|
|
|
|
withTempDir :: ArchiveConfig -> (String -> (FilePath -> CM' a) -> CM' a)
|
|
withTempDir cfg = case parentTempDirectory (cfg :: ArchiveConfig) of
|
|
Just tmpDir -> withTempDirectory tmpDir
|
|
_ -> withSystemTempDirectory
|
|
|
|
copyDirectoryFiles :: FilePath -> FilePath -> CM' [ArchiveError]
|
|
copyDirectoryFiles fromDir toDir = copyValidDirectoryFiles (\_ -> pure Nothing) fromDir toDir
|
|
|
|
copyValidDirectoryFiles :: (FilePath -> IO (Maybe String)) -> FilePath -> FilePath -> CM' [ArchiveError]
|
|
copyValidDirectoryFiles isFileError fromDir toDir = do
|
|
createDirectoryIfMissing True toDir
|
|
fs <- listDirectory fromDir
|
|
foldM copyFileCatchError [] fs
|
|
where
|
|
copyFileCatchError fileErrs f =
|
|
liftIO (isFileError f) >>= \case
|
|
Nothing ->
|
|
(copyDirectoryFile f $> fileErrs)
|
|
`E.catch` \(e :: E.SomeException) -> addErr $ show e
|
|
Just e -> addErr e
|
|
where
|
|
addErr e = pure $ AEFileError f e : fileErrs
|
|
copyDirectoryFile f = do
|
|
let fn = takeFileName f
|
|
f' = fromDir </> fn
|
|
whenM (doesFileExist f') $ copyFile f' $ toDir </> fn
|
|
|
|
deleteStorage :: CM ()
|
|
deleteStorage = do
|
|
fs <- lift storageFiles
|
|
liftIO $ closeDBStore `withStores` fs
|
|
remove `withDBs` fs
|
|
mapM_ removeDir $ filesPath fs
|
|
mapM_ removeDir $ assetsPath fs
|
|
mapM_ removeDir =<< chatReadVar tempDirectory
|
|
where
|
|
remove f = whenM (doesFileExist f) $ removeFile f
|
|
removeDir d = whenM (doesDirectoryExist d) $ removePathForcibly d
|
|
|
|
data StorageFiles = StorageFiles
|
|
{ chatStore :: DBStore,
|
|
agentStore :: DBStore,
|
|
filesPath :: Maybe FilePath,
|
|
assetsPath :: Maybe FilePath
|
|
}
|
|
|
|
storageFiles :: CM' StorageFiles
|
|
storageFiles = do
|
|
ChatController {chatStore, filesFolder, assetsDirectory, smpAgent} <- ask
|
|
let agentStore = agentClientStore smpAgent
|
|
filesPath <- readTVarIO filesFolder
|
|
assetsPath <- readTVarIO assetsDirectory
|
|
pure StorageFiles {chatStore, agentStore, filesPath, assetsPath}
|
|
|
|
sqlCipherExport :: DBEncryptionConfig -> CM ()
|
|
sqlCipherExport DBEncryptionConfig {currentKey = DBEncryptionKey key, newKey = DBEncryptionKey key', keepKey} =
|
|
when (key /= key') $ do
|
|
fs <- lift storageFiles
|
|
checkFile `withDBs` fs
|
|
backup `withDBs` fs
|
|
checkEncryption `withStores` fs
|
|
removeExported `withDBs` fs
|
|
export `withDBs` fs
|
|
-- closing after encryption prevents closing in case wrong encryption key was passed
|
|
liftIO $ closeDBStore `withStores` fs
|
|
(moveExported `withStores` fs)
|
|
`catchAllErrors` \e -> (restore `withDBs` fs) >> throwError e
|
|
where
|
|
backup f = copyFile f (f <> ".bak")
|
|
restore f = copyFile (f <> ".bak") f
|
|
checkFile f = unlessM (doesFileExist f) $ throwDBError $ DBErrorNoFile f
|
|
checkEncryption DBStore {dbKey} = do
|
|
enc <- maybe True (not . BA.null) <$> readTVarIO dbKey
|
|
when (enc && BA.null key) $ throwDBError DBErrorEncrypted
|
|
when (not enc && not (BA.null key)) $ throwDBError DBErrorPlaintext
|
|
exported = (<> ".exported")
|
|
removeExported f = whenM (doesFileExist $ exported f) $ removeFile (exported f)
|
|
moveExported DBStore {dbFilePath = f, dbKey} = do
|
|
renameFile (exported f) f
|
|
atomically $ writeTVar dbKey $ storeKey key' (fromMaybe False keepKey)
|
|
export f = do
|
|
withDB f (`SQL.exec` exportSQL) DBErrorExport
|
|
withDB (exported f) (`SQL.exec` testSQL key') DBErrorOpen
|
|
where
|
|
exportSQL =
|
|
T.unlines $
|
|
keySQL key
|
|
<> [ "ATTACH DATABASE " <> sqlString (T.pack f <> ".exported") <> " AS exported KEY " <> keyString key' <> ";",
|
|
"SELECT sqlcipher_export('exported');",
|
|
"DETACH DATABASE exported;"
|
|
]
|
|
|
|
withDB :: FilePath -> (SQL.Database -> IO a) -> (SQLiteError -> DatabaseError) -> CM ()
|
|
withDB f' a err =
|
|
liftIO (bracket (SQL.open $ T.pack f') SQL.close a $> Nothing)
|
|
`catch` checkSQLError
|
|
`catch` (\(e :: SomeException) -> sqliteError' e)
|
|
>>= mapM_ (throwDBError . err)
|
|
where
|
|
checkSQLError e = case SQL.sqlError e of
|
|
SQL.ErrorNotADatabase -> pure $ Just SQLiteErrorNotADatabase
|
|
_ -> sqliteError' e
|
|
sqliteError' :: Show e => e -> CM (Maybe SQLiteError)
|
|
sqliteError' = pure . Just . SQLiteError . show
|
|
|
|
testSQL :: BA.ScrubbedBytes -> Text
|
|
testSQL k =
|
|
T.unlines $
|
|
keySQL k
|
|
<> [ "PRAGMA foreign_keys = ON;",
|
|
"PRAGMA secure_delete = ON;",
|
|
"SELECT count(*) FROM sqlite_master;"
|
|
]
|
|
|
|
keySQL :: BA.ScrubbedBytes -> [Text]
|
|
keySQL k = ["PRAGMA key = " <> keyString k <> ";" | not (BA.null k)]
|
|
|
|
sqlCipherTestKey :: DBEncryptionKey -> CM ()
|
|
sqlCipherTestKey (DBEncryptionKey key) = do
|
|
fs <- lift storageFiles
|
|
testKey `withDBs` fs
|
|
where
|
|
testKey f = withDB f (`SQL.exec` testSQL key) DBErrorOpen
|
|
|
|
withDBs :: Monad m => (FilePath -> m b) -> StorageFiles -> m b
|
|
action `withDBs` StorageFiles {chatStore, agentStore} = action (dbFilePath chatStore) >> action (dbFilePath agentStore)
|
|
|
|
withStores :: Monad m => (DBStore -> m b) -> StorageFiles -> m b
|
|
action `withStores` StorageFiles {chatStore, agentStore} = action chatStore >> action agentStore
|