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.runDbMTransactionNoLogging (getDBSyncPGPass env)
 
 getPoolLayer :: DBSyncEnv -> IO PoolDataLayer
 getPoolLayer env = do

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.runDbMTransactionNoLogging 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

@@ -208,8 +208,8 @@ 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

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.runDbTransactionIohkNoLogging (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.runDbTransactionIohkNoLogging (envDbEnv syncEnv) DB.enableJsonbInSchema
 
 runRemoveJsonbFromSchema :: SyncEnv -> IO ()
 runRemoveJsonbFromSchema syncEnv =
-  void $ DB.runDbIohkNoLogging (envDbEnv syncEnv) DB.disableJsonbInSchema
+  void $ DB.runDbTransactionIohkNoLogging (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.runDbTransactionIohkNoLogging 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.runDbTransactionIohkNoLogging 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 $
@@ -309,7 +309,7 @@ mkSyncEnv ::
   RunMigration ->
   IO SyncEnv
 mkSyncEnv trce dbEnv syncOptions protoInfo nw nwMagic systemStart syncNodeConfigFromFile syncNP runNearTipMigrationFnc = do
-  dbCNamesVar <- newTVarIO =<< DB.runDbActionIO dbEnv DB.queryRewardAndEpochStakeConstraints
+  dbCNamesVar <- newTVarIO =<< DB.runDbTransactionIohkNoLogging dbEnv DB.queryRewardAndEpochStakeConstraints
   cache <-
     if soptCache syncOptions
       then
@@ -434,7 +434,7 @@ getLatestPoints env = do
       verifySnapshotPoint env snapshotPoints
     NoLedger _ -> do
       -- Brings the 5 latest.
-      lastPoints <- DB.runDbIohkNoLogging (envDbEnv env) DB.queryLatestPoints
+      lastPoints <- DB.runDbTransactionIohkNoLogging (envDbEnv env) DB.queryLatestPoints
       pure $ mapMaybe convert lastPoints
   where
     convert (Nothing, _) = Nothing
@@ -489,7 +489,7 @@ getBootstrapInProgress ::
   DB.DbEnv ->
   IO Bool
 getBootstrapInProgress trce bootstrapFlag dbEnv = do
-  DB.runDbIohkNoLogging dbEnv $ do
+  DB.runDbTransactionIohkNoLogging dbEnv $ do
     ems <- DB.queryAllExtraMigrations
     let btsState = DB.bootstrapState ems
     case (bootstrapFlag, btsState) of

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

@@ -16,10 +16,10 @@ import Cardano.Ledger.Core (Value)
 import Cardano.Ledger.Mary.Value
 import Cardano.Ledger.Shelley.LedgerState
 import Cardano.Ledger.TxIn
-import Cardano.Prelude (textShow, throwIO)
+import Cardano.Prelude (ExceptT, lift, textShow, throwIO)
 import Control.Concurrent.Class.MonadSTM.Strict (atomically, readTVarIO, writeTVar)
 import Control.Monad.Extra
-import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.IO.Class (liftIO)
 import Data.List.Extra
 import Data.Map (Map)
 import qualified Data.Map.Strict as Map
@@ -39,34 +39,33 @@ import Cardano.DbSync.Era.Shelley.Generic.Tx.Types (DBPlutusScript)
 import qualified Cardano.DbSync.Era.Shelley.Generic.Util as Generic
 import Cardano.DbSync.Era.Universal.Insert.Grouped
 import Cardano.DbSync.Era.Universal.Insert.Tx (insertTxOut)
+import Cardano.DbSync.Error (SyncNodeError)
 import Cardano.DbSync.Ledger.State
 import Cardano.DbSync.Types
 import Cardano.DbSync.Util (maxBulkSize)
 
 bootStrapMaybe ::
-  MonadIO m =>
   SyncEnv ->
-  DB.DbAction m ()
+  ExceptT SyncNodeError DB.DbM ()
 bootStrapMaybe syncEnv = do
   bts <- liftIO $ readTVarIO (envBootstrap syncEnv)
   when bts $ migrateBootstrapUTxO syncEnv
 
 migrateBootstrapUTxO ::
-  MonadIO m =>
   SyncEnv ->
-  DB.DbAction m ()
+  ExceptT SyncNodeError DB.DbM ()
 migrateBootstrapUTxO syncEnv = do
   case envLedgerEnv syncEnv of
     HasLedger lenv -> do
       liftIO $ logInfo trce "Starting UTxO bootstrap migration"
       cls <- liftIO $ readCurrentStateUnsafe lenv
-      count <- DB.deleteTxOut (getTxOutVariantType syncEnv)
+      count <- lift $ DB.deleteTxOut (getTxOutVariantType syncEnv)
       when (count > 0) $
         liftIO $
           logWarning trce $
             "Found and deleted " <> textShow count <> " tx_out."
       storeUTxOFromLedger syncEnv cls
-      DB.insertExtraMigration DB.BootstrapFinished
+      lift $ DB.insertExtraMigration DB.BootstrapFinished
       liftIO $ logInfo trce "UTxO bootstrap migration done"
       liftIO $ atomically $ writeTVar (envBootstrap syncEnv) False
     NoLedger _ ->
@@ -75,10 +74,9 @@ migrateBootstrapUTxO syncEnv = do
     trce = getTrace syncEnv
 
 storeUTxOFromLedger ::
-  MonadIO m =>
   SyncEnv ->
   ExtLedgerState CardanoBlock ->
-  DB.DbAction m ()
+  ExceptT SyncNodeError DB.DbM ()
 storeUTxOFromLedger env st = case ledgerState st of
   LedgerStateBabbage bts -> storeUTxO env (getUTxO bts)
   LedgerStateConway stc -> storeUTxO env (getUTxO stc)
@@ -93,13 +91,12 @@ storeUTxO ::
   , Script era ~ AlonzoScript era
   , TxOut era ~ BabbageTxOut era
   , BabbageEraTxOut era
-  , MonadIO m
   , DBPlutusScript era
   , NativeScript era ~ Timelock era
   ) =>
   SyncEnv ->
   Map TxIn (BabbageTxOut era) ->
-  DB.DbAction m ()
+  ExceptT SyncNodeError DB.DbM ()
 storeUTxO env mp = do
   liftIO $
     logInfo trce $
@@ -123,18 +120,17 @@ storePage ::
   , DBPlutusScript era
   , BabbageEraTxOut era
   , NativeScript era ~ Timelock era
-  , MonadIO m
   ) =>
   SyncEnv ->
   Float ->
   (Int, [(TxIn, BabbageTxOut era)]) ->
