dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-08-24 14:10:14 +00:00
Code Issues Packages Projects Releases Wiki Activity

db error busy treatments (#796)

Browse Source
This commit is contained in:
spaced4ndy
2023-07-11 20:19:20 +04:00
committed by GitHub
parent 532cd2f39c
commit 1afcefa5e7
5 changed files with 109 additions and 87 deletions
Download Patch File Download Diff File Expand all files Collapse all files
simplexmq.cabal
+1
View File
@@ -63,6 +63,7 @@ library
Simplex.Messaging.Agent.Server
Simplex.Messaging.Agent.Store
Simplex.Messaging.Agent.Store.SQLite
Simplex.Messaging.Agent.Store.SQLite.Common
Simplex.Messaging.Agent.Store.SQLite.Migrations
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
src/Simplex/Messaging/Agent/Store/SQLite.hs
+23 -62
View File
@@ -206,7 +206,6 @@ module Simplex.Messaging.Agent.Store.SQLite
)
where
import Control.Concurrent (threadDelay)
import Control.Concurrent.STM (stateTVar)
import Control.Monad.Except
import Crypto.Random (ChaChaDRG, randomBytesGenerate)
@@ -229,7 +228,7 @@ import Data.Ord (Down (..))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime)
import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime)
import Data.Word (Word32)
import Database.SQLite.Simple (FromRow, NamedParam (..), Only (..), Query (..), SQLError, ToRow, field, (:.) (..))
import qualified Database.SQLite.Simple as DB
@@ -246,6 +245,7 @@ import Simplex.FileTransfer.Types
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.RetryInterval (RI2State (..))
import Simplex.Messaging.Agent.Store
import Simplex.Messaging.Agent.Store.SQLite.Common
import Simplex.Messaging.Agent.Store.SQLite.Migrations (DownMigration (..), MTRError, Migration (..), MigrationsToRun (..), mtrErrorDescription)
import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
import qualified Simplex.Messaging.Crypto as C
@@ -258,25 +258,18 @@ import Simplex.Messaging.Parsers (blobFieldParser, dropPrefix, fromTextField_, s
import Simplex.Messaging.Protocol
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Transport.Client (TransportHost)
import Simplex.Messaging.Util (bshow, diffToMilliseconds, eitherToMaybe, groupOn, ($>>=), (<$$>))
import Simplex.Messaging.Util (bshow, eitherToMaybe, groupOn, ($>>=), (<$$>))
import Simplex.Messaging.Version
import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
import System.Exit (exitFailure)
import System.FilePath (takeDirectory)
import System.IO (hFlush, stdout)
import UnliftIO.Exception (bracket, onException)
import UnliftIO.Exception (onException)
import qualified UnliftIO.Exception as E
import UnliftIO.STM
-- * SQLite Store implementation
data SQLiteStore = SQLiteStore
{ dbFilePath :: FilePath,
dbEncrypted :: TVar Bool,
dbConnection :: TMVar DB.Connection,
dbNew :: Bool
}
data MigrationError
= MEUpgrade {upMigrations :: [UpMigration]}
| MEDowngrade {downMigrations :: [String]}
@@ -333,35 +326,35 @@ createSQLiteStore dbFilePath dbKey migrations confirmMigrations = do
Left e -> closeSQLiteStore st $> Left e
migrateSchema :: SQLiteStore -> [Migration] -> MigrationConfirmation -> IO (Either MigrationError ())
migrateSchema st migrations confirmMigrations = withConnection st $ \db -> do
Migrations.initialize db
Migrations.get db migrations >>= \case
migrateSchema st migrations confirmMigrations = do
Migrations.initialize st
Migrations.get st migrations >>= \case
Left e -> do
when (confirmMigrations == MCConsole) $ confirmOrExit ("Database state error: " <> mtrErrorDescription e)
pure . Left $ MigrationError e
Right MTRNone -> pure $ Right ()
Right ms@(MTRUp ums)
| dbNew st -> Migrations.run db ms $> Right ()
| dbNew st -> Migrations.run st ms $> Right ()
| otherwise -> case confirmMigrations of
MCYesUp -> run db ms
MCYesUpDown -> run db ms
MCConsole -> confirm err >> run db ms
MCYesUp -> run ms
MCYesUpDown -> run ms
MCConsole -> confirm err >> run 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 -> run db ms
MCConsole -> confirm err >> run db ms
MCYesUpDown -> run ms
MCConsole -> confirm err >> run ms
MCYesUp -> pure $ Left err
MCError -> pure $ Left err
where
err = MEDowngrade $ map downName dms
where
confirm err = confirmOrExit $ migrationErrorDescription err
run db ms = do
run ms = do
let f = dbFilePath st
copyFile f (f <> ".bak")
Migrations.run db ms
Migrations.run st ms
pure $ Right ()
confirmOrExit :: String -> IO ()
@@ -375,9 +368,10 @@ confirmOrExit s = do
connectSQLiteStore :: FilePath -> String -> IO SQLiteStore
connectSQLiteStore dbFilePath dbKey = do
dbNew <- not <$> doesFileExist dbFilePath
dbConnection <- newTMVarIO =<< connectDB dbFilePath dbKey
dbConn <- dbBusyLoop $ connectDB dbFilePath dbKey
dbConnVar <- newTMVarIO dbConn
dbEncrypted <- newTVarIO . not $ null dbKey
pure SQLiteStore {dbFilePath, dbEncrypted, dbConnection, dbNew}
pure SQLiteStore {dbFilePath, dbEncrypted, dbConnection = dbConnVar, dbNew}
connectDB :: FilePath -> String -> IO DB.Connection
connectDB path key = do
@@ -389,13 +383,11 @@ connectDB path key = do
prepare db = do
let exec = SQLite3.exec $ DB.connectionHandle db
unless (null key) . exec $ "PRAGMA key = " <> sqlString key <> ";"
exec . fromQuery $
[sql|
PRAGMA foreign_keys = ON;
-- PRAGMA trusted_schema = OFF;
PRAGMA secure_delete = ON;
PRAGMA auto_vacuum = FULL;
|]
exec "PRAGMA busy_timeout = 100;"
exec "PRAGMA foreign_keys = ON;"
-- exec "PRAGMA trusted_schema = OFF;"
exec "PRAGMA secure_delete = ON;"
exec "PRAGMA auto_vacuum = FULL;"
closeSQLiteStore :: SQLiteStore -> IO ()
closeSQLiteStore st = atomically (takeTMVar $ dbConnection st) >>= DB.close
@@ -438,37 +430,6 @@ handleSQLError err e
| DB.sqlError e == DB.ErrorConstraint = err
| otherwise = SEInternal $ bshow e
withConnection :: SQLiteStore -> (DB.Connection -> IO a) -> IO a
withConnection SQLiteStore {dbConnection} =
bracket
(atomically $ takeTMVar dbConnection)
(atomically . putTMVar dbConnection)
withTransaction :: forall a. SQLiteStore -> (DB.Connection -> IO a) -> IO a
withTransaction = withTransactionCtx Nothing
withTransactionCtx :: forall a. Maybe String -> SQLiteStore -> (DB.Connection -> IO a) -> IO a
withTransactionCtx ctx_ st action = withConnection st $ loop 500 3_000_000
where
loop :: Int -> Int -> DB.Connection -> IO a
loop t tLim db =
transactionWithCtx `E.catch` \(e :: SQLError) ->
if tLim > t && DB.sqlError e == DB.ErrorBusy
then do
threadDelay t
loop (t * 9 `div` 8) (tLim - t) db
else E.throwIO e
where
transactionWithCtx = case ctx_ of
Nothing -> DB.withImmediateTransaction db (action db)
Just ctx -> do
t1 <- getCurrentTime
r <- DB.withImmediateTransaction db (action db)
t2 <- getCurrentTime
putStrLn $ "withTransactionCtx start :: " <> show t1 <> " :: " <> ctx
putStrLn $ "withTransactionCtx end :: " <> show t2 <> " :: " <> ctx <> " :: duration=" <> show (diffToMilliseconds $ diffUTCTime t2 t1)
pure r
createUserRecord :: DB.Connection -> IO UserId
createUserRecord db = do
DB.execute_ db "INSERT INTO users DEFAULT VALUES"
src/Simplex/Messaging/Agent/Store/SQLite/Common.hs
+61
View File
@@ -0,0 +1,61 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Messaging.Agent.Store.SQLite.Common
( SQLiteStore (..),
withConnection,
withTransaction,
withTransactionCtx,
dbBusyLoop,
)
where
import Control.Concurrent (threadDelay)
import Data.Time.Clock (diffUTCTime, getCurrentTime)
import Database.SQLite.Simple (SQLError)
import qualified Database.SQLite.Simple as DB
import Simplex.Messaging.Util (diffToMilliseconds)
import UnliftIO.Exception (bracket)
import qualified UnliftIO.Exception as E
import UnliftIO.STM
data SQLiteStore = SQLiteStore
{ dbFilePath :: FilePath,
dbEncrypted :: TVar Bool,
dbConnection :: TMVar DB.Connection,
dbNew :: Bool
}
withConnection :: SQLiteStore -> (DB.Connection -> IO a) -> IO a
withConnection SQLiteStore {dbConnection} =
bracket
(atomically $ takeTMVar dbConnection)
(atomically . putTMVar dbConnection)
withTransaction :: forall a. SQLiteStore -> (DB.Connection -> IO a) -> IO a
withTransaction = withTransactionCtx Nothing
withTransactionCtx :: forall a. Maybe String -> SQLiteStore -> (DB.Connection -> IO a) -> IO a
withTransactionCtx ctx_ st action = withConnection st $ \db -> dbBusyLoop (transactionWithCtx db)
where
transactionWithCtx db = case ctx_ of
Nothing -> DB.withImmediateTransaction db (action db)
Just ctx -> do
t1 <- getCurrentTime
r <- DB.withImmediateTransaction db (action db)
t2 <- getCurrentTime
putStrLn $ "withTransactionCtx start :: " <> show t1 <> " :: " <> ctx
putStrLn $ "withTransactionCtx end :: " <> show t2 <> " :: " <> ctx <> " :: duration=" <> show (diffToMilliseconds $ diffUTCTime t2 t1)
pure r
dbBusyLoop :: forall a. IO a -> IO a
dbBusyLoop action = loop 500 3000000
where
loop :: Int -> Int -> IO a
loop t tLim =
action `E.catch` \(e :: SQLError) ->
if tLim > t && DB.sqlError e == DB.ErrorBusy
then do
threadDelay t
loop (t * 9 `div` 8) (tLim - t)
else E.throwIO e
src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs
+21 -22
View File
@@ -42,6 +42,7 @@ import Database.SQLite.Simple.QQ (sql)
import qualified Database.SQLite3 as SQLite3
import GHC.Generics (Generic)
import Simplex.Messaging.Agent.Protocol (extraSMPServerHosts)
import Simplex.Messaging.Agent.Store.SQLite.Common
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications
@@ -99,44 +100,42 @@ app = sortOn name $ map migration schemaMigrations
where
migration (name, up, down) = Migration {name, up = fromQuery up, down = fromQuery <$> down}
get :: Connection -> [Migration] -> IO (Either MTRError MigrationsToRun)
get db migrations = migrationsToRun migrations <$> getCurrent db
get :: SQLiteStore -> [Migration] -> IO (Either MTRError MigrationsToRun)
get st migrations = migrationsToRun migrations <$> withTransaction st getCurrent
getCurrent :: Connection -> IO [Migration]
getCurrent db = map toMigration <$> DB.query_ db "SELECT name, down FROM migrations ORDER BY name ASC;"
where
toMigration (name, down) = Migration {name, up = "", down}
run :: Connection -> MigrationsToRun -> IO ()
run db = \case
run :: SQLiteStore -> MigrationsToRun -> IO ()
run st = \case
MTRUp [] -> pure ()
MTRUp ms -> mapM_ runUp ms >> execSQL "VACUUM;"
MTRUp ms -> mapM_ runUp ms >> withConnection st (`execSQL` "VACUUM;")
MTRDown ms -> mapM_ runDown $ reverse ms
MTRNone -> pure ()
where
runUp Migration {name, up, down} = do
when (name == "m20220811_onion_hosts") updateServers
DB.withImmediateTransaction db $ insert >> execSQL up
runUp Migration {name, up, down} = withTransaction st $ \db -> do
when (name == "m20220811_onion_hosts") $ updateServers db
insert db >> execSQL db up
where
insert = DB.execute db "INSERT INTO migrations (name, down, ts) VALUES (?,?,?)" . (name,down,) =<< getCurrentTime
updateServers = forM_ (M.assocs extraSMPServerHosts) $ \(h, h') ->
DB.withImmediateTransaction db $
let hs = decodeLatin1 . strEncode $ ([h, h'] :: NonEmpty TransportHost)
in DB.execute db "UPDATE servers SET host = ? WHERE host = ?" (hs, decodeLatin1 $ strEncode h)
runDown DownMigration {downName, downQuery} = do
DB.withImmediateTransaction db $ do
execSQL downQuery
DB.execute db "DELETE FROM migrations WHERE name = ?" (Only downName)
execSQL = SQLite3.exec $ DB.connectionHandle db
insert db = DB.execute db "INSERT INTO migrations (name, down, ts) VALUES (?,?,?)" . (name,down,) =<< getCurrentTime
updateServers db = forM_ (M.assocs extraSMPServerHosts) $ \(h, h') ->
let hs = decodeLatin1 . strEncode $ ([h, h'] :: NonEmpty TransportHost)
in DB.execute db "UPDATE servers SET host = ? WHERE host = ?" (hs, decodeLatin1 $ strEncode h)
runDown DownMigration {downName, downQuery} = withTransaction st $ \db -> do
execSQL db downQuery
DB.execute db "DELETE FROM migrations WHERE name = ?" (Only downName)
execSQL db = SQLite3.exec $ DB.connectionHandle db
initialize :: Connection -> IO ()
initialize db = do
initialize :: SQLiteStore -> IO ()
initialize st = withTransaction st $ \db -> do
cs :: [Text] <- map fromOnly <$> DB.query_ db "SELECT name FROM pragma_table_info('migrations')"
case cs of
[] -> createMigrations
[] -> createMigrations db
_ -> when ("down" `notElem` cs) $ DB.execute_ db "ALTER TABLE migrations ADD COLUMN down TEXT"
where
createMigrations =
createMigrations db =
DB.execute_
db
[sql|
tests/AgentTests/SchemaDump.hs
+3 -3
View File
@@ -50,13 +50,13 @@ testSchemaMigrations = do
putStrLn $ "down migration " <> name m
let downMigr = fromJust $ toDownMigration m
schema <- getSchema testDB testSchema
withConnection st (`Migrations.run` MTRUp [m])
Migrations.run st $ MTRUp [m]
schema' <- getSchema testDB testSchema
schema' `shouldNotBe` schema
withConnection st (`Migrations.run` MTRDown [downMigr])
Migrations.run st $ MTRDown [downMigr]
schema'' <- getSchema testDB testSchema
schema'' `shouldBe` schema
withConnection st (`Migrations.run` MTRUp [m])
Migrations.run st $ MTRUp [m]
schema''' <- getSchema testDB testSchema
schema''' `shouldBe` schema'