Skip to content

Commit 8a7991a

Browse files
epoberezkinepoberezkin
authored
agent: option to set SQLite database backup path (#1636)
* agent: option to set SQLite database backup path * fix test compilation
1 parent 7e98b31 commit 8a7991a

File tree

13 files changed

+56
-43
lines changed

13 files changed

+56
-43
lines changed

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -64,7 +64,7 @@ import Simplex.Messaging.Agent.RetryInterval
6464
import Simplex.Messaging.Agent.Store (createStore)
6565
import Simplex.Messaging.Agent.Store.Common (DBStore)
6666
import Simplex.Messaging.Agent.Store.Interface (DBOpts)
67-
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..))
67+
import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationError (..))
6868
import Simplex.Messaging.Client
6969
import qualified Simplex.Messaging.Crypto as C
7070
import Simplex.Messaging.Crypto.Ratchet (VersionRangeE2E, supportedE2EEncryptVRange)
@@ -266,7 +266,7 @@ newSMPAgentEnv config store = do
266266
multicastSubscribers <- newTMVarIO 0
267267
pure Env {config, store, random, randomServer, ntfSupervisor, xftpAgent, multicastSubscribers}
268268

269-
createAgentStore :: DBOpts -> MigrationConfirmation -> IO (Either MigrationError DBStore)
269+
createAgentStore :: DBOpts -> MigrationConfig -> IO (Either MigrationError DBStore)
270270
createAgentStore = createStore
271271

272272
data NtfSupervisor = NtfSupervisor

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -33,7 +33,7 @@ import Simplex.Messaging.Agent.Store.Entity
3333
import Simplex.Messaging.Agent.Store.Common
3434
import Simplex.Messaging.Agent.Store.Interface (createDBStore)
3535
import Simplex.Messaging.Agent.Store.Migrations.App (appMigrations)
36-
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..))
36+
import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationError (..))
3737
import qualified Simplex.Messaging.Crypto as C
3838
import Simplex.Messaging.Crypto.Ratchet (MsgEncryptKeyX448, PQEncryption, PQSupport, RatchetX448)
3939
import Simplex.Messaging.Encoding.String
@@ -55,7 +55,7 @@ import Simplex.Messaging.Protocol
5555
import qualified Simplex.Messaging.Protocol as SMP
5656
import Simplex.Messaging.Util (AnyError (..), bshow)
5757

58-
createStore :: DBOpts -> MigrationConfirmation -> IO (Either MigrationError DBStore)
58+
createStore :: DBOpts -> MigrationConfig -> IO (Either MigrationError DBStore)
5959
createStore dbOpts = createDBStore dbOpts appMigrations
6060

6161
-- * Queue types

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

Lines changed: 6 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -15,7 +15,7 @@ where
1515
import Control.Monad
1616
import Data.Char (toLower)
1717
import Data.Functor (($>))
18-
import Data.Maybe (isNothing, mapMaybe)
18+
import Data.Maybe (isJust, isNothing, mapMaybe)
1919
import Simplex.Messaging.Agent.Store.Shared
2020
import System.Exit (exitFailure)
2121
import System.IO (hFlush, stdout)
@@ -37,7 +37,7 @@ data DBMigrate = DBMigrate
3737
{ initialize :: IO (),
3838
getCurrent :: IO [Migration],
3939
run :: MigrationsToRun -> IO (),
40-
backup :: IO ()
40+
backup :: Maybe (IO ())
4141
}
4242