-  DB.DbAction m ()
+  ExceptT SyncNodeError DB.DbM ()
 storePage syncEnv percQuantum (n, ls) = do
   when (n `mod` 10 == 0) $ liftIO $ logInfo trce $ "Bootstrap in progress " <> prc <> "%"
   txOuts <- mapM (prepareTxOut syncEnv) ls
-  txOutIds <- DB.insertBulkTxOut False $ etoTxOut . fst <$> txOuts
+  txOutIds <- lift $ DB.insertBulkTxOut False $ etoTxOut . fst <$> txOuts
   let maTxOuts = concatMap (mkmaTxOuts txOutVariantType) $ zip txOutIds (snd <$> txOuts)
-  void $ DB.insertBulkMaTxOut maTxOuts
+  void . lift $ DB.insertBulkMaTxOut maTxOuts
   where
     txOutVariantType = getTxOutVariantType syncEnv
     trce = getTrace syncEnv
@@ -145,13 +141,12 @@ prepareTxOut ::
   , Script era ~ AlonzoScript era
   , TxOut era ~ BabbageTxOut era
   , BabbageEraTxOut era
-  , MonadIO m
   , DBPlutusScript era
   , NativeScript era ~ Timelock era
   ) =>
   SyncEnv ->
   (TxIn, BabbageTxOut era) ->
-  DB.DbAction m (ExtendedTxOut, [MissingMaTxOut])
+  ExceptT SyncNodeError DB.DbM (ExtendedTxOut, [MissingMaTxOut])
 prepareTxOut syncEnv (TxIn txIntxId (TxIx index), txOut) = do
   let txHashByteString = Generic.safeHashToByteString $ unTxId txIntxId
   let genTxOut = fromTxOut (fromIntegral index) txOut