diff --git a/lib/core/cardano-wallet-core.cabal b/lib/core/cardano-wallet-core.cabal index 8ebd1a87726..747f1de568d 100644 --- a/lib/core/cardano-wallet-core.cabal +++ b/lib/core/cardano-wallet-core.cabal @@ -82,6 +82,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 41adfd2a6c5..9236932fdaa 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs @@ -200,12 +200,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 2a18a06ee9e..b40ad27560f 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs @@ -253,11 +253,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 a8d91c6427f..2d9aee36631 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 @@ -628,7 +628,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 @@ -722,7 +722,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 f8b5670df5c..4599c5dc221 100644 --- a/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs @@ -799,7 +799,7 @@ fileModeSpec = do replicateM_ 25 $ do db <- Just <$> temporaryDBFile (ctx, _) <- newDBLayer' @(SeqState 'Mainnet ShelleyKey) db - destroyDBLayer ctx + destroyDBLayer nullTracer ctx describe "DBFactory" $ do let ti = dummyTimeInterpreter @@ -879,7 +879,7 @@ fileModeSpec = do (ctx, DBLayer{..}) <- newDBLayer' (Just f) atomically $ unsafeRunExceptT $ initializeWallet testPk testCp testMetadata mempty gp pp - destroyDBLayer ctx + destroyDBLayer nullTracer ctx testOpeningCleaning f listWallets' [testPk] [] it "create and get meta works" $ \f -> do @@ -889,7 +889,7 @@ fileModeSpec = do { passphraseInfo = Just $ WalletPassphraseInfo now EncryptWithPBKDF2 } atomically $ unsafeRunExceptT $ initializeWallet testPk testCp meta mempty gp pp - destroyDBLayer ctx + destroyDBLayer nullTracer ctx testOpeningCleaning f (`readWalletMeta'` testPk) (Just meta) Nothing it "create and get private key" $ \f-> do @@ -897,7 +897,7 @@ fileModeSpec = do atomically $ unsafeRunExceptT $ initializeWallet testPk testCp testMetadata mempty gp pp (k, h) <- unsafeRunExceptT $ attachPrivateKey db testPk - destroyDBLayer ctx + destroyDBLayer nullTracer ctx testOpeningCleaning f (`readPrivateKey'` testPk) (Just (k, h)) Nothing it "put and read tx history (Ascending)" $ \f -> do @@ -906,7 +906,7 @@ fileModeSpec = do unsafeRunExceptT $ initializeWallet testPk testCp testMetadata mempty gp pp unsafeRunExceptT $ putTxHistory testPk testTxs - destroyDBLayer ctx + destroyDBLayer nullTracer ctx testOpeningCleaning f (\db' -> readTxHistory' db' testPk Ascending wholeRange Nothing) @@ -919,7 +919,7 @@ fileModeSpec = do unsafeRunExceptT $ initializeWallet testPk testCp testMetadata mempty gp pp unsafeRunExceptT $ putTxHistory testPk testTxs - destroyDBLayer ctx + destroyDBLayer nullTracer ctx testOpeningCleaning f (\db' -> readTxHistory' db' testPk Descending wholeRange Nothing) @@ -932,7 +932,7 @@ fileModeSpec = do unsafeRunExceptT $ initializeWallet testPk testCp testMetadata mempty gp pp unsafeRunExceptT $ putCheckpoint testPk testCp - destroyDBLayer ctx + destroyDBLayer nullTracer ctx testOpeningCleaning f (`readCheckpoint'` testPk) (Just testCp) Nothing describe "Golden rollback scenarios" $ do @@ -1029,9 +1029,9 @@ prop_randomOpChunks (KeyValPairs pairs) = cutRandomly pairs >>= mapM_ (\chunk -> do (ctx, db) <- newDBLayer' (Just filepath) forM_ chunk (insertPair db) - destroyDBLayer ctx) + destroyDBLayer nullTracer ctx) dbF `shouldBeConsistentWith` dbM - destroyDBLayer ctxF *> destroyDBLayer ctxM + destroyDBLayer nullTracer ctxF *> destroyDBLayer nullTracer ctxM insertPair :: DBLayer IO s k @@ -1077,11 +1077,10 @@ testOpeningCleaning filepath call expectedAfterOpen expectedAfterClean = do call db1 `shouldReturn` expectedAfterOpen _ <- cleanDB db1 call db1 `shouldReturn` expectedAfterClean - destroyDBLayer ctx1 + destroyDBLayer nullTracer ctx1 (ctx2,db2) <- newDBLayer' (Just filepath) call db2 `shouldReturn` expectedAfterClean - destroyDBLayer ctx2 - + destroyDBLayer nullTracer ctx2 -- | Run a test action inside withDBLayer, then check assertions. withTestDBFile diff --git a/lib/shelley/bench/Restore.hs b/lib/shelley/bench/Restore.hs index e2fa866cc0d..000693400e0 100644 --- a/lib/shelley/bench/Restore.hs +++ b/lib/shelley/bench/Restore.hs @@ -675,7 +675,7 @@ withBenchDBLayer withBenchDBLayer ti action = withSystemTempFile "bench.db" $ \dbFile _ -> do let before = newDBLayer nullTracer migrationDefaultValues (Just dbFile) ti - let after = destroyDBLayer . fst + let after = destroyDBLayer nullTracer . fst bracket before after $ \(_ctx, db) -> action db where migrationDefaultValues = Sqlite.DefaultFieldValues diff --git a/nix/.stack.nix/cardano-wallet-core.nix b/nix/.stack.nix/cardano-wallet-core.nix index 1047d244cc6..775f1644d09 100644 --- a/nix/.stack.nix/cardano-wallet-core.nix +++ b/nix/.stack.nix/cardano-wallet-core.nix @@ -78,6 +78,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"))