Merge pull request #1905 from IntersectMBO/kderme/fixes-rollback

Fix rollbacks

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

@@ -575,7 +575,7 @@ withFullConfig' WithConfigArgs {..} cmdLineArgs mSyncNodeConfig configFilePath t
         -- we dont fork dbsync here. Just prepare it as an action
         withDBSyncEnv (mkDBSyncEnv dbsyncParams syncNodeConfig partialDbSyncRun) $ \dbSyncEnv -> do
           let pgPass = getDBSyncPGPass dbSyncEnv
-          tableNames <- DB.getAllTablleNames pgPass
+          tableNames <- DB.getAllTableNames pgPass
           -- We only want to create the table schema once for the tests so here we check
           -- if there are any table names.
           if null tableNames || shouldDropDB

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

@@ -48,7 +48,7 @@ rollbackFromBlockNo syncEnv blkNo = do
         , textShow blkNo
         ]
     lift $ do
-      deletedBlockCount <- DB.deleteBlocksBlockId trce txOutTableType blockId epochNo (Just (DB.pcmConsumedTxOut $ getPruneConsume syncEnv))
+      deletedBlockCount <- DB.deleteBlocksBlockId trce txOutTableType blockId epochNo (DB.pcmConsumedTxOut $ getPruneConsume syncEnv)
       when (deletedBlockCount > 0) $ do
         -- We use custom constraints to improve input speeds when syncing.
         -- If they don't already exists we add them here as once a rollback has happened
@@ -111,4 +111,4 @@ prepareRollback syncEnv point serverTip =
 unsafeRollback :: Trace IO Text -> DB.TxOutTableType -> DB.PGConfig -> SlotNo -> IO (Either SyncNodeError ())
 unsafeRollback trce txOutTableType config slotNo = do
   logWarning trce $ "Starting a forced rollback to slot: " <> textShow (unSlotNo slotNo)
-  Right <$> DB.runDbNoLogging (DB.PGPassCached config) (void $ DB.deleteBlocksSlotNo trce txOutTableType slotNo Nothing)
+  Right <$> DB.runDbNoLogging (DB.PGPassCached config) (void $ DB.deleteBlocksSlotNo trce txOutTableType slotNo True)

cardano-db/src/Cardano/Db/Migration.hs

