sql: set journal_mode to WAL

rfcs/2023-09-28-journal-mode-wal.md

@@ -0,0 +1,30 @@
+# Switching database to WAL mode
+
+## Problem
+
+1. Slow writes when sending messages to large groups.
+
+A possible solution is batching multiple writes into a single transaction, which is attempted for sending messages in #847 / #3067. The problem with that approach is that it substantially complicates the code and has to be done for other scenarios separately (e.g., broadcasting profile updates, which is even more complex as different messages have to be sent to different contacts, to account for preference overrides).
+
+2. Conflicts for the database access from multiple processes (iOS app and NSE).
+
+A possible solution is better coordination of access than currently implemented, but it is substantially more complex, particularly if additional extensions are added.
+
+## Solution
+
+A proposed solution is to increase page_size to 16kb (from 4kb) and switch to WAL mode. This should improve write performance and reduce conflicts.
+
+Problems with this soltion:
+- old versions of the app won't be taking into account WAL file when exporting. Possible solutions are:
+  - make it non-reversible change (that is, without down migration).
+  - checkpoint and switch database to DELETE mode when exporting.
+- windows closes the database connection when the app is stopped, so we can no longer do any operations prior to exporting without providing database key. Possible solutions are:
+  - always checkpoint and move to DELETE mode when stopping and move back to WAL mode when starting.
+  - what else?
+
+Switching to 16kb block also requires a process:
+- set it first
+- run VACUUM (this will change block size)
+- only then the database can be switched to WAL mode
+
+If the database is already in WAL mode it needs to be switched to DELETE mode before block size change will happen on VACUUM.

src/Simplex/Messaging/Agent.hs

@@ -40,6 +40,7 @@
     SubscriptionsInfo (..),
     getSMPAgentClient,
     disconnectAgentClient,
+    disposeAgentClient,
     resumeAgentClient,
     withConnLock,
     withInvLock,
@@ -188,6 +189,11 @@
   closeXFTPAgent xa
   logConnection c False
 
+disposeAgentClient :: MonadUnliftIO m => AgentClient -> m ()
+disposeAgentClient c@AgentClient {agentEnv = Env {store}} = do
+  disconnectAgentClient c
+  liftIO $ closeSQLiteStore store
+
 resumeAgentClient :: MonadIO m => AgentClient -> m ()
 resumeAgentClient c = atomically $ writeTVar (active c) True
 
@@ -318,7 +324,7 @@
 setProtocolServers c = withAgentEnv c .: setProtocolServers' c
 
 -- | Test protocol server
 testProtocolServer :: forall p m. (ProtocolTypeI p, UserProtocol p, AgentErrorMonad m) => AgentClient -> UserId -> ProtoServerWithAuth p -> m (Maybe ProtocolTestFailure)
 testProtocolServer c userId srv = withAgentEnv c $ case protocolTypeI @p of
   SPSMP -> runSMPServerTest c userId srv
   SPXFTP -> runXFTPServerTest c userId srv

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

@@ -28,10 +28,17 @@ module Simplex.Messaging.Agent.Store.SQLite
     MigrationConfirmation (..),
     MigrationError (..),
     UpMigration (..),
+    SQLiteJournalMode (..),
     createSQLiteStore,
     connectSQLiteStore,
     closeSQLiteStore,
     openSQLiteStore,
+    checkpointSQLiteStore,
+    backupSQLiteStore,
+    restoreSQLiteStore,
+    removeSQLiteStore,
+    setSQLiteJournalMode,
+    getSQLiteJournalMode,
     sqlString,
     execSQL,
     upMigration, -- used in tests
@@ -219,12 +226,14 @@ import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Class
 import Crypto.Random (ChaChaDRG)
+import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson.TH as J
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (second)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Base64.URL as U
 import Data.Char (toLower)
+import Data.Either (fromRight)
 import Data.Functor (($>))
 import Data.IORef
 import Data.Int (Int64)
