Merge pull request #2674 from input-output-hk/ts-babbage-unittests

Generalized the generic unit tests in TwoPhaseValidation.hs

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

@@ -169,6 +169,7 @@ instance
 
 instance CC.Crypto c => UsesTxOut (AlonzoEra c) where
   makeTxOut _proxy addr val = TxOut addr val SNothing
+  getTxOutExtras (TxOut _ _ dhashM) = (dhashM, SNothing)
 
 instance CC.Crypto c => API.CLI (AlonzoEra c) where
   evaluateMinFee = minfee

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

@@ -53,13 +53,9 @@ import Cardano.Ledger.BaseTypes (StrictMaybe (..))
 import qualified Cardano.Ledger.Core as Core
 import qualified Cardano.Ledger.Crypto as CC
 import Cardano.Ledger.Era (Crypto, Era)
-import Cardano.Ledger.Hashes
-  ( EraIndependentAuxiliaryData,
-    EraIndependentData,
-  )
+import Cardano.Ledger.Hashes (DataHash, EraIndependentAuxiliaryData, EraIndependentData)
 import Cardano.Ledger.SafeHash
   ( HashAnnotated,
-    SafeHash,
     SafeToHash (..),
     hashAnnotated,
   )
@@ -172,8 +168,6 @@ hashBinaryData = hashAnnotated
 
 -- =============================================================================
 
-type DataHash crypto = SafeHash crypto EraIndependentData
-
 hashData :: Era era => Data era -> DataHash (Crypto era)
 hashData = hashAnnotated
 

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs

@@ -29,8 +29,8 @@ import Cardano.Ledger.Alonzo.Tx
   ( ScriptPurpose,
     ValidatedTx (..),
     hashScriptIntegrity,
-    isTwoPhaseScriptAddress,
     rdptr,
+    txInputHashes,
   )
 import Cardano.Ledger.Alonzo.TxBody (ScriptIntegrityHash)
 import Cardano.Ledger.Alonzo.TxWitness
@@ -54,6 +54,7 @@ import Cardano.Ledger.Hashes (EraIndependentData, EraIndependentTxBody)
 import Cardano.Ledger.Keys (GenDelegs, KeyHash, KeyRole (..), asWitness)
 import Cardano.Ledger.Rules.ValidationMode (Inject (..), Test, runTest, runTestOnSignal)
 import Cardano.Ledger.SafeHash (SafeHash)
+import Cardano.Ledger.Shelley.Constraints (UsesTxOut (..))
 import Cardano.Ledger.Shelley.Delegation.Certificates
   ( delegCWitness,
     genesisCWitness,
@@ -89,7 +90,6 @@ import Control.Monad.Trans.Reader (asks)
 import Control.SetAlgebra (domain, eval, (⊆), (➖))
 import Control.State.Transition.Extended
 import Data.Coders
-import qualified Data.Compact.SplitMap as SplitMap
 import Data.Foldable (sequenceA_, toList)
 import qualified Data.Map.Strict as Map
 import Data.Sequence.Strict (StrictSeq)
@@ -225,51 +225,36 @@ missingRequiredDatums ::
       (StrictMaybe (SafeHash (Crypto era) EraIndependentData)),
     ValidateScript era,
     HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))),
-    Core.Script era ~ Script era -- from txdats
+    Core.Script era ~ Script era,
+    UsesTxOut era
   ) =>
+  Map.Map (ScriptHash (Crypto era)) (Core.Script era) ->
   UTxO era ->
   ValidatedTx era ->
   Core.TxBody era ->
   Test (UtxowPredicateFail era)
