Unit tests for the Plutus txinfo translation in the Babbage era

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxInfo.hs

@@ -100,6 +100,7 @@ data TranslationError
   | LanguageNotSupported
   | InlineDatumsNotSupported
   | ReferenceScriptsNotSupported
+  | ReferenceInputsNotSupported
   deriving (Eq, Show, Generic, NoThunks)
 
 instance ToCBOR TranslationError where
@@ -111,6 +112,7 @@ instance ToCBOR TranslationError where
   toCBOR LanguageNotSupported = encode $ Sum LanguageNotSupported 5
   toCBOR InlineDatumsNotSupported = encode $ Sum InlineDatumsNotSupported 6
   toCBOR ReferenceScriptsNotSupported = encode $ Sum ReferenceScriptsNotSupported 7
+  toCBOR ReferenceInputsNotSupported = encode $ Sum ReferenceInputsNotSupported 8
 
 instance FromCBOR TranslationError where
   fromCBOR = decode (Summands "TranslationError" dec)
@@ -123,6 +125,7 @@ instance FromCBOR TranslationError where
       dec 5 = SumD LanguageNotSupported
       dec 6 = SumD InlineDatumsNotSupported
       dec 7 = SumD ReferenceScriptsNotSupported
+      dec 8 = SumD ReferenceInputsNotSupported
       dec n = Invalid n
 
 transDataHash :: StrictMaybe (DataHash c) -> Maybe PV1.DatumHash

eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxow.hs

@@ -268,26 +268,3 @@ instance
   where
   wrapFailed = id
   wrapEvent = WrappedShelleyEraEvent . UtxoEvent
-
-{-
--- | In orer to reuse the AlonzoLEDGER STS instance we need to embed this UTXOW instance into it.
-instance ( ConcreteBabbage era
-         , Signal (Core.EraRule "UTXO" era) ~ ValidatedTx era
-         , State (Core.EraRule "UTXO" era) ~ UTxOState era
-         , Environment (Core.EraRule "UTXO" era) ~ UtxoEnv era
-         , Signable (DSIGN (Crypto era)) (Hash (HASH (Crypto era)) EraIndependentTxBody)
-         , Eq (PredicateFailure (Core.EraRule "UTXOS" era))
-         , Show (PredicateFailure (Core.EraRule "UTXOS" era))
-         , Embed (Core.EraRule "UTXO" era) (BabbageUTXOW era)
-         , ValidateAuxiliaryData era (Crypto era)
-         , ValidateScript era
-      --   , PredicateFailure (Core.EraRule "UTXOW" era) ~ BabbageUtxoPred era
-         , Event (Core.EraRule "UTXOW" era) ~ AlonzoEvent era
-         ) =>
-         Embed (BabbageUTXOW era) (AlonzoLEDGER era) where
-  wrapFailed =  foo -- FromAlonzoUtxowFail . UtxowFailure
-  wrapEvent = UtxowEvent
-
-foo :: BabbageUtxoPred era -> LedgerPredicateFailure era
-foo _ = undefined
--}

eras/babbage/impl/src/Cardano/Ledger/Babbage/TxInfo.hs

@@ -33,6 +33,7 @@ import Cardano.Ledger.TxIn (TxIn (..))
 import Cardano.Ledger.Val (Val (..))
 import Cardano.Slotting.EpochInfo (EpochInfo)
 import Cardano.Slotting.Time (SystemStart)
+import Control.Monad (unless)
 import qualified Data.Compact.SplitMap as SplitMap
 import qualified Data.Map as Map
 import Data.Sequence.Strict (StrictSeq)
@@ -50,6 +51,10 @@ transReferenceScript :: forall era. ValidateScript era => StrictMaybe (Core.Scri
 transReferenceScript SNothing = Nothing
 transReferenceScript (SJust s) = Just . transScriptHash . hashScript @era $ s
 
+-- | A transaction output can be transalated because it is a newly created output,
+-- or because it is the output which is connected to an transaction input being spent.
+data OutputSource = OutputFromInput | OutputFromOutput
+
 -- | Given a TxOut, translate it for V2 and return (Right transalation).
 -- If the transaction contains any Byron addresses or Babbage features, return Left.
 txInfoOutV1 ::
@@ -61,18 +66,20 @@ txInfoOutV1 ::
     HasField "datum" (Core.TxOut era) (StrictMaybe (Data era)),
     HasField "referenceScript" (Core.TxOut era) (StrictMaybe (Core.Script era))
   ) =>
+  OutputSource ->
   Core.TxOut era ->
   Either TranslationError PV1.TxOut
-txInfoOutV1 txout =
+txInfoOutV1 os txout =
   let val = getField @"value" txout
       datahash = getField @"datahash" txout
       inlineDatum = getField @"datum" txout
       referenceScript = transReferenceScript @era $ getField @"referenceScript" txout
