From 53e997c4d8560e85994fe6b9cdc485a515333e46 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Tue, 25 Feb 2025 15:35:31 -0400 Subject: [PATCH] Everything builds! Need to sorrt out getScriptIntegrityHash --- cardano-api/cardano-api.cabal | 9 +- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 24 +- .../src/Cardano/Api/Internal/Certificate.hs | 45 +- .../Api/Internal/Eon/AlonzoEraOnwards.hs | 2 + .../Cardano/Api/Internal/Experimental/Eras.hs | 6 + .../Internal/Experimental/Plutus/Script.hs | 48 ++ .../Experimental/Plutus/ScriptWitness.hs | 582 ++++++++++++++++++ .../Experimental/Plutus/Shim/LegacyScripts.hs | 240 ++++++++ .../Internal/Experimental/Simple/Script.hs | 23 + .../Cardano/Api/Internal/Experimental/Tx.hs | 21 +- .../Governance/Actions/ProposalProcedure.hs | 16 +- .../Governance/Actions/VotingProcedure.hs | 24 +- .../src/Cardano/Api/Internal/Script.hs | 3 + .../src/Cardano/Api/Internal/ScriptData.hs | 2 +- .../src/Cardano/Api/Internal/Tx/Body.hs | 185 +++++- .../Cardano/Api/Internal/Tx/BuildTxWith.hs | 49 ++ 16 files changed, 1213 insertions(+), 66 deletions(-) create mode 100644 cardano-api/src/Cardano/Api/Internal/Experimental/Plutus/Script.hs create mode 100644 cardano-api/src/Cardano/Api/Internal/Experimental/Plutus/ScriptWitness.hs create mode 100644 cardano-api/src/Cardano/Api/Internal/Experimental/Plutus/Shim/LegacyScripts.hs create mode 100644 cardano-api/src/Cardano/Api/Internal/Experimental/Simple/Script.hs create mode 100644 cardano-api/src/Cardano/Api/Internal/Tx/BuildTxWith.hs diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 8bef1239b..266ec18d3 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -77,8 +77,6 @@ library Cardano.Api.Internal.Eon.ShelleyBasedEra Cardano.Api.Internal.Eras Cardano.Api.Internal.Error - Cardano.Api.Internal.Experimental.Eras - Cardano.Api.Internal.Experimental.Tx Cardano.Api.Internal.Fees Cardano.Api.Internal.Genesis Cardano.Api.Internal.GenesisParameters @@ -200,6 +198,12 @@ library Cardano.Api.Internal.Eon.ShelleyToMaryEra Cardano.Api.Internal.Eras.Case Cardano.Api.Internal.Eras.Core + Cardano.Api.Internal.Experimental.Eras + Cardano.Api.Internal.Experimental.Plutus.Shim.LegacyScripts + Cardano.Api.Internal.Experimental.Plutus.Script + Cardano.Api.Internal.Experimental.Plutus.ScriptWitness + Cardano.Api.Internal.Experimental.Simple.Script + Cardano.Api.Internal.Experimental.Tx Cardano.Api.Internal.Feature Cardano.Api.Internal.Governance.Actions.ProposalProcedure Cardano.Api.Internal.Governance.Actions.VotingProcedure @@ -248,6 +252,7 @@ library Cardano.Api.Internal.SerialiseUsing Cardano.Api.Internal.SpecialByron Cardano.Api.Internal.StakePoolMetadata + Cardano.Api.Internal.Tx.BuildTxWith Cardano.Api.Internal.Tx.UTxO Cardano.Api.Internal.TxIn Cardano.Api.Internal.TxMetadata diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 15ca77016..01f8ca355 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -169,6 +169,7 @@ import qualified Data.ByteString.Base16 as Base16 import Data.Ratio (Ratio, (%)) import Data.String import Test.Gen.Cardano.Api.Hardcoded +import Data.Typeable import Data.Word (Word16, Word32, Word64) import GHC.Exts (IsList (..)) import GHC.Stack @@ -707,7 +708,7 @@ genTxWithdrawals = ] ) -genTxCertificates :: CardanoEra era -> Gen (TxCertificates BuildTx era) +genTxCertificates :: Typeable era => CardanoEra era -> Gen (TxCertificates BuildTx era) genTxCertificates = inEonForEra (pure TxCertificatesNone) @@ -720,7 +721,7 @@ genTxCertificates = ] ) -genCertificate :: forall era. ShelleyBasedEra era -> Gen (Certificate era) +genCertificate :: forall era. Typeable era => ShelleyBasedEra era -> Gen (Certificate era) genCertificate sbe = Gen.choice $ catMaybes @@ -871,7 +872,7 @@ genTxMintValue = , pure $ TxMintValue w (fromList assets) ] -genTxBodyContent :: ShelleyBasedEra era -> Gen (TxBodyContent BuildTx era) +genTxBodyContent :: Typeable era => ShelleyBasedEra era -> Gen (TxBodyContent BuildTx era) genTxBodyContent sbe = do let era = toCardanoEra sbe txIns <- @@ -992,7 +993,8 @@ genWitnessesByron = Gen.list (Range.constant 1 10) genByronKeyWitness -- | This generator validates generated 'TxBodyContent' and backtracks when the generated body -- fails the validation. That also means that it is quite slow. -genValidTxBody :: ShelleyBasedEra era +genValidTxBody :: Typeable era + => ShelleyBasedEra era -> Gen (TxBody era, TxBodyContent BuildTx era) -- ^ validated 'TxBody' and 'TxBodyContent' genValidTxBody sbe = Gen.mapMaybe @@ -1003,7 +1005,7 @@ genValidTxBody sbe = (genTxBodyContent sbe) -- | Partial! This function will throw an error when the generated transaction is invalid. -genTxBody :: HasCallStack => ShelleyBasedEra era -> Gen (TxBody era) +genTxBody :: (HasCallStack, Typeable era) => ShelleyBasedEra era -> Gen (TxBody era) genTxBody era = do res <- Api.createTransactionBody era <$> genTxBodyContent era case res of @@ -1042,7 +1044,7 @@ genScriptValidity :: Gen ScriptValidity genScriptValidity = Gen.element [ScriptInvalid, ScriptValid] genTx - :: () + :: Typeable era => ShelleyBasedEra era -> Gen (Tx era) genTx era = @@ -1050,7 +1052,7 @@ genTx era = <$> genWitnesses era <*> (fst <$> genValidTxBody era) -genWitnesses :: ShelleyBasedEra era -> Gen [KeyWitness era] +genWitnesses :: Typeable era => ShelleyBasedEra era -> Gen [KeyWitness era] genWitnesses sbe = do bsWits <- Gen.list (Range.constant 0 10) (genShelleyBootstrapWitness sbe) keyWits <- Gen.list (Range.constant 0 10) (genShelleyKeyWitness sbe) @@ -1095,7 +1097,7 @@ genWitnessNetworkIdOrByronAddress = ] genShelleyBootstrapWitness - :: () + :: Typeable era => ShelleyBasedEra era -> Gen (KeyWitness era) genShelleyBootstrapWitness sbe = @@ -1104,8 +1106,10 @@ genShelleyBootstrapWitness sbe = <*> (fst <$> genValidTxBody sbe) <*> genSigningKey AsByronKey + genShelleyKeyWitness :: () + => Typeable era => ShelleyBasedEra era -> Gen (KeyWitness era) genShelleyKeyWitness sbe = @@ -1114,7 +1118,7 @@ genShelleyKeyWitness sbe = <*> genShelleyWitnessSigningKey genShelleyWitness - :: () + :: Typeable era => ShelleyBasedEra era -> Gen (KeyWitness era) genShelleyWitness sbe = @@ -1135,7 +1139,7 @@ genShelleyWitnessSigningKey = ] genCardanoKeyWitness - :: () + :: Typeable era => ShelleyBasedEra era -> Gen (KeyWitness era) genCardanoKeyWitness = genShelleyWitness diff --git a/cardano-api/src/Cardano/Api/Internal/Certificate.hs b/cardano-api/src/Cardano/Api/Internal/Certificate.hs index 80895765d..b0964f3ec 100644 --- a/cardano-api/src/Cardano/Api/Internal/Certificate.hs +++ b/cardano-api/src/Cardano/Api/Internal/Certificate.hs @@ -10,6 +10,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -- | Certificates embedded in transactions module Cardano.Api.Internal.Certificate @@ -111,6 +112,7 @@ import Data.Maybe import Data.Text (Text) import Data.Text qualified as Text import Data.Text.Encoding qualified as Text +import Data.Type.Equality (TestEquality (..)) import Data.Typeable import GHC.Exts (IsList (..), fromString) import Network.Socket (PortNumber) @@ -129,13 +131,15 @@ data Certificate era where -- 6. Genesis delegation -- 7. MIR certificates ShelleyRelatedCertificate - :: ShelleyToBabbageEra era + :: Typeable era + => ShelleyToBabbageEra era -> Ledger.ShelleyTxCert (ShelleyLedgerEra era) -> Certificate era -- Conway onwards -- TODO: Add comments about the new types of certificates ConwayCertificate - :: ConwayEraOnwards era + :: Typeable era + => ConwayEraOnwards era -> Ledger.ConwayTxCert (ShelleyLedgerEra era) -> Certificate era deriving anyclass SerialiseAsCBOR @@ -146,6 +150,27 @@ deriving instance Ord (Certificate era) deriving instance Show (Certificate era) +instance TestEquality Certificate where + testEquality (ShelleyRelatedCertificate _ c) (ShelleyRelatedCertificate _ c') = + shelleyCertTypeEquality c c' + testEquality (ConwayCertificate _ c) (ConwayCertificate _ c') = + conwayCertTypeEquality c c' + testEquality _ _ = Nothing + +conwayCertTypeEquality + :: (Typeable eraA, Typeable eraB) + => Ledger.ConwayTxCert (ShelleyLedgerEra eraA) + -> Ledger.ConwayTxCert (ShelleyLedgerEra eraB) + -> Maybe (eraA :~: eraB) +conwayCertTypeEquality _ _ = eqT + +shelleyCertTypeEquality + :: (Typeable eraA, Typeable eraB) + => Ledger.ShelleyTxCert (ShelleyLedgerEra eraA) + -> Ledger.ShelleyTxCert (ShelleyLedgerEra eraB) + -> Maybe (eraA :~: eraB) +shelleyCertTypeEquality _ _ = eqT + instance Typeable era => HasTypeProxy (Certificate era) where data AsType (Certificate era) = AsCertificate proxyToAsType _ = AsCertificate @@ -373,7 +398,8 @@ data GenesisKeyDelegationRequirements era where -> Hash VrfKey -> GenesisKeyDelegationRequirements era -makeGenesisKeyDelegationCertificate :: GenesisKeyDelegationRequirements era -> Certificate era +makeGenesisKeyDelegationCertificate + :: Typeable era => GenesisKeyDelegationRequirements era -> Certificate era makeGenesisKeyDelegationCertificate ( GenesisKeyDelegationRequirements atMostEra @@ -394,7 +420,7 @@ data MirCertificateRequirements era where -> MirCertificateRequirements era makeMIRCertificate - :: () + :: Typeable era => MirCertificateRequirements era -> Certificate era makeMIRCertificate (MirCertificateRequirements atMostEra mirPot mirTarget) = @@ -410,7 +436,7 @@ data DRepRegistrationRequirements era where -> DRepRegistrationRequirements era makeDrepRegistrationCertificate - :: () + :: Typeable era => DRepRegistrationRequirements era -> Maybe (Ledger.Anchor (EraCrypto (ShelleyLedgerEra era))) -> Certificate era @@ -427,7 +453,7 @@ data CommitteeHotKeyAuthorizationRequirements era where -> CommitteeHotKeyAuthorizationRequirements era makeCommitteeHotKeyAuthorizationCertificate - :: () + :: Typeable era => CommitteeHotKeyAuthorizationRequirements era -> Certificate era makeCommitteeHotKeyAuthorizationCertificate (CommitteeHotKeyAuthorizationRequirements cOnwards coldKeyCredential hotKeyCredential) = @@ -443,7 +469,7 @@ data CommitteeColdkeyResignationRequirements era where -> CommitteeColdkeyResignationRequirements era makeCommitteeColdkeyResignationCertificate - :: () + :: Typeable era => CommitteeColdkeyResignationRequirements era -> Certificate era makeCommitteeColdkeyResignationCertificate (CommitteeColdkeyResignationRequirements cOnwards coldKeyCred anchor) = @@ -461,7 +487,7 @@ data DRepUnregistrationRequirements era where -> DRepUnregistrationRequirements era makeDrepUnregistrationCertificate - :: () + :: Typeable era => DRepUnregistrationRequirements era -> Certificate era makeDrepUnregistrationCertificate (DRepUnregistrationRequirements conwayOnwards vcred deposit) = @@ -488,7 +514,8 @@ data DRepUpdateRequirements era where -> DRepUpdateRequirements era makeDrepUpdateCertificate - :: DRepUpdateRequirements era + :: Typeable era + => DRepUpdateRequirements era -> Maybe (Ledger.Anchor (EraCrypto (ShelleyLedgerEra era))) -> Certificate era makeDrepUpdateCertificate (DRepUpdateRequirements conwayOnwards vcred) mAnchor = diff --git a/cardano-api/src/Cardano/Api/Internal/Eon/AlonzoEraOnwards.hs b/cardano-api/src/Cardano/Api/Internal/Eon/AlonzoEraOnwards.hs index c936271a9..988f0ced3 100644 --- a/cardano-api/src/Cardano/Api/Internal/Eon/AlonzoEraOnwards.hs +++ b/cardano-api/src/Cardano/Api/Internal/Eon/AlonzoEraOnwards.hs @@ -29,6 +29,7 @@ import Cardano.Binary import Cardano.Crypto.Hash.Blake2b qualified as Blake2b import Cardano.Crypto.Hash.Class qualified as C import Cardano.Crypto.VRF qualified as C +import Cardano.Ledger.Allegra.Scripts qualified as L import Cardano.Ledger.Alonzo.Plutus.Context qualified as Plutus import Cardano.Ledger.Alonzo.Scripts qualified as L import Cardano.Ledger.Alonzo.Tx qualified as L @@ -103,6 +104,7 @@ type AlonzoEraOnwardsConstraints era = , L.EraUTxO (ShelleyLedgerEra era) , L.HashAnnotated (L.TxBody (ShelleyLedgerEra era)) L.EraIndependentTxBody L.StandardCrypto , L.MaryEraTxBody (ShelleyLedgerEra era) + , L.NativeScript (ShelleyLedgerEra era) ~ L.Timelock (ShelleyLedgerEra era) , Plutus.EraPlutusContext (ShelleyLedgerEra era) , L.Script (ShelleyLedgerEra era) ~ L.AlonzoScript (ShelleyLedgerEra era) , L.ScriptsNeeded (ShelleyLedgerEra era) ~ L.AlonzoScriptsNeeded (ShelleyLedgerEra era) diff --git a/cardano-api/src/Cardano/Api/Internal/Experimental/Eras.hs b/cardano-api/src/Cardano/Api/Internal/Experimental/Eras.hs index 66bcd5ca3..e5390f08d 100644 --- a/cardano-api/src/Cardano/Api/Internal/Experimental/Eras.hs +++ b/cardano-api/src/Cardano/Api/Internal/Experimental/Eras.hs @@ -32,6 +32,7 @@ module Cardano.Api.Internal.Experimental.Eras ) where +import Cardano.Api.Internal.Eon.AlonzoEraOnwards import Cardano.Api.Internal.Eon.BabbageEraOnwards import Cardano.Api.Internal.Eon.Convert import Cardano.Api.Internal.Eon.ShelleyBasedEra (ShelleyBasedEra (..), ShelleyLedgerEra) @@ -206,6 +207,11 @@ instance Convert Era ShelleyBasedEra where BabbageEra -> ShelleyBasedEraBabbage ConwayEra -> ShelleyBasedEraConway +instance Convert Era AlonzoEraOnwards where + convert = \case + BabbageEra -> AlonzoEraOnwardsBabbage + ConwayEra -> AlonzoEraOnwardsConway + instance Convert Era BabbageEraOnwards where convert = \case BabbageEra -> BabbageEraOnwardsBabbage diff --git a/cardano-api/src/Cardano/Api/Internal/Experimental/Plutus/Script.hs b/cardano-api/src/Cardano/Api/Internal/Experimental/Plutus/Script.hs new file mode 100644 index 000000000..be1e2c433 --- /dev/null +++ b/cardano-api/src/Cardano/Api/Internal/Experimental/Plutus/Script.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Cardano.Api.Internal.Experimental.Plutus.Script + ( PlutusScriptInEra (..) + , PlutusScriptOrReferenceInput (..) + ) +where + +import Cardano.Api.Internal.TxIn (TxIn) + +import Cardano.Ledger.Plutus.Language (PlutusRunnable) +import Cardano.Ledger.Plutus.Language qualified as L + +-- | A Plutus script in a particular era. +-- Why PlutusRunnable? Mainly for deserialization benefits. +-- The deserialization of this type looks at the +-- major protocol version and the script language to determine if +-- indeed the script is runnable. This is a dramatic improvement over the old api +-- which essentially read a 'ByteString'. Any failures due to malformed/invalid scripts +-- were caught upon transaction submission or running the script when attempting to +-- predict the necessary execution units. +-- +-- Where do we get the major protocol version from? +-- In order to access the major protocol version we pass in an 'era` type parameter which +-- can be translated to the major protocol version. +-- +-- Where do we get the script language from? +-- The serialized version of 'PlutusRunnable' encodes the script language. +-- See `DecCBOR (PlutusRunnable l)` in cardano-ledger for more details. +data PlutusScriptInEra (lang :: L.Language) era where + PlutusScriptInEra + :: PlutusRunnable lang -> PlutusScriptInEra lang era + +deriving instance Show (PlutusScriptInEra lang era) + +-- :: IsEra era => PlutusRunnable lang -> PlutusScriptInEra lang era + +-- | You can provide the plutus script directly in the transaction +-- or a reference input that points to the script in the UTxO. +-- Using a reference script saves space in your transaction. +data PlutusScriptOrReferenceInput lang era + = PScript (PlutusScriptInEra lang era) + | PReferenceScript TxIn + deriving Show diff --git a/cardano-api/src/Cardano/Api/Internal/Experimental/Plutus/ScriptWitness.hs b/cardano-api/src/Cardano/Api/Internal/Experimental/Plutus/ScriptWitness.hs new file mode 100644 index 000000000..39349f2c9 --- /dev/null +++ b/cardano-api/src/Cardano/Api/Internal/Experimental/Plutus/ScriptWitness.hs @@ -0,0 +1,582 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Cardano.Api.Internal.Experimental.Plutus.ScriptWitness + ( PlutusScriptWitness (..) + + -- * Plutus script witnessable things. + , Mint + , Withdrawal + , Cert + , Voter + + -- * Any witness (key, simple script, plutus script). + , AnyWitness (..) + + -- * Witnessable things + , Witnessable (..) + , getWitnessable + , getAnyWitnessScript + + -- * All the parts that constitute a plutus script witness but also including simple scripts + , TxScriptWitnessRequirements (..) + + -- * Constucting an indexed plutus script witness. + , IndexedPlutusScriptWitness (..) + , createIndexedPlutusScriptWitnesses + + -- * Constructing a plutus script witness. + , AnyIndexedPlutusScriptWitness (..) + , GetPlutusScriptPurpose + , PlutusScriptOrReferenceInput (..) + , ScriptRedeemer + , PlutusScriptPurpose (..) + , PlutusScriptDatum + , PlutusScriptDatumGADT (..) + , NoScriptDatum (..) + , mkPlutusScriptWitness + + -- * Collecting plutus script witness related transaction requirements. + , getTxScriptWitnessesRequirements + + -- * Not sure yet + , obtainAlonzoScriptPurposeConstraints + , getTxScriptWitnessRequirements + , obtainMonoidConstraint + + -- * move to cert module + , AnyCertificate (..) + , AnyVoter (..) + , AnyProposal (..) + ) +where + +import Cardano.Api.Internal.Address +import Cardano.Api.Internal.Certificate +import Cardano.Api.Internal.Eon.AlonzoEraOnwards +import Cardano.Api.Internal.Eon.Convert (Convert (convert)) +import Cardano.Api.Internal.Eon.ShelleyBasedEra +import Cardano.Api.Internal.Eras.Core +import Cardano.Api.Internal.Experimental.Plutus.Script +import Cardano.Api.Internal.Experimental.Simple.Script + ( SimpleScript (SimpleScript) + , SimpleScriptOrReferenceInput (..) + ) +import Cardano.Api.Internal.Governance.Actions.ProposalProcedure qualified as Api +import Cardano.Api.Internal.Governance.Actions.VotingProcedure qualified as Api +import Cardano.Api.Internal.Script (ExecutionUnits, toAlonzoExUnits) +import Cardano.Api.Internal.ScriptData +import Cardano.Api.Internal.TxIn +import Cardano.Api.Internal.Value +import Cardano.Api.Ledger qualified as L + +import Cardano.Ledger.Alonzo.Scripts qualified as L +import Cardano.Ledger.Alonzo.TxWits qualified as L +import Cardano.Ledger.Babbage.Scripts qualified as L +import Cardano.Ledger.Conway.Scripts qualified as L +import Cardano.Ledger.Core qualified as L +import Cardano.Ledger.Plutus.Data qualified as L +import Cardano.Ledger.Plutus.Language qualified as L + +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Type.Equality (TestEquality (..)) +import Data.Typeable +import Data.Word +import GHC.Exts + +{- +To construct a plutus script witness you need: +1. The plutus script or reference input +2. A redeemer +3. The thing being witnessed + +This is true regardless of the plutus script version. + +-} + +type ScriptRedeemer = HashableScriptData + +-- | This is a Plutus script witness. It possesses: +-- 1. The plutus script or reference input +-- 2. The script redeemer +-- 3. The execution units +-- 4. Potentially a script datum. See the PlutusScriptDatum type family for more details. +-- +-- Note that Plutus script witnesses do not exist on their own. They must witness something +-- and a redeemer pointer must be constucted to point to the thing being witnessed. +-- See 'IndexedPlutusScriptWitness' for more details. +data PlutusScriptWitness (lang :: L.Language) (purpose :: PlutusScriptPurpose) era where + PlutusScriptWitness + :: L.SLanguage lang + -> (PlutusScriptOrReferenceInput lang era) + -> (PlutusScriptDatumGADT lang purpose) + -> ScriptRedeemer + -> ExecutionUnits + -> PlutusScriptWitness lang purpose era + +getPlutusScriptWitnessLanguage :: PlutusScriptWitness lang purpose era -> L.Language +getPlutusScriptWitnessLanguage (PlutusScriptWitness l _ _ _ _) = + case l of + L.SPlutusV1 -> L.plutusLanguage l + L.SPlutusV2 -> L.plutusLanguage l + L.SPlutusV3 -> L.plutusLanguage l + +-- | Every Plutus script has a purpose that indicates +-- what that script is witnessing. +data PlutusScriptPurpose + = -- | Witnesses a transaction input + SpendingScript + | -- | Witnesses a minting policy + MintingScript + | -- | Witnesses a withdrawal + WithdrawingScript + | -- | Witnesses a certificate + CertifyingScript + | -- | Witnesses a proposal + ProposingScript + | -- | Witnesses a vote + VotingScript + +data NoScriptDatum = NoScriptDatumAllowed deriving Show + +-- | The PlutusScriptDatum type family is used to determine if a script datum is allowed +-- for a given plutus script purpose and version. This change was proposed in CIP-69 +-- https://github.com/cardano-foundation/CIPs/tree/master/CIP-0069 +type family PlutusScriptDatum (lang :: L.Language) (purpose :: PlutusScriptPurpose) where + PlutusScriptDatum L.PlutusV1 SpendingScript = HashableScriptData + PlutusScriptDatum L.PlutusV2 SpendingScript = HashableScriptData + PlutusScriptDatum L.PlutusV3 SpendingScript = Maybe HashableScriptData -- CIP-69 + PlutusScriptDatum L.PlutusV1 MintingScript = NoScriptDatum + PlutusScriptDatum L.PlutusV2 MintingScript = NoScriptDatum + PlutusScriptDatum L.PlutusV3 MintingScript = NoScriptDatum + PlutusScriptDatum L.PlutusV1 WithdrawingScript = NoScriptDatum + PlutusScriptDatum L.PlutusV2 WithdrawingScript = NoScriptDatum + PlutusScriptDatum L.PlutusV3 WithdrawingScript = NoScriptDatum + PlutusScriptDatum L.PlutusV1 CertifyingScript = NoScriptDatum + PlutusScriptDatum L.PlutusV2 CertifyingScript = NoScriptDatum + PlutusScriptDatum L.PlutusV3 CertifyingScript = NoScriptDatum + PlutusScriptDatum L.PlutusV1 ProposingScript = NoScriptDatum + PlutusScriptDatum L.PlutusV2 ProposingScript = NoScriptDatum + PlutusScriptDatum L.PlutusV3 ProposingScript = NoScriptDatum + PlutusScriptDatum L.PlutusV1 VotingScript = NoScriptDatum + PlutusScriptDatum L.PlutusV2 VotingScript = NoScriptDatum + PlutusScriptDatum L.PlutusV3 VotingScript = NoScriptDatum + +data PlutusScriptDatumGADT (lang :: L.Language) (purpose :: PlutusScriptPurpose) where + SpendingScriptDatum + :: PlutusScriptDatum lang SpendingScript -> PlutusScriptDatumGADT lang SpendingScript + InlineDatum :: PlutusScriptDatumGADT lang purpose + NoScriptDatum + :: PlutusScriptDatumGADT lang purpose + +getPlutusDatum + :: L.SLanguage lang -> PlutusScriptDatumGADT lang purpose -> Maybe HashableScriptData +getPlutusDatum L.SPlutusV1 (SpendingScriptDatum d) = Just d +getPlutusDatum L.SPlutusV2 (SpendingScriptDatum d) = Just d +getPlutusDatum L.SPlutusV3 (SpendingScriptDatum d) = d +getPlutusDatum _ InlineDatum = Nothing +getPlutusDatum _ NoScriptDatum = Nothing + +toAlonzoDatum + :: AlonzoEraOnwards era + -> L.SLanguage lang + -> PlutusScriptDatumGADT lang purpose + -> Maybe (L.Data (ShelleyLedgerEra era)) +toAlonzoDatum eon l d = + let mHashableData = getPlutusDatum l d + in case mHashableData of + Just h -> Just $ alonzoEraOnwardsConstraints eon $ toAlonzoData h + Nothing -> Nothing + +instance Show (PlutusScriptDatumGADT lang purpose) where + show = \case + SpendingScriptDatum _d -> "Datum" + InlineDatum -> "InlineDatum" + NoScriptDatum -> "NoScriptDatum" + +-- | A Plutus script witness along the thing it is witnessing and the index of that thing. +-- E.g transaction input, certificate, withdrawal, minting policy, etc. +-- A Plutus script witness only makes sense in the context of what it is witnessing +-- and the index of the thing it is witnessing. +data IndexedPlutusScriptWitness witnessable (lang :: L.Language) (purpose :: PlutusScriptPurpose) era where + IndexedPlutusScriptWitness + :: Witnessable witnessable era + -> (L.PlutusPurpose L.AsIx (ShelleyLedgerEra era)) + -> (PlutusScriptWitness lang purpose era) + -> IndexedPlutusScriptWitness witnessable lang purpose era + +data AnyIndexedPlutusScriptWitness era where + AnyIndexedPlutusScriptWitness + :: GetPlutusScriptPurpose era + => IndexedPlutusScriptWitness witnessable lang purpose era + -> AnyIndexedPlutusScriptWitness era + +------------------- +{- Because we are traversing the container of things that need witnessing +we need a top level Witness type that encompasses Key and Plutus Script witnesses. +This is so that we generare the correct script witness index for things +witnessed by plutus scripts + +-} +------------------- + +-- | Here we consider three types of witnesses in Cardano: key witnesses, simple script witnesses and +-- Plutus script witnesses. Note that AnyKeyWitness does not contain a key witness. This is because +-- that witness is provided in the signing stage of the transaction. AnyWitness is used to contruct +-- the transaction body. +data AnyWitness era where + AnyKeyWitness :: AnyWitness era + AnySimpleScriptWitness :: SimpleScriptOrReferenceInput era -> AnyWitness era + AnyPlutusScriptWitness :: PlutusScriptWitness lang purpose era -> AnyWitness era + +-- TODO: Left off here. Anything with a ShelleyBasedEra or AlonzoBasedEraOnwards +-- parameter really should be in the Shim module. We will have to leave the era +-- paramters of the new script api as polymorphic because we intend to use the api +-- in the old api as well. This means its up to the caller to restrict the eras with +-- ShelleyLedgerEra (old api) or LedgerEra (new api) constraints. + +-- TODO: construct redeemer maps as well here! +getAnyWitnessPlutusLanguage :: AnyWitness era -> Maybe L.Language +getAnyWitnessPlutusLanguage AnyKeyWitness = Nothing +getAnyWitnessPlutusLanguage (AnySimpleScriptWitness _) = Nothing +getAnyWitnessPlutusLanguage (AnyPlutusScriptWitness swit) = Just $ getPlutusScriptWitnessLanguage swit + +getAnyWitnessSimpleScript :: AnyWitness era -> Maybe (L.NativeScript (ShelleyLedgerEra era)) +getAnyWitnessSimpleScript AnyKeyWitness = Nothing +getAnyWitnessSimpleScript (AnySimpleScriptWitness simpleScriptOrRefInput) = + case simpleScriptOrRefInput of + SScript (SimpleScript simpleScript) -> Just simpleScript + SReferenceScript{} -> Nothing +getAnyWitnessSimpleScript (AnyPlutusScriptWitness _) = Nothing + +getAnyWitnessPlutusScript + :: AlonzoEraOnwards era -> AnyWitness era -> Maybe (L.PlutusScript (ShelleyLedgerEra era)) +getAnyWitnessPlutusScript _ AnyKeyWitness = Nothing +getAnyWitnessPlutusScript _ (AnySimpleScriptWitness _) = Nothing +getAnyWitnessPlutusScript + eon + ( AnyPlutusScriptWitness + (PlutusScriptWitness l (PScript (PlutusScriptInEra plutusScriptRunnable)) _ _ _) + ) = fromPlutusRunnable l eon plutusScriptRunnable +getAnyWitnessPlutusScript _ (AnyPlutusScriptWitness (PlutusScriptWitness _ (PReferenceScript{}) _ _ _)) = + Nothing + +-- | NB this does not include datums from inline datums existing at tx outputs! +getAnyWitnessScriptData :: AlonzoEraOnwards era -> AnyWitness era -> L.TxDats (ShelleyLedgerEra era) +getAnyWitnessScriptData eon AnyKeyWitness = alonzoEraOnwardsConstraints eon mempty +getAnyWitnessScriptData eon AnySimpleScriptWitness{} = alonzoEraOnwardsConstraints eon mempty +getAnyWitnessScriptData eon (AnyPlutusScriptWitness (PlutusScriptWitness l _ scriptDatum _ _)) = + let alonzoSdat = toAlonzoDatum eon l scriptDatum + in alonzoEraOnwardsConstraints eon $ + case alonzoSdat of + Nothing -> alonzoEraOnwardsConstraints eon mempty + Just d -> alonzoEraOnwardsConstraints eon $ L.TxDats $ fromList [(L.hashData d, d)] + +data TxScriptWitnessRequirements era + = TxScriptWitnessRequirements + (Set L.Language) + [L.Script (ShelleyLedgerEra era)] + (L.TxDats (ShelleyLedgerEra era)) + (L.Redeemers (ShelleyLedgerEra era)) + +instance Semigroup (TxScriptWitnessRequirements AlonzoEra) where + (<>) (TxScriptWitnessRequirements l1 s1 d1 r1) (TxScriptWitnessRequirements l2 s2 d2 r2) = + TxScriptWitnessRequirements (l1 <> l2) (s1 <> s2) (d1 <> d2) (r1 <> r2) + +instance Monoid (TxScriptWitnessRequirements AlonzoEra) where + mempty = TxScriptWitnessRequirements mempty mempty mempty mempty + +instance Semigroup (TxScriptWitnessRequirements BabbageEra) where + (<>) (TxScriptWitnessRequirements l1 s1 d1 r1) (TxScriptWitnessRequirements l2 s2 d2 r2) = + TxScriptWitnessRequirements (l1 <> l2) (s1 <> s2) (d1 <> d2) (r1 <> r2) + +instance Monoid (TxScriptWitnessRequirements BabbageEra) where + mempty = TxScriptWitnessRequirements mempty mempty mempty mempty + +instance Semigroup (TxScriptWitnessRequirements ConwayEra) where + (<>) (TxScriptWitnessRequirements l1 s1 d1 r1) (TxScriptWitnessRequirements l2 s2 d2 r2) = + TxScriptWitnessRequirements (l1 <> l2) (s1 <> s2) (d1 <> d2) (r1 <> r2) + +instance Monoid (TxScriptWitnessRequirements ConwayEra) where + mempty = TxScriptWitnessRequirements mempty mempty mempty mempty + +getTxScriptWitnessRequirements + :: AlonzoEraOnwards era + -> (Witnessable witnessable era, AnyWitness era) + -> TxScriptWitnessRequirements era +getTxScriptWitnessRequirements era (thing, anyWit) = + TxScriptWitnessRequirements + (maybe mempty Set.singleton $ getAnyWitnessPlutusLanguage anyWit) + (maybe mempty return $ getAnyWitnessScript (convert era) anyWit) + (getAnyWitnessScriptData era anyWit) + (getAnyWitnessRedeemerPointerMap era (thing, anyWit)) + +getTxScriptWitnessesRequirements + :: AlonzoEraOnwards era + -> [(Witnessable witnessable era, AnyWitness era)] + -> TxScriptWitnessRequirements era +getTxScriptWitnessesRequirements eon wits = + obtainMonoidConstraint eon $ mconcat $ map (getTxScriptWitnessRequirements eon) wits + +obtainMonoidConstraint + :: AlonzoEraOnwards era + -> (Monoid (TxScriptWitnessRequirements era) => a) + -> a +obtainMonoidConstraint eon = case eon of + AlonzoEraOnwardsAlonzo -> id + AlonzoEraOnwardsBabbage -> id + AlonzoEraOnwardsConway -> id + +-- So how would the new api look? We would paramterize on data Era and +-- always have two cases instead of multipl cases +-- We could also parameterize on the IsEra era type class for exposed functions + +getAnyWitnessScript + :: ShelleyBasedEra era -> AnyWitness era -> Maybe (L.Script (ShelleyLedgerEra era)) +getAnyWitnessScript _ AnyKeyWitness = Nothing +getAnyWitnessScript era ss@(AnySimpleScriptWitness{}) = + case era of + ShelleyBasedEraShelley -> getAnyWitnessSimpleScript ss + ShelleyBasedEraAllegra -> getAnyWitnessSimpleScript ss + ShelleyBasedEraMary -> getAnyWitnessSimpleScript ss + ShelleyBasedEraAlonzo -> L.TimelockScript <$> getAnyWitnessSimpleScript ss + ShelleyBasedEraBabbage -> L.TimelockScript <$> getAnyWitnessSimpleScript ss + ShelleyBasedEraConway -> L.TimelockScript <$> getAnyWitnessSimpleScript ss +getAnyWitnessScript era ps@(AnyPlutusScriptWitness{}) = + forShelleyBasedEraInEon era Nothing $ \aEon -> + case aEon of + AlonzoEraOnwardsAlonzo -> L.PlutusScript <$> getAnyWitnessPlutusScript aEon ps + AlonzoEraOnwardsBabbage -> L.PlutusScript <$> getAnyWitnessPlutusScript aEon ps + AlonzoEraOnwardsConway -> L.PlutusScript <$> getAnyWitnessPlutusScript aEon ps + +-- It should be noted that 'PlutusRunnable' is constructed via deserialization. The deserialization +-- instance lives in ledger and will fail for an invalid script language/era pairing. Therefore +-- this function should never return 'Nothing'. +fromPlutusRunnable + :: L.SLanguage lang + -> AlonzoEraOnwards era + -> L.PlutusRunnable lang + -> Maybe (L.PlutusScript (ShelleyLedgerEra era)) +fromPlutusRunnable l@L.SPlutusV1 eon runnable = + case eon of + AlonzoEraOnwardsAlonzo -> + let plutusScript = plutusFromRunnableAssist l runnable + in Just $ L.AlonzoPlutusV1 plutusScript + AlonzoEraOnwardsBabbage -> + let plutusScript = plutusFromRunnableAssist l runnable + in Just $ L.BabbagePlutusV1 plutusScript + AlonzoEraOnwardsConway -> + let plutusScript = plutusFromRunnableAssist l runnable + in Just $ L.ConwayPlutusV1 plutusScript +fromPlutusRunnable l@L.SPlutusV2 eon runnable = + case eon of + AlonzoEraOnwardsAlonzo -> Nothing + AlonzoEraOnwardsBabbage -> + let plutusScript = plutusFromRunnableAssist l runnable + in Just $ L.BabbagePlutusV2 plutusScript + AlonzoEraOnwardsConway -> + let plutusScript = plutusFromRunnableAssist l runnable + in Just $ L.ConwayPlutusV2 plutusScript +fromPlutusRunnable l@L.SPlutusV3 eon runnable = + case eon of + AlonzoEraOnwardsAlonzo -> Nothing + AlonzoEraOnwardsBabbage -> Nothing + AlonzoEraOnwardsConway -> + let plutusScript = plutusFromRunnableAssist l runnable + in Just $ L.ConwayPlutusV3 plutusScript + +-- Created purely to help type inference +plutusFromRunnableAssist :: L.SLanguage lang -> L.PlutusRunnable lang -> L.Plutus lang +plutusFromRunnableAssist _ = L.plutusFromRunnable + +data Witnessable thing era where + WitTxIn :: L.AlonzoEraScript (ShelleyLedgerEra era) => TxIn -> Witnessable TxIn era + WitTxCert :: L.AlonzoEraScript (ShelleyLedgerEra era) => Cert -> Witnessable Cert era + WitMint :: L.AlonzoEraScript (ShelleyLedgerEra era) => Mint -> Witnessable Mint era + WitWithdrawal + :: L.AlonzoEraScript (ShelleyLedgerEra era) => Withdrawal -> Witnessable Withdrawal era + WitVote + :: L.ConwayEraScript (ShelleyLedgerEra era) + => Voter -> Witnessable Voter era + WitProposal :: L.ConwayEraScript (ShelleyLedgerEra era) => Proposal -> Witnessable Proposal era + +deriving instance Show (Witnessable thing era) + +deriving instance Eq (Witnessable thing era) + +type Mint = (PolicyId, AssetName, Quantity) + +type Withdrawal = (StakeAddress, L.Coin) + +type Cert = (AnyCertificate, StakeCredential) + +type Voter = AnyVoter + +type Proposal = AnyProposal + +data AnyProposal where + AnyProposal :: IsShelleyBasedEra era => Api.Proposal era -> AnyProposal + +deriving instance Show AnyProposal + +instance Eq AnyProposal where + (==) (AnyProposal p) (AnyProposal p') = + case testEquality p p' of + Nothing -> False + Just Refl -> p == p' + +data AnyVoter where + AnyVoter :: Api.Voter era -> AnyVoter + +deriving instance Show AnyVoter + +instance Eq AnyVoter where + (==) (AnyVoter v) (AnyVoter v') = + case testEquality v v' of + Nothing -> False + Just Refl -> v == v' + +data AnyCertificate where + AnyCertificate :: Certificate era -> AnyCertificate + +deriving instance Show AnyCertificate + +instance Eq AnyCertificate where + (==) + (AnyCertificate cert) + (AnyCertificate cert') = + case testEquality cert cert' of + Nothing -> False + Just Refl -> cert == cert' + +getWitnessable :: Witnessable thing era -> thing +getWitnessable (WitTxIn txIn) = txIn +getWitnessable _ = error "getWitnessable: minting scripts do not have a witnessable" + +-- | In order to reduce boilerplate we reuse cardano-ledger's PlutusPurpose type. This +-- type is used in the construction of the redeemer pointers map. The redeemer pointers map +-- connects the redeemer and execution units to the thing being witnessed. The map is +-- indexed by redeemer pointer! +-- So the natural question is how do the Plutus script witnesses know what +-- execution units and redeemer is paired with it? The ledger constructs a pointer +-- for every Plutus script and this pointer corresponds to the pointer constructed +-- in the redeemer pointer map. See 'collectPlutusScriptsWithContext' in 'cardano-ledger'. +class GetPlutusScriptPurpose era where + toPlutusScriptPurpose + :: Word32 + -> Witnessable thing era + -> L.PlutusPurpose L.AsIx (ShelleyLedgerEra era) + +instance GetPlutusScriptPurpose era where + toPlutusScriptPurpose index WitTxIn{} = L.mkSpendingPurpose (L.AsIx index) + toPlutusScriptPurpose index WitWithdrawal{} = L.mkRewardingPurpose (L.AsIx index) + toPlutusScriptPurpose index WitMint{} = L.mkMintingPurpose (L.AsIx index) + toPlutusScriptPurpose index WitTxCert{} = L.mkCertifyingPurpose (L.AsIx index) + toPlutusScriptPurpose index WitVote{} = L.mkVotingPurpose (L.AsIx index) + toPlutusScriptPurpose index WitProposal{} = L.mkProposingPurpose (L.AsIx index) + +obtainAlonzoScriptPurposeConstraints + :: AlonzoEraOnwards era + -> ((GetPlutusScriptPurpose era, L.AlonzoEraScript (ShelleyLedgerEra era)) => a) + -> a +obtainAlonzoScriptPurposeConstraints v = + case v of + AlonzoEraOnwardsAlonzo -> id + AlonzoEraOnwardsBabbage -> id + AlonzoEraOnwardsConway -> id + +createIndexedPlutusScriptWitness + :: Word32 + -> Witnessable witnessable era + -> PlutusScriptWitness lang purpose era + -> IndexedPlutusScriptWitness witnessable lang purpose era +createIndexedPlutusScriptWitness index witnessable pSwit = + IndexedPlutusScriptWitness witnessable (toPlutusScriptPurpose index witnessable) pSwit + +createIndexedPlutusScriptWitnesses + :: [(Witnessable witnessable era, AnyWitness era)] + -> [AnyIndexedPlutusScriptWitness era] +createIndexedPlutusScriptWitnesses witnessableThings = + [ AnyIndexedPlutusScriptWitness $ createIndexedPlutusScriptWitness index thing sWit + | (index, (thing, AnyPlutusScriptWitness sWit)) <- zip [0 ..] witnessableThings + ] + +{- +The transaction redeemer pointer map allows the ledger to connect a redeemer and execution unit pairing to the relevant +script. The ledger basically reconstructs the indicies of this map can then look up the relevant pairing. +-} +-- This is the smoking gun. The truth is in Conway votes and proposals were introduced. +-- Therefore only in conway we should be allowed to get votes and props being paired with +-- witnesses. Can we express this in the type system? Witnessable will have to be parameterized +-- on era and we would need a type family to enforce this relation ship +-- Witnessable era witnessable -> AnyWitness era -> (Witnessable era witnessable, AnyWitness era) +-- And we can be explict about the pairings! We would need the result type of the family to be CanBePaired era witnessable + +getAnyWitnessRedeemerPointerMap + :: AlonzoEraOnwards era + -> (Witnessable witnessable era, AnyWitness era) + -> L.Redeemers (ShelleyLedgerEra era) +getAnyWitnessRedeemerPointerMap eon (_, AnyKeyWitness) = alonzoEraOnwardsConstraints eon mempty +getAnyWitnessRedeemerPointerMap eon (_, AnySimpleScriptWitness{}) = alonzoEraOnwardsConstraints eon mempty +getAnyWitnessRedeemerPointerMap eon anyWit = + constructRedeeemerPointerMap eon $ + createIndexedPlutusScriptWitnesses [anyWit] + +constructRedeeemerPointerMap + :: AlonzoEraOnwards era + -> [AnyIndexedPlutusScriptWitness era] + -> L.Redeemers (ShelleyLedgerEra era) +constructRedeeemerPointerMap eon scriptWits = + let redeemerPointers = map (constructRedeemerPointer eon) scriptWits + in alonzoEraOnwardsConstraints eon $ mconcat redeemerPointers + +constructRedeemerPointer + :: AlonzoEraOnwards era + -> AnyIndexedPlutusScriptWitness era + -> L.Redeemers (ShelleyLedgerEra era) +constructRedeemerPointer eon (AnyIndexedPlutusScriptWitness (IndexedPlutusScriptWitness _ purpose scriptWit)) = + let PlutusScriptWitness _ _ _ redeemer execUnits = scriptWit + in alonzoEraOnwardsConstraints eon $ + L.Redeemers $ + fromList [(purpose, (toAlonzoData redeemer, toAlonzoExUnits execUnits))] + +---------------------------------------------- +-- TEST +---------------------------------------------- + +mkPlutusScriptWitness + :: AlonzoEraOnwards era + -> L.SLanguage plutuslang + -> L.PlutusRunnable plutuslang + -> PlutusScriptDatumGADT plutuslang purpose + -> ScriptRedeemer + -> ExecutionUnits + -> PlutusScriptWitness plutuslang purpose era +mkPlutusScriptWitness _ l plutusScriptRunnable datum scriptRedeemer execUnits = + PlutusScriptWitness + l + (PScript $ PlutusScriptInEra plutusScriptRunnable) + datum + scriptRedeemer + execUnits + +-- PROPOSED REPLACEMENT +----------------------------------------------- + +------------------------------------------------ diff --git a/cardano-api/src/Cardano/Api/Internal/Experimental/Plutus/Shim/LegacyScripts.hs b/cardano-api/src/Cardano/Api/Internal/Experimental/Plutus/Shim/LegacyScripts.hs new file mode 100644 index 000000000..00dd39ca6 --- /dev/null +++ b/cardano-api/src/Cardano/Api/Internal/Experimental/Plutus/Shim/LegacyScripts.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} + +module Cardano.Api.Internal.Experimental.Plutus.Shim.LegacyScripts + ( legacyCreateWitnessIndexedTxIns + , legacyWitnessConversion + , indexedWithdrawalScriptWitnesses + , legacyWitnessToScriptRequirements + ) +where + +import Cardano.Api.Internal.Eon.AlonzoEraOnwards +import Cardano.Api.Internal.Eon.ShelleyBasedEra +import Cardano.Api.Internal.Experimental.Plutus.Script +import Cardano.Api.Internal.Experimental.Plutus.ScriptWitness +import Cardano.Api.Internal.Experimental.Simple.Script +import Cardano.Api.Internal.Pretty +import Cardano.Api.Internal.Script + ( ExecutionUnits + , Witness + ) +import Cardano.Api.Internal.Script qualified as Old +import Cardano.Api.Internal.Tx.BuildTxWith +import Cardano.Api.Internal.TxIn + +import Cardano.Binary qualified as CBOR +import Cardano.Ledger.Alonzo.Scripts qualified as L +import Cardano.Ledger.BaseTypes (Version) +import Cardano.Ledger.Core qualified as L +import Cardano.Ledger.Plutus.Language qualified as L + +import Data.Text qualified as Text + +-- | This module is concerned with converting legacy api scripts and by extension +-- script witnesses to the new api. + +-- Remember we don't care about simple script witnesses beyond the fact that they require key witnesses +-- and therefore contribute to the determination of the script witness index. +fromExistingApi + :: AlonzoEraOnwards era + -> (Witnessable thing era, BuildTxWith BuildTx (Witness witctx era)) + -> Either CBOR.DecoderError (Witnessable thing era, AnyWitness era) +fromExistingApi _ (witnessable, BuildTxWith (Old.KeyWitness _)) = + return (witnessable, AnyKeyWitness) +fromExistingApi _ (witnessable, BuildTxWith (Old.ScriptWitness _ Old.SimpleScriptWitness{})) = + return (witnessable, AnyKeyWitness) +fromExistingApi eon (witnessable, BuildTxWith (Old.ScriptWitness _ oldApiPlutusScriptWitness)) = + convertToNewPlutusScriptWitness eon oldApiPlutusScriptWitness witnessable + +type family ToPlutusScriptPurpose witnessable = (purpose :: PlutusScriptPurpose) | purpose -> witnessable where + ToPlutusScriptPurpose TxIn = SpendingScript + ToPlutusScriptPurpose Withdrawal = WithdrawingScript + ToPlutusScriptPurpose Mint = MintingScript + +convertToNewPlutusScriptWitness + :: AlonzoEraOnwards era + -> Old.ScriptWitness witctx era + -> Witnessable thing era + -> Either CBOR.DecoderError (Witnessable thing era, AnyWitness era) +convertToNewPlutusScriptWitness eon (Old.PlutusScriptWitness _ v scriptOrRefInput datum scriptRedeemer execUnits) witnessable = do + let d = createDatum witnessable v datum + newScriptWitness <- + obtainConstraints v $ + toNewPlutusScriptWitness + eon + v + scriptOrRefInput + scriptRedeemer + execUnits + d + return $ (witnessable, newScriptWitness) +convertToNewPlutusScriptWitness eon (Old.SimpleScriptWitness _ scriptOrRefInput) witnessable = + case scriptOrRefInput of + Old.SScript simpleScript -> do + let timelock = convertTotimelock eon simpleScript + return (witnessable, AnySimpleScriptWitness $ SScript $ SimpleScript timelock) + Old.SReferenceScript txIn -> + return (witnessable, AnySimpleScriptWitness $ SReferenceScript txIn) + +convertTotimelock + :: AlonzoEraOnwards era -> Old.SimpleScript -> L.NativeScript (ShelleyLedgerEra era) +convertTotimelock eon s = alonzoEraOnwardsConstraints eon $ Old.toAllegraTimelock s + +createDatum + :: Witnessable thing era + -> Old.PlutusScriptVersion lang + -> Old.ScriptDatum witctx + -> PlutusScriptDatumGADT (Old.ToLedgerPlutusLanguage lang) SpendingScript +createDatum missingContext plutusVersion oldDatum = + case (missingContext, oldDatum) of + (w@WitTxIn{}, d@Old.ScriptDatumForTxIn{}) -> toCip69Datum w plutusVersion d + (WitTxIn{}, Old.InlineScriptDatum) -> NoScriptDatum + (WitTxIn{}, _) -> + error $ + unlines + [ "createDatum: invalid combination of witnessable and script datum" + , "Witnessable: " ++ show missingContext + , "Script Datum: " ++ show oldDatum + ] + (WitMint{}, _) -> NoScriptDatum + (WitWithdrawal{}, _) -> NoScriptDatum + (WitProposal{}, _) -> NoScriptDatum + (WitVote{}, _) -> NoScriptDatum + (WitTxCert{}, _) -> NoScriptDatum + +toCip69Datum + :: Witnessable TxIn era + -> Old.PlutusScriptVersion lang + -> Old.ScriptDatum Old.WitCtxTxIn + -> PlutusScriptDatumGADT (Old.ToLedgerPlutusLanguage lang) (ToPlutusScriptPurpose TxIn) +-- ^ Encapsulates CIP-69: V3 spending script datums are optional +toCip69Datum WitTxIn{} Old.PlutusScriptV3 (Old.ScriptDatumForTxIn r) = SpendingScriptDatum r +-- \^ V2 and V1 spending script datums are required +toCip69Datum WitTxIn{} Old.PlutusScriptV2 (Old.ScriptDatumForTxIn (Just r)) = SpendingScriptDatum r +toCip69Datum WitTxIn{} Old.PlutusScriptV1 (Old.ScriptDatumForTxIn (Just r)) = SpendingScriptDatum r +-- \^ V2 and V3 scripts can have inline datums +toCip69Datum WitTxIn{} Old.PlutusScriptV3 (Old.InlineScriptDatum) = InlineDatum +toCip69Datum WitTxIn{} Old.PlutusScriptV2 (Old.InlineScriptDatum) = InlineDatum +-- \^ Everything else is not allowed. The old api does not prevent these invalid combinations +-- so we are forced to error here. The valid combinations are enforced in the PlutusScriptDatum +-- type family within the resultant PlutusScriptDatumGADT GADT. +toCip69Datum WitTxIn{} scriptVersion datum = + error $ + unlines + [ "toCip69Datum: invalid combination of script version and script datum" + , "Script Version: " ++ show scriptVersion + , "Script Datum: " ++ show datum + ] + +toNewPlutusScriptWitness + :: forall era lang purpose + . L.PlutusLanguage (Old.ToLedgerPlutusLanguage lang) + => AlonzoEraOnwards era + -> Old.PlutusScriptVersion lang + -> Old.PlutusScriptOrReferenceInput lang + -> ScriptRedeemer + -> ExecutionUnits + -> PlutusScriptDatumGADT (Old.ToLedgerPlutusLanguage lang) purpose + -> Either + CBOR.DecoderError + ( AnyWitness + era + ) +toNewPlutusScriptWitness eon l (Old.PScript (Old.PlutusScriptSerialised scriptShortBs)) scriptRedeemer execUnits datum = do + let protocolVersion = getVersion eon + plutusScript = L.Plutus $ L.PlutusBinary scriptShortBs + + case L.decodePlutusRunnable @(Old.ToLedgerPlutusLanguage lang) protocolVersion plutusScript of + Left e -> + Left $ + CBOR.DecoderErrorCustom "PlutusLedgerApi.Common.ScriptDecodeError" (Text.pack . show $ pretty e) + Right plutusScriptRunnable -> + return + . AnyPlutusScriptWitness + $ mkPlutusScriptWitness + eon + (toPlutusSLanguage l) + plutusScriptRunnable + datum + scriptRedeemer + execUnits +toNewPlutusScriptWitness _ l (Old.PReferenceScript refInput) scriptRedeemer execUnits datum = + return . AnyPlutusScriptWitness $ + PlutusScriptWitness (toPlutusSLanguage l) (PReferenceScript refInput) datum scriptRedeemer execUnits + +getVersion :: forall era. AlonzoEraOnwards era -> Version +getVersion eon = alonzoEraOnwardsConstraints eon $ L.eraProtVerLow @(ShelleyLedgerEra era) + +obtainConstraints + :: Old.PlutusScriptVersion lang + -> (L.PlutusLanguage (Old.ToLedgerPlutusLanguage lang) => a) + -> a +obtainConstraints v = + case v of + Old.PlutusScriptV1 -> id + Old.PlutusScriptV2 -> id + Old.PlutusScriptV3 -> id + +toPlutusSLanguage + :: Old.PlutusScriptVersion lang -> L.SLanguage (Old.ToLedgerPlutusLanguage lang) +toPlutusSLanguage = \case + Old.PlutusScriptV1 -> L.SPlutusV1 + Old.PlutusScriptV2 -> L.SPlutusV2 + Old.PlutusScriptV3 -> L.SPlutusV3 + +{- +In the end when it comes to plutus scripts we need to provide +the following to the tx: +1. The redeemer pointer map +2. The set of plutus languages in use +3. The set of plutus scripts in use (present in the t) +4. The datum map + +Assuming the above can work lets see how it looks because then we can deprecate the internal +usage of the existing script api and eventually remove it +-} + +legacyWitnessConversion + :: AlonzoEraOnwards era + -> [(Witnessable witnessable era, BuildTxWith BuildTx (Witness ctx era))] + -> Either CBOR.DecoderError [(Witnessable witnessable era, AnyWitness era)] +legacyWitnessConversion eon = mapM (fromExistingApi eon) + +legacyWitnessToScriptRequirements + :: AlonzoEraOnwards era + -> [(Witnessable witnessable era, BuildTxWith BuildTx (Witness ctx era))] + -> Either CBOR.DecoderError (TxScriptWitnessRequirements era) +legacyWitnessToScriptRequirements eon wits = do + r <- legacyWitnessConversion eon wits + return $ getTxScriptWitnessesRequirements eon r + +indexedTxInScriptWitnesses + :: [(Witnessable TxIn era, AnyWitness era)] + -> [AnyIndexedPlutusScriptWitness era] +indexedTxInScriptWitnesses = createIndexedPlutusScriptWitnesses + +legacyCreateWitnessIndexedTxIns + :: AlonzoEraOnwards era + -> [(Witnessable TxIn era, BuildTxWith BuildTx (Witness Old.WitCtxTxIn era))] + -> Either CBOR.DecoderError [AnyIndexedPlutusScriptWitness era] +legacyCreateWitnessIndexedTxIns eon ins = + indexedTxInScriptWitnesses <$> legacyWitnessConversion eon ins + +indexedWithdrawalScriptWitnesses + :: [(Witnessable Withdrawal era, AnyWitness era)] + -> [AnyIndexedPlutusScriptWitness era] +indexedWithdrawalScriptWitnesses = createIndexedPlutusScriptWitnesses diff --git a/cardano-api/src/Cardano/Api/Internal/Experimental/Simple/Script.hs b/cardano-api/src/Cardano/Api/Internal/Experimental/Simple/Script.hs new file mode 100644 index 000000000..8da006dc5 --- /dev/null +++ b/cardano-api/src/Cardano/Api/Internal/Experimental/Simple/Script.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE GADTs #-} + +module Cardano.Api.Internal.Experimental.Simple.Script + ( SimpleScript (..) + , SimpleScriptOrReferenceInput (..) + ) +where + +import Cardano.Api.Internal.Eon.ShelleyBasedEra +import Cardano.Api.Internal.TxIn (TxIn) + +import Cardano.Ledger.Core qualified as Ledger + +-- | A simple script in a particular era. We leverage ledger's Cardano.Api.Experimental.ErasraScript +-- type class methods to work with the script. +data SimpleScript era where + SimpleScript :: Ledger.NativeScript (ShelleyLedgerEra era) -> SimpleScript era + +-- SimpleScript :: Ledger.EraScript era => Ledger.Timelock (LedgerEra era) -> SimpleScript era + +data SimpleScriptOrReferenceInput era + = SScript (SimpleScript era) + | SReferenceScript TxIn diff --git a/cardano-api/src/Cardano/Api/Internal/Experimental/Tx.hs b/cardano-api/src/Cardano/Api/Internal/Experimental/Tx.hs index 8057b3cb2..1d3937ebe 100644 --- a/cardano-api/src/Cardano/Api/Internal/Experimental/Tx.hs +++ b/cardano-api/src/Cardano/Api/Internal/Experimental/Tx.hs @@ -127,6 +127,7 @@ import Cardano.Api.Internal.Eon.Convert import Cardano.Api.Internal.Eon.ShelleyBasedEra import Cardano.Api.Internal.Eras.Core (ToCardanoEra (toCardanoEra), forEraInEon) import Cardano.Api.Internal.Experimental.Eras +import Cardano.Api.Internal.Experimental.Plutus.ScriptWitness (TxScriptWitnessRequirements (..)) import Cardano.Api.Internal.Feature import Cardano.Api.Internal.Pretty (docToString, pretty) import Cardano.Api.Internal.ReexposeLedger (StrictMaybe (..), maybeToStrictMaybe) @@ -168,10 +169,13 @@ makeUnsignedTx -> Either TxBodyError (UnsignedTx era) makeUnsignedTx era bc = obtainCommonConstraints era $ do let sbe = convert era + aeon = convert era + TxScriptWitnessRequirements languages scripts datums redeemers <- + shelleyBasedEraConstraints sbe $ + collectTxBodyScriptWitnessRequirements (convert era) bc -- cardano-api types let apiTxOuts = txOuts bc - apiScriptWitnesses = collectTxBodyScriptWitnesses sbe bc apiScriptValidity = txScriptValidity bc apiMintValue = txMintValue bc apiProtocolParameters = txProtocolParams bc @@ -192,12 +196,13 @@ makeUnsignedTx era bc = obtainCommonConstraints era $ do totalCollateral = convTotalCollateral apiTotalCollateral certs = convCertificates sbe $ txCertificates bc txAuxData = toAuxiliaryData sbe (txMetadata bc) (txAuxScripts bc) - scripts = convScripts apiScriptWitnesses - languages = convLanguages apiScriptWitnesses - sData = convScriptData sbe apiTxOuts apiScriptWitnesses - (datums, redeemers) = case sData of - TxBodyScriptData _ ds rs -> (ds, rs) - TxBodyNoScriptData -> (mempty, L.Redeemers mempty) + scriptIntegrityHash = + convPParamsToScriptIntegrityHash + aeon + apiProtocolParameters + redeemers + datums + languages let setMint = convMintValue apiMintValue setReqSignerHashes = convExtraKeyWitnesses apiExtraKeyWitnesses @@ -213,7 +218,7 @@ makeUnsignedTx era bc = obtainCommonConstraints era $ do & L.vldtTxBodyL . L.invalidBeforeL .~ convValidityLowerBound (txValidityLowerBound bc) & L.vldtTxBodyL . L.invalidHereAfterL .~ convValidityUpperBound sbe (txValidityUpperBound bc) & L.reqSignerHashesTxBodyL .~ setReqSignerHashes - & L.scriptIntegrityHashTxBodyL .~ getScriptIntegrityHash apiProtocolParameters languages sData + & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash & L.withdrawalsTxBodyL .~ withdrawals & L.certsTxBodyL .~ certs & L.mintTxBodyL .~ setMint diff --git a/cardano-api/src/Cardano/Api/Internal/Governance/Actions/ProposalProcedure.hs b/cardano-api/src/Cardano/Api/Internal/Governance/Actions/ProposalProcedure.hs index e0c71da25..eb84ae9a9 100644 --- a/cardano-api/src/Cardano/Api/Internal/Governance/Actions/ProposalProcedure.hs +++ b/cardano-api/src/Cardano/Api/Internal/Governance/Actions/ProposalProcedure.hs @@ -37,6 +37,8 @@ import Cardano.Ledger.Keys (KeyRole (ColdCommitteeRole)) import Data.ByteString (ByteString) import Data.Map.Strict (Map) import Data.Maybe (fromMaybe) +import Data.Type.Equality (TestEquality (..)) +import Data.Typeable import Data.Word import GHC.Exts (IsList (..)) @@ -144,7 +146,19 @@ fromGovernanceAction = \case Gov.InfoAction -> InfoAct -newtype Proposal era = Proposal {unProposal :: Gov.ProposalProcedure (ShelleyLedgerEra era)} +data Proposal era where + Proposal :: Typeable era => Gov.ProposalProcedure (ShelleyLedgerEra era) -> Proposal era + +instance TestEquality Proposal where + testEquality (Proposal v) (Proposal v') = + proposalTypeEquality v v' + +proposalTypeEquality + :: (Typeable eraA, Typeable eraB) + => Gov.ProposalProcedure (ShelleyLedgerEra eraA) + -> Gov.ProposalProcedure (ShelleyLedgerEra eraB) + -> Maybe (eraA :~: eraB) +proposalTypeEquality _ _ = eqT instance IsShelleyBasedEra era => Show (Proposal era) where show (Proposal pp) = do diff --git a/cardano-api/src/Cardano/Api/Internal/Governance/Actions/VotingProcedure.hs b/cardano-api/src/Cardano/Api/Internal/Governance/Actions/VotingProcedure.hs index 78ec8190c..963ae5524 100644 --- a/cardano-api/src/Cardano/Api/Internal/Governance/Actions/VotingProcedure.hs +++ b/cardano-api/src/Cardano/Api/Internal/Governance/Actions/VotingProcedure.hs @@ -12,6 +12,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Cardano.Api.Internal.Governance.Actions.VotingProcedure where @@ -35,6 +36,8 @@ import Data.Map qualified as Map import Data.Set qualified as Set import Data.Text (Text) import Data.Text.Encoding qualified as Text +import Data.Type.Equality (TestEquality (..)) +import Data.Typeable import GHC.Generics newtype GovernanceActionId era = GovernanceActionId @@ -52,8 +55,25 @@ instance IsShelleyBasedEra era => FromCBOR (GovernanceActionId era) where !v <- shelleyBasedEraConstraints (shelleyBasedEra @era) $ Ledger.fromEraCBOR @(ShelleyLedgerEra era) return $ GovernanceActionId v -newtype Voter era = Voter (Ledger.Voter (L.EraCrypto (ShelleyLedgerEra era))) - deriving (Show, Eq, Ord) +data Voter era where + Voter :: Typeable era => (Ledger.Voter (L.EraCrypto (ShelleyLedgerEra era))) -> Voter era + +deriving instance Show (Voter era) + +deriving instance Eq (Voter era) + +deriving instance Ord (Voter era) + +instance TestEquality Voter where + testEquality (Voter v) (Voter v') = + voterTypeEquality v v' + +voterTypeEquality + :: (Typeable eraA, Typeable eraB) + => Ledger.Voter (L.EraCrypto (ShelleyLedgerEra eraA)) + -> Ledger.Voter (L.EraCrypto (ShelleyLedgerEra eraB)) + -> Maybe (eraA :~: eraB) +voterTypeEquality _ _ = eqT instance IsShelleyBasedEra era => ToCBOR (Voter era) where toCBOR (Voter v) = shelleyBasedEraConstraints (shelleyBasedEra @era) $ Ledger.toEraCBOR @(ShelleyLedgerEra era) v diff --git a/cardano-api/src/Cardano/Api/Internal/Script.hs b/cardano-api/src/Cardano/Api/Internal/Script.hs index 434a20a77..79777b95e 100644 --- a/cardano-api/src/Cardano/Api/Internal/Script.hs +++ b/cardano-api/src/Cardano/Api/Internal/Script.hs @@ -95,6 +95,8 @@ module Cardano.Api.Internal.Script , ScriptHash (..) , hashScript + -- * Internal type families + -- * Internal conversion functions , toShelleyScript , fromShelleyBasedScript @@ -1399,6 +1401,7 @@ instance ToJSON SimpleScript where ] instance FromJSON SimpleScript where + parseJSON :: Value -> Aeson.Parser SimpleScript parseJSON = parseSimpleScript parseSimpleScript :: Value -> Aeson.Parser SimpleScript diff --git a/cardano-api/src/Cardano/Api/Internal/ScriptData.hs b/cardano-api/src/Cardano/Api/Internal/ScriptData.hs index 15fd0aec5..610fb9e01 100644 --- a/cardano-api/src/Cardano/Api/Internal/ScriptData.hs +++ b/cardano-api/src/Cardano/Api/Internal/ScriptData.hs @@ -10,7 +10,7 @@ module Cardano.Api.Internal.ScriptData ( -- * Script data - HashableScriptData + HashableScriptData (..) , hashScriptDataBytes , getOriginalScriptDataBytes , getScriptData diff --git a/cardano-api/src/Cardano/Api/Internal/Tx/Body.hs b/cardano-api/src/Cardano/Api/Internal/Tx/Body.hs index 6409b710a..16fd919da 100644 --- a/cardano-api/src/Cardano/Api/Internal/Tx/Body.hs +++ b/cardano-api/src/Cardano/Api/Internal/Tx/Body.hs @@ -335,6 +335,7 @@ module Cardano.Api.Internal.Tx.Body , ScriptWitnessIndex (..) , renderScriptWitnessIndex , collectTxBodyScriptWitnesses + , collectTxBodyScriptWitnessRequirements , toScriptIndex -- ** Conversion to inline data @@ -346,6 +347,7 @@ module Cardano.Api.Internal.Tx.Body , convExtraKeyWitnesses , convLanguages , convMintValue + , convPParamsToScriptIntegrityHash , convReferenceInputs , convReturnCollateral , convScripts @@ -403,7 +405,18 @@ import Cardano.Api.Internal.Eon.ShelleyToBabbageEra import Cardano.Api.Internal.Eras.Case import Cardano.Api.Internal.Eras.Core import Cardano.Api.Internal.Error (Error (..), displayError) +import Cardano.Api.Internal.Experimental.Plutus.ScriptWitness + ( AnyCertificate (..) + , AnyProposal (..) + , AnyVoter (..) + , TxScriptWitnessRequirements (..) + , Witnessable (..) + , obtainAlonzoScriptPurposeConstraints + , obtainMonoidConstraint + ) +import Cardano.Api.Internal.Experimental.Plutus.Shim.LegacyScripts import Cardano.Api.Internal.Feature +import Cardano.Api.Internal.Governance.Actions.ProposalProcedure import Cardano.Api.Internal.Governance.Actions.VotingProcedure import Cardano.Api.Internal.Hash import Cardano.Api.Internal.Keys.Byron @@ -417,6 +430,7 @@ import Cardano.Api.Internal.ScriptData import Cardano.Api.Internal.SerialiseCBOR import Cardano.Api.Internal.SerialiseJSON import Cardano.Api.Internal.SerialiseRaw +import Cardano.Api.Internal.Tx.BuildTxWith import Cardano.Api.Internal.Tx.Sign import Cardano.Api.Internal.TxIn import Cardano.Api.Internal.TxMetadata @@ -497,9 +511,13 @@ import Data.String import Data.Text (Text) import Data.Text qualified as Text import Data.Text.Encoding qualified as Text +import Data.Text.Lazy qualified as LText +import Data.Text.Lazy.Builder qualified as LText import Data.Type.Equality import Data.Typeable import Data.Word (Word16, Word32, Word64) +import Formatting.Buildable (Buildable) +import Formatting.Buildable qualified as Build import GHC.Exts (IsList (..)) import GHC.Stack import Lens.Micro hiding (ix) @@ -1080,38 +1098,6 @@ fromBabbageTxOutDatum w _ (Plutus.DatumHash dh) = fromBabbageTxOutDatum _ w (Plutus.Datum binData) = TxOutDatumInline w $ binaryDataToScriptData w binData --- ---------------------------------------------------------------------------- --- Building vs viewing transactions --- - -data ViewTx - -data BuildTx - -data BuildTxWith build a where - ViewTx :: BuildTxWith ViewTx a - BuildTxWith :: a -> BuildTxWith BuildTx a - -instance Functor (BuildTxWith build) where - fmap _ ViewTx = ViewTx - fmap f (BuildTxWith x) = BuildTxWith (f x) - -instance Applicative (BuildTxWith ViewTx) where - pure _ = ViewTx - _ <*> _ = ViewTx - -instance Applicative (BuildTxWith BuildTx) where - pure = BuildTxWith - (BuildTxWith f) <*> (BuildTxWith a) = BuildTxWith (f a) - -buildTxWithToMaybe :: BuildTxWith build a -> Maybe a -buildTxWithToMaybe ViewTx = Nothing -buildTxWithToMaybe (BuildTxWith a) = Just a - -deriving instance Eq a => Eq (BuildTxWith build a) - -deriving instance Show a => Show (BuildTxWith build a) - -- ---------------------------------------------------------------------------- -- Transaction input values (era-dependent) -- @@ -2035,7 +2021,8 @@ getTxIdShelley _ tx = -- data TxBodyError - = TxBodyEmptyTxIns + = TxBodyPlutusScriptDecodeError CBOR.DecoderError + | TxBodyEmptyTxIns | TxBodyEmptyTxInsCollateral | TxBodyEmptyTxOuts | TxBodyOutputNegative !Quantity !TxOutInAnyEra @@ -2046,8 +2033,13 @@ data TxBodyError | TxBodyProtocolParamsConversionError !ProtocolParametersConversionError deriving (Eq, Show) +renderBuildable :: Buildable a => a -> Text +renderBuildable e = LText.toStrict . LText.toLazyText $ Build.build e + instance Error TxBodyError where prettyError = \case + TxBodyPlutusScriptDecodeError err -> + "Error decoding Plutus script: " <> pretty (renderBuildable err) TxBodyEmptyTxIns -> "Transaction body has no inputs" TxBodyEmptyTxInsCollateral -> @@ -3833,6 +3825,133 @@ collectTxBodyScriptWitnesses | (ix, _, witness) <- indexTxProposalProcedures txp ] +getSupplementalDatums :: [TxOut CtxTx era] -> L.TxDats (ShelleyLedgerEra era) +getSupplementalDatums = undefined + +collectTxBodyScriptWitnessRequirements + :: forall era + . IsShelleyBasedEra era + => AlonzoEraOnwards era + -> TxBodyContent BuildTx era + -> Either + TxBodyError + (TxScriptWitnessRequirements era) +collectTxBodyScriptWitnessRequirements + aEon + TxBodyContent + { txIns + , txOuts + , txWithdrawals + , txCertificates + , txMintValue + , txVotingProcedures + , txProposalProcedures + } = + obtainAlonzoScriptPurposeConstraints aEon $ do + let sbe = shelleyBasedEra @era + let supplementaldatums = TxScriptWitnessRequirements mempty mempty (getSupplementalDatums txOuts) mempty + txInWits <- + first TxBodyPlutusScriptDecodeError $ + legacyWitnessToScriptRequirements aEon $ + List.nub [(WitTxIn txin, wit) | (txin, wit) <- txIns] + + txWithdrawalWits <- + first TxBodyPlutusScriptDecodeError $ + legacyWitnessToScriptRequirements aEon $ + List.nub + [ (WitWithdrawal (addr, withAmt), wit) + | (addr, withAmt, wit) <- getWithdrawals txWithdrawals + ] + txCertWits <- + first TxBodyPlutusScriptDecodeError $ + legacyWitnessToScriptRequirements aEon $ + List.nub + [ ( WitTxCert (AnyCertificate cert, stakeCred) + , BuildTxWith wit + ) + | (cert, BuildTxWith (Just (stakeCred, wit))) <- getCertificates txCertificates + ] + + txMintWits <- + first TxBodyPlutusScriptDecodeError $ + legacyWitnessToScriptRequirements aEon $ + List.nub + [ (WitMint (policyId, assetName, quantity), BuildTxWith $ ScriptWitness ScriptWitnessForMinting wit) + | (policyId, assetsWithWits) <- getMints txMintValue + , (assetName, quantity, BuildTxWith wit) <- assetsWithWits + ] + + txVotingWits <- + caseShelleyToBabbageOrConwayEraOnwards + (const $ Right $ TxScriptWitnessRequirements mempty mempty mempty mempty) + ( const $ + first TxBodyPlutusScriptDecodeError $ + legacyWitnessToScriptRequirements aEon $ + List.nub + [ (WitVote $ AnyVoter vote, BuildTxWith wit) + | (vote, wit) <- getVotes $ maybe TxVotingProceduresNone unFeatured txVotingProcedures + ] + ) + sbe + txProposalWits <- + caseShelleyToBabbageOrConwayEraOnwards + (const $ Right $ TxScriptWitnessRequirements mempty mempty mempty mempty) + ( const $ + first TxBodyPlutusScriptDecodeError $ + legacyWitnessToScriptRequirements aEon $ + List.nub + [ (WitProposal $ AnyProposal prop, BuildTxWith wit) + | (prop, wit) <- + getProposals $ maybe TxProposalProceduresNone unFeatured txProposalProcedures + ] + ) + sbe + + return $ + obtainMonoidConstraint aEon $ + mconcat + [ supplementaldatums + , txInWits + , txWithdrawalWits + , txCertWits + , txMintWits + , txVotingWits + , txProposalWits + ] + where + getWithdrawals TxWithdrawalsNone = [] + getWithdrawals (TxWithdrawals _ txws) = txws + + getCertificates TxCertificatesNone = [] + getCertificates (TxCertificates _ txcs) = toList txcs + + getMints TxMintNone = [] + getMints (TxMintValue _ txms) = toList txms + + getVotes + :: TxVotingProcedures BuildTx era + -> [(Voter era, Witness WitCtxStake era)] + getVotes TxVotingProceduresNone = [] + getVotes (TxVotingProcedures allVotingProcedures (BuildTxWith scriptWitnessedVotes)) = + [ (Voter singleVoter, wit) + | (singleVoter, _) <- toList $ L.unVotingProcedures allVotingProcedures + , let wit = case Map.lookup singleVoter scriptWitnessedVotes of + Just sWit -> ScriptWitness ScriptWitnessForStakeAddr sWit + Nothing -> KeyWitness KeyWitnessForStakeAddr + ] + + getProposals + :: TxProposalProcedures BuildTx era + -> [(Proposal era, Witness WitCtxStake era)] + getProposals TxProposalProceduresNone = [] + getProposals (TxProposalProcedures txps) = + [ (Proposal p, wit) + | (p, BuildTxWith mScriptWit) <- toList txps + , let wit = case mScriptWit of + Just sWit -> ScriptWitness ScriptWitnessForStakeAddr sWit + Nothing -> KeyWitness KeyWitnessForStakeAddr + ] + -- TODO: Investigate if we need toShelleyWithdrawal :: [(StakeAddress, L.Coin, a)] -> L.Withdrawals StandardCrypto toShelleyWithdrawal withdrawals = diff --git a/cardano-api/src/Cardano/Api/Internal/Tx/BuildTxWith.hs b/cardano-api/src/Cardano/Api/Internal/Tx/BuildTxWith.hs new file mode 100644 index 000000000..bb4623049 --- /dev/null +++ b/cardano-api/src/Cardano/Api/Internal/Tx/BuildTxWith.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Cardano.Api.Internal.Tx.BuildTxWith + ( BuildTxWith (..) + , BuildTx + , ViewTx + , buildTxWithToMaybe + ) +where + +-- ---------------------------------------------------------------------------- +-- Building vs viewing transactions +-- + +data ViewTx + +data BuildTx + +data BuildTxWith build a where + ViewTx :: BuildTxWith ViewTx a + BuildTxWith :: a -> BuildTxWith BuildTx a + +instance Functor (BuildTxWith build) where + fmap _ ViewTx = ViewTx + fmap f (BuildTxWith x) = BuildTxWith (f x) + +instance Applicative (BuildTxWith ViewTx) where + pure _ = ViewTx + _ <*> _ = ViewTx + +instance Applicative (BuildTxWith BuildTx) where + pure = BuildTxWith + (BuildTxWith f) <*> (BuildTxWith a) = BuildTxWith (f a) + +buildTxWithToMaybe :: BuildTxWith build a -> Maybe a +buildTxWithToMaybe ViewTx = Nothing +buildTxWithToMaybe (BuildTxWith a) = Just a + +deriving instance Eq a => Eq (BuildTxWith build a) + +deriving instance Show a => Show (BuildTxWith build a)