change DbAction monad to not have ExceptT

Author: Cmdv

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

@@ -188,7 +188,6 @@ library
                       , memory
                       , microlens
                       , monad-control
-                      , monad-logger
                       , network-mux
                       , ouroboros-consensus
                       , ouroboros-consensus-cardano

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

@@ -145,19 +145,19 @@ runDbSync metricsSetters iomgr trce params syncNodeConfigFromFile abortOnPanic =
     void $ unsafeRollback trce (txOutConfigToTableType txOutConfig) pgConfig slotNo
 
   -- This runMigration is ONLY for delayed migrations during sync (like indexes)
-  let runIndexesMigration mode = do
+  let runNearTipMigration mode = do
         msg <- DB.getMaintenancePsqlConf pgConfig
-        logInfo trce $ "Running database migrations in mode " <> textShow mode
+        logInfo trce $ "Running NearTip database migrations in mode " <> textShow mode
         logInfo trce msg
-        when (mode `elem` [DB.Indexes, DB.Full]) $ logWarning trce indexesMsg
+        when (mode `elem` [DB.NearTip, DB.Full]) $ logWarning trce indexesMsg
         DB.runMigrations pgConfig True dbMigrationDir (Just $ DB.LogFileDir "/tmp") mode (txOutConfigToTableType txOutConfig)
 
   runSyncNode
     metricsSetters
     trce
     iomgr
     dbConnectionSetting
-    (void . runIndexesMigration)
+    (void . runNearTipMigration)
     syncNodeConfigFromFile
     params
     syncOpts
@@ -188,7 +188,7 @@ runSyncNode ::
   SyncNodeParams ->
   SyncOptions ->
   IO ()
-runSyncNode metricsSetters trce iomgr dbConnSetting runIndexesMigrationFnc syncNodeConfigFromFile syncNodeParams syncOptions = do
+runSyncNode metricsSetters trce iomgr dbConnSetting runNearTipMigrationFnc syncNodeConfigFromFile syncNodeParams syncOptions = do
   whenJust maybeLedgerDir $
     \enpLedgerStateDir -> do
       createDirectoryIfMissing True (unLedgerStateDir enpLedgerStateDir)
@@ -222,7 +222,7 @@ runSyncNode metricsSetters trce iomgr dbConnSetting runIndexesMigrationFnc syncN
                 genCfg
                 syncNodeConfigFromFile
                 syncNodeParams
-                runIndexesMigrationFnc
+                runNearTipMigrationFnc
 
           -- Warn the user that jsonb datatypes are being removed from the database schema.
           when (isJsonbInSchema && removeJsonbFromSchemaConfig) $ do

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

