Merge pull request #800 from IntersectMBO/jordan/bug-fix-798

carbolymer · web-flow · commit 5937f402b240 · 2025-04-04T08:25:25.000Z
Bug fix - redeemer pointer map construction
diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal
@@ -332,6 +332,7 @@ test-suite cardano-api-test
     cardano-ledger-alonzo,
     cardano-ledger-api >=1.9,
     cardano-ledger-binary,
+    cardano-ledger-conway,
     cardano-ledger-core:{cardano-ledger-core, testlib} >=1.14,
     cardano-ledger-mary,
     cardano-protocol-tpraos,
@@ -377,6 +378,7 @@ test-suite cardano-api-test
     Test.Cardano.Api.Orphans
     Test.Cardano.Api.RawBytes
     Test.Cardano.Api.Transaction.Autobalance
+    Test.Cardano.Api.Transaction.Body.Plutus.Scripts
     Test.Cardano.Api.TxBody
     Test.Cardano.Api.Value
 
diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs
@@ -119,6 +119,7 @@ module Test.Gen.Cardano.Api.Typed
   , genTxValidityUpperBound
   , genTxWithdrawals
   , genUnsignedQuantity
+
   , genPositiveQuantity
   , genValueForMinting
   , genValueForTxOut
@@ -133,11 +134,15 @@ module Test.Gen.Cardano.Api.Typed
   , genProposal
   , genVotingProcedures
   , genSimpleScriptWithoutEmptyAnys
+  , genWitnessable
+  , genPlutusScriptWitness
+  , genIndexedPlutusScriptWitness
   )
 where
 
 import           Cardano.Api hiding (txIns)
 import qualified Cardano.Api as Api
+import qualified Cardano.Api.Experimental as Exp 
 import           Cardano.Api.Byron (KeyWitness (ByronKeyWitness),
                    WitnessNetworkIdOrByronAddress (..))
 import qualified Cardano.Api.Byron as Byron
@@ -146,6 +151,8 @@ import qualified Cardano.Api.Ledger as L
 import qualified Cardano.Api.Ledger.Lens as A
 import           Cardano.Api.Internal.Script (scriptInEraToRefScript)
 import           Cardano.Api.Shelley
+import           Cardano.Ledger.Plutus.Language qualified as L
+
 import qualified Cardano.Api.Shelley as ShelleyApi
 
 import qualified Cardano.Binary as CBOR
@@ -168,8 +175,8 @@ import           Data.Maybe
 import qualified Data.ByteString.Base16 as Base16
 import           Data.Ratio (Ratio, (%))
 import           Data.String
-import Test.Gen.Cardano.Api.Hardcoded
-import Data.Typeable
+import           Test.Gen.Cardano.Api.Hardcoded
+import           Data.Typeable
 import           Data.Word (Word16, Word32, Word64)
 import           GHC.Exts (IsList (..))
 import           GHC.Stack
@@ -1362,6 +1369,38 @@ genCurrentTreasuryValue _era = Q.arbitrary
 genTreasuryDonation :: ConwayEraOnwards era -> Gen L.Coin
 genTreasuryDonation _era = Q.arbitrary
 
+genWitnessable :: L.AlonzoEraScript era => Gen (Exp.Witnessable Exp.TxInItem era)
+genWitnessable = Exp.WitTxIn <$> genTxIn  
+
+genIndexedPlutusScriptWitness 
+  :: L.AlonzoEraScript (ShelleyLedgerEra era) 
+  => Gen (Exp.IndexedPlutusScriptWitness Exp.TxInItem L.PlutusV3 Exp.SpendingScript (ShelleyLedgerEra era))
+genIndexedPlutusScriptWitness =  do
+    index <- Gen.word32 $ Range.linear 1 10
+    witnessable <- genWitnessable
+    Exp.IndexedPlutusScriptWitness 
+       <$> genWitnessable
+       <*> genPlutusPurpose index witnessable
+       <*> genPlutusScriptWitness 
+
+genPlutusPurpose 
+  :: Word32 
+  -> Exp.Witnessable thing (ShelleyLedgerEra era) 
+  -> Gen (L.PlutusPurpose L.AsIx (ShelleyLedgerEra era))
+genPlutusPurpose index wit = return $ Exp.toPlutusScriptPurpose index wit
+
+genPlutusScriptWitness :: Gen (Exp.PlutusScriptWitness L.PlutusV3 purpose era)
+genPlutusScriptWitness = do 
+  let l = Exp.toPlutusSLanguage PlutusScriptV3
+  Exp.PlutusScriptWitness l . Exp.PReferenceScript 
+    <$> genTxIn
+    <*> genPlutusScriptDatum
+    <*> genHashableScriptData
+    <*> genExecutionUnits 
+
+genPlutusScriptDatum :: Gen (Exp.PlutusScriptDatum lang purpose)
+genPlutusScriptDatum = return Exp.NoScriptDatum 
+
 -- | This generator does not generate a valid witness - just a random one.
 genScriptWitnessForStake :: ShelleyBasedEra era -> Gen (Api.ScriptWitness WitCtxStake era)
 genScriptWitnessForStake sbe = do
