From 206f7898c367389f1b1ab0a62b77ea6526156d85 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sat, 28 Dec 2024 22:14:06 +0000 Subject: [PATCH] cli: option to disable vacuum on migration (#5446) * cli: option to disable vacuum on migration * update simplexmq * mobile options * use option in test --- cabal.project | 2 +- scripts/nix/sha256map.nix | 2 +- src/Simplex/Chat.hs | 8 ++++---- src/Simplex/Chat/Core.hs | 4 ++-- src/Simplex/Chat/Mobile.hs | 8 +++++--- src/Simplex/Chat/Options.hs | 11 +++++++++-- src/Simplex/Chat/Store.hs | 2 +- tests/ChatClient.hs | 11 ++++++----- tests/MobileTests.hs | 2 +- tests/SchemaDump.hs | 12 ++++++------ 10 files changed, 36 insertions(+), 26 deletions(-) diff --git a/cabal.project b/cabal.project index c7a5c080b4..6ff20fadc9 100644 --- a/cabal.project +++ b/cabal.project @@ -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 diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index 803044f19c..5b01a3a330 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -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"; 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..8e40469d84 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, 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 diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index d790c5cd2c..f8b044676a 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, + 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 diff --git a/src/Simplex/Chat/Options.hs b/src/Simplex/Chat/Options.hs index f398831194..e034bd03f0 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, + 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 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..42f139f05d 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -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 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'