@@ -14,7 +14,7 @@ module Cardano.DbSync.Api (
   isConsistent,
   getDisableInOutState,
   getRanIndexes,
-  runIndexesMigrations,
+  runNearTipMigrations,
   initPruneConsumeMigration,
   runConsumedTxOutMigrationsMaybe,
   runAddJsonbToSchema,
@@ -46,6 +46,13 @@ module Cardano.DbSync.Api (
 )
 where
 
+import Cardano.BM.Trace (Trace, logInfo, logWarning)
+import qualified Cardano.Chain.Genesis as Byron
+import Cardano.Crypto.ProtocolMagic (ProtocolMagicId (..))
+import qualified Cardano.Ledger.BaseTypes as Ledger
+import qualified Cardano.Ledger.Shelley.Genesis as Shelley
+import Cardano.Prelude
+import Cardano.Slotting.Slot (EpochNo (..), SlotNo (..), WithOrigin (..))
 import Control.Concurrent.Class.MonadSTM.Strict (
   newTBQueueIO,
   newTVarIO,
@@ -55,14 +62,6 @@ import Control.Concurrent.Class.MonadSTM.Strict (
  )
 import Control.Monad.Trans.Maybe (MaybeT (..))
 import qualified Data.Strict.Maybe as Strict
-
-import Cardano.BM.Trace (Trace, logInfo, logWarning)
-import qualified Cardano.Chain.Genesis as Byron
-import Cardano.Crypto.ProtocolMagic (ProtocolMagicId (..))
-import qualified Cardano.Ledger.BaseTypes as Ledger
-import qualified Cardano.Ledger.Shelley.Genesis as Shelley
-import Cardano.Prelude
-import Cardano.Slotting.Slot (EpochNo (..), SlotNo (..), WithOrigin (..))
 import Ouroboros.Consensus.Block.Abstract (BlockProtocol, HeaderHash, Point (..), fromRawHash)
 import Ouroboros.Consensus.BlockchainTime.WallClock.Types (SystemStart (..))
 import Ouroboros.Consensus.Config (SecurityParam (..), TopLevelConfig, configSecurityParam)
@@ -120,12 +119,12 @@ getRanIndexes :: SyncEnv -> IO Bool
 getRanIndexes env = do
   readTVarIO $ envIndexes env
 
-runIndexesMigrations :: SyncEnv -> IO ()
-runIndexesMigrations env = do
+runNearTipMigrations :: SyncEnv -> IO ()
+runNearTipMigrations env = do
   haveRan <- readTVarIO $ envIndexes env
   unless haveRan $ do
-    envRunIndexesMigration env DB.Indexes
-    logInfo (getTrace env) "Indexes were created"
+    envRunNearTipMigration env DB.NearTip
+    logInfo (getTrace env) "NearTip migrations were ran successfully."
     atomically $ writeTVar (envIndexes env) True
 
 initPruneConsumeMigration :: Bool -> Bool -> Bool -> Bool -> DB.PruneConsumeMigration
@@ -297,53 +296,6 @@ getCurrentTipBlockNo env = do
     Just tip -> pure $ At (bBlockNo tip)
     Nothing -> pure Origin
 
-mkSyncEnvFromConfig ::
-  Trace IO Text ->
-  DB.DbEnv ->
-  SyncOptions ->
-  GenesisConfig ->
-  SyncNodeConfig ->
-  SyncNodeParams ->
-  -- | run migration function
-  RunMigration ->
-  IO (Either SyncNodeError SyncEnv)
-mkSyncEnvFromConfig trce dbEnv syncOptions genCfg syncNodeConfigFromFile syncNodeParams runIndexesMigrationFnc =
-  case genCfg of
-    GenesisCardano _ bCfg sCfg _ _
-      | unProtocolMagicId (Byron.configProtocolMagicId bCfg) /= Shelley.sgNetworkMagic (scConfig sCfg) ->
-          pure
-            . Left
-            . SNErrCardanoConfig
-            $ mconcat
-              [ "ProtocolMagicId "
-              , textShow (unProtocolMagicId $ Byron.configProtocolMagicId bCfg)
-              , " /= "
-              , textShow (Shelley.sgNetworkMagic $ scConfig sCfg)
-              ]
-      | Byron.gdStartTime (Byron.configGenesisData bCfg) /= Shelley.sgSystemStart (scConfig sCfg) ->
-          pure
-            . Left
-            . SNErrCardanoConfig
-            $ mconcat
-              [ "SystemStart "
-              , textShow (Byron.gdStartTime $ Byron.configGenesisData bCfg)
-              , " /= "
-              , textShow (Shelley.sgSystemStart $ scConfig sCfg)
-              ]
-      | otherwise ->
-          Right
-            <$> mkSyncEnv
-              trce
-              dbEnv
-              syncOptions
-              (fst $ mkProtocolInfoCardano genCfg [])
-              (Shelley.sgNetworkId $ scConfig sCfg)
-              (NetworkMagic . unProtocolMagicId $ Byron.configProtocolMagicId bCfg)
-              (SystemStart . Byron.gdStartTime $ Byron.configGenesisData bCfg)
-              syncNodeConfigFromFile
-              syncNodeParams
-              runIndexesMigrationFnc
-
 mkSyncEnv ::
   Trace IO Text ->
   DB.DbEnv ->
@@ -356,7 +308,7 @@ mkSyncEnv ::
   SyncNodeParams ->
   RunMigration ->
   IO SyncEnv
-mkSyncEnv trce dbEnv syncOptions protoInfo nw nwMagic systemStart syncNodeConfigFromFile syncNP runIndexesMigrationFnc = do
+mkSyncEnv trce dbEnv syncOptions protoInfo nw nwMagic systemStart syncNodeConfigFromFile syncNP runNearTipMigrationFnc = do
   dbCNamesVar <- newTVarIO =<< DB.runDbActionIO dbEnv DB.queryRewardAndEpochStakeConstraints
   cache <-
     if soptCache syncOptions
@@ -418,14 +370,61 @@ mkSyncEnv trce dbEnv syncOptions protoInfo nw nwMagic systemStart syncNodeConfig
       , envOffChainVoteResultQueue = oarq
       , envOffChainVoteWorkQueue = oawq
       , envOptions = syncOptions
-      , envRunIndexesMigration = runIndexesMigrationFnc
+      , envRunNearTipMigration = runNearTipMigrationFnc
       , envSyncNodeConfig = syncNodeConfigFromFile
       , envSystemStart = systemStart
       }
   where
     hasLedger' = hasLedger . sioLedger . dncInsertOptions
     isTxOutConsumedBootstrap' = isTxOutConsumedBootstrap . sioTxOut . dncInsertOptions
 
+mkSyncEnvFromConfig ::
+  Trace IO Text ->
+  DB.DbEnv ->
+  SyncOptions ->
+  GenesisConfig ->
+  SyncNodeConfig ->
+  SyncNodeParams ->
+  -- | run migration function
+  RunMigration ->
+  IO (Either SyncNodeError SyncEnv)
+mkSyncEnvFromConfig trce dbEnv syncOptions genCfg syncNodeConfigFromFile syncNodeParams runNearTipMigrationFnc =
+  case genCfg of
+    GenesisCardano _ bCfg sCfg _ _
+      | unProtocolMagicId (Byron.configProtocolMagicId bCfg) /= Shelley.sgNetworkMagic (scConfig sCfg) ->
+          pure
+            . Left
+            . SNErrCardanoConfig
+            $ mconcat
+              [ "ProtocolMagicId "
+              , textShow (unProtocolMagicId $ Byron.configProtocolMagicId bCfg)
+              , " /= "
+              , textShow (Shelley.sgNetworkMagic $ scConfig sCfg)
+              ]
+      | Byron.gdStartTime (Byron.configGenesisData bCfg) /= Shelley.sgSystemStart (scConfig sCfg) ->
+          pure
+            . Left
+            . SNErrCardanoConfig
+            $ mconcat
+              [ "SystemStart "
+              , textShow (Byron.gdStartTime $ Byron.configGenesisData bCfg)
+              , " /= "
+              , textShow (Shelley.sgSystemStart $ scConfig sCfg)
+              ]
+      | otherwise ->
+          Right
+            <$> mkSyncEnv
+              trce
+              dbEnv
+              syncOptions
+              (fst $ mkProtocolInfoCardano genCfg [])
+              (Shelley.sgNetworkId $ scConfig sCfg)
+              (NetworkMagic . unProtocolMagicId $ Byron.configProtocolMagicId bCfg)
+              (SystemStart . Byron.gdStartTime $ Byron.configGenesisData bCfg)
+              syncNodeConfigFromFile
+              syncNodeParams
+              runNearTipMigrationFnc
+
 -- | 'True' is for in memory points and 'False' for on disk
 getLatestPoints :: SyncEnv -> IO [(CardanoPoint, Bool)]
 getLatestPoints env = do

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

@@ -6,16 +6,6 @@
 
 module Cardano.DbSync.Api.Ledger where
 
-import Control.Concurrent.Class.MonadSTM.Strict (atomically, readTVarIO, writeTVar)
-import Control.Monad.Extra
-import Control.Monad.IO.Class (MonadIO, liftIO)
-import Data.List.Extra
-import Data.Map (Map)
-import qualified Data.Map.Strict as Map
-import qualified Data.Text as Text
-import Lens.Micro
-import Numeric
-
 import Cardano.BM.Trace (logError, logInfo, logWarning)
 import Cardano.Ledger.Allegra.Scripts (Timelock)
 import Cardano.Ledger.Alonzo.Scripts
@@ -26,7 +16,16 @@ import Cardano.Ledger.Core (Value)
 import Cardano.Ledger.Mary.Value
 import Cardano.Ledger.Shelley.LedgerState
 import Cardano.Ledger.TxIn
-import Cardano.Prelude (MonadError (..), textShow)
+import Cardano.Prelude (textShow, throwIO)
+import Control.Concurrent.Class.MonadSTM.Strict (atomically, readTVarIO, writeTVar)
+import Control.Monad.Extra
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Data.List.Extra
+import Data.Map (Map)
+import qualified Data.Map.Strict as Map
+import qualified Data.Text as Text
+import Lens.Micro
+import Numeric
 import Ouroboros.Consensus.Cardano.Block hiding (CardanoBlock)
 import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState, ledgerState)
 import qualified Ouroboros.Consensus.Shelley.Ledger.Ledger as Consensus
