From ec456caf2963263869a58d79bf7d17ad3571c760 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Thu, 31 Dec 2020 16:43:11 +0100 Subject: [PATCH 01/21] use a single-striped connection pool for each database layer It is a rather common practice to use a pool of database connection when dealing with databases. So far, we've been using a single shared connection per wallet worker with, in front of each connection a lock preventing concurrent access to the database. The lock is only necessary because of the way persistent handles query statements internally, in principle, SQLite handles concurrent database accesses just well. For basic wallets, this is a relatively useless change. But for larger wallets like those manipulated by exchanges, we've observed very slow response time due to concurrent access of the database lock. Indeed, some requests may grab the lock for 10 or 20 seconds, preventing any requests from going throug. However, most requests are read-only requests and could be executed in parallel, at the discretion of the SQLite engine. I hope that the introduction of a connection pool will improve the overall experience for large wallets by better serving concurrent requests on the database. Finger crossed. --- lib/core/cardano-wallet-core.cabal | 1 + lib/core/src/Cardano/DB/Sqlite.hs | 163 +++++++++++------- lib/core/src/Cardano/Pool/DB/Sqlite.hs | 8 +- lib/core/src/Cardano/Wallet/DB/Sqlite.hs | 6 +- lib/core/test/bench/db/Main.hs | 6 +- .../test/unit/Cardano/Wallet/DB/SqliteSpec.hs | 1 - lib/shelley/bench/Restore.hs | 5 +- 7 files changed, 115 insertions(+), 75 deletions(-) diff --git a/lib/core/cardano-wallet-core.cabal b/lib/core/cardano-wallet-core.cabal index d79fecbf016..d4a3de86201 100644 --- a/lib/core/cardano-wallet-core.cabal +++ b/lib/core/cardano-wallet-core.cabal @@ -86,6 +86,7 @@ library , quiet , random , random-shuffle + , resource-pool , retry , safe , scientific diff --git a/lib/core/src/Cardano/DB/Sqlite.hs b/lib/core/src/Cardano/DB/Sqlite.hs index 0bfd30ef05c..926f4b72b26 100644 --- a/lib/core/src/Cardano/DB/Sqlite.hs +++ b/lib/core/src/Cardano/DB/Sqlite.hs @@ -73,12 +73,16 @@ import Data.List.Split ( chunksOf ) import Data.Maybe ( fromMaybe ) +import Data.Pool + ( Pool, createPool, destroyAllResources, withResource ) import Data.Proxy ( Proxy (..) ) import Data.Text ( Text ) import Data.Text.Class ( ToText (..) ) +import Data.Time.Clock + ( NominalDiffTime ) import Database.Persist.Sql ( DBName (..) , EntityField @@ -108,9 +112,7 @@ import System.Log.FastLogger import UnliftIO.Compat ( handleIf, mkRetryHandler ) import UnliftIO.Exception - ( Exception, bracket_, handleJust, tryJust ) -import UnliftIO.MVar - ( newMVar, withMVarMasked ) + ( Exception, bracket_, handleJust, mask_, tryJust ) import qualified Data.Aeson as Aeson import qualified Data.ByteString.Char8 as B8 @@ -125,14 +127,12 @@ import qualified Database.Sqlite as Sqlite -- | Context for the SQLite 'DBLayer'. data SqliteContext = SqliteContext - { getSqlBackend :: SqlBackend + { connectionPool :: Pool (SqlBackend, Sqlite.Connection) -- ^ A handle to the Persistent SQL backend. , runQuery :: forall a. SqlPersistT IO a -> IO a -- ^ 'safely' run a query with logging and lock-protection , dbFile :: Maybe FilePath -- ^ The actual database file, if any. If none, runs in-memory - , trace :: Tracer IO DBLog - -- ^ A 'Tracer' for logging } -- | Error type for when migrations go wrong after opening a database. @@ -167,44 +167,16 @@ queryLogFunc tr _loc _source level str = traceWith tr (MsgQuery msg sev) handleConstraint :: MonadUnliftIO m => e -> m a -> m (Either e a) handleConstraint e = handleJust select handler . fmap Right where - select (SqliteException ErrorConstraint _ _) = Just () - select _ = Nothing - handler = const . pure . Left $ e + select (SqliteException ErrorConstraint _ _) = Just () + select _ = Nothing + handler = const . pure . Left $ e --- | Finalize database statements and close the database connection. --- --- If the database connection is still in use, it will retry for up to a minute, --- to let other threads finish up. +-- | Free all allocated database connections. See also 'destroySqliteBackend' -- --- This function is idempotent: if the database connection has already been --- closed, calling this function will exit without doing anything. --- -destroyDBLayer :: SqliteContext -> IO () -destroyDBLayer (SqliteContext {getSqlBackend, trace, dbFile}) = do - traceWith trace (MsgClosing dbFile) - recovering pol (mkRetryHandler isBusy) (const $ close' getSqlBackend) - & handleIf isAlreadyClosed - (traceWith trace . MsgIsAlreadyClosed . showT) - & handleIf statementAlreadyFinalized - (traceWith trace . MsgStatementAlreadyFinalized . showT) - where - isAlreadyClosed = \case - -- Thrown when an attempt is made to close a connection that is already - -- in the closed state: - Sqlite.SqliteException Sqlite.ErrorMisuse _ _ -> True - Sqlite.SqliteException {} -> False - - statementAlreadyFinalized = \case - -- Thrown - Persist.StatementAlreadyFinalized{} -> True - Persist.Couldn'tGetSQLConnection{} -> False - - showT :: Show a => a -> Text - showT = T.pack . show - - isBusy (SqliteException name _ _) = pure (name == Sqlite.ErrorBusy) - pol = limitRetriesByCumulativeDelay (60000*ms) $ constantDelay (25*ms) - ms = 1000 -- microseconds in a millisecond +destroyDBLayer :: Tracer IO DBLog -> SqliteContext -> IO () +destroyDBLayer tr SqliteContext{connectionPool,dbFile} = do + traceWith tr (MsgDestroyConnectionPool dbFile) + destroyAllResources connectionPool {------------------------------------------------------------------------------- Internal / Database Setup @@ -219,32 +191,75 @@ startSqliteBackend -> Maybe FilePath -> IO (Either MigrationError SqliteContext) startSqliteBackend manualMigration autoMigration tr fp = do - (unsafeBackend, connection) <- - createSqliteBackend tr fp manualMigration (queryLogFunc tr) - lock <- newMVar unsafeBackend + pool <- createSqlitePool tr fp manualMigration (queryLogFunc tr) let observe :: IO a -> IO a observe = bracketTracer (contramap MsgRun tr) -- runSqlConn is guarded with a lock because it's not threadsafe in general. -- It is also masked, so that the SqlBackend state is not corrupted if a -- thread gets cancelled while running a query. -- See: https://github.com/yesodweb/persistent/issues/981 + -- + -- Note that `withResource` does already mask async exception but only for + -- dealing with the pool resource acquisition. The action is then ran + -- unmasked with the acquired resource. If an asynchronous exception occurs, + -- the resource is NOT placed back in the pool. let runQuery :: SqlPersistT IO a -> IO a - runQuery cmd = withMVarMasked lock $ \backend -> - observe $ runSqlConn cmd backend - autoMigrationResult <- + runQuery cmd = withResource pool $ \(backend, _) -> + observe $ mask_ $ runSqlConn cmd backend + + autoMigrationResult <- withResource pool $ \(backend, connection) -> do withForeignKeysDisabled tr connection - $ runQuery (runMigrationQuiet autoMigration) + $ mask_ (runSqlConn (runMigrationQuiet autoMigration) backend) & tryJust (matchMigrationError @PersistException) & tryJust (matchMigrationError @SqliteException) & fmap join traceWith tr $ MsgMigrations $ fmap length autoMigrationResult - let ctx = SqliteContext unsafeBackend runQuery fp tr + let ctx = SqliteContext pool runQuery fp case autoMigrationResult of Left e -> do - destroyDBLayer ctx + destroyDBLayer tr ctx pure $ Left e Right _ -> pure $ Right ctx +-- | Finalize database statements and close the database connection. +-- +-- If the database connection is still in use, it will retry for up to a minute, +-- to let other threads finish up. +-- +-- This function is idempotent: if the database connection has already been +-- closed, calling this function will exit without doing anything. +destroySqliteBackend + :: Tracer IO DBLog + -> SqlBackend + -> Maybe FilePath + -> IO () +destroySqliteBackend tr sqlBackend dbFile = do + traceWith tr (MsgCloseSingleConnection dbFile) + recovering pol (mkRetryHandler isBusy) (const $ close' sqlBackend) + & handleIf isAlreadyClosed + (traceWith tr . MsgIsAlreadyClosed . showT) + & handleIf statementAlreadyFinalized + (traceWith tr . MsgStatementAlreadyFinalized . showT) + where + isAlreadyClosed = \case + -- Thrown when an attempt is made to close a connection that is already + -- in the closed state: + Sqlite.SqliteException Sqlite.ErrorMisuse _ _ -> True + Sqlite.SqliteException {} -> False + + statementAlreadyFinalized = \case + -- Thrown + Persist.StatementAlreadyFinalized{} -> True + Persist.Couldn'tGetSQLConnection{} -> False + + showT :: Show a => a -> Text + showT = T.pack . show + + isBusy (SqliteException name _ _) = pure (name == Sqlite.ErrorBusy) + pol = limitRetriesByCumulativeDelay (60000*ms) $ constantDelay (25*ms) + ms = 1000 -- microseconds in a millisecond + + -- | Run the given task in a context where foreign key constraints are -- /temporarily disabled/, before re-enabling them. -- @@ -345,19 +360,38 @@ instance MatchMigrationError SqliteException where newtype ManualMigration = ManualMigration { executeManualMigration :: Sqlite.Connection -> IO () } -createSqliteBackend +createSqlitePool :: Tracer IO DBLog -> Maybe FilePath -> ManualMigration -> LogFunc - -> IO (SqlBackend, Sqlite.Connection) -createSqliteBackend trace fp migration logFunc = do + -> IO (Pool (SqlBackend, Sqlite.Connection)) +createSqlitePool tr fp migration logFunc = do let connStr = sqliteConnStr fp - traceWith trace $ MsgConnStr connStr - conn <- Sqlite.open connStr - executeManualMigration migration conn - backend <- wrapConnectionInfo (mkSqliteConnectionInfo connStr) conn logFunc - pure (backend, conn) + traceWith tr $ MsgConnStr connStr + + let createConnection = do + let info = mkSqliteConnectionInfo connStr + conn <- Sqlite.open connStr + executeManualMigration migration conn + backend <- wrapConnectionInfo info conn logFunc + pure (backend, conn) + + let destroyConnection = \(backend, _) -> do + destroySqliteBackend tr backend fp + + createPool + createConnection + destroyConnection + numberOfStripes + timeToLive + maximumConnections + where + numberOfStripes = 1 + timeToLive = 600 :: NominalDiffTime + -- When running in :memory:, we want a single connection that does not get + -- cleaned up. + maximumConnections = maybe 1 (const 10) fp sqliteConnStr :: Maybe FilePath -> Text sqliteConnStr = maybe ":memory:" T.pack @@ -371,7 +405,8 @@ data DBLog | MsgQuery Text Severity | MsgRun BracketLog | MsgConnStr Text - | MsgClosing (Maybe FilePath) + | MsgCloseSingleConnection (Maybe FilePath) + | MsgDestroyConnectionPool (Maybe FilePath) | MsgWillOpenDB (Maybe FilePath) | MsgDatabaseReset | MsgIsAlreadyClosed Text @@ -446,7 +481,8 @@ instance HasSeverityAnnotation DBLog where MsgQuery _ sev -> sev MsgRun _ -> Debug MsgConnStr _ -> Debug - MsgClosing _ -> Debug + MsgCloseSingleConnection _ -> Debug + MsgDestroyConnectionPool _ -> Debug MsgWillOpenDB _ -> Info MsgDatabaseReset -> Notice MsgIsAlreadyClosed _ -> Warning @@ -473,7 +509,10 @@ instance ToText DBLog where MsgRun b -> "Running database action - " <> toText b MsgWillOpenDB fp -> "Will open db at " <> (maybe "in-memory" T.pack fp) MsgConnStr connStr -> "Using connection string: " <> connStr - MsgClosing fp -> "Closing database ("+|fromMaybe "in-memory" fp|+")" + MsgCloseSingleConnection fp -> + "Closing single database connection ("+|fromMaybe "in-memory" fp|+")" + MsgDestroyConnectionPool fp -> + "Destroy database connection pool ("+|fromMaybe "in-memory" fp|+")" MsgDatabaseReset -> "Non backward compatible database found. Removing old database \ \and re-creating it from scratch. Ignore the previous error." diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs index 7ad3581368d..8a14f1cdd0f 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs @@ -201,12 +201,12 @@ withDecoratedDBLayer -> (DBLayer IO -> IO a) -- ^ Action to run. -> IO a -withDecoratedDBLayer dbDecorator trace fp ti action = do - traceWith trace (MsgGeneric $ MsgWillOpenDB fp) +withDecoratedDBLayer dbDecorator tr fp ti action = do + traceWith tr (MsgGeneric $ MsgWillOpenDB fp) bracket before after (action . decorateDBLayer dbDecorator . snd) where - before = newDBLayer trace fp ti - after = destroyDBLayer . fst + before = newDBLayer tr fp ti + after = destroyDBLayer (contramap MsgGeneric tr) . fst -- | Sets up a connection to the SQLite database. -- diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs index 020ce674db3..fd7a6d24d77 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs @@ -250,11 +250,11 @@ withDBLayer -> ((SqliteContext, DBLayer IO s k) -> IO a) -- ^ Action to run. -> IO a -withDBLayer trace defaultFieldValues mDatabaseDir ti = +withDBLayer tr defaultFieldValues mDatabaseDir ti = bracket before after where - before = newDBLayer trace defaultFieldValues mDatabaseDir ti - after = destroyDBLayer . fst + before = newDBLayer tr defaultFieldValues mDatabaseDir ti + after = destroyDBLayer tr . fst -- | Instantiate a 'DBFactory' from a given directory newDBFactory diff --git a/lib/core/test/bench/db/Main.hs b/lib/core/test/bench/db/Main.hs index 3aacd705fd9..60aba9bfb7a 100644 --- a/lib/core/test/bench/db/Main.hs +++ b/lib/core/test/bench/db/Main.hs @@ -49,7 +49,7 @@ import Cardano.BM.Data.Severity import Cardano.BM.Data.Trace ( Trace ) import Cardano.BM.Data.Tracer - ( Tracer, filterSeverity ) + ( Tracer, filterSeverity, nullTracer ) import Cardano.BM.Setup ( setupTrace_, shutdown ) import Cardano.DB.Sqlite @@ -691,7 +691,7 @@ defaultFieldValues = DefaultFieldValues cleanupDB :: (FilePath, SqliteContext, DBLayer IO s k) -> IO () cleanupDB (db, ctx, _) = do - handle (\SqliteException{} -> pure ()) $ destroyDBLayer ctx + handle (\SqliteException{} -> pure ()) $ destroyDBLayer nullTracer ctx mapM_ remove [db, db <> "-shm", db <> "-wal"] where remove f = doesFileExist f >>= \case @@ -778,7 +778,7 @@ benchDiskSize :: Tracer IO DBLog -> (DBLayerBench -> IO ()) -> IO () benchDiskSize tr action = bracket (setupDB tr) cleanupDB $ \(f, ctx, db) -> do action db mapM_ (printFileSize "") [f, f <> "-shm", f <> "-wal"] - destroyDBLayer ctx + destroyDBLayer nullTracer ctx printFileSize " (closed)" f putStrLn "" where diff --git a/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs b/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs index bf0c40c5898..670afd1b793 100644 --- a/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs @@ -1006,7 +1006,6 @@ testOpeningCleaning filepath call expectedAfterOpen expectedAfterClean = do withDBLayer' (Just filepath) $ \db2 -> do call db2 `shouldReturn` expectedAfterClean - -- | Run a test action inside withDBLayer, then check assertions. withTestDBFile :: (DBLayer IO (SeqState 'Mainnet ShelleyKey) ShelleyKey -> IO ()) diff --git a/lib/shelley/bench/Restore.hs b/lib/shelley/bench/Restore.hs index 68ab41b793c..ca8d0de0fba 100644 --- a/lib/shelley/bench/Restore.hs +++ b/lib/shelley/bench/Restore.hs @@ -692,8 +692,8 @@ withBenchDBLayer -> IO a withBenchDBLayer ti tr action = withSystemTempFile "bench.db" $ \dbFile _ -> do - let before = newDBLayer (trMessageText tr) migrationDefaultValues (Just dbFile) ti - let after = destroyDBLayer . fst + let before = newDBLayer tr' migrationDefaultValues (Just dbFile) ti + let after = destroyDBLayer tr' . fst bracket before after $ \(_ctx, db) -> action db where migrationDefaultValues = Sqlite.DefaultFieldValues @@ -703,6 +703,7 @@ withBenchDBLayer ti tr action = , Sqlite.defaultHardforkEpoch = Nothing , Sqlite.defaultKeyDeposit = Coin 0 } + tr' = trMessageText tr prepareNode :: forall n. (NetworkDiscriminantVal n) From 55660e2918e0b0566859eda7c2c7be28e38a88da Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 5 Jan 2021 09:23:01 +0100 Subject: [PATCH 02/21] Properly handle 'SQLITE_BUSY' in the context of a connection pool I ran into quite a few issues with the integration tests since the unliftio merge and rebase (I think, as I am pretty I did observe unit and integration tests doing just fine with the resource pool at least once). I've been investigating this for most of the day, and found a few interesting cases: (a) SQLite may return 'SQLITE_BUSY' on pretty much any requests if two concurrent write queries hit the engine; though we currently only catch this kind of exception when we try closing the database so I generalized a bit our error handling here. (b) It seems that calling destroyAllResources from resource-pool does not prevent new threads from acquiring new resources. And there's no way with the resource-pool library itself to prevent the creation of new resources after a certain point. So it may happen that while the database layer is being destroyed, new database connections are created and start causing conflicts between each others. --- lib/core/cardano-wallet-core.cabal | 1 + lib/core/src/Cardano/DB/Sqlite.hs | 181 ++++++++++++++++------- lib/core/src/Cardano/Pool/DB/Sqlite.hs | 21 +-- lib/core/src/Cardano/Wallet/DB/Sqlite.hs | 64 ++++---- 4 files changed, 165 insertions(+), 102 deletions(-) diff --git a/lib/core/cardano-wallet-core.cabal b/lib/core/cardano-wallet-core.cabal index d4a3de86201..cf08a75dd76 100644 --- a/lib/core/cardano-wallet-core.cabal +++ b/lib/core/cardano-wallet-core.cabal @@ -96,6 +96,7 @@ library , servant-server , split , statistics + , stm , streaming-commons , strict-non-empty-containers , string-interpolate diff --git a/lib/core/src/Cardano/DB/Sqlite.hs b/lib/core/src/Cardano/DB/Sqlite.hs index 926f4b72b26..21550dab17b 100644 --- a/lib/core/src/Cardano/DB/Sqlite.hs +++ b/lib/core/src/Cardano/DB/Sqlite.hs @@ -9,6 +9,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -28,7 +29,7 @@ module Cardano.DB.Sqlite , dbChunked' , destroyDBLayer , handleConstraint - , startSqliteBackend + , newSqliteContext , unsafeRunQuery -- * Manual Migration @@ -53,6 +54,8 @@ import Cardano.DB.Sqlite.Delete ( DeleteSqliteDatabaseLog ) import Cardano.Wallet.Logging ( BracketLog, bracketTracer ) +import Control.Concurrent.STM.TVar + ( TVar, newTVarIO, readTVarIO, writeTVar ) import Control.Monad ( join, mapM_, when ) import Control.Monad.IO.Unlift @@ -60,13 +63,19 @@ import Control.Monad.IO.Unlift import Control.Monad.Logger ( LogLevel (..) ) import Control.Retry - ( constantDelay, limitRetriesByCumulativeDelay, recovering ) + ( RetryStatus (..) + , constantDelay + , limitRetriesByCumulativeDelay + , recovering + ) import Control.Tracer ( Tracer, contramap, traceWith ) import Data.Aeson ( ToJSON (..) ) import Data.Function ( (&) ) +import Data.Functor + ( ($>), (<&>) ) import Data.List ( isInfixOf ) import Data.List.Split @@ -104,7 +113,7 @@ import Database.Persist.Sqlite import Database.Sqlite ( Error (ErrorConstraint), SqliteException (SqliteException) ) import Fmt - ( fmt, (+|), (+||), (|+), (||+) ) + ( fmt, ordinalF, (+|), (+||), (|+), (||+) ) import GHC.Generics ( Generic ) import System.Log.FastLogger @@ -112,8 +121,9 @@ import System.Log.FastLogger import UnliftIO.Compat ( handleIf, mkRetryHandler ) import UnliftIO.Exception - ( Exception, bracket_, handleJust, mask_, tryJust ) + ( Exception, bracket_, handleJust, mask_, throwIO, tryJust ) +import qualified Control.Concurrent.STM as STM import qualified Data.Aeson as Aeson import qualified Data.ByteString.Char8 as B8 import qualified Data.Text as T @@ -129,12 +139,24 @@ import qualified Database.Sqlite as Sqlite data SqliteContext = SqliteContext { connectionPool :: Pool (SqlBackend, Sqlite.Connection) -- ^ A handle to the Persistent SQL backend. + , isDatabaseActive :: TVar Bool + -- ^ A mutable reference to know whether the database is 'active'. This is + -- useful to prevent new requests from being accepted when we're trying to + -- shutdown the database. It is actually crucial with the connection pool + -- since, even though we can purge the pool of all existing resources, we + -- can't easily prevent the creation of new resources. This TVar must + -- therefore be used to guard any call to 'withResource'; if 'False', then + -- 'withResource' mustn't be called. , runQuery :: forall a. SqlPersistT IO a -> IO a -- ^ 'safely' run a query with logging and lock-protection , dbFile :: Maybe FilePath -- ^ The actual database file, if any. If none, runs in-memory } +data DatabaseIsShuttingDownError = DatabaseIsShuttingDownError deriving Show + +instance Exception DatabaseIsShuttingDownError + -- | Error type for when migrations go wrong after opening a database. newtype MigrationError = MigrationError { getMigrationErrorMessage :: Text } @@ -174,7 +196,8 @@ handleConstraint e = handleJust select handler . fmap Right -- | Free all allocated database connections. See also 'destroySqliteBackend' -- destroyDBLayer :: Tracer IO DBLog -> SqliteContext -> IO () -destroyDBLayer tr SqliteContext{connectionPool,dbFile} = do +destroyDBLayer tr SqliteContext{connectionPool,isDatabaseActive,dbFile} = do + STM.atomically $ writeTVar isDatabaseActive False traceWith tr (MsgDestroyConnectionPool dbFile) destroyAllResources connectionPool @@ -182,44 +205,45 @@ destroyDBLayer tr SqliteContext{connectionPool,dbFile} = do Internal / Database Setup -------------------------------------------------------------------------------} --- | Opens the SQLite database connection, sets up query logging and timing, +-- | Opens the SQLite database connection pool, sets up query logging and timing, -- runs schema migrations if necessary. -startSqliteBackend - :: ManualMigration +newSqliteContext + :: [ManualMigration] -> Migration -> Tracer IO DBLog -> Maybe FilePath -> IO (Either MigrationError SqliteContext) -startSqliteBackend manualMigration autoMigration tr fp = do - pool <- createSqlitePool tr fp manualMigration (queryLogFunc tr) - let observe :: IO a -> IO a - observe = bracketTracer (contramap MsgRun tr) - -- runSqlConn is guarded with a lock because it's not threadsafe in general. - -- It is also masked, so that the SqlBackend state is not corrupted if a - -- thread gets cancelled while running a query. - -- See: https://github.com/yesodweb/persistent/issues/981 - -- - -- Note that `withResource` does already mask async exception but only for - -- dealing with the pool resource acquisition. The action is then ran - -- unmasked with the acquired resource. If an asynchronous exception occurs, - -- the resource is NOT placed back in the pool. - let runQuery :: SqlPersistT IO a -> IO a - runQuery cmd = withResource pool $ \(backend, _) -> - observe $ mask_ $ runSqlConn cmd backend - - autoMigrationResult <- withResource pool $ \(backend, connection) -> do - withForeignKeysDisabled tr connection - $ mask_ (runSqlConn (runMigrationQuiet autoMigration) backend) - & tryJust (matchMigrationError @PersistException) - & tryJust (matchMigrationError @SqliteException) - & fmap join - traceWith tr $ MsgMigrations $ fmap length autoMigrationResult - let ctx = SqliteContext pool runQuery fp - case autoMigrationResult of - Left e -> do - destroyDBLayer tr ctx - pure $ Left e - Right _ -> pure $ Right ctx +newSqliteContext manualMigrations autoMigration tr dbFile = do + isDatabaseActive <- newTVarIO True + createSqlitePool tr dbFile manualMigrations autoMigration <&> \case + Left e -> Left e + Right connectionPool -> + let observe :: IO a -> IO a + observe = bracketTracer (contramap MsgRun tr) + + -- runSqlConn is guarded with a lock because it's not threadsafe in + -- general.It is also masked, so that the SqlBackend state is not + -- corrupted if a thread gets cancelled while running a query. + -- See: https://github.com/yesodweb/persistent/issues/981 + -- + -- Note that `withResource` does already mask async exception but + -- only for dealing with the pool resource acquisition. The action + -- is then ran unmasked with the acquired resource. If an + -- asynchronous exception occurs (or actually any exception), the + -- resource is NOT placed back in the pool. + runQuery :: SqlPersistT IO a -> IO a + runQuery cmd = do + readTVarIO isDatabaseActive >>= \case + False -> throwIO DatabaseIsShuttingDownError + True -> withResource connectionPool $ + mask_ . observe . retryOnBusy tr . runSqlConn cmd . fst + + in Right $ SqliteContext + { connectionPool + , isDatabaseActive + , runQuery + , dbFile + } -- | Finalize database statements and close the database connection. -- @@ -235,7 +259,7 @@ destroySqliteBackend -> IO () destroySqliteBackend tr sqlBackend dbFile = do traceWith tr (MsgCloseSingleConnection dbFile) - recovering pol (mkRetryHandler isBusy) (const $ close' sqlBackend) + retryOnBusy tr (close' sqlBackend) & handleIf isAlreadyClosed (traceWith tr . MsgIsAlreadyClosed . showT) & handleIf statementAlreadyFinalized @@ -255,11 +279,33 @@ destroySqliteBackend tr sqlBackend dbFile = do showT :: Show a => a -> Text showT = T.pack . show +-- | Retry an action if the database yields an 'SQLITE_BUSY' error. +-- +-- From +-- +-- The SQLITE_BUSY result code indicates that the database file could not be +-- written (or in some cases read) because of concurrent activity by some +-- other database connection, usually a database connection in a separate +-- process. +-- +-- For example, if process A is in the middle of a large write transaction +-- and at the same time process B attempts to start a new write transaction, +-- process B will get back an SQLITE_BUSY result because SQLite only supports +-- one writer at a time. Process B will need to wait for process A to finish +-- its transaction before starting a new transaction. The sqlite3_busy_timeout() +-- and sqlite3_busy_handler() interfaces and the busy_timeout pragma are +-- available to process B to help it deal with SQLITE_BUSY errors. +-- +retryOnBusy :: Tracer IO DBLog -> IO a -> IO a +retryOnBusy tr action = + recovering policy (mkRetryHandler isBusy) $ \RetryStatus{rsIterNumber} -> do + when (rsIterNumber > 0) $ traceWith tr (MsgRetryOnBusy rsIterNumber) + action + where isBusy (SqliteException name _ _) = pure (name == Sqlite.ErrorBusy) - pol = limitRetriesByCumulativeDelay (60000*ms) $ constantDelay (25*ms) + policy = limitRetriesByCumulativeDelay (60000*ms) $ constantDelay (25*ms) ms = 1000 -- microseconds in a millisecond - -- | Run the given task in a context where foreign key constraints are -- /temporarily disabled/, before re-enabling them. -- @@ -363,35 +409,53 @@ newtype ManualMigration = ManualMigration createSqlitePool :: Tracer IO DBLog -> Maybe FilePath - -> ManualMigration - -> LogFunc - -> IO (Pool (SqlBackend, Sqlite.Connection)) -createSqlitePool tr fp migration logFunc = do + -> [ManualMigration] + -> Migration + -> IO (Either MigrationError (Pool (SqlBackend, Sqlite.Connection))) +createSqlitePool tr fp migrations autoMigration = do let connStr = sqliteConnStr fp + let info = mkSqliteConnectionInfo connStr traceWith tr $ MsgConnStr connStr let createConnection = do - let info = mkSqliteConnectionInfo connStr conn <- Sqlite.open connStr - executeManualMigration migration conn - backend <- wrapConnectionInfo info conn logFunc - pure (backend, conn) + (,conn) <$> wrapConnectionInfo info conn (queryLogFunc tr) let destroyConnection = \(backend, _) -> do destroySqliteBackend tr backend fp - createPool + pool <- createPool createConnection destroyConnection numberOfStripes timeToLive maximumConnections + + -- Run migrations BEFORE making the pool widely accessible to other threads. + -- This works fine for the :memory: case because there's a single connection + -- in the pool, so the next 'withResource' will get exactly this + -- connection. + migrationResult <- withResource pool $ \(backend, conn) -> mask_ $ do + let executeAutoMigration = runSqlConn (runMigrationQuiet autoMigration) backend + migrationResult <- withForeignKeysDisabled tr conn $ do + mapM_ (`executeManualMigration` conn) migrations + executeAutoMigration + & tryJust (matchMigrationError @PersistException) + & tryJust (matchMigrationError @SqliteException) + & fmap join + traceWith tr $ MsgMigrations $ fmap length migrationResult + return migrationResult + + case migrationResult of + Left e -> destroyAllResources pool $> Left e + Right{} -> return (Right pool) where numberOfStripes = 1 - timeToLive = 600 :: NominalDiffTime -- When running in :memory:, we want a single connection that does not get - -- cleaned up. + -- cleaned up. Indeed, the pool will regularly remove connections, destroying + -- our :memory: database regularly otherwise. maximumConnections = maybe 1 (const 10) fp + timeToLive = maybe 31536000 {- one year -} (const 600) {- 10 minutes -} fp :: NominalDiffTime sqliteConnStr :: Maybe FilePath -> Text sqliteConnStr = maybe ":memory:" T.pack @@ -420,6 +484,7 @@ data DBLog | MsgUpdatingForeignKeysSetting ForeignKeysSetting | MsgFoundDatabase FilePath Text | MsgUnknownDBFile FilePath + | MsgRetryOnBusy Int deriving (Generic, Show, Eq, ToJSON) {------------------------------------------------------------------------------- @@ -480,9 +545,9 @@ instance HasSeverityAnnotation DBLog where MsgMigrations (Left _) -> Error MsgQuery _ sev -> sev MsgRun _ -> Debug - MsgConnStr _ -> Debug - MsgCloseSingleConnection _ -> Debug - MsgDestroyConnectionPool _ -> Debug + MsgConnStr _ -> Notice + MsgCloseSingleConnection _ -> Info + MsgDestroyConnectionPool _ -> Notice MsgWillOpenDB _ -> Info MsgDatabaseReset -> Notice MsgIsAlreadyClosed _ -> Warning @@ -496,6 +561,9 @@ instance HasSeverityAnnotation DBLog where MsgUpdatingForeignKeysSetting{} -> Debug MsgFoundDatabase _ _ -> Info MsgUnknownDBFile _ -> Notice + MsgRetryOnBusy n | n <= 1 -> Debug + MsgRetryOnBusy n | n <= 3 -> Notice + MsgRetryOnBusy _ -> Warning instance ToText DBLog where toText = \case @@ -557,6 +625,9 @@ instance ToText DBLog where [ "Found something other than a database file in " , "the database folder: ", T.pack file ] + MsgRetryOnBusy n -> + let nF = ordinalF n in + "Retrying db query because db was busy for the " +| nF |+ " time." {------------------------------------------------------------------------------- Extra DB Helpers diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs index 8a14f1cdd0f..2bf5dc160b6 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs @@ -43,7 +43,7 @@ import Cardano.DB.Sqlite , destroyDBLayer , fieldName , handleConstraint - , startSqliteBackend + , newSqliteContext , tableName ) import Cardano.Pool.DB @@ -226,7 +226,7 @@ newDBLayer -> TimeInterpreter IO -> IO (SqliteContext, DBLayer IO) newDBLayer trace fp ti = do - let io = startSqliteBackend + let io = newSqliteContext (migrateManually trace) migrateAll (contramap MsgGeneric trace) @@ -687,13 +687,14 @@ runRawQuery trace q = do migrateManually :: Tracer IO PoolDbLog - -> ManualMigration + -> [ManualMigration] migrateManually _tr = - ManualMigration $ \conn -> do - createView conn activePoolLifeCycleData - createView conn activePoolOwners - createView conn activePoolRegistrations - createView conn activePoolRetirements + ManualMigration <$> + [ createView activePoolLifeCycleData + , createView activePoolOwners + , createView activePoolRegistrations + , createView activePoolRetirements + ] -- | Represents a database view. -- @@ -706,8 +707,8 @@ data DatabaseView = DatabaseView -- | Creates the specified database view, if it does not already exist. -- -createView :: Sqlite.Connection -> DatabaseView -> IO () -createView conn (DatabaseView name definition) = do +createView :: DatabaseView -> Sqlite.Connection -> IO () +createView (DatabaseView name definition) conn = do deleteQuery <- Sqlite.prepare conn deleteQueryString Sqlite.step deleteQuery *> Sqlite.finalize deleteQuery createQuery <- Sqlite.prepare conn createQueryString diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs index fd7a6d24d77..4207814e43f 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs @@ -54,7 +54,7 @@ import Cardano.DB.Sqlite , fieldName , fieldType , handleConstraint - , startSqliteBackend + , newSqliteContext , tableName ) import Cardano.DB.Sqlite.Delete @@ -368,42 +368,32 @@ migrateManually => Tracer IO DBLog -> Proxy k -> DefaultFieldValues - -> ManualMigration + -> [ManualMigration] migrateManually tr proxy defaultFieldValues = - ManualMigration $ \conn -> do - cleanupCheckpointTable conn - - assignDefaultPassphraseScheme conn - - addDesiredPoolNumberIfMissing conn - - addMinimumUTxOValueIfMissing conn - - addHardforkEpochIfMissing conn - - -- FIXME - -- Temporary migration to fix Daedalus flight wallets. This should - -- really be removed as soon as we have a fix for the cardano-sl:wallet - -- currently in production. - removeSoftRndAddresses conn - - removeOldTxParametersTable conn - - addAddressStateIfMissing conn - - addSeqStateDerivationPrefixIfMissing conn - - renameRoleColumn conn - - renameRoleFields conn - - updateFeeValueAndAddKeyDeposit conn - - addFeeToTransaction conn - - moveRndUnusedAddresses conn - - cleanupSeqStateTable conn + ManualMigration <$> + [ cleanupCheckpointTable + , assignDefaultPassphraseScheme + , addDesiredPoolNumberIfMissing + , addMinimumUTxOValueIfMissing + , addHardforkEpochIfMissing + + -- FIXME + -- Temporary migration to fix Daedalus flight wallets. This should + -- really be removed as soon as we have a fix for the cardano-sl:wallet + -- currently in production. + , removeSoftRndAddresses + + , removeOldTxParametersTable + , addAddressStateIfMissing + , addSeqStateDerivationPrefixIfMissing + , renameRoleColumn + , renameRoleFields + , addScriptAddressGapIfMissing + , updateFeeValueAndAddKeyDeposit + , addFeeToTransaction + , moveRndUnusedAddresses + , cleanupSeqStateTable + ] where -- NOTE -- We originally stored script pool gap inside sequential state in the 'SeqState' table, @@ -1126,7 +1116,7 @@ newDBLayerWith newDBLayerWith cacheBehavior trace defaultFieldValues mDatabaseFile ti = do ctx@SqliteContext{runQuery} <- either throwIO pure =<< - startSqliteBackend + newSqliteContext (migrateManually trace (Proxy @k) defaultFieldValues) migrateAll trace From 05099867de8d3c195424ba91d448f2e946d14711 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 5 Jan 2021 17:06:41 +0100 Subject: [PATCH 03/21] use bracket-style resource acquisition for the db connection pool This avoids the need for an extra 'TVar Bool' to guard the connection pool from threads whishing to acquire new resources. Instead, we can wrap the pool acquisition in a bracket: `bracket createPool destroyAllResources` so that the pool is cleaned up when done and we are sure that no thread will attempt to acquire a new resource while destroyAllResources is called. This sole change wasn't as straightforward as I wanted because it moves the control of the `SqliteContext` up in the stack and therefore requires reviewing many more parts of both the pool and wallet db layers. I think it's for a greater good in the end and make them both slightly better / robust. In the end, it is still a bit "awkward" that we have constructors / functions in those modules that are solely used by the test code and not by the actual application (this is the case of 'withDBLayer' for instance...). To not over-complicate things, I ended up handling the in-memory and in-file SqliteContext setup a bit differently. Incidentally I realized later that we run most of our unit-tests on the 'in-memory' version; which means that we aren't testing the resource pool in the context of the unit tests. I am not sure whether this is a good thing or not: it makes the unit tests a bit more focus on testing the actual business logic, and we still have the system-level integration tests to put the resource pool under great stress. --- lib/core/cardano-wallet-core.cabal | 2 - lib/core/src/Cardano/DB/Sqlite.hs | 210 +++++++++--------- lib/core/src/Cardano/Pool/DB/Sqlite.hs | 91 ++++---- lib/core/src/Cardano/Wallet/DB/Sqlite.hs | 80 ++++--- lib/core/test/bench/db/Main.hs | 75 ++++--- .../test/unit/Cardano/Pool/DB/SqliteSpec.hs | 16 +- .../test/unit/Cardano/Wallet/DB/SqliteSpec.hs | 95 ++++---- lib/shelley/bench/Restore.hs | 12 +- 8 files changed, 288 insertions(+), 293 deletions(-) diff --git a/lib/core/cardano-wallet-core.cabal b/lib/core/cardano-wallet-core.cabal index cf08a75dd76..4548a923b0a 100644 --- a/lib/core/cardano-wallet-core.cabal +++ b/lib/core/cardano-wallet-core.cabal @@ -96,7 +96,6 @@ library , servant-server , split , statistics - , stm , streaming-commons , strict-non-empty-containers , string-interpolate @@ -404,7 +403,6 @@ benchmark db , fmt , iohk-monitoring , memory - , persistent-sqlite , random , temporary , text diff --git a/lib/core/src/Cardano/DB/Sqlite.hs b/lib/core/src/Cardano/DB/Sqlite.hs index 21550dab17b..8fc9d986ef7 100644 --- a/lib/core/src/Cardano/DB/Sqlite.hs +++ b/lib/core/src/Cardano/DB/Sqlite.hs @@ -24,12 +24,19 @@ module Cardano.DB.Sqlite ( SqliteContext (..) + , newSqliteContext + , newInMemorySqliteContext + + -- * ConnectionPool + , ConnectionPool + , newConnectionPool + , destroyConnectionPool + + -- * Helpers , chunkSize , dbChunked , dbChunked' - , destroyDBLayer , handleConstraint - , newSqliteContext , unsafeRunQuery -- * Manual Migration @@ -54,10 +61,8 @@ import Cardano.DB.Sqlite.Delete ( DeleteSqliteDatabaseLog ) import Cardano.Wallet.Logging ( BracketLog, bracketTracer ) -import Control.Concurrent.STM.TVar - ( TVar, newTVarIO, readTVarIO, writeTVar ) import Control.Monad - ( join, mapM_, when ) + ( join, mapM_, void, when ) import Control.Monad.IO.Unlift ( MonadUnliftIO (..) ) import Control.Monad.Logger @@ -74,14 +79,10 @@ import Data.Aeson ( ToJSON (..) ) import Data.Function ( (&) ) -import Data.Functor - ( ($>), (<&>) ) import Data.List ( isInfixOf ) import Data.List.Split ( chunksOf ) -import Data.Maybe - ( fromMaybe ) import Data.Pool ( Pool, createPool, destroyAllResources, withResource ) import Data.Proxy @@ -121,9 +122,10 @@ import System.Log.FastLogger import UnliftIO.Compat ( handleIf, mkRetryHandler ) import UnliftIO.Exception - ( Exception, bracket_, handleJust, mask_, throwIO, tryJust ) + ( Exception, bracket_, handleJust, mask_, tryJust ) +import UnliftIO.MVar + ( newMVar, withMVarMasked ) -import qualified Control.Concurrent.STM as STM import qualified Data.Aeson as Aeson import qualified Data.ByteString.Char8 as B8 import qualified Data.Text as T @@ -137,25 +139,13 @@ import qualified Database.Sqlite as Sqlite -- | Context for the SQLite 'DBLayer'. data SqliteContext = SqliteContext - { connectionPool :: Pool (SqlBackend, Sqlite.Connection) - -- ^ A handle to the Persistent SQL backend. - , isDatabaseActive :: TVar Bool - -- ^ A mutable reference to know whether the database is 'active'. This is - -- useful to prevent new requests from being accepted when we're trying to - -- shutdown the database. It is actually crucial with the connection pool - -- since, even though we can purge the pool of all existing resources, we - -- can't easily prevent the creation of new resources. This TVar must - -- therefore be used to guard any call to 'withResource'; if 'False', then - -- 'withResource' mustn't be called. - , runQuery :: forall a. SqlPersistT IO a -> IO a + { runQuery :: forall a. SqlPersistT IO a -> IO a -- ^ 'safely' run a query with logging and lock-protection , dbFile :: Maybe FilePath -- ^ The actual database file, if any. If none, runs in-memory } -data DatabaseIsShuttingDownError = DatabaseIsShuttingDownError deriving Show - -instance Exception DatabaseIsShuttingDownError +type ConnectionPool = Pool (SqlBackend, Sqlite.Connection) -- | Error type for when migrations go wrong after opening a database. newtype MigrationError = MigrationError @@ -193,57 +183,78 @@ handleConstraint e = handleJust select handler . fmap Right select _ = Nothing handler = const . pure . Left $ e --- | Free all allocated database connections. See also 'destroySqliteBackend' --- -destroyDBLayer :: Tracer IO DBLog -> SqliteContext -> IO () -destroyDBLayer tr SqliteContext{connectionPool,isDatabaseActive,dbFile} = do - STM.atomically $ writeTVar isDatabaseActive False - traceWith tr (MsgDestroyConnectionPool dbFile) - destroyAllResources connectionPool - {------------------------------------------------------------------------------- Internal / Database Setup -------------------------------------------------------------------------------} --- | Opens the SQLite database connection pool, sets up query logging and timing, --- runs schema migrations if necessary. +newInMemorySqliteContext + :: Tracer IO DBLog + -> [ManualMigration] + -> Migration + -> IO SqliteContext +newInMemorySqliteContext tr manualMigrations autoMigration = do + conn <- Sqlite.open connStr + mapM_ (`executeManualMigration` conn) manualMigrations + unsafeBackend <- wrapConnectionInfo info conn (queryLogFunc tr) + void $ runSqlConn (runMigrationQuiet autoMigration) unsafeBackend + + let observe :: forall a. IO a -> IO a + observe = bracketTracer (contramap MsgRun tr) + + -- We still use a lock with the in-memory database to protect it from + -- concurrent accesses and ensure database integrity in case where multiple + -- threads would be reading/writing from/to it. + lock <- newMVar unsafeBackend + let runQuery :: forall a. SqlPersistT IO a -> IO a + runQuery cmd = withMVarMasked lock (observe . runSqlConn cmd) + + return $ SqliteContext { runQuery, dbFile } + where + dbFile = Nothing + connStr = sqliteConnStr dbFile + info = mkSqliteConnectionInfo connStr + +-- | Sets up query logging and timing, runs schema migrations if necessary and +-- provide a safe 'SqliteContext' for interacting with the database. newSqliteContext - :: [ManualMigration] + :: Tracer IO DBLog + -> ConnectionPool + -> [ManualMigration] -> Migration - -> Tracer IO DBLog - -> Maybe FilePath + -> FilePath -> IO (Either MigrationError SqliteContext) -newSqliteContext manualMigrations autoMigration tr dbFile = do - isDatabaseActive <- newTVarIO True - createSqlitePool tr dbFile manualMigrations autoMigration <&> \case +newSqliteContext tr pool manualMigrations autoMigration fp = do + migrationResult <- withResource pool $ \(backend, conn) -> do + let executeAutoMigration = runSqlConn (runMigrationQuiet autoMigration) backend + migrationResult <- withForeignKeysDisabled tr conn $ do + mapM_ (`executeManualMigration` conn) manualMigrations + executeAutoMigration + & tryJust (matchMigrationError @PersistException) + & tryJust (matchMigrationError @SqliteException) + & fmap join + traceWith tr $ MsgMigrations $ fmap length migrationResult + return migrationResult + return $ case migrationResult of Left e -> Left e - Right connectionPool -> + Right{} -> let observe :: IO a -> IO a observe = bracketTracer (contramap MsgRun tr) - -- runSqlConn is guarded with a lock because it's not threadsafe in - -- general.It is also masked, so that the SqlBackend state is not - -- corrupted if a thread gets cancelled while running a query. - -- See: https://github.com/yesodweb/persistent/issues/981 - -- - -- Note that `withResource` does already mask async exception but - -- only for dealing with the pool resource acquisition. The action - -- is then ran unmasked with the acquired resource. If an - -- asynchronous exception occurs (or actually any exception), the - -- resource is NOT placed back in the pool. + -- runSqlConn is guarded with a lock because it's not threadsafe in + -- general.It is also masked, so that the SqlBackend state is not + -- corrupted if a thread gets cancelled while running a query. + -- See: https://github.com/yesodweb/persistent/issues/981 + -- + -- Note that `withResource` does already mask async exception but + -- only for dealing with the pool resource acquisition. The action + -- is then ran unmasked with the acquired resource. If an + -- asynchronous exception occurs (or actually any exception), the + -- resource is NOT placed back in the pool. runQuery :: SqlPersistT IO a -> IO a - runQuery cmd = do - readTVarIO isDatabaseActive >>= \case - False -> throwIO DatabaseIsShuttingDownError - True -> withResource connectionPool $ - mask_ . observe . retryOnBusy tr . runSqlConn cmd . fst - - in Right $ SqliteContext - { connectionPool - , isDatabaseActive - , runQuery - , dbFile - } + runQuery cmd = withResource pool $ + mask_ . observe . retryOnBusy tr . runSqlConn cmd . fst + + in Right $ SqliteContext { runQuery, dbFile = Just fp } -- | Finalize database statements and close the database connection. -- @@ -255,7 +266,7 @@ newSqliteContext manualMigrations autoMigration tr dbFile = do destroySqliteBackend :: Tracer IO DBLog -> SqlBackend - -> Maybe FilePath + -> FilePath -> IO () destroySqliteBackend tr sqlBackend dbFile = do traceWith tr (MsgCloseSingleConnection dbFile) @@ -406,56 +417,36 @@ instance MatchMigrationError SqliteException where newtype ManualMigration = ManualMigration { executeManualMigration :: Sqlite.Connection -> IO () } -createSqlitePool +newConnectionPool :: Tracer IO DBLog - -> Maybe FilePath - -> [ManualMigration] - -> Migration - -> IO (Either MigrationError (Pool (SqlBackend, Sqlite.Connection))) -createSqlitePool tr fp migrations autoMigration = do - let connStr = sqliteConnStr fp + -> FilePath + -> IO ConnectionPool +newConnectionPool tr fp = do + let connStr = sqliteConnStr (Just fp) let info = mkSqliteConnectionInfo connStr - traceWith tr $ MsgConnStr connStr - let createConnection = do + traceWith tr $ MsgWillOpenDB (Just fp) + + let acquireConnection = do conn <- Sqlite.open connStr (,conn) <$> wrapConnectionInfo info conn (queryLogFunc tr) - let destroyConnection = \(backend, _) -> do + let releaseConnection = \(backend, _) -> do destroySqliteBackend tr backend fp - pool <- createPool - createConnection - destroyConnection + createPool + acquireConnection + releaseConnection numberOfStripes timeToLive maximumConnections - - -- Run migrations BEFORE making the pool widely accessible to other threads. - -- This works fine for the :memory: case because there's a single connection - -- in the pool, so the next 'withResource' will get exactly this - -- connection. - migrationResult <- withResource pool $ \(backend, conn) -> mask_ $ do - let executeAutoMigration = runSqlConn (runMigrationQuiet autoMigration) backend - migrationResult <- withForeignKeysDisabled tr conn $ do - mapM_ (`executeManualMigration` conn) migrations - executeAutoMigration - & tryJust (matchMigrationError @PersistException) - & tryJust (matchMigrationError @SqliteException) - & fmap join - traceWith tr $ MsgMigrations $ fmap length migrationResult - return migrationResult - - case migrationResult of - Left e -> destroyAllResources pool $> Left e - Right{} -> return (Right pool) where numberOfStripes = 1 - -- When running in :memory:, we want a single connection that does not get - -- cleaned up. Indeed, the pool will regularly remove connections, destroying - -- our :memory: database regularly otherwise. - maximumConnections = maybe 1 (const 10) fp - timeToLive = maybe 31536000 {- one year -} (const 600) {- 10 minutes -} fp :: NominalDiffTime + maximumConnections = 10 + timeToLive = 600 {- 10 minutes -} :: NominalDiffTime + +destroyConnectionPool :: Pool a -> IO () +destroyConnectionPool = destroyAllResources sqliteConnStr :: Maybe FilePath -> Text sqliteConnStr = maybe ":memory:" T.pack @@ -468,9 +459,8 @@ data DBLog = MsgMigrations (Either MigrationError Int) | MsgQuery Text Severity | MsgRun BracketLog - | MsgConnStr Text - | MsgCloseSingleConnection (Maybe FilePath) - | MsgDestroyConnectionPool (Maybe FilePath) + | MsgCloseSingleConnection FilePath + | MsgDestroyConnectionPool FilePath | MsgWillOpenDB (Maybe FilePath) | MsgDatabaseReset | MsgIsAlreadyClosed Text @@ -545,7 +535,6 @@ instance HasSeverityAnnotation DBLog where MsgMigrations (Left _) -> Error MsgQuery _ sev -> sev MsgRun _ -> Debug - MsgConnStr _ -> Notice MsgCloseSingleConnection _ -> Info MsgDestroyConnectionPool _ -> Notice MsgWillOpenDB _ -> Info @@ -576,14 +565,13 @@ instance ToText DBLog where MsgQuery stmt _ -> stmt MsgRun b -> "Running database action - " <> toText b MsgWillOpenDB fp -> "Will open db at " <> (maybe "in-memory" T.pack fp) - MsgConnStr connStr -> "Using connection string: " <> connStr - MsgCloseSingleConnection fp -> - "Closing single database connection ("+|fromMaybe "in-memory" fp|+")" - MsgDestroyConnectionPool fp -> - "Destroy database connection pool ("+|fromMaybe "in-memory" fp|+")" MsgDatabaseReset -> "Non backward compatible database found. Removing old database \ \and re-creating it from scratch. Ignore the previous error." + MsgCloseSingleConnection fp -> + "Closing single database connection ("+|fp|+")" + MsgDestroyConnectionPool fp -> + "Destroy database connection pool ("+|fp|+")" MsgIsAlreadyClosed msg -> "Attempted to close an already closed connection: " <> msg MsgStatementAlreadyFinalized msg -> diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs index 2bf5dc160b6..8834819d3a1 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs @@ -30,6 +30,7 @@ module Cardano.Pool.DB.Sqlite , undecoratedDB , defaultFilePath , DatabaseView (..) + , createViews ) where import Prelude @@ -38,11 +39,13 @@ import Cardano.DB.Sqlite ( DBField (..) , DBLog (..) , ManualMigration (..) - , MigrationError (..) + , MigrationError , SqliteContext (..) - , destroyDBLayer + , destroyConnectionPool , fieldName , handleConstraint + , newConnectionPool + , newInMemorySqliteContext , newSqliteContext , tableName ) @@ -136,7 +139,7 @@ import System.FilePath import System.Random ( newStdGen ) import UnliftIO.Exception - ( bracket, throwIO ) + ( bracket, catch, throwIO ) import qualified Cardano.Pool.DB.Sqlite.TH as TH import qualified Cardano.Wallet.Primitive.Types as W @@ -201,12 +204,22 @@ withDecoratedDBLayer -> (DBLayer IO -> IO a) -- ^ Action to run. -> IO a -withDecoratedDBLayer dbDecorator tr fp ti action = do - traceWith tr (MsgGeneric $ MsgWillOpenDB fp) - bracket before after (action . decorateDBLayer dbDecorator . snd) +withDecoratedDBLayer dbDecorator tr mDatabaseDir ti action = do + case mDatabaseDir of + Nothing -> do + ctx <- newInMemorySqliteContext tr' createViews migrateAll + action (decorateDBLayer dbDecorator $ newDBLayer tr ti ctx) + + Just fp -> do + let acquirePool = newConnectionPool tr' fp + handlingPersistError tr fp $ + bracket acquirePool destroyConnectionPool $ \pool -> do + ctx <- newSqliteContext tr' pool createViews migrateAll fp + ctx & either + throwIO + (action . decorateDBLayer dbDecorator . newDBLayer tr ti) where - before = newDBLayer tr fp ti - after = destroyDBLayer (contramap MsgGeneric tr) . fst + tr' = contramap MsgGeneric tr -- | Sets up a connection to the SQLite database. -- @@ -221,21 +234,13 @@ withDecoratedDBLayer dbDecorator tr fp ti action = do newDBLayer :: Tracer IO PoolDbLog -- ^ Logging object - -> Maybe FilePath - -- ^ Database file location, or Nothing for in-memory database -> TimeInterpreter IO - -> IO (SqliteContext, DBLayer IO) -newDBLayer trace fp ti = do - let io = newSqliteContext - (migrateManually trace) - migrateAll - (contramap MsgGeneric trace) - fp - ctx@SqliteContext{runQuery} <- handlingPersistError trace fp io - pure (ctx, mkDBLayer runQuery) - where - mkDBLayer :: (forall a. SqlPersistT IO a -> IO a) -> DBLayer IO - mkDBLayer runQuery = DBLayer {..} + -- ^ Time interpreter for slot to time conversions + -> SqliteContext + -- ^ A (thread-) safe wrapper for running db queries. + -> DBLayer IO +newDBLayer tr ti SqliteContext{runQuery} = + DBLayer {..} where putPoolProduction point pool = ExceptT $ handleConstraint (ErrPointAlreadyExists point) $ @@ -254,7 +259,7 @@ newDBLayer trace fp ti = do pure (foldl' toMap Map.empty production) - readTotalProduction = Map.fromList <$> runRawQuery trace + readTotalProduction = Map.fromList <$> runRawQuery tr (RawQuery "readTotalProduction" query [] parseRow) where query = T.unwords @@ -417,7 +422,7 @@ newDBLayer trace fp ti = do , Desc PoolRegistrationSlotInternalIndex ] - listRetiredPools epochNo = runRawQuery trace $ + listRetiredPools epochNo = runRawQuery tr $ RawQuery "listRetiredPools" query parameters parseRow where query = T.unwords @@ -431,7 +436,7 @@ newDBLayer trace fp ti = do <$> fromPersistValue poolId <*> fromPersistValue retirementEpoch - listPoolLifeCycleData epochNo = runRawQuery trace $ RawQuery + listPoolLifeCycleData epochNo = runRawQuery tr $ RawQuery "listPoolLifeCycleData" query parameters parseRow where query = T.unwords @@ -501,7 +506,7 @@ newDBLayer trace fp ti = do fmap (delistedPoolId . entityVal) <$> selectList [] [] removePools = mapM_ $ \pool -> do - liftIO $ traceWith trace $ MsgRemovingPool pool + liftIO $ traceWith tr $ MsgRemovingPool pool deleteWhere [ PoolProductionPoolId ==. pool ] deleteWhere [ PoolOwnerPoolId ==. pool ] deleteWhere [ PoolRegistrationPoolId ==. pool ] @@ -515,11 +520,11 @@ newDBLayer trace fp ti = do traceInner retirementCerts removePools (view #poolId <$> retirementCerts) pure retirementCerts - traceOuter = trace + traceOuter = tr & natTracer liftIO & contramap (MsgRemovingRetiredPoolsForEpoch epoch) traceInner = liftIO - . traceWith trace + . traceWith tr . MsgRemovingRetiredPools readPoolProductionCursor k = do @@ -674,22 +679,19 @@ runRawQuery => Tracer IO PoolDbLog -> RawQuery a b -> SqlPersistT IO [b] -runRawQuery trace q = do +runRawQuery tr q = do (failures, results) <- partitionEithers . fmap (queryParser q) <$> rawSql (queryDefinition q) (queryParameters q) forM_ failures $ liftIO - . traceWith trace + . traceWith tr . MsgParseFailure . ParseFailure (queryName q) pure results -migrateManually - :: Tracer IO PoolDbLog - -> [ManualMigration] -migrateManually _tr = - ManualMigration <$> +createViews :: [ManualMigration] +createViews = ManualMigration <$> [ createView activePoolLifeCycleData , createView activePoolOwners , createView activePoolRegistrations @@ -858,17 +860,16 @@ activePoolRetirements = DatabaseView "active_pool_retirements" [i| handlingPersistError :: Tracer IO PoolDbLog -- ^ Logging object - -> Maybe FilePath + -> FilePath -- ^ Database file location, or Nothing for in-memory database - -> IO (Either MigrationError ctx) - -- ^ Action to set up the context. - -> IO ctx -handlingPersistError trace fp action = action >>= \case - Right ctx -> pure ctx - Left _ -> do - traceWith trace $ MsgGeneric MsgDatabaseReset - maybe (pure ()) removeFile fp - action >>= either throwIO pure + -> IO a + -- ^ Action to retry + -> IO a +handlingPersistError tr fp action = + action `catch` \(_e :: MigrationError) -> do + traceWith tr $ MsgGeneric MsgDatabaseReset + removeFile fp + action -- | Compute a new date from a base date, with an increasing delay. -- diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs index 4207814e43f..c3dbc3e940c 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs @@ -50,10 +50,12 @@ import Cardano.DB.Sqlite , chunkSize , dbChunked , dbChunked' - , destroyDBLayer + , destroyConnectionPool , fieldName , fieldType , handleConstraint + , newConnectionPool + , newInMemorySqliteContext , newSqliteContext , tableName ) @@ -124,7 +126,7 @@ import Cardano.Wallet.Primitive.Types.TokenBundle import Cardano.Wallet.Primitive.Types.TokenMap ( AssetId (..) ) import Control.Monad - ( forM, forM_, unless, void, when ) + ( forM, forM_, unless, void, when, (<=<) ) import Control.Monad.Extra ( concatMapM ) import Control.Monad.IO.Class @@ -247,14 +249,23 @@ withDBLayer -> Maybe FilePath -- ^ Path to database directory, or Nothing for in-memory database -> TimeInterpreter IO - -> ((SqliteContext, DBLayer IO s k) -> IO a) + -- ^ Time interpreter for slot to time conversions + -> (DBLayer IO s k -> IO a) -- ^ Action to run. -> IO a -withDBLayer tr defaultFieldValues mDatabaseDir ti = - bracket before after - where - before = newDBLayer tr defaultFieldValues mDatabaseDir ti - after = destroyDBLayer tr . fst +withDBLayer tr defaultFieldValues mDatabaseDir ti action = + case mDatabaseDir of + Nothing -> do + db <- newInMemorySqliteContext tr [] migrateAll >>= newDBLayer ti + action db + + Just fp -> do + let manualMigrations = migrateManually tr (Proxy @k) defaultFieldValues + let autoMigrations = migrateAll + let acquirePool = newConnectionPool tr fp + bracket acquirePool destroyConnectionPool $ \pool -> do + ctx <- newSqliteContext tr pool manualMigrations autoMigrations fp + either throwIO (action <=< newDBLayer ti) ctx -- | Instantiate a 'DBFactory' from a given directory newDBFactory @@ -268,7 +279,7 @@ newDBFactory -> DefaultFieldValues -- ^ Default database field values, used during migration. -> TimeInterpreter IO - + -- ^ Time interpreter for slot to time conversions -> Maybe FilePath -- ^ Path to database directory, or Nothing for in-memory database -> IO (DBFactory IO s k) @@ -286,8 +297,8 @@ newDBFactory tr defaultFieldValues ti = \case db <- modifyMVar mvar $ \m -> case Map.lookup wid m of Just (_, db) -> pure (m, db) Nothing -> do - (ctx, db) <- - newDBLayer tr defaultFieldValues Nothing ti + ctx <- newInMemorySqliteContext tr [] migrateAll + db <- newDBLayer ti ctx pure (Map.insert wid (ctx, db) m, db) action db , removeDatabase = \wid -> do @@ -306,7 +317,7 @@ newDBFactory tr defaultFieldValues ti = \case defaultFieldValues (Just $ databaseFile wid) ti - (action . snd) + action , removeDatabase = \wid -> do let widp = pretty wid -- try to wait for all 'withDatabase' calls to finish before @@ -1080,23 +1091,19 @@ data CacheBehavior -- If the given file path does not exist, it will be created by the sqlite -- library. -- --- 'getDBLayer' will provide the actual 'DBLayer' implementation. The database --- should be closed with 'destroyDBLayer'. If you use 'withDBLayer' then both of --- these things will be handled for you. +-- 'newDBLayer' will provide the actual 'DBLayer' implementation. It requires an +-- 'SqliteContext' which can be obtained from a database connection pool. This +-- is better initialized with 'withDBLayer'. newDBLayer :: forall s k. ( PersistState s , PersistPrivateKey (k 'RootK) - , WalletKey k ) - => Tracer IO DBLog - -- ^ Logging object - -> DefaultFieldValues - -- ^ Default database field values, used during migration. - -> Maybe FilePath - -- ^ Path to database file, or Nothing for in-memory database - -> TimeInterpreter IO - -> IO (SqliteContext, DBLayer IO s k) + => TimeInterpreter IO + -- ^ Time interpreter for slot to time conversions + -> SqliteContext + -- ^ A (thread-)safe wrapper for query execution. + -> IO (DBLayer IO s k) newDBLayer = newDBLayerWith @s @k CacheLatestCheckpoint @@ -1105,23 +1112,15 @@ newDBLayerWith :: forall s k. ( PersistState s , PersistPrivateKey (k 'RootK) - , WalletKey k ) => CacheBehavior - -> Tracer IO DBLog - -> DefaultFieldValues - -> Maybe FilePath + -- ^ Option to disable IORef caching. -> TimeInterpreter IO - -> IO (SqliteContext, DBLayer IO s k) -newDBLayerWith cacheBehavior trace defaultFieldValues mDatabaseFile ti = do - ctx@SqliteContext{runQuery} <- - either throwIO pure =<< - newSqliteContext - (migrateManually trace (Proxy @k) defaultFieldValues) - migrateAll - trace - mDatabaseFile - + -- ^ Time interpreter for slot to time conversions. + -> SqliteContext + -- ^ A (thread-)safe wrapper for query execution. + -> IO (DBLayer IO s k) +newDBLayerWith cacheBehavior ti SqliteContext{runQuery} = do -- NOTE1 -- We cache the latest checkpoint for read operation such that we prevent -- needless marshalling and unmarshalling with the database. Many handlers @@ -1190,7 +1189,7 @@ newDBLayerWith cacheBehavior trace defaultFieldValues mDatabaseFile ti = do writeCache wid Nothing selectLatestCheckpoint wid >>= writeCache wid - return (ctx, DBLayer + return DBLayer {----------------------------------------------------------------------- Wallets @@ -1427,8 +1426,7 @@ newDBLayerWith cacheBehavior trace defaultFieldValues mDatabaseFile ti = do -----------------------------------------------------------------------} , atomically = runQuery - - }) + } readWalletMetadata :: W.WalletId diff --git a/lib/core/test/bench/db/Main.hs b/lib/core/test/bench/db/Main.hs index 60aba9bfb7a..47c3a23eca2 100644 --- a/lib/core/test/bench/db/Main.hs +++ b/lib/core/test/bench/db/Main.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} @@ -49,11 +50,17 @@ import Cardano.BM.Data.Severity import Cardano.BM.Data.Trace ( Trace ) import Cardano.BM.Data.Tracer - ( Tracer, filterSeverity, nullTracer ) + ( Tracer, filterSeverity ) import Cardano.BM.Setup ( setupTrace_, shutdown ) import Cardano.DB.Sqlite - ( DBLog, SqliteContext, destroyDBLayer ) + ( ConnectionPool + , DBLog + , SqliteContext (..) + , destroyConnectionPool + , newConnectionPool + , newSqliteContext + ) import Cardano.Mnemonic ( EntropySize, SomeMnemonic (..), entropyToMnemonic, genEntropy ) import Cardano.Startup @@ -61,11 +68,9 @@ import Cardano.Startup import Cardano.Wallet.DB ( DBLayer (..), PrimaryKey (..), cleanDB ) import Cardano.Wallet.DB.Sqlite - ( CacheBehavior (..) - , DefaultFieldValues (..) - , PersistState - , newDBLayerWith - ) + ( CacheBehavior (..), PersistState, newDBLayerWith ) +import Cardano.Wallet.DB.Sqlite.TH + ( migrateAll ) import Cardano.Wallet.DummyTarget.Primitive.Types ( block0, dummyGenesisParameters, mkTxId ) import Cardano.Wallet.Logging @@ -102,7 +107,7 @@ import Cardano.Wallet.Primitive.AddressDiscovery.Sequential import Cardano.Wallet.Primitive.Model ( Wallet, initWallet, unsafeInitWallet ) import Cardano.Wallet.Primitive.Slotting - ( hoistTimeInterpreter, mkSingleEraInterpreter ) + ( TimeInterpreter, hoistTimeInterpreter, mkSingleEraInterpreter ) import Cardano.Wallet.Primitive.Types ( ActiveSlotCoefficient (..) , Block (..) @@ -186,8 +191,6 @@ import Data.Time.Clock.System ( SystemTime (..), systemToUTCTime ) import Data.Word ( Word64 ) -import Database.Sqlite - ( SqliteException (..) ) import Fmt ( build, padLeftF, padRightF, pretty, (+|), (|+) ) import System.Directory @@ -201,7 +204,7 @@ import System.IO.Unsafe import System.Random ( mkStdGen, randoms ) import UnliftIO.Exception - ( bracket, handle ) + ( bracket, throwIO ) import qualified Cardano.BM.Configuration.Model as CM import qualified Cardano.BM.Data.BackendKind as CM @@ -664,13 +667,17 @@ setupDB , WalletKey k ) => Tracer IO DBLog - -> IO (FilePath, SqliteContext, DBLayer IO s k) + -> IO (ConnectionPool, SqliteContext, DBLayer IO s k) setupDB tr = do f <- emptySystemTempFile "bench.db" - (ctx, db) <- newDBLayerWith NoCache tr defaultFieldValues (Just f) ti - pure (f, ctx, db) - where - ti = hoistTimeInterpreter (pure . runIdentity) $ mkSingleEraInterpreter + pool <- newConnectionPool tr f + ctx <- either throwIO pure =<< newSqliteContext tr pool [] migrateAll f + db <- newDBLayerWith NoCache singleEraInterpreter ctx + pure (pool, ctx, db) + +singleEraInterpreter :: TimeInterpreter IO +singleEraInterpreter = hoistTimeInterpreter (pure . runIdentity) $ + mkSingleEraInterpreter (StartTime $ posixSecondsToUTCTime 0) (SlottingParameters { getSlotLength = SlotLength 1 @@ -679,20 +686,11 @@ setupDB tr = do , getSecurityParameter = Quantity 2160 }) -defaultFieldValues :: DefaultFieldValues -defaultFieldValues = DefaultFieldValues - { defaultActiveSlotCoefficient = ActiveSlotCoefficient 1.0 - , defaultDesiredNumberOfPool = 50 - , defaultMinimumUTxOValue = Coin 0 - , defaultHardforkEpoch = Nothing - -- NOTE value in the genesis when at the time this migration was needed. - , defaultKeyDeposit = Coin 0 - } - -cleanupDB :: (FilePath, SqliteContext, DBLayer IO s k) -> IO () -cleanupDB (db, ctx, _) = do - handle (\SqliteException{} -> pure ()) $ destroyDBLayer nullTracer ctx - mapM_ remove [db, db <> "-shm", db <> "-wal"] +cleanupDB :: (ConnectionPool, SqliteContext, DBLayer IO s k) -> IO () +cleanupDB (pool, SqliteContext{dbFile}, _) = do + destroyConnectionPool pool + let f = fromMaybe ":memory:" dbFile + mapM_ remove [f, f <> "-shm", f <> "-wal"] where remove f = doesFileExist f >>= \case True -> removeFile f @@ -775,12 +773,14 @@ txHistoryDiskSpaceTests tr = do benchPutTxHistory n i o 0 [1..100] db benchDiskSize :: Tracer IO DBLog -> (DBLayerBench -> IO ()) -> IO () -benchDiskSize tr action = bracket (setupDB tr) cleanupDB $ \(f, ctx, db) -> do - action db - mapM_ (printFileSize "") [f, f <> "-shm", f <> "-wal"] - destroyDBLayer nullTracer ctx - printFileSize " (closed)" f - putStrLn "" +benchDiskSize tr action = bracket (setupDB tr) cleanupDB + $ \(pool, SqliteContext{dbFile}, db) -> do + let f = fromMaybe ":memory:" dbFile + action db + mapM_ (printFileSize "") [f, f <> "-shm", f <> "-wal"] + destroyConnectionPool pool + printFileSize " (closed)" f + putStrLn "" where printFileSize sfx f = do size <- doesFileExist f >>= \case @@ -814,6 +814,9 @@ instance NFData (DBLayer m s k) where instance NFData SqliteContext where rnf _ = () +instance NFData ConnectionPool where + rnf _ = () + testCp :: WalletBench testCp = snd $ initWallet block0 initDummySeqState diff --git a/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs b/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs index 08e6f25d466..4fe79050ead 100644 --- a/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs +++ b/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs @@ -16,7 +16,7 @@ import Prelude import Cardano.BM.Trace ( nullTracer ) import Cardano.DB.Sqlite - ( DBLog (..) ) + ( DBLog (..), newInMemorySqliteContext ) import Cardano.Pool.DB ( DBLayer (..) ) import Cardano.Pool.DB.Log @@ -24,9 +24,13 @@ import Cardano.Pool.DB.Log import Cardano.Pool.DB.Properties ( properties ) import Cardano.Pool.DB.Sqlite - ( withDBLayer ) + ( createViews, newDBLayer, withDBLayer ) +import Cardano.Pool.DB.Sqlite.TH + ( migrateAll ) import Cardano.Wallet.DummyTarget.Primitive.Types ( dummyTimeInterpreter ) +import Control.Tracer + ( contramap ) import System.Directory ( copyFile ) import System.FilePath @@ -68,7 +72,7 @@ test_migrationFromv20191216 = withDBLayer tr (Just path) ti $ \_ -> pure () withDBLayer tr (Just path) ti $ \_ -> pure () - let databaseConnMsg = filter isMsgConnStr logs + let databaseConnMsg = filter isMsgWillOpenDB logs let databaseResetMsg = filter (== MsgGeneric MsgDatabaseReset) logs let migrationErrMsg = filter isMsgMigrationError logs @@ -76,9 +80,9 @@ test_migrationFromv20191216 = length databaseResetMsg `shouldBe` 1 length migrationErrMsg `shouldBe` 1 -isMsgConnStr :: PoolDbLog -> Bool -isMsgConnStr (MsgGeneric (MsgConnStr _)) = True -isMsgConnStr _ = False +isMsgWillOpenDB :: PoolDbLog -> Bool +isMsgWillOpenDB (MsgGeneric (MsgWillOpenDB _)) = True +isMsgWillOpenDB _ = False isMsgMigrationError :: PoolDbLog -> Bool isMsgMigrationError (MsgGeneric (MsgMigrations (Left _))) = True diff --git a/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs b/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs index 670afd1b793..3afd5d1300a 100644 --- a/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs @@ -47,7 +47,12 @@ import Cardano.BM.Trace import Cardano.Crypto.Wallet ( XPrv ) import Cardano.DB.Sqlite - ( DBLog (..), SqliteContext, fieldName ) + ( DBLog (..) + , SqliteContext + , destroyDBLayer + , fieldName + , newInMemorySqliteContext + ) import Cardano.Mnemonic ( SomeMnemonic (..) ) import Cardano.Wallet.DB @@ -160,10 +165,6 @@ import Data.ByteString ( ByteString ) import Data.Coerce ( coerce ) -import Data.Function - ( (&) ) -import Data.Functor - ( ($>) ) import Data.Generics.Internal.VL.Lens ( (^.) ) import Data.Generics.Labels @@ -406,7 +407,7 @@ spec = parallel $ do sqliteSpecSeq :: Spec sqliteSpecSeq = do validateGenerators @(SeqState 'Mainnet ShelleyKey) - around (withDBLayer' Nothing) $ do + around (withShelleyDBLayer Nothing) $ do parallel $ describe "Sqlite" properties parallel $ describe "Sqlite State machine tests" $ do it "Sequential" (prop_sequential :: TestDBSeq -> Property) @@ -441,7 +442,7 @@ testMigrationTxMetaFee dbName expectedLength caseByCase = do copyFile orig path (logs, result) <- captureLogging $ \tr -> do withDBLayer @s @k tr defaultFieldValues (Just path) ti - $ \(_, db) -> db & \DBLayer{..} -> atomically + $ \DBLayer{..} -> atomically $ do [wid] <- listWallets readTxHistory wid Nothing Descending wholeRange Nothing @@ -497,7 +498,7 @@ testMigrationCleanupCheckpoints dbName genesisParameters tip = do copyFile orig path (logs, result) <- captureLogging $ \tr -> do withDBLayer @s @k tr defaultFieldValues (Just path) ti - $ \(_, db) -> db & \DBLayer{..} -> atomically + $ \DBLayer{..} -> atomically $ do [wid] <- listWallets (,) <$> readGenesisParameters wid <*> readCheckpoint wid @@ -536,7 +537,7 @@ testMigrationRole dbName = do copyFile orig path (logs, Just cp) <- captureLogging $ \tr -> do withDBLayer @s @k tr defaultFieldValues (Just path) ti - $ \(_, db) -> db & \DBLayer{..} -> atomically + $ \DBLayer{..} -> atomically $ do [wid] <- listWallets readCheckpoint wid @@ -574,7 +575,7 @@ testMigrationSeqStateDerivationPrefix dbName prefix = do copyFile orig path (logs, Just cp) <- captureLogging $ \tr -> do withDBLayer @s @k tr defaultFieldValues (Just path) ti - $ \(_, db) -> db & \DBLayer{..} -> atomically + $ \DBLayer{..} -> atomically $ do [wid] <- listWallets readCheckpoint wid @@ -601,7 +602,7 @@ testMigrationPassphraseScheme = do copyFile orig path (logs, (a,b,c,d)) <- captureLogging $ \tr -> do withDBLayer @s @k tr defaultFieldValues (Just path) ti - $ \(_, db) -> db & \DBLayer{..} -> atomically + $ \DBLayer{..} -> atomically $ do Just a <- readWalletMeta $ PrimaryKey walNeedMigration Just b <- readWalletMeta $ PrimaryKey walNewScheme @@ -731,7 +732,7 @@ fileModeSpec = do it "Opening and closing of db works" $ do replicateM_ 25 $ do db <- Just <$> temporaryDBFile - withDBLayer' @(SeqState 'Mainnet ShelleyKey) db + withShelleyDBLayer @(SeqState 'Mainnet ShelleyKey) db (\_ -> pure ()) describe "DBFactory" $ do @@ -809,13 +810,13 @@ fileModeSpec = do describe "Check db reading/writing from/to file and cleaning" $ do it "create and list wallet works" $ \f -> do - withDBLayer' (Just f) $ \DBLayer{..} -> do + withShelleyDBLayer (Just f) $ \DBLayer{..} -> do atomically $ unsafeRunExceptT $ initializeWallet testPk testCp testMetadata mempty gp testOpeningCleaning f listWallets' [testPk] [] it "create and get meta works" $ \f -> do - meta <- withDBLayer' (Just f) $ \DBLayer{..} -> do + meta <- withShelleyDBLayer (Just f) $ \DBLayer{..} -> do now <- getCurrentTime let meta = testMetadata { passphraseInfo = Just $ WalletPassphraseInfo now EncryptWithPBKDF2 } @@ -825,14 +826,14 @@ fileModeSpec = do testOpeningCleaning f (`readWalletMeta'` testPk) (Just meta) Nothing it "create and get private key" $ \f-> do - (k, h) <- withDBLayer' (Just f) $ \db@DBLayer{..} -> do + (k, h) <- withShelleyDBLayer (Just f) $ \db@DBLayer{..} -> do atomically $ unsafeRunExceptT $ initializeWallet testPk testCp testMetadata mempty gp unsafeRunExceptT $ attachPrivateKey db testPk testOpeningCleaning f (`readPrivateKey'` testPk) (Just (k, h)) Nothing it "put and read tx history (Ascending)" $ \f -> do - withDBLayer' (Just f) $ \DBLayer{..} -> do + withShelleyDBLayer (Just f) $ \DBLayer{..} -> do atomically $ do unsafeRunExceptT $ initializeWallet testPk testCp testMetadata mempty gp @@ -844,7 +845,7 @@ fileModeSpec = do mempty it "put and read tx history (Decending)" $ \f -> do - withDBLayer' (Just f) $ \DBLayer{..} -> do + withShelleyDBLayer (Just f) $ \DBLayer{..} -> do atomically $ do unsafeRunExceptT $ initializeWallet testPk testCp testMetadata mempty gp @@ -856,7 +857,7 @@ fileModeSpec = do mempty it "put and read checkpoint" $ \f -> do - withDBLayer' (Just f) $ \DBLayer{..} -> do + withShelleyDBLayer (Just f) $ \DBLayer{..} -> do atomically $ do unsafeRunExceptT $ initializeWallet testPk testCp testMetadata mempty gp @@ -868,8 +869,9 @@ fileModeSpec = do let dummyAddr x = Address $ x <> BS.pack (replicate (32 - (BS.length x)) 0) it "(Regression test #1575) - TxMetas and checkpoints should \ - \rollback to the same place" - $ \f -> withDBLayer' (Just f) $ \db@DBLayer{..} -> do + \rollback to the same place" $ \f -> do + withShelleyDBLayer (Just f) $ \db@DBLayer{..} -> do + let ourAddrs = knownAddresses (getState testCp) atomically $ unsafeRunExceptT $ initializeWallet @@ -950,13 +952,12 @@ prop_randomOpChunks (KeyValPairs pairs) = where prop = do filepath <- temporaryDBFile - withDBLayer' (Just filepath) $ \dbF -> do + withShelleyDBLayer (Just filepath) $ \dbF -> do cleanDB dbF - withDBLayer' Nothing $ \dbM -> do + withShelleyDBLayer Nothing $ \dbM -> do cleanDB dbM forM_ pairs (insertPair dbM) - cutRandomly pairs >>= mapM_ (\chunk -> do - withDBLayer' (Just filepath) (forM_ chunk . insertPair)) + cutRandomly pairs >>= mapM_ (mapM (insertPair dbF)) dbF `shouldBeConsistentWith` dbM insertPair @@ -999,12 +1000,12 @@ testOpeningCleaning -> s -> Expectation testOpeningCleaning filepath call expectedAfterOpen expectedAfterClean = do - withDBLayer' (Just filepath) $ \db1 -> do - call db1 `shouldReturn` expectedAfterOpen - _ <- cleanDB db1 - call db1 `shouldReturn` expectedAfterClean - withDBLayer' (Just filepath) $ \db2 -> do - call db2 `shouldReturn` expectedAfterClean + withShelleyDBLayer (Just filepath) $ \db -> do + call db `shouldReturn` expectedAfterOpen + _ <- cleanDB db + call db `shouldReturn` expectedAfterClean + withShelleyDBLayer (Just filepath) $ \db -> do + call db `shouldReturn` expectedAfterClean -- | Run a test action inside withDBLayer, then check assertions. withTestDBFile @@ -1022,7 +1023,7 @@ withTestDBFile action expectations = do defaultFieldValues (Just fp) ti - (action . snd) + action expectations fp where ti = dummyTimeInterpreter @@ -1039,23 +1040,29 @@ defaultFieldValues = DefaultFieldValues , defaultKeyDeposit = Coin 2_000_000 } -withDBLayer' - :: (PersistState s) - => Maybe FilePath -- ^ Just for on-disk db, Nothing for in-memory. - -> (((DBLayer IO s ShelleyKey) -> IO a) -> IO a) -withDBLayer' fp = withDBLayer nullTracer defaultFieldValues fp ti . (. snd) - where - ti = dummyTimeInterpreter - -- Note: Having two separate helpers with concrete key types reduces the need -- for type-application everywhere. withByronDBLayer - :: (PersistState s) + :: PersistState s => Maybe FilePath -- ^ Just for on-disk db, Nothing for in-memory. - -> (((DBLayer IO s ByronKey) -> IO a) -> IO a) -withByronDBLayer fp = withDBLayer nullTracer defaultFieldValues fp ti . (. snd) - where - ti = dummyTimeInterpreter + -> ((DBLayer IO s ByronKey) -> IO a) + -> IO a +withByronDBLayer fp = withDBLayer + nullTracer + defaultFieldValues + fp + dummyTimeInterpreter + +withShelleyDBLayer + :: PersistState s + => Maybe FilePath + -> (DBLayer IO s ShelleyKey -> IO a) + -> IO a +withShelleyDBLayer fp = withDBLayer + nullTracer + defaultFieldValues + fp + dummyTimeInterpreter listWallets' :: DBLayer m s k diff --git a/lib/shelley/bench/Restore.hs b/lib/shelley/bench/Restore.hs index ca8d0de0fba..41be5adbef3 100644 --- a/lib/shelley/bench/Restore.hs +++ b/lib/shelley/bench/Restore.hs @@ -53,8 +53,6 @@ import Cardano.BM.Data.Tracer ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) ) import Cardano.BM.Trace ( Trace, nullTracer ) -import Cardano.DB.Sqlite - ( destroyDBLayer ) import Cardano.Mnemonic ( SomeMnemonic (..), entropyToMnemonic ) import Cardano.Wallet @@ -73,7 +71,7 @@ import Cardano.Wallet.BenchShared import Cardano.Wallet.DB ( DBLayer ) import Cardano.Wallet.DB.Sqlite - ( PersistState, newDBLayer ) + ( PersistState, withDBLayer ) import Cardano.Wallet.Logging ( trMessageText ) import Cardano.Wallet.Network @@ -205,7 +203,7 @@ import Type.Reflection import UnliftIO.Concurrent ( forkIO, threadDelay ) import UnliftIO.Exception - ( bracket, evaluate, throwString ) + ( evaluate, throwString ) import UnliftIO.Temporary ( withSystemTempFile ) @@ -691,10 +689,8 @@ withBenchDBLayer -> (DBLayer IO s k -> IO a) -> IO a withBenchDBLayer ti tr action = - withSystemTempFile "bench.db" $ \dbFile _ -> do - let before = newDBLayer tr' migrationDefaultValues (Just dbFile) ti - let after = destroyDBLayer tr' . fst - bracket before after $ \(_ctx, db) -> action db + withSystemTempFile "bench.db" $ \dbFile _ -> + withDBLayer tr' migrationDefaultValues (Just dbFile) ti action where migrationDefaultValues = Sqlite.DefaultFieldValues { Sqlite.defaultActiveSlotCoefficient = 1 From 037e95e8c27fc23977188c01d2ab4eaac15350fe Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Wed, 17 Feb 2021 14:41:28 +0800 Subject: [PATCH 04/21] Regenerate nix --- nix/.stack.nix/cardano-wallet-core.nix | 5 +++-- nix/.stack.nix/cardano-wallet-test-utils.nix | 3 +++ 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/nix/.stack.nix/cardano-wallet-core.nix b/nix/.stack.nix/cardano-wallet-core.nix index c112293c6d6..5503c4a7225 100644 --- a/nix/.stack.nix/cardano-wallet-core.nix +++ b/nix/.stack.nix/cardano-wallet-core.nix @@ -82,6 +82,7 @@ (hsPkgs."quiet" or (errorHandler.buildDepError "quiet")) (hsPkgs."random" or (errorHandler.buildDepError "random")) (hsPkgs."random-shuffle" or (errorHandler.buildDepError "random-shuffle")) + (hsPkgs."resource-pool" or (errorHandler.buildDepError "resource-pool")) (hsPkgs."retry" or (errorHandler.buildDepError "retry")) (hsPkgs."safe" or (errorHandler.buildDepError "safe")) (hsPkgs."scientific" or (errorHandler.buildDepError "scientific")) @@ -210,7 +211,9 @@ (hsPkgs."cardano-crypto" or (errorHandler.buildDepError "cardano-crypto")) (hsPkgs."cardano-wallet-core" or (errorHandler.buildDepError "cardano-wallet-core")) (hsPkgs."cardano-wallet-launcher" or (errorHandler.buildDepError "cardano-wallet-launcher")) + (hsPkgs."cardano-wallet-test-utils" or (errorHandler.buildDepError "cardano-wallet-test-utils")) (hsPkgs."containers" or (errorHandler.buildDepError "containers")) + (hsPkgs."contra-tracer" or (errorHandler.buildDepError "contra-tracer")) (hsPkgs."criterion" or (errorHandler.buildDepError "criterion")) (hsPkgs."cryptonite" or (errorHandler.buildDepError "cryptonite")) (hsPkgs."deepseq" or (errorHandler.buildDepError "deepseq")) @@ -219,9 +222,7 @@ (hsPkgs."fmt" or (errorHandler.buildDepError "fmt")) (hsPkgs."iohk-monitoring" or (errorHandler.buildDepError "iohk-monitoring")) (hsPkgs."memory" or (errorHandler.buildDepError "memory")) - (hsPkgs."persistent-sqlite" or (errorHandler.buildDepError "persistent-sqlite")) (hsPkgs."random" or (errorHandler.buildDepError "random")) - (hsPkgs."temporary" or (errorHandler.buildDepError "temporary")) (hsPkgs."text" or (errorHandler.buildDepError "text")) (hsPkgs."text-class" or (errorHandler.buildDepError "text-class")) (hsPkgs."time" or (errorHandler.buildDepError "time")) diff --git a/nix/.stack.nix/cardano-wallet-test-utils.nix b/nix/.stack.nix/cardano-wallet-test-utils.nix index ea0a3fcab51..94ed73d992a 100644 --- a/nix/.stack.nix/cardano-wallet-test-utils.nix +++ b/nix/.stack.nix/cardano-wallet-test-utils.nix @@ -49,6 +49,7 @@ (hsPkgs."text-class" or (errorHandler.buildDepError "text-class")) (hsPkgs."time" or (errorHandler.buildDepError "time")) (hsPkgs."unliftio" or (errorHandler.buildDepError "unliftio")) + (hsPkgs."unliftio-core" or (errorHandler.buildDepError "unliftio-core")) (hsPkgs."wai-app-static" or (errorHandler.buildDepError "wai-app-static")) (hsPkgs."warp" or (errorHandler.buildDepError "warp")) ]; @@ -61,8 +62,10 @@ (hsPkgs."cardano-wallet-test-utils" or (errorHandler.buildDepError "cardano-wallet-test-utils")) (hsPkgs."hspec" or (errorHandler.buildDepError "hspec")) (hsPkgs."hspec-core" or (errorHandler.buildDepError "hspec-core")) + (hsPkgs."hspec-expectations-lifted" or (errorHandler.buildDepError "hspec-expectations-lifted")) (hsPkgs."silently" or (errorHandler.buildDepError "silently")) (hsPkgs."unliftio" or (errorHandler.buildDepError "unliftio")) + (hsPkgs."unliftio-core" or (errorHandler.buildDepError "unliftio-core")) ]; build-tools = [ (hsPkgs.buildPackages.hspec-discover or (pkgs.buildPackages.hspec-discover or (errorHandler.buildToolDepError "hspec-discover"))) From da6afb332f66b30bdb2b042f64d9ad6efb0695a1 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Wed, 17 Feb 2021 15:19:35 +0800 Subject: [PATCH 05/21] newConnectionPool -> withConnectionPool --- lib/core/src/Cardano/DB/Sqlite.hs | 13 ++++++++++--- lib/core/src/Cardano/Pool/DB/Sqlite.hs | 19 ++++++++----------- lib/core/src/Cardano/Wallet/DB/Sqlite.hs | 10 +++++----- 3 files changed, 23 insertions(+), 19 deletions(-) diff --git a/lib/core/src/Cardano/DB/Sqlite.hs b/lib/core/src/Cardano/DB/Sqlite.hs index 8fc9d986ef7..14cc1a27fff 100644 --- a/lib/core/src/Cardano/DB/Sqlite.hs +++ b/lib/core/src/Cardano/DB/Sqlite.hs @@ -29,8 +29,7 @@ module Cardano.DB.Sqlite -- * ConnectionPool , ConnectionPool - , newConnectionPool - , destroyConnectionPool + , withConnectionPool -- * Helpers , chunkSize @@ -122,7 +121,7 @@ import System.Log.FastLogger import UnliftIO.Compat ( handleIf, mkRetryHandler ) import UnliftIO.Exception - ( Exception, bracket_, handleJust, mask_, tryJust ) + ( Exception, bracket, bracket_, handleJust, mask_, tryJust ) import UnliftIO.MVar ( newMVar, withMVarMasked ) @@ -417,6 +416,14 @@ instance MatchMigrationError SqliteException where newtype ManualMigration = ManualMigration { executeManualMigration :: Sqlite.Connection -> IO () } +withConnectionPool + :: Tracer IO DBLog + -> FilePath + -> (ConnectionPool -> IO a) + -> IO a +withConnectionPool tr fp = + bracket (newConnectionPool tr fp) destroyConnectionPool + newConnectionPool :: Tracer IO DBLog -> FilePath diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs index 8834819d3a1..333a20cf984 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs @@ -41,13 +41,12 @@ import Cardano.DB.Sqlite , ManualMigration (..) , MigrationError , SqliteContext (..) - , destroyConnectionPool , fieldName , handleConstraint - , newConnectionPool , newInMemorySqliteContext , newSqliteContext , tableName + , withConnectionPool ) import Cardano.Pool.DB ( DBLayer (..), ErrPointAlreadyExists (..), determinePoolLifeCycleStatus ) @@ -139,7 +138,7 @@ import System.FilePath import System.Random ( newStdGen ) import UnliftIO.Exception - ( bracket, catch, throwIO ) + ( catch, throwIO ) import qualified Cardano.Pool.DB.Sqlite.TH as TH import qualified Cardano.Wallet.Primitive.Types as W @@ -210,14 +209,12 @@ withDecoratedDBLayer dbDecorator tr mDatabaseDir ti action = do ctx <- newInMemorySqliteContext tr' createViews migrateAll action (decorateDBLayer dbDecorator $ newDBLayer tr ti ctx) - Just fp -> do - let acquirePool = newConnectionPool tr' fp - handlingPersistError tr fp $ - bracket acquirePool destroyConnectionPool $ \pool -> do - ctx <- newSqliteContext tr' pool createViews migrateAll fp - ctx & either - throwIO - (action . decorateDBLayer dbDecorator . newDBLayer tr ti) + Just fp -> handlingPersistError tr fp $ + withConnectionPool tr' fp $ \pool -> do + ctx <- newSqliteContext tr' pool createViews migrateAll fp + ctx & either + throwIO + (action . decorateDBLayer dbDecorator . newDBLayer tr ti) where tr' = contramap MsgGeneric tr diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs index c3dbc3e940c..401bf0d0483 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs @@ -50,14 +50,13 @@ import Cardano.DB.Sqlite , chunkSize , dbChunked , dbChunked' - , destroyConnectionPool , fieldName , fieldType , handleConstraint - , newConnectionPool , newInMemorySqliteContext , newSqliteContext , tableName + , withConnectionPool ) import Cardano.DB.Sqlite.Delete ( deleteSqliteDatabase, newRefCount, waitForFree, withRef ) @@ -210,7 +209,7 @@ import System.Directory import System.FilePath ( () ) import UnliftIO.Exception - ( Exception, bracket, throwIO ) + ( Exception, throwIO ) import UnliftIO.MVar ( modifyMVar, modifyMVar_, newMVar, readMVar ) @@ -262,8 +261,7 @@ withDBLayer tr defaultFieldValues mDatabaseDir ti action = Just fp -> do let manualMigrations = migrateManually tr (Proxy @k) defaultFieldValues let autoMigrations = migrateAll - let acquirePool = newConnectionPool tr fp - bracket acquirePool destroyConnectionPool $ \pool -> do + withConnectionPool tr fp $ \pool -> do ctx <- newSqliteContext tr pool manualMigrations autoMigrations fp either throwIO (action <=< newDBLayer ti) ctx @@ -323,6 +321,8 @@ newDBFactory tr defaultFieldValues ti = \case -- try to wait for all 'withDatabase' calls to finish before -- deleting database file. let trWait = contramap (MsgWaitingForDatabase widp) tr + -- TODO: rather than refcounting, why not keep retrying the + -- delete until there are no file busy errors? waitForFree trWait refs wid $ \inUse -> do unless (inUse == 0) $ traceWith tr $ MsgRemovingInUse widp inUse From 6009b5d6dd6944dbb90910c15ebd96a0ec0a2be4 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Thu, 18 Feb 2021 13:41:25 +0800 Subject: [PATCH 06/21] Add tests for aroundAll --- .../cardano-wallet-test-utils.cabal | 2 + lib/test-utils/test/Test/Hspec/ExtraSpec.hs | 151 +++++++++++++----- 2 files changed, 117 insertions(+), 36 deletions(-) diff --git a/lib/test-utils/cardano-wallet-test-utils.cabal b/lib/test-utils/cardano-wallet-test-utils.cabal index 13273f92a51..c7966980260 100644 --- a/lib/test-utils/cardano-wallet-test-utils.cabal +++ b/lib/test-utils/cardano-wallet-test-utils.cabal @@ -82,8 +82,10 @@ test-suite unit , cardano-wallet-test-utils , hspec , hspec-core + , hspec-expectations-lifted , silently , unliftio + , unliftio-core build-tools: hspec-discover type: diff --git a/lib/test-utils/test/Test/Hspec/ExtraSpec.hs b/lib/test-utils/test/Test/Hspec/ExtraSpec.hs index d3ccdddd20f..2fa80c0d639 100644 --- a/lib/test-utils/test/Test/Hspec/ExtraSpec.hs +++ b/lib/test-utils/test/Test/Hspec/ExtraSpec.hs @@ -1,7 +1,14 @@ -module Test.Hspec.ExtraSpec where +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Hspec.ExtraSpec (spec) where import Prelude +import Control.Monad.IO.Unlift + ( MonadUnliftIO (..) ) +import Data.Bifunctor + ( first ) import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) import Data.List @@ -9,7 +16,7 @@ import Data.List import System.Environment ( setEnv ) import System.IO.Silently - ( capture_ ) + ( capture_, silence ) import Test.Hspec ( ActionWith , Expectation @@ -24,47 +31,61 @@ import Test.Hspec , shouldContain ) import Test.Hspec.Core.Runner - ( defaultConfig, runSpec ) + ( Summary (..), defaultConfig, runSpec ) +import Test.Hspec.Core.Spec + ( runIO, sequential ) +import Test.Hspec.Expectations.Lifted + ( shouldReturn ) +import Test.Hspec.Extra + ( aroundAll ) import UnliftIO.Concurrent ( threadDelay ) +import UnliftIO.Exception + ( bracket, throwString, tryAny ) +import UnliftIO.MVar + ( MVar, newEmptyMVar, newMVar, putMVar, tryReadMVar, tryTakeMVar ) import qualified Test.Hspec.Extra as Extra spec :: Spec spec = do - describe "Extra.it" $ before_ (setEnv "TESTS_RETRY_FAILED" "y") $ do - it "equals Hspec.it on success" $ do - let test = 1 `shouldBe` (1::Int) - test `shouldMatchHSpecIt` test - - it "equals Hspec.it on failure" $ do - let test = (2+2) `shouldBe` (5::Int) - test `shouldMatchHSpecIt` test - - describe "when first attempt fails due to flakiness" $ do - describe "when the retry succeeds" $ do - let flaky = expectationFailure "flaky test" - let succeed = 1 `shouldBe` (1 :: Int) - it "succeeds" $ do - outcomes <- newIORef [flaky, succeed] - (dynamically outcomes) `shouldMatchHSpecIt` succeed - - describe "when the retry also fails" $ do - -- Some tests use limited resources and cannot be retried. - -- On failures, we should make sure to show the first failure - -- which is the interesting one. - it "fails with the first error" $ do - let failure = expectationFailure "failure" - let noRetry = expectationFailure "test can't be retried" - outcomes <- newIORef [failure, noRetry] - (dynamically outcomes) `shouldMatchHSpecIt` failure - it "can time out" $ do - let micro = (1000*1000 *) - let timeout = do - threadDelay (micro 10) - expectationFailure "should have timed out" - res <- run (Extra.itWithCustomTimeout 2) timeout - res `shouldContain` "timed out in 2 seconds" + itSpec + aroundAllSpec + +itSpec :: Spec +itSpec = describe "Extra.it" $ before_ (setEnv "TESTS_RETRY_FAILED" "y") $ do + it "equals Hspec.it on success" $ do + let test = 1 `shouldBe` (1::Int) + test `shouldMatchHSpecIt` test + + it "equals Hspec.it on failure" $ do + let test = (2+2) `shouldBe` (5::Int) + test `shouldMatchHSpecIt` test + + describe "when first attempt fails due to flakiness" $ do + describe "when the retry succeeds" $ do + let flaky = expectationFailure "flaky test" + let succeed = 1 `shouldBe` (1 :: Int) + it "succeeds" $ do + outcomes <- newIORef [flaky, succeed] + (dynamically outcomes) `shouldMatchHSpecIt` succeed + + describe "when the retry also fails" $ do + -- Some tests use limited resources and cannot be retried. + -- On failures, we should make sure to show the first failure + -- which is the interesting one. + it "fails with the first error" $ do + let failure = expectationFailure "failure" + let noRetry = expectationFailure "test can't be retried" + outcomes <- newIORef [failure, noRetry] + (dynamically outcomes) `shouldMatchHSpecIt` failure + it "can time out" $ do + let micro = (1000*1000 *) + let timeout = do + threadDelay (micro 10) + expectationFailure "should have timed out" + res <- run (Extra.itWithCustomTimeout 2) timeout + res `shouldContain` "timed out in 2 seconds" where -- | lhs `shouldMatchHSpecIt` rhs asserts that the output of running @@ -104,3 +125,61 @@ spec = do outcome:rest <- readIORef outcomes writeIORef outcomes rest outcome + +aroundAllSpec :: Spec +aroundAllSpec = sequential $ do + let withMockResource :: MonadUnliftIO m => a -> (a -> m r) -> m r + withMockResource a = bracket (pure a) (const $ pure ()) + + withMVarResource :: (Show a, Eq a, MonadUnliftIO m) => a -> (MVar a -> m r) -> m r + withMVarResource a = bracket (newMVar a) (takeMVarCheck a) + + takeMVarCheck :: (Show a, Eq a, MonadUnliftIO m) => a -> MVar a -> m () + takeMVarCheck a var = tryTakeMVar var `shouldReturn` Just a + + resourceA = 1 :: Int + + describe "Extra.aroundAll" $ do + describe "trivial" $ aroundAll (withMockResource resourceA) $ do + it "provides resource to first test" + (`shouldBe` resourceA) + it "provides resource to second test" + (`shouldBe` resourceA) + + describe "basic" $ aroundAll (withMVarResource resourceA) $ do + it "provides resource to first test" $ \var -> + tryReadMVar @IO var `shouldReturn` Just resourceA + + it "provides resource to second test" $ \var -> + tryReadMVar @IO var `shouldReturn` Just resourceA + + mvar <- runIO newEmptyMVar + let withResource = bracket (putMVar mvar ()) (`takeMVarCheck` mvar) + + describe "lazy allocation" $ aroundAll withResource $ do + before <- runIO $ tryReadMVar mvar + it "not before the spec runs" $ \_ -> do + before `shouldBe` Nothing + tryReadMVar mvar `shouldReturn` Just () + + describe "prompt release" $ + it "after the spec runs" $ + tryReadMVar @IO mvar `shouldReturn` Nothing + + describe "exceptions" $ do + let trySpec = fmap (first show) . tryAny + . silence . flip runSpec defaultConfig + let bombBefore = bracket (throwString "bomb1") (const $ pure ()) + let bombAfter = bracket (pure ()) (const $ throwString "bomb2") + + it "while allocating resource" $ do + a <- trySpec $ aroundAll bombBefore $ + it "should never happen" $ const $ + False `shouldBe` True + a `shouldBe` Right (Summary 1 1) + + it "while releasing resource" $ do + b <- trySpec $ aroundAll bombAfter $ + it "spec" $ const $ + pure @IO () + b `shouldBe` Right (Summary 1 0) From 660f63ec6557428a1048789880315981182a4b04 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Thu, 18 Feb 2021 13:38:14 +0800 Subject: [PATCH 07/21] Split Test.Utils.Resource.unBracket from Test.Hspec.Extra.aroundAll This function will be useful in criterion benchmarks. It also fixes handling of exceptions while allocating resources. --- .../cardano-wallet-test-utils.cabal | 2 + lib/test-utils/src/Test/Hspec/Extra.hs | 77 ++----------- lib/test-utils/src/Test/Utils/Resource.hs | 103 ++++++++++++++++++ 3 files changed, 115 insertions(+), 67 deletions(-) create mode 100644 lib/test-utils/src/Test/Utils/Resource.hs diff --git a/lib/test-utils/cardano-wallet-test-utils.cabal b/lib/test-utils/cardano-wallet-test-utils.cabal index c7966980260..1432b05b824 100644 --- a/lib/test-utils/cardano-wallet-test-utils.cabal +++ b/lib/test-utils/cardano-wallet-test-utils.cabal @@ -49,6 +49,7 @@ library , text-class , time , unliftio + , unliftio-core , wai-app-static , warp hs-source-dirs: @@ -61,6 +62,7 @@ library Test.Utils.Laws.PartialOrd Test.Utils.Paths Test.Utils.Roundtrip + Test.Utils.Resource Test.Utils.StaticServer Test.Utils.Time Test.Utils.Trace diff --git a/lib/test-utils/src/Test/Hspec/Extra.hs b/lib/test-utils/src/Test/Hspec/Extra.hs index 75ab08f42fd..7464eed90f5 100644 --- a/lib/test-utils/src/Test/Hspec/Extra.hs +++ b/lib/test-utils/src/Test/Hspec/Extra.hs @@ -39,90 +39,33 @@ import Test.Hspec ) import Test.HUnit.Lang ( HUnitFailure (..), assertFailure, formatFailureReason ) +import Test.Utils.Resource + ( unBracket ) import Test.Utils.Windows ( isWindows ) import UnliftIO.Async - ( async, race, wait ) + ( race ) import UnliftIO.Concurrent ( threadDelay ) import UnliftIO.Exception - ( catch, finally, throwIO, throwString ) + ( catch, throwIO ) import UnliftIO.MVar - ( MVar, newEmptyMVar, putMVar, takeMVar, tryPutMVar, tryTakeMVar ) + ( newEmptyMVar, tryPutMVar, tryTakeMVar ) import qualified Test.Hspec as Hspec -- | Run a 'bracket' resource acquisition function around all the specs. The --- bracket opens before the first test case and closes after the last test case. --- --- It works by actually spawning a new thread responsible for the resource --- acquisition, passing the resource along to the parent threads via a shared --- MVar. Then, there's a bit of logic to synchronize both threads and make sure --- that: --- --- a) The 'Resource Owner' thread is terminated when the main thread is done --- with the resource. --- --- b) The 'Main Thread' only exists when the resource owner has released the --- resource. Exiting the main thread before the 'Resource Owner' has --- released the resource could left a hanging resource open. This is --- particularly annoying when the resource is a running process! --- --- Main Thread Resource Owner --- x --- | Spawn --- |----------------------->x --- | | --- | |-- Acquire resource --- | Send Resource | --- |<-----------------------| --- | | --- | | --- ... ... Await main thread signal --- | | --- | | --- | Send Signal | --- |----------------------->| --- | | --- | ... Release resource --- | Send Done | --- |<-----------------------| --- | Exit --- | --- Exit +-- resource is allocated just before the first test case and released +-- immediately after the last test case. -- +-- Each test is given the resource as a function parameter. aroundAll - :: forall a. - (HasCallStack) + :: forall a. HasCallStack => (ActionWith a -> IO ()) -> SpecWith a -> Spec aroundAll acquire = - beforeAll setup . afterAll snd . beforeWith (pure . fst) - where - setup :: IO (a, IO ()) - setup = do - resource <- newEmptyMVar - release <- newEmptyMVar - done <- newEmptyMVar - - pid <- async $ flip finally (unlock done) $ acquire $ \a -> do - putMVar resource a - await release - - let cleanup = do - unlock release - await done - - race (wait pid) (takeMVar resource) >>= \case - Left _ -> throwString "aroundAll: failed to setup" - Right a -> pure (a, cleanup) - - await :: MVar () -> IO () - await = takeMVar - - unlock :: MVar () -> IO () - unlock = flip putMVar () + beforeAll (unBracket acquire) . afterAll snd . beforeWith fst -- | A drop-in replacement for 'it' that'll automatically retry a scenario once -- if it fails, to cope with potentially flaky tests, if the environment diff --git a/lib/test-utils/src/Test/Utils/Resource.hs b/lib/test-utils/src/Test/Utils/Resource.hs new file mode 100644 index 00000000000..0783f1e4946 --- /dev/null +++ b/lib/test-utils/src/Test/Utils/Resource.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Copyright: © 2018-2020 IOHK +-- License: Apache-2.0 +-- +-- A helper function for using the bracket pattern in code. +-- + +module Test.Utils.Resource + ( unBracket + ) where + +import Prelude + +import Control.Monad.IO.Unlift + ( MonadUnliftIO ) +import GHC.Stack + ( HasCallStack ) +import UnliftIO.Async + ( async, race, waitCatch ) +import UnliftIO.Exception + ( finally, throwIO, throwString ) +import UnliftIO.Memoize + ( memoizeMVar, runMemoized ) +import UnliftIO.MVar + ( MVar, newEmptyMVar, putMVar, takeMVar ) + +-- | Decompose a bracket pattern resource acquisition function into two separate +-- functions: "allocate" and "release". +-- +-- It almost goes without saying that you should always call "release" after +-- "allocate", otherwise bad things will happen. +-- +-- It works by actually spawning a new thread responsible for the resource +-- acquisition, passing the resource along to the parent threads via a shared +-- MVar. Then, there's a bit of logic to synchronize both threads and make sure +-- that: +-- +-- a) The 'Resource Owner' thread is terminated when the main thread is done +-- with the resource. +-- +-- b) The 'Main Thread' only exists when the resource owner has released the +-- resource. Exiting the main thread before the 'Resource Owner' has +-- released the resource could left a hanging resource open. This is +-- particularly annoying when the resource is a running process! +-- +-- Main Thread Resource Owner +-- x +-- | Spawn +-- |----------------------->x +-- | | +-- | |-- Acquire resource +-- | Send Resource | +-- |<-----------------------| +-- | | +-- | | +-- ... ... Await main thread signal +-- | | +-- | | +-- | Send Signal | +-- |----------------------->| +-- | | +-- | ... Release resource +-- | Send Done | +-- |<-----------------------| +-- | Exit +-- | +-- Exit +-- +unBracket + :: forall m a. (HasCallStack, MonadUnliftIO m) + => ((a -> m ()) -> m ()) + -> m (m a, m ()) +unBracket withResource = do + allocated <- newEmptyMVar + released <- newEmptyMVar + done <- newEmptyMVar + + let cont a = do + putMVar allocated a + await released + + release <- memoizeMVar $ do + unlock released + await done + + allocate <- memoizeMVar $ do + pid <- async $ withResource cont `finally` unlock done + race (waitCatch pid) (takeMVar allocated) >>= \case + Left (Left e) -> throwIO e + Left (Right ()) -> throwString "aroundAll: failed to setup" + Right a -> pure a + + pure (runMemoized allocate, runMemoized release) + + where + await :: MVar () -> m () + await = takeMVar + + unlock :: MVar () -> m () + unlock = flip putMVar () From 8ef586c8eb973907750baaaba1928d46ab06fd82 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Thu, 18 Feb 2021 14:35:45 +0800 Subject: [PATCH 08/21] Let bench:db work using withConnectionPool --- lib/core/cardano-wallet-core.cabal | 2 +- lib/core/test/bench/db/Main.hs | 39 +++++++++++++++++++++--------- 2 files changed, 28 insertions(+), 13 deletions(-) diff --git a/lib/core/cardano-wallet-core.cabal b/lib/core/cardano-wallet-core.cabal index 4548a923b0a..3e852ab85b2 100644 --- a/lib/core/cardano-wallet-core.cabal +++ b/lib/core/cardano-wallet-core.cabal @@ -394,6 +394,7 @@ benchmark db , cardano-crypto , cardano-wallet-core , cardano-wallet-launcher + , cardano-wallet-test-utils , containers , criterion , cryptonite @@ -404,7 +405,6 @@ benchmark db , iohk-monitoring , memory , random - , temporary , text , text-class , time diff --git a/lib/core/test/bench/db/Main.hs b/lib/core/test/bench/db/Main.hs index 47c3a23eca2..f53d021f6db 100644 --- a/lib/core/test/bench/db/Main.hs +++ b/lib/core/test/bench/db/Main.hs @@ -57,9 +57,8 @@ import Cardano.DB.Sqlite ( ConnectionPool , DBLog , SqliteContext (..) - , destroyConnectionPool - , newConnectionPool , newSqliteContext + , withConnectionPool ) import Cardano.Mnemonic ( EntropySize, SomeMnemonic (..), entropyToMnemonic, genEntropy ) @@ -149,7 +148,7 @@ import Cardano.Wallet.Primitive.Types.UTxO import Cardano.Wallet.Unsafe ( someDummyMnemonic, unsafeRunExceptT ) import Control.DeepSeq - ( NFData (..), force ) + ( NFData (..), deepseq, force ) import Control.Monad ( join ) import Control.Monad.Trans.Except @@ -203,6 +202,8 @@ import System.IO.Unsafe ( unsafePerformIO ) import System.Random ( mkStdGen, randoms ) +import Test.Utils.Resource + ( unBracket ) import UnliftIO.Exception ( bracket, throwIO ) @@ -658,7 +659,20 @@ withDB => Tracer IO DBLog -> (DBLayer IO s k -> Benchmark) -> Benchmark -withDB tr bm = envWithCleanup (setupDB tr) cleanupDB (\ ~(_, _, db) -> bm db) +withDB tr bm = envWithCleanup (setupDB tr) cleanupDB (\(BenchEnv _ _ _ db) -> bm db) + +data BenchEnv s k = BenchEnv + { _connectionPool :: !ConnectionPool + , _destroyPool :: IO () + , _ctx :: !SqliteContext + , _dbLayer :: !(DBLayer IO s k) + } + +instance NFData (BenchEnv s k) where + rnf (BenchEnv p _ ctx db) = + deepseq (rnf p) $ + deepseq (rnf ctx) $ + deepseq (rnf db) () setupDB :: forall s k. @@ -667,13 +681,14 @@ setupDB , WalletKey k ) => Tracer IO DBLog - -> IO (ConnectionPool, SqliteContext, DBLayer IO s k) + -> IO (BenchEnv s k) setupDB tr = do f <- emptySystemTempFile "bench.db" - pool <- newConnectionPool tr f + (createPool, destroyPool) <- unBracket (withConnectionPool tr f) + pool <- createPool ctx <- either throwIO pure =<< newSqliteContext tr pool [] migrateAll f db <- newDBLayerWith NoCache singleEraInterpreter ctx - pure (pool, ctx, db) + pure $ BenchEnv pool destroyPool ctx db singleEraInterpreter :: TimeInterpreter IO singleEraInterpreter = hoistTimeInterpreter (pure . runIdentity) $ @@ -686,9 +701,9 @@ singleEraInterpreter = hoistTimeInterpreter (pure . runIdentity) $ , getSecurityParameter = Quantity 2160 }) -cleanupDB :: (ConnectionPool, SqliteContext, DBLayer IO s k) -> IO () -cleanupDB (pool, SqliteContext{dbFile}, _) = do - destroyConnectionPool pool +cleanupDB :: BenchEnv s k -> IO () +cleanupDB (BenchEnv _ destroyPool SqliteContext{dbFile} _) = do + destroyPool let f = fromMaybe ":memory:" dbFile mapM_ remove [f, f <> "-shm", f <> "-wal"] where @@ -774,11 +789,11 @@ txHistoryDiskSpaceTests tr = do benchDiskSize :: Tracer IO DBLog -> (DBLayerBench -> IO ()) -> IO () benchDiskSize tr action = bracket (setupDB tr) cleanupDB - $ \(pool, SqliteContext{dbFile}, db) -> do + $ \(BenchEnv _ destroyPool SqliteContext{dbFile} db) -> do let f = fromMaybe ":memory:" dbFile action db mapM_ (printFileSize "") [f, f <> "-shm", f <> "-wal"] - destroyConnectionPool pool + destroyPool printFileSize " (closed)" f putStrLn "" where From 400a69eff53a0a2b58d62f458961735f19465d18 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Thu, 18 Feb 2021 17:22:06 +0800 Subject: [PATCH 09/21] Straighten out connection pool logging a little --- lib/core/src/Cardano/DB/Sqlite.hs | 165 +++++++++--------- .../test/unit/Cardano/Pool/DB/SqliteSpec.hs | 8 +- 2 files changed, 89 insertions(+), 84 deletions(-) diff --git a/lib/core/src/Cardano/DB/Sqlite.hs b/lib/core/src/Cardano/DB/Sqlite.hs index 14cc1a27fff..c46d27738d1 100644 --- a/lib/core/src/Cardano/DB/Sqlite.hs +++ b/lib/core/src/Cardano/DB/Sqlite.hs @@ -146,33 +146,12 @@ data SqliteContext = SqliteContext type ConnectionPool = Pool (SqlBackend, Sqlite.Connection) --- | Error type for when migrations go wrong after opening a database. -newtype MigrationError = MigrationError - { getMigrationErrorMessage :: Text } - deriving (Show, Eq, Generic, ToJSON) - -instance Exception MigrationError - -- | Run a raw query from the outside using an instantiate DB layer. This is -- completely unsafe because it breaks the abstraction boundary and can have -- disastrous results on the database consistency. unsafeRunQuery :: SqliteContext -> SqlPersistT IO a -> IO a unsafeRunQuery = runQuery -queryLogFunc :: Tracer IO DBLog -> LogFunc -queryLogFunc tr _loc _source level str = traceWith tr (MsgQuery msg sev) - where - -- Filter out parameters which appear after the statement semicolon. - -- They will contain sensitive material that we don't want in the log. - stmt = B8.takeWhile (/= ';') $ fromLogStr str - msg = T.decodeUtf8 stmt - sev = case level of - LevelDebug -> Debug - LevelInfo -> Info - LevelWarn -> Warning - LevelError -> Error - LevelOther _ -> Warning - -- | Run an action, and convert any Sqlite constraints exception into the given -- error result. No other exceptions are handled. handleConstraint :: MonadUnliftIO m => e -> m a -> m (Either e a) @@ -392,37 +371,13 @@ updateForeignKeysSetting trace connection desiredValue = do ForeignKeysEnabled -> "ON" ForeignKeysDisabled -> "OFF" -class Exception e => MatchMigrationError e where - -- | Exception predicate for migration errors. - matchMigrationError :: e -> Maybe MigrationError - -instance MatchMigrationError PersistException where - matchMigrationError e - | mark `isInfixOf` msg = Just $ MigrationError $ T.pack msg - | otherwise = Nothing - where - msg = show e - mark = "Database migration: manual intervention required." - -instance MatchMigrationError SqliteException where - matchMigrationError (SqliteException ErrorConstraint _ msg) = - Just $ MigrationError msg - matchMigrationError _ = - Nothing - --- | Encapsulates a manual migration action (or sequence of actions) to be --- performed immediately after an SQL connection is initiated. --- -newtype ManualMigration = ManualMigration - { executeManualMigration :: Sqlite.Connection -> IO () } - withConnectionPool :: Tracer IO DBLog -> FilePath -> (ConnectionPool -> IO a) -> IO a withConnectionPool tr fp = - bracket (newConnectionPool tr fp) destroyConnectionPool + bracket (newConnectionPool tr fp) (destroyConnectionPool tr fp) newConnectionPool :: Tracer IO DBLog @@ -432,7 +387,7 @@ newConnectionPool tr fp = do let connStr = sqliteConnStr (Just fp) let info = mkSqliteConnectionInfo connStr - traceWith tr $ MsgWillOpenDB (Just fp) + traceWith tr $ MsgStartConnectionPool fp let acquireConnection = do conn <- Sqlite.open connStr @@ -452,41 +407,48 @@ newConnectionPool tr fp = do maximumConnections = 10 timeToLive = 600 {- 10 minutes -} :: NominalDiffTime -destroyConnectionPool :: Pool a -> IO () -destroyConnectionPool = destroyAllResources +destroyConnectionPool :: Tracer IO DBLog -> FilePath -> Pool a -> IO () +destroyConnectionPool tr fp pool = do + traceWith tr (MsgStopConnectionPool fp) + destroyAllResources pool sqliteConnStr :: Maybe FilePath -> Text sqliteConnStr = maybe ":memory:" T.pack {------------------------------------------------------------------------------- - Logging + Migrations -------------------------------------------------------------------------------} -data DBLog - = MsgMigrations (Either MigrationError Int) - | MsgQuery Text Severity - | MsgRun BracketLog - | MsgCloseSingleConnection FilePath - | MsgDestroyConnectionPool FilePath - | MsgWillOpenDB (Maybe FilePath) - | MsgDatabaseReset - | MsgIsAlreadyClosed Text - | MsgStatementAlreadyFinalized Text - | MsgWaitingForDatabase Text (Maybe Int) - | MsgRemovingInUse Text Int - | MsgRemoving Text - | MsgRemovingDatabaseFile Text DeleteSqliteDatabaseLog - | MsgManualMigrationNeeded DBField Text - | MsgManualMigrationNotNeeded DBField - | MsgUpdatingForeignKeysSetting ForeignKeysSetting - | MsgFoundDatabase FilePath Text - | MsgUnknownDBFile FilePath - | MsgRetryOnBusy Int - deriving (Generic, Show, Eq, ToJSON) +-- | Error type for when migrations go wrong after opening a database. +newtype MigrationError = MigrationError + { getMigrationErrorMessage :: Text } + deriving (Show, Eq, Generic, ToJSON) -{------------------------------------------------------------------------------- - Logging --------------------------------------------------------------------------------} +instance Exception MigrationError + +class Exception e => MatchMigrationError e where + -- | Exception predicate for migration errors. + matchMigrationError :: e -> Maybe MigrationError + +instance MatchMigrationError PersistException where + matchMigrationError e + | mark `isInfixOf` msg = Just $ MigrationError $ T.pack msg + | otherwise = Nothing + where + msg = show e + mark = "Database migration: manual intervention required." + +instance MatchMigrationError SqliteException where + matchMigrationError (SqliteException ErrorConstraint _ msg) = + Just $ MigrationError msg + matchMigrationError _ = + Nothing + +-- | Encapsulates a manual migration action (or sequence of actions) to be +-- performed immediately after an SQL connection is initiated. +-- +newtype ManualMigration = ManualMigration + { executeManualMigration :: Sqlite.Connection -> IO () } data DBField where DBField @@ -534,6 +496,32 @@ instance Eq DBField where instance ToJSON DBField where toJSON = Aeson.String . fieldName +{------------------------------------------------------------------------------- + Logging +-------------------------------------------------------------------------------} + +data DBLog + = MsgMigrations (Either MigrationError Int) + | MsgQuery Text Severity + | MsgRun BracketLog + | MsgCloseSingleConnection FilePath + | MsgStartConnectionPool FilePath + | MsgStopConnectionPool FilePath + | MsgDatabaseReset + | MsgIsAlreadyClosed Text + | MsgStatementAlreadyFinalized Text + | MsgWaitingForDatabase Text (Maybe Int) + | MsgRemovingInUse Text Int + | MsgRemoving Text + | MsgRemovingDatabaseFile Text DeleteSqliteDatabaseLog + | MsgManualMigrationNeeded DBField Text + | MsgManualMigrationNotNeeded DBField + | MsgUpdatingForeignKeysSetting ForeignKeysSetting + | MsgFoundDatabase FilePath Text + | MsgUnknownDBFile FilePath + | MsgRetryOnBusy Int + deriving (Generic, Show, Eq, ToJSON) + instance HasPrivacyAnnotation DBLog instance HasSeverityAnnotation DBLog where getSeverityAnnotation ev = case ev of @@ -543,8 +531,8 @@ instance HasSeverityAnnotation DBLog where MsgQuery _ sev -> sev MsgRun _ -> Debug MsgCloseSingleConnection _ -> Info - MsgDestroyConnectionPool _ -> Notice - MsgWillOpenDB _ -> Info + MsgStartConnectionPool _ -> Info + MsgStopConnectionPool _ -> Info MsgDatabaseReset -> Notice MsgIsAlreadyClosed _ -> Warning MsgStatementAlreadyFinalized _ -> Warning @@ -570,15 +558,17 @@ instance ToText DBLog where MsgMigrations (Left err) -> "Failed to migrate the database: " <> getMigrationErrorMessage err MsgQuery stmt _ -> stmt - MsgRun b -> "Running database action - " <> toText b - MsgWillOpenDB fp -> "Will open db at " <> (maybe "in-memory" T.pack fp) + MsgRun b -> + "Running database action - " <> toText b + MsgStartConnectionPool fp -> + "Starting connection pool for " <> T.pack fp + MsgStopConnectionPool fp -> + "Stopping database connection pool " <> T.pack fp MsgDatabaseReset -> "Non backward compatible database found. Removing old database \ \and re-creating it from scratch. Ignore the previous error." MsgCloseSingleConnection fp -> "Closing single database connection ("+|fp|+")" - MsgDestroyConnectionPool fp -> - "Destroy database connection pool ("+|fp|+")" MsgIsAlreadyClosed msg -> "Attempted to close an already closed connection: " <> msg MsgStatementAlreadyFinalized msg -> @@ -624,6 +614,21 @@ instance ToText DBLog where let nF = ordinalF n in "Retrying db query because db was busy for the " +| nF |+ " time." +-- | Produce a persistent 'LogFunc' backed by 'Tracer IO DBLog' +queryLogFunc :: Tracer IO DBLog -> LogFunc +queryLogFunc tr _loc _source level str = traceWith tr (MsgQuery msg sev) + where + -- Filter out parameters which appear after the statement semicolon. + -- They will contain sensitive material that we don't want in the log. + stmt = B8.takeWhile (/= ';') $ fromLogStr str + msg = T.decodeUtf8 stmt + sev = case level of + LevelDebug -> Debug + LevelInfo -> Info + LevelWarn -> Warning + LevelError -> Error + LevelOther _ -> Warning + {------------------------------------------------------------------------------- Extra DB Helpers -------------------------------------------------------------------------------} diff --git a/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs b/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs index 4fe79050ead..bbcfb639426 100644 --- a/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs +++ b/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs @@ -72,7 +72,7 @@ test_migrationFromv20191216 = withDBLayer tr (Just path) ti $ \_ -> pure () withDBLayer tr (Just path) ti $ \_ -> pure () - let databaseConnMsg = filter isMsgWillOpenDB logs + let databaseConnMsg = filter isMsgOpenDB logs let databaseResetMsg = filter (== MsgGeneric MsgDatabaseReset) logs let migrationErrMsg = filter isMsgMigrationError logs @@ -80,9 +80,9 @@ test_migrationFromv20191216 = length databaseResetMsg `shouldBe` 1 length migrationErrMsg `shouldBe` 1 -isMsgWillOpenDB :: PoolDbLog -> Bool -isMsgWillOpenDB (MsgGeneric (MsgWillOpenDB _)) = True -isMsgWillOpenDB _ = False +isMsgOpenDB :: PoolDbLog -> Bool +isMsgOpenDB (MsgGeneric (MsgStartConnectionPool _)) = True +isMsgOpenDB _ = False isMsgMigrationError :: PoolDbLog -> Bool isMsgMigrationError (MsgGeneric (MsgMigrations (Left _))) = True From 6d53144f18440927f23411214bdca00924b64e68 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Thu, 18 Feb 2021 08:11:32 +0800 Subject: [PATCH 10/21] No need for mask in runQuery If the thread is cancelled, we want the query stopped immediately. Anything uncommitted will be rolled back by persistent. --- lib/core/src/Cardano/DB/Sqlite.hs | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/lib/core/src/Cardano/DB/Sqlite.hs b/lib/core/src/Cardano/DB/Sqlite.hs index c46d27738d1..337bfe07b71 100644 --- a/lib/core/src/Cardano/DB/Sqlite.hs +++ b/lib/core/src/Cardano/DB/Sqlite.hs @@ -121,7 +121,7 @@ import System.Log.FastLogger import UnliftIO.Compat ( handleIf, mkRetryHandler ) import UnliftIO.Exception - ( Exception, bracket, bracket_, handleJust, mask_, tryJust ) + ( Exception, bracket, bracket_, handleJust, tryJust ) import UnliftIO.MVar ( newMVar, withMVarMasked ) @@ -218,11 +218,6 @@ newSqliteContext tr pool manualMigrations autoMigration fp = do let observe :: IO a -> IO a observe = bracketTracer (contramap MsgRun tr) - -- runSqlConn is guarded with a lock because it's not threadsafe in - -- general.It is also masked, so that the SqlBackend state is not - -- corrupted if a thread gets cancelled while running a query. - -- See: https://github.com/yesodweb/persistent/issues/981 - -- -- Note that `withResource` does already mask async exception but -- only for dealing with the pool resource acquisition. The action -- is then ran unmasked with the acquired resource. If an @@ -230,7 +225,7 @@ newSqliteContext tr pool manualMigrations autoMigration fp = do -- resource is NOT placed back in the pool. runQuery :: SqlPersistT IO a -> IO a runQuery cmd = withResource pool $ - mask_ . observe . retryOnBusy tr . runSqlConn cmd . fst + observe . retryOnBusy tr . runSqlConn cmd . fst in Right $ SqliteContext { runQuery, dbFile = Just fp } From dc369a801eadae649cfc28162eca307f0626cbcf Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Thu, 18 Feb 2021 18:29:49 +0800 Subject: [PATCH 11/21] Don't get stuck when deleting wallets The deleteWallet handler opens a database connection then tries to remove the database before closing the connection. But the sqlite removeDatabase function waits for all connections to be closed first. The livelock is only broken after the 1 minute timeout in removeDatabase. --- lib/core/src/Cardano/Wallet/Api/Server.hs | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/lib/core/src/Cardano/Wallet/Api/Server.hs b/lib/core/src/Cardano/Wallet/Api/Server.hs index bacec918cf3..95c6354548f 100644 --- a/lib/core/src/Cardano/Wallet/Api/Server.hs +++ b/lib/core/src/Cardano/Wallet/Api/Server.hs @@ -1061,11 +1061,15 @@ deleteWallet => ctx -> ApiT WalletId -> Handler NoContent -deleteWallet ctx (ApiT wid) = - withWorkerCtx @_ @s @k ctx wid liftE liftE $ \_ -> do - liftIO $ Registry.unregister re wid - liftIO $ removeDatabase df wid - return NoContent +deleteWallet ctx (ApiT wid) = do + -- Start a context so that an error is throw if the wallet doesn't exist. + withWorkerCtx @_ @s @k ctx wid liftE + (const $ pure()) (const $ pure ()) + + liftIO $ Registry.unregister re wid + liftIO $ removeDatabase df wid + + return NoContent where re = ctx ^. workerRegistry @s @k df = ctx ^. dbFactory @s @k From 16f3564624aecdd283e606f152c5f43bb3755875 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Thu, 18 Feb 2021 19:34:03 +0800 Subject: [PATCH 12/21] Elide retryOnBusy logging --- lib/core/src/Cardano/DB/Sqlite.hs | 45 ++++++++++++++++++++++--------- 1 file changed, 32 insertions(+), 13 deletions(-) diff --git a/lib/core/src/Cardano/DB/Sqlite.hs b/lib/core/src/Cardano/DB/Sqlite.hs index 337bfe07b71..5ba7a989507 100644 --- a/lib/core/src/Cardano/DB/Sqlite.hs +++ b/lib/core/src/Cardano/DB/Sqlite.hs @@ -70,6 +70,7 @@ import Control.Retry ( RetryStatus (..) , constantDelay , limitRetriesByCumulativeDelay + , logRetries , recovering ) import Control.Tracer @@ -119,7 +120,7 @@ import GHC.Generics import System.Log.FastLogger ( fromLogStr ) import UnliftIO.Compat - ( handleIf, mkRetryHandler ) + ( handleIf ) import UnliftIO.Exception ( Exception, bracket, bracket_, handleJust, tryJust ) import UnliftIO.MVar @@ -281,15 +282,20 @@ destroySqliteBackend tr sqlBackend dbFile = do -- available to process B to help it deal with SQLITE_BUSY errors. -- retryOnBusy :: Tracer IO DBLog -> IO a -> IO a -retryOnBusy tr action = - recovering policy (mkRetryHandler isBusy) $ \RetryStatus{rsIterNumber} -> do - when (rsIterNumber > 0) $ traceWith tr (MsgRetryOnBusy rsIterNumber) - action +retryOnBusy tr action = recovering policy + [logRetries isBusy traceRetries] + (\st -> action <* trace MsgRetryDone st) where - isBusy (SqliteException name _ _) = pure (name == Sqlite.ErrorBusy) policy = limitRetriesByCumulativeDelay (60000*ms) $ constantDelay (25*ms) ms = 1000 -- microseconds in a millisecond + isBusy (SqliteException name _ _) = pure (name == Sqlite.ErrorBusy) + + traceRetries retr _ = trace $ if retr then MsgRetry else MsgRetryGaveUp + + trace m RetryStatus{rsIterNumber} = traceWith tr $ + MsgRetryOnBusy rsIterNumber m + -- | Run the given task in a context where foreign key constraints are -- /temporarily disabled/, before re-enabling them. -- @@ -514,7 +520,10 @@ data DBLog | MsgUpdatingForeignKeysSetting ForeignKeysSetting | MsgFoundDatabase FilePath Text | MsgUnknownDBFile FilePath - | MsgRetryOnBusy Int + | MsgRetryOnBusy Int RetryLog + deriving (Generic, Show, Eq, ToJSON) + +data RetryLog = MsgRetry | MsgRetryGaveUp | MsgRetryDone deriving (Generic, Show, Eq, ToJSON) instance HasPrivacyAnnotation DBLog @@ -540,9 +549,10 @@ instance HasSeverityAnnotation DBLog where MsgUpdatingForeignKeysSetting{} -> Debug MsgFoundDatabase _ _ -> Info MsgUnknownDBFile _ -> Notice - MsgRetryOnBusy n | n <= 1 -> Debug - MsgRetryOnBusy n | n <= 3 -> Notice - MsgRetryOnBusy _ -> Warning + MsgRetryOnBusy n _ + | n <= 1 -> Debug + | n <= 3 -> Notice + | otherwise -> Warning instance ToText DBLog where toText = \case @@ -605,9 +615,18 @@ instance ToText DBLog where [ "Found something other than a database file in " , "the database folder: ", T.pack file ] - MsgRetryOnBusy n -> - let nF = ordinalF n in - "Retrying db query because db was busy for the " +| nF |+ " time." + MsgRetryOnBusy n msg -> case msg of + MsgRetry + | n <= 10 -> + "Retrying db query because db was busy " <> + "for the " +| ordinalF n |+ " time." + | n == 11 -> + "No more logs until it finishes..." + | otherwise -> "" + MsgRetryGaveUp -> "Gave up on retrying the db query." + MsgRetryDone + | n > 3 -> "DB query succeeded after " +| n |+ " attempts." + | otherwise -> "" -- | Produce a persistent 'LogFunc' backed by 'Tracer IO DBLog' queryLogFunc :: Tracer IO DBLog -> LogFunc From 96b08d3990bb075c09532f2bb0a48e26f314177c Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Thu, 18 Feb 2021 20:17:42 +0800 Subject: [PATCH 13/21] Fix MsgApplyBlocks logging It was bothering me. --- lib/core/src/Cardano/Wallet/Network.hs | 23 ++++++++++++++--------- lib/shelley/bench/Restore.hs | 2 +- 2 files changed, 15 insertions(+), 10 deletions(-) diff --git a/lib/core/src/Cardano/Wallet/Network.hs b/lib/core/src/Cardano/Wallet/Network.hs index 44e5065bd32..60005d83058 100644 --- a/lib/core/src/Cardano/Wallet/Network.hs +++ b/lib/core/src/Cardano/Wallet/Network.hs @@ -71,6 +71,8 @@ import Data.Functor ( ($>) ) import Data.List.NonEmpty ( NonEmpty (..) ) +import Data.Quantity + ( Quantity (..) ) import Data.Text ( Text ) import Data.Text.Class @@ -348,7 +350,7 @@ follow nl tr cps yield header = Right (RollForward cursor' tip (blockFirst : blocksRest)) -> do let blocks = blockFirst :| blocksRest - traceWith tr $ MsgApplyBlocks (header <$> blocks) + traceWith tr $ MsgApplyBlocks tip (header <$> blocks) action <- yield blocks tip traceWith tr $ MsgFollowAction (fmap show action) continueWith cursor' True action @@ -407,7 +409,7 @@ data FollowLog | MsgUnhandledException Text | MsgNextBlockFailed ErrGetBlock | MsgSynced - | MsgApplyBlocks (NonEmpty BlockHeader) + | MsgApplyBlocks BlockHeader (NonEmpty BlockHeader) | MsgWillRollback SlotNo | MsgWillIgnoreRollback SlotNo Text -- Reason deriving (Show, Eq) @@ -423,13 +425,16 @@ instance ToText FollowLog where T.pack $ "Failed to get next blocks: " <> show e MsgSynced -> "In sync with the node." - MsgApplyBlocks hdrs -> - let (slFst, slLst) = - ( slotNo $ NE.head hdrs - , slotNo $ NE.last hdrs - ) + MsgApplyBlocks tipHdr hdrs -> + let slot = pretty . slotNo + buildRange (x :| []) = x + buildRange xs = NE.head xs <> ".." <> NE.last xs + blockHeights = pretty . getQuantity . blockHeight <$> hdrs in mconcat - [ "Applying blocks [", pretty slFst, " ... ", pretty slLst, "]" ] + [ "Applying block numbers [", buildRange blockHeights, "]" + , " Wallet/node slots: ", slot (NE.last hdrs) + , "/", slot tipHdr + ] MsgWillRollback sl -> "Will rollback to " <> pretty sl MsgWillIgnoreRollback sl reason -> @@ -444,6 +449,6 @@ instance HasSeverityAnnotation FollowLog where MsgUnhandledException _ -> Error MsgNextBlockFailed _ -> Warning MsgSynced -> Debug - MsgApplyBlocks _ -> Info + MsgApplyBlocks _ _ -> Info MsgWillRollback _ -> Debug MsgWillIgnoreRollback _ _ -> Debug diff --git a/lib/shelley/bench/Restore.hs b/lib/shelley/bench/Restore.hs index 41be5adbef3..ca1587f5baf 100644 --- a/lib/shelley/bench/Restore.hs +++ b/lib/shelley/bench/Restore.hs @@ -667,7 +667,7 @@ dummySeedFromName = SomeMnemonic @24 traceProgressForPlotting :: Tracer IO Text -> Tracer IO WalletLog traceProgressForPlotting tr = Tracer $ \case - MsgFollow (MsgApplyBlocks bs) -> do + MsgFollow (MsgApplyBlocks _nodeTip bs) -> do let tip = pretty . getQuantity . blockHeight . NE.last $ bs time <- pretty . utcTimeToPOSIXSeconds <$> getCurrentTime traceWith tr (time <> " " <> tip) From 8f5e54c402e4e6b95b5e6a1b6a495c6b9ef823d9 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Thu, 18 Feb 2021 20:30:28 +0800 Subject: [PATCH 14/21] Simplify sqlite connection setup --- lib/core/src/Cardano/DB/Sqlite.hs | 22 ++++++---------------- 1 file changed, 6 insertions(+), 16 deletions(-) diff --git a/lib/core/src/Cardano/DB/Sqlite.hs b/lib/core/src/Cardano/DB/Sqlite.hs index 5ba7a989507..5b94ee7973a 100644 --- a/lib/core/src/Cardano/DB/Sqlite.hs +++ b/lib/core/src/Cardano/DB/Sqlite.hs @@ -110,7 +110,7 @@ import Database.Persist.Sql , runSqlConn ) import Database.Persist.Sqlite - ( SqlBackend, SqlPersistT, mkSqliteConnectionInfo, wrapConnectionInfo ) + ( SqlBackend, SqlPersistT, wrapConnection ) import Database.Sqlite ( Error (ErrorConstraint), SqliteException (SqliteException) ) import Fmt @@ -172,9 +172,9 @@ newInMemorySqliteContext -> Migration -> IO SqliteContext newInMemorySqliteContext tr manualMigrations autoMigration = do - conn <- Sqlite.open connStr + conn <- Sqlite.open ":memory:" mapM_ (`executeManualMigration` conn) manualMigrations - unsafeBackend <- wrapConnectionInfo info conn (queryLogFunc tr) + unsafeBackend <- wrapConnection conn (queryLogFunc tr) void $ runSqlConn (runMigrationQuiet autoMigration) unsafeBackend let observe :: forall a. IO a -> IO a @@ -187,11 +187,7 @@ newInMemorySqliteContext tr manualMigrations autoMigration = do let runQuery :: forall a. SqlPersistT IO a -> IO a runQuery cmd = withMVarMasked lock (observe . runSqlConn cmd) - return $ SqliteContext { runQuery, dbFile } - where - dbFile = Nothing - connStr = sqliteConnStr dbFile - info = mkSqliteConnectionInfo connStr + return $ SqliteContext { runQuery, dbFile = Nothing } -- | Sets up query logging and timing, runs schema migrations if necessary and -- provide a safe 'SqliteContext' for interacting with the database. @@ -385,14 +381,11 @@ newConnectionPool -> FilePath -> IO ConnectionPool newConnectionPool tr fp = do - let connStr = sqliteConnStr (Just fp) - let info = mkSqliteConnectionInfo connStr - traceWith tr $ MsgStartConnectionPool fp let acquireConnection = do - conn <- Sqlite.open connStr - (,conn) <$> wrapConnectionInfo info conn (queryLogFunc tr) + conn <- Sqlite.open (T.pack fp) + (,conn) <$> wrapConnection conn (queryLogFunc tr) let releaseConnection = \(backend, _) -> do destroySqliteBackend tr backend fp @@ -413,9 +406,6 @@ destroyConnectionPool tr fp pool = do traceWith tr (MsgStopConnectionPool fp) destroyAllResources pool -sqliteConnStr :: Maybe FilePath -> Text -sqliteConnStr = maybe ":memory:" T.pack - {------------------------------------------------------------------------------- Migrations -------------------------------------------------------------------------------} From ac11b5094344cd081a5e6cd5416b358bb4fc0f20 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Thu, 18 Feb 2021 21:31:57 +0800 Subject: [PATCH 15/21] Switch checkpoint cache from IORef to MVar --- lib/core/src/Cardano/DB/Sqlite.hs | 2 +- lib/core/src/Cardano/Wallet/DB/Sqlite.hs | 31 +++++++++--------------- 2 files changed, 13 insertions(+), 20 deletions(-) diff --git a/lib/core/src/Cardano/DB/Sqlite.hs b/lib/core/src/Cardano/DB/Sqlite.hs index 5b94ee7973a..6c0c60a6cc5 100644 --- a/lib/core/src/Cardano/DB/Sqlite.hs +++ b/lib/core/src/Cardano/DB/Sqlite.hs @@ -140,7 +140,7 @@ import qualified Database.Sqlite as Sqlite -- | Context for the SQLite 'DBLayer'. data SqliteContext = SqliteContext { runQuery :: forall a. SqlPersistT IO a -> IO a - -- ^ 'safely' run a query with logging and lock-protection + -- ^ Run a query with a connection from the pool. , dbFile :: Maybe FilePath -- ^ The actual database file, if any. If none, runs in-memory } diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs index 401bf0d0483..22678a3a983 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs @@ -146,8 +146,6 @@ import Data.Functor ( (<&>) ) import Data.Generics.Internal.VL.Lens ( view, (^.) ) -import Data.IORef - ( modifyIORef', newIORef, readIORef ) import Data.List ( nub, sortOn, unzip3 ) import Data.List.Split @@ -1114,7 +1112,7 @@ newDBLayerWith , PersistPrivateKey (k 'RootK) ) => CacheBehavior - -- ^ Option to disable IORef caching. + -- ^ Option to disable caching. -> TimeInterpreter IO -- ^ Time interpreter for slot to time conversions. -> SqliteContext @@ -1138,34 +1136,29 @@ newDBLayerWith cacheBehavior ti SqliteContext{runQuery} = do -- short-circuit the most frequent database lookups. -- -- NOTE2 - -- We use an IORef here without fearing race-conditions because every - -- database query can only be run within calls to `atomically` which - -- enforces that there's only a single thread executing a given - -- `SqlPersistT`. - -- - -- NOTE3 -- When 'cacheBehavior' is set to 'NoCache', we simply never write anything -- to the cache, which forces 'selectLatestCheckpoint' to always perform a -- database lookup. - cache <- newIORef Map.empty + cache <- newMVar Map.empty let readCache :: W.WalletId -> SqlPersistT IO (Maybe (W.Wallet s)) - readCache wid = Map.lookup wid <$> liftIO (readIORef cache) + readCache wid = Map.lookup wid <$> readMVar cache + + let maybeUpdateCache m = case cacheBehavior of + NoCache -> pure () + CacheLatestCheckpoint -> modifyMVar_ cache (pure . m) let writeCache :: W.WalletId -> Maybe (W.Wallet s) -> SqlPersistT IO () - writeCache wid = case cacheBehavior of - NoCache -> const (pure ()) - CacheLatestCheckpoint -> \case - Nothing -> - liftIO $ modifyIORef' cache $ Map.delete wid - Just cp -> do + writeCache wid = maybeUpdateCache . \case + Nothing -> Map.delete wid + Just cp -> let tip = cp ^. #currentTip . #blockHeight - let alter = \case + alter = \case Just old | tip < old ^. #currentTip . #blockHeight -> Just old _ -> Just cp - liftIO $ modifyIORef' cache $ Map.alter alter wid + in Map.alter alter wid let selectLatestCheckpoint :: W.WalletId From ffc0a30198852649c874915cf72083652898dad6 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Thu, 18 Feb 2021 22:08:54 +0800 Subject: [PATCH 16/21] Straighten out SqliteContext --- lib/core/src/Cardano/DB/Sqlite.hs | 11 ++---- lib/core/src/Cardano/Pool/DB/Sqlite.hs | 2 +- lib/core/src/Cardano/Wallet/DB/Sqlite.hs | 11 +++--- lib/core/test/bench/db/Main.hs | 49 +++++++++--------------- 4 files changed, 30 insertions(+), 43 deletions(-) diff --git a/lib/core/src/Cardano/DB/Sqlite.hs b/lib/core/src/Cardano/DB/Sqlite.hs index 6c0c60a6cc5..b388d044a3b 100644 --- a/lib/core/src/Cardano/DB/Sqlite.hs +++ b/lib/core/src/Cardano/DB/Sqlite.hs @@ -138,11 +138,9 @@ import qualified Database.Sqlite as Sqlite -------------------------------------------------------------------------------} -- | Context for the SQLite 'DBLayer'. -data SqliteContext = SqliteContext +newtype SqliteContext = SqliteContext { runQuery :: forall a. SqlPersistT IO a -> IO a -- ^ Run a query with a connection from the pool. - , dbFile :: Maybe FilePath - -- ^ The actual database file, if any. If none, runs in-memory } type ConnectionPool = Pool (SqlBackend, Sqlite.Connection) @@ -187,7 +185,7 @@ newInMemorySqliteContext tr manualMigrations autoMigration = do let runQuery :: forall a. SqlPersistT IO a -> IO a runQuery cmd = withMVarMasked lock (observe . runSqlConn cmd) - return $ SqliteContext { runQuery, dbFile = Nothing } + return $ SqliteContext { runQuery } -- | Sets up query logging and timing, runs schema migrations if necessary and -- provide a safe 'SqliteContext' for interacting with the database. @@ -196,9 +194,8 @@ newSqliteContext -> ConnectionPool -> [ManualMigration] -> Migration - -> FilePath -> IO (Either MigrationError SqliteContext) -newSqliteContext tr pool manualMigrations autoMigration fp = do +newSqliteContext tr pool manualMigrations autoMigration = do migrationResult <- withResource pool $ \(backend, conn) -> do let executeAutoMigration = runSqlConn (runMigrationQuiet autoMigration) backend migrationResult <- withForeignKeysDisabled tr conn $ do @@ -224,7 +221,7 @@ newSqliteContext tr pool manualMigrations autoMigration fp = do runQuery cmd = withResource pool $ observe . retryOnBusy tr . runSqlConn cmd . fst - in Right $ SqliteContext { runQuery, dbFile = Just fp } + in Right $ SqliteContext { runQuery } -- | Finalize database statements and close the database connection. -- diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs index 333a20cf984..04c1effd649 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs @@ -211,7 +211,7 @@ withDecoratedDBLayer dbDecorator tr mDatabaseDir ti action = do Just fp -> handlingPersistError tr fp $ withConnectionPool tr' fp $ \pool -> do - ctx <- newSqliteContext tr' pool createViews migrateAll fp + ctx <- newSqliteContext tr' pool createViews migrateAll ctx & either throwIO (action . decorateDBLayer dbDecorator . newDBLayer tr ti) diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs index 22678a3a983..1ca54bcd21e 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs @@ -252,16 +252,17 @@ withDBLayer -> IO a withDBLayer tr defaultFieldValues mDatabaseDir ti action = case mDatabaseDir of - Nothing -> do - db <- newInMemorySqliteContext tr [] migrateAll >>= newDBLayer ti - action db + Nothing -> + newInMemorySqliteContext tr [] migrateAll + >>= newDBLayer ti + >>= action Just fp -> do let manualMigrations = migrateManually tr (Proxy @k) defaultFieldValues let autoMigrations = migrateAll withConnectionPool tr fp $ \pool -> do - ctx <- newSqliteContext tr pool manualMigrations autoMigrations fp - either throwIO (action <=< newDBLayer ti) ctx + res <- newSqliteContext tr pool manualMigrations autoMigrations + either throwIO (action <=< newDBLayer ti) res -- | Instantiate a 'DBFactory' from a given directory newDBFactory diff --git a/lib/core/test/bench/db/Main.hs b/lib/core/test/bench/db/Main.hs index f53d021f6db..6683a99d048 100644 --- a/lib/core/test/bench/db/Main.hs +++ b/lib/core/test/bench/db/Main.hs @@ -4,7 +4,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} @@ -193,11 +192,9 @@ import Data.Word import Fmt ( build, padLeftF, padRightF, pretty, (+|), (|+) ) import System.Directory - ( doesFileExist, getFileSize, removeFile ) + ( doesFileExist, getFileSize ) import System.FilePath ( takeFileName ) -import System.IO.Temp - ( emptySystemTempFile ) import System.IO.Unsafe ( unsafePerformIO ) import System.Random @@ -206,6 +203,8 @@ import Test.Utils.Resource ( unBracket ) import UnliftIO.Exception ( bracket, throwIO ) +import UnliftIO.Temporary + ( withSystemTempFile ) import qualified Cardano.BM.Configuration.Model as CM import qualified Cardano.BM.Data.BackendKind as CM @@ -659,20 +658,19 @@ withDB => Tracer IO DBLog -> (DBLayer IO s k -> Benchmark) -> Benchmark -withDB tr bm = envWithCleanup (setupDB tr) cleanupDB (\(BenchEnv _ _ _ db) -> bm db) +withDB tr bm = envWithCleanup (setupDB tr) cleanupDB (\(BenchEnv _ _ db) -> bm db) data BenchEnv s k = BenchEnv - { _connectionPool :: !ConnectionPool - , _destroyPool :: IO () - , _ctx :: !SqliteContext + { cleanupDB :: IO () + , _dbFile :: FilePath , _dbLayer :: !(DBLayer IO s k) } instance NFData (BenchEnv s k) where - rnf (BenchEnv p _ ctx db) = - deepseq (rnf p) $ - deepseq (rnf ctx) $ - deepseq (rnf db) () + rnf (BenchEnv _ fp db) = deepseq (rnf fp) $ deepseq (rnf db) () + +withTempSqliteFile :: (FilePath -> IO a) -> IO a +withTempSqliteFile action = withSystemTempFile "bench.db" $ \fp _ -> action fp setupDB :: forall s k. @@ -683,12 +681,14 @@ setupDB => Tracer IO DBLog -> IO (BenchEnv s k) setupDB tr = do - f <- emptySystemTempFile "bench.db" - (createPool, destroyPool) <- unBracket (withConnectionPool tr f) - pool <- createPool - ctx <- either throwIO pure =<< newSqliteContext tr pool [] migrateAll f - db <- newDBLayerWith NoCache singleEraInterpreter ctx - pure $ BenchEnv pool destroyPool ctx db + (createPool, destroyPool) <- unBracket withSetup + uncurry (BenchEnv destroyPool) <$> createPool + where + withSetup action = withTempSqliteFile $ \fp -> + withConnectionPool tr fp $ \pool -> do + ctx <- either throwIO pure =<< newSqliteContext tr pool [] migrateAll + db <- newDBLayerWith NoCache singleEraInterpreter ctx + action (fp, db) singleEraInterpreter :: TimeInterpreter IO singleEraInterpreter = hoistTimeInterpreter (pure . runIdentity) $ @@ -701,16 +701,6 @@ singleEraInterpreter = hoistTimeInterpreter (pure . runIdentity) $ , getSecurityParameter = Quantity 2160 }) -cleanupDB :: BenchEnv s k -> IO () -cleanupDB (BenchEnv _ destroyPool SqliteContext{dbFile} _) = do - destroyPool - let f = fromMaybe ":memory:" dbFile - mapM_ remove [f, f <> "-shm", f <> "-wal"] - where - remove f = doesFileExist f >>= \case - True -> removeFile f - False -> pure () - -- | Cleans the database before running the benchmark. -- It also cleans the database after running the benchmark. That is just to -- exercise the delete functions. @@ -789,8 +779,7 @@ txHistoryDiskSpaceTests tr = do benchDiskSize :: Tracer IO DBLog -> (DBLayerBench -> IO ()) -> IO () benchDiskSize tr action = bracket (setupDB tr) cleanupDB - $ \(BenchEnv _ destroyPool SqliteContext{dbFile} db) -> do - let f = fromMaybe ":memory:" dbFile + $ \(BenchEnv destroyPool f db) -> do action db mapM_ (printFileSize "") [f, f <> "-shm", f <> "-wal"] destroyPool From 1e27df549f36595b520b87514d2fb38cb2befba4 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Thu, 18 Feb 2021 23:56:58 +0800 Subject: [PATCH 17/21] Lightly refactor checkpoint cache --- lib/core/src/Cardano/Wallet/DB/Sqlite.hs | 82 +++++++++++++----------- 1 file changed, 45 insertions(+), 37 deletions(-) diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs index 1ca54bcd21e..ba36c219caf 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs @@ -1103,8 +1103,7 @@ newDBLayer -> SqliteContext -- ^ A (thread-)safe wrapper for query execution. -> IO (DBLayer IO s k) -newDBLayer = - newDBLayerWith @s @k CacheLatestCheckpoint +newDBLayer = newDBLayerWith @s @k CacheLatestCheckpoint -- | Like 'newDBLayer', but allows to explicitly specify the caching behavior. newDBLayerWith @@ -1138,7 +1137,7 @@ newDBLayerWith cacheBehavior ti SqliteContext{runQuery} = do -- -- NOTE2 -- When 'cacheBehavior' is set to 'NoCache', we simply never write anything - -- to the cache, which forces 'selectLatestCheckpoint' to always perform a + -- to the cache, which forces 'selectLatestCheckpointCached' to always perform a -- database lookup. cache <- newMVar Map.empty @@ -1149,39 +1148,33 @@ newDBLayerWith cacheBehavior ti SqliteContext{runQuery} = do NoCache -> pure () CacheLatestCheckpoint -> modifyMVar_ cache (pure . m) - let writeCache :: W.WalletId -> Maybe (W.Wallet s) -> SqlPersistT IO () - writeCache wid = maybeUpdateCache . \case - Nothing -> Map.delete wid - Just cp -> - let tip = cp ^. #currentTip . #blockHeight - alter = \case - Just old | tip < old ^. #currentTip . #blockHeight -> - Just old - _ -> - Just cp - in Map.alter alter wid - - let selectLatestCheckpoint + writeCache :: W.WalletId -> Maybe (W.Wallet s) -> SqlPersistT IO () + writeCache wid = maybeUpdateCache . flip Map.alter wid . maybe (const Nothing) alterCache + + alterCache :: W.Wallet s -> (Maybe (W.Wallet s) -> Maybe (W.Wallet s)) + alterCache cp = \case + -- this seems suspicious + Just old | getHeight cp < getHeight old -> Just old + _ -> Just cp + + getHeight = view (#currentTip . #blockHeight) + + let selectLatestCheckpointCached :: W.WalletId -> SqlPersistT IO (Maybe (W.Wallet s)) - selectLatestCheckpoint wid = do - readCache wid >>= maybe fromDatabase (pure . Just) - where - fromDatabase = do - mcp <- fmap entityVal <$> selectFirst - [ CheckpointWalletId ==. wid ] - [ LimitTo 1, Desc CheckpointSlot ] - case mcp of - Nothing -> pure Nothing - Just cp -> do - utxo <- selectUTxO cp - s <- selectState (checkpointId cp) - pure (checkpointFromEntity @s cp utxo <$> s) + selectLatestCheckpointCached wid = do + readCache wid >>= maybe (selectLatestCheckpoint @s wid) (pure . Just) + -- fixme: not threadsafe let invalidateCache :: W.WalletId -> SqlPersistT IO () invalidateCache wid = do writeCache wid Nothing - selectLatestCheckpoint wid >>= writeCache wid + cp <- selectLatestCheckpoint wid + writeCache wid cp + + -- fixme: not threadsafe + let insertCheckpointCached wid cp = + writeCache wid (Just cp) *> insertCheckpoint wid cp return DBLayer @@ -1193,7 +1186,7 @@ newDBLayerWith cacheBehavior ti SqliteContext{runQuery} = do res <- handleConstraint (ErrWalletAlreadyExists wid) $ insert_ (mkWalletEntity wid meta gp) when (isRight res) $ do - insertCheckpoint wid cp <* writeCache wid (Just cp) + insertCheckpointCached wid cp let (metas, txins, txouts, txoutTokens, ws) = mkTxHistory wid txs putTxs metas txins txouts txoutTokens ws @@ -1219,10 +1212,10 @@ newDBLayerWith cacheBehavior ti SqliteContext{runQuery} = do Nothing -> pure $ Left $ ErrNoSuchWallet wid Just _ -> - Right <$> (insertCheckpoint wid cp <* writeCache wid (Just cp)) + Right <$> insertCheckpointCached wid cp , readCheckpoint = \(PrimaryKey wid) -> do - selectLatestCheckpoint wid + selectLatestCheckpointCached wid , listCheckpoints = \(PrimaryKey wid) -> do map (blockHeaderFromEntity . entityVal) <$> selectList @@ -1261,7 +1254,7 @@ newDBLayerWith cacheBehavior ti SqliteContext{runQuery} = do pure (Right nearestPoint) , prune = \(PrimaryKey wid) epochStability -> ExceptT $ do - selectLatestCheckpoint wid >>= \case + selectLatestCheckpointCached wid >>= \case Nothing -> pure $ Left $ ErrNoSuchWallet wid Just cp -> Right <$> do pruneCheckpoints wid epochStability cp @@ -1280,7 +1273,7 @@ newDBLayerWith cacheBehavior ti SqliteContext{runQuery} = do pure $ Right () , readWalletMeta = \(PrimaryKey wid) -> do - selectLatestCheckpoint wid >>= \case + selectLatestCheckpointCached wid >>= \case Nothing -> pure Nothing Just cp -> do currentEpoch <- liftIO $ @@ -1334,7 +1327,7 @@ newDBLayerWith cacheBehavior ti SqliteContext{runQuery} = do pure $ Right () , readTxHistory = \(PrimaryKey wid) minWithdrawal order range status -> do - selectLatestCheckpoint wid >>= \case + selectLatestCheckpointCached wid >>= \case Nothing -> pure [] Just cp -> selectTxHistory cp ti wid minWithdrawal order $ catMaybes @@ -1368,7 +1361,7 @@ newDBLayerWith cacheBehavior ti SqliteContext{runQuery} = do else Right () , getTx = \(PrimaryKey wid) tid -> ExceptT $ do - selectLatestCheckpoint wid >>= \case + selectLatestCheckpointCached wid >>= \case Nothing -> pure $ Left $ ErrNoSuchWallet wid Just cp -> do metas <- selectTxHistory cp @@ -1796,6 +1789,21 @@ selectWallet :: MonadIO m => W.WalletId -> SqlPersistT m (Maybe Wallet) selectWallet wid = fmap entityVal <$> selectFirst [WalId ==. wid] [] +selectLatestCheckpoint + :: forall s. (PersistState s) + => W.WalletId + -> SqlPersistT IO (Maybe (W.Wallet s)) +selectLatestCheckpoint wid = do + mcp <- fmap entityVal <$> selectFirst + [ CheckpointWalletId ==. wid ] + [ LimitTo 1, Desc CheckpointSlot ] + case mcp of + Nothing -> pure Nothing + Just cp -> do + utxo <- selectUTxO cp + s <- selectState (checkpointId cp) + pure (checkpointFromEntity @s cp utxo <$> s) + insertCheckpoint :: forall s. (PersistState s) => W.WalletId From 201b6703d95ab6b3f9cb8754621c777e5170783e Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Thu, 25 Feb 2021 07:56:05 +1000 Subject: [PATCH 18/21] Decouple DBFactory from DBLayer a little --- lib/core/src/Cardano/DB/Sqlite.hs | 33 +-- lib/core/src/Cardano/Wallet/DB/Sqlite.hs | 211 ++++++++++++------ .../test/unit/Cardano/Wallet/DB/SqliteSpec.hs | 51 +++-- lib/shelley/bench/Restore.hs | 2 +- lib/shelley/src/Cardano/Wallet/Shelley.hs | 6 +- 5 files changed, 182 insertions(+), 121 deletions(-) diff --git a/lib/core/src/Cardano/DB/Sqlite.hs b/lib/core/src/Cardano/DB/Sqlite.hs index b388d044a3b..990809eb076 100644 --- a/lib/core/src/Cardano/DB/Sqlite.hs +++ b/lib/core/src/Cardano/DB/Sqlite.hs @@ -56,8 +56,6 @@ import Cardano.BM.Data.Severity ( Severity (..) ) import Cardano.BM.Data.Tracer ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) ) -import Cardano.DB.Sqlite.Delete - ( DeleteSqliteDatabaseLog ) import Cardano.Wallet.Logging ( BracketLog, bracketTracer ) import Control.Monad @@ -137,7 +135,7 @@ import qualified Database.Sqlite as Sqlite Sqlite connection set up -------------------------------------------------------------------------------} --- | Context for the SQLite 'DBLayer'. +-- | 'SqliteContext' is a function to execute queries. newtype SqliteContext = SqliteContext { runQuery :: forall a. SqlPersistT IO a -> IO a -- ^ Run a query with a connection from the pool. @@ -498,15 +496,9 @@ data DBLog | MsgDatabaseReset | MsgIsAlreadyClosed Text | MsgStatementAlreadyFinalized Text - | MsgWaitingForDatabase Text (Maybe Int) - | MsgRemovingInUse Text Int - | MsgRemoving Text - | MsgRemovingDatabaseFile Text DeleteSqliteDatabaseLog | MsgManualMigrationNeeded DBField Text | MsgManualMigrationNotNeeded DBField | MsgUpdatingForeignKeysSetting ForeignKeysSetting - | MsgFoundDatabase FilePath Text - | MsgUnknownDBFile FilePath | MsgRetryOnBusy Int RetryLog deriving (Generic, Show, Eq, ToJSON) @@ -527,15 +519,9 @@ instance HasSeverityAnnotation DBLog where MsgDatabaseReset -> Notice MsgIsAlreadyClosed _ -> Warning MsgStatementAlreadyFinalized _ -> Warning - MsgWaitingForDatabase _ _ -> Info - MsgRemovingInUse _ _ -> Notice - MsgRemoving _ -> Info - MsgRemovingDatabaseFile _ msg -> getSeverityAnnotation msg MsgManualMigrationNeeded{} -> Notice MsgManualMigrationNotNeeded{} -> Debug MsgUpdatingForeignKeysSetting{} -> Debug - MsgFoundDatabase _ _ -> Info - MsgUnknownDBFile _ -> Notice MsgRetryOnBusy n _ | n <= 1 -> Debug | n <= 3 -> Notice @@ -565,17 +551,6 @@ instance ToText DBLog where "Attempted to close an already closed connection: " <> msg MsgStatementAlreadyFinalized msg -> "Statement already finalized: " <> msg - MsgWaitingForDatabase wid Nothing -> - "Database "+|wid|+" is ready to be deleted" - MsgWaitingForDatabase wid (Just count) -> - "Waiting for "+|count|+" withDatabase "+|wid|+" call(s) to finish" - MsgRemovingInUse wid count -> - "Timed out waiting for "+|count|+" withDatabase "+|wid|+" call(s) to finish. " <> - "Attempting to remove the database anyway." - MsgRemoving wid -> - "Removing wallet's database. Wallet id was " <> wid - MsgRemovingDatabaseFile wid msg -> - "Removing " <> wid <> ": " <> toText msg MsgManualMigrationNeeded field value -> mconcat [ tableName field , " table does not contain required field '" @@ -596,12 +571,6 @@ instance ToText DBLog where , T.pack $ show value , "." ] - MsgFoundDatabase _file wid -> - "Found existing wallet: " <> wid - MsgUnknownDBFile file -> mconcat - [ "Found something other than a database file in " - , "the database folder: ", T.pack file - ] MsgRetryOnBusy n msg -> case msg of MsgRetry | n <= 10 -> diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs index ba36c219caf..5ee4254ea04 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs @@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} @@ -24,24 +25,39 @@ -- An implementation of the DBLayer which uses Persistent and SQLite. module Cardano.Wallet.DB.Sqlite - ( newDBLayer - , newDBLayerWith - , CacheBehavior (..) - , newDBFactory + ( -- * Directory of wallet databases + newDBFactory , findDatabases + , DBFactoryLog + + -- * Single file wallet database , withDBLayer + -- * Internal implementation + , newDBLayer + , newDBLayerInMemory + , newDBLayerWith + , CacheBehavior (..) + -- * Interfaces , PersistState (..) -- * Migration Support , DefaultFieldValues (..) + + ) where import Prelude import Cardano.Address.Derivation ( XPrv, XPub ) +import Cardano.Address.Script + ( KeyHash, ScriptHash (..) ) +import Cardano.BM.Data.Severity + ( Severity (..) ) +import Cardano.BM.Data.Tracer + ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) ) import Cardano.DB.Sqlite ( DBField (..) , DBLog (..) @@ -59,7 +75,12 @@ import Cardano.DB.Sqlite , withConnectionPool ) import Cardano.DB.Sqlite.Delete - ( deleteSqliteDatabase, newRefCount, waitForFree, withRef ) + ( DeleteSqliteDatabaseLog + , deleteSqliteDatabase + , newRefCount + , waitForFree + , withRef + ) import Cardano.Wallet.DB ( DBFactory (..) , DBLayer (..) @@ -201,7 +222,9 @@ import Database.Persist.Sqlite import Database.Persist.Types ( PersistValue (..), fromPersistValueText ) import Fmt - ( pretty ) + ( pretty, (+|), (|+) ) +import GHC.Generics + ( Generic ) import System.Directory ( doesFileExist, listDirectory ) import System.FilePath @@ -227,51 +250,19 @@ import qualified Data.Map.Strict as Map import qualified Data.Text as T import qualified Database.Sqlite as Sqlite --- | Runs an action with a connection to the SQLite database. --- --- Database migrations are run to create tables if necessary. --- --- If the given file path does not exist, it will be created by the sqlite --- library. -withDBLayer - :: forall s k a. - ( PersistState s - , PersistPrivateKey (k 'RootK) - , WalletKey k - ) - => Tracer IO DBLog - -- ^ Logging object - -> DefaultFieldValues - -- ^ Default database field values, used during migration. - -> Maybe FilePath - -- ^ Path to database directory, or Nothing for in-memory database - -> TimeInterpreter IO - -- ^ Time interpreter for slot to time conversions - -> (DBLayer IO s k -> IO a) - -- ^ Action to run. - -> IO a -withDBLayer tr defaultFieldValues mDatabaseDir ti action = - case mDatabaseDir of - Nothing -> - newInMemorySqliteContext tr [] migrateAll - >>= newDBLayer ti - >>= action - - Just fp -> do - let manualMigrations = migrateManually tr (Proxy @k) defaultFieldValues - let autoMigrations = migrateAll - withConnectionPool tr fp $ \pool -> do - res <- newSqliteContext tr pool manualMigrations autoMigrations - either throwIO (action <=< newDBLayer ti) res - --- | Instantiate a 'DBFactory' from a given directory +{------------------------------------------------------------------------------- + Database "factory" + (a directory containing one database file per wallet) +-------------------------------------------------------------------------------} + +-- | Instantiate a 'DBFactory' from a given directory, or in-memory for testing. newDBFactory :: forall s k. ( PersistState s , PersistPrivateKey (k 'RootK) , WalletKey k ) - => Tracer IO DBLog + => Tracer IO DBFactoryLog -- ^ Logging object -> DefaultFieldValues -- ^ Default database field values, used during migration. @@ -292,11 +283,11 @@ newDBFactory tr defaultFieldValues ti = \case pure DBFactory { withDatabase = \wid action -> do db <- modifyMVar mvar $ \m -> case Map.lookup wid m of - Just (_, db) -> pure (m, db) + Just db -> pure (m, db) Nothing -> do - ctx <- newInMemorySqliteContext tr [] migrateAll - db <- newDBLayer ti ctx - pure (Map.insert wid (ctx, db) m, db) + let tr' = contramap (MsgDBLog "") tr + db <- newDBLayerInMemory tr' ti + pure (Map.insert wid db m, db) action db , removeDatabase = \wid -> do traceWith tr $ MsgRemoving (pretty wid) @@ -310,9 +301,9 @@ newDBFactory tr defaultFieldValues ti = \case refs <- newRefCount pure DBFactory { withDatabase = \wid action -> withRef refs wid $ withDBLayer - tr + (contramap (MsgDBLog (databaseFile wid)) tr) defaultFieldValues - (Just $ databaseFile wid) + (databaseFile wid) ti action , removeDatabase = \wid -> do @@ -342,7 +333,7 @@ newDBFactory tr defaultFieldValues ti = \case -- specified directory. findDatabases :: forall k. WalletKey k - => Tracer IO DBLog + => Tracer IO DBFactoryLog -> FilePath -> IO [W.WalletId] findDatabases tr dir = do @@ -362,6 +353,63 @@ findDatabases tr dir = do where expectedPrefix = T.pack $ keyTypeDescriptor $ Proxy @k +data DBFactoryLog + = MsgFoundDatabase FilePath Text + | MsgUnknownDBFile FilePath + | MsgRemoving Text + | MsgRemovingInUse Text Int + | MsgRemovingDatabaseFile Text DeleteSqliteDatabaseLog + | MsgWaitingForDatabase Text (Maybe Int) + | MsgDBLog FilePath DBLog + deriving (Generic, Show, Eq) + +instance HasPrivacyAnnotation DBFactoryLog +instance HasSeverityAnnotation DBFactoryLog where + getSeverityAnnotation ev = case ev of + MsgFoundDatabase _ _ -> Info + MsgUnknownDBFile _ -> Notice + MsgRemoving _ -> Info + MsgRemovingInUse _ _ -> Notice + MsgRemovingDatabaseFile _ msg -> getSeverityAnnotation msg + MsgWaitingForDatabase _ _ -> Info + MsgDBLog _ msg -> getSeverityAnnotation msg + +instance ToText DBFactoryLog where + toText = \case + MsgFoundDatabase _file wid -> + "Found existing wallet: " <> wid + MsgUnknownDBFile file -> mconcat + [ "Found something other than a database file in " + , "the database folder: ", T.pack file + ] + MsgRemoving wid -> + "Removing wallet's database. Wallet id was " <> wid + MsgRemovingDatabaseFile wid msg -> + "Removing " <> wid <> ": " <> toText msg + MsgWaitingForDatabase wid Nothing -> + "Database "+|wid|+" is ready to be deleted" + MsgWaitingForDatabase wid (Just count) -> + "Waiting for "+|count|+" withDatabase "+|wid|+" call(s) to finish" + MsgRemovingInUse wid count -> + "Timed out waiting for "+|count|+" withDatabase "+|wid|+" call(s) to finish. " <> + "Attempting to remove the database anyway." + MsgDBLog _file msg -> toText msg + +{------------------------------------------------------------------------------- + Database Schema Migrations +-------------------------------------------------------------------------------} + +-- | A set of default field values that can be consulted when performing a +-- database migration. +-- +data DefaultFieldValues = DefaultFieldValues + { defaultActiveSlotCoefficient :: W.ActiveSlotCoefficient + , defaultDesiredNumberOfPool :: Word16 + , defaultMinimumUTxOValue :: W.Coin + , defaultHardforkEpoch :: Maybe W.EpochNo + , defaultKeyDeposit :: W.Coin + } + -- | A data-type for capturing column status. Used to be represented as a -- 'Maybe Bool' which is somewhat confusing to interpret. data SqlColumnStatus @@ -1065,19 +1113,56 @@ runSql conn raw = do Sqlite.Done -> do return (reverse acc) --- | A set of default field values that can be consulted when performing a --- database migration. +{------------------------------------------------------------------------------- + Database layer +-------------------------------------------------------------------------------} + +-- | Runs an action with a connection to the SQLite database. -- -data DefaultFieldValues = DefaultFieldValues - { defaultActiveSlotCoefficient :: W.ActiveSlotCoefficient - , defaultDesiredNumberOfPool :: Word16 - , defaultMinimumUTxOValue :: W.Coin - , defaultHardforkEpoch :: Maybe W.EpochNo - , defaultKeyDeposit :: W.Coin - } +-- Database migrations are run to create tables if necessary. +-- +-- If the given file path does not exist, it will be created by the sqlite +-- library. +withDBLayer + :: forall s k a. + ( PersistState s + , PersistPrivateKey (k 'RootK) + , WalletKey k + ) + => Tracer IO DBLog + -- ^ Logging object + -> DefaultFieldValues + -- ^ Default database field values, used during migration. + -> FilePath + -- ^ Path to database file + -> TimeInterpreter IO + -- ^ Time interpreter for slot to time conversions + -> (DBLayer IO s k -> IO a) + -- ^ Action to run. + -> IO a +withDBLayer tr defaultFieldValues dbFile ti action = do + let manualMigrations = migrateManually tr (Proxy @k) defaultFieldValues + let autoMigrations = migrateAll + withConnectionPool tr dbFile $ \pool -> do + res <- newSqliteContext tr pool manualMigrations autoMigrations + either throwIO (action <=< newDBLayer ti) res + +-- | Creates a 'DBLayer' backed by a sqlite in-memory database. +newDBLayerInMemory + :: forall s k. + ( PersistState s + , PersistPrivateKey (k 'RootK) + ) + => Tracer IO DBLog + -- ^ Logging object + -> TimeInterpreter IO + -- ^ Time interpreter for slot to time conversions + -> IO (DBLayer IO s k) +newDBLayerInMemory tr ti = + newInMemorySqliteContext tr [] migrateAll >>= newDBLayer ti --- | A type to capture what to do with regards to caching. This is useful to --- disable caching in database benchmarks. +-- | What to do with regards to caching. This is useful to disable caching in +-- database benchmarks. data CacheBehavior = NoCache | CacheLatestCheckpoint diff --git a/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs b/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs index 3afd5d1300a..a624f1a8d5a 100644 --- a/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs @@ -67,7 +67,16 @@ import Cardano.Wallet.DB.Arbitrary import Cardano.Wallet.DB.Properties ( properties ) import Cardano.Wallet.DB.Sqlite - ( DefaultFieldValues (..), PersistState, newDBFactory, withDBLayer ) + ( DefaultFieldValues (..) + , PersistState + , PersistState + , newDBFactory + , newDBFactory + , newDBLayer + , newDBLayerInMemory + , withDBLayer + , withDBLayer + ) import Cardano.Wallet.DB.StateMachine ( prop_parallel, prop_sequential, validateGenerators ) import Cardano.Wallet.DummyTarget.Primitive.Types @@ -441,7 +450,7 @@ testMigrationTxMetaFee dbName expectedLength caseByCase = do let ti = dummyTimeInterpreter copyFile orig path (logs, result) <- captureLogging $ \tr -> do - withDBLayer @s @k tr defaultFieldValues (Just path) ti + withDBLayer @s @k tr defaultFieldValues path ti $ \DBLayer{..} -> atomically $ do [wid] <- listWallets @@ -497,7 +506,7 @@ testMigrationCleanupCheckpoints dbName genesisParameters tip = do let ti = dummyTimeInterpreter copyFile orig path (logs, result) <- captureLogging $ \tr -> do - withDBLayer @s @k tr defaultFieldValues (Just path) ti + withDBLayer @s @k tr defaultFieldValues path ti $ \DBLayer{..} -> atomically $ do [wid] <- listWallets @@ -536,7 +545,7 @@ testMigrationRole dbName = do let ti = dummyTimeInterpreter copyFile orig path (logs, Just cp) <- captureLogging $ \tr -> do - withDBLayer @s @k tr defaultFieldValues (Just path) ti + withDBLayer @s @k tr defaultFieldValues path ti $ \DBLayer{..} -> atomically $ do [wid] <- listWallets @@ -574,7 +583,7 @@ testMigrationSeqStateDerivationPrefix dbName prefix = do let ti = dummyTimeInterpreter copyFile orig path (logs, Just cp) <- captureLogging $ \tr -> do - withDBLayer @s @k tr defaultFieldValues (Just path) ti + withDBLayer @s @k tr defaultFieldValues path ti $ \DBLayer{..} -> atomically $ do [wid] <- listWallets @@ -601,7 +610,7 @@ testMigrationPassphraseScheme = do let ti = dummyTimeInterpreter copyFile orig path (logs, (a,b,c,d)) <- captureLogging $ \tr -> do - withDBLayer @s @k tr defaultFieldValues (Just path) ti + withDBLayer @s @k tr defaultFieldValues path ti $ \DBLayer{..} -> atomically $ do Just a <- readWalletMeta $ PrimaryKey walNeedMigration @@ -810,13 +819,13 @@ fileModeSpec = do describe "Check db reading/writing from/to file and cleaning" $ do it "create and list wallet works" $ \f -> do - withShelleyDBLayer (Just f) $ \DBLayer{..} -> do + withShelleyDBLayer f $ \DBLayer{..} -> do atomically $ unsafeRunExceptT $ initializeWallet testPk testCp testMetadata mempty gp testOpeningCleaning f listWallets' [testPk] [] it "create and get meta works" $ \f -> do - meta <- withShelleyDBLayer (Just f) $ \DBLayer{..} -> do + meta <- withShelleyDBLayer f $ \DBLayer{..} -> do now <- getCurrentTime let meta = testMetadata { passphraseInfo = Just $ WalletPassphraseInfo now EncryptWithPBKDF2 } @@ -825,15 +834,15 @@ fileModeSpec = do return meta testOpeningCleaning f (`readWalletMeta'` testPk) (Just meta) Nothing - it "create and get private key" $ \f-> do - (k, h) <- withShelleyDBLayer (Just f) $ \db@DBLayer{..} -> do + it "create and get private key" $ \f -> do + (k, h) <- withShelleyDBLayer f $ \db@DBLayer{..} -> do atomically $ unsafeRunExceptT $ initializeWallet testPk testCp testMetadata mempty gp unsafeRunExceptT $ attachPrivateKey db testPk testOpeningCleaning f (`readPrivateKey'` testPk) (Just (k, h)) Nothing it "put and read tx history (Ascending)" $ \f -> do - withShelleyDBLayer (Just f) $ \DBLayer{..} -> do + withShelleyDBLayer f $ \DBLayer{..} -> do atomically $ do unsafeRunExceptT $ initializeWallet testPk testCp testMetadata mempty gp @@ -845,7 +854,7 @@ fileModeSpec = do mempty it "put and read tx history (Decending)" $ \f -> do - withShelleyDBLayer (Just f) $ \DBLayer{..} -> do + withShelleyDBLayer f $ \DBLayer{..} -> do atomically $ do unsafeRunExceptT $ initializeWallet testPk testCp testMetadata mempty gp @@ -857,7 +866,7 @@ fileModeSpec = do mempty it "put and read checkpoint" $ \f -> do - withShelleyDBLayer (Just f) $ \DBLayer{..} -> do + withShelleyDBLayer f $ \DBLayer{..} -> do atomically $ do unsafeRunExceptT $ initializeWallet testPk testCp testMetadata mempty gp @@ -870,7 +879,7 @@ fileModeSpec = do it "(Regression test #1575) - TxMetas and checkpoints should \ \rollback to the same place" $ \f -> do - withShelleyDBLayer (Just f) $ \db@DBLayer{..} -> do + withShelleyDBLayer f $ \db@DBLayer{..} -> do let ourAddrs = knownAddresses (getState testCp) @@ -952,9 +961,9 @@ prop_randomOpChunks (KeyValPairs pairs) = where prop = do filepath <- temporaryDBFile - withShelleyDBLayer (Just filepath) $ \dbF -> do + withShelleyDBLayer filepath $ \dbF -> do cleanDB dbF - withShelleyDBLayer Nothing $ \dbM -> do + withShelleyDBLayerInMemory $ \dbM -> do cleanDB dbM forM_ pairs (insertPair dbM) cutRandomly pairs >>= mapM_ (mapM (insertPair dbF)) @@ -1000,11 +1009,11 @@ testOpeningCleaning -> s -> Expectation testOpeningCleaning filepath call expectedAfterOpen expectedAfterClean = do - withShelleyDBLayer (Just filepath) $ \db -> do + withShelleyDBLayer filepath $ \db -> do call db `shouldReturn` expectedAfterOpen _ <- cleanDB db call db `shouldReturn` expectedAfterClean - withShelleyDBLayer (Just filepath) $ \db -> do + withShelleyDBLayer filepath $ \db -> do call db `shouldReturn` expectedAfterClean -- | Run a test action inside withDBLayer, then check assertions. @@ -1021,7 +1030,7 @@ withTestDBFile action expectations = do withDBLayer (trMessageText trace) defaultFieldValues - (Just fp) + fp ti action expectations fp @@ -1055,11 +1064,11 @@ withByronDBLayer fp = withDBLayer withShelleyDBLayer :: PersistState s - => Maybe FilePath + => FilePath -> (DBLayer IO s ShelleyKey -> IO a) -> IO a withShelleyDBLayer fp = withDBLayer - nullTracer + nullTracer -- fixme: capture logging defaultFieldValues fp dummyTimeInterpreter diff --git a/lib/shelley/bench/Restore.hs b/lib/shelley/bench/Restore.hs index ca1587f5baf..73092f7d4a3 100644 --- a/lib/shelley/bench/Restore.hs +++ b/lib/shelley/bench/Restore.hs @@ -690,7 +690,7 @@ withBenchDBLayer -> IO a withBenchDBLayer ti tr action = withSystemTempFile "bench.db" $ \dbFile _ -> - withDBLayer tr' migrationDefaultValues (Just dbFile) ti action + withDBLayer tr' migrationDefaultValues dbFile ti action where migrationDefaultValues = Sqlite.DefaultFieldValues { Sqlite.defaultActiveSlotCoefficient = 1 diff --git a/lib/shelley/src/Cardano/Wallet/Shelley.hs b/lib/shelley/src/Cardano/Wallet/Shelley.hs index b8720d3502e..99a650b896c 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley.hs @@ -50,8 +50,6 @@ import Cardano.BM.Data.Tracer ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..), filterSeverity ) import Cardano.BM.Trace ( Trace, appendName, nullTracer ) -import Cardano.DB.Sqlite - ( DBLog ) import Cardano.Launcher.Node ( CardanoNodeConn ) import Cardano.Pool.DB @@ -72,7 +70,7 @@ import Cardano.Wallet.Api.Types , EncodeStakeAddress ) import Cardano.Wallet.DB.Sqlite - ( DefaultFieldValues (..), PersistState ) + ( DBFactoryLog, DefaultFieldValues (..), PersistState ) import Cardano.Wallet.Logging ( trMessageText ) import Cardano.Wallet.Network @@ -497,7 +495,7 @@ data Tracers' f = Tracers , apiServerTracer :: f ApiLog , tokenMetadataTracer :: f TokenMetadataLog , walletEngineTracer :: f (WorkerLog WalletId WalletLog) - , walletDbTracer :: f DBLog + , walletDbTracer :: f DBFactoryLog , poolsEngineTracer :: f (WorkerLog Text StakePoolLog) , poolsDbTracer :: f PoolDbLog , ntpClientTracer :: f NtpTrace From f925eedaea1c98f6f6d0f90979fdbbefd4da3941 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Tue, 23 Feb 2021 17:03:31 +1000 Subject: [PATCH 19/21] DBLayer: Attempt to make the checkpoint cache threadsafe And add logging of database checkpoint cache --- lib/core/cardano-wallet-core.cabal | 1 + lib/core/src/Cardano/Wallet/DB/Sqlite.hs | 152 ++++++++++++------ lib/core/test/bench/db/Main.hs | 25 +-- .../test/unit/Cardano/Wallet/DB/SqliteSpec.hs | 68 ++++---- 4 files changed, 145 insertions(+), 101 deletions(-) diff --git a/lib/core/cardano-wallet-core.cabal b/lib/core/cardano-wallet-core.cabal index 3e852ab85b2..965defb33a9 100644 --- a/lib/core/cardano-wallet-core.cabal +++ b/lib/core/cardano-wallet-core.cabal @@ -396,6 +396,7 @@ benchmark db , cardano-wallet-launcher , cardano-wallet-test-utils , containers + , contra-tracer , criterion , cryptonite , deepseq diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs index 5ee4254ea04..4b3d7566ad6 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs @@ -28,10 +28,11 @@ module Cardano.Wallet.DB.Sqlite ( -- * Directory of wallet databases newDBFactory , findDatabases - , DBFactoryLog + , DBFactoryLog (..) -- * Single file wallet database , withDBLayer + , WalletDBLog (..) -- * Internal implementation , newDBLayer @@ -45,7 +46,6 @@ module Cardano.Wallet.DB.Sqlite -- * Migration Support , DefaultFieldValues (..) - ) where import Prelude @@ -174,7 +174,7 @@ import Data.List.Split import Data.Map.Strict ( Map ) import Data.Maybe - ( catMaybes, mapMaybe ) + ( catMaybes, isJust, mapMaybe ) import Data.Ord ( Down (..) ) import Data.Proxy @@ -232,7 +232,7 @@ import System.FilePath import UnliftIO.Exception ( Exception, throwIO ) import UnliftIO.MVar - ( modifyMVar, modifyMVar_, newMVar, readMVar ) + ( MVar, modifyMVar, modifyMVar_, newMVar, readMVar ) import qualified Cardano.Wallet.Primitive.AddressDerivation as W import qualified Cardano.Wallet.Primitive.AddressDiscovery.Random as Rnd @@ -285,7 +285,7 @@ newDBFactory tr defaultFieldValues ti = \case db <- modifyMVar mvar $ \m -> case Map.lookup wid m of Just db -> pure (m, db) Nothing -> do - let tr' = contramap (MsgDBLog "") tr + let tr' = contramap (MsgWalletDB "") tr db <- newDBLayerInMemory tr' ti pure (Map.insert wid db m, db) action db @@ -301,7 +301,7 @@ newDBFactory tr defaultFieldValues ti = \case refs <- newRefCount pure DBFactory { withDatabase = \wid action -> withRef refs wid $ withDBLayer - (contramap (MsgDBLog (databaseFile wid)) tr) + (contramap (MsgWalletDB (databaseFile wid)) tr) defaultFieldValues (databaseFile wid) ti @@ -360,7 +360,7 @@ data DBFactoryLog | MsgRemovingInUse Text Int | MsgRemovingDatabaseFile Text DeleteSqliteDatabaseLog | MsgWaitingForDatabase Text (Maybe Int) - | MsgDBLog FilePath DBLog + | MsgWalletDB FilePath WalletDBLog deriving (Generic, Show, Eq) instance HasPrivacyAnnotation DBFactoryLog @@ -372,7 +372,7 @@ instance HasSeverityAnnotation DBFactoryLog where MsgRemovingInUse _ _ -> Notice MsgRemovingDatabaseFile _ msg -> getSeverityAnnotation msg MsgWaitingForDatabase _ _ -> Info - MsgDBLog _ msg -> getSeverityAnnotation msg + MsgWalletDB _ msg -> getSeverityAnnotation msg instance ToText DBFactoryLog where toText = \case @@ -393,7 +393,7 @@ instance ToText DBFactoryLog where MsgRemovingInUse wid count -> "Timed out waiting for "+|count|+" withDatabase "+|wid|+" call(s) to finish. " <> "Attempting to remove the database anyway." - MsgDBLog _file msg -> toText msg + MsgWalletDB _file msg -> toText msg {------------------------------------------------------------------------------- Database Schema Migrations @@ -1129,7 +1129,7 @@ withDBLayer , PersistPrivateKey (k 'RootK) , WalletKey k ) - => Tracer IO DBLog + => Tracer IO WalletDBLog -- ^ Logging object -> DefaultFieldValues -- ^ Default database field values, used during migration. @@ -1141,11 +1141,42 @@ withDBLayer -- ^ Action to run. -> IO a withDBLayer tr defaultFieldValues dbFile ti action = do - let manualMigrations = migrateManually tr (Proxy @k) defaultFieldValues + let trDB = contramap MsgDB tr + let manualMigrations = migrateManually trDB (Proxy @k) defaultFieldValues let autoMigrations = migrateAll - withConnectionPool tr dbFile $ \pool -> do - res <- newSqliteContext tr pool manualMigrations autoMigrations - either throwIO (action <=< newDBLayer ti) res + withConnectionPool trDB dbFile $ \pool -> do + res <- newSqliteContext trDB pool manualMigrations autoMigrations + either throwIO (action <=< newDBLayer tr ti) res + +data WalletDBLog + = MsgDB DBLog + | MsgCheckpointCache W.WalletId CheckpointCacheLog + deriving (Generic, Show, Eq) + +data CheckpointCacheLog + = MsgPutCheckpoint + | MsgGetCheckpoint Bool + | MsgRefresh + | MsgDrop + deriving (Generic, Show, Eq) + +instance HasPrivacyAnnotation WalletDBLog +instance HasSeverityAnnotation WalletDBLog where + getSeverityAnnotation = \case + MsgDB msg -> getSeverityAnnotation msg + MsgCheckpointCache _ _ -> Debug + +instance ToText WalletDBLog where + toText = \case + MsgDB msg -> toText msg + MsgCheckpointCache wid msg -> "Checkpoint cache " <> toText wid <> ": " <> toText msg + +instance ToText CheckpointCacheLog where + toText = \case + MsgPutCheckpoint -> "Put" + MsgGetCheckpoint hit -> "Get " <> if hit then "hit" else "miss" + MsgRefresh -> "Refresh" + MsgDrop -> "Drop" -- | Creates a 'DBLayer' backed by a sqlite in-memory database. newDBLayerInMemory @@ -1153,13 +1184,14 @@ newDBLayerInMemory ( PersistState s , PersistPrivateKey (k 'RootK) ) - => Tracer IO DBLog + => Tracer IO WalletDBLog -- ^ Logging object -> TimeInterpreter IO -- ^ Time interpreter for slot to time conversions -> IO (DBLayer IO s k) -newDBLayerInMemory tr ti = - newInMemorySqliteContext tr [] migrateAll >>= newDBLayer ti +newDBLayerInMemory tr ti = do + ctx <- newInMemorySqliteContext (contramap MsgDB tr) [] migrateAll + newDBLayer tr ti ctx -- | What to do with regards to caching. This is useful to disable caching in -- database benchmarks. @@ -1183,7 +1215,9 @@ newDBLayer ( PersistState s , PersistPrivateKey (k 'RootK) ) - => TimeInterpreter IO + => Tracer IO WalletDBLog + -- ^ Logging + -> TimeInterpreter IO -- ^ Time interpreter for slot to time conversions -> SqliteContext -- ^ A (thread-)safe wrapper for query execution. @@ -1198,12 +1232,14 @@ newDBLayerWith ) => CacheBehavior -- ^ Option to disable caching. + -> Tracer IO WalletDBLog + -- ^ Logging -> TimeInterpreter IO - -- ^ Time interpreter for slot to time conversions. + -- ^ Time interpreter for slot to time conversions -> SqliteContext -- ^ A (thread-)safe wrapper for query execution. -> IO (DBLayer IO s k) -newDBLayerWith cacheBehavior ti SqliteContext{runQuery} = do +newDBLayerWith cacheBehavior tr ti SqliteContext{runQuery} = do -- NOTE1 -- We cache the latest checkpoint for read operation such that we prevent -- needless marshalling and unmarshalling with the database. Many handlers @@ -1224,42 +1260,62 @@ newDBLayerWith cacheBehavior ti SqliteContext{runQuery} = do -- When 'cacheBehavior' is set to 'NoCache', we simply never write anything -- to the cache, which forces 'selectLatestCheckpointCached' to always perform a -- database lookup. - cache <- newMVar Map.empty - - let readCache :: W.WalletId -> SqlPersistT IO (Maybe (W.Wallet s)) - readCache wid = Map.lookup wid <$> readMVar cache - - let maybeUpdateCache m = case cacheBehavior of - NoCache -> pure () - CacheLatestCheckpoint -> modifyMVar_ cache (pure . m) - - writeCache :: W.WalletId -> Maybe (W.Wallet s) -> SqlPersistT IO () - writeCache wid = maybeUpdateCache . flip Map.alter wid . maybe (const Nothing) alterCache - - alterCache :: W.Wallet s -> (Maybe (W.Wallet s) -> Maybe (W.Wallet s)) + -- + -- NOTE3 + -- Nested MVars provide per-wallet locking when updating the checkpoint + -- cache. + -- + cacheVar <- newMVar Map.empty :: IO (MVar (Map W.WalletId (MVar (Maybe (W.Wallet s))))) + + -- Gets or creates the cache MVar for a given wallet. + -- If caching is disabled it unconditionally returns a new empty cache. + let getCache :: W.WalletId -> SqlPersistT IO (MVar (Maybe (W.Wallet s))) + getCache wid = modifyMVar cacheVar $ \cache -> do + mvar <- maybe (newMVar Nothing) pure $ Map.lookup wid cache + let cache' = case cacheBehavior of + NoCache -> cache -- stick to initial value + CacheLatestCheckpoint -> Map.insert wid mvar cache + pure (cache', mvar) + + -- This condition is required to make property tests pass, where checkpoints + -- may be generated in any order. + let alterCache :: W.Wallet s -> Maybe (W.Wallet s) -> Maybe (W.Wallet s) alterCache cp = \case - -- this seems suspicious Just old | getHeight cp < getHeight old -> Just old _ -> Just cp getHeight = view (#currentTip . #blockHeight) + -- Inserts a checkpoint into the database and checkpoint cache + let insertCheckpointCached wid cp = do + mvar <- getCache wid + modifyMVar_ mvar $ \old -> do + liftIO $ traceWith tr $ MsgCheckpointCache wid MsgPutCheckpoint + insertCheckpoint wid cp + pure (alterCache cp old) + + -- Checks for cached a checkpoint before running selectLatestCheckpoint let selectLatestCheckpointCached :: W.WalletId -> SqlPersistT IO (Maybe (W.Wallet s)) selectLatestCheckpointCached wid = do - readCache wid >>= maybe (selectLatestCheckpoint @s wid) (pure . Just) - - -- fixme: not threadsafe - let invalidateCache :: W.WalletId -> SqlPersistT IO () - invalidateCache wid = do - writeCache wid Nothing - cp <- selectLatestCheckpoint wid - writeCache wid cp - - -- fixme: not threadsafe - let insertCheckpointCached wid cp = - writeCache wid (Just cp) *> insertCheckpoint wid cp + cp <- readMVar =<< getCache wid + liftIO $ traceWith tr $ MsgCheckpointCache wid $ MsgGetCheckpoint $ isJust cp + maybe (selectLatestCheckpoint @s wid) (pure . Just) cp + + -- Re-run the selectLatestCheckpoint query + let refreshCache :: W.WalletId -> SqlPersistT IO () + refreshCache wid = do + mvar <- getCache wid + modifyMVar_ mvar $ const $ do + liftIO $ traceWith tr $ MsgCheckpointCache wid MsgRefresh + selectLatestCheckpoint @s wid + + -- Delete the cache for a wallet + let dropCache :: W.WalletId -> SqlPersistT IO () + dropCache wid = modifyMVar_ cacheVar $ \cache -> do + liftIO $ traceWith tr $ MsgCheckpointCache wid MsgDrop + pure $ Map.delete wid cache return DBLayer @@ -1283,7 +1339,7 @@ newDBLayerWith cacheBehavior ti SqliteContext{runQuery} = do Just _ -> Right <$> do deleteCascadeWhere [WalId ==. wid] deleteLooseTransactions - invalidateCache wid + dropCache wid , listWallets = map (PrimaryKey . unWalletKey) <$> selectKeysList [] [Asc WalId] @@ -1335,7 +1391,7 @@ newDBLayerWith cacheBehavior ti SqliteContext{runQuery} = do deleteStakeKeyCerts wid [ StakeKeyCertSlot >. nearestPoint ] - invalidateCache wid + refreshCache wid pure (Right nearestPoint) , prune = \(PrimaryKey wid) epochStability -> ExceptT $ do diff --git a/lib/core/test/bench/db/Main.hs b/lib/core/test/bench/db/Main.hs index 6683a99d048..ea73d575fc6 100644 --- a/lib/core/test/bench/db/Main.hs +++ b/lib/core/test/bench/db/Main.hs @@ -54,7 +54,6 @@ import Cardano.BM.Setup ( setupTrace_, shutdown ) import Cardano.DB.Sqlite ( ConnectionPool - , DBLog , SqliteContext (..) , newSqliteContext , withConnectionPool @@ -66,7 +65,7 @@ import Cardano.Startup import Cardano.Wallet.DB ( DBLayer (..), PrimaryKey (..), cleanDB ) import Cardano.Wallet.DB.Sqlite - ( CacheBehavior (..), PersistState, newDBLayerWith ) + ( CacheBehavior (..), PersistState, WalletDBLog (..), newDBLayerWith ) import Cardano.Wallet.DB.Sqlite.TH ( migrateAll ) import Cardano.Wallet.DummyTarget.Primitive.Types @@ -152,6 +151,8 @@ import Control.Monad ( join ) import Control.Monad.Trans.Except ( mapExceptT ) +import Control.Tracer + ( contramap ) import Criterion.Main ( Benchmark , Benchmarkable @@ -655,7 +656,7 @@ withDB , PersistPrivateKey (k 'RootK) , WalletKey k ) - => Tracer IO DBLog + => Tracer IO WalletDBLog -> (DBLayer IO s k -> Benchmark) -> Benchmark withDB tr bm = envWithCleanup (setupDB tr) cleanupDB (\(BenchEnv _ _ db) -> bm db) @@ -678,18 +679,18 @@ setupDB , PersistPrivateKey (k 'RootK) , WalletKey k ) - => Tracer IO DBLog + => Tracer IO WalletDBLog -> IO (BenchEnv s k) setupDB tr = do (createPool, destroyPool) <- unBracket withSetup uncurry (BenchEnv destroyPool) <$> createPool where - withSetup action = withTempSqliteFile $ \fp -> - withConnectionPool tr fp $ \pool -> do - ctx <- either throwIO pure =<< newSqliteContext tr pool [] migrateAll - db <- newDBLayerWith NoCache singleEraInterpreter ctx + withSetup action = withTempSqliteFile $ \fp -> do + let trDB = contramap MsgDB tr + withConnectionPool trDB fp $ \pool -> do + ctx <- either throwIO pure =<< newSqliteContext trDB pool [] migrateAll + db <- newDBLayerWith NoCache tr singleEraInterpreter ctx action (fp, db) - singleEraInterpreter :: TimeInterpreter IO singleEraInterpreter = hoistTimeInterpreter (pure . runIdentity) $ mkSingleEraInterpreter @@ -739,7 +740,7 @@ walletFixtureByron db@DBLayer{..} = do -- These are not proper criterion benchmarks but use the benchmark test data to -- measure size on disk of the database and its temporary files. -utxoDiskSpaceTests :: Tracer IO DBLog -> IO () +utxoDiskSpaceTests :: Tracer IO WalletDBLog -> IO () utxoDiskSpaceTests tr = do putStrLn "Database disk space usage tests for UTxO\n" sequence_ @@ -761,7 +762,7 @@ utxoDiskSpaceTests tr = do walletFixture db benchPutUTxO n s 0 db -txHistoryDiskSpaceTests :: Tracer IO DBLog -> IO () +txHistoryDiskSpaceTests :: Tracer IO WalletDBLog -> IO () txHistoryDiskSpaceTests tr = do putStrLn "Database disk space usage tests for TxHistory\n" sequence_ @@ -777,7 +778,7 @@ txHistoryDiskSpaceTests tr = do walletFixture db benchPutTxHistory n i o 0 [1..100] db -benchDiskSize :: Tracer IO DBLog -> (DBLayerBench -> IO ()) -> IO () +benchDiskSize :: Tracer IO WalletDBLog -> (DBLayerBench -> IO ()) -> IO () benchDiskSize tr action = bracket (setupDB tr) cleanupDB $ \(BenchEnv destroyPool f db) -> do action db diff --git a/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs b/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs index a624f1a8d5a..0d1da75165d 100644 --- a/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs @@ -47,10 +47,14 @@ import Cardano.BM.Trace import Cardano.Crypto.Wallet ( XPrv ) import Cardano.DB.Sqlite - ( DBLog (..) + ( DBField + , DBLog (..) + , DBLog (..) , SqliteContext , destroyDBLayer , fieldName + , fieldName + , newInMemorySqliteContext , newInMemorySqliteContext ) import Cardano.Mnemonic @@ -69,13 +73,11 @@ import Cardano.Wallet.DB.Properties import Cardano.Wallet.DB.Sqlite ( DefaultFieldValues (..) , PersistState - , PersistState - , newDBFactory + , WalletDBLog (..) , newDBFactory , newDBLayer , newDBLayerInMemory , withDBLayer - , withDBLayer ) import Cardano.Wallet.DB.StateMachine ( prop_parallel, prop_sequential, validateGenerators ) @@ -477,14 +479,14 @@ testMigrationTxMetaFee dbName expectedLength caseByCase = do Just TransactionInfo{txInfoFee} -> txInfoFee `shouldBe` Just expectedFee where - isMsgManualMigration :: DBLog -> Bool - isMsgManualMigration = \case - MsgManualMigrationNeeded field _ -> - fieldName field == unDBName fieldInDb - _ -> - False - where - fieldInDb = fieldDB $ persistFieldDef DB.TxMetaFee + isMsgManualMigration = matchMsgManualMigration $ \field -> + let fieldInDB = fieldDB $ persistFieldDef DB.TxMetaFee + in fieldName field == unDBName fieldInDB + +matchMsgManualMigration :: (DBField -> Bool) -> WalletDBLog -> Bool +matchMsgManualMigration p = \case + MsgDB (MsgManualMigrationNeeded field _) -> p field + _ -> False testMigrationCleanupCheckpoints :: forall k s. @@ -521,12 +523,9 @@ testMigrationCleanupCheckpoints dbName genesisParameters tip = do fieldGenesisHash = fieldDB $ persistFieldDef DB.WalGenesisHash fieldGenesisStart = fieldDB $ persistFieldDef DB.WalGenesisStart - isMsgManualMigration :: DBName -> DBLog -> Bool - isMsgManualMigration fieldInDb = \case - MsgManualMigrationNeeded field _ -> - fieldName field == unDBName fieldInDb - _ -> - False + isMsgManualMigration :: DBName -> WalletDBLog -> Bool + isMsgManualMigration fieldInDB = matchMsgManualMigration $ \field -> + fieldName field == unDBName fieldInDB testMigrationRole :: forall k s. @@ -554,14 +553,10 @@ testMigrationRole dbName = do length migrationMsg `shouldBe` 3 length (knownAddresses $ getState cp) `shouldBe` 71 where - isMsgManualMigration :: DBLog -> Bool - isMsgManualMigration = \case - MsgManualMigrationNeeded field _ -> - fieldName field == unDBName fieldInDb - _ -> - False - where - fieldInDb = fieldDB $ persistFieldDef DB.SeqStateAddressRole + isMsgManualMigration :: WalletDBLog -> Bool + isMsgManualMigration = matchMsgManualMigration $ \field -> + let fieldInDB = fieldDB $ persistFieldDef DB.SeqStateAddressRole + in fieldName field == unDBName fieldInDB testMigrationSeqStateDerivationPrefix :: forall k s. @@ -592,13 +587,9 @@ testMigrationSeqStateDerivationPrefix dbName prefix = do length migrationMsg `shouldBe` 1 derivationPrefix (getState cp) `shouldBe` DerivationPrefix prefix where - isMsgManualMigration :: DBLog -> Bool - isMsgManualMigration = \case - MsgManualMigrationNeeded field _ -> - fieldName field == - unDBName (fieldDB $ persistFieldDef DB.SeqStateDerivationPrefix) - _ -> - False + isMsgManualMigration = matchMsgManualMigration $ \field -> + let fieldInDB = fieldDB $ persistFieldDef DB.SeqStateDerivationPrefix + in fieldName field == unDBName fieldInDB testMigrationPassphraseScheme :: forall s k. (k ~ ShelleyKey, s ~ SeqState 'Mainnet k) @@ -640,13 +631,9 @@ testMigrationPassphraseScheme = do -- account public key), so it should still have NO scheme. (passphraseScheme <$> passphraseInfo d) `shouldBe` Nothing where - isMsgManualMigration :: DBLog -> Bool - isMsgManualMigration = \case - MsgManualMigrationNeeded field _ -> - fieldName field == - unDBName (fieldDB $ persistFieldDef DB.WalPassphraseScheme) - _ -> - False + isMsgManualMigration = matchMsgManualMigration $ \field -> + let fieldInDB = fieldDB $ persistFieldDef DB.WalPassphraseScheme + in fieldName field == unDBName fieldInDB -- Coming from __test/data/passphraseScheme-v2020-03-16.sqlite__: -- @@ -691,7 +678,6 @@ loggingSpec = withLoggingDB @(SeqState 'Mainnet ShelleyKey) $ do msgs <- findObserveDiffs <$> getLogs length msgs `shouldBe` count * 2 - withLoggingDB :: PersistState s => SpecWith (IO [DBLog], DBLayer IO s ShelleyKey) From b062938fb880bdfd98dd362e7d05d4d3e6012362 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Fri, 26 Feb 2021 19:53:02 +1000 Subject: [PATCH 20/21] Add a query lock temporarily to let the checkpoint cache work --- lib/core/src/Cardano/Wallet/DB/Sqlite.hs | 66 +++++++++++++----------- 1 file changed, 35 insertions(+), 31 deletions(-) diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs index 4b3d7566ad6..005043842ff 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs @@ -232,7 +232,7 @@ import System.FilePath import UnliftIO.Exception ( Exception, throwIO ) import UnliftIO.MVar - ( MVar, modifyMVar, modifyMVar_, newMVar, readMVar ) + ( MVar, modifyMVar, modifyMVar_, newMVar, readMVar, withMVar ) import qualified Cardano.Wallet.Primitive.AddressDerivation as W import qualified Cardano.Wallet.Primitive.AddressDiscovery.Random as Rnd @@ -1260,26 +1260,34 @@ newDBLayerWith cacheBehavior tr ti SqliteContext{runQuery} = do -- When 'cacheBehavior' is set to 'NoCache', we simply never write anything -- to the cache, which forces 'selectLatestCheckpointCached' to always perform a -- database lookup. + + cacheVar <- newMVar Map.empty :: IO (MVar (Map W.WalletId (W.Wallet s))) + -- -- NOTE3 - -- Nested MVars provide per-wallet locking when updating the checkpoint - -- cache. + -- This cache will not work properly unless 'atomically' is protected by a + -- mutex (queryLock), which means no concurrent queries. -- - cacheVar <- newMVar Map.empty :: IO (MVar (Map W.WalletId (MVar (Maybe (W.Wallet s))))) - - -- Gets or creates the cache MVar for a given wallet. - -- If caching is disabled it unconditionally returns a new empty cache. - let getCache :: W.WalletId -> SqlPersistT IO (MVar (Maybe (W.Wallet s))) - getCache wid = modifyMVar cacheVar $ \cache -> do - mvar <- maybe (newMVar Nothing) pure $ Map.lookup wid cache - let cache' = case cacheBehavior of + queryLock <- newMVar () -- fixme: ADP-586 + + -- Gets cached checkpoint for a given wallet. + -- If caching is disabled it unconditionally returns Nothing + let getCache :: W.WalletId -> SqlPersistT IO (Maybe (W.Wallet s)) + getCache wid = Map.lookup wid <$> readMVar cacheVar + + -- Adjust a wallet entry in the cache. + modifyCache :: W.WalletId -> (Maybe (W.Wallet s) -> SqlPersistT IO (Maybe (W.Wallet s))) -> SqlPersistT IO () + modifyCache wid action = modifyMVar_ cacheVar $ \cache -> do + let old = Map.lookup wid cache + action old >>= \case + Nothing -> pure $ Map.delete wid cache + Just cp -> pure $ case cacheBehavior of NoCache -> cache -- stick to initial value - CacheLatestCheckpoint -> Map.insert wid mvar cache - pure (cache', mvar) + CacheLatestCheckpoint -> Map.insert wid cp cache - -- This condition is required to make property tests pass, where checkpoints - -- may be generated in any order. - let alterCache :: W.Wallet s -> Maybe (W.Wallet s) -> Maybe (W.Wallet s) + -- This condition is required to make property tests pass, where + -- checkpoints may be generated in any order. + alterCache :: W.Wallet s -> Maybe (W.Wallet s) -> Maybe (W.Wallet s) alterCache cp = \case Just old | getHeight cp < getHeight old -> Just old _ -> Just cp @@ -1287,35 +1295,31 @@ newDBLayerWith cacheBehavior tr ti SqliteContext{runQuery} = do getHeight = view (#currentTip . #blockHeight) -- Inserts a checkpoint into the database and checkpoint cache - let insertCheckpointCached wid cp = do - mvar <- getCache wid - modifyMVar_ mvar $ \old -> do - liftIO $ traceWith tr $ MsgCheckpointCache wid MsgPutCheckpoint - insertCheckpoint wid cp - pure (alterCache cp old) + let insertCheckpointCached wid cp = modifyCache wid $ \old -> do + liftIO $ traceWith tr $ MsgCheckpointCache wid MsgPutCheckpoint + insertCheckpoint wid cp + pure (alterCache cp old) -- Checks for cached a checkpoint before running selectLatestCheckpoint let selectLatestCheckpointCached :: W.WalletId -> SqlPersistT IO (Maybe (W.Wallet s)) selectLatestCheckpointCached wid = do - cp <- readMVar =<< getCache wid + cp <- getCache wid liftIO $ traceWith tr $ MsgCheckpointCache wid $ MsgGetCheckpoint $ isJust cp maybe (selectLatestCheckpoint @s wid) (pure . Just) cp -- Re-run the selectLatestCheckpoint query let refreshCache :: W.WalletId -> SqlPersistT IO () - refreshCache wid = do - mvar <- getCache wid - modifyMVar_ mvar $ const $ do - liftIO $ traceWith tr $ MsgCheckpointCache wid MsgRefresh - selectLatestCheckpoint @s wid + refreshCache wid = modifyCache wid $ const $ do + liftIO $ traceWith tr $ MsgCheckpointCache wid MsgRefresh + selectLatestCheckpoint @s wid -- Delete the cache for a wallet let dropCache :: W.WalletId -> SqlPersistT IO () - dropCache wid = modifyMVar_ cacheVar $ \cache -> do + dropCache wid = modifyCache wid $ const $ do liftIO $ traceWith tr $ MsgCheckpointCache wid MsgDrop - pure $ Map.delete wid cache + pure Nothing return DBLayer @@ -1553,7 +1557,7 @@ newDBLayerWith cacheBehavior tr ti SqliteContext{runQuery} = do ACID Execution -----------------------------------------------------------------------} - , atomically = runQuery + , atomically = withMVar queryLock . const . runQuery } readWalletMetadata From 7729917df1fabd1f22596c3dccec56f560da4c12 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Tue, 2 Mar 2021 15:35:46 +1000 Subject: [PATCH 21/21] Properly resolve merge conflicts from rebase --- lib/core/src/Cardano/DB/Sqlite.hs | 4 +- lib/core/src/Cardano/Pool/DB/Sqlite.hs | 9 ++-- lib/core/src/Cardano/Wallet/DB/Sqlite.hs | 48 ++++++++++++------- lib/core/test/bench/db/Main.hs | 1 + .../test/unit/Cardano/Pool/DB/SqliteSpec.hs | 8 +--- .../test/unit/Cardano/Wallet/DB/SqliteSpec.hs | 45 ++++++++--------- 6 files changed, 62 insertions(+), 53 deletions(-) diff --git a/lib/core/src/Cardano/DB/Sqlite.hs b/lib/core/src/Cardano/DB/Sqlite.hs index 990809eb076..30f2fb74648 100644 --- a/lib/core/src/Cardano/DB/Sqlite.hs +++ b/lib/core/src/Cardano/DB/Sqlite.hs @@ -166,7 +166,7 @@ newInMemorySqliteContext :: Tracer IO DBLog -> [ManualMigration] -> Migration - -> IO SqliteContext + -> IO (IO (), SqliteContext) newInMemorySqliteContext tr manualMigrations autoMigration = do conn <- Sqlite.open ":memory:" mapM_ (`executeManualMigration` conn) manualMigrations @@ -183,7 +183,7 @@ newInMemorySqliteContext tr manualMigrations autoMigration = do let runQuery :: forall a. SqlPersistT IO a -> IO a runQuery cmd = withMVarMasked lock (observe . runSqlConn cmd) - return $ SqliteContext { runQuery } + return (close' unsafeBackend, SqliteContext { runQuery }) -- | Sets up query logging and timing, runs schema migrations if necessary and -- provide a safe 'SqliteContext' for interacting with the database. diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs index 04c1effd649..f96473dd796 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs @@ -138,7 +138,7 @@ import System.FilePath import System.Random ( newStdGen ) import UnliftIO.Exception - ( catch, throwIO ) + ( bracket, catch, throwIO ) import qualified Cardano.Pool.DB.Sqlite.TH as TH import qualified Cardano.Wallet.Primitive.Types as W @@ -205,9 +205,10 @@ withDecoratedDBLayer -> IO a withDecoratedDBLayer dbDecorator tr mDatabaseDir ti action = do case mDatabaseDir of - Nothing -> do - ctx <- newInMemorySqliteContext tr' createViews migrateAll - action (decorateDBLayer dbDecorator $ newDBLayer tr ti ctx) + Nothing -> bracket + (newInMemorySqliteContext tr' createViews migrateAll) + fst + (action . decorateDBLayer dbDecorator . newDBLayer tr ti . snd) Just fp -> handlingPersistError tr fp $ withConnectionPool tr' fp $ \pool -> do diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs index 005043842ff..523af662788 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs @@ -25,18 +25,15 @@ -- An implementation of the DBLayer which uses Persistent and SQLite. module Cardano.Wallet.DB.Sqlite - ( -- * Directory of wallet databases + ( -- * Directory of single-file wallet databases newDBFactory , findDatabases , DBFactoryLog (..) - -- * Single file wallet database + -- * Internal implementation , withDBLayer + , withDBLayerInMemory , WalletDBLog (..) - - -- * Internal implementation - , newDBLayer - , newDBLayerInMemory , newDBLayerWith , CacheBehavior (..) @@ -52,8 +49,6 @@ import Prelude import Cardano.Address.Derivation ( XPrv, XPub ) -import Cardano.Address.Script - ( KeyHash, ScriptHash (..) ) import Cardano.BM.Data.Severity ( Severity (..) ) import Cardano.BM.Data.Tracer @@ -230,7 +225,7 @@ import System.Directory import System.FilePath ( () ) import UnliftIO.Exception - ( Exception, throwIO ) + ( Exception, bracket, throwIO ) import UnliftIO.MVar ( MVar, modifyMVar, modifyMVar_, newMVar, readMVar, withMVar ) @@ -273,12 +268,17 @@ newDBFactory -> IO (DBFactory IO s k) newDBFactory tr defaultFieldValues ti = \case Nothing -> do - -- NOTE + -- NOTE1 -- For the in-memory database, we do actually preserve the database -- after the 'action' is done. This allows for calling 'withDatabase' -- several times within the same execution and get back the same -- database. The memory is only cleaned up when calling -- 'removeDatabase', to mimic the way the file database works! + -- + -- NOTE2 + -- The in-memory withDatabase will leak memory unless removeDatabase is + -- called after using the database. In practice, this is only a problem + -- for testing. mvar <- newMVar mempty pure DBFactory { withDatabase = \wid action -> do @@ -286,7 +286,7 @@ newDBFactory tr defaultFieldValues ti = \case Just db -> pure (m, db) Nothing -> do let tr' = contramap (MsgWalletDB "") tr - db <- newDBLayerInMemory tr' ti + (_cleanup, db) <- newDBLayerInMemory tr' ti pure (Map.insert wid db m, db) action db , removeDatabase = \wid -> do @@ -446,7 +446,6 @@ migrateManually tr proxy defaultFieldValues = , addSeqStateDerivationPrefixIfMissing , renameRoleColumn , renameRoleFields - , addScriptAddressGapIfMissing , updateFeeValueAndAddKeyDeposit , addFeeToTransaction , moveRndUnusedAddresses @@ -1146,7 +1145,7 @@ withDBLayer tr defaultFieldValues dbFile ti action = do let autoMigrations = migrateAll withConnectionPool trDB dbFile $ \pool -> do res <- newSqliteContext trDB pool manualMigrations autoMigrations - either throwIO (action <=< newDBLayer tr ti) res + either throwIO (action <=< newDBLayerWith CacheLatestCheckpoint tr ti) res data WalletDBLog = MsgDB DBLog @@ -1178,6 +1177,21 @@ instance ToText CheckpointCacheLog where MsgRefresh -> "Refresh" MsgDrop -> "Drop" +-- | Runs an IO action with a new 'DBLayer' backed by a sqlite in-memory +-- database. +withDBLayerInMemory + :: forall s k a. + ( PersistState s + , PersistPrivateKey (k 'RootK) + ) + => Tracer IO WalletDBLog + -- ^ Logging object + -> TimeInterpreter IO + -- ^ Time interpreter for slot to time conversions + -> (DBLayer IO s k -> IO a) + -> IO a +withDBLayerInMemory tr ti action = bracket (newDBLayerInMemory tr ti) fst (action . snd) + -- | Creates a 'DBLayer' backed by a sqlite in-memory database. newDBLayerInMemory :: forall s k. @@ -1188,10 +1202,12 @@ newDBLayerInMemory -- ^ Logging object -> TimeInterpreter IO -- ^ Time interpreter for slot to time conversions - -> IO (DBLayer IO s k) + -> IO (IO (), DBLayer IO s k) newDBLayerInMemory tr ti = do - ctx <- newInMemorySqliteContext (contramap MsgDB tr) [] migrateAll - newDBLayer tr ti ctx + let tr' = contramap MsgDB tr + (destroy, ctx) <- newInMemorySqliteContext tr' [] migrateAll + db <- newDBLayer tr ti ctx + pure (destroy, db) -- | What to do with regards to caching. This is useful to disable caching in -- database benchmarks. diff --git a/lib/core/test/bench/db/Main.hs b/lib/core/test/bench/db/Main.hs index ea73d575fc6..9c37631e4e5 100644 --- a/lib/core/test/bench/db/Main.hs +++ b/lib/core/test/bench/db/Main.hs @@ -691,6 +691,7 @@ setupDB tr = do ctx <- either throwIO pure =<< newSqliteContext trDB pool [] migrateAll db <- newDBLayerWith NoCache tr singleEraInterpreter ctx action (fp, db) + singleEraInterpreter :: TimeInterpreter IO singleEraInterpreter = hoistTimeInterpreter (pure . runIdentity) $ mkSingleEraInterpreter diff --git a/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs b/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs index bbcfb639426..7704c31a9e9 100644 --- a/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs +++ b/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs @@ -16,7 +16,7 @@ import Prelude import Cardano.BM.Trace ( nullTracer ) import Cardano.DB.Sqlite - ( DBLog (..), newInMemorySqliteContext ) + ( DBLog (..) ) import Cardano.Pool.DB ( DBLayer (..) ) import Cardano.Pool.DB.Log @@ -24,13 +24,9 @@ import Cardano.Pool.DB.Log import Cardano.Pool.DB.Properties ( properties ) import Cardano.Pool.DB.Sqlite - ( createViews, newDBLayer, withDBLayer ) -import Cardano.Pool.DB.Sqlite.TH - ( migrateAll ) + ( withDBLayer ) import Cardano.Wallet.DummyTarget.Primitive.Types ( dummyTimeInterpreter ) -import Control.Tracer - ( contramap ) import System.Directory ( copyFile ) import System.FilePath diff --git a/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs b/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs index 0d1da75165d..06541cb83ef 100644 --- a/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs @@ -47,16 +47,7 @@ import Cardano.BM.Trace import Cardano.Crypto.Wallet ( XPrv ) import Cardano.DB.Sqlite - ( DBField - , DBLog (..) - , DBLog (..) - , SqliteContext - , destroyDBLayer - , fieldName - , fieldName - , newInMemorySqliteContext - , newInMemorySqliteContext - ) + ( DBField, DBLog (..), SqliteContext, fieldName, newInMemorySqliteContext ) import Cardano.Mnemonic ( SomeMnemonic (..) ) import Cardano.Wallet.DB @@ -75,9 +66,8 @@ import Cardano.Wallet.DB.Sqlite , PersistState , WalletDBLog (..) , newDBFactory - , newDBLayer - , newDBLayerInMemory , withDBLayer + , withDBLayerInMemory ) import Cardano.Wallet.DB.StateMachine ( prop_parallel, prop_sequential, validateGenerators ) @@ -418,7 +408,7 @@ spec = parallel $ do sqliteSpecSeq :: Spec sqliteSpecSeq = do validateGenerators @(SeqState 'Mainnet ShelleyKey) - around (withShelleyDBLayer Nothing) $ do + around withShelleyDBLayerInMemory $ do parallel $ describe "Sqlite" properties parallel $ describe "Sqlite State machine tests" $ do it "Sequential" (prop_sequential :: TestDBSeq -> Property) @@ -427,7 +417,7 @@ sqliteSpecSeq = do sqliteSpecRnd :: Spec sqliteSpecRnd = do validateGenerators @(RndState 'Mainnet) - around (withByronDBLayer Nothing) $ do + around withByronDBLayer $ do parallel $ describe "Sqlite State machine (RndState)" $ do it "Sequential state machine tests" (prop_sequential :: TestDBRnd -> Property) @@ -686,16 +676,18 @@ withLoggingDB = around f . beforeWith clean where f act = do logVar <- newTVarIO [] - withDBLayer + withDBLayerInMemory (traceInTVarIO logVar) - defaultFieldValues - Nothing dummyTimeInterpreter - (\(_, db) -> act (logVar, db)) + (\db -> act (logVar, db)) clean (logs, db) = do cleanDB db STM.atomically $ writeTVar logs [] - pure (readTVarIO logs, db) + pure (mapMaybe getMsgDB <$> readTVarIO logs, db) + +getMsgDB :: WalletDBLog -> Maybe DBLog +getMsgDB (MsgDB msg) = Just msg +getMsgDB _ = Nothing shouldHaveMsgQuery :: [DBLog] -> Text -> Expectation shouldHaveMsgQuery msgs str = unless (any match msgs) $ @@ -726,7 +718,7 @@ fileModeSpec = do describe "Check db opening/closing" $ do it "Opening and closing of db works" $ do replicateM_ 25 $ do - db <- Just <$> temporaryDBFile + db <- temporaryDBFile withShelleyDBLayer @(SeqState 'Mainnet ShelleyKey) db (\_ -> pure ()) @@ -1039,13 +1031,10 @@ defaultFieldValues = DefaultFieldValues -- for type-application everywhere. withByronDBLayer :: PersistState s - => Maybe FilePath -- ^ Just for on-disk db, Nothing for in-memory. - -> ((DBLayer IO s ByronKey) -> IO a) + => ((DBLayer IO s ByronKey) -> IO a) -> IO a -withByronDBLayer fp = withDBLayer +withByronDBLayer = withDBLayerInMemory nullTracer - defaultFieldValues - fp dummyTimeInterpreter withShelleyDBLayer @@ -1059,6 +1048,12 @@ withShelleyDBLayer fp = withDBLayer fp dummyTimeInterpreter +withShelleyDBLayerInMemory + :: PersistState s + => (DBLayer IO s ShelleyKey -> IO a) + -> IO a +withShelleyDBLayerInMemory = withDBLayerInMemory nullTracer dummyTimeInterpreter + listWallets' :: DBLayer m s k -> m [PrimaryKey WalletId]