agent: option to set SQLite database backup path (#1636)

* agent: option to set SQLite database backup path

* fix test compilation

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

@@ -64,7 +64,7 @@ import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Store (createStore)
 import Simplex.Messaging.Agent.Store.Common (DBStore)
 import Simplex.Messaging.Agent.Store.Interface (DBOpts)
-import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..))
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationError (..))
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (VersionRangeE2E, supportedE2EEncryptVRange)
@@ -266,7 +266,7 @@ newSMPAgentEnv config store = do
   multicastSubscribers <- newTMVarIO 0
   pure Env {config, store, random, randomServer, ntfSupervisor, xftpAgent, multicastSubscribers}
 
-createAgentStore :: DBOpts -> MigrationConfirmation -> IO (Either MigrationError DBStore)
+createAgentStore :: DBOpts -> MigrationConfig -> IO (Either MigrationError DBStore)
 createAgentStore = createStore
 
 data NtfSupervisor = NtfSupervisor

src/Simplex/Messaging/Agent/Store.hs

@@ -33,7 +33,7 @@ import Simplex.Messaging.Agent.Store.Entity
 import Simplex.Messaging.Agent.Store.Common
 import Simplex.Messaging.Agent.Store.Interface (createDBStore)
 import Simplex.Messaging.Agent.Store.Migrations.App (appMigrations)
-import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..))
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationError (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (MsgEncryptKeyX448, PQEncryption, PQSupport, RatchetX448)
 import Simplex.Messaging.Encoding.String
@@ -55,7 +55,7 @@ import Simplex.Messaging.Protocol
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Util (AnyError (..), bshow)
 
-createStore :: DBOpts -> MigrationConfirmation -> IO (Either MigrationError DBStore)
+createStore :: DBOpts -> MigrationConfig -> IO (Either MigrationError DBStore)
 createStore dbOpts = createDBStore dbOpts appMigrations
 
 -- * Queue types

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

@@ -15,7 +15,7 @@ where
 import Control.Monad
 import Data.Char (toLower)
 import Data.Functor (($>))
-import Data.Maybe (isNothing, mapMaybe)
+import Data.Maybe (isJust, isNothing, mapMaybe)
 import Simplex.Messaging.Agent.Store.Shared
 import System.Exit (exitFailure)
 import System.IO (hFlush, stdout)
@@ -37,7 +37,7 @@ data DBMigrate = DBMigrate
   { initialize :: IO (),
     getCurrent :: IO [Migration],
     run :: MigrationsToRun -> IO (),
-    backup :: IO ()
+    backup :: Maybe (IO ())
   }
 
 sharedMigrateSchema :: DBMigrate -> Bool -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError ())
@@ -54,20 +54,20 @@ sharedMigrateSchema dbm dbNew' migrations confirmMigrations = do
       | otherwise -> case confirmMigrations of
           MCYesUp -> runWithBackup ms
           MCYesUpDown -> runWithBackup ms
-          MCConsole -> confirm err >> runWithBackup ms
+          MCConsole -> confirm' err >> runWithBackup 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 ms
-      MCConsole -> confirm err >> runWithBackup ms
+      MCConsole -> confirm' err >> runWithBackup ms
       MCYesUp -> pure $ Left err
       MCError -> pure $ Left err
       where
         err = MEDowngrade $ map downName dms
   where
-    runWithBackup ms = backup dbm >> run dbm ms $> Right ()
-    confirm err = confirmOrExit $ migrationErrorDescription err
+    runWithBackup ms = sequence (backup dbm) >> run dbm ms $> Right ()
+    confirm' err = confirmOrExit $ migrationErrorDescription (isJust $ backup dbm) err
 
 confirmOrExit :: String -> IO ()
 confirmOrExit s = do

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

