dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-08-29 01:09:15 +00:00
Code Issues Packages Projects Releases Wiki Activity

cli: option to disable vacuum on migration (#5446)

Browse Source 
* cli: option to disable vacuum on migration

* update simplexmq

* mobile options

* use option in test
This commit is contained in:
Evgeny
2024-12-28 22:14:06 +00:00
committed by GitHub
parent d37d309f85
commit 206f7898c3
10 changed files with 36 additions and 26 deletions
Download Patch File Download Diff File Expand all files Collapse all files
cabal.project
+1 -1
View File
@@ -12,7 +12,7 @@ constraints: zip +disable-bzip2 +disable-zstd
source-repository-package
type: git
location: https://github.com/simplex-chat/simplexmq.git
tag: 3cf9dacbc0f006153394a283fdcaf88ea0711c0f
tag: c7a07d22520f74f4023f597559abb3793285b5d6
source-repository-package
type: git
scripts/nix/sha256map.nix
+1 -1
View File
@@ -1,5 +1,5 @@
{
"https://github.com/simplex-chat/simplexmq.git"."3cf9dacbc0f006153394a283fdcaf88ea0711c0f" = "19j32pv7xcvgz9c2wdnaa8ykixr3c09icy8yvdssb661bd1hc4wr";
"https://github.com/simplex-chat/simplexmq.git"."c7a07d22520f74f4023f597559abb3793285b5d6" = "08bhkqm2hvgql63hrayas7izvxbv99pdzwvn3kj6z0j02pnwng6d";
"https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
"https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d";
"https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl";
src/Simplex/Chat.hs
+4 -4
View File
@@ -183,10 +183,10 @@ fluxXFTPServers =
logCfg :: LogConfig
logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
createChatDatabase :: FilePath -> ScrubbedBytes -> Bool -> MigrationConfirmation -> IO (Either MigrationError ChatDatabase)
createChatDatabase filePrefix key keepKey confirmMigrations = runExceptT $ do
chatStore <- ExceptT $ createChatStore (chatStoreFile filePrefix) key keepKey confirmMigrations
agentStore <- ExceptT $ createAgentStore (agentStoreFile filePrefix) key keepKey confirmMigrations
createChatDatabase :: FilePath -> ScrubbedBytes -> Bool -> MigrationConfirmation -> Bool -> IO (Either MigrationError ChatDatabase)
createChatDatabase filePrefix key keepKey confirmMigrations vacuum = runExceptT $ do
chatStore <- ExceptT $ createChatStore (chatStoreFile filePrefix) key keepKey confirmMigrations vacuum
agentStore <- ExceptT $ createAgentStore (agentStoreFile filePrefix) key keepKey confirmMigrations vacuum
pure ChatDatabase {chatStore, agentStore}
newChatController :: ChatDatabase -> Maybe User -> ChatConfig -> ChatOpts -> Bool -> IO ChatController
src/Simplex/Chat/Core.hs
+2 -2
View File
@@ -34,14 +34,14 @@ import Text.Read (readMaybe)
import UnliftIO.Async
simplexChatCore :: ChatConfig -> ChatOpts -> (User -> ChatController -> IO ()) -> IO ()
simplexChatCore cfg@ChatConfig {confirmMigrations, testView} opts@ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, dbKey, logAgent, yesToUpMigrations}} chat =
simplexChatCore cfg@ChatConfig {confirmMigrations, testView} opts@ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, dbKey, logAgent, yesToUpMigrations, vacuumOnMigration}} chat =
case logAgent of
Just level -> do
setLogLevel level
withGlobalLogging logCfg initRun
_ -> initRun
where
initRun = createChatDatabase dbFilePrefix dbKey False confirm' >>= either exit run
initRun = createChatDatabase dbFilePrefix dbKey False confirm' vacuumOnMigration >>= either exit run
confirm' = if confirmMigrations == MCConsole && yesToUpMigrations then MCYesUp else confirmMigrations
exit e = do
putStrLn $ "Error opening database: " <> show e
src/Simplex/Chat/Mobile.hs
+5 -3
View File
@@ -201,7 +201,8 @@ mobileChatOpts dbFilePrefix =
logFile = Nothing,
tbqSize = 1024,
highlyAvailable = False,
yesToUpMigrations = False
yesToUpMigrations = False,
vacuumOnMigration = True
},
deviceName = Nothing,
chatCmd = "",
@@ -240,12 +241,13 @@ chatMigrateInitKey dbFilePrefix dbKey keepKey confirm backgroundMode = runExcept
agentStore <- migrate createAgentStore (agentStoreFile dbFilePrefix) confirmMigrations
liftIO $ initialize chatStore ChatDatabase {chatStore, agentStore}
where
opts = mobileChatOpts dbFilePrefix
initialize st db = do
user_ <- getActiveUser_ st
newChatController db user_ defaultMobileConfig (mobileChatOpts dbFilePrefix) backgroundMode
newChatController db user_ defaultMobileConfig opts backgroundMode
migrate createStore dbFile confirmMigrations =
ExceptT $
(first (DBMErrorMigration dbFile) <$> createStore dbFile dbKey keepKey confirmMigrations)
(first (DBMErrorMigration dbFile) <$> createStore dbFile dbKey keepKey confirmMigrations (vacuumOnMigration $ coreOptions opts))
`catch` (pure . checkDBError)
`catchAll` (pure . dbError)
where
src/Simplex/Chat/Options.hs
+9 -2
View File
@@ -66,7 +66,8 @@ data CoreChatOpts = CoreChatOpts
logFile :: Maybe FilePath,
tbqSize :: Natural,
highlyAvailable :: Bool,
yesToUpMigrations :: Bool
yesToUpMigrations :: Bool,
vacuumOnMigration :: Bool
}
data ChatCmdLog = CCLAll | CCLMessages | CCLNone
@@ -240,6 +241,11 @@ coreChatOptsP appDir defaultDbFileName = do
<> short 'y'
<> help "Automatically confirm \"up\" database migrations"
)
disableVacuum <-
switch
( long "disable-vacuum"
<> help "Do not vacuum database after migrations"
)
pure
CoreChatOpts
{ dbFilePrefix,
@@ -265,7 +271,8 @@ coreChatOptsP appDir defaultDbFileName = do
logFile,
tbqSize,
highlyAvailable,
yesToUpMigrations
yesToUpMigrations,
vacuumOnMigration = not disableVacuum
}
where
useTcpTimeout p t = 1000000 * if t > 0 then t else maybe 7 (const 15) p
src/Simplex/Chat/Store.hs
+1 -1
View File
@@ -21,7 +21,7 @@ import Simplex.Messaging.Agent.Store.SQLite (createDBStore)
import Simplex.Messaging.Agent.Store.SQLite.Common (DBStore (..), withTransaction)
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation, MigrationError)
createChatStore :: FilePath -> ScrubbedBytes -> Bool -> MigrationConfirmation -> IO (Either MigrationError DBStore)
createChatStore :: FilePath -> ScrubbedBytes -> Bool -> MigrationConfirmation -> Bool -> IO (Either MigrationError DBStore)
createChatStore dbPath key keepKey = createDBStore dbPath key keepKey migrations
chatStoreFile :: FilePath -> FilePath
tests/ChatClient.hs
+6 -5
View File
@@ -106,7 +106,8 @@ testCoreOpts =
logFile = Nothing,
tbqSize = 16,
highlyAvailable = False,
yesToUpMigrations = False
yesToUpMigrations = False,
vacuumOnMigration = True
}
getTestOpts :: Bool -> ScrubbedBytes -> ChatOpts
@@ -247,15 +248,15 @@ groupLinkViaContactVRange :: VersionRangeChat
groupLinkViaContactVRange = mkVersionRange (VersionChat 1) (VersionChat 2)
createTestChat :: FilePath -> ChatConfig -> ChatOpts -> String -> Profile -> IO TestCC
createTestChat tmp cfg opts@ChatOpts {coreOptions = CoreChatOpts {dbKey}} dbPrefix profile = do
Right db@ChatDatabase {chatStore, agentStore} <- createChatDatabase (tmp </> dbPrefix) dbKey False MCError
createTestChat tmp cfg opts@ChatOpts {coreOptions = CoreChatOpts {dbKey, vacuumOnMigration}} dbPrefix profile = do
Right db@ChatDatabase {chatStore, agentStore} <- createChatDatabase (tmp </> dbPrefix) dbKey False MCError vacuumOnMigration
withTransaction agentStore (`DB.execute_` "INSERT INTO users (user_id) VALUES (1);")
Right user <- withTransaction chatStore $ \db' -> runExceptT $ createUserRecord db' (AgentUserId 1) profile True
startTestChat_ db cfg opts user
startTestChat :: FilePath -> ChatConfig -> ChatOpts -> String -> IO TestCC
startTestChat tmp cfg opts@ChatOpts {coreOptions = CoreChatOpts {dbKey}} dbPrefix = do
Right db@ChatDatabase {chatStore} <- createChatDatabase (tmp </> dbPrefix) dbKey False MCError
startTestChat tmp cfg opts@ChatOpts {coreOptions = CoreChatOpts {dbKey, vacuumOnMigration}} dbPrefix = do
Right db@ChatDatabase {chatStore} <- createChatDatabase (tmp </> dbPrefix) dbKey False MCError vacuumOnMigration
Just user <- find activeUser <$> withTransaction chatStore getUsers
startTestChat_ db cfg opts user
tests/MobileTests.hs
+1 -1
View File
@@ -214,7 +214,7 @@ testChatApi :: FilePath -> IO ()
testChatApi tmp = do
let dbPrefix = tmp </> "1"
f = chatStoreFile dbPrefix
Right st <- createChatStore f "myKey" False MCYesUp
Right st <- createChatStore f "myKey" False MCYesUp True
Right _ <- withTransaction st $ \db -> runExceptT $ createUserRecord db (AgentUserId 1) aliceProfile {preferences = Nothing} True
Right cc <- chatMigrateInit dbPrefix "myKey" "yesUp"
Left (DBMErrorNotADatabase _) <- chatMigrateInit dbPrefix "" "yesUp"
tests/SchemaDump.hs
+6 -6
View File
@@ -53,7 +53,7 @@ testVerifySchemaDump :: IO ()
testVerifySchemaDump = withTmpFiles $ do
savedSchema <- ifM (doesFileExist appSchema) (readFile appSchema) (pure "")
savedSchema `deepseq` pure ()
void $ createChatStore testDB "" False MCError
void $ createChatStore testDB "" False MCError True
getSchema testDB appSchema `shouldReturn` savedSchema
removeFile testDB
@@ -61,14 +61,14 @@ testVerifyLintFKeyIndexes :: IO ()
testVerifyLintFKeyIndexes = withTmpFiles $ do
savedLint <- ifM (doesFileExist appLint) (readFile appLint) (pure "")
savedLint `deepseq` pure ()
void $ createChatStore testDB "" False MCError
void $ createChatStore testDB "" False MCError True
getLintFKeyIndexes testDB "tests/tmp/chat_lint.sql" `shouldReturn` savedLint
removeFile testDB
testSchemaMigrations :: IO ()
testSchemaMigrations = withTmpFiles $ do
let noDownMigrations = dropWhileEnd (\Migration {down} -> isJust down) Store.migrations
Right st <- createDBStore testDB "" False noDownMigrations MCError
Right st <- createDBStore testDB "" False noDownMigrations MCError True
mapM_ (testDownMigration st) $ drop (length noDownMigrations) Store.migrations
closeDBStore st
removeFile testDB
@@ -78,14 +78,14 @@ testSchemaMigrations = withTmpFiles $ do
putStrLn $ "down migration " <> name m
let downMigr = fromJust $ toDownMigration m
schema <- getSchema testDB testSchema
Migrations.run st $ MTRUp [m]
Migrations.run st True $ MTRUp [m]
schema' <- getSchema testDB testSchema
schema' `shouldNotBe` schema
Migrations.run st $ MTRDown [downMigr]
Migrations.run st True $ MTRDown [downMigr]
unless (name m `elem` skipComparisonForDownMigrations) $ do
schema'' <- getSchema testDB testSchema
schema'' `shouldBe` schema
Migrations.run st $ MTRUp [m]
Migrations.run st True $ MTRUp [m]
schema''' <- getSchema testDB testSchema
schema''' `shouldBe` schema'