convert DB.DbAction to DB.DbM

Author: Cmdv

cardano-chain-gen/cardano-chain-gen.cabal

@@ -192,7 +192,6 @@ test-suite cardano-chain-gen
                       , transformers-except
                       , tree-diff
                       , tasty-hunit
-                      , monad-logger
                       , ouroboros-consensus
                       , ouroboros-consensus-cardano
                       , ouroboros-network-api

cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs

@@ -74,7 +74,6 @@ import Control.Concurrent.STM.TMVar (
 import Control.Exception (SomeException, bracket)
 import Control.Monad (void)
 import Control.Monad.Extra (eitherM)
-import Control.Monad.Logger (NoLoggingT)
 import Control.Monad.Trans.Except.Extra (runExceptT)
 import Control.Tracer (nullTracer)
 import Data.Text (Text)
@@ -230,9 +229,9 @@ withDBSyncEnv mkEnv = bracket mkEnv stopDBSyncIfRunning
 getDBSyncPGPass :: DBSyncEnv -> DB.PGPassSource
 getDBSyncPGPass = enpPGPassSource . dbSyncParams
 
-queryDBSync :: DBSyncEnv -> DB.DbAction (NoLoggingT IO) a -> IO a
+queryDBSync :: DBSyncEnv -> DB.DbM a -> IO a
 queryDBSync env = do
-  DB.runWithConnectionNoLogging (getDBSyncPGPass env)
+  DB.runDbStandaloneTransSilent (getDBSyncPGPass env)
 
 getPoolLayer :: DBSyncEnv -> IO PoolDataLayer
 getPoolLayer env = do
@@ -385,6 +384,8 @@ emptyMetricsSetters =
     , metricsSetDbQueueLength = \_ -> pure ()
     , metricsSetDbBlockHeight = \_ -> pure ()
     , metricsSetDbSlotHeight = \_ -> pure ()
+    , metricsSetDbEpochSyncDuration = \_ -> pure ()
+    , metricsSetDbEpochSyncNumber = \_ -> pure ()
     }
 
 withFullConfig ::

cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Config.hs

@@ -34,6 +34,7 @@ insertConfig = do
           , sioPoolStats = PoolStatsConfig False
           , sioJsonType = JsonTypeDisable
           , sioRemoveJsonbFromSchema = RemoveJsonbFromSchemaConfig False
+          , sioStopAtBlock = Nothing
           }
 
   dncInsertOptions cfg @?= expected

cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Config/Parse.hs

@@ -104,6 +104,7 @@ insertConfig = do
           , sioPoolStats = PoolStatsConfig False
           , sioJsonType = JsonTypeDisable
           , sioRemoveJsonbFromSchema = RemoveJsonbFromSchemaConfig False
+          , sioStopAtBlock = Nothing
           }
 
   dncInsertOptions cfg @?= expected

cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Config/Schema.hs

@@ -79,7 +79,7 @@ validateSchemaColumns =
     validateCall dbSync (Proxy @DB.MultiAsset)
     validateCall dbSync (Proxy @DB.MaTxMint)
 
-    -- Cardano.Db.Schema.Core.StakeDeligation
+    -- Cardano.Db.Schema.Core.StakeDelegation
     validateCall dbSync (Proxy @DB.StakeAddress)
     validateCall dbSync (Proxy @DB.StakeRegistration)
     validateCall dbSync (Proxy @DB.StakeDeregistration)

cardano-chain-gen/test/Test/Cardano/Db/Mock/Validate.hs

