Make it possible to decorate the pool DB layer.

This is useful for instrumenting or monitoring calls to pool database
operations.

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,49 @@ 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.
+newtype DBDecorator a =
+    DBDecorator { decorateDBLayer :: DBLayer a -> DBLayer a }
+
+-- | The identity decorator.
+--
+-- Equivalent to an undecorated database.
+--
+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/shelley/bench/Latency.hs

@@ -393,6 +393,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/test/integration/Main.hs

@@ -237,6 +237,7 @@ specWithServer (tr, tracers) = aroundAll withContext . after tearDown
                 tracers
                 (SyncTolerance 10)
                 (Just db)
+                Nothing
                 "127.0.0.1"
                 ListenOnRandomPort
                 Nothing