From 992b42e92224ec663684923aaa40ed1f9a683f61 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sat, 28 Dec 2024 21:06:42 +0000 Subject: [PATCH] agent: option to enable/disable vacuum after SQLite migration (#1429) --- src/Simplex/Messaging/Agent/Env/SQLite.hs | 2 +- src/Simplex/Messaging/Agent/Store.hs | 14 +++++------ .../Messaging/Agent/Store/Migrations.hs | 24 +++++++++---------- src/Simplex/Messaging/Agent/Store/Postgres.hs | 2 +- .../Agent/Store/Postgres/Migrations.hs | 4 ++-- src/Simplex/Messaging/Agent/Store/SQLite.hs | 6 ++--- .../Agent/Store/SQLite/Migrations.hs | 8 ++++--- tests/AgentTests/FunctionalAPITests.hs | 2 +- tests/AgentTests/MigrationTests.hs | 2 +- tests/AgentTests/SQLiteTests.hs | 2 +- tests/AgentTests/SchemaDump.hs | 18 +++++++------- 11 files changed, 43 insertions(+), 41 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index 80a307efa..f1e0aaf15 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/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 diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index c199e480b..ff8c29b6c 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/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 diff --git a/src/Simplex/Messaging/Agent/Store/Migrations.hs b/src/Simplex/Messaging/Agent/Store/Migrations.hs index 35015f634..7dc1528f1 100644 --- a/src/Simplex/Messaging/Agent/Store/Migrations.hs +++ b/src/Simplex/Messaging/Agent/Store/Migrations.hs @@ -48,8 +48,8 @@ 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 @@ -57,17 +57,17 @@ migrateSchema st migrations confirmMigrations = do 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 @@ -75,14 +75,14 @@ migrateSchema st migrations confirmMigrations = do 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 diff --git a/src/Simplex/Messaging/Agent/Store/Postgres.hs b/src/Simplex/Messaging/Agent/Store/Postgres.hs index a4c8a52bb..897c31965 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres.hs +++ b/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 diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs index bf8d56caa..9f8d5744d 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs +++ b/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 diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 816968208..4e03bb6f3 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/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 diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs index 2f3c6010e..73ab17e5a 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs +++ b/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 diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 9c3c5a972..f569cc3d5 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/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)") diff --git a/tests/AgentTests/MigrationTests.hs b/tests/AgentTests/MigrationTests.hs index fb8550a7d..9bbb41be1 100644 --- a/tests/AgentTests/MigrationTests.hs +++ b/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) diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 3fb791af6..51112c426 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/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 diff --git a/tests/AgentTests/SchemaDump.hs b/tests/AgentTests/SchemaDump.hs index b7fcce8ee..ba81bc79c 100644 --- a/tests/AgentTests/SchemaDump.hs +++ b/tests/AgentTests/SchemaDump.hs @@ -49,7 +49,7 @@ 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 @@ -57,7 +57,7 @@ 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,20 +80,20 @@ 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 @@ -101,11 +101,11 @@ testUsersMigrationNew = do 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'