agent: option to enable/disable vacuum after SQLite migration

Author: epoberezkin

src/Simplex/Messaging/Agent/Env/SQLite.hs

@@ -281,7 +281,7 @@ newSMPAgentEnv config store = do
 createAgentStore :: ConnectInfo -> String -> MigrationConfirmation -> IO (Either MigrationError DBStore)
 createAgentStore = createStore
 #else
-createAgentStore :: FilePath -> ScrubbedBytes -> Bool -> MigrationConfirmation -> IO (Either MigrationError DBStore)
+createAgentStore :: FilePath -> ScrubbedBytes -> Bool -> MigrationConfirmation -> Bool -> IO (Either MigrationError DBStore)
 createAgentStore = createStore
 #endif
 

src/Simplex/Messaging/Agent/Store.hs

@@ -56,25 +56,25 @@ import Simplex.Messaging.Protocol
 import qualified Simplex.Messaging.Protocol as SMP
 #if defined(dbPostgres)
 import Database.PostgreSQL.Simple (ConnectInfo (..))
-import qualified Simplex.Messaging.Agent.Store.Postgres as StoreFunctions
+import qualified Simplex.Messaging.Agent.Store.Postgres as Store
 #else
 import Data.ByteArray (ScrubbedBytes)
-import qualified Simplex.Messaging.Agent.Store.SQLite as StoreFunctions
+import qualified Simplex.Messaging.Agent.Store.SQLite as Store
 #endif
 
 #if defined(dbPostgres)
 createStore :: ConnectInfo -> String -> MigrationConfirmation -> IO (Either MigrationError DBStore)
-createStore connectInfo schema = StoreFunctions.createDBStore connectInfo schema Migrations.app
+createStore connectInfo schema = Store.createDBStore connectInfo schema Migrations.app
 #else
-createStore :: FilePath -> ScrubbedBytes -> Bool -> MigrationConfirmation -> IO (Either MigrationError DBStore)
-createStore dbFilePath dbKey keepKey = StoreFunctions.createDBStore dbFilePath dbKey keepKey Migrations.app
+createStore :: FilePath -> ScrubbedBytes -> Bool -> MigrationConfirmation -> Bool -> IO (Either MigrationError DBStore)
+createStore dbFilePath dbKey keepKey = Store.createDBStore dbFilePath dbKey keepKey Migrations.app
 #endif
 
 closeStore :: DBStore -> IO ()
-closeStore = StoreFunctions.closeDBStore
+closeStore = Store.closeDBStore
 
 execSQL :: DB.Connection -> Text -> IO [Text]
-execSQL = StoreFunctions.execSQL
+execSQL = Store.execSQL
 
 -- * Queue types
 

src/Simplex/Messaging/Agent/Store/Migrations.hs

@@ -48,41 +48,41 @@ migrationsToRun (a : as) (d : ds)
   | name a == name d = migrationsToRun as ds
   | otherwise = Left $ MTREDifferent (name a) (name d)
 
-migrateSchema :: DBStore -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError ())
-migrateSchema st migrations confirmMigrations = do
+migrateSchema :: DBStore -> [Migration] -> MigrationConfirmation -> Bool -> IO (Either MigrationError ())
+migrateSchema st migrations confirmMigrations vacuum = do
   Migrations.initialize st
   get st migrations >>= \case
     Left e -> do
       when (confirmMigrations == MCConsole) $ confirmOrExit ("Database state error: " <> mtrErrorDescription e)
       pure . Left $ MigrationError e
     Right MTRNone -> pure $ Right ()
     Right ms@(MTRUp ums)
-      | dbNew st -> Migrations.run st ms $> Right ()
+      | dbNew st -> Migrations.run st vacuum ms $> Right ()
       | otherwise -> case confirmMigrations of
-          MCYesUp -> runWithBackup st ms
-          MCYesUpDown -> runWithBackup st ms
-          MCConsole -> confirm err >> runWithBackup st ms
+          MCYesUp -> runWithBackup st vacuum ms
+          MCYesUpDown -> runWithBackup st vacuum ms
+          MCConsole -> confirm err >> runWithBackup st vacuum ms
           MCError -> pure $ Left err
       where
         err = MEUpgrade $ map upMigration ums -- "The app has a newer version than the database.\nConfirm to back up and upgrade using these migrations: " <> intercalate ", " (map name ums)
     Right ms@(MTRDown dms) -> case confirmMigrations of
