Fourmolise

IntersectMBO · May 30, 2023 · eeff068 · eeff068
1 parent 192c2ad
commit eeff068
Show file tree

Hide file tree

Showing 9 changed files with 183 additions and 166 deletions.
diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo.hs
@@ -74,9 +74,9 @@ unitTests iom knownMigrations =
         , test "Mir Cert" mirReward
         , test "Mir rollback" mirRewardRollback
         , test "Mir Cert deregistration" mirRewardDereg
-        -- , test "test rewards empty last part of epoch" rewardsEmptyChainLast
-         --        , test "test delta rewards" rewardsDelta -- See the same test on Babbage for the reason it was disabled.
-        ,  test "rollback on epoch boundary" rollbackBoundary
+        , -- , test "test rewards empty last part of epoch" rewardsEmptyChainLast
+          --        , test "test delta rewards" rewardsDelta -- See the same test on Babbage for the reason it was disabled.
+          test "rollback on epoch boundary" rollbackBoundary
         , test "single MIR Cert multiple outputs" singleMIRCertMultiOut
         ]
     , testGroup

diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage.hs
@@ -105,9 +105,9 @@ unitTests iom knownMigrations =
         , --          , test "Mir rollback" mirRewardRollback
           test "Mir Cert Shelley" mirRewardShelley
         , test "Mir Cert deregistration" mirRewardDereg
-        -- , test "test rewards empty last part of epoch" rewardsEmptyChainLast
-        --        , test "test delta rewards" rewardsDelta -- We disable the test. See in the test for more.
-        , test "rollback on epoch boundary" rollbackBoundary
+        , -- , test "test rewards empty last part of epoch" rewardsEmptyChainLast
+          --        , test "test delta rewards" rewardsDelta -- We disable the test. See in the test for more.
+          test "rollback on epoch boundary" rollbackBoundary
         , test "single MIR Cert multiple outputs" singleMIRCertMultiOut
         ]
     , testGroup

diff --git a/cardano-db-sync/app/cardano-db-sync.hs b/cardano-db-sync/app/cardano-db-sync.hs
@@ -158,9 +158,10 @@ pOnlyFix =
     False
     True
     ( Opt.long "fix-only"
-        <> Opt.help "Runs only the db-sync fix procedure for the wrong datum, redeemer_data and plutus script bytes and exits. \
-            \This doesn't run any migrations. This can also be ran on previous schema, ie 13.0 13.1 to fix the issues without \
-            \bumping the schema version minor number."
+        <> Opt.help
+          "Runs only the db-sync fix procedure for the wrong datum, redeemer_data and plutus script bytes and exits. \
+          \This doesn't run any migrations. This can also be ran on previous schema, ie 13.0 13.1 to fix the issues without \
+          \bumping the schema version minor number."
     )
 
 pHasCache :: Parser Bool

diff --git a/cardano-db-sync/src/Cardano/DbSync/Api.hs b/cardano-db-sync/src/Cardano/DbSync/Api.hs
@@ -359,7 +359,7 @@ mkSyncEnv trce connSring syncOptions protoInfo nw nwMagic systemStart maybeLedge
       (Just _, False) -> do
         logWarning trce $
           "Using `--disable-ledger` doesn't require having a --state-dir."
-          <> " For more details view https://github.com/input-output-hk/cardano-db-sync/blob/master/doc/configuration.md#--disable-ledger"
+            <> " For more details view https://github.com/input-output-hk/cardano-db-sync/blob/master/doc/configuration.md#--disable-ledger"
         NoLedger <$> mkNoLedgerEnv trce protoInfo nw systemStart
       -- This won't ever call because we error out this combination at parse time
       (Nothing, True) -> NoLedger <$> mkNoLedgerEnv trce protoInfo nw systemStart

diff --git a/cardano-db-sync/src/Cardano/DbSync/Default.hs b/cardano-db-sync/src/Cardano/DbSync/Default.hs
@@ -89,8 +89,9 @@ applyAndInsertBlockMaybe syncEnv cblk = do
           if replaced
             then liftIO $ logInfo tracer $ "Fixed AdaPots for " <> textShow epochNo
             else liftIO $ logInfo tracer $ "Reached " <> textShow epochNo
-        Right _ | Just epochNo <- getNewEpoch applyRes ->
-          liftIO $ logInfo tracer $ "Reached " <> textShow epochNo
+        Right _
+          | Just epochNo <- getNewEpoch applyRes ->
+              liftIO $ logInfo tracer $ "Reached " <> textShow epochNo
         _ -> pure ()
   where
     tracer = getTrace syncEnv