@@ -268,9 +277,9 @@ import Simplex.Messaging.Parsers (blobFieldParser, defaultJSON, dropPrefix, from
 import Simplex.Messaging.Protocol
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Transport.Client (TransportHost)
-import Simplex.Messaging.Util (bshow, eitherToMaybe, groupOn, ifM, ($>>=), (<$$>))
+import Simplex.Messaging.Util (bshow, eitherToMaybe, groupOn, ifM, unlessM, whenM, ($>>=), (<$$>))
 import Simplex.Messaging.Version
-import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
+import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist, removeFile)
 import System.Exit (exitFailure)
 import System.FilePath (takeDirectory)
 import System.IO (hFlush, stdout)
@@ -317,6 +326,33 @@ instance StrEncoding MigrationConfirmation where
       "error" -> pure MCError
       _ -> fail "invalid MigrationConfirmation"
 
+data SQLiteJournalMode = SQLModeWAL | SQLModeDelete | SQLMode Text
+  deriving (Show)
+
+instance StrEncoding SQLiteJournalMode where
+  strEncode = \case
+    SQLModeWAL -> "wal"
+    SQLModeDelete -> "delete"
+    SQLMode s -> encodeUtf8 s
+  strP = do
+    s <- A.takeTill (== ' ')
+    pure $ case s of
+      "wal" -> SQLModeWAL
+      "WAL" -> SQLModeWAL
+      "delete" -> SQLModeDelete
+      "DELETE" -> SQLModeDelete
+      _ -> SQLMode $ decodeLatin1 s
+
+decodeJournalMode :: Text -> SQLiteJournalMode
+decodeJournalMode s = fromRight (SQLMode s) $ strDecode $ encodeUtf8 s
+
+instance ToJSON SQLiteJournalMode where
+  toJSON = strToJSON
+  toEncoding = strToJEncoding
+
+instance FromJSON SQLiteJournalMode where
+  parseJSON = strParseJSON "SQLiteJournalMode"
+
 createSQLiteStore :: FilePath -> String -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError SQLiteStore)
 createSQLiteStore dbFilePath dbKey migrations confirmMigrations = do
   let dbDir = takeDirectory dbFilePath
@@ -354,11 +390,44 @@ migrateSchema st migrations confirmMigrations = do
   where
     confirm err = confirmOrExit $ migrationErrorDescription err
     run ms = do
-      let f = dbFilePath st
-      copyFile f (f <> ".bak")
+      withConnection st $ \db -> do
+        execSQL_ db "PRAGMA wal_checkpoint(TRUNCATE);"
+        backupSQLiteStore st
       Migrations.run st ms
       pure $ Right ()
 
+-- names are chosen to make .bak file a valid database with WAL files
+backupSQLiteStore :: SQLiteStore -> IO ()
+backupSQLiteStore st = do
+  let f = dbFilePath st
+      fBak = f <> ".bak"
+  copyWhenExists f fBak
+  copyWhenExists (f <> "-wal") (fBak <> "-wal")
+  copyWhenExists (f <> "-shm") (fBak <> "-shm")
+
+restoreSQLiteStore :: SQLiteStore -> IO ()
+restoreSQLiteStore st = do
+  let f = dbFilePath st
+      fBak = f <> ".bak"
+  copyWhenExists fBak f
+  copyWhenExists (fBak <> "-wal") (f <> "-wal")
+  copyWhenExists (fBak <> "-shm") (f <> "-shm")
+
+copyWhenExists :: FilePath -> FilePath -> IO ()
+copyWhenExists f f' = whenM (doesFileExist f) $ copyFile f f'
+
+removeSQLiteStore :: SQLiteStore -> IO ()
+removeSQLiteStore st = do
+  let f = dbFilePath st
+  removeDB f
+  removeDB (f <> ".bak")
+  where
+    removeDB f = do
+      remove f
+      remove (f <> "-wal")
+      remove (f <> "-shm")
+    remove f = whenM (doesFileExist f) $ removeFile f
+
 confirmOrExit :: String -> IO ()
 confirmOrExit s = do
   putStrLn s
@@ -380,27 +449,23 @@ connectSQLiteStore dbFilePath dbKey = do
 connectDB :: FilePath -> String -> IO DB.Connection
 connectDB path key = do
   db <- DB.open path
