Monitor pool DB garbage collection events from integration tests.

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

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

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

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)

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

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

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)

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

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,16 +103,19 @@ 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
     , unsafeRequest
     )
 
 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,20 +308,33 @@ data TestsLog
     = MsgBracket Text BracketLog
     | MsgBaseUrl Text
     | MsgCluster ClusterLog
+    | MsgPoolGarbageCollectionEvent PoolGarbageCollectionEvent
     deriving (Show)
 
 instance ToText TestsLog where
     toText = \case
         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
     getSeverityAnnotation = \case
         MsgBracket _ _ -> Debug
         MsgBaseUrl _ -> Notice
         MsgCluster msg -> getSeverityAnnotation msg
+        MsgPoolGarbageCollectionEvent _ -> Notice
 
 withTracers
     :: ((Tracer IO TestsLog, Tracers IO) -> IO a)