From db1ab814b6cd8ce10a2ae44195401aa902b1a519 Mon Sep 17 00:00:00 2001 From: Tim Sheard Date: Thu, 25 Mar 2021 12:05:19 -0700 Subject: [PATCH] Renamed RunPlutus, completed ValidateScript, evalScripts. Renamed module Caradano.Ledger.Alonzo.RunPlutus to Caradano.Ledger.Alonzo.PlutusScriptApi. Completed the ValidateScript instance for Alonzo, and the evalScripts function. Cleaned up the Utxos modue, that was way over constrained. --- alonzo/impl/cardano-ledger-alonzo.cabal | 2 +- alonzo/impl/src/Cardano/Ledger/Alonzo.hs | 18 +- .../Cardano/Ledger/Alonzo/PlutusScriptApi.hs | 212 ++++++++++++++++++ .../src/Cardano/Ledger/Alonzo/Rules/Utxos.hs | 35 ++- .../src/Cardano/Ledger/Alonzo/Rules/Utxow.hs | 4 +- .../src/Cardano/Ledger/Alonzo/RunPlutus.hs | 129 ----------- alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs | 86 +------ .../impl/src/Cardano/Ledger/Alonzo/TxInfo.hs | 25 ++- .../src/Cardano/Ledger/ShelleyMA/Timelocks.hs | 1 + 9 files changed, 269 insertions(+), 243 deletions(-) create mode 100644 alonzo/impl/src/Cardano/Ledger/Alonzo/PlutusScriptApi.hs delete mode 100644 alonzo/impl/src/Cardano/Ledger/Alonzo/RunPlutus.hs diff --git a/alonzo/impl/cardano-ledger-alonzo.cabal b/alonzo/impl/cardano-ledger-alonzo.cabal index 17287779ba3..c20d695e5e6 100644 --- a/alonzo/impl/cardano-ledger-alonzo.cabal +++ b/alonzo/impl/cardano-ledger-alonzo.cabal @@ -41,7 +41,7 @@ library Cardano.Ledger.Alonzo Cardano.Ledger.Alonzo.Data Cardano.Ledger.Alonzo.FakePlutus - Cardano.Ledger.Alonzo.RunPlutus + Cardano.Ledger.Alonzo.PlutusScriptApi Cardano.Ledger.Alonzo.Language Cardano.Ledger.Alonzo.PParams Cardano.Ledger.Alonzo.Rules.Utxo diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo.hs index 0d0120d6cef..4f09b052d5d 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo.hs @@ -14,9 +14,10 @@ import Cardano.Ledger.Alonzo.PParams (PParams, PParams' (..), PParamsUpdate, upd import qualified Cardano.Ledger.Alonzo.Rules.Utxo as Alonzo (AlonzoUTXO) import qualified Cardano.Ledger.Alonzo.Rules.Utxos as Alonzo (UTXOS) import qualified Cardano.Ledger.Alonzo.Rules.Utxow as Alonzo (AlonzoUTXOW) -import Cardano.Ledger.Alonzo.Scripts (Script, isPlutusScript) -import Cardano.Ledger.Alonzo.Tx (Tx) -import Cardano.Ledger.Alonzo.TxBody (TxBody, TxOut) +import Cardano.Ledger.Alonzo.Scripts (Script (..), isPlutusScript) +import Cardano.Ledger.Alonzo.Tx (Tx, body', wits') +import Cardano.Ledger.Alonzo.TxBody (TxBody, TxOut, vldt') +import Cardano.Ledger.Alonzo.TxWitness (TxWitness (txwitsVKey')) import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash (..), ValidateAuxiliaryData (..)) import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Crypto as CC @@ -29,8 +30,10 @@ import Cardano.Ledger.Shelley.Constraints UsesTxOut (..), UsesValue, ) +import Cardano.Ledger.ShelleyMA.Timelocks (evalTimelock) import Control.State.Transition.Extended (STUB) import qualified Control.State.Transition.Extended as STS +import qualified Data.Set as Set import Data.Typeable (Typeable) import qualified Shelley.Spec.Ledger.API as API import qualified Shelley.Spec.Ledger.BaseTypes as Shelley @@ -46,6 +49,7 @@ import qualified Shelley.Spec.Ledger.STS.Snap as Shelley import qualified Shelley.Spec.Ledger.STS.Tick as Shelley import qualified Shelley.Spec.Ledger.STS.Upec as Shelley import qualified Shelley.Spec.Ledger.Tx as Shelley +import Shelley.Spec.Ledger.TxBody (witKeyHash) -- | The Alonzo era data AlonzoEra c @@ -62,9 +66,11 @@ instance (CC.Crypto c) => Shelley.ValidateScript (AlonzoEra c) where if isPlutusScript script then "\x01" else nativeMultiSigTag -- "\x00" - validateScript = error "TODO: implement validateScript" - --- hashScript x = ... We use the default method for hashScript + validateScript (NativeScript timelock) tx = evalTimelock vhks (vldt' (body' tx)) timelock + where + vhks = Set.map witKeyHash (txwitsVKey' (wits' tx)) + validateScript (PlutusScript _) _tx = False -- Plutus scripts are stripped out an run in function evalScripts + -- hashScript x = ... We use the default method for hashScript instance ( CC.Crypto c diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/PlutusScriptApi.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/PlutusScriptApi.hs new file mode 100644 index 00000000000..df62cf4d2a9 --- /dev/null +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/PlutusScriptApi.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Cardano.Ledger.Alonzo.PlutusScriptApi + ( -- Figure 8 + getData, + collectNNScriptInputs, + evalScripts, + -- Figure 12 + scriptsNeeded, + checkScriptData, + language, + ) +where + +import Cardano.Ledger.Alonzo.Data (getPlutusData) +import Cardano.Ledger.Alonzo.Language (Language (..)) +import Cardano.Ledger.Alonzo.Scripts (CostModel, ExUnits (..)) +import qualified Cardano.Ledger.Alonzo.Scripts as AlonzoScript (Script (..)) +import Cardano.Ledger.Alonzo.Tx + ( Data, + DataHash, + ScriptPurpose (..), + Tx (..), + body', + getValidatorHash, + indexedRdmrs, + txdats', + wits', + ) +import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo (TxBody (..), TxOut (..), vldt') +import Cardano.Ledger.Alonzo.TxInfo (evalPlutusScript, valContext) +import Cardano.Ledger.Alonzo.TxWitness (TxWitness (txwitsVKey'), txscripts') +import qualified Cardano.Ledger.Core as Core +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.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.Records (HasField (..)) +import Shelley.Spec.Ledger.BaseTypes (StrictMaybe (..)) +import Shelley.Spec.Ledger.Credential (Credential (ScriptHashObj)) +import Shelley.Spec.Ledger.Delegation.Certificates (DCert (..)) +import Shelley.Spec.Ledger.Scripts (ScriptHash (..)) +import Shelley.Spec.Ledger.TxBody + ( DelegCert (..), + Delegation (..), + TxIn (..), + Wdrl (..), + getRwdCred, + witKeyHash, + ) +import Shelley.Spec.Ledger.UTxO (UTxO (..)) + +-- =============================================================== +-- From the specification, Figure 8 "Scripts and their Arguments" +-- =============================================================== + +getData :: + forall era. + ( HasField "datahash" (Core.TxOut era) (StrictMaybe (DataHash (Crypto era))) + ) => + Tx era -> + UTxO era -> + ScriptPurpose (Crypto era) -> + [Data era] +getData tx (UTxO m) sp = case sp of + Minting _policyid -> [] + Rewarding _rewaccnt -> [] + Certifying _dcert -> [] + Spending txin -> + -- Only the Spending ScriptPurpose contains Data + case Map.lookup txin m of + Nothing -> [] + Just txout -> + case getField @"datahash" txout of + SNothing -> [] + SJust hash -> + case Map.lookup hash (txdats' (getField @"wits" tx)) of + Nothing -> [] + Just d -> [d] + +collectNNScriptInputs :: + ( 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 -> + [(AlonzoScript.Script era, [Data era], ExUnits, CostModel)] +collectNNScriptInputs pp tx utxo = + [ (script, d : (valContext utxo tx 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))), + cost <- maybeToList (Map.lookup PlutusV1 (getField @"_costmdls" pp)) + ] + +language :: Era era => AlonzoScript.Script era -> Maybe Language +language (AlonzoScript.PlutusScript _) = Just PlutusV1 +language (AlonzoScript.NativeScript _) = Nothing + +evalScripts :: + forall era. + ( Era era, + Alonzo.TxBody era ~ Core.TxBody era + ) => + Tx era -> + [(AlonzoScript.Script era, [Data era], ExUnits, CostModel)] -> + Bool +evalScripts _tx [] = True +evalScripts tx ((AlonzoScript.NativeScript timelock, _, _, _) : rest) = + evalTimelock vhks (Alonzo.vldt' (body' tx)) timelock && evalScripts tx rest + where + vhks = Set.map witKeyHash (txwitsVKey' (wits' tx)) +evalScripts tx ((AlonzoScript.PlutusScript pscript, ds, units, cost) : rest) = + evalPlutusScript cost units pscript (map getPlutusData ds) && evalScripts tx rest + +-- =================================================================== +-- From Specification, Figure 12 "UTXOW helper functions" + +-- This is called checkRedeemers in the Speicifcation +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 -> + (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))) + ) + +-- THE SPEC CALLS FOR A SET, BUT THAT NEEDS A BUNCH OF ORD INSTANCES (DCert) +scriptsNeeded :: + forall era. + ( Era 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))) + ) => + UTxO era -> + Tx era -> + [(ScriptPurpose (Crypto era), ScriptHash (Crypto era))] +scriptsNeeded (UTxO utxomap) tx = spend ++ reward ++ cert ++ minted + where + txb = body' tx + !spend = foldl' accum [] (getField @"inputs" txb) + where + accum !ans !i = + case Map.lookup i utxomap of + Nothing -> ans + Just txout -> + case getValidatorHash (getField @"address" txout) of + Nothing -> ans + Just hash -> (Spending i, hash) : ans + + !reward = foldl' accum [] (Map.keys m2) + where + (Wdrl m2) = getField @"wdrls" txb + accum !ans !accnt = case getRwdCred accnt of -- TODO IS THIS RIGHT? + (ScriptHashObj hash) -> (Rewarding accnt, hash) : ans + _ -> ans + + !cert = foldl addOnlyCwitness [] (getField @"certs" txb) + + !minted = foldr (\hash ans -> (Minting (PolicyID hash), hash) : ans) [] valuePolicyHashes + where + valuePolicyHashes = getField @"minted" txb + +-- We only find certificate witnesses in Delegating and Deregistration DCerts +-- that have ScriptHashObj credentials. +addOnlyCwitness :: + [(ScriptPurpose crypto, ScriptHash crypto)] -> + DCert crypto -> + [(ScriptPurpose crypto, ScriptHash crypto)] +addOnlyCwitness !ans (DCertDeleg c@(DeRegKey (ScriptHashObj hk))) = + (Certifying $ DCertDeleg c, hk) : ans +addOnlyCwitness !ans (DCertDeleg c@(Delegate (Delegation (ScriptHashObj hk) _dpool))) = + (Certifying $ DCertDeleg c, hk) : ans +addOnlyCwitness !ans _ = ans diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs index 018a70a0f2e..7ca1f09a028 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs @@ -13,12 +13,22 @@ 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.Scripts (Script) import Cardano.Ledger.Alonzo.Tx + ( CostModel, + DataHash, + IsValidating (..), + Tx (..), + txbody, + txins, + txouts, + ) import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Era (Crypto, Era) -import Cardano.Ledger.Shelley.Constraints +import Cardano.Ledger.Mary.Value (Value) +import Cardano.Ledger.Shelley.Constraints (PParamsDelta) import qualified Cardano.Ledger.Val as Val import Control.Iterate.SetAlgebra (eval, (∪), (⋪), (◁)) import Control.State.Transition.Extended @@ -50,16 +60,16 @@ data UTXOS era instance forall era. ( Era era, - UsesAuxiliary era, - UsesTxBody era, - UsesTxOut era, - UsesValue era, - UsesPParams era, + Eq (Core.PParams era), + Show (Core.PParams era), + Show (PParamsDelta era), + Eq (PParamsDelta era), Embed (Core.EraRule "PPUP" era) (UTXOS era), Environment (Core.EraRule "PPUP" era) ~ PPUPEnv era, State (Core.EraRule "PPUP" era) ~ PPUPState era, Signal (Core.EraRule "PPUP" era) ~ Maybe (Update era), Core.Script era ~ Script era, + Core.Value era ~ Value (Crypto era), Core.TxOut era ~ Alonzo.TxOut era, Core.TxBody era ~ Alonzo.TxBody era, HasField "_keyDeposit" (Core.PParams era) Coin, @@ -79,13 +89,15 @@ instance utxosTransition :: forall era. - ( UsesTxOut era, + ( Era era, Core.Script era ~ Script era, Environment (Core.EraRule "PPUP" era) ~ PPUPEnv era, State (Core.EraRule "PPUP" era) ~ PPUPState era, Signal (Core.EraRule "PPUP" era) ~ Maybe (Update era), Embed (Core.EraRule "PPUP" era) (UTXOS era), Core.TxOut era ~ Alonzo.TxOut era, + Core.Value era ~ Value (Crypto era), + Core.TxBody era ~ Alonzo.TxBody era, HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), HasField "update" (Core.TxBody era) (StrictMaybe (Update era)), HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), @@ -100,14 +112,15 @@ utxosTransition :: utxosTransition = judgmentContext >>= \(TRC (UtxoEnv _ pp _ _, UTxOState utxo _ _ _, tx)) -> let sLst = collectNNScriptInputs pp tx utxo - scriptEvalResult = evalScripts @era sLst + scriptEvalResult = evalScripts @era tx sLst in if scriptEvalResult then scriptsValidateTransition else scriptsNotValidateTransition scriptsValidateTransition :: forall era. - ( UsesTxOut era, + ( Show (Core.Value era), -- Arises because of the use of (∪) from SetAlgebra, needs Show to report errors. + Era era, Environment (Core.EraRule "PPUP" era) ~ PPUPEnv era, State (Core.EraRule "PPUP" era) ~ PPUPState era, Signal (Core.EraRule "PPUP" era) ~ Maybe (Update era), @@ -153,7 +166,7 @@ scriptsValidateTransition = do scriptsNotValidateTransition :: forall era. - ( UsesTxOut era, + ( Era era, HasField "txinputs_fee" (Core.TxBody era) (Set (TxIn (Crypto era))) ) => TransitionRule (UTXOS era) @@ -200,14 +213,12 @@ instance deriving stock instance ( Shelley.TransUTxOState Show era, - TransValue Show era, Show (PredicateFailure (Core.EraRule "PPUP" era)) ) => Show (UtxosPredicateFailure era) deriving stock instance ( Shelley.TransUTxOState Eq era, - TransValue Eq era, Eq (PredicateFailure (Core.EraRule "PPUP" era)) ) => Eq (UtxosPredicateFailure era) diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs index 3668a58d8fc..4fe4e0e3c52 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs @@ -17,17 +17,15 @@ module Cardano.Ledger.Alonzo.Rules.Utxow where import Cardano.Binary (FromCBOR (..), ToCBOR (..)) import Cardano.Ledger.Alonzo.Data (Data, DataHash) import Cardano.Ledger.Alonzo.PParams (PParams) +import Cardano.Ledger.Alonzo.PlutusScriptApi (checkScriptData, language, scriptsNeeded) import Cardano.Ledger.Alonzo.Rules.Utxo (AlonzoUTXO) import qualified Cardano.Ledger.Alonzo.Rules.Utxo as Alonzo (UtxoPredicateFailure) import Cardano.Ledger.Alonzo.Scripts (Script) import Cardano.Ledger.Alonzo.Tx ( ScriptPurpose, Tx, - checkScriptData, hashWitnessPPData, isNonNativeScriptAddress, - language, - scriptsNeeded, wits', ) import Cardano.Ledger.Alonzo.TxBody (WitnessPPDataHash) diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/RunPlutus.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/RunPlutus.hs deleted file mode 100644 index f387625df9d..00000000000 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/RunPlutus.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - -module Cardano.Ledger.Alonzo.RunPlutus where - -import Cardano.Ledger.Alonzo.Data (getPlutusData) -import Cardano.Ledger.Alonzo.Language (Language (..)) -import Cardano.Ledger.Alonzo.Scripts (CostModel, ExUnits (..)) -import qualified Cardano.Ledger.Alonzo.Scripts as AlonzoScript (Script (..)) -import Cardano.Ledger.Alonzo.Tx - ( Data, - DataHash, - IsValidating (..), - ScriptPurpose (..), - Tx (..), - indexedRdmrs, - scriptsNeeded, - txdats', - ) -import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo (TxBody (..), TxOut (..)) -import Cardano.Ledger.Alonzo.TxInfo (evalPlutusScript, valContext) -import Cardano.Ledger.Core as Core hiding (Tx) -import Cardano.Ledger.Era (Crypto, Era, ValidateScript (..)) -import qualified Cardano.Ledger.Mary.Value as Mary (Value (..)) -import qualified Data.Map as Map -import Data.Maybe (maybeToList) -import Data.Sequence.Strict (StrictSeq) -import Data.Set (Set) -import Data.Typeable (Typeable) -import GHC.Records (HasField (..)) -import qualified Plutus.V1.Ledger.Scripts as Plutus (Script) -import Shelley.Spec.Ledger.BaseTypes (StrictMaybe (..)) -import Shelley.Spec.Ledger.Delegation.Certificates (DCert (..)) -import Shelley.Spec.Ledger.Scripts (ScriptHash (..)) -import Shelley.Spec.Ledger.TxBody (TxIn (..), Wdrl (..)) -import Shelley.Spec.Ledger.UTxO (UTxO (..)) - --- =============================================================== --- From the specification, Figure 7 "Script Validation, cont." --- =============================================================== - --- TODO Specification says CostMod, not CostModel -runPLCScript :: - CostModel -> - AlonzoScript.Script era -> - [Data era] -> - ExUnits -> - (IsValidating, ExUnits) -runPLCScript _cost _script _data _exunits = (IsValidating True, ExUnits 0 0) -- TODO FIX THIS - --- =============================================================== --- From the specification, Figure 8 "Scripts and their Arguments" --- =============================================================== - -getData :: - forall era. - ( HasField "datahash" (Core.TxOut era) (StrictMaybe (DataHash (Crypto era))) - ) => - Tx era -> - UTxO era -> - ScriptPurpose (Crypto era) -> - [Data era] -getData tx (UTxO m) sp = case sp of - Minting _policyid -> [] - Rewarding _rewaccnt -> [] - Certifying _dcert -> [] - Spending txin -> - -- Only the Spending ScriptPurpose contains Data - case Map.lookup txin m of - Nothing -> [] - Just txout -> - case getField @"datahash" txout of - SNothing -> [] - SJust hash -> - case Map.lookup hash (txdats' (getField @"wits" tx)) of - Nothing -> [] - Just d -> [d] - -collectNNScriptInputs :: - ( 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 -> - [(Plutus.Script, [Data era], ExUnits, CostModel)] -collectNNScriptInputs pp tx utxo = - [ (script, d : (valContext utxo tx 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))), - cost <- maybeToList (Map.lookup PlutusV1 (getField @"_costmdls" pp)) - ] - --- | return only the scripts that use two-phase validation (Here that means Plutus scripts) -onlytwoPhaseScripts :: - ( Era era, - Script era ~ AlonzoScript.Script era - ) => - Tx era -> - ScriptHash (Crypto era) -> - [Plutus.Script] -onlytwoPhaseScripts tx scripthash = - case Map.lookup scripthash (getField @"scriptWits" tx) of - Just (AlonzoScript.PlutusScript pscript) -> [pscript] - Just (AlonzoScript.NativeScript _) -> [] - Nothing -> [] - -evalScripts :: - Typeable (Crypto era) => - [(AlonzoScript.Script era, [Data era], ExUnits, CostModel)] -> - Bool -evalScripts [] = True --- We may safely skip over the Timelock scripts -evalScripts ((AlonzoScript.NativeScript _, _, _, _) : rest) = evalScripts rest -evalScripts ((AlonzoScript.PlutusScript pscript, ds, units, cost) : rest) = - evalPlutusScript cost units pscript (map getPlutusData ds) && evalScripts rest diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs index ecdba9e3e61..df96d84ba77 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs @@ -35,7 +35,6 @@ module Cardano.Ledger.Alonzo.Tx DataHash, IsValidating (..), hashData, - language, nonNativeLanguages, hashWitnessPPData, getCoin, @@ -68,13 +67,6 @@ module Cardano.Ledger.Alonzo.Tx -- Figure 7 valContext, runPLCScript, - -- Figure 8 - getData, - collectNNScriptInputs, - evalScripts, - -- Figure 12 - scriptsNeeded, - checkScriptData, -- Pretty ppIsValidating, ppTx, @@ -552,6 +544,7 @@ runPLCScript :: (IsValidating, ExUnits) runPLCScript _cost _script _data _exunits = (IsValidating True, ExUnits 0 0) -- TODO FIX THIS +{- -- =============================================================== -- From the specification, Figure 8 "Scripts and their Arguments" -- =============================================================== @@ -618,82 +611,7 @@ evalScripts ((AlonzoScript.PlutusScript s, ds, units, cost) : rest) = b && evalScripts rest where (IsValidating b, _exunits) = runPLCScript cost (AlonzoScript.PlutusScript s) ds units - --- =================================================================== --- From Specification, Figure 12 "UTXOW helper functions" - --- THE SPEC CALLS FOR A SET, BUT THAT NEEDS A BUNCH OF ORD INSTANCES (DCert) -scriptsNeeded :: - forall era. - ( Era 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))) - ) => - UTxO era -> - Tx era -> - [(ScriptPurpose (Crypto era), ScriptHash (Crypto era))] -scriptsNeeded (UTxO utxomap) tx = spend ++ reward ++ cert ++ minted - where - txb = txbody tx - !spend = foldl' accum [] (getField @"inputs" txb) - where - accum !ans !i = - case Map.lookup i utxomap of - Nothing -> ans - Just txout -> - case getValidatorHash (getField @"address" txout) of - Nothing -> ans - Just hash -> (Spending i, hash) : ans - - !reward = foldl' accum [] (Map.keys m2) - where - (Wdrl m2) = getField @"wdrls" txb - accum !ans !accnt = case getRwdCred accnt of -- TODO IS THIS RIGHT? - (ScriptHashObj hash) -> (Rewarding accnt, hash) : ans - _ -> ans - - !cert = foldl addOnlyCwitness [] (getField @"certs" txb) - - !minted = foldr (\hash ans -> (Minting (PolicyID hash), hash) : ans) [] valuePolicyHashes - where - valuePolicyHashes = getField @"minted" txb - --- We only find certificate witnesses in Delegating and Deregistration DCerts --- that have ScriptHashObj credentials. -addOnlyCwitness :: - [(ScriptPurpose crypto, ScriptHash crypto)] -> - DCert crypto -> - [(ScriptPurpose crypto, ScriptHash crypto)] -addOnlyCwitness !ans (DCertDeleg c@(DeRegKey (ScriptHashObj hk))) = - (Certifying $ DCertDeleg c, hk) : ans -addOnlyCwitness !ans (DCertDeleg c@(Delegate (Delegation (ScriptHashObj hk) _dpool))) = - (Certifying $ DCertDeleg c, hk) : ans -addOnlyCwitness !ans _ = ans - --- This is called checkRedeemers in the Speicifcation -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 -> - (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))) - ) +-} -- ======================================================= diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/TxInfo.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/TxInfo.hs index 93a0d271c4b..ce88b1252b8 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/TxInfo.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/TxInfo.hs @@ -132,9 +132,9 @@ transCred :: Credential keyrole crypto -> P.Credential transCred (KeyHashObj (KeyHash (UnsafeHash kh))) = P.PubKeyCredential (P.PubKeyHash (fromShort kh)) transCred (ScriptHashObj (ScriptHash (UnsafeHash kh))) = P.ScriptCredential (P.ValidatorHash (fromShort kh)) -transAddr :: Addr crypto -> P.Address -transAddr (Addr _net object stake) = P.Address (transCred object) (transStakeReference stake) -transAddr (AddrBootstrap _bootaddr) = P.Address (P.PubKeyCredential (P.PubKeyHash undefined)) Nothing -- TODO get a hash from a Bootstrap address. +transAddr :: Addr crypto -> Maybe P.Address +transAddr (Addr _net object stake) = Just (P.Address (transCred object) (transStakeReference stake)) +transAddr (AddrBootstrap _bootaddr) = Nothing -- =============================== -- Translate ValidityIntervals @@ -178,7 +178,9 @@ consTranslatedTxIn :: consTranslatedTxIn (UTxO mp) txin answer = case Map.lookup txin mp of Nothing -> answer - Just txout -> (P.TxInInfo (transTxIn' txin) (P.TxOut (transAddr addr) valout dhash)) : answer + Just txout -> case (transAddr addr) of + Just ad -> (P.TxInInfo (transTxIn' txin) (P.TxOut ad valout dhash)) : answer + Nothing -> answer where valout = transValue (getField @"value" txout) addr = getField @"address" txout @@ -186,14 +188,21 @@ consTranslatedTxIn (UTxO mp) txin answer = SNothing -> Nothing SJust (safehash) -> Just (P.DatumHash (transSafeHash safehash)) -transTxOut :: +-- | 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. +-- I.e. don't include Bootstrap Addresses in the answer. +consTranslatedTxOut :: forall era. ( Era era, Value era ~ Mary.Value (Crypto era) ) => Alonzo.TxOut era -> - P.TxOut -transTxOut (Alonzo.TxOut addr val datahash) = P.TxOut (transAddr addr) (transValue @(Crypto era) val) (transDataHash datahash) + [P.TxOut] -> + [P.TxOut] +consTranslatedTxOut (Alonzo.TxOut addr val datahash) answer = + case (transAddr addr) of + Just ad -> (P.TxOut ad (transValue @(Crypto era) val) (transDataHash datahash)) : answer + Nothing -> answer -- ================================== -- translate Values @@ -261,7 +270,7 @@ transTx :: transTx utxo tx = P.TxInfo { P.txInfoInputs = foldr (consTranslatedTxIn utxo) [] (Set.toList allinputs), - P.txInfoOutputs = (map (transTxOut) (foldr (:) [] outs)), + P.txInfoOutputs = foldr consTranslatedTxOut [] (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)), diff --git a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Timelocks.hs b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Timelocks.hs index e023cda0dbc..92e2417e18e 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Timelocks.hs +++ b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Timelocks.hs @@ -25,6 +25,7 @@ module Cardano.Ledger.ShelleyMA.Timelocks pattern TimelockConstr, inInterval, showTimelock, + evalTimelock, validateTimelock, ValidityInterval (..), encodeVI,