From 2126f3242ce403b9636ec7ff5f3ccab5a5c7998c Mon Sep 17 00:00:00 2001 From: Tim Sheard Date: Thu, 25 Feb 2021 18:04:57 -0800 Subject: [PATCH] Added class (CoreUtxow era tx body wit txout) Made instances for (ShelleyEra c) and (AlonzoEra c). Also made a UTXOW instance, which works for both. --- .../src/Cardano/Ledger/Alonzo/Rules/Utxow.hs | 402 +++++++++++++----- alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs | 11 +- .../src/Cardano/Ledger/Alonzo/TxWitness.hs | 20 +- .../src/Shelley/Spec/Ledger/LedgerState.hs | 54 ++- .../src/Shelley/Spec/Ledger/STS/Utxo.hs | 3 +- .../src/Shelley/Spec/Ledger/Tx.hs | 41 +- 6 files changed, 375 insertions(+), 156 deletions(-) diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs index 435c8aa6511..4f424b4896a 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs @@ -6,17 +6,15 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} + -- The STS instance for UTXOW is technically an orphan. {-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE FunctionalDependencies #-} + module Cardano.Ledger.Alonzo.Rules.Utxow where -import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo(TxBody,TxOut,txcerts,txADhash) -import qualified Cardano.Ledger.Alonzo.Tx as Alonzo(Tx(..),TxRaw(..)) -import qualified Cardano.Ledger.Alonzo.TxWitness as Alonzo(TxWitness,witsFromTxWitness) -import qualified Cardano.Ledger.Mary.Value as Alonzo(Value) -import qualified Cardano.Ledger.ShelleyMA.AuxiliaryData as Alonzo(AuxiliaryData) -import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo(Script) + import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash) import qualified Cardano.Ledger.Core as Core @@ -38,7 +36,7 @@ import Shelley.Spec.Ledger.Coin (Coin) import Shelley.Spec.Ledger.Delegation.Certificates (requiresVKeyWitness) import Shelley.Spec.Ledger.Keys (DSignable, Hash) import Shelley.Spec.Ledger.LedgerState (UTxOState) -import Shelley.Spec.Ledger.PParams (ProtVer, Update) +import Shelley.Spec.Ledger.PParams (ProtVer, Update(..),ProposedPPUpdates(..)) import qualified Shelley.Spec.Ledger.STS.Ledger as Shelley import Shelley.Spec.Ledger.STS.Utxo (UtxoEnv(..)) import Shelley.Spec.Ledger.STS.Utxow @@ -63,24 +61,58 @@ import Shelley.Spec.Ledger.UTxO ) -- Extra imports +import Cardano.Ledger.Shelley(ShelleyEra) +import Shelley.Spec.Ledger.Tx as Shelley(Tx,TxBody,TxOut,WitnessSet) + +import qualified Shelley.Spec.Ledger.Tx as Mary(Tx(Tx')) +import qualified Shelley.Spec.Ledger.Tx as Mary(TxBody) +import qualified Cardano.Ledger.Mary.Value as Mary(Value) +import qualified Cardano.Ledger.Mary.Value as Alonzo(Value) + +import Shelley.Spec.Ledger.UTxO(UTxO(..),txinLookup,verifyWitVKey) import qualified Data.Sequence as Seq (filter) import Data.Sequence.Strict (StrictSeq) import qualified Data.Sequence.Strict as StrictSeq import qualified Shelley.Spec.Ledger.SoftForks as SoftForks import Shelley.Spec.Ledger.LedgerState(WitHashes(..)) -import Shelley.Spec.Ledger.Keys(GenDelegs(..),genDelegKeyHash,asWitness) -import Shelley.Spec.Ledger.Tx(Tx(..),hashScript,validateScript,txwitsScript ) +import Shelley.Spec.Ledger.Keys(GenDelegs(..),genDelegKeyHash,asWitness,KeyHash) +import Shelley.Spec.Ledger.Tx(Tx(..),hashScript,validateScript,txwitsScript,WitVKey,addrWitsX,bootWitsX,scriptWitsX,extractKeyHashWitnessSet) import Shelley.Spec.Ledger.LedgerState(UTxOState(_utxo),witsFromWitnessSet,nullWitHashes,verifiedWits,witsVKeyNeeded,diffWitHashes) import Cardano.Ledger.AuxiliaryData(validateAuxiliaryData,hashAuxiliaryData) import Control.Monad (when) import Control.Monad.Trans.Reader (asks) import Control.SetAlgebra (eval, (∩)) -import Shelley.Spec.Ledger.Delegation.Certificates(isInstantaneousRewards) +import Shelley.Spec.Ledger.Delegation.Certificates + ( isInstantaneousRewards, + PoolCert(..), + poolCWitness, + genesisCWitness, + delegCWitness, + ) +import Shelley.Spec.Ledger.Keys(KeyRole(Witness),VKey) + -import qualified Shelley.Spec.Ledger.Tx as Mary(Tx(Tx'),WitnessSet) -import qualified Shelley.Spec.Ledger.Tx as Mary(TxBody) import Data.MemoBytes(MemoBytes(Memo)) import Cardano.Ledger.AuxiliaryData(ValidateAuxiliaryData,AuxiliaryDataHash(..)) +import Cardano.Binary(ToCBOR(..),FromCBOR(..)) +import Shelley.Spec.Ledger.Address.Bootstrap(BootstrapWitness,bootstrapWitKeyHash,bwKey,verifyBootstrapWit) +import Shelley.Spec.Ledger.Address(Addr(..),bootstrapKeyHash) +import Shelley.Spec.Ledger.Credential(Credential(ScriptHashObj,KeyHashObj)) +import Shelley.Spec.Ledger.TxBody(TxOut(TxOutCompact),witKeyHash,DCert(..),PoolParams(..),WitVKey(..)) +import Shelley.Spec.Ledger.CompactAddr( decompactAddr ) +import qualified Cardano.Ledger.Crypto as CC(Crypto) +import Cardano.Ledger.SafeHash (HashAnnotated, extractHash, hashAnnotated) + +import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo(TxBody,TxOut(..)) +import qualified Cardano.Ledger.Alonzo.Tx as Alonzo(Tx(..),body,wits,TxRaw(..)) +import qualified Cardano.Ledger.Alonzo.TxWitness as Alonzo(TxWitness,witsFromTxWitness,txwitsVKey,txwitsBoot,txscripts) +import qualified Cardano.Ledger.ShelleyMA.AuxiliaryData as Alonzo(AuxiliaryData) +import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo(Script) +import Cardano.Ledger.Alonzo.TxBody(txcerts,txwdrls,txUpdates,txADhash,txmint,txinputs) +import Cardano.Ledger.Alonzo(AlonzoEra) + +-- ==================================================== + -- ========================================================== @@ -100,8 +132,7 @@ instance GetPolicies (Value crypto) crypto where getPolicies = policies -scriptsNeeded u tx = undefined - +scriptsNeeded utxo tx = undefined {- -- | Computes the set of script hashes required to unlock the transaction inputs -- and the withdrawals. @@ -147,7 +178,7 @@ data UTXOW era instance forall era. ( UsesValue era, -- Core.Value era ~ Alonzo.Value (Crypto era), - UsesScript era, + UsesScript era, -- arising from utxoWitnessed UsesAuxiliary era, UsesTxBody era, UsesTxOut era, @@ -207,63 +238,56 @@ instance -- ================================================================ -- ================================================================ -myWitnessed :: - forall era utxow. - ( -- UsesValue era, - UsesScript era, -- arises from witsFromWitnessSet which is over constrained - UsesAuxiliary era, --arrises from witsVKeyNeeded (Eq (Core.AuxiliaryData era)), probaly an over constrained selector - UsesTxBody era, --(ToCBOR ...) from the pattern: (Tx txbody wits md) In the pattern: (UtxoEnv slot pp stakepools genDelegs, u, tx@(Tx txbody wits md)) - UsesTxOut era, -- arises from witsVKeyNeeded - ValidateScript era, - STS (utxow era), +myWitnessed :: forall era tx body wit txout utxow. + ( Era era, + CoreUtxow era tx body wit txout, BaseM (utxow era) ~ ShelleyBase, Embed (Core.EraRule "UTXO" era) (utxow era), - DSignable (Crypto era) (Hash (Crypto era) EraIndependentTxBody), Environment (Core.EraRule "UTXO" era) ~ UtxoEnv era, State (Core.EraRule "UTXO" era) ~ UTxOState era, - Signal (Core.EraRule "UTXO" era) ~ Tx era, + Signal (Core.EraRule "UTXO" era) ~ tx era, Environment (utxow era) ~ UtxoEnv era, State (utxow era) ~ UTxOState era, - Signal (utxow era) ~ Tx era, + Signal (utxow era) ~ tx era, PredicateFailure (utxow era) ~ UtxowPredicateFailure 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))), - HasField "adHash" (Core.TxBody era) (StrictMaybe (AuxiliaryDataHash (Crypto era))), - HasField "update" (Core.TxBody era) (StrictMaybe (Update era)), - HasField "_protocolVersion" (Core.PParams era) ProtVer - ) => - (UTxO era -> Tx era -> Set (ScriptHash (Crypto era))) -> - TransitionRule (utxow era) -myWitnessed scriptsNeeded = do + STS (utxow era), + + HasField "_protocolVersion" (Core.PParams era) ProtVer, + ValidateAuxiliaryData era, + DSignable (Crypto era) (Hash (Crypto era) EraIndependentTxBody) + + ) => TransitionRule (utxow era) +myWitnessed = do (TRC (UtxoEnv slot pp stakepools genDelegs, u, tx)) <- judgmentContext - let (Tx txbody wits md) = tx + let txbody = bodyTx tx + wits = witTx tx + md = undefined let utxo = _utxo u - let witsKeyHashes = witsFromWitnessSet wits + let witsKeyHashes = witsFromWitnessSet2 wits -- check scripts let failedScripts = filter ( \(hs, validator) -> hashScript @era validator /= hs - || not (validateScript validator tx) + || not (validateScript2 validator tx) ) - (Map.toList $ txwitsScript tx) + (Map.toList $ txwitsScript2 tx) case failedScripts of [] -> pure () fs -> failBecause $ ScriptWitnessNotValidatingUTXOW $ Set.fromList $ fmap fst fs - let sNeeded = scriptsNeeded utxo tx - sReceived = Map.keysSet (txwitsScript tx) + let sNeeded = scriptsNeeded2 utxo tx + sReceived = Map.keysSet (txwitsScript2 tx) sNeeded == sReceived ?! MissingScriptWitnessesUTXOW (sNeeded `Set.difference` sReceived) -- check VKey witnesses - verifiedWits tx ?!: InvalidWitnessesUTXOW + verifiedWits2 tx ?!: InvalidWitnessesUTXOW - let needed = witsVKeyNeeded utxo tx genDelegs + let needed = witsVKeyNeeded2 utxo tx genDelegs missingWitnesses = diffWitHashes needed witsKeyHashes haveNeededWitnesses = case nullWitHashes missingWitnesses of True -> Right () @@ -271,7 +295,7 @@ myWitnessed scriptsNeeded = do haveNeededWitnesses ?!: MissingVKeyWitnessesUTXOW -- check metadata hash - case (getField @"adHash" txbody, md) of + case (adHashBody txbody, md) of (SNothing, SNothing) -> pure () (SJust mdh, SNothing) -> failBecause $ MissingTxMetadata mdh (SNothing, SJust md') -> @@ -294,7 +318,7 @@ myWitnessed scriptsNeeded = do StrictSeq.forceToStrict . Seq.filter isInstantaneousRewards . StrictSeq.fromStrict - $ getField @"certs" txbody + $ certsBody txbody GenDelegs genMapping = genDelegs coreNodeQuorum <- liftSTS $ asks quorum @@ -309,77 +333,219 @@ myWitnessed scriptsNeeded = do -- ======================================================== -data VirtualTx era = - VirtualTx { vwithash :: (WitHashes (Crypto era)) - , vcerts :: (StrictSeq (DCert (Crypto era))) - , vadHash :: (StrictMaybe (AuxiliaryDataHash (Crypto era))) - } - -class TxLike tx era where - virtualTx :: tx era -> VirtualTx era - -instance - ( UsesScript era, - Era era, - HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), - HasField "adHash" (Core.TxBody era) (StrictMaybe (AuxiliaryDataHash (Crypto era))) - ) => TxLike Mary.Tx era where - virtualTx (Mary.Tx' body witness metadata _ ) = - VirtualTx (witsFromWitnessSet witness) - ( getField @"certs" body ) - ( getField @"adHash" body ) - -instance (Era era) => TxLike Alonzo.Tx era where - virtualTx (Alonzo.TxConstr (Memo (Alonzo.TxRaw body wits _ auxdata) _)) = - VirtualTx ( Alonzo.witsFromTxWitness wits ) - ( Alonzo.txcerts body ) - ( AuxiliaryDataHash <$> Alonzo.txADhash body ) - -{- -import qualified Shelley.Spec.Ledger.Tx as Mary(Tx(Tx'),WitnessSet) -import qualified Shelley.Spec.Ledger.Tx as Mary(TxBody) -import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash) -import Shelley.Spec.Ledger.LedgerState(WitHashes(..),witsFromWitnessSet) -import Cardano.Ledger.AuxiliaryData(ValidateAuxiliaryData,AuxiliaryDataHash(..)) -import Shelley.Spec.Ledger.TxBody (WitVKey(..),witKeyHash) -import Shelley.Spec.Ledger.Address.Bootstrap(bootstrapWitKeyHash) -import Cardano.Ledger.TxBody(txADhash) --- ============================================== - -class TxParts tx wit era | tx -> wit where - type Body tx era :: * - txParts :: tx era -> (Body tx era, wit era, StrictMaybe (Core.AuxiliaryData era)) - -instance TxParts Tx TxWitness era where - type Body Tx era = TxBody era - txParts (TxConstr (Memo (TxRaw a b _ c)_)) = (a,b,c) - -instance TxParts Mary.Tx Mary.WitnessSet era where - type Body Mary.Tx era = Core.TxBody era - txParts (Mary.Tx' body witness metadata _ ) = (body,witness,metadata) -class TxParts2 tx body wit era | tx era -> wit body where - txParts2 :: tx era -> (body era, wit era, StrictMaybe (Core.AuxiliaryData era)) - -instance TxParts2 Tx TxBody TxWitness era where - txParts2 (TxConstr (Memo (TxRaw a b _ c)_)) = (a,b,c) - -instance (body era ~ Core.TxBody era) => TxParts2 Mary.Tx body Mary.WitnessSet era where - txParts2 (Mary.Tx' body witness metadata _ ) = (body,witness,metadata) - -Operations on Tx to be in the Utxow rule - -These "accessor" like functions -txwitsScript :: Tx era -> Map.Map (ScriptHash (Crypto era)) (Core.Script era) -verifiedWits - :: Tx era - -> Either - [Shelley.Spec.Ledger.Keys.VKey - 'Shelley.Spec.Ledger.Keys.Witness (Crypto era)] - () +class ( ValidateScript era, + HashAnnotated (body era) EraIndependentTxBody (Crypto era), + Core.TxOut era ~ txout era + ) => CoreUtxow era tx body wit txout | era -> tx body wit txout where + bodyTx :: tx era -> body era + witTx :: tx era -> wit era + addrWit :: wit era -> Set(WitVKey 'Witness (Crypto era)) + bootWit :: wit era -> Set(BootstrapWitness (Crypto era)) + scriptWit :: wit era -> Map.Map (ScriptHash (Crypto era)) (Core.Script era) + updateBody :: body era -> StrictMaybe (Update era) + wdrlsBody :: body era -> Wdrl (Crypto era) + certsBody :: body era -> StrictSeq (DCert (Crypto era)) + inputsBody :: body era -> Set (TxIn (Crypto era)) + mintBody :: body era -> Mary.Value (Crypto era) + adHashBody :: body era -> StrictMaybe (AuxiliaryDataHash (Crypto era)) + addressOut :: txout era -> Addr (Crypto era) + validateScript2 :: Core.Script era -> tx era -> Bool + +-- =========== Shelley Instance =============== +instance CC.Crypto c => CoreUtxow (ShelleyEra c) Shelley.Tx Shelley.TxBody Shelley.WitnessSet Shelley.TxOut where + bodyTx (Tx' body _wit _meta _) = body + witTx (Tx' _body wit _meta _) = wit + addrWit x = addrWitsX x + bootWit x = bootWitsX x + scriptWit x = scriptWitsX x + updateBody x = getField @"update" x + wdrlsBody x = getField @"wdrls" x + certsBody x = getField @"certs" x + inputsBody x = getField @"inputs" x + mintBody x = mempty + adHashBody x = getField @"adHash" x + addressOut (TxOutCompact ca _) = decompactAddr ca + validateScript2 = validateScript + +-- ============ Alonzo instance =============== + +type instance Core.TxOut(AlonzoEra c) = Alonzo.TxOut (AlonzoEra c) +instance CC.Crypto c => ValidateScript(AlonzoEra c) where + validateScript = undefined + hashScript = undefined + +instance CC.Crypto c => CoreUtxow (AlonzoEra c) Alonzo.Tx Alonzo.TxBody Alonzo.TxWitness Alonzo.TxOut where + bodyTx x = Alonzo.body x + witTx x = Alonzo.wits x + addrWit x = Alonzo.txwitsVKey x + bootWit x = Alonzo.txwitsBoot x + scriptWit x = Alonzo.txscripts x + updateBody = txUpdates + wdrlsBody = txwdrls + certsBody = txcerts + inputsBody x = getField @"inputs" x + mintBody = txmint + adHashBody x = AuxiliaryDataHash <$> (txADhash x) + addressOut (Alonzo.TxOutCompact ca _v _dhash) = decompactAddr ca + validateScript2 = undefined + + +-- =================================================================================== +-- UTxOw witnessing functions abstracted over any (CoreUtxow era tx body wit txout) + + +-- Used to be in Shelley.Spec.Ledger.UTxO +scriptsNeeded2 :: forall era tx body wit txout. + ( CoreUtxow era tx body wit txout + ) => + UTxO era -> + tx era -> + Set (ScriptHash (Crypto era)) +scriptsNeeded2 u tx = + Set.fromList (Map.elems $ Map.mapMaybe (getScriptHash . (addressOut)) u'') + `Set.union` Set.fromList + ( Maybe.mapMaybe (scriptCred . getRwdCred) $ + Map.keys withdrawals + ) + `Set.union` Set.fromList + ( Maybe.mapMaybe + scriptStakeCred + (filter requiresVKeyWitness certificates) + ) + `Set.union` (policyID `Set.map` (policies $ mintBody @era txb)) + where + txb = bodyTx @era tx + withdrawals = unWdrl $ wdrlsBody @era txb + u'' :: Map.Map (TxIn (Crypto era)) (txout era) + u'' = eval ((txinsScript2 (inputsBody @era txb) u) ◁ u) + certificates = (toList . certsBody) txb + +-- Used to be in Shelley.Spec.Ledger.UTxO +txinsScript2 :: forall era tx body wit txout. + ( CoreUtxow era tx body wit txout ) => + Set (TxIn (Crypto era)) -> + UTxO era -> + Set (TxIn (Crypto era)) +txinsScript2 txInps (UTxO u) = foldr add Set.empty txInps + where + -- to get subset, start with empty, and only insert those inputs in txInps that are locked in u + add input ans = case Map.lookup input u of + Just out -> case addressOut out of + Addr _ (ScriptHashObj _) _ -> Set.insert input ans + _ -> ans + Nothing -> ans + +-- Used to be in Shelley.Spec.Ledger.LedgerState +witsFromWitnessSet2 ::forall era tx body wits txout. + (CC.Crypto (Crypto era), CoreUtxow era tx body wits txout) => + wits era -> + WitHashes (Crypto era) +witsFromWitnessSet2 wits = + WitHashes $ + Set.map witKeyHash (addrWit wits) + `Set.union` Set.map bootstrapWitKeyHash (bootWit wits) + +witsVKeyNeeded2 :: forall era tx body wits txout. + ( CC.Crypto (Crypto era), + CoreUtxow era tx body wits txout + ) => + UTxO era -> + tx era -> + GenDelegs (Crypto era) -> + WitHashes (Crypto era) +witsVKeyNeeded2 utxo' tx genDelegs = + WitHashes $ + certAuthors + `Set.union` inputAuthors + `Set.union` owners + `Set.union` wdrlAuthors + `Set.union` updateKeys + where + txbody = bodyTx tx + inputAuthors :: Set (KeyHash 'Witness (Crypto era)) + inputAuthors = foldr accum Set.empty (inputsBody txbody) + where + accum txin ans = + case txinLookup txin utxo' of + Just out -> + case addressOut out of + Addr _ (KeyHashObj pay) _ -> Set.insert (asWitness pay) ans + AddrBootstrap bootAddr -> + Set.insert (asWitness (bootstrapKeyHash bootAddr)) ans + _ -> ans + Nothing -> ans + + wdrlAuthors :: Set (KeyHash 'Witness (Crypto era)) + wdrlAuthors = Map.foldrWithKey accum Set.empty (unWdrl (wdrlsBody txbody)) + where + accum key _ ans = Set.union (extractKeyHashWitnessSet [getRwdCred key]) ans + owners :: Set (KeyHash 'Witness (Crypto era)) + owners = foldr accum Set.empty (certsBody txbody) + where + accum (DCertPool (RegPool pool)) ans = + Set.union + (Set.map asWitness (_poolOwners pool)) + ans + accum _cert ans = ans + cwitness (DCertDeleg dc) = extractKeyHashWitnessSet [delegCWitness dc] + cwitness (DCertPool pc) = extractKeyHashWitnessSet [poolCWitness pc] + cwitness (DCertGenesis gc) = Set.singleton (asWitness $ genesisCWitness gc) + cwitness c = error $ show c ++ " does not have a witness" + -- key reg requires no witness but this is already filtered outby requiresVKeyWitness + -- before the call to `cwitness`, so this error should never be reached. + + certAuthors :: Set (KeyHash 'Witness (Crypto era)) + certAuthors = foldr accum Set.empty (certsBody txbody) + where + accum cert ans | requiresVKeyWitness cert = Set.union (cwitness cert) ans + accum _cert ans = ans + updateKeys :: Set (KeyHash 'Witness (Crypto era)) + updateKeys = asWitness `Set.map` propWits @era (updateBody txbody) genDelegs + +-- Used to be in Shelley.Spec.Ledger.LedgerState +propWits :: + StrictMaybe (Update era) -> + GenDelegs (Crypto era) -> + Set (KeyHash 'Witness (Crypto era)) +propWits SNothing _ = Set.empty +propWits (SJust (Update (ProposedPPUpdates pup) _)) (GenDelegs genDelegs) = + Set.map asWitness . Set.fromList $ Map.elems updateKeys + where + updateKeys' = eval (Map.keysSet pup ◁ genDelegs) + updateKeys = Map.map genDelegKeyHash updateKeys' -These operations -witsVKeyNeeded :: UTxO era -> Tx era -> GenDelegs (Crypto era) -> WitHashes (Crypto era) -validateScript :: ValidateScript era => Core.Script era -> Tx era -> Bool --} +-- | Given a ledger state, determine if the UTxO witnesses in a given +-- transaction are correct. +verifiedWits2 :: forall era tx body wits txout. + ( Era era, + CoreUtxow era tx body wits txout, + DSignable (Crypto era) (Hash (Crypto era) EraIndependentTxBody) + ) => + tx era -> + Either [VKey 'Witness (Crypto era)] () +verifiedWits2 tx = + case (failed <> failedBootstrap) of + [] -> Right () + nonEmpty -> Left nonEmpty + where + txbody = bodyTx tx + wits = witTx tx + wvkKey (WitVKey k _) = k + failed = + wvkKey + <$> filter + (not . verifyWitVKey (extractHash (hashAnnotated @(Crypto era) txbody))) + (Set.toList $ addrWit wits) + failedBootstrap = + bwKey + <$> filter + (not . verifyBootstrapWit (extractHash (hashAnnotated @(Crypto era) txbody))) + (Set.toList $ bootWit wits) + +txwitsScript2 ::forall era tx body wit txout. + ( CoreUtxow era tx body wit txout ) => + tx era -> + Map.Map (ScriptHash (Crypto era)) (Core.Script era) +txwitsScript2 = scriptWit . witTx diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs index 88924700689..fa426b5ddac 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs @@ -42,7 +42,8 @@ module Cardano.Ledger.Alonzo.Tx WitnessPPData, WitnessPPDataHash, -- Figure 3 - Tx (Tx), + Tx (Tx,TxConstr), -- Temporarily export the hidden constructor. + TxRaw(..), -- And its hidden base type body, wits, isValidating, @@ -479,9 +480,6 @@ getMapFromValue :: Value crypto -> Map.Map (PolicyID crypto) (Map.Map AssetName getMapFromValue (Value _ m) = m indexedRdmrs :: - ( Era era, - ToCBOR (Core.Script era) - ) => Tx era -> ScriptPurpose (Crypto era) -> Maybe (Data era, ExUnits) @@ -516,9 +514,7 @@ runPLCScript _cost _script _data _exunits = (IsValidating True, ExUnits 0 0) -- getData :: forall era. - ( ToCBOR (Core.Script era), - UsesTxOut era, - HasField "datahash" (Core.TxOut era) (Maybe (DataHash (Crypto era))) + ( HasField "datahash" (Core.TxOut era) (Maybe (DataHash (Crypto era))) ) => Tx era -> UTxO era -> @@ -622,7 +618,6 @@ addOnlyCwitness !ans _ = ans checkScriptData :: forall era. ( ValidateScript era, - UsesTxOut era, HasField "datahash" (Core.TxOut era) (Maybe (DataHash (Crypto era))) ) => Tx era -> diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWitness.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWitness.hs index 9b2150464b6..4300898b76d 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWitness.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWitness.hs @@ -20,7 +20,7 @@ module Cardano.Ledger.Alonzo.TxWitness ( RdmrPtr (..), - TxWitness (TxWitness, txwitsVKey, txwitsBoot, txscripts, txdats, txrdmrs), + TxWitness (TxWitness, TxWitness', txwitsVKey, txwitsBoot, txscripts, txdats, txrdmrs), ppRdmrPtr, ppTxWitness, witsFromTxWitness, @@ -136,15 +136,28 @@ deriving newtype instance -- ===================================================== -- Pattern for TxWitness +-- | Defined accessors with out annoying constraints +pattern TxWitness' :: forall era. + Set (WitVKey 'Witness (Crypto era)) + -> Set (BootstrapWitness (Crypto era)) + -> Map (ScriptHash (Crypto era)) (Core.Script era) + -> Map (DataHash (Crypto era)) (Data era) + -> Map RdmrPtr (Data era, ExUnits) + -> TxWitness era +pattern TxWitness' {txwitsVKey, txwitsBoot, txscripts, txdats, txrdmrs} <- + TxWitnessConstr + (Memo (TxWitnessRaw txwitsVKey txwitsBoot txscripts txdats txrdmrs) _) + + pattern TxWitness :: - (Era era, ToCBOR (Core.Script era)) => + (Era era,ToCBOR (Core.Script era)) => Set (WitVKey 'Witness (Crypto era)) -> Set (BootstrapWitness (Crypto era)) -> Map (ScriptHash (Crypto era)) (Core.Script era) -> Map (DataHash (Crypto era)) (Data era) -> Map RdmrPtr (Data era, ExUnits) -> TxWitness era -pattern TxWitness {txwitsVKey, txwitsBoot, txscripts, txdats, txrdmrs} <- +pattern TxWitness txwitsVKey txwitsBoot txscripts txdats txrdmrs <- TxWitnessConstr (Memo (TxWitnessRaw txwitsVKey txwitsBoot txscripts txdats txrdmrs) _) where @@ -154,6 +167,7 @@ pattern TxWitness {txwitsVKey, txwitsBoot, txscripts, txdats, txrdmrs} <- $ encodeWitnessRaw witsVKey' witsBoot' witsScript' witsDat' witsRdmr' {-# COMPLETE TxWitness #-} +{-# COMPLETE TxWitness' #-} -- ====================================================================== diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs index 67df6b73819..c017109c895 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs @@ -234,9 +234,10 @@ import Shelley.Spec.Ledger.Slot ) import Shelley.Spec.Ledger.Tx ( Tx (..), + WitnessSetHKD(WitnessSet), WitnessSet, - WitnessSetHKD (..), - addrWits, + addrWitsX, + bootWitsX, extractKeyHashWitnessSet, ) import Shelley.Spec.Ledger.TxBody @@ -260,7 +261,6 @@ import Shelley.Spec.Ledger.UTxO txinLookup, txins, txouts, - txup, verifyWitVKey, ) @@ -846,22 +846,23 @@ witsFromWitnessSet (WitnessSet aWits _ bsWits) = -- given transaction. This set consists of the txin owners, -- certificate authors, and withdrawal reward accounts. witsVKeyNeeded :: - forall era. + forall era tx. ( Era era, - UsesAuxiliary era, - UsesTxBody era, - UsesTxOut era, - UsesScript era, + -- Added to make very general, and not over constrained + HasField "txbody" tx (Core.TxBody era), + HasField "update" (Core.TxBody era) (StrictMaybe (Update era)), 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))), - HasField "update" (Core.TxBody era) (StrictMaybe (Update era)) + HasField "address" (Core.TxOut era) (Addr (Crypto era)) + + ) => UTxO era -> - Tx era -> + tx -> GenDelegs (Crypto era) -> WitHashes (Crypto era) -witsVKeyNeeded utxo' tx@(Tx txbody _ _) genDelegs = +witsVKeyNeeded utxo' tx genDelegs = WitHashes $ certAuthors `Set.union` inputAuthors @@ -869,6 +870,7 @@ witsVKeyNeeded utxo' tx@(Tx txbody _ _) genDelegs = `Set.union` wdrlAuthors `Set.union` updateKeys where + txbody = getField @"txbody" tx inputAuthors :: Set (KeyHash 'Witness (Crypto era)) inputAuthors = foldr accum Set.empty (getField @"inputs" txbody) where @@ -907,44 +909,52 @@ witsVKeyNeeded utxo' tx@(Tx txbody _ _) genDelegs = accum cert ans | requiresVKeyWitness cert = Set.union (cwitness cert) ans accum _cert ans = ans updateKeys :: Set (KeyHash 'Witness (Crypto era)) - updateKeys = asWitness `Set.map` propWits (txup tx) genDelegs + updateKeys = asWitness `Set.map` propWits @era (getField @"update" txbody) genDelegs -- | Given a ledger state, determine if the UTxO witnesses in a given -- transaction are correct. verifiedWits :: forall era. - ( UsesTxBody era, - Core.AnnotatedData (Core.Script era), - ToCBOR (Core.AuxiliaryData era), - DSignable (Crypto era) (Hash (Crypto era) EraIndependentTxBody) + ( Era era, + HashAnnotated (Core.TxBody era) EraIndependentTxBody (Crypto era), + -- UsesTxBody era, + -- ToCBOR (Core.AuxiliaryData era), + -- Core.AnnotatedData (Core.Script era), -- arises from addrWits + DSignable (Crypto era) (Hash (Crypto era) EraIndependentTxBody), + HasField "txbody" (Tx era) (Core.TxBody era) + -- HasField "txwitnessSet" (Tx era) (WitnessSet era), + -- HasField "addrWits" (WitnessSetHKD Identity era) (Set(WitVKey 'Witness (Crypto era))), + -- HasField "bootWits" (WitnessSetHKD Identity era) (Set(BootstrapWitness (Crypto era))) ) => Tx era -> Either [VKey 'Witness (Crypto era)] () -verifiedWits (Tx txbody wits _) = +verifiedWits tx = case (failed <> failedBootstrap) of [] -> Right () nonEmpty -> Left nonEmpty where + txbody = getField @"txbody" tx + wits = getField @"txwitnessSet" tx wvkKey (WitVKey k _) = k failed = wvkKey <$> filter (not . verifyWitVKey (extractHash (hashAnnotated @(Crypto era) txbody))) - (Set.toList $ addrWits wits) + (Set.toList $ addrWitsX wits) failedBootstrap = bwKey <$> filter (not . verifyBootstrapWit (extractHash (hashAnnotated @(Crypto era) txbody))) - (Set.toList $ bootWits wits) + (Set.toList $ bootWitsX wits) -- | Calculate the set of hash keys of the required witnesses for update -- proposals. propWits :: - Maybe (Update era) -> + StrictMaybe (Update era) -> GenDelegs (Crypto era) -> Set (KeyHash 'Witness (Crypto era)) -propWits Nothing _ = Set.empty -propWits (Just (Update (ProposedPPUpdates pup) _)) (GenDelegs genDelegs) = +propWits SNothing _ = Set.empty +propWits (SJust (Update (ProposedPPUpdates pup) _)) (GenDelegs genDelegs) = Set.map asWitness . Set.fromList $ Map.elems updateKeys where updateKeys' = eval (Map.keysSet pup ◁ genDelegs) diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Utxo.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Utxo.hs index 6d860fb8ea3..29b685775f5 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Utxo.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Utxo.hs @@ -19,6 +19,7 @@ module Shelley.Spec.Ledger.STS.Utxo UtxoEnv (..), UtxoPredicateFailure (..), PredicateFailure, + WitnessSetHKD, ) where @@ -100,7 +101,7 @@ import Shelley.Spec.Ledger.Serialization encodeFoldable, ) import Shelley.Spec.Ledger.Slot (SlotNo) -import Shelley.Spec.Ledger.Tx (Tx (..), TxIn) +import Shelley.Spec.Ledger.Tx (Tx (..), TxIn, WitnessSetHKD(..)) import Shelley.Spec.Ledger.TxBody ( DCert, PoolParams, diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Tx.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Tx.hs index ece9704157e..ab2a050719e 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Tx.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Tx.hs @@ -37,14 +37,18 @@ module Shelley.Spec.Ledger.Tx decodeWits, segwitTx, -- witness data - WitnessSet, WitnessSetHKD ( WitnessSet, addrWits, bootWits, scriptWits, - txWitsBytes + txWitsBytes, + WitnessSetX, + addrWitsX, + bootWitsX, + scriptWitsX ), + WitnessSet, -- the type synonym WitVKey (..), ValidateScript (..), txwitsScript, @@ -92,6 +96,7 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Typeable import GHC.Generics (Generic) +import GHC.Records(HasField(..)) import NoThunks.Class (AllowThunksIn (..), NoThunks (..)) import Shelley.Spec.Ledger.Address.Bootstrap (BootstrapWitness) import Shelley.Spec.Ledger.BaseTypes @@ -173,6 +178,14 @@ instance where mempty = WitnessSet mempty mempty mempty +pattern WitnessSetX :: + Set (WitVKey 'Witness (Crypto era)) -> + Map (ScriptHash (Crypto era)) (Core.Script era) -> + Set (BootstrapWitness (Crypto era)) -> + WitnessSet era +pattern WitnessSetX {addrWitsX, scriptWitsX, bootWitsX} <- + WitnessSet' addrWitsX scriptWitsX bootWitsX _ + pattern WitnessSet :: (Era era, Core.AnnotatedData (Core.Script era)) => Set (WitVKey 'Witness (Crypto era)) -> @@ -201,6 +214,16 @@ pattern WitnessSet {addrWits, scriptWits, bootWits} <- } {-# COMPLETE WitnessSet #-} +{-# COMPLETE WitnessSetX #-} + + +{- +instance (Crypto era ~ c) => HasField "addrWits" (WitnessSetHKD Identity era) (Set (WitVKey 'Witness c)) where + getField (WitnessSet' addrWits _ _ _) = addrWits + +instance (Crypto era ~ c) => HasField "bootWits" (WitnessSetHKD Identity era) (Set (BootstrapWitness c)) where + getField (WitnessSet' _ _ boot _) = boot +-} -- | Exports the relevant parts from a (WintessSetHKD Identity era) for -- use by the pretty printer without all the horrible constraints. @@ -275,6 +298,13 @@ pattern Tx {_body, _witnessSet, _metadata} <- {-# COMPLETE Tx #-} +-- | These instances makes it possible to extract the Core.TxBody without incurring +-- the ToCBOR constraints introduced by the pattern Tx, above . +instance (Core.TxBody era ~ coretxbody) => HasField "txbody" (Tx era) coretxbody where + getField (Tx' body _ _ _) = body +instance HasField "txwitnessSet" (Tx era) (WitnessSet era) where + getField (Tx' _ wits _ _) = wits + instance (Era era, c ~ Crypto era) => HashAnnotated (Tx era) EraIndependentTx c segwitTx :: @@ -310,7 +340,8 @@ segwitTx decodeWits :: forall era s. - ( Core.AnnotatedData (Core.Script era), + ( -- Core.AnnotatedData (Core.Script era), + FromCBOR (Annotator (Core.Script era)), ValidateScript era ) => Decoder s (Annotator (WitnessSet era)) @@ -382,7 +413,9 @@ instance -- | Typeclass for multis-signature script data types. Allows for script -- validation and hashing. class - (Era era, ToCBOR (Core.Script era)) => + ( Era era + -- , ToCBOR (Core.Script era) + ) => ValidateScript era where validateScript :: Core.Script era -> Tx era -> Bool