@@ -30,15 +30,15 @@ import Simplex.Messaging.Agent.Store.Migrations (DBMigrate (..), sharedMigrateSc
 import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations
 import Simplex.Messaging.Agent.Store.Postgres.Common
 import qualified Simplex.Messaging.Agent.Store.Postgres.DB as DB
-import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationError (..))
+import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfig (..), MigrationError (..))
 import Simplex.Messaging.Util (ifM, safeDecodeUtf8)
 import System.Exit (exitFailure)
 
 -- | Create a new Postgres DBStore with the given connection string, schema name and migrations.
 -- If passed schema does not exist in connectInfo database, it will be created.
 -- Applies necessary migrations to schema.
-createDBStore :: DBOpts -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore)
-createDBStore opts migrations confirmMigrations = do
+createDBStore :: DBOpts -> [Migration] -> MigrationConfig -> IO (Either MigrationError DBStore)
+createDBStore opts migrations MigrationConfig {confirm} = do
   st <- connectPostgresStore opts
   r <- migrateSchema st `onException` closeDBStore st
   case r of
@@ -48,8 +48,8 @@ createDBStore opts migrations confirmMigrations = do
     migrateSchema st =
       let initialize = Migrations.initialize st
           getCurrent = withTransaction st Migrations.getCurrentMigrations
-          dbm = DBMigrate {initialize, getCurrent, run = Migrations.run st, backup = pure ()}
-       in sharedMigrateSchema dbm (dbNew st) migrations confirmMigrations
+          dbm = DBMigrate {initialize, getCurrent, run = Migrations.run st, backup = Nothing}
+       in sharedMigrateSchema dbm (dbNew st) migrations confirm
 
 connectPostgresStore :: DBOpts -> IO DBStore
 connectPostgresStore DBOpts {connstr, schema, poolSize, createSchema} = do

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

@@ -57,18 +57,18 @@ import Simplex.Messaging.Agent.Store.Migrations (DBMigrate (..), sharedMigrateSc
 import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
 import Simplex.Messaging.Agent.Store.SQLite.Common
 import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
-import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationError (..))
+import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfig (..), MigrationError (..))
 import Simplex.Messaging.Util (ifM, safeDecodeUtf8)
 import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
-import System.FilePath (takeDirectory)
+import System.FilePath (takeDirectory, takeFileName, (</>))
 import UnliftIO.Exception (bracketOnError, onException)
 import UnliftIO.MVar
 import UnliftIO.STM
 
 -- * SQLite Store implementation
 
-createDBStore :: DBOpts -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError DBStore)
-createDBStore DBOpts {dbFilePath, dbKey, keepKey, track, vacuum} migrations confirmMigrations = do
+createDBStore :: DBOpts -> [Migration] -> MigrationConfig -> IO (Either MigrationError DBStore)
+createDBStore DBOpts {dbFilePath, dbKey, keepKey, track, vacuum} migrations MigrationConfig {confirm, backupPath} = do
   let dbDir = takeDirectory dbFilePath
   createDirectoryIfMissing True dbDir
   st <- connectSQLiteStore dbFilePath dbKey keepKey track
@@ -81,9 +81,12 @@ createDBStore DBOpts {dbFilePath, dbKey, keepKey, track, vacuum} migrations conf
       let initialize = Migrations.initialize st
           getCurrent = withTransaction st Migrations.getCurrentMigrations
           run = Migrations.run st vacuum
-          backup = copyFile dbFilePath (dbFilePath <> ".bak")
+          backup = mkBackup <$> backupPath
+          mkBackup bp =
+            let f = if null bp then dbFilePath else bp </> takeFileName dbFilePath
+             in copyFile dbFilePath $ f <> ".bak"
           dbm = DBMigrate {initialize, getCurrent, run, backup}
-       in sharedMigrateSchema dbm (dbNew st) migrations confirmMigrations
+       in sharedMigrateSchema dbm (dbNew st) migrations confirm
 
 connectSQLiteStore :: FilePath -> ScrubbedBytes -> Bool -> DB.TrackQueries -> IO DBStore
 connectSQLiteStore dbFilePath key keepKey track = do

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

@@ -9,6 +9,7 @@ module Simplex.Messaging.Agent.Store.Shared
     DownMigration (..),
     MTRError (..),
     mtrErrorDescription,