@@ -158,7 +157,7 @@ prepareTxOut syncEnv (TxIn txIntxId (TxIx index), txOut) = do
   let genTxOut = fromTxOut (fromIntegral index) txOut
   eTxId <- queryTxIdWithCache syncEnv txIntxId
   txId <- case eTxId of
-    Left err -> throwError err
+    Left err -> liftIO $ throwIO err
     Right tid -> pure tid
   insertTxOut syncEnv iopts (txId, txHashByteString) genTxOut
   where

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

@@ -16,6 +16,8 @@ module Cardano.DbSync.Api.Types (
   formatUnicodeNullSource,
 ) where
 
+import Cardano.Prelude (Bool, Eq, IO, Ord, Show, Text, Word64)
+import Cardano.Slotting.Slot (EpochNo (..))
 import Control.Concurrent.Class.MonadSTM.Strict (StrictTVar)
 import Control.Concurrent.Class.MonadSTM.Strict.TBQueue (StrictTBQueue)
 import qualified Data.Map.Strict as Map
@@ -24,9 +26,6 @@ import Data.Time.Clock (UTCTime)
 import Ouroboros.Consensus.BlockchainTime.WallClock.Types (SystemStart (..))
 import Ouroboros.Network.Magic (NetworkMagic (..))
 
-import Cardano.Prelude (Bool, Eq, IO, Ord, Show, Text, Word64)
-import Cardano.Slotting.Slot (EpochNo (..))
-
 import qualified Cardano.Db as DB
 import Cardano.DbSync.Cache.Types (CacheStatistics, CacheStatus)
 import Cardano.DbSync.Config.Types (SyncNodeConfig)
@@ -57,7 +56,7 @@ data SyncEnv = SyncEnv
   , envOffChainVoteWorkQueue :: !(StrictTBQueue IO OffChainVoteWorkQueue)
   , envOptions :: !SyncOptions
   , envSyncNodeConfig :: !SyncNodeConfig
-  , envRunIndexesMigration :: RunMigration
+  , envRunNearTipMigration :: RunMigration
   , envSystemStart :: !SystemStart
   }