Merge pull request #2717 from input-output-hk/zc/isWellFormed-check

babbage script well-formedness check

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

@@ -54,6 +54,7 @@ import Cardano.Ledger.BaseTypes
 import Cardano.Ledger.Coin (Coin (..))
 import qualified Cardano.Ledger.Core as Core
 import Cardano.Ledger.Era (Era (..), ValidateScript (..))
+import Cardano.Ledger.Hashes (ScriptHash)
 import Cardano.Ledger.Rules.ValidationMode
   ( Inject (..),
     Test,
@@ -108,6 +109,7 @@ data BabbageUtxoPred era
   | FromAlonzoUtxowFail !(UtxowPredicateFail era)
   | UnequalCollateralReturn !Coin !Coin
   | DanglingWitnessDataHash !(Set.Set (DataHash (Crypto era)))
+  | MalformedScripts !(Set (ScriptHash (Crypto era)))
 
 deriving instance
   ( Era era,
@@ -394,6 +396,7 @@ instance
       work (FromAlonzoUtxowFail x) = Sum FromAlonzoUtxowFail 2 !> To x
       work (UnequalCollateralReturn c1 c2) = Sum UnequalCollateralReturn 3 !> To c1 !> To c2
       work (DanglingWitnessDataHash x) = Sum DanglingWitnessDataHash 4 !> To x
+      work (MalformedScripts x) = Sum MalformedScripts 5 !> To x
 
 instance
   ( Era era,
@@ -413,6 +416,7 @@ instance
       work 2 = SumD FromAlonzoUtxowFail <! From
       work 3 = SumD UnequalCollateralReturn <! From <! From
       work 4 = SumD DanglingWitnessDataHash <! From
+      work 5 = SumD MalformedScripts <! From
       work n = Invalid n
 
 deriving via InspectHeapNamed "BabbageUtxoPred" (BabbageUtxoPred era) instance NoThunks (BabbageUtxoPred era)

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

@@ -23,7 +23,7 @@ import Cardano.Ledger.Alonzo.Rules.Utxow
   )
 import Cardano.Ledger.Alonzo.Scripts (Script)
 import Cardano.Ledger.Alonzo.Tx (ValidatedTx (..))
-import Cardano.Ledger.Alonzo.TxInfo (ExtendedUTxO (..))
+import Cardano.Ledger.Alonzo.TxInfo (ExtendedUTxO (..), validScript)
 import qualified Cardano.Ledger.Alonzo.TxWitness as Alonzo (TxDats (..))
 import Cardano.Ledger.AuxiliaryData (ValidateAuxiliaryData)
 import Cardano.Ledger.Babbage.PParams (PParams' (..))
@@ -120,7 +120,7 @@ validateFailedBabbageScripts ::
   Core.Tx era ->
   UTxO era ->
   Test (Shelley.UtxowPredicateFailure era)
-validateFailedBabbageScripts tx utxo = do
+validateFailedBabbageScripts tx utxo =
   let failedScripts =
         Map.filterWithKey
           ( \hs script ->
@@ -131,8 +131,28 @@ validateFailedBabbageScripts tx utxo = do
                in answer
           )
           (txscripts utxo tx)
-  failureUnless (Map.null failedScripts) $
-    Shelley.ScriptWitnessNotValidatingUTXOW (Map.keysSet failedScripts)
+   in failureUnless
+        (Map.null failedScripts)
+        (Shelley.ScriptWitnessNotValidatingUTXOW $ Map.keysSet failedScripts)
+
+{- ∀x ∈ range(txdats txw) ∪ range(txwitscripts txw) ∪ ⋃ ( , ,d,s)∈txouts tx{s, d},
+                       x ∈ Script ∪ Datum ⇒ isWellFormed x
+-}
+validateScriptsWellFormed ::
+  forall era.
+  ( ExtendedUTxO era,
+    HasField "_protocolVersion" (Core.PParams era) ProtVer,
+    Core.Script era ~ Script era
+  ) =>
+  Core.PParams era ->
+  Core.Tx era ->
+  UTxO era ->
+  Test (BabbageUtxoPred era)
+validateScriptsWellFormed pp tx utxo =
+  let invalidScripts = Map.filter (\script -> not $ validScript (getField @"_protocolVersion" pp) script) (txscripts utxo tx)
+   in failureUnless
+        (Map.null invalidScripts)
+        (MalformedScripts $ Map.keysSet invalidScripts)
 
 -- ==============================================================
 -- Here we define the transtion function, using reusable tests.
@@ -214,6 +234,13 @@ babbageUtxowTransition = do
   runTestOnSignal $
     Shelley.validateMetadata pp tx
 
+  {- ∀x ∈ range(txdats txw) ∪ range(txwitscripts txw) ∪ ⋃ ( , ,d,s)∈txouts tx{s, d},
+                         x ∈ Script ∪ Datum ⇒ isWellFormed x
+  -}
+  -- Datums are currently guarded by the wire format,
+  -- so we assume all datums to be well formed.
+  runTest $ validateScriptsWellFormed pp tx utxo
+
   {- languages tx utxo ⊆ dom(costmdls tx) -}
   -- This check is checked when building the TxInfo using collectTwoPhaseScriptInputs, if it fails
   -- It raises 'NoCostModel' a construcotr of the predicate failure 'CollectError'. This check

eras/babbage/test-suite/src/Test/Cardano/Ledger/Babbage/Serialisation/Generators.hs

@@ -238,5 +238,6 @@ instance Mock c => Arbitrary (BabbageUtxoPred (BabbageEra c)) where
       [ FromAlonzoUtxoFail <$> arbitrary,
         FromAlonzoUtxowFail <$> arbitrary,
         UnequalCollateralReturn <$> arbitrary <*> arbitrary,
-        DanglingWitnessDataHash <$> arbitrary
+        DanglingWitnessDataHash <$> arbitrary,
+        MalformedScripts <$> arbitrary
       ]

libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty/Babbage.hs

@@ -144,6 +144,8 @@ ppBabbageUtxoPred (UnequalCollateralReturn c1 c2) =
     [("collateral needed", ppCoin c1), ("collateral returned", ppCoin c2)]
 ppBabbageUtxoPred (DanglingWitnessDataHash dhset) =
   ppSexp "DanglingWitnessDataHashes" [ppSet ppDataHash dhset]
+ppBabbageUtxoPred (MalformedScripts scripts) =
+  ppSexp "MalformedScripts" [ppSet ppScriptHash scripts]
 
 instance
   ( PrettyA (UtxoPredicateFailure era),

libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/BabbageFeatures.hs

@@ -20,7 +20,7 @@ import Cardano.Ledger.Alonzo.Language (Language (..))
 import Cardano.Ledger.Alonzo.PlutusScriptApi (CollectError (..))
 import Cardano.Ledger.Alonzo.Rules.Utxos (UtxosPredicateFailure (..))
 import Cardano.Ledger.Alonzo.Rules.Utxow (UtxowPredicateFail (..))
-import Cardano.Ledger.Alonzo.Scripts (CostModels (..), ExUnits (..))
+import Cardano.Ledger.Alonzo.Scripts (CostModels (..), ExUnits (..), Script (PlutusScript))
 import qualified Cardano.Ledger.Alonzo.Scripts as Tag (Tag (..))
 import Cardano.Ledger.Alonzo.TxInfo (TranslationError (..))
 import Cardano.Ledger.Alonzo.TxWitness (RdmrPtr (..), Redeemers (..), TxDats (..))
@@ -38,6 +38,7 @@ import qualified Cardano.Ledger.Core as Core
 import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
 import qualified Cardano.Ledger.Crypto as CC
 import Cardano.Ledger.Era (Era (..), ValidateScript (hashScript))
+import Cardano.Ledger.Hashes (ScriptHash)
 import Cardano.Ledger.Keys
   ( KeyPair (..),
     KeyRole (..),
@@ -52,6 +53,7 @@ import Cardano.Ledger.Shelley.UTxO (makeWitnessVKey)
 import Cardano.Ledger.TxIn (TxIn (..), txid)
 import Cardano.Ledger.Val (inject)
 import Control.State.Transition.Extended hiding (Assertion)
+import Data.ByteString.Short (ShortByteString)
 import qualified Data.Compact.SplitMap as SplitMap
 import Data.Default.Class (Default (..))
 import qualified Data.Map as Map
@@ -77,7 +79,7 @@ import Test.Cardano.Ledger.Generic.Fields
   )
 import Test.Cardano.Ledger.Generic.PrettyCore ()
 import Test.Cardano.Ledger.Generic.Proof
-import Test.Cardano.Ledger.Generic.Scriptic (PostShelley, Scriptic (..))
+import Test.Cardano.Ledger.Generic.Scriptic (PostShelley (after), Scriptic (..), matchkey)
 import Test.Cardano.Ledger.Generic.Updaters
 import Test.Cardano.Ledger.Shelley.Generator.EraGen (genesisId)
 import Test.Cardano.Ledger.Shelley.Utils (RawSeed (..), mkKeyPair)
@@ -218,6 +220,9 @@ collateralInput11 = mkGenesisTxIn 11
 collateralInput17 :: (CH.HashAlgorithm (CC.HASH crypto), HasCallStack) => TxIn crypto
 collateralInput17 = mkGenesisTxIn 17
 
+referenceScriptInput3 :: (CH.HashAlgorithm (CC.HASH crypto), HasCallStack) => TxIn crypto
+referenceScriptInput3 = mkGenesisTxIn 18
+
 --
 -- Genesis UTxO
 --
@@ -235,7 +240,8 @@ initUTxO pf =
         (failsEUTxOInput, failsEUTxO pf),
         (inlineDatumInputV1, inlineDatumOutputV1 pf),
         (collateralInput11, collateralOutput pf),
-        (collateralInput17, collateralOutput pf)
+        (collateralInput17, collateralOutput pf),
+        (referenceScriptInput3, malformedScriptsTxOut pf)
       ]
 
 defaultPPs :: [PParamsField era]
@@ -735,6 +741,81 @@ class BabbageBased era failure where
 instance BabbageBased (BabbageEra c) (BabbageUtxoPred (BabbageEra c)) where
   fromUtxoB = id
 
+-- ====================================================================================
+--  Example 12: Invalid - Malformed plutus scripts
+-- ====================================================================================
+
+plutusScriptHash ::
+  forall era.
+  PostShelley era =>
+  Int ->
+  Proof era ->
+  ScriptHash (Crypto era)
+plutusScriptHash n pf = hashScript @era $ plutusScript n pf
+
+plutusScript :: PostShelley era => Int -> Proof era -> Core.Script era
+plutusScript s = allOf [matchkey 1, after (100 + s)]
+
+malformedScriptsTx ::
+  forall era.
+  ( Scriptic era,
+    GoodCrypto (Crypto era)
+  ) =>
+  Proof era ->
+  Core.Tx era
+malformedScriptsTx pf =
+  newTx
+    pf
+    [ Body txb,
+      WitnessesI
+        [ ScriptWits' [malformedScript pf "rs"],
+          AddrWits' [makeWitnessVKey (hashAnnotated txb) (someKeys pf)]
+        ]
+    ]
+  where
+    txb = malformedScriptsTxBody pf
+
+malformedScriptsTxBody ::
+  forall era.
+  (Scriptic era) =>
+  Proof era ->
+  Core.TxBody era
+malformedScriptsTxBody pf =
+  newTxBody
+    pf
+    [ Outputs' [malformedScriptsTxOut pf],
+      WppHash (newScriptIntegrityHash pf (pp pf) [PlutusV2] (Redeemers mempty) mempty),
+      Inputs' [referenceScriptInput3]
+    ]
+
+malformedScriptsTxOut ::
+  Era era =>
+  Proof era ->
+  Core.TxOut era
+malformedScriptsTxOut pf =
+  newTxOut
+    pf
+    [ Address (plainAddr pf),
+      Amount (inject $ Coin 5000),
+      RefScript' [malformedScript pf "rs"]
+    ]
+
+malformedScript :: forall era. Proof era -> ShortByteString -> Core.Script era
+malformedScript pf s = case pf of
+  Babbage {} -> ms
+  Alonzo {} -> ms
+  x@Shelley {} -> er x
+  x@Mary {} -> er x
+  x@Allegra {} -> er x
+  where
+    ms :: Script era
+    ms = PlutusScript PlutusV2 $ "nonsense " <> s
+    er x = error $ "no malformedScript for " <> show x
+
+-- ====================================================================================
+--
+-- ====================================================================================
+
 testU ::
   forall era.
   ( GoodCrypto (Crypto era),
@@ -818,6 +899,11 @@ genericBabbageFeatures pf =
               pf
               (trustMeP pf True $ incorrectCollateralTotalTx pf)
               (Left [fromUtxoB @era (UnequalCollateralReturn (Coin 5) (Coin 6))]),
+          testCase "malformed scripts" $
+            testU
+              pf
+              (trustMeP pf True $ malformedScriptsTx pf)
+              (Left [fromUtxoB @era (MalformedScripts (Set.fromList [hashScript @era $ malformedScript pf "rs"]))]),
           testCase "inline datum with redundant datum witness" $
             testU
               pf