4343
sharedMigrateSchema :: DBMigrate -> Bool -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError ())
@@ -54,20 +54,20 @@ sharedMigrateSchema dbm dbNew' migrations confirmMigrations = do
5454
| otherwise -> case confirmMigrations of
5555
MCYesUp -> runWithBackup ms
5656
MCYesUpDown -> runWithBackup ms
57-
MCConsole -> confirm err >> runWithBackup ms
57+
MCConsole -> confirm' err >> runWithBackup ms
5858
MCError -> pure $ Left err
5959
where
6060
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)
6161
Right ms@(MTRDown dms) -> case confirmMigrations of
6262
MCYesUpDown -> runWithBackup ms
63-
MCConsole -> confirm err >> runWithBackup ms
63+
MCConsole -> confirm' err >> runWithBackup ms
6464
MCYesUp -> pure $ Left err
6565
MCError -> pure $ Left err
6666
where
6767
err = MEDowngrade $ map downName dms
6868
where
69-
runWithBackup ms = backup dbm >> run dbm ms $> Right ()
70-
confirm err = confirmOrExit $ migrationErrorDescription err
69+
runWithBackup ms = sequence (backup dbm) >> run dbm ms $> Right ()
70+
confirm' err = confirmOrExit $ migrationErrorDescription (isJust $ backup dbm) err
7171

7272
confirmOrExit :: String -> IO ()
7373
confirmOrExit s = do

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

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -30,15 +30,15 @@ import Simplex.Messaging.Agent.Store.Migrations (DBMigrate (..), sharedMigrateSc
3030
import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations
3131
import Simplex.Messaging.Agent.Store.Postgres.Common
3232
import qualified Simplex.Messaging.Agent.Store.Postgres.DB as DB
33-
import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationError (..))
33+
import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfig (..), MigrationError (..))
3434
import Simplex.Messaging.Util (ifM, safeDecodeUtf8)
3535
import System.Exit (exitFailure)
3636

3737
-- | Create a new Postgres DBStore with the given connection string, schema name and migrations.
3838
-- If passed schema does not exist in connectInfo database, it will be created.
3939
-- Applies necessary migrations to schema.
40-
createDBStore :: DBOpts -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore)
41-
createDBStore opts migrations confirmMigrations = do
40+
createDBStore :: DBOpts -> [Migration] -> MigrationConfig -> IO (Either MigrationError DBStore)
41+
createDBStore opts migrations MigrationConfig {confirm} = do
4242
st <- connectPostgresStore opts
4343
r <- migrateSchema st `onException` closeDBStore st
4444
case r of
@@ -48,8 +48,8 @@ createDBStore opts migrations confirmMigrations = do
4848
migrateSchema st =
4949
let initialize = Migrations.initialize st
5050
getCurrent = withTransaction st Migrations.getCurrentMigrations
51-
dbm = DBMigrate {initialize, getCurrent, run = Migrations.run st, backup = pure ()}
52-
in sharedMigrateSchema dbm (dbNew st) migrations confirmMigrations
51+
dbm = DBMigrate {initialize, getCurrent, run = Migrations.run st, backup = Nothing}
52+
in sharedMigrateSchema dbm (dbNew st) migrations confirm
5353

5454
connectPostgresStore :: DBOpts -> IO DBStore
5555
connectPostgresStore DBOpts {connstr, schema, poolSize, createSchema} = do

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

Lines changed: 9 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -57,18 +57,18 @@ import Simplex.Messaging.Agent.Store.Migrations (DBMigrate (..), sharedMigrateSc
5757
import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
5858
import Simplex.Messaging.Agent.Store.SQLite.Common
5959
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
60-
import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationError (..))
60+
import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfig (..), MigrationError (..))
6161
import Simplex.Messaging.Util (ifM, safeDecodeUtf8)
6262
import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
63-
import System.FilePath (takeDirectory)
63+
import System.FilePath (takeDirectory, takeFileName, (</>))
6464
import UnliftIO.Exception (bracketOnError, onException)
6565
import UnliftIO.MVar
6666
import UnliftIO.STM
6767

6868
-- * SQLite Store implementation
6969