-      MCYesUpDown -> runWithBackup st ms
-      MCConsole -> confirm err >> runWithBackup st ms
+      MCYesUpDown -> runWithBackup st vacuum ms
+      MCConsole -> confirm err >> runWithBackup st vacuum ms
       MCYesUp -> pure $ Left err
       MCError -> pure $ Left err
       where
         err = MEDowngrade $ map downName dms
   where
     confirm err = confirmOrExit $ migrationErrorDescription err
 
-runWithBackup :: DBStore -> MigrationsToRun -> IO (Either a ())
+runWithBackup :: DBStore -> Bool -> MigrationsToRun -> IO (Either a ())
 #if defined(dbPostgres)
-runWithBackup st ms = Migrations.run st ms $> Right ()
+runWithBackup st vacuum ms = Migrations.run st vacuum ms $> Right ()
 #else
-runWithBackup st ms = do
+runWithBackup st vacuum ms = do
   let f = dbFilePath st
   copyFile f (f <> ".bak")
-  Migrations.run st ms
+  Migrations.run st vacuum ms
   pure $ Right ()
 #endif
 

src/Simplex/Messaging/Agent/Store/Postgres.hs

@@ -46,7 +46,7 @@ createDBStore :: ConnectInfo -> String -> [Migration] -> MigrationConfirmation -
 createDBStore connectInfo schema migrations confirmMigrations = do
   createDBAndUserIfNotExists connectInfo
   st <- connectPostgresStore connectInfo schema
-  r <- migrateSchema st migrations confirmMigrations `onException` closeDBStore st
+  r <- migrateSchema st migrations confirmMigrations True `onException` closeDBStore st
   case r of
     Right () -> pure $ Right st
     Left e -> closeDBStore st $> Left e

src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs

@@ -53,8 +53,8 @@ initialize st = withTransaction' st $ \db ->
       )
     |]
 
-run :: DBStore -> MigrationsToRun -> IO ()
-run st = \case
+run :: DBStore -> Bool -> MigrationsToRun -> IO ()
+run st _vacuum = \case
   MTRUp [] -> pure ()
   MTRUp ms -> mapM_ runUp ms
   MTRDown ms -> mapM_ runDown $ reverse ms

src/Simplex/Messaging/Agent/Store/SQLite.hs

@@ -65,12 +65,12 @@ import UnliftIO.STM
 
 -- * SQLite Store implementation
 
-createDBStore :: FilePath -> ScrubbedBytes -> Bool -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore)
-createDBStore dbFilePath dbKey keepKey migrations confirmMigrations = do
+createDBStore :: FilePath -> ScrubbedBytes -> Bool -> [Migration] -> MigrationConfirmation -> Bool -> IO (Either MigrationError DBStore)
+createDBStore dbFilePath dbKey keepKey migrations confirmMigrations vacuum = do
   let dbDir = takeDirectory dbFilePath
   createDirectoryIfMissing True dbDir
   st <- connectSQLiteStore dbFilePath dbKey keepKey
-  r <- migrateSchema st migrations confirmMigrations `onException` closeDBStore st
+  r <- migrateSchema st migrations confirmMigrations vacuum `onException` closeDBStore st
   case r of
     Right () -> pure $ Right st
     Left e -> closeDBStore st $> Left e

src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs

@@ -122,10 +122,12 @@ getCurrent DB.Connection {DB.conn} = map toMigration <$> SQL.query_ conn "SELECT
   where
     toMigration (name, down) = Migration {name, up = "", down}
 
-run :: DBStore -> MigrationsToRun -> IO ()
-run st = \case
+run :: DBStore -> Bool -> MigrationsToRun -> IO ()
+run st vacuum = \case
   MTRUp [] -> pure ()
-  MTRUp ms -> mapM_ runUp ms >> withConnection' st (`execSQL` "VACUUM;")
+  MTRUp ms -> do
+    mapM_ runUp ms
+    when vacuum $ withConnection' st (`execSQL` "VACUUM;")
   MTRDown ms -> mapM_ runDown $ reverse ms
   MTRNone -> pure ()
   where

tests/AgentTests/FunctionalAPITests.hs

@@ -3113,7 +3113,7 @@ insertUser :: DBStore -> IO ()
 insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users DEFAULT VALUES")
 #else
 createStore :: String -> IO (Either MigrationError DBStore)