-  prepare db `onException` DB.close db
+  execSQL_ db openSQL `onException` DB.close db
   -- _printPragmas db path
   pure db
   where
-    prepare db = do
-      let exec = SQLite3.exec $ SQL.connectionHandle $ DB.conn db
-      unless (null key) . exec $ "PRAGMA key = " <> sqlString key <> ";"
-      exec . fromQuery $
-        [sql|
-          PRAGMA busy_timeout = 100;
-          PRAGMA foreign_keys = ON;
-          -- PRAGMA trusted_schema = OFF;
-          PRAGMA secure_delete = ON;
-          PRAGMA auto_vacuum = FULL;
-        |]
+    openSQL =
+      (if null key then "" else "PRAGMA key = " <> sqlString key <> ";\n")
+        <> "PRAGMA journal_mode = WAL;\n\
+           \PRAGMA busy_timeout = 100;\n\
+           \PRAGMA foreign_keys = ON;\n\
+           \PRAGMA trusted_schema = OFF;\n\
+           \PRAGMA secure_delete = ON;\n"
 
 closeSQLiteStore :: SQLiteStore -> IO ()
 closeSQLiteStore st@SQLiteStore {dbClosed} =
   ifM (readTVarIO dbClosed) (putStrLn "closeSQLiteStore: already closed") $
-    withConnection st $ \conn -> do
-      DB.close conn
+    withConnection st $ \db -> do
+      DB.close db
       atomically $ writeTVar dbClosed True
 
 openSQLiteStore :: SQLiteStore -> String -> IO ()
@@ -417,6 +482,26 @@ openSQLiteStore SQLiteStore {dbConnection, dbFilePath, dbClosed} key =
             putTMVar dbConnection DB.Connection {conn, slow}
             writeTVar dbClosed False
 
+checkpointSQLiteStore :: SQLiteStore -> IO ()
+checkpointSQLiteStore st =
+  unlessM (readTVarIO $ dbClosed st) $
+    withConnection st (`execSQL_` "PRAGMA wal_checkpoint(TRUNCATE);")
+
+setSQLiteJournalMode :: SQLiteStore -> SQLiteJournalMode -> IO ()
+setSQLiteJournalMode st mode =
+  withConnection st (`execSQL_` q)
+  where
+    q = case mode of
+      SQLModeWAL -> "PRAGMA journal_mode = WAL;"
+      SQLModeDelete -> "PRAGMA journal_mode = DELETE;"
+      SQLMode s -> "PRAGMA journal_mode = " <> s <> ";"
+
+getSQLiteJournalMode :: SQLiteStore -> IO SQLiteJournalMode
+getSQLiteJournalMode st =
+  withConnection st $ \db -> do
+    [Only mode] <- DB.query_ db "PRAGMA journal_mode;" :: IO [Only Text]
+    pure $ decodeJournalMode mode
+
 sqlString :: String -> Text
 sqlString s = quote <> T.replace quote "''" (T.pack s) <> quote
   where
@@ -434,6 +519,9 @@ sqlString s = quote <> T.replace quote "''" (T.pack s) <> quote
 --   auto_vacuum <- DB.query_ db "PRAGMA auto_vacuum;" :: IO [[Int]]
 --   print $ path <> " auto_vacuum: " <> show auto_vacuum
 
+execSQL_ :: DB.Connection -> Text -> IO ()
+execSQL_ = SQLite3.exec . SQL.connectionHandle . DB.conn
+
 execSQL :: DB.Connection -> Text -> IO [Text]
 execSQL db query = do
   rs <- newIORef []

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

@@ -118,7 +118,7 @@ getCurrent db = map toMigration <$> DB.query_ db "SELECT name, down FROM migrati
 run :: SQLiteStore -> MigrationsToRun -> IO ()
 run st = \case
   MTRUp [] -> pure ()
-  MTRUp ms -> mapM_ runUp ms >> withConnection' st (`execSQL` "VACUUM;")
+  MTRUp ms -> mapM_ runUp ms >> withConnection' st (`execSQL` "VACUUM; PRAGMA wal_checkpoint(TRUNCATE);")
   MTRDown ms -> mapM_ runDown $ reverse ms
   MTRNone -> pure ()
   where