Merge branch 'stable'

cabal.project

@@ -12,7 +12,7 @@ constraints: zip +disable-bzip2 +disable-zstd
 source-repository-package
     type: git
     location: https://github.com/simplex-chat/simplexmq.git
-    tag: a4f049d8da1021ee76fbd1b25635d16aef24154a
+    tag: 112cd9d5f44055b6d9b12cb918a1f108f78726f8
 
 source-repository-package
     type: git

scripts/nix/sha256map.nix

@@ -1,5 +1,5 @@
 {
-  "https://github.com/simplex-chat/simplexmq.git"."a4f049d8da1021ee76fbd1b25635d16aef24154a" = "1wvrmb6swpsl24by8d6wz0nfj8bi2pbkigv26pl7c1binc0qichy";
+  "https://github.com/simplex-chat/simplexmq.git"."112cd9d5f44055b6d9b12cb918a1f108f78726f8" = "18jp2jrq7a4giqvqpvd3jjrbznwwl1dsh1ymmq3197xdd515wxr1";
   "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
   "https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d";
   "https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl";

src/Simplex/Chat.hs

@@ -45,7 +45,7 @@ import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.Store.Common (DBStore (dbNew))
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import Simplex.Messaging.Agent.Store.Entity
-import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError)
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..), MigrationError)
 import Simplex.Messaging.Client (defaultNetworkConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolType (..), SProtocolType (..), SubscriptionMode (..), UserProtocol)
@@ -115,10 +115,10 @@ defaultChatConfig =
 logCfg :: LogConfig
 logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
 
-createChatDatabase :: ChatDbOpts -> MigrationConfirmation -> IO (Either MigrationError ChatDatabase)
-createChatDatabase chatDbOpts confirmMigrations = runExceptT $ do
-  chatStore <- ExceptT $ createChatStore (toDBOpts chatDbOpts chatSuffix False) confirmMigrations
-  agentStore <- ExceptT $ createAgentStore (toDBOpts chatDbOpts agentSuffix False) confirmMigrations
+createChatDatabase :: ChatDbOpts -> MigrationConfig -> IO (Either MigrationError ChatDatabase)
+createChatDatabase chatDbOpts migrationConfig = runExceptT $ do
+  chatStore <- ExceptT $ createChatStore (toDBOpts chatDbOpts chatSuffix False) migrationConfig
+  agentStore <- ExceptT $ createAgentStore (toDBOpts chatDbOpts agentSuffix False) migrationConfig
   pure ChatDatabase {chatStore, agentStore}
 
 newChatController :: ChatDatabase -> Maybe User -> ChatConfig -> ChatOpts -> Bool -> IO ChatController

src/Simplex/Chat/Core.hs

@@ -30,7 +30,7 @@ import Simplex.Chat.Store.Profiles
 import Simplex.Chat.Types
 import Simplex.Chat.Types.Preferences (FeatureAllowed (..), FilesPreference (..), Preferences (..), emptyChatPrefs)
 import Simplex.Chat.View (ChatResponseEvent, serializeChatError, serializeChatResponse)
-import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..))
 import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction)
 import System.Exit (exitFailure)
 import System.IO (hFlush, stdout)
@@ -38,15 +38,15 @@ import Text.Read (readMaybe)
 import UnliftIO.Async
 
 simplexChatCore :: ChatConfig -> ChatOpts -> (User -> ChatController -> IO ()) -> IO ()
-simplexChatCore cfg@ChatConfig {confirmMigrations, testView, chatHooks} opts@ChatOpts {coreOptions = CoreChatOpts {dbOptions, logAgent, yesToUpMigrations}, createBot, maintenance} chat =
+simplexChatCore cfg@ChatConfig {confirmMigrations, testView, chatHooks} opts@ChatOpts {coreOptions = CoreChatOpts {dbOptions, logAgent, yesToUpMigrations, migrationBackupPath}, createBot, maintenance} chat =
   case logAgent of
     Just level -> do
       setLogLevel level
       withGlobalLogging logCfg initRun
     _ -> initRun
   where
-    initRun = createChatDatabase dbOptions confirm' >>= either exit run
-    confirm' = if confirmMigrations == MCConsole && yesToUpMigrations then MCYesUp else confirmMigrations
+    initRun = createChatDatabase dbOptions migrationConfig >>= either exit run
+    migrationConfig = MigrationConfig (if confirmMigrations == MCConsole && yesToUpMigrations then MCYesUp else confirmMigrations) migrationBackupPath
     exit e = do
       putStrLn $ "Error opening database: " <> show e
       exitFailure

src/Simplex/Chat/Mobile.hs

@@ -50,7 +50,7 @@ import Simplex.Chat.Types
 import Simplex.Messaging.Agent.Client (agentClientStore)
 import Simplex.Messaging.Agent.Env.SQLite (createAgentStore)
 import Simplex.Messaging.Agent.Store.Interface (closeDBStore, reopenDBStore)
-import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError)
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..), MigrationError)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, sumTypeJSON)
@@ -254,7 +254,8 @@ mobileChatOpts dbOptions =
             tbqSize = 4096,
             deviceName = Nothing,
             highlyAvailable = False,