-createStore dbPath = createAgentStore dbPath "" False MCError
+createStore dbPath = createAgentStore dbPath "" False MCError True
 
 insertUser :: DBStore -> IO ()
 insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users (user_id) VALUES (1)")

tests/AgentTests/MigrationTests.hs

@@ -218,7 +218,7 @@ testDB :: Word32 -> FilePath
 testDB randSuffix = "tests/tmp/test_migrations.db" <> show randSuffix
 
 createStore :: Word32 -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore)
-createStore randSuffix = createDBStore (testDB randSuffix) "" False
+createStore randSuffix migrations migrationConf = createDBStore (testDB randSuffix) "" False migrations migrationConf True
 
 cleanup :: Word32 -> IO ()
 cleanup randSuffix = removeFile (testDB randSuffix)

tests/AgentTests/SQLiteTests.hs

@@ -81,7 +81,7 @@ createEncryptedStore key keepKey = do
   -- Randomize DB file name to avoid SQLite IO errors supposedly caused by asynchronous
   -- IO operations on multiple similarly named files; error seems to be environment specific
   r <- randomIO :: IO Word32
-  Right st <- createDBStore (testDB <> show r) key keepKey Migrations.app MCError
+  Right st <- createDBStore (testDB <> show r) key keepKey Migrations.app MCError True
   withTransaction' st (`SQL.execute_` "INSERT INTO users (user_id) VALUES (1);")
   pure st
 

tests/AgentTests/SchemaDump.hs

@@ -49,15 +49,15 @@ testVerifySchemaDump :: IO ()
 testVerifySchemaDump = do
   savedSchema <- ifM (doesFileExist appSchema) (readFile appSchema) (pure "")
   savedSchema `deepseq` pure ()
-  void $ createDBStore testDB "" False Migrations.app MCConsole
+  void $ createDBStore testDB "" False Migrations.app MCConsole True
   getSchema testDB appSchema `shouldReturn` savedSchema
   removeFile testDB
 
 testVerifyLintFKeyIndexes :: IO ()
 testVerifyLintFKeyIndexes = do
   savedLint <- ifM (doesFileExist appLint) (readFile appLint) (pure "")
   savedLint `deepseq` pure ()
-  void $ createDBStore testDB "" False Migrations.app MCConsole
+  void $ createDBStore testDB "" False Migrations.app MCConsole True
   getLintFKeyIndexes testDB "tests/tmp/agent_lint.sql" `shouldReturn` savedLint
   removeFile testDB
 
@@ -70,7 +70,7 @@ withTmpFiles =
 testSchemaMigrations :: IO ()
 testSchemaMigrations = do
   let noDownMigrations = dropWhileEnd (\Migration {down} -> isJust down) Migrations.app
-  Right st <- createDBStore testDB "" False noDownMigrations MCError
+  Right st <- createDBStore testDB "" False noDownMigrations MCError True
   mapM_ (testDownMigration st) $ drop (length noDownMigrations) Migrations.app
   closeDBStore st
   removeFile testDB
@@ -80,32 +80,32 @@ testSchemaMigrations = 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'
 
 testUsersMigrationNew :: IO ()
 testUsersMigrationNew = do
-  Right st <- createDBStore testDB "" False Migrations.app MCError
+  Right st <- createDBStore testDB "" False Migrations.app MCError True
   withTransaction' st (`SQL.query_` "SELECT user_id FROM users;")
     `shouldReturn` ([] :: [Only Int])
   closeDBStore st
 
 testUsersMigrationOld :: IO ()
 testUsersMigrationOld = do
   let beforeUsers = takeWhile (("m20230110_users" /=) . name) Migrations.app
-  Right st <- createDBStore testDB "" False beforeUsers MCError
+  Right st <- createDBStore testDB "" False beforeUsers MCError True
   withTransaction' st (`SQL.query_` "SELECT name FROM sqlite_master WHERE type = 'table' AND name = 'users';")
     `shouldReturn` ([] :: [Only String])
   closeDBStore st
-  Right st' <- createDBStore testDB "" False Migrations.app MCYesUp
+  Right st' <- createDBStore testDB "" False Migrations.app MCYesUp True
   withTransaction' st' (`SQL.query_` "SELECT user_id FROM users;")
     `shouldReturn` ([Only (1 :: Int)])
   closeDBStore st'