Merge pull request #2210 from input-output-hk/ts-better-collectNNScri…

…ptInputs

Improve collectNNScriptInputs

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

@@ -1,5 +1,7 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -15,9 +17,12 @@ module Cardano.Ledger.Alonzo.PlutusScriptApi
     scriptsNeeded,
     checkScriptData,
     language,
+    CollectError (..),
+    collectTwoPhaseScriptInputs,
   )
 where
 
+import Cardano.Binary (FromCBOR (..), ToCBOR (..))
 import Cardano.Ledger.Alonzo.Data (getPlutusData)
 import Cardano.Ledger.Alonzo.Language (Language (..))
 import Cardano.Ledger.Alonzo.Scripts (CostModel, ExUnits (..))
@@ -37,17 +42,21 @@ import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo (TxBody (..), TxOut (..)
 import Cardano.Ledger.Alonzo.TxInfo (runPLCScript, transTx, valContext)
 import Cardano.Ledger.Alonzo.TxWitness (TxWitness (txwitsVKey'), txscripts')
 import qualified Cardano.Ledger.Core as Core
+import qualified Cardano.Ledger.Crypto as CC (Crypto)
 import Cardano.Ledger.Era (Crypto, Era, ValidateScript (..))
 import Cardano.Ledger.Mary.Value (PolicyID (..))
 import qualified Cardano.Ledger.Mary.Value as Mary (Value (..))
 import Cardano.Ledger.ShelleyMA.Timelocks (evalTimelock)
+import Data.Coders
 import Data.List (foldl')
 import qualified Data.Map as Map
 import Data.Maybe (isJust, maybeToList)
 import Data.Sequence.Strict (StrictSeq)
 import Data.Set (Set)
 import qualified Data.Set as Set
+import GHC.Generics
 import GHC.Records (HasField (..))
+import NoThunks.Class (NoThunks)
 import Shelley.Spec.Ledger.Address (Addr)
 import Shelley.Spec.Ledger.BaseTypes (StrictMaybe (..))
 import Shelley.Spec.Ledger.Credential (Credential (ScriptHashObj))
@@ -119,6 +128,85 @@ collectNNScriptInputs pp tx utxo =
           cost <- maybeToList (Map.lookup PlutusV1 (getField @"_costmdls" pp))
       ]
 
+-- ========================================================================
+
+-- | When collecting inputs for twophase scripts, 3 things can go wrong.
+data CollectError crypto
+  = NoRedeemer !(ScriptPurpose crypto)
+  | NoWitness !(ScriptHash crypto)
+  | NoCostModel !Language
+  deriving (Eq, Show, Generic, NoThunks)
+
+instance (CC.Crypto crypto) => ToCBOR (CollectError crypto) where
+  toCBOR (NoRedeemer x) = encode $ Sum NoRedeemer 0 !> To x
+  toCBOR (NoWitness x) = encode $ Sum NoWitness 1 !> To x
+  toCBOR (NoCostModel x) = encode $ Sum NoCostModel 2 !> To x
+
+instance (CC.Crypto crypto) => FromCBOR (CollectError crypto) where
+  fromCBOR = decode (Summands "CollectError" dec)
+    where
+      dec 0 = SumD NoRedeemer <! From
+      dec 1 = SumD NoWitness <! From
+      dec 2 = SumD NoCostModel <! From
+      dec n = Invalid n
+
+-- | Collect the inputs for twophase scripts. If any script can't find ist data return
+--     a list of CollectError, if all goes well return a list of quadruples with the inputs.
+--     Previous PredicateFailure tests should ensure we find Data for every script, BUT
+--     the consequences of not finding Data means scripts can get dropped, so things
+--     might validate that shouldn't. So we double check that every Script has its Data, and
+--     if that is not the case, a PredicateFailure is raised in the Utxos rule.
+collectTwoPhaseScriptInputs ::
+  ( Era era,
+    Core.Script era ~ AlonzoScript.Script era,
+    Core.TxOut era ~ Alonzo.TxOut era,
+    Core.TxBody era ~ Alonzo.TxBody era,
+    Core.Value era ~ Mary.Value (Crypto era),
+    HasField "datahash" (Core.TxOut era) (StrictMaybe (DataHash (Crypto era))),
+    HasField "_costmdls" (Core.PParams era) (Map.Map Language CostModel),
+    HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)),
+    HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))),
+    HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era)))
+  ) =>
+  Core.PParams era ->
+  Tx era ->
+  UTxO era ->
+  Either [CollectError (Crypto era)] [(AlonzoScript.Script era, [Data era], ExUnits, CostModel)]
+collectTwoPhaseScriptInputs pp tx utxo =
+  case Map.lookup PlutusV1 (getField @"_costmdls" pp) of
+    Nothing -> Left [NoCostModel PlutusV1]
+    Just cost -> merge (apply cost) (map redeemer needed) (map getscript needed) (Right [])
+  where
+    txinfo = transTx utxo tx
+    needed = scriptsNeeded utxo tx
+    redeemer (sp, _) =
+      case indexedRdmrs tx sp of
+        Just (d, eu) -> Right (sp, d, eu)
+        Nothing -> Left (NoRedeemer sp)
+    getscript (_, hash) =
+      case Map.lookup hash (txscripts' (getField @"wits" tx)) of
+        Just script -> Right script
+        Nothing -> Left (NoWitness hash)
+    apply cost (sp, d, eu) script = (script, d : (valContext txinfo sp) : (getData tx utxo sp), eu, cost)
+
+-- | Merge two lists (either of which may have failures, i.e. (Left _)), collect all the failures
+--   but if there are none, use 'f' to construct a success.
+merge :: forall t1 t2 a1 a2. (t1 -> t2 -> a1) -> [Either a2 t1] -> [Either a2 t2] -> Either [a2] [a1] -> Either [a2] [a1]
+merge _f [] [] answer = answer
+merge _f [] (_ : _) answer = answer
+merge _f (_ : _) [] answer = answer
+merge f (x : xs) (y : ys) zs = merge f xs ys (gg x y zs)
+  where
+    gg :: Either a2 t1 -> Either a2 t2 -> Either [a2] [a1] -> Either [a2] [a1]
+    gg (Right a) (Right b) (Right cs) = Right (f a b : cs) -- The one place a success occurs.
+    gg (Left a) (Right _) (Right _) = Left [a]
+    gg (Right _) (Left b) (Right _) = Left [b]
+    gg (Left a) (Left b) (Right _) = Left [a, b]
+    gg (Right _) (Right _) (Left cs) = Left cs
+    gg (Right _) (Left b) (Left cs) = Left (b : cs)
+    gg (Left a) (Right _) (Left cs) = Left (a : cs)
+    gg (Left a) (Left b) (Left cs) = Left (a : b : cs)
+
 language :: AlonzoScript.Script era -> Maybe Language
 language (AlonzoScript.PlutusScript _) = Just PlutusV1
 language (AlonzoScript.TimelockScript _) = Nothing

alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs

@@ -13,7 +13,11 @@ module Cardano.Ledger.Alonzo.Rules.Utxos where
 
 import Cardano.Binary (FromCBOR (..), ToCBOR (..))
 import Cardano.Ledger.Alonzo.Language (Language)
-import Cardano.Ledger.Alonzo.PlutusScriptApi (collectNNScriptInputs, evalScripts)
+import Cardano.Ledger.Alonzo.PlutusScriptApi
+  ( CollectError,
+    collectTwoPhaseScriptInputs,
+    evalScripts,
+  )
 import Cardano.Ledger.Alonzo.Scripts (Script)
 import Cardano.Ledger.Alonzo.Tx
   ( CostModel,
@@ -38,7 +42,6 @@ import Data.Foldable (toList)
 import qualified Data.Map.Strict as Map
 import Data.Sequence.Strict (StrictSeq)
 import Data.Set (Set)
-import Data.Typeable (Typeable)
 import GHC.Generics (Generic)
 import GHC.Records (HasField (..))
 import NoThunks.Class (NoThunks)
@@ -110,12 +113,14 @@ utxosTransition ::
   ) =>
   TransitionRule (UTXOS era)
 utxosTransition =
-  judgmentContext >>= \(TRC (UtxoEnv _ pp _ _, UTxOState utxo _ _ _, tx)) ->
-    let sLst = collectNNScriptInputs pp tx utxo
-        scriptEvalResult = evalScripts @era tx sLst
-     in if scriptEvalResult
-          then scriptsValidateTransition
-          else scriptsNotValidateTransition
+  judgmentContext >>= \(TRC (UtxoEnv _ pp _ _, st@(UTxOState utxo _ _ _), tx)) -> do
+    case collectTwoPhaseScriptInputs pp tx utxo of
+      Right sLst ->
+        let scriptEvalResult = evalScripts @era tx sLst
+         in if scriptEvalResult
+              then scriptsValidateTransition
+              else scriptsNotValidateTransition
+      Left info -> (failBecause $ ShouldNeverHappenScriptInputsNotFound info) >> pure st
 
 scriptsValidateTransition ::
   forall era.
@@ -186,29 +191,38 @@ data UtxosPredicateFailure era
     --   here is that provided on the transaction (whereas evaluation of the
     --   scripts gives the opposite.)
     ValidationTagMismatch IsValidating
+  | -- | We could not find all the necessary inputs for a Plutus Script.
+    --         Previous PredicateFailure tests should make this impossible, but the
+    --         consequences of not detecting this means scripts get dropped, so things
+    --         might validate that shouldn't. So we double check in the function
+    --         collectTwoPhaseScriptInputs, it should find data for every Script.
+    ShouldNeverHappenScriptInputsNotFound [CollectError (Crypto era)]
   | UpdateFailure (PredicateFailure (Core.EraRule "PPUP" era))
   deriving
     (Generic)
 
 instance
-  ( Typeable era,
+  ( Era era,
     ToCBOR (PredicateFailure (Core.EraRule "PPUP" era))
   ) =>
   ToCBOR (UtxosPredicateFailure era)
   where
   toCBOR (ValidationTagMismatch v) = encode (Sum ValidationTagMismatch 0 !> To v)
-  toCBOR (UpdateFailure pf) = encode (Sum (UpdateFailure @era) 1 !> To pf)
+  toCBOR (ShouldNeverHappenScriptInputsNotFound cs) =
+    encode (Sum (ShouldNeverHappenScriptInputsNotFound @era) 1 !> To cs)
+  toCBOR (UpdateFailure pf) = encode (Sum (UpdateFailure @era) 2 !> To pf)
 
 instance
-  ( Typeable era,
+  ( Era era,
     FromCBOR (PredicateFailure (Core.EraRule "PPUP" era))
   ) =>
   FromCBOR (UtxosPredicateFailure era)
   where
   fromCBOR = decode (Summands "UtxosPredicateFailure" dec)
     where
       dec 0 = SumD ValidationTagMismatch <! From
-      dec 1 = SumD UpdateFailure <! From
+      dec 1 = SumD (ShouldNeverHappenScriptInputsNotFound @era) <! From
+      dec 2 = SumD UpdateFailure <! From
       dec n = Invalid n
 
 deriving stock instance