-missingRequiredDatums utxo tx txbody = do
-  let {- inputHashes := {h | ( _ → (a, , h)) ∈ txins txb ◁ utxo, isTwoPhaseScriptAddress tx a} -}
-      inputs = getField @"inputs" txbody :: (Set (TxIn (Crypto era)))
-      smallUtxo = inputs SplitMap.◁ unUTxO utxo
-      twoPhaseOuts =
-        [ output
-          | (_input, output) <- SplitMap.toList smallUtxo,
-            isTwoPhaseScriptAddress @era tx (getTxOutAddr output)
-        ]
-      utxoHashes' = mapM (getField @"datahash") twoPhaseOuts
-  case utxoHashes' of
-    SNothing ->
-      -- In the spec, the Nothing value can end up on the left hand side
-      -- of the equality check, but we must explicitly rule it out.
-      failure . UnspendableUTxONoDatumHash . Set.fromList $
-        [ input
-          | (input, output) <- SplitMap.toList smallUtxo,
-            SNothing <- [getField @"datahash" output],
-            isTwoPhaseScriptAddress @era tx (getTxOutAddr output)
-        ]
-    SJust utxoHashes -> do
-      let txHashes = domain (unTxDats . txdats . wits $ tx)
-          inputHashes = Set.fromList utxoHashes
-          unmatchedDatumHashes = eval (inputHashes ➖ txHashes)
-          outputDatumHashes =
-            Set.fromList
-              [ dh | out <- toList (getField @"outputs" txbody), SJust dh <- [getField @"datahash" out]
-              ]
-          supplimentalDatumHashes = eval (txHashes ➖ inputHashes)
-          (okSupplimentalDHs, notOkSupplimentalDHs) =
-            Set.partition (`Set.member` outputDatumHashes) supplimentalDatumHashes
-      sequenceA_
-        [ failureUnless
-            (Set.null unmatchedDatumHashes)
-            (MissingRequiredDatums unmatchedDatumHashes txHashes),
-          failureUnless
-            (Set.null notOkSupplimentalDHs)
-            (NonOutputSupplimentaryDatums notOkSupplimentalDHs okSupplimentalDHs)
-        ]
+missingRequiredDatums scriptwits utxo tx txbody = do
+  let (inputHashes, txinsNoDhash) = txInputHashes scriptwits tx utxo
+      txHashes = domain (unTxDats . txdats . wits $ tx)
+      unmatchedDatumHashes = eval (inputHashes ➖ txHashes)
+      outputDatumHashes =
+        Set.fromList
+          [ dh | out <- toList (getField @"outputs" txbody), SJust dh <- [getField @"datahash" out]
+          ]
+      supplimentalDatumHashes = eval (txHashes ➖ inputHashes)
+      (okSupplimentalDHs, notOkSupplimentalDHs) =
+        Set.partition (`Set.member` outputDatumHashes) supplimentalDatumHashes
+  sequenceA_
+    [ failureUnless
+        (Set.null txinsNoDhash)
+        (UnspendableUTxONoDatumHash txinsNoDhash),
+      failureUnless
+        (Set.null unmatchedDatumHashes)
+        (MissingRequiredDatums unmatchedDatumHashes txHashes),
+      failureUnless
+        (Set.null notOkSupplimentalDHs)
+        (NonOutputSupplimentaryDatums notOkSupplimentalDHs okSupplimentalDHs)
+    ]
 
 -- ==================
 {-  dom (txrdmrs tx) = { rdptr txb sp | (sp, h) ∈ scriptsNeeded utxo tx,
@@ -356,6 +341,7 @@ alonzoStyleWitness ::
   forall era.
   ( ValidateScript era,
     ValidateAuxiliaryData era (Crypto era),
+    UsesTxOut era,
     -- Fix some Core types to the Alonzo Era
     ConcreteAlonzo era,
     Core.Tx era ~ ValidatedTx era,
@@ -390,7 +376,7 @@ alonzoStyleWitness = do
 
   {- inputHashes := { h | (_ → (a,_,h)) ∈ txins tx ◁ utxo, isTwoPhaseScriptAddress tx a} -}
   {-  inputHashes ⊆ dom(txdats txw)  -}
-  runTest $ missingRequiredDatums utxo tx txbody
+  runTest $ missingRequiredDatums (getField @"scriptWits" tx) utxo tx txbody
 
   {- dom(txdats txw) ⊆ inputHashes ∪ {h | ( , , h) ∈ txouts tx -}
   -- This is incorporated into missingRequiredDatums, see the
@@ -534,6 +520,7 @@ data AlonzoUTXOW era
 instance
   forall era.
   ( ValidateScript era,
+    UsesTxOut era,
     ValidateAuxiliaryData era (Crypto era),
     Signable (DSIGN (Crypto era)) (Hash (HASH (Crypto era)) EraIndependentTxBody),
     -- Fix some Core types to the Alonzo Era

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
@@ -48,6 +49,8 @@ module Cardano.Ledger.Alonzo.Tx
     --  Figure 5
     minfee,
     isTwoPhaseScriptAddress,
+    isTwoPhaseScriptAddressFromMap,
+    txInputHashes,
     Shelley.txouts,
     -- Figure 6
     txrdmrs,
@@ -106,7 +109,8 @@ import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Compactible
 import qualified Cardano.Ledger.Core as Core
 import qualified Cardano.Ledger.Crypto as CC
-import Cardano.Ledger.Era (Crypto, Era, ValidateScript (isNativeScript))
+import Cardano.Ledger.Era (Crypto, Era, ValidateScript (hashScript, isNativeScript))
+import Cardano.Ledger.Hashes (ScriptHash)
 import Cardano.Ledger.Keys (KeyRole (Witness))
 import Cardano.Ledger.Mary.Value (AssetName, PolicyID (..), Value (..))
 import Cardano.Ledger.SafeHash
@@ -115,15 +119,17 @@ import Cardano.Ledger.SafeHash
     hashAnnotated,
   )
 import Cardano.Ledger.Shelley.Address.Bootstrap (BootstrapWitness)
+import Cardano.Ledger.Shelley.Constraints (UsesTxOut (..), txOutView)
 import Cardano.Ledger.Shelley.Delegation.Certificates (DCert (..))
-import Cardano.Ledger.Shelley.Scripts (ScriptHash)
 import Cardano.Ledger.Shelley.TxBody (Wdrl (..), WitVKey, unWdrl)
+import Cardano.Ledger.Shelley.UTxO (UTxO (..))
 import qualified Cardano.Ledger.Shelley.UTxO as Shelley
 import Cardano.Ledger.TxIn (TxIn (..))
 import Cardano.Ledger.Val (Val (coin, (<+>), (<×>)))
 import Control.DeepSeq (NFData (..))
 import qualified Data.ByteString.Lazy as LBS
 import Data.Coders
+import qualified Data.Compact.SplitMap as SplitMap
 import qualified Data.Map as Map
 import Data.Maybe.Strict
   ( StrictMaybe (..),
@@ -271,13 +277,7 @@ isTwoPhaseScriptAddress ::
   ValidatedTx era ->
   Addr (Crypto era) ->
   Bool
-isTwoPhaseScriptAddress tx addr =
-  case Shelley.getScriptHash addr of
-    Nothing -> False
-    Just hash ->
-      case Map.lookup hash (getField @"scriptWits" tx) of
-        Nothing -> False
-        Just scr -> not (isNativeScript @era scr)
+isTwoPhaseScriptAddress tx addr = isTwoPhaseScriptAddressFromMap @era (getField @"scriptWits" tx) addr
 
 -- | txsize computes the length of the serialised bytes
 instance
@@ -541,3 +541,56 @@ instance
           ( sequence . maybeToStrictMaybe
               <$> decodeNullMaybe fromCBOR
           )
+
+-- =======================================================================
+-- Some generic functions that compute over Tx. We try to be abstract over
+-- things that might differ from Era to Era like
+--    1) TxOut might have additional fields (uses txOutView from UsesTxOut)
+--    2) Scripts might appear in places other than the witness set. So
+--       we need such a 'witness' we pass it as a parameter and each call site
+--       can use a different method to compute it in the current Era.
+
+-- | Compute if an Addr has the hash of a TwoPhaseScript, we can tell
+--   what kind of Script from the Hash, by looking it up in the Map
+isTwoPhaseScriptAddressFromMap ::
+  forall era.
+  (ValidateScript era) =>
+  Map.Map (ScriptHash (Crypto era)) (Core.Script era) ->
+  Addr (Crypto era) ->
+  Bool
+isTwoPhaseScriptAddressFromMap hashScriptMap addr =
+  case Shelley.getScriptHash @(Crypto era) addr of
+    Nothing -> False
+    Just hash -> any ok hashScriptMap
+      where
+        ok script = hashScript @era script == hash && not (isNativeScript @era script)
+
+-- Compute two sets for all TwoPhase scripts in a Tx.
+-- set 1) DataHashes for each Two phase Script in a TxIn that has a DataHash
+-- set 2) TxIns that are TwoPhase scripts, and should have a DataHash, but don't.
+{- { h | (_ → (a,_,h)) ∈ txins tx ◁ utxo, isNonNativeScriptAddress tx a} -}
+txInputHashes ::
+  forall era.
+  ( HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))),
+    UsesTxOut era,
+    ValidateScript era
+  ) =>
+  Map.Map (ScriptHash (Crypto era)) (Core.Script era) ->
+  ValidatedTx era ->
+  UTxO era ->
+  (Set (DataHash (Crypto era)), Set (TxIn (Crypto era)))
+txInputHashes hashScriptMap tx (UTxO mp) = SplitMap.foldlWithKey' accum (Set.empty, Set.empty) smallUtxo
+  where
+    txbody = body tx
+    spendinputs = getField @"inputs" txbody :: (Set (TxIn (Crypto era)))
+    smallUtxo = spendinputs SplitMap.◁ mp
+    accum ans@(hashSet, inputSet) txin txout =
+      case txOutView @era txout of
+        (addr, _, SNothing, _) ->
+          if isTwoPhaseScriptAddressFromMap @era hashScriptMap addr
+            then (hashSet, Set.insert txin inputSet)
+            else ans
+        (addr, _, SJust dhash, _) ->
+          if isTwoPhaseScriptAddressFromMap @era hashScriptMap addr
+            then (Set.insert dhash hashSet, inputSet)
+            else ans

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