+    MigrationConfig (..),
     MigrationConfirmation (..),
     MigrationError (..),
     UpMigration (..),
@@ -55,13 +56,15 @@ data MigrationError
   | MigrationError {mtrError :: MTRError}
   deriving (Eq, Show)
 
-migrationErrorDescription :: MigrationError -> String
-migrationErrorDescription = \case
+migrationErrorDescription :: Bool -> MigrationError -> String
+migrationErrorDescription withBackup = \case
   MEUpgrade ums ->
-    "The app has a newer version than the database.\nConfirm to back up and upgrade using these migrations: " <> intercalate ", " (map upName ums)
+    "The app has a newer version than the database.\nConfirm to " <> backupStr <> "upgrade using these migrations: " <> intercalate ", " (map upName ums)
   MEDowngrade dms ->
-    "Database version is newer than the app.\nConfirm to back up and downgrade using these migrations: " <> intercalate ", " dms
+    "Database version is newer than the app.\nConfirm to " <> backupStr <> "downgrade using these migrations: " <> intercalate ", " dms
   MigrationError err -> mtrErrorDescription err
+  where
+    backupStr = if withBackup then "back up and " else ""
 
 data UpMigration = UpMigration {upName :: String, withDown :: Bool}
   deriving (Eq, Show)
@@ -69,6 +72,11 @@ data UpMigration = UpMigration {upName :: String, withDown :: Bool}
 upMigration :: Migration -> UpMigration
 upMigration Migration {name, down} = UpMigration name $ isJust down
 
+data MigrationConfig = MigrationConfig
+  { confirm :: MigrationConfirmation,
+    backupPath :: Maybe FilePath -- Nothing - no backup, empty string - the same folder
+  }
+
 data MigrationConfirmation = MCYesUp | MCYesUpDown | MCConsole | MCError
   deriving (Eq, Show)
 

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

@@ -55,6 +55,7 @@ import Simplex.Messaging.Agent.Store.AgentStore ()
 import Simplex.Messaging.Agent.Store.Postgres (closeDBStore, createDBStore)
 import Simplex.Messaging.Agent.Store.Postgres.Common
 import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder, fromTextField_)
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..))
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import qualified Simplex.Messaging.Crypto as C
@@ -98,7 +99,7 @@ data NtfEntityRec (e :: NtfEntity) where
 
 newNtfDbStore :: PostgresStoreCfg -> IO NtfPostgresStore
 newNtfDbStore PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations, deletedTTL} = do
-  dbStore <- either err pure =<< createDBStore dbOpts ntfServerMigrations confirmMigrations
+  dbStore <- either err pure =<< createDBStore dbOpts ntfServerMigrations (MigrationConfig confirmMigrations Nothing)
   dbStoreLog <- mapM (openWriteStoreLog True) dbStoreLogPath
   pure NtfPostgresStore {dbStore, dbStoreLog, deletedTTL}
   where

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

@@ -70,6 +70,7 @@ import Simplex.Messaging.Agent.Store.AgentStore ()
 import Simplex.Messaging.Agent.Store.Postgres (createDBStore, closeDBStore)
 import Simplex.Messaging.Agent.Store.Postgres.Common
 import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder, fromTextField_)
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Parsers (parseAll)
@@ -112,7 +113,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
 
   newQueueStore :: PostgresStoreCfg  -> IO (PostgresQueueStore q)
   newQueueStore PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations, deletedTTL} = do
-    dbStore <- either err pure =<< createDBStore dbOpts serverMigrations confirmMigrations
+    dbStore <- either err pure =<< createDBStore dbOpts serverMigrations (MigrationConfig confirmMigrations Nothing)
     dbStoreLog <- mapM (openWriteStoreLog True) dbStoreLogPath
     queues <- TM.emptyIO
     senders <- TM.emptyIO

tests/AgentTests/FunctionalAPITests.hs