@@ -46,7 +46,6 @@ module Test.Cardano.Db.Mock.Validate (
 import Control.Concurrent
 import Control.Exception
 import Control.Monad (forM_)
-import Control.Monad.Logger (NoLoggingT)
 import Data.Bifunctor (first)
 import Data.ByteString (ByteString)
 import Data.Either (isRight)
@@ -69,7 +68,6 @@ import qualified Cardano.Ledger.Core as Core
 import Cardano.Ledger.Shelley.LedgerState (EraCertState)
 import Cardano.Mock.Forging.Tx.Generic
 import Cardano.Mock.Forging.Types
-import Cardano.Prelude (MonadIO)
 import Cardano.SMASH.Server.PoolDataLayer
 import Cardano.SMASH.Server.Types
 import Test.Cardano.Db.Mock.Config
@@ -129,16 +127,16 @@ assertUnspentTx dbSyncEnv = do
 defaultDelays :: [Int]
 defaultDelays = [1, 2, 4, 8, 16, 32, 64, 128, 256]
 
-assertEqQuery :: (Eq a, Show a) => DBSyncEnv -> DB.DbAction (NoLoggingT IO) a -> a -> String -> IO ()
+assertEqQuery :: (Eq a, Show a) => DBSyncEnv -> DB.DbM a -> a -> String -> IO ()
 assertEqQuery env query a msg = do
   assertEqBackoff env query a defaultDelays msg
 
-assertEqBackoff :: (Eq a, Show a) => DBSyncEnv -> DB.DbAction (NoLoggingT IO) a -> a -> [Int] -> String -> IO ()
+assertEqBackoff :: (Eq a, Show a) => DBSyncEnv -> DB.DbM a -> a -> [Int] -> String -> IO ()
 assertEqBackoff env query a delays msg = do
   checkStillRuns env
   assertBackoff env query delays (== a) (\a' -> msg <> ": got " <> show a' <> " expected " <> show a)
 
-assertBackoff :: DBSyncEnv -> DB.DbAction (NoLoggingT IO) a -> [Int] -> (a -> Bool) -> (a -> String) -> IO ()
+assertBackoff :: DBSyncEnv -> DB.DbM a -> [Int] -> (a -> Bool) -> (a -> String) -> IO ()
 assertBackoff env query delays check errMsg = go delays
   where
     go ds = do
@@ -150,7 +148,7 @@ assertBackoff env query delays check errMsg = go delays
           threadDelay $ dl * 100_000
           go rest
 
-assertQuery :: DBSyncEnv -> DB.DbAction (NoLoggingT IO) a -> (a -> Bool) -> (a -> String) -> IO (Maybe String)
+assertQuery :: DBSyncEnv -> DB.DbM a -> (a -> Bool) -> (a -> String) -> IO (Maybe String)
 assertQuery env query check errMsg = do
   ma <- try @DB.DbError $ queryDBSync env query
   case ma of
@@ -161,7 +159,7 @@ assertQuery env query check errMsg = do
     Right a | not (check a) -> pure $ Just $ errMsg a
     _ -> pure Nothing
 
-runQuery :: DBSyncEnv -> DB.DbAction (NoLoggingT IO) a -> IO a
+runQuery :: DBSyncEnv -> DB.DbM a -> IO a
 runQuery env query = do
   ma <- try @DB.DbError $ queryDBSync env query
   case ma of
@@ -371,7 +369,7 @@ assertPoolCounters :: DBSyncEnv -> (Word64, Word64, Word64, Word64, Word64, Word
 assertPoolCounters env expected =
   assertEqBackoff env poolCountersQuery expected defaultDelays "Unexpected Pool counts"
 
-poolCountersQuery :: MonadIO m => DB.DbAction m (Word64, Word64, Word64, Word64, Word64, Word64)
+poolCountersQuery :: DB.DbM (Word64, Word64, Word64, Word64, Word64, Word64)
 poolCountersQuery = do
   poolHash <- DB.queryPoolHashCount
   poolMetadataRef <- DB.queryPoolMetadataRefCount

cardano-db-sync/app/test-http-get-json-metadata.hs

@@ -16,7 +16,6 @@ import Cardano.DbSync.Types (
   OffChainUrlType (..),
  )
 import Control.Monad (foldM)
-import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.Trans.Except.Extra (runExceptT)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.List as List
@@ -32,7 +31,7 @@ import Network.HTTP.Client.TLS (tlsManagerSettings)
 main :: IO ()
 main = do
   manager <- Http.newManager tlsManagerSettings
-  xs <- DB.runDbNoLoggingEnv queryTestOffChainData
+  xs <- DB.runDbStandaloneTransSilent DB.PGPassDefaultEnv queryTestOffChainData
   putStrLn $ "testOffChainPoolDataFetch: " ++ show (length xs) ++ " tests to run."
   tfs <- foldM (testOne manager) emptyTestFailure xs
   reportTestFailures tfs
@@ -74,7 +73,7 @@ data TestFailure = TestFailure
   , tfOtherError :: !Word
   }
 
-queryTestOffChainData :: MonadIO m => DB.DbAction m [TestOffChain]
+queryTestOffChainData :: DB.DbM [TestOffChain]
 queryTestOffChainData = do
   res <- DB.queryTestOffChainData
   pure . organise $ map convert res

cardano-db-sync/cardano-db-sync.cabal

@@ -187,7 +187,7 @@ library
                       , lifted-base
                       , memory
                       , microlens
-                      , monad-control
+                      -- , monad-control
                       , network-mux
                       , ouroboros-consensus
                       , ouroboros-consensus-cardano
@@ -215,6 +215,7 @@ library
                       , transformers
                       , transformers-except
                       , typed-protocols
+                      , unliftio-core
                       , vector
                       , wide-word
                       , yaml

cardano-db-sync/src/Cardano/DbSync.hs

@@ -55,7 +55,7 @@ import Cardano.DbSync.Era
 import Cardano.DbSync.Error
 import Cardano.DbSync.Ledger.State
 import Cardano.DbSync.OffChain (runFetchOffChainPoolThread, runFetchOffChainVoteThread)
-import Cardano.DbSync.Rollback (unsafeRollback)
+import Cardano.DbSync.Rollback (handlePostRollbackSnapshots, unsafeRollback)
 import Cardano.DbSync.Sync (runSyncNodeClient)
 import Cardano.DbSync.Tracing.ToObjectOrphans ()
 import Cardano.DbSync.Types
@@ -98,7 +98,7 @@ runMigrationsOnly knownMigrations trce params syncNodeConfigFromFile = do
         msg <- DB.getMaintenancePsqlConf pgConfig
         logInfo trce $ "Running database migrations in mode " <> textShow mode
         logInfo trce msg
-        DB.runMigrations pgConfig True dbMigrationDir (Just $ DB.LogFileDir "/tmp") mode (txOutConfigToTableType txOutConfig)
+        DB.runMigrations (Just trce) pgConfig True dbMigrationDir (Just $ DB.LogFileDir "/tmp") mode (txOutConfigToTableType txOutConfig)
 
   -- Always run Initial mode only - never indexes
   (ranMigrations, unofficial) <- runMigration DB.Initial
@@ -150,7 +150,7 @@ runDbSync metricsSetters iomgr trce params syncNodeConfigFromFile abortOnPanic =
         logInfo trce $ "Running NearTip database migrations in mode " <> textShow mode
         logInfo trce msg
         when (mode `elem` [DB.NearTip, DB.Full]) $ logWarning trce indexesMsg
-        DB.runMigrations pgConfig True dbMigrationDir (Just $ DB.LogFileDir "/tmp") mode (txOutConfigToTableType txOutConfig)
+        DB.runMigrations (Just trce) pgConfig True dbMigrationDir (Just $ DB.LogFileDir "/tmp") mode (txOutConfigToTableType txOutConfig)
 
   runSyncNode
     metricsSetters
@@ -199,7 +199,7 @@ runSyncNode metricsSetters trce iomgr dbConnSetting runNearTipMigrationFnc syncN
   let useLedger = shouldUseLedger (sioLedger $ dncInsertOptions syncNodeConfigFromFile)
   -- The main thread
   bracket
-    (acquireDbConnection [dbConnSetting])
+    (DB.acquireConnection [dbConnSetting])
     HsqlC.release
     ( \dbConn -> do
         runOrThrowIO $ runExceptT $ do
@@ -208,14 +208,15 @@ runSyncNode metricsSetters trce iomgr dbConnSetting runNearTipMigrationFnc syncN
           pool <- liftIO $ DB.createHasqlConnectionPool [dbConnSetting] 4 -- 4 connections for reasonable parallelism
           let dbEnv =
                 if isLogingEnabled
-                  then DB.createDbEnv dbConn pool (Just trce)
-                  else DB.createDbEnv dbConn pool Nothing
+                  then DB.createDbEnv dbConn (Just pool) (Just trce)
+                  else DB.createDbEnv dbConn (Just pool) Nothing
           genCfg <- readCardanoGenesisConfig syncNodeConfigFromFile
           isJsonbInSchema <- liftDbError $ DB.queryJsonbInSchemaExists dbConn
           logProtocolMagicId trce $ genesisProtocolMagicId genCfg
           syncEnv <-
             ExceptT $
               mkSyncEnvFromConfig
+                metricsSetters
                 trce
                 dbEnv
                 syncOptions
@@ -239,12 +240,15 @@ runSyncNode metricsSetters trce iomgr dbConnSetting runNearTipMigrationFnc syncN
             DB.noLedgerMigrations dbEnv trce
           insertValidateGenesisDist syncEnv (dncNetworkName syncNodeConfigFromFile) genCfg (useShelleyInit syncNodeConfigFromFile)
 
+          -- Handle ledger snapshots after rollback to ensure consistency
+          liftIO $ handlePostRollbackSnapshots syncEnv (enpMaybeRollback syncNodeParams)
+
           -- communication channel between datalayer thread and chainsync-client thread
           threadChannels <- liftIO newThreadChannels
           liftIO $
             race_
               -- We split the main thread into two parts to allow for graceful shutdown of the main App db thread.
-              (runDbThread syncEnv metricsSetters threadChannels)
+              (runDbThread syncEnv threadChannels)
               ( mapConcurrently_
                   id
                   [ runSyncNodeClient metricsSetters syncEnv iomgr trce threadChannels (enpSocketPath syncNodeParams)

cardano-db-sync/src/Cardano/DbSync/Api.hs

@@ -143,7 +143,7 @@ runConsumedTxOutMigrationsMaybe syncEnv = do
   let pcm = getPruneConsume syncEnv
       txOutVariantType = getTxOutVariantType syncEnv
   logInfo (getTrace syncEnv) $ "runConsumedTxOutMigrationsMaybe: " <> textShow pcm
-  DB.runDbIohkNoLogging (envDbEnv syncEnv) $
+  DB.runDbDirectSilent (envDbEnv syncEnv) $
     DB.runConsumedTxOutMigrations
       (getTrace syncEnv)
       maxBulkSize
@@ -153,11 +153,11 @@ runConsumedTxOutMigrationsMaybe syncEnv = do
 
 runAddJsonbToSchema :: SyncEnv -> IO ()
 runAddJsonbToSchema syncEnv =
-  void $ DB.runDbIohkNoLogging (envDbEnv syncEnv) DB.enableJsonbInSchema
+  void $ DB.runDbDirectSilent (envDbEnv syncEnv) DB.enableJsonbInSchema
 
 runRemoveJsonbFromSchema :: SyncEnv -> IO ()
 runRemoveJsonbFromSchema syncEnv =
-  void $ DB.runDbIohkNoLogging (envDbEnv syncEnv) DB.disableJsonbInSchema
+  void $ DB.runDbDirectSilent (envDbEnv syncEnv) DB.disableJsonbInSchema
 
 getSafeBlockNoDiff :: SyncEnv -> Word64
 getSafeBlockNoDiff syncEnv = 2 * getSecurityParam syncEnv
@@ -243,7 +243,7 @@ getInsertOptions :: SyncEnv -> InsertOptions
 getInsertOptions = soptInsertOptions . envOptions
 
 getSlotHash :: DB.DbEnv -> SlotNo -> IO [(SlotNo, ByteString)]
-getSlotHash backend = DB.runDbIohkNoLogging backend . DB.querySlotHash
+getSlotHash backend = DB.runDbDirectSilent backend . DB.querySlotHash
 
 hasLedgerState :: SyncEnv -> Bool
 hasLedgerState syncEnv =
@@ -254,7 +254,7 @@ hasLedgerState syncEnv =
 getDbLatestBlockInfo :: DB.DbEnv -> IO (Maybe TipInfo)
 getDbLatestBlockInfo dbEnv = do
   runMaybeT $ do
-    block <- MaybeT $ DB.runDbIohkNoLogging dbEnv DB.queryLatestBlock
+    block <- MaybeT $ DB.runDbDirectSilent dbEnv DB.queryLatestBlock
     -- The EpochNo, SlotNo and BlockNo can only be zero for the Byron
     -- era, but we need to make the types match, hence `fromMaybe`.
     pure $
@@ -297,6 +297,7 @@ getCurrentTipBlockNo env = do
     Nothing -> pure Origin
 
 mkSyncEnv ::
+  MetricSetters ->
   Trace IO Text ->
   DB.DbEnv ->
   SyncOptions ->
@@ -308,18 +309,20 @@ mkSyncEnv ::
   SyncNodeParams ->
   RunMigration ->
   IO SyncEnv
-mkSyncEnv trce dbEnv syncOptions protoInfo nw nwMagic systemStart syncNodeConfigFromFile syncNP runNearTipMigrationFnc = do
-  dbCNamesVar <- newTVarIO =<< DB.runDbActionIO dbEnv DB.queryRewardAndEpochStakeConstraints
+mkSyncEnv metricSetters trce dbEnv syncOptions protoInfo nw nwMagic systemStart syncNodeConfigFromFile syncNP runNearTipMigrationFnc = do
+  dbCNamesVar <- newTVarIO =<< DB.runDbDirectSilent dbEnv DB.queryRewardAndEpochStakeConstraints
   cache <-
     if soptCache syncOptions
       then
         newEmptyCache
           CacheCapacity
-            { cacheCapacityAddress = 100000
-            , cacheCapacityStake = 100000
-            , cacheCapacityDatum = 250000
-            , cacheCapacityMultiAsset = 250000
-            , cacheCapacityTx = 100000
+            { cacheCapacityAddress = 50000
+            , cacheCapacityStake = 50000
+            , cacheCapacityDatum = 125000
+            , cacheCapacityMultiAsset = 125000
+            , cacheCapacityTx = 50000
+            , cacheOptimisePools = 50000
+            , cacheOptimiseStake = 50000
             }
       else pure useNoCache
   consistentLevelVar <- newTVarIO Unchecked
@@ -356,6 +359,7 @@ mkSyncEnv trce dbEnv syncOptions protoInfo nw nwMagic systemStart syncNodeConfig
   pure $
     SyncEnv
       { envDbEnv = dbEnv
+      , envMetricSetters = metricSetters
       , envBootstrap = bootstrapVar
       , envCache = cache
       , envEpochStatistics = epochStatistics
@@ -379,6 +383,7 @@ mkSyncEnv trce dbEnv syncOptions protoInfo nw nwMagic systemStart syncNodeConfig
     isTxOutConsumedBootstrap' = isTxOutConsumedBootstrap . sioTxOut . dncInsertOptions
 
 mkSyncEnvFromConfig ::
+  MetricSetters ->
   Trace IO Text ->
   DB.DbEnv ->
   SyncOptions ->
@@ -388,7 +393,7 @@ mkSyncEnvFromConfig ::
   -- | run migration function
   RunMigration ->
   IO (Either SyncNodeError SyncEnv)
-mkSyncEnvFromConfig trce dbEnv syncOptions genCfg syncNodeConfigFromFile syncNodeParams runNearTipMigrationFnc =
+mkSyncEnvFromConfig metricsSetters trce dbEnv syncOptions genCfg syncNodeConfigFromFile syncNodeParams runNearTipMigrationFnc =
   case genCfg of
     GenesisCardano _ bCfg sCfg _ _
       | unProtocolMagicId (Byron.configProtocolMagicId bCfg) /= Shelley.sgNetworkMagic (scConfig sCfg) ->
@@ -414,6 +419,7 @@ mkSyncEnvFromConfig trce dbEnv syncOptions genCfg syncNodeConfigFromFile syncNod
       | otherwise ->
           Right
             <$> mkSyncEnv
+              metricsSetters
               trce
               dbEnv
               syncOptions
@@ -434,7 +440,7 @@ getLatestPoints env = do
       verifySnapshotPoint env snapshotPoints
     NoLedger _ -> do
       -- Brings the 5 latest.
-      lastPoints <- DB.runDbIohkNoLogging (envDbEnv env) DB.queryLatestPoints
+      lastPoints <- DB.runDbDirectSilent (envDbEnv env) DB.queryLatestPoints
       pure $ mapMaybe convert lastPoints
   where
     convert (Nothing, _) = Nothing
@@ -489,7 +495,7 @@ getBootstrapInProgress ::
   DB.DbEnv ->
   IO Bool
 getBootstrapInProgress trce bootstrapFlag dbEnv = do
-  DB.runDbIohkNoLogging dbEnv $ do
+  DB.runDbDirectSilent dbEnv $ do
     ems <- DB.queryAllExtraMigrations
     let btsState = DB.bootstrapState ems
     case (bootstrapFlag, btsState) of