diff --git a/cardano-db-sync/src/Cardano/DbSync/Fix/PlutusDataBytes.hs b/cardano-db-sync/src/Cardano/DbSync/Fix/PlutusDataBytes.hs
@@ -127,8 +127,8 @@ getWrongPlutusData tracer = do
     getRedeemerDataBytes = DB_V_13_0.redeemerDataBytes . entityVal
 
     hashPlutusData a =
-      dataHashToBytes . Alonzo.hashBinaryData @StandardAlonzo <$>
-        Alonzo.makeBinaryData (SBS.toShort a)
+      dataHashToBytes . Alonzo.hashBinaryData @StandardAlonzo
+        <$> Alonzo.makeBinaryData (SBS.toShort a)
 
 findWrongPlutusData ::
   forall a m.

diff --git a/cardano-db-sync/src/Cardano/DbSync/Fix/PlutusScripts.hs b/cardano-db-sync/src/Cardano/DbSync/Fix/PlutusScripts.hs
@@ -1,57 +1,56 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE GADTs #-}
 
 module Cardano.DbSync.Fix.PlutusScripts where
 
-import           Cardano.Prelude (mapMaybe)
+import Cardano.Prelude (mapMaybe)
 
-import           Control.Monad.Except
-import           Control.Monad.Trans.Control (MonadBaseControl)
-import           Control.Monad.Trans.Reader (ReaderT)
-import           Data.ByteString (ByteString)
+import Control.Monad.Except
+import Control.Monad.Trans.Control (MonadBaseControl)
+import Control.Monad.Trans.Reader (ReaderT)
+import Data.ByteString (ByteString)
 import qualified Data.ByteString.Short as SBS
-import           Data.Foldable (toList)
-import           Data.Text (Text)
-import           Lens.Micro
-import           Data.Map (Map)
+import Data.Foldable (toList)
+import Data.Map (Map)
 import qualified Data.Map as Map
+import Data.Text (Text)
+import Lens.Micro
 
-import           Cardano.Slotting.Slot (SlotNo(..))
+import Cardano.Slotting.Slot (SlotNo (..))
 
-import           Cardano.Ledger.Alonzo.Scripts
+import Cardano.Ledger.Alonzo.Scripts
 import qualified Cardano.Ledger.Babbage.TxBody as Babbage
-import           Cardano.Ledger.BaseTypes (strictMaybeToMaybe)
+import Cardano.Ledger.BaseTypes (strictMaybeToMaybe)
 import qualified Cardano.Ledger.Core as Ledger
 import qualified Cardano.Ledger.Language as Ledger
 
-import           Cardano.Db (ScriptType (..), maybeToEither)
+import Cardano.Db (ScriptType (..), maybeToEither)
 import qualified Cardano.Db.Old.V13_0 as DB_V_13_0
 
-import           Cardano.BM.Trace (Trace, logInfo, logWarning)
+import Cardano.BM.Trace (Trace, logInfo, logWarning)
 
-import           Cardano.DbSync.Era.Shelley.Generic.Tx.Alonzo
+import Cardano.DbSync.Api
 import qualified Cardano.DbSync.Era.Shelley.Generic as Generic
+import Cardano.DbSync.Era.Shelley.Generic.Block
+import Cardano.DbSync.Era.Shelley.Generic.Tx.Alonzo
 import qualified Cardano.DbSync.Era.Shelley.Generic.Tx.Babbage as Babbage
-import           Cardano.DbSync.Types
-import           Cardano.DbSync.Era.Shelley.Generic.Tx.Types
-import           Cardano.DbSync.Era.Shelley.Generic.Block
-import           Cardano.DbSync.Api
-
-import           Database.Persist (Entity(..))
-import           Database.Persist.Sql (SqlBackend)
+import Cardano.DbSync.Era.Shelley.Generic.Tx.Types
+import Cardano.DbSync.Types
 
-import           Ouroboros.Consensus.Shelley.Eras
-import           Ouroboros.Consensus.Cardano.Block (HardForkBlock (BlockBabbage, BlockAlonzo, BlockShelley, BlockAllegra, BlockByron, BlockMary))
+import Database.Persist (Entity (..))
+import Database.Persist.Sql (SqlBackend)
 
-import           Cardano.DbSync.Fix.PlutusDataBytes
+import Ouroboros.Consensus.Cardano.Block (HardForkBlock (BlockAllegra, BlockAlonzo, BlockBabbage, BlockByron, BlockMary, BlockShelley))
+import Ouroboros.Consensus.Shelley.Eras
 
