dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-03-30 16:26:02 +00:00
Code Issues Packages Projects Releases Wiki Activity

agent: option to enable/disable vacuum after SQLite migration (#1429)

Browse Source
This commit is contained in:
Evgeny
2024-12-28 21:06:42 +00:00
committed by GitHub
parent 3cf9dacbc0
commit 992b42e922
11 changed files with 43 additions and 41 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/Simplex/Messaging/Agent/Env/SQLite.hs
View File

@@ -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

14
src/Simplex/Messaging/Agent/Store.hs
View File

@@ -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

24
src/Simplex/Messaging/Agent/Store/Migrations.hs
View File

@@ -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

2
src/Simplex/Messaging/Agent/Store/Postgres.hs
View File

@@ -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

4
src/Simplex/Messaging/Agent/Store/Postgres/Migrations.hs
View File

@@ -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

6
src/Simplex/Messaging/Agent/Store/SQLite.hs
View File

@@ -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

8
src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs
View File

@@ -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

2
tests/AgentTests/FunctionalAPITests.hs
View File

@@ -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)")

2
tests/AgentTests/MigrationTests.hs
View File

@@ -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)

2
tests/AgentTests/SQLiteTests.hs
View File

@@ -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

18
tests/AgentTests/SchemaDump.hs
View File

@@ -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'