cli: option to disable vacuum on migration

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

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

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

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

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

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

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
 

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"

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'