@@ -90,7 +90,7 @@ import qualified Simplex.Messaging.Agent.Protocol as A
 import Simplex.Messaging.Agent.Store.Common (DBStore (..), withTransaction)
 import Simplex.Messaging.Agent.Store.Interface
 import qualified Simplex.Messaging.Agent.Store.DB as DB
-import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..))
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..), MigrationError (..))
 import Simplex.Messaging.Client (pattern NRMInteractive, NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (..), defaultClientConfig)
 import qualified Simplex.Messaging.Crypto as C
 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
 
 #if defined(dbPostgres)
 createStore :: String -> IO (Either MigrationError DBStore)
-createStore schema = createAgentStore (DBOpts testDBConnstr (B.pack schema) 1 True) MCError
+createStore schema = createAgentStore (DBOpts testDBConnstr (B.pack schema) 1 True) (MigrationConfig MCError Nothing)
 
 insertUser :: DBStore -> IO ()
 insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users DEFAULT VALUES")
 #else
 createStore :: String -> IO (Either MigrationError DBStore)
-createStore dbPath = createAgentStore (DBOpts dbPath "" False True DB.TQOff) MCError
+createStore dbPath = createAgentStore (DBOpts dbPath "" False True DB.TQOff) (MigrationConfig MCError Nothing)
 
 insertUser :: DBStore -> IO ()
 insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users (user_id) VALUES (1)")

tests/AgentTests/MigrationTests.hs

@@ -235,7 +235,7 @@ createStore randSuffix migrations confirmMigrations = do
           vacuum = True,
           track = DB.TQOff
         }
-  createDBStore dbOpts migrations confirmMigrations
+  createDBStore dbOpts migrations (MigrationConfig confirmMigrations Nothing)
 
 cleanup :: Word32 -> IO ()
 cleanup randSuffix = removeFile (testDB randSuffix)

tests/AgentTests/SQLiteTests.hs

@@ -46,7 +46,7 @@ import Simplex.Messaging.Agent.Store.Migrations.App (appMigrations)
 import Simplex.Messaging.Agent.Store.SQLite
 import Simplex.Messaging.Agent.Store.SQLite.Common (DBStore (..), withTransaction')
 import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
-import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.File (CryptoFile (..))
 import Simplex.Messaging.Crypto.Ratchet (pattern IKPQOn)
@@ -83,7 +83,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 (DBOpts (testDB <> show r) key keepKey True DB.TQOff) appMigrations MCError
+  Right st <- createDBStore (DBOpts (testDB <> show r) key keepKey True DB.TQOff) appMigrations (MigrationConfig MCError Nothing)
   withTransaction' st (`SQL.execute_` "INSERT INTO users (user_id) VALUES (1);")
   pure st
 

tests/AgentTests/SchemaDump.hs

@@ -14,7 +14,7 @@ import Simplex.Messaging.Agent.Store.SQLite
 import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction')
 import Simplex.Messaging.Agent.Store.SQLite.DB (TrackQueries (..))
 import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
-import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration)
+import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfig (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration)
 import Simplex.Messaging.Util (ifM)
 import System.Directory (doesFileExist, removeFile)
 import System.Process (readCreateProcess, shell)
@@ -51,7 +51,7 @@ testVerifySchemaDump :: IO ()
 testVerifySchemaDump = do
   savedSchema <- ifM (doesFileExist appSchema) (readFile appSchema) (pure "")
   savedSchema `deepseq` pure ()
-  void $ createDBStore (DBOpts testDB "" False True TQOff) appMigrations MCConsole
+  void $ createDBStore (DBOpts testDB "" False True TQOff) appMigrations (MigrationConfig MCConsole Nothing)
   getSchema testDB appSchema `shouldReturn` savedSchema
   removeFile testDB
 
@@ -59,14 +59,14 @@ testVerifyLintFKeyIndexes :: IO ()
 testVerifyLintFKeyIndexes = do
   savedLint <- ifM (doesFileExist appLint) (readFile appLint) (pure "")
   savedLint `deepseq` pure ()