+import Cardano.DbSync.Fix.PlutusDataBytes
 
-newtype FixPlutusScripts  = FixPlutusScripts {scriptsInfo :: [FixPlutusInfo]}
+newtype FixPlutusScripts = FixPlutusScripts {scriptsInfo :: [FixPlutusInfo]}
 
 nullPlutusScripts :: FixPlutusScripts -> Bool
 nullPlutusScripts = null . scriptsInfo
@@ -71,50 +70,57 @@ spanFPSOnPoint fps point =
     (atPoint, rest) = span ((point ==) . fpPrevPoint) (scriptsInfo fps)
 
 getWrongPlutusScripts ::
-       (MonadBaseControl IO m, MonadIO m)
-    => Trace IO Text
-    -> ReaderT SqlBackend m FixPlutusScripts
+  (MonadBaseControl IO m, MonadIO m) =>
+  Trace IO Text ->
+  ReaderT SqlBackend m FixPlutusScripts
 getWrongPlutusScripts tracer = do
-    liftIO $ logInfo tracer $ mconcat
-      [ "Starting the fixing Plutus Script procedure. This may take a couple minutes on mainnet if there are wrong values."
-      , " You can skip it using --skip-plutus-script-fix."
-      , " It will fix Script with wrong bytes. See more in Issue #1214 and #1348."
-      , " This procedure makes resyncing unnecessary."
-      ]
-    FixPlutusScripts <$> findWrongPlutusScripts tracer
+  liftIO $
+    logInfo tracer $
+      mconcat
+        [ "Starting the fixing Plutus Script procedure. This may take a couple minutes on mainnet if there are wrong values."
+        , " You can skip it using --skip-plutus-script-fix."
+        , " It will fix Script with wrong bytes. See more in Issue #1214 and #1348."
+        , " This procedure makes resyncing unnecessary."
+        ]
+  FixPlutusScripts <$> findWrongPlutusScripts tracer
 
 findWrongPlutusScripts ::
-      forall m.
-      (MonadBaseControl IO m, MonadIO m)
-      => Trace IO Text
-      -> ReaderT SqlBackend m [FixPlutusInfo]
+  forall m.
+  (MonadBaseControl IO m, MonadIO m) =>
+  Trace IO Text ->
+  ReaderT SqlBackend m [FixPlutusInfo]
 findWrongPlutusScripts tracer =
-      findWrongPlutusData
-        tracer "Script"
-        DB_V_13_0.queryScriptCount DB_V_13_0.queryScriptPage (fmap f . DB_V_13_0.queryScriptInfo . entityKey)
-        (DB_V_13_0.scriptHash . entityVal) (DB_V_13_0.scriptBytes . entityVal) (hashPlutusScript . entityVal)
-    where
-      f queryRes = do
-        (prevBlockHsh, mPrevSlotNo) <- queryRes
-        prevSlotNo <- mPrevSlotNo
-        prevPoint <- convertToPoint (SlotNo prevSlotNo) prevBlockHsh
-        Just prevPoint
-
-      hashPlutusScript dbScript = do
-          lang <- getLang
-          bytes <- maybeToEither "No bytes found for plutus script" id $ DB_V_13_0.scriptBytes dbScript
-          let script :: AlonzoScript StandardAlonzo = PlutusScript lang (SBS.toShort bytes)
-          let hsh :: Ledger.ScriptHash StandardCrypto = Ledger.hashScript @StandardAlonzo script
-          Right $ Generic.unScriptHash hsh
-        where
-          getLang = case DB_V_13_0.scriptType dbScript of
-            PlutusV1 -> Right Ledger.PlutusV1
-            PlutusV2 -> Right Ledger.PlutusV2
-            _ -> Left "Non plutus script found where it shouldn't."
+  findWrongPlutusData
+    tracer
+    "Script"
+    DB_V_13_0.queryScriptCount
+    DB_V_13_0.queryScriptPage
+    (fmap f . DB_V_13_0.queryScriptInfo . entityKey)
+    (DB_V_13_0.scriptHash . entityVal)
+    (DB_V_13_0.scriptBytes . entityVal)
+    (hashPlutusScript . entityVal)
+  where
+    f queryRes = do
+      (prevBlockHsh, mPrevSlotNo) <- queryRes
+      prevSlotNo <- mPrevSlotNo
+      prevPoint <- convertToPoint (SlotNo prevSlotNo) prevBlockHsh
+      Just prevPoint
+
+    hashPlutusScript dbScript = do
+      lang <- getLang
+      bytes <- maybeToEither "No bytes found for plutus script" id $ DB_V_13_0.scriptBytes dbScript
+      let script :: AlonzoScript StandardAlonzo = PlutusScript lang (SBS.toShort bytes)
+      let hsh :: Ledger.ScriptHash StandardCrypto = Ledger.hashScript @StandardAlonzo script
+      Right $ Generic.unScriptHash hsh
+      where
+        getLang = case DB_V_13_0.scriptType dbScript of
+          PlutusV1 -> Right Ledger.PlutusV1
+          PlutusV2 -> Right Ledger.PlutusV2
+          _ -> Left "Non plutus script found where it shouldn't."
 
 fixPlutusScripts :: MonadIO m => Trace IO Text -> CardanoBlock -> FixPlutusScripts -> ReaderT SqlBackend m ()
 fixPlutusScripts tracer cblk fpss = do