@@ -171,6 +171,8 @@ instance
 
 instance CC.Crypto c => UsesTxOut (BabbageEra c) where
   makeTxOut _proxy addr val = TxOut addr val NoDatum SNothing
+  getTxOutExtras (TxOut _ _ (DatumHash h) scriptM) = (SJust h, scriptM)
+  getTxOutExtras (TxOut _ _ _ scriptM) = (SNothing, scriptM)
 
 instance CC.Crypto c => API.CLI (BabbageEra c) where
   evaluateMinFee = minfee

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

@@ -10,7 +10,7 @@
 module Cardano.Ledger.Babbage.Collateral where
 
 import Cardano.Ledger.Address (Addr (..))
-import Cardano.Ledger.Alonzo.TxWitness (TxWitness)
+import Cardano.Ledger.Alonzo.Tx (isTwoPhaseScriptAddressFromMap)
 import Cardano.Ledger.Babbage.Scripts (txscripts)
 import Cardano.Ledger.Babbage.TxBody
   ( TxBody (..),
@@ -24,7 +24,8 @@ import Cardano.Ledger.BaseTypes (txIxFromIntegral)
 import Cardano.Ledger.Coin (Coin (..))
 import qualified Cardano.Ledger.Core as Core
 import Cardano.Ledger.Era (Era (Crypto), ValidateScript (..))
-import Cardano.Ledger.Shelley.UTxO (UTxO (..), balance, getScriptHash)
+import Cardano.Ledger.Shelley.Constraints (UsesTxOut (..))
+import Cardano.Ledger.Shelley.UTxO (UTxO (..), balance)
 import Cardano.Ledger.TxIn (TxIn (..), txid)
 import Cardano.Ledger.Val ((<->))
 import Data.Compact.SplitMap ((◁))
@@ -37,21 +38,15 @@ import Numeric.Natural (Natural)
 
 isTwoPhaseScriptAddress ::
   forall era.
-  ( ValidateScript era,
-    Core.Witnesses era ~ TxWitness era,
-    Core.TxBody era ~ TxBody era,
-    Core.TxOut era ~ TxOut era
+  ( UsesTxOut era,
+    ValidateScript era,
+    Core.TxBody era ~ TxBody era
   ) =>
   Core.Tx era ->
   UTxO era ->
   Addr (Crypto era) ->
   Bool
-isTwoPhaseScriptAddress tx utxo addr =
-  case getScriptHash addr of
-    Nothing -> False
-    Just hash -> any ok (txscripts utxo tx)
-      where
-        ok script = hashScript @era script == hash && not (isNativeScript @era script)
+isTwoPhaseScriptAddress tx utxo addr = isTwoPhaseScriptAddressFromMap @era (txscripts utxo tx) addr
 
 minCollateral ::
   HasField "_collateralPercentage" (Core.PParams era) Natural =>

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

@@ -102,7 +102,6 @@ data BabbageUtxoPred era
   = FromAlonzoUtxoFail !(UtxoPredicateFailure era) -- Inherited from Alonzo
   | FromAlonzoUtxowFail !(UtxowPredicateFail era)
   | UnequalCollateralReturn !Coin !Coin
-  | UnknownDataHash !(Set.Set (DataHash (Crypto era)))
   | DanglingWitnessDataHash !(Set.Set (DataHash (Crypto era)))
 
 deriving instance
@@ -363,7 +362,6 @@ instance
       work (FromAlonzoUtxoFail x) = Sum FromAlonzoUtxoFail 1 !> To x
       work (FromAlonzoUtxowFail x) = Sum FromAlonzoUtxowFail 2 !> To x
       work (UnequalCollateralReturn c1 c2) = Sum UnequalCollateralReturn 3 !> To c1 !> To c2
-      work (UnknownDataHash x) = Sum UnknownDataHash 4 !> To x
       work (DanglingWitnessDataHash x) = Sum DanglingWitnessDataHash 5 !> To x
 
 instance
@@ -383,7 +381,6 @@ instance
       work 1 = SumD FromAlonzoUtxoFail <! From
       work 2 = SumD FromAlonzoUtxowFail <! From
       work 3 = SumD UnequalCollateralReturn <! From <! From
-      work 4 = SumD UnknownDataHash <! From
       work 5 = SumD DanglingWitnessDataHash <! From
       work n = Invalid n