-  void $ createDBStore (DBOpts testDB "" False True TQOff) appMigrations MCConsole
+  void $ createDBStore (DBOpts testDB "" False True TQOff) appMigrations (MigrationConfig MCConsole Nothing)
   getLintFKeyIndexes testDB "tests/tmp/agent_lint.sql" `shouldReturn` savedLint
   removeFile testDB
 
 testSchemaMigrations :: IO ()
 testSchemaMigrations = do
   let noDownMigrations = dropWhileEnd (\Migration {down} -> isJust down) appMigrations
-  Right st <- createDBStore (DBOpts testDB "" False True TQOff) noDownMigrations MCError
+  Right st <- createDBStore (DBOpts testDB "" False True TQOff) noDownMigrations (MigrationConfig MCError Nothing)
   mapM_ (testDownMigration st) $ drop (length noDownMigrations) appMigrations
   closeDBStore st
   removeFile testDB
@@ -89,7 +89,7 @@ testSchemaMigrations = do
 
 testUsersMigrationNew :: IO ()
 testUsersMigrationNew = do
-  Right st <- createDBStore (DBOpts testDB "" False True TQOff) appMigrations MCError
+  Right st <- createDBStore (DBOpts testDB "" False True TQOff) appMigrations (MigrationConfig MCError Nothing)
   withTransaction' st (`SQL.query_` "SELECT user_id FROM users;")
     `shouldReturn` ([] :: [Only Int])
   closeDBStore st
@@ -97,11 +97,11 @@ testUsersMigrationNew = do
 testUsersMigrationOld :: IO ()
 testUsersMigrationOld = do
   let beforeUsers = takeWhile (("m20230110_users" /=) . name) appMigrations
-  Right st <- createDBStore (DBOpts testDB "" False True TQOff) beforeUsers MCError
+  Right st <- createDBStore (DBOpts testDB "" False True TQOff) beforeUsers (MigrationConfig MCError Nothing)
   withTransaction' st (`SQL.query_` "SELECT name FROM sqlite_master WHERE type = 'table' AND name = 'users';")
     `shouldReturn` ([] :: [Only String])
   closeDBStore st
-  Right st' <- createDBStore (DBOpts testDB "" False True TQOff) appMigrations MCYesUp
+  Right st' <- createDBStore (DBOpts testDB "" False True TQOff) appMigrations (MigrationConfig MCYesUp Nothing)
   withTransaction' st' (`SQL.query_` "SELECT user_id FROM users;")
     `shouldReturn` ([Only (1 :: Int)])
   closeDBStore st'

tests/PostgresSchemaDump.hs

@@ -12,7 +12,7 @@ import Data.Maybe (fromJust, isJust)
 import Simplex.Messaging.Agent.Store.Postgres (closeDBStore, createDBStore)
 import Simplex.Messaging.Agent.Store.Postgres.Common (DBOpts (..))
 import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations
-import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration)
+import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfig (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration)
 import Simplex.Messaging.Util (ifM, whenM)
 import System.Directory (doesFileExist, removeFile)
 import System.Process (readCreateProcess, shell)
@@ -30,12 +30,12 @@ postgresSchemaDumpTest migrations skipComparisonForDownMigrations testDBOpts@DBO
     testVerifySchemaDump = do
       savedSchema <- ifM (doesFileExist srcSchemaPath) (readFile srcSchemaPath) (pure "")
       savedSchema `deepseq` pure ()
-      void $ createDBStore testDBOpts migrations MCConsole
+      void $ createDBStore testDBOpts migrations (MigrationConfig MCConsole Nothing)
       getSchema srcSchemaPath `shouldReturn` savedSchema
 
     testSchemaMigrations = do
       let noDownMigrations = dropWhileEnd (\Migration {down} -> isJust down) migrations
-      Right st <- createDBStore testDBOpts noDownMigrations MCError
+      Right st <- createDBStore testDBOpts noDownMigrations (MigrationConfig MCError Nothing)
       mapM_ (testDownMigration st) $ drop (length noDownMigrations) migrations
       closeDBStore st
       whenM (doesFileExist testSchemaPath) $ removeFile testSchemaPath