@@ -11,7 +11,7 @@ module Cardano.Db.Migration (
   getMigrationScripts,
   runMigrations,
   recreateDB,
-  getAllTablleNames,
+  getAllTableNames,
   truncateTables,
   dropTables,
   getMaintenancePsqlConf,
@@ -298,8 +298,8 @@ recreateDB pgpass = do
     rawExecute "drop schema if exists public cascade" []
     rawExecute "create schema public" []
 
-getAllTablleNames :: PGPassSource -> IO [Text]
-getAllTablleNames pgpass = do
+getAllTableNames :: PGPassSource -> IO [Text]
+getAllTableNames pgpass = do
   runWithConnectionNoLogging pgpass $ do
     fmap unSingle <$> rawSql "SELECT tablename FROM pg_catalog.pg_tables WHERE schemaname = current_schema()" []
 

cardano-db/src/Cardano/Db/Operations/Delete.hs

@@ -9,13 +9,13 @@
 {-# LANGUAGE TypeOperators #-}
 
 module Cardano.Db.Operations.Delete (
-  deleteBlocksSlotNo,
-  deleteBlocksSlotNoNoTrace,
   deleteDelistedPool,
   deleteBlocksBlockId,
+  queryDelete,
+  deleteBlocksSlotNo,
+  deleteBlocksSlotNoNoTrace,
   deleteBlocksForTests,
   deleteBlock,
-  queryDelete,
 ) where
 
 import Cardano.BM.Trace (Trace, logInfo, logWarning, nullTracer)
@@ -54,32 +54,25 @@ import Database.Persist (
  )
 import Database.Persist.Sql (Filter, SqlBackend, delete, deleteWhere, deleteWhereCount, selectKeysList)
 
-deleteBlocksSlotNoNoTrace :: MonadIO m => TxOutTableType -> SlotNo -> ReaderT SqlBackend m Bool
-deleteBlocksSlotNoNoTrace txOutTableType slotNo = deleteBlocksSlotNo nullTracer txOutTableType slotNo Nothing
-
 -- | Delete a block if it exists. Returns 'True' if it did exist and has been
 -- deleted and 'False' if it did not exist.
 deleteBlocksSlotNo ::
   MonadIO m =>
   Trace IO Text ->
   TxOutTableType ->
   SlotNo ->
-  Maybe Bool ->
+  Bool ->
   ReaderT SqlBackend m Bool
-deleteBlocksSlotNo trce txOutTableType (SlotNo slotNo) mIsConsumedTxOut = do
+deleteBlocksSlotNo trce txOutTableType (SlotNo slotNo) isConsumedTxOut = do
   mBlockId <- queryNearestBlockSlotNo slotNo
   case mBlockId of
     Nothing -> do
       liftIO $ logWarning trce $ "deleteBlocksSlotNo: No block contains the the slot: " <> pack (show slotNo)
       pure False
     Just (blockId, epochN) -> do
-      void $ deleteBlocksBlockId trce txOutTableType blockId epochN mIsConsumedTxOut
+      void $ deleteBlocksBlockId trce txOutTableType blockId epochN isConsumedTxOut
       pure True
 
-deleteBlocksForTests :: MonadIO m => TxOutTableType -> BlockId -> Word64 -> ReaderT SqlBackend m ()
-deleteBlocksForTests txOutTableType blockId epochN = do
-  void $ deleteBlocksBlockId nullTracer txOutTableType blockId epochN Nothing
-
 -- | Delete starting from a 'BlockId'.
 deleteBlocksBlockId ::
   MonadIO m =>
@@ -89,20 +82,19 @@ deleteBlocksBlockId ::
   -- | The 'EpochNo' of the block to delete.
   Word64 ->
   -- | Is ConsumeTxout
-  Maybe Bool ->
+  Bool ->
   ReaderT SqlBackend m Int64
-deleteBlocksBlockId trce txOutTableType blockId epochN mIsConsumedTxOut = do
+deleteBlocksBlockId trce txOutTableType blockId epochN isConsumedTxOut = do
   mMinIds <- fmap (textToMinIds txOutTableType =<<) <$> queryReverseIndexBlockId blockId
   (cminIds, completed) <- findMinIdsRec mMinIds mempty
   mTxId <- queryMinRefId TxBlockId blockId
   minIds <- if completed then pure cminIds else completeMinId mTxId cminIds
   deleteEpochLogs <- deleteUsingEpochNo epochN
   (deleteBlockCount, blockDeleteLogs) <- deleteTablesAfterBlockId txOutTableType blockId mTxId minIds
   setNullLogs <-
-    maybe
-      (pure ("ConsumedTxOut is not active so no Nulls set", 0))
-      (\_ -> querySetNullTxOut txOutTableType mTxId)
-      mIsConsumedTxOut
+    if isConsumedTxOut
+      then querySetNullTxOut txOutTableType mTxId
+      else pure ("ConsumedTxOut is not active so no Nulls set", 0)
   -- log all the deleted rows in the rollback
   liftIO $ logInfo trce $ mkRollbackSummary (deleteEpochLogs <> blockDeleteLogs) setNullLogs
   pure deleteBlockCount
@@ -357,17 +349,6 @@ deleteDelistedPool poolHash = do
   mapM_ delete keys
   pure $ not (null keys)
 
--- | Delete a block if it exists. Returns 'True' if it did exist and has been
--- deleted and 'False' if it did not exist.
-deleteBlock :: MonadIO m => TxOutTableType -> Block -> ReaderT SqlBackend m Bool
-deleteBlock txOutTableType block = do
-  mBlockId <- queryBlockHash block
-  case mBlockId of
-    Nothing -> pure False
-    Just (blockId, epochN) -> do
-      void $ deleteBlocksBlockId nullTracer txOutTableType blockId epochN Nothing
-      pure True
-
 mkRollbackSummary :: [(Text, Int64)] -> (Text, Int64) -> Text
 mkRollbackSummary logs setNullLogs =
   "\n----------------------- Rollback Summary: ----------------------- \n"
@@ -392,3 +373,25 @@ mkRollbackSummary logs setNullLogs =
         <> if nullCount == 0
           then nullMessage
           else "\n\nSet Null: " <> nullMessage <> " - Count: " <> pack (show nullCount)
+
+-- Tools
+
+deleteBlocksSlotNoNoTrace :: MonadIO m => TxOutTableType -> SlotNo -> ReaderT SqlBackend m Bool
+deleteBlocksSlotNoNoTrace txOutTableType slotNo = deleteBlocksSlotNo nullTracer txOutTableType slotNo True
+
+-- Tests
+
+deleteBlocksForTests :: MonadIO m => TxOutTableType -> BlockId -> Word64 -> ReaderT SqlBackend m ()
+deleteBlocksForTests txOutTableType blockId epochN = do
+  void $ deleteBlocksBlockId nullTracer txOutTableType blockId epochN False
+
+-- | Delete a block if it exists. Returns 'True' if it did exist and has been
+-- deleted and 'False' if it did not exist.
+deleteBlock :: MonadIO m => TxOutTableType -> Block -> ReaderT SqlBackend m Bool
+deleteBlock txOutTableType block = do
+  mBlockId <- queryBlockHash block
+  case mBlockId of
+    Nothing -> pure False
+    Just (blockId, epochN) -> do
+      void $ deleteBlocksBlockId nullTracer txOutTableType blockId epochN False
+      pure True