From 0656feb85dd66fe83e82479e4e366f433b16fe1b Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 5 Jan 2021 17:06:41 +0100 Subject: [PATCH] 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 | 70 +++--- lib/core/test/bench/db/Main.hs | 71 +++--- .../test/unit/Cardano/Pool/DB/SqliteSpec.hs | 25 ++- .../test/unit/Cardano/Wallet/DB/SqliteSpec.hs | 148 +++++------- lib/shelley/bench/Restore.hs | 10 +- 8 files changed, 298 insertions(+), 329 deletions(-) diff --git a/lib/core/cardano-wallet-core.cabal b/lib/core/cardano-wallet-core.cabal index a53ee32883d..b413a721ed7 100644 --- a/lib/core/cardano-wallet-core.cabal +++ b/lib/core/cardano-wallet-core.cabal @@ -95,7 +95,6 @@ library , servant-server , split , statistics - , stm , streaming-commons , strict-non-empty-containers , string-interpolate @@ -408,7 +407,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 3cc8f3e9ddf..8af37feef17 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 @@ -200,12 +203,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. -- @@ -220,21 +233,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) $ @@ -253,7 +258,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 @@ -416,7 +421,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 @@ -430,7 +435,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 @@ -500,7 +505,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 ] @@ -514,11 +519,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 @@ -673,22 +678,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 @@ -857,17 +859,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 9eafd01205e..f9cdd478948 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 ) @@ -125,7 +127,7 @@ import Cardano.Wallet.Primitive.Slotting 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 @@ -250,14 +252,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 @@ -271,7 +282,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) @@ -289,8 +300,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 @@ -309,7 +320,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 @@ -1038,32 +1049,20 @@ data DefaultFieldValues = DefaultFieldValues -- 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) -newDBLayer trace defaultFieldValues mDatabaseFile ti = do - ctx@SqliteContext{runQuery} <- - either throwIO pure =<< - newSqliteContext - (migrateManually trace (Proxy @k) defaultFieldValues) - migrateAll - trace - mDatabaseFile - + => TimeInterpreter IO + -- ^ Time interpreter for slot to time conversions + -> SqliteContext + -- ^ A (thread-)safe wrapper for query execution. + -> IO (DBLayer IO s k) +newDBLayer 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 @@ -1125,7 +1124,7 @@ newDBLayer trace defaultFieldValues mDatabaseFile ti = do writeCache wid Nothing selectLatestCheckpoint wid >>= writeCache wid - return (ctx, DBLayer + return DBLayer {----------------------------------------------------------------------- Wallets @@ -1373,8 +1372,7 @@ newDBLayer 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 1c43523d42b..bb311a6d342 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,7 +68,9 @@ import Cardano.Startup import Cardano.Wallet.DB ( DBLayer (..), PrimaryKey (..), cleanDB ) import Cardano.Wallet.DB.Sqlite - ( DefaultFieldValues (..), PersistState, newDBLayer ) + ( PersistState, newDBLayer ) +import Cardano.Wallet.DB.Sqlite.TH + ( migrateAll ) import Cardano.Wallet.DummyTarget.Primitive.Types ( block0, dummyGenesisParameters, dummyProtocolParameters, mkTxId ) import Cardano.Wallet.Logging @@ -99,7 +108,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 (..) @@ -183,8 +192,6 @@ import Data.Typeable ( Typeable ) import Data.Word ( Word64 ) -import Database.Sqlite - ( SqliteException (..) ) import Fmt ( build, padLeftF, padRightF, pretty, (+|), (|+) ) import System.Directory @@ -198,7 +205,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 @@ -674,13 +681,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) <- newDBLayer 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 <- newDBLayer singleEraInterpreter ctx + pure (pool, ctx, db) + +singleEraInterpreter :: TimeInterpreter IO +singleEraInterpreter = hoistTimeInterpreter (pure . runIdentity) $ + mkSingleEraInterpreter (StartTime $ posixSecondsToUTCTime 0) (SlottingParameters { getSlotLength = SlotLength 1 @@ -689,20 +700,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 @@ -792,12 +794,14 @@ txHistoryDiskSpaceTests tr = do benchPutTxHistory mkOutputsCoin n i o [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 @@ -831,6 +835,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 9e88856b733..20b61ed4dd9 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 ( traceInTVarIO ) import Cardano.DB.Sqlite - ( DBLog (..), SqliteContext ) + ( 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 - ( newDBLayer, 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 @@ -45,12 +49,15 @@ import UnliftIO.Temporary -- | Set up a DBLayer for testing, with the command context, and the logging -- variable. newMemoryDBLayer :: IO (DBLayer IO) -newMemoryDBLayer = snd . snd <$> newMemoryDBLayer' +newMemoryDBLayer = snd <$> newMemoryDBLayer' -newMemoryDBLayer' :: IO (TVar [PoolDbLog], (SqliteContext, DBLayer IO)) +newMemoryDBLayer' :: IO (TVar [PoolDbLog], DBLayer IO) newMemoryDBLayer' = do logVar <- newTVarIO [] - (logVar, ) <$> newDBLayer (traceInTVarIO logVar) Nothing ti + let tr = traceInTVarIO logVar + let tr' = contramap MsgGeneric tr + ctx <- newInMemorySqliteContext tr' createViews migrateAll + return (logVar, newDBLayer tr ti ctx) where ti = dummyTimeInterpreter @@ -75,7 +82,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 @@ -83,9 +90,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 4599c5dc221..f3b8ddf52a1 100644 --- a/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs @@ -46,7 +46,7 @@ import Cardano.BM.Trace import Cardano.Crypto.Wallet ( XPrv ) import Cardano.DB.Sqlite - ( DBLog (..), SqliteContext, destroyDBLayer, fieldName ) + ( DBLog (..), fieldName, newInMemorySqliteContext ) import Cardano.Mnemonic ( SomeMnemonic (..) ) import Cardano.Wallet.DB @@ -172,10 +172,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 @@ -454,7 +450,7 @@ testMigrationTxMetaFee dbName expectedLength caseByCase = do copyFile orig path (logs, result) <- captureLogging $ \tr -> do withDBLayer @s @k tr defaultFieldValues (Just path) ti - $ \(_ctx, db) -> db & \DBLayer{..} -> atomically + $ \DBLayer{..} -> atomically $ do [wid] <- listWallets readTxHistory wid Nothing Descending wholeRange Nothing @@ -510,7 +506,7 @@ testMigrationCleanupCheckpoints dbName genesisParameters tip = do copyFile orig path (logs, result) <- captureLogging $ \tr -> do withDBLayer @s @k tr defaultFieldValues (Just path) ti - $ \(_ctx, db) -> db & \DBLayer{..} -> atomically + $ \DBLayer{..} -> atomically $ do [wid] <- listWallets (,) <$> readGenesisParameters wid <*> readCheckpoint wid @@ -549,7 +545,7 @@ testMigrationRole dbName = do copyFile orig path (logs, Just cp) <- captureLogging $ \tr -> do withDBLayer @s @k tr defaultFieldValues (Just path) ti - $ \(_ctx, db) -> db & \DBLayer{..} -> atomically + $ \DBLayer{..} -> atomically $ do [wid] <- listWallets readCheckpoint wid @@ -587,7 +583,7 @@ testMigrationSeqStateDerivationPrefix dbName prefix = do copyFile orig path (logs, Just cp) <- captureLogging $ \tr -> do withDBLayer @s @k tr defaultFieldValues (Just path) ti - $ \(_ctx, db) -> db & \DBLayer{..} -> atomically + $ \DBLayer{..} -> atomically $ do [wid] <- listWallets readCheckpoint wid @@ -614,7 +610,7 @@ testMigrationPassphraseScheme = do copyFile orig path (logs, (a,b,c,d)) <- captureLogging $ \tr -> do withDBLayer @s @k tr defaultFieldValues (Just path) ti - $ \(_ctx, db) -> db & \DBLayer{..} -> atomically + $ \DBLayer{..} -> atomically $ do Just a <- readWalletMeta $ PrimaryKey walNeedMigration Just b <- readWalletMeta $ PrimaryKey walNewScheme @@ -686,7 +682,7 @@ testMigrationUpdateFeeValue dbName expectedFeePolicy expectedKeyDeposit = do copyFile orig path (logs, pp') <- captureLogging $ \tr -> do withDBLayer @s @k tr defaultFieldValues (Just path) ti - $ \(_ctx, db) -> db & \DBLayer{..} -> atomically + $ \DBLayer{..} -> atomically $ do [wid] <- listWallets readProtocolParameters wid @@ -739,18 +735,18 @@ newMemoryDBLayer , WalletKey k ) => IO (DBLayer IO s k) -newMemoryDBLayer = snd . snd <$> newMemoryDBLayer' +newMemoryDBLayer = snd <$> newMemoryDBLayer' newMemoryDBLayer' :: ( PersistState s , PersistPrivateKey (k 'RootK) , WalletKey k ) - => IO (TVar [DBLog], (SqliteContext, DBLayer IO s k)) + => IO (TVar [DBLog], DBLayer IO s k) newMemoryDBLayer' = do logVar <- newTVarIO [] - (logVar, ) <$> - newDBLayer (traceInTVarIO logVar) defaultFieldValues Nothing ti + ctx <- newInMemorySqliteContext (traceInTVarIO logVar) [] DB.migrateAll + (logVar,) <$> newDBLayer ti ctx where ti = dummyTimeInterpreter @@ -763,7 +759,7 @@ withLoggingDB -> Spec withLoggingDB = beforeAll newMemoryDBLayer' . beforeWith clean where - clean (logs, (_, db)) = do + clean (logs, db) = do cleanDB db STM.atomically $ writeTVar logs [] pure (readTVarIO logs, db) @@ -798,8 +794,7 @@ fileModeSpec = do it "Opening and closing of db works" $ do replicateM_ 25 $ do db <- Just <$> temporaryDBFile - (ctx, _) <- newDBLayer' @(SeqState 'Mainnet ShelleyKey) db - destroyDBLayer nullTracer ctx + withTestDBLayer @(SeqState 'Mainnet ShelleyKey) db $ \_ -> pure () describe "DBFactory" $ do let ti = dummyTimeInterpreter @@ -876,37 +871,33 @@ fileModeSpec = do describe "Check db reading/writing from/to file and cleaning" $ do it "create and list wallet works" $ \f -> do - (ctx, DBLayer{..}) <- newDBLayer' (Just f) - atomically $ unsafeRunExceptT $ - initializeWallet testPk testCp testMetadata mempty gp pp - destroyDBLayer nullTracer ctx + withTestDBLayer (Just f) $ \DBLayer{..} -> do + atomically $ unsafeRunExceptT $ + initializeWallet testPk testCp testMetadata mempty gp pp testOpeningCleaning f listWallets' [testPk] [] it "create and get meta works" $ \f -> do - (ctx, DBLayer{..}) <- newDBLayer' (Just f) now <- getCurrentTime let meta = testMetadata { passphraseInfo = Just $ WalletPassphraseInfo now EncryptWithPBKDF2 } - atomically $ unsafeRunExceptT $ - initializeWallet testPk testCp meta mempty gp pp - destroyDBLayer nullTracer ctx + withTestDBLayer (Just f) $ \DBLayer{..} -> do + atomically $ unsafeRunExceptT $ + initializeWallet testPk testCp meta mempty gp pp testOpeningCleaning f (`readWalletMeta'` testPk) (Just meta) Nothing - it "create and get private key" $ \f-> do - (ctx, db@DBLayer{..}) <- newDBLayer' (Just f) - atomically $ unsafeRunExceptT $ - initializeWallet testPk testCp testMetadata mempty gp pp - (k, h) <- unsafeRunExceptT $ attachPrivateKey db testPk - destroyDBLayer nullTracer ctx + it "create and get private key" $ \f -> do + (k, h) <- withTestDBLayer (Just f) $ \db@DBLayer{..} -> do + atomically $ unsafeRunExceptT $ + initializeWallet testPk testCp testMetadata mempty gp pp + unsafeRunExceptT $ attachPrivateKey db testPk testOpeningCleaning f (`readPrivateKey'` testPk) (Just (k, h)) Nothing it "put and read tx history (Ascending)" $ \f -> do - (ctx, DBLayer{..}) <- newDBLayer' (Just f) - atomically $ do - unsafeRunExceptT $ - initializeWallet testPk testCp testMetadata mempty gp pp - unsafeRunExceptT $ putTxHistory testPk testTxs - destroyDBLayer nullTracer ctx + withTestDBLayer (Just f) $ \DBLayer{..} -> do + atomically $ do + unsafeRunExceptT $ + initializeWallet testPk testCp testMetadata mempty gp pp + unsafeRunExceptT $ putTxHistory testPk testTxs testOpeningCleaning f (\db' -> readTxHistory' db' testPk Ascending wholeRange Nothing) @@ -914,12 +905,11 @@ fileModeSpec = do mempty it "put and read tx history (Decending)" $ \f -> do - (ctx, DBLayer{..}) <- newDBLayer' (Just f) - atomically $ do - unsafeRunExceptT $ - initializeWallet testPk testCp testMetadata mempty gp pp - unsafeRunExceptT $ putTxHistory testPk testTxs - destroyDBLayer nullTracer ctx + withTestDBLayer (Just f) $ \DBLayer{..} -> do + atomically $ do + unsafeRunExceptT $ + initializeWallet testPk testCp testMetadata mempty gp pp + unsafeRunExceptT $ putTxHistory testPk testTxs testOpeningCleaning f (\db' -> readTxHistory' db' testPk Descending wholeRange Nothing) @@ -927,12 +917,11 @@ fileModeSpec = do mempty it "put and read checkpoint" $ \f -> do - (ctx, DBLayer{..}) <- newDBLayer' (Just f) - atomically $ do - unsafeRunExceptT $ - initializeWallet testPk testCp testMetadata mempty gp pp - unsafeRunExceptT $ putCheckpoint testPk testCp - destroyDBLayer nullTracer ctx + withTestDBLayer (Just f) $ \DBLayer{..} -> do + atomically $ do + unsafeRunExceptT $ + initializeWallet testPk testCp testMetadata mempty gp pp + unsafeRunExceptT $ putCheckpoint testPk testCp testOpeningCleaning f (`readCheckpoint'` testPk) (Just testCp) Nothing describe "Golden rollback scenarios" $ do @@ -941,7 +930,7 @@ fileModeSpec = do it "(Regression test #1575) - TxMetas and checkpoints should \ \rollback to the same place" $ \f -> do - (_ctx, db@DBLayer{..}) <- newDBLayer' (Just f) + withTestDBLayer (Just f) $ \db@DBLayer{..} -> do let ourAddrs = knownAddresses (getState testCp) @@ -1023,15 +1012,12 @@ prop_randomOpChunks (KeyValPairs pairs) = where prop = do filepath <- temporaryDBFile - (ctxF, dbF) <- newDBLayer' (Just filepath) >>= cleanDB' - (ctxM, dbM) <- inMemoryDBLayer >>= cleanDB' - forM_ pairs (insertPair dbM) - cutRandomly pairs >>= mapM_ (\chunk -> do - (ctx, db) <- newDBLayer' (Just filepath) - forM_ chunk (insertPair db) - destroyDBLayer nullTracer ctx) - dbF `shouldBeConsistentWith` dbM - destroyDBLayer nullTracer ctxF *> destroyDBLayer nullTracer ctxM + withTestDBLayer (Just filepath) $ \dbF -> do + cleanDB dbF + withTestDBLayer Nothing $ \dbM -> do + forM_ pairs (insertPair dbM) + cutRandomly pairs >>= mapM_ (mapM (insertPair dbF)) + dbF `shouldBeConsistentWith` dbM insertPair :: DBLayer IO s k @@ -1073,14 +1059,12 @@ testOpeningCleaning -> s -> Expectation testOpeningCleaning filepath call expectedAfterOpen expectedAfterClean = do - (ctx1, db1) <- newDBLayer' (Just filepath) - call db1 `shouldReturn` expectedAfterOpen - _ <- cleanDB db1 - call db1 `shouldReturn` expectedAfterClean - destroyDBLayer nullTracer ctx1 - (ctx2,db2) <- newDBLayer' (Just filepath) - call db2 `shouldReturn` expectedAfterClean - destroyDBLayer nullTracer ctx2 + withTestDBLayer (Just filepath) $ \db -> do + call db `shouldReturn` expectedAfterOpen + _ <- cleanDB db + call db `shouldReturn` expectedAfterClean + withTestDBLayer (Just filepath) $ \db -> do + call db `shouldReturn` expectedAfterClean -- | Run a test action inside withDBLayer, then check assertions. withTestDBFile @@ -1098,16 +1082,11 @@ withTestDBFile action expectations = do defaultFieldValues (Just fp) ti - (action . snd) + action expectations fp where ti = dummyTimeInterpreter -inMemoryDBLayer - :: PersistState s - => IO (SqliteContext, DBLayer IO s ShelleyKey) -inMemoryDBLayer = newDBLayer' Nothing - temporaryDBFile :: IO FilePath temporaryDBFile = emptySystemTempFile "cardano-wallet-SqliteFileMode" @@ -1120,21 +1099,16 @@ defaultFieldValues = DefaultFieldValues , defaultKeyDeposit = Coin 2_000_000 } -newDBLayer' +withTestDBLayer :: PersistState s => Maybe FilePath - -> IO (SqliteContext, DBLayer IO s ShelleyKey) -newDBLayer' fp = newDBLayer nullTracer defaultFieldValues fp ti - where - ti = dummyTimeInterpreter - --- | Clean the database -cleanDB' - :: Monad m - => (SqliteContext, DBLayer m s k) - -> m (SqliteContext, DBLayer m s k) -cleanDB' (ctx, db) = - cleanDB db $> (ctx, db) + -> (DBLayer IO s ShelleyKey -> IO a) + -> IO a +withTestDBLayer 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 9e2753769de..903e7c58705 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 @@ -72,7 +70,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 @@ -198,7 +196,7 @@ import System.IO import UnliftIO.Concurrent ( forkIO, threadDelay ) import UnliftIO.Exception - ( bracket, evaluate, throwString ) + ( evaluate, throwString ) import UnliftIO.Temporary ( withSystemTempFile ) @@ -673,9 +671,7 @@ withBenchDBLayer -> IO a withBenchDBLayer ti action = withSystemTempFile "bench.db" $ \dbFile _ -> do - let before = newDBLayer nullTracer migrationDefaultValues (Just dbFile) ti - let after = destroyDBLayer nullTracer . fst - bracket before after $ \(_ctx, db) -> action db + withDBLayer nullTracer migrationDefaultValues (Just dbFile) ti action where migrationDefaultValues = Sqlite.DefaultFieldValues { Sqlite.defaultActiveSlotCoefficient = 1