70-
createDBStore :: DBOpts -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore)
71-
createDBStore DBOpts {dbFilePath, dbKey, keepKey, track, vacuum} migrations confirmMigrations = do
70+
createDBStore :: DBOpts -> [Migration] -> MigrationConfig -> IO (Either MigrationError DBStore)
71+
createDBStore DBOpts {dbFilePath, dbKey, keepKey, track, vacuum} migrations MigrationConfig {confirm, backupPath} = do
7272
let dbDir = takeDirectory dbFilePath
7373
createDirectoryIfMissing True dbDir
7474
st <- connectSQLiteStore dbFilePath dbKey keepKey track
@@ -81,9 +81,12 @@ createDBStore DBOpts {dbFilePath, dbKey, keepKey, track, vacuum} migrations conf
8181
let initialize = Migrations.initialize st
8282
getCurrent = withTransaction st Migrations.getCurrentMigrations
8383
run = Migrations.run st vacuum
84-
backup = copyFile dbFilePath (dbFilePath <> ".bak")
84+
backup = mkBackup <$> backupPath
85+
mkBackup bp =
86+
let f = if null bp then dbFilePath else bp </> takeFileName dbFilePath
87+
in copyFile dbFilePath $ f <> ".bak"
8588
dbm = DBMigrate {initialize, getCurrent, run, backup}
86-
in sharedMigrateSchema dbm (dbNew st) migrations confirmMigrations
89+
in sharedMigrateSchema dbm (dbNew st) migrations confirm
8790

8891
connectSQLiteStore :: FilePath -> ScrubbedBytes -> Bool -> DB.TrackQueries -> IO DBStore
8992
connectSQLiteStore dbFilePath key keepKey track = do

‎src/Simplex/Messaging/Agent/Store/Shared.hs‎

Lines changed: 12 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ module Simplex.Messaging.Agent.Store.Shared
99
DownMigration (..),
1010
MTRError (..),
1111
mtrErrorDescription,
12+
MigrationConfig (..),
1213
MigrationConfirmation (..),
1314
MigrationError (..),
1415
UpMigration (..),
@@ -55,20 +56,27 @@ data MigrationError
5556
| MigrationError {mtrError :: MTRError}
5657
deriving (Eq, Show)
5758

58-
migrationErrorDescription :: MigrationError -> String
59-
migrationErrorDescription = \case
59+
migrationErrorDescription :: Bool -> MigrationError -> String
60+
migrationErrorDescription withBackup = \case
6061
MEUpgrade ums ->
61-
"The app has a newer version than the database.\nConfirm to back up and upgrade using these migrations: " <> intercalate ", " (map upName ums)
62+
"The app has a newer version than the database.\nConfirm to " <> backupStr <> "upgrade using these migrations: " <> intercalate ", " (map upName ums)
6263
MEDowngrade dms ->
63-
"Database version is newer than the app.\nConfirm to back up and downgrade using these migrations: " <> intercalate ", " dms
64+
"Database version is newer than the app.\nConfirm to " <> backupStr <> "downgrade using these migrations: " <> intercalate ", " dms
6465
MigrationError err -> mtrErrorDescription err
66+
where
67+
backupStr = if withBackup then "back up and " else ""
6568

6669
data UpMigration = UpMigration {upName :: String, withDown :: Bool}
6770
deriving (Eq, Show)
6871

6972
upMigration :: Migration -> UpMigration
7073
upMigration Migration {name, down} = UpMigration name $ isJust down
7174

75+
data MigrationConfig = MigrationConfig
76+
{ confirm :: MigrationConfirmation,
77+
backupPath :: Maybe FilePath -- Nothing - no backup, empty string - the same folder
78+
}
79+
7280
data MigrationConfirmation = MCYesUp | MCYesUpDown | MCConsole | MCError
7381
deriving (Eq, Show)
7482

‎src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -55,6 +55,7 @@ import Simplex.Messaging.Agent.Store.AgentStore ()
5555
import Simplex.Messaging.Agent.Store.Postgres (closeDBStore, createDBStore)
5656
import Simplex.Messaging.Agent.Store.Postgres.Common
5757
import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder, fromTextField_)
58+
import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..))
5859
import Simplex.Messaging.Encoding
5960
import Simplex.Messaging.Encoding.String
6061
import qualified Simplex.Messaging.Crypto as C
@@ -98,7 +99,7 @@ data NtfEntityRec (e :: NtfEntity) where
9899

