From 483d888fe2187f52bae6cf9daa3edcd7773cf47f Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Sat, 28 Dec 2024 12:50:47 +0000 Subject: [PATCH] cli: option to disable vacuum on migration --- cabal.project | 12 ++++++------ src/Simplex/Chat.hs | 8 ++++---- src/Simplex/Chat/Core.hs | 4 ++-- src/Simplex/Chat/Mobile.hs | 5 +++-- src/Simplex/Chat/Options.hs | 11 +++++++++-- src/Simplex/Chat/Store.hs | 2 +- tests/ChatClient.hs | 7 ++++--- tests/MobileTests.hs | 2 +- tests/SchemaDump.hs | 12 ++++++------ 9 files changed, 36 insertions(+), 27 deletions(-) diff --git a/cabal.project b/cabal.project index c7a5c080b4..b0863dad99 100644 --- a/cabal.project +++ b/cabal.project @@ -1,5 +1,5 @@ -packages: . --- packages: . ../simplexmq +-- packages: . +packages: . ../simplexmq -- packages: . ../simplexmq ../direct-sqlcipher ../sqlcipher-simple index-state: 2023-12-12T00:00:00Z @@ -9,10 +9,10 @@ package cryptostore constraints: zip +disable-bzip2 +disable-zstd -source-repository-package - type: git - location: https://github.com/simplex-chat/simplexmq.git - tag: 3cf9dacbc0f006153394a283fdcaf88ea0711c0f +-- source-repository-package + -- type: git + -- location: https://github.com/simplex-chat/simplexmq.git + -- tag: 3cf9dacbc0f006153394a283fdcaf88ea0711c0f source-repository-package type: git diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index bffe288cf4..f3be6cbbdb 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -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 diff --git a/src/Simplex/Chat/Core.hs b/src/Simplex/Chat/Core.hs index 35f8cacdf5..24c5812f7e 100644 --- a/src/Simplex/Chat/Core.hs +++ b/src/Simplex/Chat/Core.hs @@ -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, vaccumOnMigration}} 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' vaccumOnMigration >>= either exit run confirm' = if confirmMigrations == MCConsole && yesToUpMigrations then MCYesUp else confirmMigrations exit e = do putStrLn $ "Error opening database: " <> show e diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index d790c5cd2c..a0243a5821 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/src/Simplex/Chat/Mobile.hs @@ -201,7 +201,8 @@ mobileChatOpts dbFilePrefix = logFile = Nothing, tbqSize = 1024, highlyAvailable = False, - yesToUpMigrations = False + yesToUpMigrations = False, + vaccumOnMigration = True }, deviceName = Nothing, chatCmd = "", @@ -245,7 +246,7 @@ chatMigrateInitKey dbFilePrefix dbKey keepKey confirm backgroundMode = runExcept newChatController db user_ defaultMobileConfig (mobileChatOpts dbFilePrefix) backgroundMode migrate createStore dbFile confirmMigrations = ExceptT $ - (first (DBMErrorMigration dbFile) <$> createStore dbFile dbKey keepKey confirmMigrations) + (first (DBMErrorMigration dbFile) <$> createStore dbFile dbKey keepKey confirmMigrations True) `catch` (pure . checkDBError) `catchAll` (pure . dbError) where diff --git a/src/Simplex/Chat/Options.hs b/src/Simplex/Chat/Options.hs index f398831194..367efce5a7 100644 --- a/src/Simplex/Chat/Options.hs +++ b/src/Simplex/Chat/Options.hs @@ -66,7 +66,8 @@ data CoreChatOpts = CoreChatOpts logFile :: Maybe FilePath, tbqSize :: Natural, highlyAvailable :: Bool, - yesToUpMigrations :: Bool + yesToUpMigrations :: Bool, + vaccumOnMigration :: 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, + vaccumOnMigration = not disableVacuum } where useTcpTimeout p t = 1000000 * if t > 0 then t else maybe 7 (const 15) p diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 58459e71e8..7ae1b4a32a 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -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 diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index c076ee3b4f..5070dd615a 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -106,7 +106,8 @@ testCoreOpts = logFile = Nothing, tbqSize = 16, highlyAvailable = False, - yesToUpMigrations = False + yesToUpMigrations = False, + vaccumOnMigration = True } getTestOpts :: Bool -> ScrubbedBytes -> ChatOpts @@ -248,14 +249,14 @@ 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 + Right db@ChatDatabase {chatStore, agentStore} <- createChatDatabase (tmp dbPrefix) dbKey False MCError True 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 + Right db@ChatDatabase {chatStore} <- createChatDatabase (tmp dbPrefix) dbKey False MCError True Just user <- find activeUser <$> withTransaction chatStore getUsers startTestChat_ db cfg opts user diff --git a/tests/MobileTests.hs b/tests/MobileTests.hs index 26e33cb469..905f927f37 100644 --- a/tests/MobileTests.hs +++ b/tests/MobileTests.hs @@ -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" diff --git a/tests/SchemaDump.hs b/tests/SchemaDump.hs index 8bbb68f3bf..a2794ca0f7 100644 --- a/tests/SchemaDump.hs +++ b/tests/SchemaDump.hs @@ -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'