Merge pull request #2272 from input-output-hk/jc/utxow-examples-with-…

…timelocks

More Alonzo unit tests & clean-up

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

@@ -2,7 +2,6 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -136,8 +135,7 @@ instance API.PraosCrypto c => API.ApplyTx (AlonzoEra c) where
             $ TRC (env, state, tx)
      in liftEither . left (API.ApplyTxError . join) $ res
 
-  extractTx ValidatedTx {body, wits, auxiliaryData} =
-    Tx body wits auxiliaryData
+  extractTx ValidatedTx {body = b, wits = w, auxiliaryData = a} = Tx b w a
 
 instance API.PraosCrypto c => API.ApplyBlock (AlonzoEra c)
 

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

@@ -158,7 +158,15 @@ collectTwoPhaseScriptInputs ei sysS pp tx utxo =
     Just cost -> merge (apply cost) (map redeemer needed) (map getscript needed) (Right [])
   where
     txinfo = txInfo ei sysS utxo tx
-    needed = scriptsNeeded utxo tx
+    needed = filter knownToNotBe1Phase $ scriptsNeeded utxo tx
+    -- The formal spec achieves the same filtering as knownToNotBe1Phase
+    -- by use of the (partial) language function, which is not defined
+    -- on 1-phase scripts.
+    knownToNotBe1Phase (_, sh) =
+      case sh `Map.lookup` (txscripts' $ getField @"wits" tx) of
+        Just (AlonzoScript.PlutusScript _) -> True
+        Just (AlonzoScript.TimelockScript _) -> False
+        Nothing -> True
     redeemer (sp, _) =
       case indexedRdmrs tx sp of
         Just (d, eu) -> Right (sp, d, eu)

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

@@ -175,7 +175,7 @@ scriptsValidateTransition = do
     Right sLst ->
       evalScripts @era tx sLst
         ?!# ValidationTagMismatch (getField @"isValidating" tx)
-    Left info -> failBecause (ShouldNeverHappenScriptInputsNotFound info)
+    Left info -> failBecause (CollectErrors info)
   pup' <-
     trans @(Core.EraRule "PPUP" era) $
       TRC
@@ -218,7 +218,7 @@ scriptsNotValidateTransition = do
     Right sLst ->
       not (evalScripts @era tx sLst)
         ?!# ValidationTagMismatch (getField @"isValidating" tx)
-    Left info -> failBecause (ShouldNeverHappenScriptInputsNotFound info)
+    Left info -> failBecause (CollectErrors info)
   getField @"isValidating" tx == IsValidating False
     ?!# ValidationTagMismatch (getField @"isValidating" tx)
   pure $
@@ -237,7 +237,7 @@ data UtxosPredicateFailure era
     --         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)]
+    CollectErrors [CollectError (Crypto era)]
   | UpdateFailure (PredicateFailure (Core.EraRule "PPUP" era))
   deriving
     (Generic)
@@ -249,8 +249,8 @@ instance
   ToCBOR (UtxosPredicateFailure era)
   where
   toCBOR (ValidationTagMismatch v) = encode (Sum ValidationTagMismatch 0 !> To v)
-  toCBOR (ShouldNeverHappenScriptInputsNotFound cs) =
-    encode (Sum (ShouldNeverHappenScriptInputsNotFound @era) 1 !> To cs)
+  toCBOR (CollectErrors cs) =
+    encode (Sum (CollectErrors @era) 1 !> To cs)
   toCBOR (UpdateFailure pf) = encode (Sum (UpdateFailure @era) 2 !> To pf)
 
 instance
@@ -262,7 +262,7 @@ instance
   fromCBOR = decode (Summands "UtxosPredicateFailure" dec)
     where
       dec 0 = SumD ValidationTagMismatch <! From
-      dec 1 = SumD (ShouldNeverHappenScriptInputsNotFound @era) <! From
+      dec 1 = SumD (CollectErrors @era) <! From
       dec 2 = SumD UpdateFailure <! From
       dec n = Invalid n
 