-    mapM_ fixData $ scriptsInfo fpss
+  mapM_ fixData $ scriptsInfo fpss
   where
     fixData :: MonadIO m => FixPlutusInfo -> ReaderT SqlBackend m ()
     fixData fpi = do
@@ -126,27 +132,33 @@ fixPlutusScripts tracer cblk fpss = do
             Just scriptId ->
               DB_V_13_0.updateScriptBytes scriptId correctBytes
             Nothing ->
-              liftIO $ logWarning tracer $ mconcat
-                ["Script", " not found in block"]
+              liftIO $
+                logWarning tracer $
+                  mconcat
+                    ["Script", " not found in block"]
 
     correctBytesMap = scrapScriptBlock cblk
 
 scrapScriptBlock :: CardanoBlock -> Map ByteString ByteString
 scrapScriptBlock cblk = case cblk of
-    BlockBabbage blk -> Map.unions $ scrapScriptTxBabbage . snd <$> babbageBlockTxs blk
-    BlockAlonzo blk -> Map.unions $ scrapScriptTxAlonzo . snd <$> alonzoBlockTxs blk
-    BlockByron _ -> error "No Plutus Scripts in Byron"
-    BlockShelley _  -> error "No Plutus Scripts in Shelley"
-    BlockAllegra _  -> error "No Plutus Scripts in Allegra"
-    BlockMary _ -> error "No Plutus Scripts in Mary"
-    _ -> error "TODO: Conway not supported"
+  BlockBabbage blk -> Map.unions $ scrapScriptTxBabbage . snd <$> babbageBlockTxs blk
+  BlockAlonzo blk -> Map.unions $ scrapScriptTxAlonzo . snd <$> alonzoBlockTxs blk
+  BlockByron _ -> error "No Plutus Scripts in Byron"
+  BlockShelley _ -> error "No Plutus Scripts in Shelley"
+  BlockAllegra _ -> error "No Plutus Scripts in Allegra"
+  BlockMary _ -> error "No Plutus Scripts in Mary"
+  _ -> error "TODO: Conway not supported"
 
 scrapScriptTxBabbage :: Ledger.Tx StandardBabbage -> Map ByteString ByteString
 scrapScriptTxBabbage tx = Map.union txMap txOutMap
   where
     txMap = Map.fromList $ mapMaybe getTxScript $ getScripts tx
-    txOutMap = Map.fromList $ mapMaybe getOutputScript $
-      toList $ Babbage.outputs' $ tx ^. Ledger.bodyTxL
+    txOutMap =
+      Map.fromList $
+        mapMaybe getOutputScript $
+          toList $
+            Babbage.outputs' $
+              tx ^. Ledger.bodyTxL
 
     getOutputScript :: Ledger.TxOut StandardBabbage -> Maybe (ByteString, ByteString)
     getOutputScript txOut = do
@@ -158,7 +170,8 @@ scrapScriptTxAlonzo tx = Map.fromList $ mapMaybe getTxScript $ getScripts tx
 
 getTxScript :: Generic.TxScript -> Maybe (ByteString, ByteString)
 getTxScript txScript =
-    if txScriptType txScript `elem` [PlutusV1, PlutusV2] then do
-        cbor <- txScriptCBOR txScript
-        Just (txScriptHash txScript, cbor)
+  if txScriptType txScript `elem` [PlutusV1, PlutusV2]
+    then do
+      cbor <- txScriptCBOR txScript
+      Just (txScriptHash txScript, cbor)
     else Nothing