diff --git a/cardano-api/src/Cardano/Api/Experimental.hs b/cardano-api/src/Cardano/Api/Experimental.hs
@@ -34,9 +34,35 @@ module Cardano.Api.Experimental
   , babbageEraOnwardsToEra
   , eraToBabbageEraOnwards
   , sbeToEra
+
+    -- ** Witness related
+  , AnyWitness (..)
+  , PlutusScriptWitness (..)
+  , Witnessable (..)
+  , WitnessableItem (..)
+
+    -- ** Plutus related
+  , PlutusScriptInEra (..)
+  , PlutusScriptOrReferenceInput (..)
+  , IndexedPlutusScriptWitness (..)
+  , PlutusScriptPurpose (..)
+  , PlutusScriptDatum (..)
+  , NoScriptDatum (..)
+
+    -- ** Internal
+  , getAnyWitnessRedeemerPointerMap
+  , toPlutusScriptPurpose
+
+    -- ** Legacy
+  , toPlutusSLanguage
   )
 where
 
 import Cardano.Api.Internal.Experimental.Eras
+import Cardano.Api.Internal.Experimental.Plutus.IndexedPlutusScriptWitness
+import Cardano.Api.Internal.Experimental.Plutus.Script
+import Cardano.Api.Internal.Experimental.Plutus.ScriptWitness
+import Cardano.Api.Internal.Experimental.Plutus.Shim.LegacyScripts
 import Cardano.Api.Internal.Experimental.Tx
+import Cardano.Api.Internal.Experimental.Witness.AnyWitness
 import Cardano.Api.Internal.Fees (evaluateTransactionExecutionUnitsShelley)
diff --git a/cardano-api/src/Cardano/Api/Internal/Experimental/Plutus/IndexedPlutusScriptWitness.hs b/cardano-api/src/Cardano/Api/Internal/Experimental/Plutus/IndexedPlutusScriptWitness.hs
@@ -20,6 +20,9 @@ module Cardano.Api.Internal.Experimental.Plutus.IndexedPlutusScriptWitness
   , createIndexedPlutusScriptWitnesses
   , getAnyWitnessRedeemerPointerMap
   , obtainAlonzoScriptPurposeConstraints
+
+    -- * Exposed for testing
+  , constructRedeeemerPointerMap
   )
 where
 
@@ -48,17 +51,22 @@ import GHC.Exts
 -- and the index of the thing it is witnessing.
 data IndexedPlutusScriptWitness witnessable (lang :: L.Language) (purpose :: PlutusScriptPurpose) era where
   IndexedPlutusScriptWitness
-    :: Witnessable witnessable era
+    :: L.AlonzoEraScript era
+    => Witnessable witnessable era
     -> (L.PlutusPurpose L.AsIx era)
     -> (PlutusScriptWitness lang purpose era)
     -> IndexedPlutusScriptWitness witnessable lang purpose era
 
+deriving instance Show (IndexedPlutusScriptWitness witnessable lang purpose era)
+
 data AnyIndexedPlutusScriptWitness era where
   AnyIndexedPlutusScriptWitness
     :: GetPlutusScriptPurpose era
     => IndexedPlutusScriptWitness witnessable lang purpose era
     -> AnyIndexedPlutusScriptWitness era
 