@@ -328,7 +328,7 @@ constructValidated ::
   m (UTxOState era, ValidatedTx era)
 constructValidated globals env@(UtxoEnv _ pp _ _) st tx =
   case collectTwoPhaseScriptInputs ei sysS pp tx utxo of
-    Left errs -> throwError [ShouldNeverHappenScriptInputsNotFound errs]
+    Left errs -> throwError [CollectErrors errs]
     Right sLst ->
       let scriptEvalResult = evalScripts @era tx sLst
           vTx =

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

@@ -66,7 +66,6 @@ import Shelley.Spec.Ledger.Tx (TxIn (..))
 data AlonzoPredFail era
   = WrappedShelleyEraFailure !(UtxowPredicateFailure era)
   | UnRedeemableScripts ![(ScriptPurpose (Crypto era), ScriptHash (Crypto era))]
-  | MissingNeededScriptHash (Set (ScriptHash (Crypto era)))
   | DataHashSetsDontAgree
       !(Set (DataHash (Crypto era)))
       -- ^ from the Tx
@@ -78,9 +77,6 @@ data AlonzoPredFail era
       !(StrictMaybe (WitnessPPDataHash (Crypto era)))
       -- ^ Computed from the current Protocol Parameters
   | MissingRequiredSigners (Set (KeyHash 'Witness (Crypto era)))
-  | -- | Scripts that failed
-    Phase1ScriptWitnessNotValidating
-      !(Set (ScriptHash (Crypto era)))
   deriving (Generic)
 
 deriving instance
@@ -125,11 +121,9 @@ encodePredFail ::
   Encode 'Open (AlonzoPredFail era)
 encodePredFail (WrappedShelleyEraFailure x) = Sum WrappedShelleyEraFailure 0 !> E toCBOR x
 encodePredFail (UnRedeemableScripts x) = Sum UnRedeemableScripts 1 !> To x
-encodePredFail (MissingNeededScriptHash x) = Sum MissingNeededScriptHash 2 !> To x
-encodePredFail (DataHashSetsDontAgree x y) = Sum DataHashSetsDontAgree 3 !> To x !> To y
-encodePredFail (PPViewHashesDontMatch x y) = Sum PPViewHashesDontMatch 4 !> To x !> To y
-encodePredFail (MissingRequiredSigners x) = Sum MissingRequiredSigners 5 !> To x
-encodePredFail (Phase1ScriptWitnessNotValidating x) = Sum Phase1ScriptWitnessNotValidating 6 !> To x
+encodePredFail (DataHashSetsDontAgree x y) = Sum DataHashSetsDontAgree 2 !> To x !> To y
+encodePredFail (PPViewHashesDontMatch x y) = Sum PPViewHashesDontMatch 3 !> To x !> To y
+encodePredFail (MissingRequiredSigners x) = Sum MissingRequiredSigners 4 !> To x
 
 instance
   ( Era era,
@@ -151,11 +145,9 @@ decodePredFail ::
   Decode 'Open (AlonzoPredFail era)
 decodePredFail 0 = SumD WrappedShelleyEraFailure <! D fromCBOR
 decodePredFail 1 = SumD UnRedeemableScripts <! From
-decodePredFail 2 = SumD MissingNeededScriptHash <! From
-decodePredFail 3 = SumD DataHashSetsDontAgree <! From <! From
-decodePredFail 4 = SumD PPViewHashesDontMatch <! From <! From
-decodePredFail 5 = SumD MissingRequiredSigners <! From
-decodePredFail 6 = SumD Phase1ScriptWitnessNotValidating <! From
+decodePredFail 2 = SumD DataHashSetsDontAgree <! From <! From
+decodePredFail 3 = SumD PPViewHashesDontMatch <! From <! From
+decodePredFail 4 = SumD MissingRequiredSigners <! From
 decodePredFail n = Invalid n
 
 -- =============================================
@@ -209,20 +201,9 @@ alonzoStyleWitness ::
   ) =>
   TransitionRule (utxow era)
 alonzoStyleWitness = do
-  _u <- shelleyStyleWitness WrappedShelleyEraFailure
-  (TRC (ue@(UtxoEnv _slot pp _stakepools _genDelegs), u', tx)) <- judgmentContext
+  (TRC (UtxoEnv _slot pp _stakepools _genDelegs, u', tx)) <- judgmentContext
   let txbody = getField @"body" (tx :: TxInBlock era)
 
-  let scriptWitMap = getField @"scriptWits" tx
-      failedScripts = Map.foldr accum [] scriptWitMap
-        where
-          accum script@(TimelockScript _) bad =
-            if validateScript @era script tx
-              then bad
-              else (hashScript @era script) : bad
-          accum (PlutusScript _) bad = bad
-  null failedScripts ?!# Phase1ScriptWitnessNotValidating (Set.fromList failedScripts)
-
   let utxo = _utxo u'
       sphs :: [(ScriptPurpose (Crypto era), ScriptHash (Crypto era))]
       sphs = scriptsNeeded utxo tx
@@ -232,10 +213,6 @@ alonzoStyleWitness = do
          in seq (rnf ans) ans
   null unredeemed ?! UnRedeemableScripts unredeemed
 
-  let txScriptSet = Map.keysSet scriptWitMap
-      needed = Set.fromList [script | (_purpose, script) <- sphs]
-  needed == txScriptSet ?! MissingNeededScriptHash (Set.difference needed txScriptSet)
-
   let inputs = getField @"inputs" txbody :: (Set (TxIn (Crypto era)))
       smallUtxo = eval (inputs ◁ utxo) :: Map.Map (TxIn (Crypto era)) (Core.TxOut era)
       utxoHashes :: [SafeHash (Crypto era) EraIndependentData]
@@ -256,15 +233,16 @@ alonzoStyleWitness = do
 
   let languages =
         [ l
-          | (_hash, script) <- Map.toList scriptWitMap,
+          | (_hash, script) <- Map.toList (getField @"scriptWits" tx),
             (not . isNativeScript @era) script,
             Just l <- [language @era script]
         ]
       computedPPhash = hashWitnessPPData pp (Set.fromList languages) (txrdmrs . wits' $ tx)
       bodyPPhash = getField @"wppHash" txbody
   bodyPPhash == computedPPhash ?! PPViewHashesDontMatch bodyPPhash computedPPhash
 
-  trans @(Core.EraRule "UTXO" era) $ TRC (ue, u', tx)
+  -- The shelleyStyleWitness calls the UTXO rule
+  shelleyStyleWitness WrappedShelleyEraFailure
 
 -- ====================================
 -- Make the STS instance

alonzo/test/lib/Test/Cardano/Ledger/Alonzo/Serialisation/Generators.hs

@@ -291,7 +291,6 @@ instance Mock c => Arbitrary (AlonzoPredFail (AlonzoEra c)) where
     oneof
       [ WrappedShelleyEraFailure <$> arbitrary,
         UnRedeemableScripts <$> arbitrary,
-        MissingNeededScriptHash <$> arbitrary,
         DataHashSetsDontAgree <$> arbitrary <*> arbitrary,
         PPViewHashesDontMatch <$> arbitrary <*> arbitrary
       ]

alonzo/test/test/Test/Cardano/Ledger/Alonzo/Examples/Bbody.hs

@@ -140,7 +140,8 @@ example1UTxO =
         (TxIn genesisId 15, UTXOW.collateralOutput),
         (TxIn genesisId 6, UTXOW.someOutput),
         (TxIn genesisId 17, UTXOW.collateralOutput),
-        (TxIn genesisId 8, UTXOW.someOutput)
+        (TxIn genesisId 8, UTXOW.someOutput),
+        (TxIn genesisId 100, UTXOW.timelockOut)
       ]
 
 example1UtxoSt :: UTxOState A