-            yesToUpMigrations = False
+            yesToUpMigrations = False,
+            migrationBackupPath = Just ""
           },
       chatCmd = "",
       chatCmdDelay = 3,
@@ -294,8 +295,9 @@ chatMigrateInit dbFilePrefix dbKey confirm = do
 chatMigrateInitKey :: ChatDbOpts -> Bool -> String -> Bool -> IO (Either DBMigrationResult ChatController)
 chatMigrateInitKey chatDbOpts keepKey confirm backgroundMode = runExceptT $ do
   confirmMigrations <- liftEitherWith (const DBMInvalidConfirmation) $ strDecode $ B.pack confirm
-  chatStore <- migrate createChatStore (toDBOpts chatDbOpts chatSuffix keepKey) confirmMigrations
-  agentStore <- migrate createAgentStore (toDBOpts chatDbOpts agentSuffix keepKey) confirmMigrations
+  let migrationConfig = MigrationConfig confirmMigrations (Just "")
+  chatStore <- migrate createChatStore (toDBOpts chatDbOpts chatSuffix keepKey) migrationConfig
+  agentStore <- migrate createAgentStore (toDBOpts chatDbOpts agentSuffix keepKey) migrationConfig
   liftIO $ initialize chatStore ChatDatabase {chatStore, agentStore}
   where
     opts = mobileChatOpts $ removeDbKey chatDbOpts

src/Simplex/Chat/Options.hs

@@ -67,7 +67,8 @@ data CoreChatOpts = CoreChatOpts
     tbqSize :: Natural,
     deviceName :: Maybe Text,
     highlyAvailable :: Bool,
-    yesToUpMigrations :: Bool
+    yesToUpMigrations :: Bool,
+    migrationBackupPath :: Maybe FilePath
   }
 
 data CreateBotOpts = CreateBotOpts
@@ -243,6 +244,7 @@ coreChatOptsP appDir defaultDbName = do
           <> short 'y'
           <> help "Automatically confirm \"up\" database migrations"
       )
+  migrationBackupPath <- migrationBackupPathP
   pure
     CoreChatOpts
       { dbOptions,
@@ -268,7 +270,8 @@ coreChatOptsP appDir defaultDbName = do
         tbqSize,
         deviceName,
         highlyAvailable,
-        yesToUpMigrations
+        yesToUpMigrations,
+        migrationBackupPath
       }
   where
     useTcpTimeout p t = 1000000 * if t > 0 then t else maybe 7 (const 15) p

src/Simplex/Chat/Options/Postgres.hs

@@ -52,6 +52,9 @@ chatDbOptsP _appDir defaultDbName = do
       )
   pure ChatDbOpts {dbConnstr, dbSchemaPrefix, dbPoolSize, dbCreateSchema}
 
+migrationBackupPathP :: Parser (Maybe FilePath)
+migrationBackupPathP = pure Nothing
+
 dbString :: ChatDbOpts -> String
 dbString ChatDbOpts {dbConnstr} = dbConnstr
 

src/Simplex/Chat/Options/SQLite.hs

@@ -54,6 +54,19 @@ chatDbOptsP appDir defaultDbName = do
         vacuumOnMigration = not disableVacuum
       }
 
+migrationBackupPathP :: Parser (Maybe FilePath)
+migrationBackupPathP =
+  flag' Nothing
+    ( long "disable-backup"
+        <> help "Disable backup when migrating database"
+    )
+    <|>
+      (fmap Just . strOption)
+        ( long "backup-directory"
+            <> help "Directory to backup database for migration"
+            <> value ""
+        )
+
 dbString :: ChatDbOpts -> String
 dbString ChatDbOpts {dbFilePrefix} = dbFilePrefix <> "_chat.db, " <> dbFilePrefix <> "_agent.db"
 

src/Simplex/Chat/Store.hs

@@ -21,12 +21,12 @@ import Simplex.Chat.Store.Profiles
 import Simplex.Chat.Store.Shared
 import Simplex.Messaging.Agent.Store.Common (DBStore (..), withTransaction)
 import Simplex.Messaging.Agent.Store.Interface (DBOpts, createDBStore)
-import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation, MigrationError)
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfig, MigrationError)
 #if defined(dbPostgres)
 import Simplex.Chat.Store.Postgres.Migrations
 #else
 import Simplex.Chat.Store.SQLite.Migrations
 #endif
 
-createChatStore :: DBOpts -> MigrationConfirmation -> IO (Either MigrationError DBStore)
+createChatStore :: DBOpts -> MigrationConfig -> IO (Either MigrationError DBStore)
 createChatStore dbCreateOpts = createDBStore dbCreateOpts migrations

tests/ChatClient.hs

@@ -47,7 +47,7 @@ import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Protocol (currentSMPAgentVersion, duplexHandshakeSMPAgentVersion, pqdrSMPAgentVersion, supportedSMPAgentVRange)
 import Simplex.Messaging.Agent.RetryInterval
 import Simplex.Messaging.Agent.Store.Interface (closeDBStore)
-import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError)
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..), MigrationError)
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import Simplex.Messaging.Client (ProtocolClientConfig (..))
 import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig)
