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