+deriving instance Show (AnyIndexedPlutusScriptWitness era)
+
 -- | These are all of the "things" a plutus script can witness. We include the relevant
 -- type class constraint to avoid boilerplate when creating the 'PlutusPurpose' in
 -- the 'GetPlutusScriptPurpose' instances.
@@ -141,7 +149,8 @@ instance GetPlutusScriptPurpose era where
   toPlutusScriptPurpose index WitProposal{} = L.mkProposingPurpose (L.AsIx index)
 
 createIndexedPlutusScriptWitness
-  :: Word32
+  :: L.AlonzoEraScript era
+  => Word32
   -> Witnessable witnessable era
   -> PlutusScriptWitness lang purpose era
   -> IndexedPlutusScriptWitness witnessable lang purpose era
@@ -151,7 +160,8 @@ createIndexedPlutusScriptWitness index witnessable =
 -- | Create a list of indexed plutus script witnesses from anything witnessable that has been
 -- witnesseed by a plutus script.
 createIndexedPlutusScriptWitnesses
-  :: [(Witnessable witnessable era, AnyWitness era)]
+  :: L.AlonzoEraScript era
+  => [(Witnessable witnessable era, AnyWitness era)]
   -> [AnyIndexedPlutusScriptWitness era]
 createIndexedPlutusScriptWitnesses witnessableThings =
   [ AnyIndexedPlutusScriptWitness $ createIndexedPlutusScriptWitness index thing sWit
@@ -162,16 +172,15 @@ createIndexedPlutusScriptWitnesses witnessableThings =
 
 -- | The transaction's redeemer pointer map allows the ledger to connect a redeemer and execution unit pairing to the relevant
 -- script. The ledger basically reconstructs the indicies (redeemer pointers) of this map can then look up the relevant
--- execution units/redeemer pairing. NB the redeemer pointer has been renamed to 'PlutusPurpose AsIndex' in the ledger.
+-- execution units/redeemer pairing. NB: the redeemer pointer has been renamed to 'PlutusPurpose AsIndex' in the ledger.
 getAnyWitnessRedeemerPointerMap
   :: AlonzoEraOnwards era
-  -> (Witnessable witnessable (ShelleyLedgerEra era), AnyWitness (ShelleyLedgerEra era))
+  -> [(Witnessable witnessable (ShelleyLedgerEra era), AnyWitness (ShelleyLedgerEra era))]
   -> L.Redeemers (ShelleyLedgerEra era)
-getAnyWitnessRedeemerPointerMap eon (_, AnyKeyWitnessPlaceholder) = alonzoEraOnwardsConstraints eon mempty
-getAnyWitnessRedeemerPointerMap eon (_, AnySimpleScriptWitness{}) = alonzoEraOnwardsConstraints eon mempty
 getAnyWitnessRedeemerPointerMap eon anyWit =
   constructRedeeemerPointerMap eon $
-    createIndexedPlutusScriptWitnesses [anyWit]
+    alonzoEraOnwardsConstraints eon $
+      createIndexedPlutusScriptWitnesses anyWit
 
 -- | An 'IndexedPlutusScriptWitness' contains everything we need to construct a single
 -- entry in the redeemer pointer map.
diff --git a/cardano-api/src/Cardano/Api/Internal/Experimental/Plutus/ScriptWitness.hs b/cardano-api/src/Cardano/Api/Internal/Experimental/Plutus/ScriptWitness.hs
@@ -7,6 +7,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilyDependencies #-}
 {-# LANGUAGE UndecidableInstances #-}
 
@@ -65,6 +66,8 @@ data PlutusScriptWitness (lang :: L.Language) (purpose :: PlutusScriptPurpose) e
     -> ExecutionUnits
     -> PlutusScriptWitness lang purpose era
 
+deriving instance Show (PlutusScriptWitness lang purpose era)
+
 getPlutusScriptWitnessLanguage :: PlutusScriptWitness lang purpose era -> L.Language
 getPlutusScriptWitnessLanguage (PlutusScriptWitness l _ _ _ _) =
   case l of
diff --git a/cardano-api/src/Cardano/Api/Internal/Experimental/Plutus/Shim/LegacyScripts.hs b/cardano-api/src/Cardano/Api/Internal/Experimental/Plutus/Shim/LegacyScripts.hs
@@ -12,6 +12,7 @@
 
 module Cardano.Api.Internal.Experimental.Plutus.Shim.LegacyScripts
   ( legacyWitnessToScriptRequirements
+  , toPlutusSLanguage
   )
 where
 
diff --git a/cardano-api/src/Cardano/Api/Internal/Experimental/Witness/TxScriptWitnessRequirements.hs b/cardano-api/src/Cardano/Api/Internal/Experimental/Witness/TxScriptWitnessRequirements.hs
@@ -62,21 +62,27 @@ instance Monoid (TxScriptWitnessRequirements L.ConwayEra) where
 
 getTxScriptWitnessRequirements
   :: AlonzoEraOnwards era
-  -> (Witnessable witnessable (ShelleyLedgerEra era), AnyWitness (ShelleyLedgerEra era))
+  -> [(Witnessable witnessable (ShelleyLedgerEra era), AnyWitness (ShelleyLedgerEra era))]
   -> TxScriptWitnessRequirements (ShelleyLedgerEra era)
-getTxScriptWitnessRequirements era (thing, anyWit) =
-  TxScriptWitnessRequirements
-    (maybe mempty Set.singleton $ getAnyWitnessPlutusLanguage anyWit)
-    (maybe mempty return $ getAnyWitnessScript (convert era) anyWit)
-    (getAnyWitnessScriptData era anyWit)
-    (getAnyWitnessRedeemerPointerMap era (thing, anyWit))
+getTxScriptWitnessRequirements era wits =
+  let TxScriptWitnessRequirements l s d _ =
+        obtainMonoidConstraint era $
+          mconcat
+            [ TxScriptWitnessRequirements
+                (maybe mempty Set.singleton $ getAnyWitnessPlutusLanguage anyWit)
+                (maybe mempty return $ getAnyWitnessScript (convert era) anyWit)
+                (getAnyWitnessScriptData era anyWit)
+                (alonzoEraOnwardsConstraints era mempty)
+            | (_, anyWit) <- wits
+            ]
+   in TxScriptWitnessRequirements l s d (getAnyWitnessRedeemerPointerMap era wits)
 
 getTxScriptWitnessesRequirements
   :: AlonzoEraOnwards era
   -> [(Witnessable witnessable (ShelleyLedgerEra era), AnyWitness (ShelleyLedgerEra era))]
   -> TxScriptWitnessRequirements (ShelleyLedgerEra era)
 getTxScriptWitnessesRequirements eon wits =
-  obtainMonoidConstraint eon $ mconcat $ map (getTxScriptWitnessRequirements eon) wits
+  obtainMonoidConstraint eon $ getTxScriptWitnessRequirements eon wits
 
 obtainMonoidConstraint
   :: AlonzoEraOnwards era
diff --git a/cardano-api/src/Cardano/Api/Internal/ScriptData.hs b/cardano-api/src/Cardano/Api/Internal/ScriptData.hs
@@ -98,7 +98,7 @@ data HashableScriptData
       !BS.ByteString
       -- ^ Original 'ScriptData' bytes
       !ScriptData
-  deriving (Eq, Show)
+  deriving (Eq, Show, Ord)
 
 instance HasTypeProxy HashableScriptData where
   data AsType HashableScriptData = AsHashableScriptData
diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Body/Plutus/Scripts.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Body/Plutus/Scripts.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Test.Cardano.Api.Transaction.Body.Plutus.Scripts
+  ( tests
+  )
+where
+
+import Cardano.Api (AlonzoEraOnwards (..))
+import Cardano.Api.Experimental
+import Cardano.Api.Ledger qualified as L
+import Cardano.Api.Shelley (fromAlonzoData)
+
+import Cardano.Ledger.Alonzo.TxWits qualified as L
+import Cardano.Ledger.Conway qualified as L
+
+import Prelude
+
+import Data.List qualified as List
+import Data.Map.Strict qualified as Map
+
+import Test.Gen.Cardano.Api.Typed (genIndexedPlutusScriptWitness, genWitnessable)
+
+import Test.Cardano.Api.Orphans ()
+
+import Hedgehog
+import Hedgehog.Gen qualified as Gen
+import Hedgehog.Range qualified as Range
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.Hedgehog (testProperty)
+
+-- | This property checks that the redeemer pointer map is constructed correctly.
+-- Previously identical script purposes were being created and overwriting each other
+-- in the redeemer pointer map.
+prop_getAnyWitnessRedeemerPointerMap :: Property
+prop_getAnyWitnessRedeemerPointerMap = property $ do
+  let eon = AlonzoEraOnwardsConway
+  l <- forAll $ Gen.int (Range.linear 2 5)
+  witnessables <- forAll $ Gen.list (Range.singleton l) $ genWitnessable @L.ConwayEra
+  wits <-
+    forAll $
+      Gen.list (Range.singleton l) $
+        genIndexedPlutusScriptWitness @ConwayEra
+  let anyWits =
+        [ AnyPlutusScriptWitness swit
+        | IndexedPlutusScriptWitness _ _ swit <- wits
+        ]
+
+      zipped = zip witnessables anyWits
+      expectedRedeemerPointerMapLength = length zipped
+      finalWits = take expectedRedeemerPointerMapLength wits
+
+      L.Redeemers constructedRedeemerPointerMap = getAnyWitnessRedeemerPointerMap eon zipped
+
+  annotate "Constructed redeemer pointer map"
+  annotateShow constructedRedeemerPointerMap
+  let redeemerPointerMapSize = Map.size constructedRedeemerPointerMap
+
+  cover 30 "Redeemer pointer map size more than 1" $ redeemerPointerMapSize > 1
+
+  -- Confirm we have the expected number of redeemers
+  Map.size constructedRedeemerPointerMap === expectedRedeemerPointerMapLength
+
+  let initialRedeemers =
+        [ redeemer
+        | IndexedPlutusScriptWitness _ _ swit <- finalWits
+        , let PlutusScriptWitness _ _ _ redeemer _ = swit
+        ]
+
+      ledgerRedeemers :: [L.Data L.ConwayEra]
+      ledgerRedeemers = map fst $ Map.elems constructedRedeemerPointerMap
+
+      convertedRedeemers = map fromAlonzoData ledgerRedeemers
+
+  annotate "Initial Indexed Script Witnesses"
+  annotateShow wits
+
+  -- Confirm we have idential redeemers
+  List.sort initialRedeemers === List.sort convertedRedeemers
+
+tests :: TestTree
+tests =
+  testGroup
+    "Test.Cardano.Api.Transaction.Body.Plutus.Scripts"
+    [ testProperty "prop_getAnyWitnessRedeemerPointerMap" prop_getAnyWitnessRedeemerPointerMap
+    ]
diff --git a/cardano-api/test/cardano-api-test/cardano-api-test.hs b/cardano-api/test/cardano-api-test/cardano-api-test.hs
@@ -24,6 +24,7 @@ import Test.Cardano.Api.Metadata qualified
 import Test.Cardano.Api.Ord qualified
 import Test.Cardano.Api.RawBytes qualified
 import Test.Cardano.Api.Transaction.Autobalance qualified
+import Test.Cardano.Api.Transaction.Body.Plutus.Scripts qualified
 import Test.Cardano.Api.TxBody qualified
 import Test.Cardano.Api.Value qualified
 
@@ -59,6 +60,7 @@ tests =
     , Test.Cardano.Api.Metadata.tests
     , Test.Cardano.Api.Ord.tests
     , Test.Cardano.Api.RawBytes.tests
+    , Test.Cardano.Api.Transaction.Body.Plutus.Scripts.tests
     , Test.Cardano.Api.Transaction.Autobalance.tests
     , Test.Cardano.Api.TxBody.tests
     , Test.Cardano.Api.Value.tests

Original file line number	Diff line number	Diff line change
`@@ -12,6 +12,7 @@`
`12`	`12`
`13`	`13`	`module Cardano.Api.Internal.Experimental.Plutus.Shim.LegacyScripts`
`14`	`14`	`( legacyWitnessToScriptRequirements`
	`15`	`+ , toPlutusSLanguage`
`15`	`16`	`)`
`16`	`17`	`where`
`17`	`18`