@@ -151,7 +151,8 @@ testCoreOpts =
       tbqSize = 16,
       deviceName = Nothing,
       highlyAvailable = False,
-      yesToUpMigrations = False
+      yesToUpMigrations = False,
+      migrationBackupPath = Nothing
     }
 
 #if !defined(dbPostgres)
@@ -302,7 +303,7 @@ insertUser :: DBStore -> IO ()
 insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users DEFAULT VALUES")
 #else
 createDatabase TestParams {tmpPath} CoreChatOpts {dbOptions} dbPrefix = do
-  createChatDatabase dbOptions {dbFilePrefix = tmpPath </> dbPrefix} MCError
+  createChatDatabase dbOptions {dbFilePrefix = tmpPath </> dbPrefix} (MigrationConfig MCError Nothing)
 
 insertUser :: DBStore -> IO ()
 insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users (user_id) VALUES (1)")

tests/MobileTests.hs

@@ -38,7 +38,7 @@ import Simplex.Chat.Store
 import Simplex.Chat.Store.Profiles
 import Simplex.Chat.Types (AgentUserId (..), Profile (..))
 import Simplex.Messaging.Agent.Store.Interface
-import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..))
 import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.File (CryptoFile(..), CryptoFileArgs (..))
@@ -167,7 +167,7 @@ testChatApi ps = do
   let tmp = tmpPath ps
       dbPrefix = tmp </> "1"
       f = dbPrefix <> chatSuffix
-  Right st <- createChatStore (DBOpts f "myKey" False True DB.TQOff) MCYesUp
+  Right st <- createChatStore (DBOpts f "myKey" False True DB.TQOff) (MigrationConfig MCYesUp Nothing)
   Right _ <- withTransaction st $ \db -> runExceptT $ createUserRecord db (AgentUserId 1) aliceProfile {preferences = Nothing} True
   Right cc <- chatMigrateInit dbPrefix "myKey" "yesUp"
   Left (DBMErrorNotADatabase _) <- chatMigrateInit dbPrefix "" "yesUp"

tests/SchemaDump.hs

@@ -26,7 +26,7 @@ import Simplex.Messaging.Agent.Store.DB (TrackQueries (..))
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import Simplex.Messaging.Agent.Store.Interface
 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, tshow, whenM)
 import System.Directory (doesFileExist, removeFile)
 import System.Process (readCreateProcess, shell)
@@ -63,7 +63,7 @@ testVerifySchemaDump :: IO ()
 testVerifySchemaDump = withTmpFiles $ do
   savedSchema <- ifM (doesFileExist appSchema) (readFile appSchema) (pure "")
   savedSchema `deepseq` pure ()
-  void $ createChatStore (DBOpts testDB "" False True TQOff) MCError
+  void $ createChatStore (DBOpts testDB "" False True TQOff) (MigrationConfig MCError Nothing)
   getSchema testDB appSchema `shouldReturn` savedSchema
   removeFile testDB
 
@@ -71,14 +71,14 @@ testVerifyLintFKeyIndexes :: IO ()
 testVerifyLintFKeyIndexes = withTmpFiles $ do
   savedLint <- ifM (doesFileExist appLint) (readFile appLint) (pure "")
   savedLint `deepseq` pure ()
-  void $ createChatStore (DBOpts testDB "" False True TQOff) MCError
+  void $ createChatStore (DBOpts testDB "" False True TQOff) (MigrationConfig MCError Nothing)
   getLintFKeyIndexes testDB "tests/tmp/chat_lint.sql" `shouldReturn` savedLint
   removeFile testDB
 
 testSchemaMigrations :: IO ()
 testSchemaMigrations = withTmpFiles $ do
   let noDownMigrations = dropWhileEnd (\Migration {down} -> isJust down) Store.migrations
-  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) Store.migrations
   closeDBStore st
   removeFile testDB
@@ -150,7 +150,7 @@ saveQueryPlans = it "verify and overwrite query plans" $ \TestParams {chatQueryS
     updatePlans
       appChatQueryPlans
       chatQueryStats
-      (createChatStore (DBOpts testDB "" False True TQOff) MCError)
+      (createChatStore (DBOpts testDB "" False True TQOff) (MigrationConfig MCError Nothing))
       (\db -> do
         DB.execute_ db "CREATE TABLE IF NOT EXISTS temp_conn_ids (conn_id BLOB)"
         DB.execute_ db "CREATE TABLE IF NOT EXISTS temp_delete_members (contact_profile_id INTEGER, member_profile_id INTEGER, local_display_name TEXT)"
@@ -159,7 +159,7 @@ saveQueryPlans = it "verify and overwrite query plans" $ \TestParams {chatQueryS
     updatePlans
       appAgentQueryPlans
       agentQueryStats
-      (createAgentStore (DBOpts testAgentDB "" False True TQOff) MCError)
+      (createAgentStore (DBOpts testAgentDB "" False True TQOff) (MigrationConfig MCError Nothing))
       (const $ pure ())
   chatSavedPlans' == chatSavedPlans `shouldBe` True
   agentSavedPlans' == agentSavedPlans `shouldBe` True