diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/FakePlutus.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/FakePlutus.hs index 9c991ab1344..712edaa12cb 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/FakePlutus.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/FakePlutus.hs @@ -55,8 +55,10 @@ data TxOut = TxOut } data TxInfo = TxInfo - { -- | Transaction inputs + { -- | Transaction inputs NOT used to pay fees txInfoInputs :: [TxInInfo], + -- | Transaction inputs designated to pay fees + txInfoInputsFees :: [TxInInfo], -- | Transaction outputs txInfoOutputs :: [TxOut], -- | The fee paid by this transaction. diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/PlutusScriptApi.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/PlutusScriptApi.hs index 5f3538e24cd..544b7654418 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/PlutusScriptApi.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/PlutusScriptApi.hs @@ -92,6 +92,7 @@ getData tx (UTxO m) sp = case sp of Nothing -> [] Just d -> [d] +-- | Collect the inputs (Data, execution budget, costModel) for all twoPhase scripts. collectNNScriptInputs :: ( Era era, Core.Script era ~ AlonzoScript.Script era, @@ -113,8 +114,7 @@ collectNNScriptInputs pp tx utxo = in [ (script, d : (valContext txinfo sp ++ getData tx utxo sp), eu, cost) | (sp, scripthash) <- scriptsNeeded utxo tx, -- TODO, IN specification ORDER IS WRONG (d, eu) <- maybeToList (indexedRdmrs tx sp), - script <- -- onlytwoPhaseScripts tx scripthash - maybeToList (Map.lookup scripthash (txscripts' (getField @"wits" tx))), + script <- maybeToList (Map.lookup scripthash (txscripts' (getField @"wits" tx))), cost <- maybeToList (Map.lookup PlutusV1 (getField @"_costmdls" pp)) ] @@ -122,6 +122,9 @@ language :: Era era => AlonzoScript.Script era -> Maybe Language language (AlonzoScript.PlutusScript _) = Just PlutusV1 language (AlonzoScript.TimelockScript _) = Nothing +-- | evaluate a list of scripts, All scripts in the list must be True. +-- There are two kinds of scripts, evaluate each kind using the +-- appropriate mechanism. evalScripts :: forall era. ( Era era, @@ -144,35 +147,30 @@ evalScripts tx ((AlonzoScript.PlutusScript pscript, ds, units, cost) : rest) = -- This is called checkRedeemers in the Specification -- | Check that a script has whatever associated Data that it requires. --- There are several ways this can happen --- 1) The script is Not a twoPhase script, so it doesn't need any data --- 2) The _txrdmrs Map of the TxWitness, contains Data for the script AND, either of the following --- a) It is not a Spending script OR --- b) If it is a Spending Script, we can getData for it. +-- There are several things need to test this: +-- 1) The hash appears in the script map in the Witnesses +-- 2) The script is Not a twoPhase script, so it doesn't need any data +-- 3) The script is a twoPhase script, and the _txrdmrs Map of the TxWitness, +-- contains Data for the script. checkScriptData :: forall era. ( ValidateScript era, - HasField "datahash" (Core.TxOut era) (StrictMaybe (DataHash (Crypto era))), HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)), HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))) ) => Tx era -> - UTxO era -> + -- UTxO era -> -- TODO check that we really don't use the UTxO (ScriptPurpose (Crypto era), ScriptHash (Crypto era)) -> Bool -checkScriptData tx utxo (sp, _h) = any ok scripts - where - scripts = txscripts' (getField @"wits" tx) - isSpending (Spending _) = True - isSpending _ = False - ok s = - isNativeScript @era s - || ( isJust (indexedRdmrs tx sp) - && (not (isSpending sp) || not (null (getData tx utxo sp))) - ) +checkScriptData tx {- utxo -} (sp, h) = + case Map.lookup h (txscripts' (getField @"wits" tx)) of + Nothing -> False + Just s -> if isNativeScript @era s then True else isJust (indexedRdmrs tx sp) -- THE SPEC CALLS FOR A SET, BUT THAT NEEDS A BUNCH OF ORD INSTANCES (DCert) + +-- Collect information (purpose and hash) about all the scripts in a Tx. scriptsNeeded :: forall era. ( Era era, @@ -199,7 +197,7 @@ scriptsNeeded (UTxO utxomap) tx = spend ++ reward ++ cert ++ minted !reward = foldl' accum [] (Map.keys m2) where (Wdrl m2) = getField @"wdrls" txb - accum !ans !accnt = case getRwdCred accnt of -- TODO IS THIS RIGHT? + accum !ans !accnt = case getRwdCred accnt of (ScriptHashObj hash) -> (Rewarding accnt, hash) : ans _ -> ans diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs index d2c7e36ffa3..1ed7e2ddbc6 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs @@ -208,7 +208,7 @@ alonzoStyleWitness = do sphs = scriptsNeeded utxo tx unredeemed = -- A script is unredeemed, is we can't find the Data that it requires to execute. - let ans = (filter (not . checkScriptData tx utxo) sphs) + let ans = (filter (not . checkScriptData tx) sphs) in seq (rnf ans) ans null unredeemed ?! UnRedeemableScripts unredeemed diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs index d6a0106e07c..edc308fee79 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs @@ -19,7 +19,7 @@ module Cardano.Ledger.Alonzo.Scripts ( Tag (..), Script (ScriptConstr, TimelockScript, PlutusScript), ExUnits (..), - CostModel (CostModel), + CostModel (CostModel, ..), Prices (..), hashCostModel, scriptfee, diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/TxInfo.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/TxInfo.hs index 10e8480ede2..2308df43a86 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/TxInfo.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/TxInfo.hs @@ -34,12 +34,12 @@ import Cardano.Ledger.Alonzo.TxBody inputs_fee', mint', outputs', + reqSignerHashes', txfee', vldt', wdrls', ) import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo (TxBody (..), TxOut (..)) -import Cardano.Ledger.Alonzo.TxWitness (TxWitness (..)) import Cardano.Ledger.Core as Core (TxBody, TxOut, Value) import qualified Cardano.Ledger.Crypto as CC (Crypto) import Cardano.Ledger.Era (Crypto, Era) @@ -51,6 +51,7 @@ import Cardano.Slotting.Slot (EpochNo (..), SlotNo (..)) import Data.ByteString as BS (ByteString) import Data.ByteString.Short as SBS (fromShort, toShort) import qualified Data.Map as Map +import Data.Maybe (mapMaybe) import qualified Data.Set as Set import Data.Typeable (Typeable) import qualified Flat as Flat (flat) @@ -160,9 +161,9 @@ transVI (ValidityInterval (SJust (SlotNo i)) (SJust (SlotNo j))) = transTxIn' :: CC.Crypto c => TxIn c -> P.TxOutRef transTxIn' (TxIn txid nat) = P.TxOutRef (transTxId txid) (fromIntegral nat) --- | Given a TxIn, look it up in the UTxO. If it exists, translate it and cons the result --- onto the answer list. If does not exist in the UTxO, just return the answer list. -consTranslatedTxIn :: +-- | Given a TxIn, look it up in the UTxO. If it exists, translate it and return +-- (Just translation). If does not exist in the UTxO, return Nothing. +transTxIn :: forall era. ( Era era, Value era ~ Mary.Value (Crypto era), @@ -170,14 +171,13 @@ consTranslatedTxIn :: ) => UTxO era -> TxIn (Crypto era) -> - [P.TxInInfo] -> - [P.TxInInfo] -consTranslatedTxIn (UTxO mp) txin answer = + Maybe (P.TxInInfo) +transTxIn (UTxO mp) txin = case Map.lookup txin mp of - Nothing -> answer + Nothing -> Nothing Just txout -> case (transAddr addr) of - Just ad -> (P.TxInInfo (transTxIn' txin) (P.TxOut ad valout dhash)) : answer - Nothing -> answer + Just ad -> Just (P.TxInInfo (transTxIn' txin) (P.TxOut ad valout dhash)) + Nothing -> Nothing where valout = transValue (getField @"value" txout) addr = getField @"address" txout @@ -185,21 +185,20 @@ consTranslatedTxIn (UTxO mp) txin answer = SNothing -> Nothing SJust (safehash) -> Just (P.DatumHash (transSafeHash safehash)) --- | Given a TxOut, translate it and cons the result onto the answer list. It is --- possible the address part is a Bootstrap Address, in that case just return the answer. +-- | Given a TxOut, translate it and return (Just transalation). It is +-- possible the address part is a Bootstrap Address, in that case return Nothing -- I.e. don't include Bootstrap Addresses in the answer. -consTranslatedTxOut :: +transTxOut :: forall era. ( Era era, Value era ~ Mary.Value (Crypto era) ) => Alonzo.TxOut era -> - [P.TxOut] -> - [P.TxOut] -consTranslatedTxOut (Alonzo.TxOut addr val datahash) answer = + Maybe (P.TxOut) +transTxOut (Alonzo.TxOut addr val datahash) = case (transAddr addr) of - Just ad -> (P.TxOut ad (transValue @(Crypto era) val) (transDataHash datahash)) : answer - Nothing -> answer + Just ad -> Just (P.TxOut ad (transValue @(Crypto era) val) (transDataHash datahash)) + Nothing -> Nothing -- ================================== -- translate Values @@ -283,14 +282,15 @@ transTx :: P.TxInfo transTx utxo tx = P.TxInfo - { P.txInfoInputs = foldr (consTranslatedTxIn utxo) [] (Set.toList allinputs), - P.txInfoOutputs = foldr consTranslatedTxOut [] (foldr (:) [] outs), + { P.txInfoInputs = mapMaybe (transTxIn utxo) (Set.toList (inputs' tbody)), + P.txInfoInputsFees = mapMaybe (transTxIn utxo) (Set.toList (inputs_fee' tbody)), + P.txInfoOutputs = mapMaybe transTxOut (foldr (:) [] outs), P.txInfoFee = (transValue (inject @(Mary.Value (Crypto era)) fee)), P.txInfoForge = (transValue forge), P.txInfoDCert = (foldr (\c ans -> transDCert c : ans) [] (certs' tbody)), P.txInfoWdrl = transWdrl (wdrls' tbody), P.txInfoValidRange = (transVI interval), - P.txInfoSignatories = (Set.foldl (\ans vk -> (getWitVKeyHash vk) : ans) [] vkkeyset), + P.txInfoSignatories = map transKeyHash (Set.toList (reqSignerHashes' tbody)), P.txInfoData = (map transDataPair datpairs), P.txInfoId = (P.TxId (transSafeHash (hashAnnotated @(Crypto era) tbody))) } @@ -299,12 +299,10 @@ transTx utxo tx = _witnesses = wits' tx _isval = isValidating' tx _auxdat = auxiliaryData' tx - allinputs = Set.union (inputs' tbody) (inputs_fee' tbody) outs = outputs' tbody fee = txfee' tbody forge = mint' tbody interval = vldt' tbody - vkkeyset = txwitsVKey' (wits' tx) datpairs = Map.toList (txdats' (wits' tx)) -- ===============================================================