-   in case (Alonzo.transTxOutAddr txout, inlineDatum, referenceScript) of
-        (Nothing, _, _) -> Left ByronOutputInContext
-        (_, SJust _, _) -> Left InlineDatumsNotSupported
-        (_, _, Just _) -> Left ReferenceScriptsNotSupported
-        (Just ad, SNothing, Nothing) ->
+   in case (Alonzo.transTxOutAddr txout, inlineDatum, referenceScript, os) of
+        (Nothing, _, _, OutputFromOutput) -> Left ByronOutputInContext
+        (Nothing, _, _, OutputFromInput) -> Left ByronInputInContext
+        (_, SJust _, _, _) -> Left InlineDatumsNotSupported
+        (_, _, Just _, _) -> Left ReferenceScriptsNotSupported
+        (Just ad, SNothing, Nothing, _) ->
           Right (PV1.TxOut ad (Alonzo.transValue @(Crypto era) val) (Alonzo.transDataHash datahash))
 
 -- | Given a TxOut, translate it for V2 and return (Right transalation). It is
@@ -86,9 +93,10 @@ txInfoOutV2 ::
     HasField "datum" (Core.TxOut era) (StrictMaybe (Data era)),
     HasField "referenceScript" (Core.TxOut era) (StrictMaybe (Core.Script era))
   ) =>
+  OutputSource ->
   Core.TxOut era ->
   Either TranslationError PV2.TxOut
-txInfoOutV2 txout =
+txInfoOutV2 os txout =
   let val = getField @"value" txout
       d = case (getField @"datahash" txout, getField @"datum" txout) of
         (SNothing, SNothing) -> Right PV2.NoOutputDatum
@@ -97,10 +105,11 @@ txInfoOutV2 txout =
           Right . PV2.OutputDatum . PV2.Datum . PV2.dataToBuiltinData . getPlutusData $ d'
         (SJust _, SJust _) -> Left TranslationLogicErrorDoubleDatum
       referenceScript = transReferenceScript @era $ getField @"referenceScript" txout
-   in case (Alonzo.transTxOutAddr txout, d) of
-        (_, Left e) -> Left e
-        (Nothing, _) -> Left ByronOutputInContext
-        (Just ad, Right d') ->
+   in case (Alonzo.transTxOutAddr txout, d, os) of
+        (_, Left e, _) -> Left e
+        (Nothing, _, OutputFromOutput) -> Left ByronOutputInContext
+        (Nothing, _, OutputFromInput) -> Left ByronInputInContext
+        (Just ad, Right d', _) ->
           Right (PV2.TxOut ad (Alonzo.transValue @(Crypto era) val) d' referenceScript)
 
 -- | Given a TxIn, look it up in the UTxO. If it exists, translate it to the V1 context
@@ -120,7 +129,7 @@ txInfoInV1 (UTxO mp) txin =
   case SplitMap.lookup txin mp of
     Nothing -> Left TranslationLogicErrorInput
     Just txout -> do
-      out <- txInfoOutV1 txout
+      out <- txInfoOutV1 OutputFromInput txout
       Right (PV1.TxInInfo (Alonzo.txInfoIn' txin) out)
 
 -- | Given a TxIn, look it up in the UTxO. If it exists, translate it to the V2 context
@@ -140,7 +149,7 @@ txInfoInV2 (UTxO mp) txin =
   case SplitMap.lookup txin mp of
     Nothing -> Left TranslationLogicErrorInput
     Just txout -> do
-      out <- txInfoOutV2 txout
+      out <- txInfoOutV2 OutputFromInput txout
       Right (PV2.TxInInfo (Alonzo.txInfoIn' txin) out)
 
 transRedeemer :: Data era -> PV2.Redeemer
@@ -191,8 +200,9 @@ babbageTxInfo pp lang ei sysS utxo tx = do
   pure $
     case lang of
       PlutusV1 -> do
+        unless (Set.null $ getField @"referenceInputs" tbody) (Left ReferenceInputsNotSupported)
         inputs <- mapM (txInfoInV1 utxo) (Set.toList (getField @"inputs" tbody))
-        outputs <- mapM txInfoOutV1 (foldr (:) [] outs)
+        outputs <- mapM (txInfoOutV1 OutputFromOutput) (foldr (:) [] outs)
         pure . TxInfoPV1 $
           PV1.TxInfo
             { PV1.txInfoInputs = inputs,
@@ -209,7 +219,7 @@ babbageTxInfo pp lang ei sysS utxo tx = do
       PlutusV2 -> do
         inputs <- mapM (txInfoInV2 utxo) (Set.toList (getField @"inputs" tbody))
         refInputs <- mapM (txInfoInV2 utxo) (Set.toList (getField @"referenceInputs" tbody))
-        outputs <- mapM txInfoOutV2 (foldr (:) [] outs)
+        outputs <- mapM (txInfoOutV2 OutputFromOutput) (foldr (:) [] outs)
         rdmrs' <- mapM (transRedeemerPtr tbody) rdmrs
         pure . TxInfoPV2 $
           PV2.TxInfo

eras/babbage/test-suite/cardano-ledger-babbage-test.cabal

@@ -78,7 +78,8 @@ test-suite cardano-ledger-babbage-test
     test
   other-modules:
     Test.Cardano.Ledger.Babbage.Serialisation.Tripping,
-    Test.Cardano.Ledger.Babbage.Serialisation.CDDL
+    Test.Cardano.Ledger.Babbage.Serialisation.CDDL,
+    Test.Cardano.Ledger.Babbage.TxInfo
   build-depends:
     QuickCheck,
     base16-bytestring,
@@ -98,6 +99,7 @@ test-suite cardano-ledger-babbage-test
     cardano-protocol-tpraos,
     cardano-slotting,
     cborg,
+    compact-map,
     containers,
     data-default-class,
     plutus-core,