99100
newNtfDbStore :: PostgresStoreCfg -> IO NtfPostgresStore
100101
newNtfDbStore PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations, deletedTTL} = do
101-
dbStore <- either err pure =<< createDBStore dbOpts ntfServerMigrations confirmMigrations
102+
dbStore <- either err pure =<< createDBStore dbOpts ntfServerMigrations (MigrationConfig confirmMigrations Nothing)
102103
dbStoreLog <- mapM (openWriteStoreLog True) dbStoreLogPath
103104
pure NtfPostgresStore {dbStore, dbStoreLog, deletedTTL}
104105
where

‎src/Simplex/Messaging/Server/QueueStore/Postgres.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -70,6 +70,7 @@ import Simplex.Messaging.Agent.Store.AgentStore ()
7070
import Simplex.Messaging.Agent.Store.Postgres (createDBStore, closeDBStore)
7171
import Simplex.Messaging.Agent.Store.Postgres.Common
7272
import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder, fromTextField_)
73+
import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..))
7374
import qualified Simplex.Messaging.Crypto as C
7475
import Simplex.Messaging.Encoding
7576
import Simplex.Messaging.Parsers (parseAll)
@@ -112,7 +113,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
112113

113114
newQueueStore :: PostgresStoreCfg -> IO (PostgresQueueStore q)
114115
newQueueStore PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations, deletedTTL} = do
115-
dbStore <- either err pure =<< createDBStore dbOpts serverMigrations confirmMigrations
116+
dbStore <- either err pure =<< createDBStore dbOpts serverMigrations (MigrationConfig confirmMigrations Nothing)
116117
dbStoreLog <- mapM (openWriteStoreLog True) dbStoreLogPath
117118
queues <- TM.emptyIO
118119
senders <- TM.emptyIO

‎tests/AgentTests/FunctionalAPITests.hs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -90,7 +90,7 @@ import qualified Simplex.Messaging.Agent.Protocol as A
9090
import Simplex.Messaging.Agent.Store.Common (DBStore (..), withTransaction)
9191
import Simplex.Messaging.Agent.Store.Interface
9292
import qualified Simplex.Messaging.Agent.Store.DB as DB
93-
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..))
93+
import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..), MigrationError (..))
9494
import Simplex.Messaging.Client (pattern NRMInteractive, NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (..), defaultClientConfig)
9595
import qualified Simplex.Messaging.Crypto as C
9696
import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern IKPQOn, pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
@@ -3619,13 +3619,13 @@ getSMPAgentClient' clientId cfg' initServers dbPath = do
36193619

36203620
#if defined(dbPostgres)
36213621
createStore :: String -> IO (Either MigrationError DBStore)
3622-
createStore schema = createAgentStore (DBOpts testDBConnstr (B.pack schema) 1 True) MCError
3622+
createStore schema = createAgentStore (DBOpts testDBConnstr (B.pack schema) 1 True) (MigrationConfig MCError Nothing)
36233623

36243624
insertUser :: DBStore -> IO ()
36253625
insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users DEFAULT VALUES")
36263626
#else
36273627
createStore :: String -> IO (Either MigrationError DBStore)
3628-
createStore dbPath = createAgentStore (DBOpts dbPath "" False True DB.TQOff) MCError
3628+
createStore dbPath = createAgentStore (DBOpts dbPath "" False True DB.TQOff) (MigrationConfig MCError Nothing)
36293629

36303630
insertUser :: DBStore -> IO ()
36313631
insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users (user_id) VALUES (1)")

‎tests/AgentTests/MigrationTests.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -235,7 +235,7 @@ createStore randSuffix migrations confirmMigrations = do
235235
vacuum = True,
236236
track = DB.TQOff
237237
}
238-
createDBStore dbOpts migrations confirmMigrations
238+
createDBStore dbOpts migrations (MigrationConfig confirmMigrations Nothing)
239239

240240
cleanup :: Word32 -> IO ()
241241
cleanup randSuffix = removeFile (testDB randSuffix)

0 commit comments

Comments
 (0)