diff --git a/lib/core-integration/src/Test/Integration/Framework/Context.hs b/lib/core-integration/src/Test/Integration/Framework/Context.hs index 737611d55af..0924822bb6b 100644 --- a/lib/core-integration/src/Test/Integration/Framework/Context.hs +++ b/lib/core-integration/src/Test/Integration/Framework/Context.hs @@ -3,6 +3,7 @@ module Test.Integration.Framework.Context ( Context (..) + , PoolGarbageCollectionEvent (..) , TxDescription (..) ) where @@ -11,9 +12,11 @@ import Prelude import Cardano.CLI ( Port (..) ) import Cardano.Wallet.Primitive.Types - ( NetworkParameters ) + ( EpochNo, NetworkParameters, PoolRetirementCertificate ) import Cardano.Wallet.Transaction ( DelegationAction ) +import Data.IORef + ( IORef ) import Data.Proxy ( Proxy (..) ) import Data.Text @@ -48,9 +51,24 @@ data Context t = Context -- ^ Blockchain parameters for the underlying chain. , _target :: Proxy t + , _poolGarbageCollectionEvents + :: IORef [PoolGarbageCollectionEvent] } deriving Generic +-- | Records the parameters and return value of a single call to the +-- 'removeRetiredPools' operation of 'Pool.DB.DBLayer'. +-- +data PoolGarbageCollectionEvent = PoolGarbageCollectionEvent + { poolGarbageCollectionEpochNo + :: EpochNo + -- ^ The epoch number parameter. + , poolGarbageCollectionCertificates + :: [PoolRetirementCertificate] + -- ^ The pools that were removed from the database. + } + deriving (Eq, Show) + -- | Describe a transaction in terms of its inputs and outputs. data TxDescription = DelegDescription DelegationAction diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs index 37743d527f3..45037bf5c07 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs @@ -26,6 +26,9 @@ module Cardano.Pool.DB.Sqlite ( newDBLayer , withDBLayer + , withDecoratedDBLayer + , DBDecorator (..) + , undecoratedDB , defaultFilePath , DatabaseView (..) ) where @@ -153,16 +156,45 @@ defaultFilePath = ( "stake-pools.sqlite") -- library. withDBLayer :: Tracer IO PoolDbLog + -- ^ Logging object + -> Maybe FilePath + -- ^ Database file location, or Nothing for in-memory database + -> TimeInterpreter IO + -- ^ The time interpreter object. + -> (DBLayer IO -> IO a) + -- ^ Action to run. + -> IO a +withDBLayer = withDecoratedDBLayer undecoratedDB + +-- | A decorator for the database layer, useful for instrumenting or monitoring +-- calls to database operations. +data DBDecorator a = DBDecorator { decorateDBLayer :: DBLayer a -> DBLayer a } + +-- | Do not decorate the database layer. +undecoratedDB :: DBDecorator a +undecoratedDB = DBDecorator id + +-- | Runs an action with a connection to the SQLite database. +-- +-- This function has the same behaviour as 'withDBLayer', but provides a way +-- to decorate the created 'DBLayer' object with a 'DBDecorator', useful for +-- instrumenting or monitoring calls to database operations. +-- +withDecoratedDBLayer + :: DBDecorator IO + -- ^ The database decorator. + -> Tracer IO PoolDbLog -- ^ Logging object -> Maybe FilePath -- ^ Database file location, or Nothing for in-memory database -> TimeInterpreter IO + -- ^ The time interpreter object. -> (DBLayer IO -> IO a) -- ^ Action to run. -> IO a -withDBLayer trace fp timeInterpreter action = do +withDecoratedDBLayer dbDecorator trace fp timeInterpreter action = do traceWith trace (MsgGeneric $ MsgWillOpenDB fp) - bracket before after (action . snd) + bracket before after (action . decorateDBLayer dbDecorator . snd) where before = newDBLayer trace fp timeInterpreter after = destroyDBLayer . fst diff --git a/lib/jormungandr/test/bench/Latency.hs b/lib/jormungandr/test/bench/Latency.hs index ba22ae9c04b..fe950976245 100644 --- a/lib/jormungandr/test/bench/Latency.hs +++ b/lib/jormungandr/test/bench/Latency.hs @@ -403,5 +403,7 @@ benchWithJormServer tracers action = withConfig $ \jmCfg -> do , _networkParameters = np , _feeEstimator = \_ -> error "feeEstimator not available" , _target = Proxy + , _poolGarbageCollectionEvents = + error "poolGarbageCollectionEvents not available" } throwIO $ ProcessHasExited "Server has unexpectedly exited" res diff --git a/lib/jormungandr/test/integration/Main.hs b/lib/jormungandr/test/integration/Main.hs index 3dc9f0ce32c..f99943e7ec7 100644 --- a/lib/jormungandr/test/integration/Main.hs +++ b/lib/jormungandr/test/integration/Main.hs @@ -208,6 +208,8 @@ specWithServer tr = aroundAll withContext . after (tearDown . thd3) , _feeEstimator = mkFeeEstimator feePolicy , _networkParameters = np , _target = Proxy + , _poolGarbageCollectionEvents = error + "poolGarbageCollectionEvents not available." }) race (takeMVar ctx >>= action) diff --git a/lib/shelley/bench/Latency.hs b/lib/shelley/bench/Latency.hs index f6de69067c7..59d53a779ee 100644 --- a/lib/shelley/bench/Latency.hs +++ b/lib/shelley/bench/Latency.hs @@ -362,6 +362,8 @@ withShelleyServer tracers action = do , _feeEstimator = \_ -> error "feeEstimator not available" , _networkParameters = np , _target = Proxy + , _poolGarbageCollectionEvents = + error "poolGarbageCollectionEvents not available" } race_ (takeMVar ctx >>= action) (withServer setupContext) @@ -392,6 +394,7 @@ withShelleyServer tracers action = do tracers (SyncTolerance 10) (Just db) + Nothing "127.0.0.1" ListenOnRandomPort Nothing diff --git a/lib/shelley/exe/cardano-wallet.hs b/lib/shelley/exe/cardano-wallet.hs index ca232814568..664242c499f 100644 --- a/lib/shelley/exe/cardano-wallet.hs +++ b/lib/shelley/exe/cardano-wallet.hs @@ -227,6 +227,7 @@ cmdServe = command "serve" $ info (helper <*> helper' <*> cmd) $ mempty tracers sTolerance databaseDir + Nothing host listen tlsConfig diff --git a/lib/shelley/src/Cardano/Wallet/Shelley.hs b/lib/shelley/src/Cardano/Wallet/Shelley.hs index 91800eec941..36029d4406c 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley.hs @@ -145,6 +145,8 @@ import Control.Tracer ( Tracer (..), contramap, nullTracer, traceWith ) import Data.Function ( (&) ) +import Data.Maybe + ( fromMaybe ) import Data.Proxy ( Proxy (..) ) import Data.Text @@ -236,6 +238,8 @@ serveWallet -- ^ A time tolerance within we consider being synced -> Maybe FilePath -- ^ Database folder filepath + -> Maybe (Pool.DBDecorator IO) + -- ^ An optional decorator that can be used to monitor pool DB operations. -> HostPreference -- ^ Which host to bind. -> Listen @@ -264,6 +268,7 @@ serveWallet Tracers{..} sTolerance databaseDir + mPoolDatabaseDecorator hostPref listen tlsConfig @@ -279,6 +284,8 @@ serveWallet Left e -> handleApiServerStartupError e Right (_, socket) -> serveApp socket where + poolDatabaseDecorator = fromMaybe Pool.undecoratedDB mPoolDatabaseDecorator + serveApp socket = withIOManager $ \io -> do withNetworkLayer networkTracer np socketPath vData $ \nl -> do withWalletNtpClient io ntpClientTracer $ \ntpClient -> do @@ -342,7 +349,8 @@ serveWallet -> (StakePoolLayer -> IO a) -> IO a withPoolsMonitoring dir gp nl action = - Pool.withDBLayer + Pool.withDecoratedDBLayer + poolDatabaseDecorator poolsDbTracer (Pool.defaultFilePath <$> dir) (timeInterpreter nl) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index 0820741c901..e429af83d4c 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs @@ -95,7 +95,7 @@ import Control.Concurrent import Control.Exception ( try ) import Control.Monad - ( forM, forM_, forever, unless, void, when, (<=<) ) + ( forM, forM_, forever, void, when, (<=<) ) import Control.Monad.IO.Class ( liftIO ) import Control.Monad.Trans.Except diff --git a/lib/shelley/test/integration/Main.hs b/lib/shelley/test/integration/Main.hs index 0912724265d..a800598ee1d 100644 --- a/lib/shelley/test/integration/Main.hs +++ b/lib/shelley/test/integration/Main.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} @@ -72,8 +73,12 @@ import Control.Exception ( throwIO ) import Control.Monad ( forM_, void ) +import Control.Monad.IO.Class + ( liftIO ) import Control.Tracer ( Tracer (..), contramap, traceWith ) +import Data.IORef + ( IORef, atomicModifyIORef', newIORef ) import Data.Proxy ( Proxy (..) ) import Data.Text @@ -98,9 +103,10 @@ import Test.Hspec.Extra ( aroundAll ) import Test.Integration.Faucet ( genRewardAccounts, mirMnemonics, shelleyIntegrationTestFunds ) +import Test.Integration.Framework.Context + ( Context (..), PoolGarbageCollectionEvent (..) ) import Test.Integration.Framework.DSL - ( Context (..) - , Headers (..) + ( Headers (..) , KnownCommand (..) , Payload (..) , request @@ -108,6 +114,8 @@ import Test.Integration.Framework.DSL ) import qualified Cardano.Wallet.Api.Link as Link +import qualified Cardano.Pool.DB as Pool +import qualified Cardano.Pool.DB.Sqlite as Pool import qualified Data.Aeson as Aeson import qualified Data.Text as T import qualified Test.Integration.Scenario.API.Byron.Addresses as ByronAddresses @@ -185,6 +193,9 @@ specWithServer (tr, tracers) = aroundAll withContext . after tearDown withContext :: (Context Shelley -> IO ()) -> IO () withContext action = bracketTracer' tr "withContext" $ do ctx <- newEmptyMVar + poolGarbageCollectionEvents <- newIORef [] + let dbEventRecorder = + recordPoolGarbageCollectionEvents poolGarbageCollectionEvents let setupContext np wAddr = bracketTracer' tr "setupContext" $ do let baseUrl = "http://" <> T.pack (show wAddr) <> "/" traceWith tr $ MsgBaseUrl baseUrl @@ -194,6 +205,7 @@ specWithServer (tr, tracers) = aroundAll withContext . after tearDown responseTimeoutMicro fiveMinutes }) faucet <- initFaucet + putMVar ctx $ Context { _cleanup = pure () , _manager = manager @@ -202,13 +214,37 @@ specWithServer (tr, tracers) = aroundAll withContext . after tearDown , _feeEstimator = error "feeEstimator: unused in shelley specs" , _networkParameters = np , _target = Proxy + , _poolGarbageCollectionEvents = poolGarbageCollectionEvents } - let action' = bracketTracer' tr "spec" . action - race (takeMVar ctx >>= action') (withServer setupContext) >>= - either pure (throwIO . ProcessHasExited "integration") + race + (takeMVar ctx >>= action') + (withServer dbEventRecorder setupContext) >>= + (either pure (throwIO . ProcessHasExited "integration")) + + -- A decorator for the pool database that records all calls to the + -- 'removeRetiredPools' operation. + -- + -- The parameters and return value of each call are recorded by appending + -- a 'PoolGarbageCollectionEvent' value to the start of the given log. + -- + recordPoolGarbageCollectionEvents + :: IORef [PoolGarbageCollectionEvent] + -> Pool.DBDecorator IO + recordPoolGarbageCollectionEvents eventsRef = Pool.DBDecorator $ decorate + where + decorate Pool.DBLayer {..} = + Pool.DBLayer {removeRetiredPools = removeRetiredPoolsDecorated, ..} + where + removeRetiredPoolsDecorated epochNo = do + certificates <- removeRetiredPools epochNo + let event = PoolGarbageCollectionEvent epochNo certificates + liftIO $ do + traceWith tr $ MsgPoolGarbageCollectionEvent event + atomicModifyIORef' eventsRef ((, ()) . (event :)) + pure certificates - withServer action = bracketTracer' tr "withServer" $ do + withServer dbDecorator action = bracketTracer' tr "withServer" $ do minSev <- nodeMinSeverityFromEnv testPoolConfigs' <- poolConfigsFromEnv withSystemTempDir tr' "test" $ \dir -> @@ -219,7 +255,7 @@ specWithServer (tr, tracers) = aroundAll withContext . after tearDown dir onByron (afterFork dir) - (onClusterStart action dir) + (onClusterStart action dir dbDecorator) tr' = contramap MsgCluster tr onByron _ = pure () @@ -232,7 +268,8 @@ specWithServer (tr, tracers) = aroundAll withContext . after tearDown concatMap genRewardAccounts mirMnemonics moveInstantaneousRewardsTo stdoutTextTracer dir rewards - onClusterStart action dir (RunningNode socketPath block0 (gp, vData)) = do + onClusterStart + action dir dbDecorator (RunningNode socketPath block0 (gp, vData)) = do -- NOTE: We may want to keep a wallet running across the fork, but -- having three callbacks like this might not work well for that. withTempDir tr' dir "wallets" $ \db -> do @@ -241,6 +278,7 @@ specWithServer (tr, tracers) = aroundAll withContext . after tearDown tracers (SyncTolerance 10) (Just db) + (Just dbDecorator) "127.0.0.1" ListenOnRandomPort Nothing @@ -270,6 +308,7 @@ data TestsLog = MsgBracket Text BracketLog | MsgBaseUrl Text | MsgCluster ClusterLog + | MsgPoolGarbageCollectionEvent PoolGarbageCollectionEvent deriving (Show) instance ToText TestsLog where @@ -277,6 +316,17 @@ instance ToText TestsLog where MsgBracket name b -> name <> ": " <> toText b MsgBaseUrl txt -> txt MsgCluster msg -> toText msg + MsgPoolGarbageCollectionEvent e -> mconcat + [ "Intercepted pool garbage collection event for epoch " + , toText (poolGarbageCollectionEpochNo e) + , ". " + , case poolGarbageCollectionCertificates e of + [] -> "No pools were removed from the database." + ps -> mconcat + [ "The following pools were removed from the database: " + , T.unwords (T.pack . show <$> ps) + ] + ] instance HasPrivacyAnnotation TestsLog instance HasSeverityAnnotation TestsLog where @@ -284,6 +334,7 @@ instance HasSeverityAnnotation TestsLog where MsgBracket _ _ -> Debug MsgBaseUrl _ -> Notice MsgCluster msg -> getSeverityAnnotation msg + MsgPoolGarbageCollectionEvent _ -> Notice withTracers :: ((Tracer IO TestsLog, Tracers IO) -> IO a)