diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index a3918bf26d..aaf60474df 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -72,6 +72,7 @@ library Cardano.Api.Era Cardano.Api.Error Cardano.Api.Experimental + Cardano.Api.Experimental.AnyScriptWitness Cardano.Api.Experimental.Certificate Cardano.Api.Experimental.Era Cardano.Api.Experimental.Plutus @@ -229,13 +230,13 @@ library Cardano.Api.Experimental.Plutus.Internal.Shim.LegacyScripts Cardano.Api.Experimental.Serialise.TextEnvelope.Internal Cardano.Api.Experimental.Tx.Internal.AnyWitness - Cardano.Api.Experimental.Tx.Internal.Body + Cardano.Api.Experimental.Tx.Internal.BodyContent.New Cardano.Api.Experimental.Tx.Internal.Certificate Cardano.Api.Experimental.Tx.Internal.Certificate.Compatible Cardano.Api.Experimental.Tx.Internal.Certificate.Type - Cardano.Api.Experimental.Tx.Internal.Compatible Cardano.Api.Experimental.Tx.Internal.Fee Cardano.Api.Experimental.Tx.Internal.TxScriptWitnessRequirements + Cardano.Api.Experimental.Tx.Internal.Type Cardano.Api.Genesis.Internal Cardano.Api.Genesis.Internal.Parameters Cardano.Api.Governance.Internal.Action.ProposalProcedure @@ -306,6 +307,7 @@ library gen Test.Gen.Cardano.Api Test.Gen.Cardano.Api.Byron Test.Gen.Cardano.Api.Era + Test.Gen.Cardano.Api.Experimental Test.Gen.Cardano.Api.Hardcoded Test.Gen.Cardano.Api.Metadata Test.Gen.Cardano.Api.Orphans @@ -343,6 +345,7 @@ library gen hedgehog-extras, hedgehog-quickcheck, iproute, + ordered-containers, quickcheck-instances, random, tasty, @@ -388,6 +391,7 @@ test-suite cardano-api-test hedgehog-quickcheck, microlens, mtl, + ordered-containers, ouroboros-consensus, ouroboros-consensus-protocol, raw-strings-qq, diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Experimental.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Experimental.hs new file mode 100644 index 0000000000..3d497d634d --- /dev/null +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Experimental.hs @@ -0,0 +1,89 @@ +module Test.Gen.Cardano.Api.Experimental + ( genScriptWitnessedTxCertificates + , genScriptWitnessedTxIn + , genScriptWitnessedTxMintValue + , genScriptWitnessedTxProposals + , genScriptWitnesssedTxVotingProcedures + , genScriptWitnessedTxWithdrawals + ) +where + +import Cardano.Api (TxIn) +import Cardano.Api.Experimental +import Cardano.Api.Experimental.AnyScriptWitness +import Cardano.Api.Experimental.Tx +import Cardano.Api.Ledger qualified as L + +import Data.Map.Ordered.Strict qualified as OMap + +import Test.Gen.Cardano.Api.Typed (genExecutionUnits, genHashableScriptData, genTxIn) + +import Hedgehog (Gen) +import Hedgehog.Gen qualified as Gen + +genAnyWitness :: Gen (AnyWitness era) +genAnyWitness = + Gen.choice + [ return AnyKeyWitnessPlaceholder + , AnySimpleScriptWitness <$> genAnySimpleScriptWitness + , Gen.choice + [ genAnyPlutusScriptWitnessV1 + , genAnyPlutusScriptWitnessV2 + , genAnyPlutusScriptWitnessV3 + , genAnyPlutusScriptWitnessV4 + ] + ] + +genAnyPlutusScriptWitnessV1 :: Gen (AnyWitness era) +genAnyPlutusScriptWitnessV1 = + AnyPlutusScriptWitness <$> fmap AnyPlutusMintingScriptWitness (genPlutusScriptWitness L.SPlutusV1) + +genAnyPlutusScriptWitnessV2 :: Gen (AnyWitness era) +genAnyPlutusScriptWitnessV2 = + AnyPlutusScriptWitness <$> error "TODO" -- genPlutusScriptWitness L.SPlutusV2 + +genAnyPlutusScriptWitnessV3 :: Gen (AnyWitness era) +genAnyPlutusScriptWitnessV3 = + AnyPlutusScriptWitness <$> error "TODO" -- genPlutusScriptWitness L.SPlutusV3 + +genAnyPlutusScriptWitnessV4 :: Gen (AnyWitness era) +genAnyPlutusScriptWitnessV4 = + AnyPlutusScriptWitness <$> error "TODO" -- genPlutusScriptWitness L.SPlutusV4 + +genAnySimpleScriptWitness :: Gen (SimpleScriptOrReferenceInput era) +genAnySimpleScriptWitness = SReferenceScript <$> genTxIn + +-- TODO: <|> (SScript <$> genSimpleScriptWitness) + +genPlutusScriptWitness :: L.SLanguage lang -> Gen (PlutusScriptWitness lang purpose era) +genPlutusScriptWitness l = + PlutusScriptWitness l + <$> genPlutusScript + <*> genMaybeDatum + <*> genHashableScriptData + <*> genExecutionUnits + +genPlutusScript :: Gen (PlutusScriptOrReferenceInput era lang) +genPlutusScript = PReferenceScript <$> genTxIn + +genMaybeDatum :: Gen (PlutusScriptDatum lang purpose) +genMaybeDatum = return NoScriptDatum -- TODO: Write proper generator + +genScriptWitnessedTxIn :: Gen (TxIn, AnyWitness era) +genScriptWitnessedTxIn = do + (,) <$> genTxIn <*> genAnyWitness + +genScriptWitnessedTxMintValue :: Gen (TxMintValue era) +genScriptWitnessedTxMintValue = return $ TxMintValue mempty + +genScriptWitnessedTxCertificates :: Gen (TxCertificates era) +genScriptWitnessedTxCertificates = return $ TxCertificates OMap.empty + +genScriptWitnessedTxWithdrawals :: Gen (TxWithdrawals era) +genScriptWitnessedTxWithdrawals = return $ TxWithdrawals mempty + +genScriptWitnesssedTxVotingProcedures :: Gen (TxVotingProcedures era) +genScriptWitnesssedTxVotingProcedures = return $ TxVotingProcedures (L.VotingProcedures mempty) mempty + +genScriptWitnessedTxProposals :: Gen (TxProposalProcedures era) +genScriptWitnessedTxProposals = return $ TxProposalProcedures OMap.empty diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 595e831fb0..fff8cc8144 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -157,6 +157,7 @@ import Cardano.Api hiding (txIns) import Cardano.Api qualified as Api import Cardano.Api.Byron qualified as Byron import Cardano.Api.Experimental qualified as Exp +import Cardano.Api.Experimental.AnyScriptWitness import Cardano.Api.Ledger qualified as L import Cardano.Api.Parser.Text qualified as P import Cardano.Api.Tx qualified as A @@ -1572,7 +1573,7 @@ genIndexedPlutusScriptWitness = do Exp.IndexedPlutusScriptWitness <$> genWitnessable <*> genPlutusPurpose index witnessable - <*> genPlutusScriptWitness + <*> fmap (AnyPlutusSpendingScriptWitness . PlutusSpendingScriptWitnessV3) genPlutusScriptWitness genPlutusPurpose :: Word32 diff --git a/cardano-api/src/Cardano/Api/Certificate/Internal.hs b/cardano-api/src/Cardano/Api/Certificate/Internal.hs index 08b18aa96c..115aae481e 100644 --- a/cardano-api/src/Cardano/Api/Certificate/Internal.hs +++ b/cardano-api/src/Cardano/Api/Certificate/Internal.hs @@ -10,7 +10,6 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -- | Certificates embedded in transactions module Cardano.Api.Certificate.Internal @@ -105,7 +104,6 @@ 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) @@ -145,27 +143,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 ShelleyRelatedCertificate{} ConwayCertificate{} = Nothing - testEquality ConwayCertificate{} ShelleyRelatedCertificate{} = 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 TestEquality Certificate where +-- testEquality (ShelleyRelatedCertificate _ c) (ShelleyRelatedCertificate _ c') = +-- shelleyCertTypeEquality c c' +-- testEquality (ConwayCertificate _ c) (ConwayCertificate _ c') = +-- conwayCertTypeEquality c c' +-- testEquality ShelleyRelatedCertificate{} ConwayCertificate{} = Nothing +-- testEquality ConwayCertificate{} ShelleyRelatedCertificate{} = 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 diff --git a/cardano-api/src/Cardano/Api/Compatible/Tx.hs b/cardano-api/src/Cardano/Api/Compatible/Tx.hs index cd6e894652..5e1dfae9d8 100644 --- a/cardano-api/src/Cardano/Api/Compatible/Tx.hs +++ b/cardano-api/src/Cardano/Api/Compatible/Tx.hs @@ -17,6 +17,7 @@ where import Cardano.Api.Address (StakeCredential) import Cardano.Api.Era +import Cardano.Api.Experimental.Tx qualified as Exp import Cardano.Api.Experimental.Tx.Internal.Certificate qualified as Exp import Cardano.Api.Plutus.Internal.Script import Cardano.Api.ProtocolParameters @@ -51,7 +52,7 @@ data AnyProtocolUpdate era where data AnyVote era where VotingProcedures :: ConwayEraOnwards era - -> TxVotingProcedures BuildTx era + -> Exp.TxVotingProcedures (ShelleyLedgerEra era) -> AnyVote era NoVotes :: AnyVote era @@ -108,8 +109,8 @@ createCompatibleTx sbe ins outs txFee' anyProtocolUpdate anyVote txCertificates' updateVotingProcedures = case anyVote of NoVotes -> id - VotingProcedures conwayOnwards procedures -> - overwriteVotingProcedures conwayOnwards (convVotingProcedures procedures) + VotingProcedures conwayOnwards (Exp.TxVotingProcedures procedures _) -> + overwriteVotingProcedures conwayOnwards procedures apiScriptWitnesses = [ (ix, AnyScriptWitness witness) diff --git a/cardano-api/src/Cardano/Api/Experimental.hs b/cardano-api/src/Cardano/Api/Experimental.hs index ecc4e5996b..3c7e96d6e4 100644 --- a/cardano-api/src/Cardano/Api/Experimental.hs +++ b/cardano-api/src/Cardano/Api/Experimental.hs @@ -27,6 +27,8 @@ module Cardano.Api.Experimental -- ** Transaction fee related , estimateBalancedTxBody + , evaluateTransactionFee + , collectTxBodyScriptWitnesses -- ** Era-related , BabbageEra @@ -50,6 +52,8 @@ module Cardano.Api.Experimental -- ** Simple script related , SimpleScript (..) , SimpleScriptOrReferenceInput (..) + , deserialiseSimpleScript + , hashSimpleScript -- ** Plutus related , PlutusScriptInEra (..) @@ -100,6 +104,5 @@ import Cardano.Api.Experimental.Plutus.Internal.ScriptWitness import Cardano.Api.Experimental.Plutus.Internal.Shim.LegacyScripts import Cardano.Api.Experimental.Simple.Script import Cardano.Api.Experimental.Tx -import Cardano.Api.Experimental.Tx.Internal.Compatible import Cardano.Api.Experimental.Tx.Internal.Fee import Cardano.Api.Tx.Internal.Fee (evaluateTransactionExecutionUnitsShelley) diff --git a/cardano-api/src/Cardano/Api/Experimental/AnyScriptWitness.hs b/cardano-api/src/Cardano/Api/Experimental/AnyScriptWitness.hs new file mode 100644 index 0000000000..1dea940bad --- /dev/null +++ b/cardano-api/src/Cardano/Api/Experimental/AnyScriptWitness.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} + +module Cardano.Api.Experimental.AnyScriptWitness + ( AnyScriptWitness (..) + , AnyPlutusScriptWitness (..) + , PlutusSpendingScriptWitness (..) + , createPlutusSpendingScriptWitness + , getAnyPlutusScriptData + , getAnyPlutusScriptWitnessExecutionUnits + , getAnyPlutusScriptWitnessRedeemer + , getAnyPlutusWitnessPlutusScript + , getAnyPlutusScriptWitnessLanguage + , langTypeEquality + , updatePlutusScriptWitnessExecutionUnits + ) +where + +import Cardano.Api.Experimental.Plutus.Internal.ScriptWitness +import Cardano.Api.Experimental.Simple.Script +import Cardano.Api.Ledger.Internal.Reexport qualified as L +import Cardano.Api.Plutus.Internal.Script (ExecutionUnits) + +import Cardano.Ledger.Plutus.Language qualified as L + +import Data.Type.Equality +import Data.Typeable + +data PlutusSpendingScriptWitness era + = PlutusSpendingScriptWitnessV1 (PlutusScriptWitness L.PlutusV1 SpendingScript era) + | PlutusSpendingScriptWitnessV2 (PlutusScriptWitness L.PlutusV2 SpendingScript era) + | PlutusSpendingScriptWitnessV3 (PlutusScriptWitness L.PlutusV3 SpendingScript era) + | PlutusSpendingScriptWitnessV4 (PlutusScriptWitness L.PlutusV4 SpendingScript era) + deriving (Show, Eq) + +createPlutusSpendingScriptWitness + :: L.SLanguage lang + -> PlutusScriptWitness lang SpendingScript era + -> PlutusSpendingScriptWitness era +createPlutusSpendingScriptWitness L.SPlutusV1 witness = PlutusSpendingScriptWitnessV1 witness +createPlutusSpendingScriptWitness L.SPlutusV2 witness = PlutusSpendingScriptWitnessV2 witness +createPlutusSpendingScriptWitness L.SPlutusV3 witness = PlutusSpendingScriptWitnessV3 witness +createPlutusSpendingScriptWitness L.SPlutusV4 witness = PlutusSpendingScriptWitnessV4 witness + +data AnyPlutusScriptWitness lang purpose era where + AnyPlutusSpendingScriptWitness + :: PlutusSpendingScriptWitness era -> AnyPlutusScriptWitness lang SpendingScript era + AnyPlutusMintingScriptWitness + :: Typeable lang + => PlutusScriptWitness lang MintingScript era -> AnyPlutusScriptWitness lang MintingScript era + AnyPlutusWithdrawingScriptWitness + :: Typeable lang + => PlutusScriptWitness lang WithdrawingScript era -> AnyPlutusScriptWitness lang WithdrawingScript era + AnyPlutusCertifyingScriptWitness + :: Typeable lang + => PlutusScriptWitness lang CertifyingScript era -> AnyPlutusScriptWitness lang CertifyingScript era + AnyPlutusProposingScriptWitness + :: Typeable lang + => PlutusScriptWitness lang ProposingScript era -> AnyPlutusScriptWitness lang ProposingScript era + AnyPlutusVotingScriptWitness + :: Typeable lang + => PlutusScriptWitness lang VotingScript era -> AnyPlutusScriptWitness lang VotingScript era + +deriving instance Show (AnyPlutusScriptWitness lang purpose era) + +deriving instance Eq (AnyPlutusScriptWitness lang purpose era) + +getAnyPlutusScriptWitnessExecutionUnits + :: AnyPlutusScriptWitness lang purpose era -> ExecutionUnits +getAnyPlutusScriptWitnessExecutionUnits (AnyPlutusSpendingScriptWitness s) = + case s of + PlutusSpendingScriptWitnessV1 (PlutusScriptWitness _ _ _ _ eu) -> eu + PlutusSpendingScriptWitnessV2 (PlutusScriptWitness _ _ _ _ eu) -> eu + PlutusSpendingScriptWitnessV3 (PlutusScriptWitness _ _ _ _ eu) -> eu + PlutusSpendingScriptWitnessV4 (PlutusScriptWitness _ _ _ _ eu) -> eu +getAnyPlutusScriptWitnessExecutionUnits (AnyPlutusMintingScriptWitness (PlutusScriptWitness _ _ _ _ eu)) = eu +getAnyPlutusScriptWitnessExecutionUnits (AnyPlutusWithdrawingScriptWitness (PlutusScriptWitness _ _ _ _ eu)) = eu +getAnyPlutusScriptWitnessExecutionUnits (AnyPlutusCertifyingScriptWitness (PlutusScriptWitness _ _ _ _ eu)) = eu +getAnyPlutusScriptWitnessExecutionUnits (AnyPlutusProposingScriptWitness (PlutusScriptWitness _ _ _ _ eu)) = eu +getAnyPlutusScriptWitnessExecutionUnits (AnyPlutusVotingScriptWitness (PlutusScriptWitness _ _ _ _ eu)) = eu + +getAnyPlutusScriptWitnessRedeemer + :: AnyPlutusScriptWitness lang purpose era + -> ScriptRedeemer +getAnyPlutusScriptWitnessRedeemer (AnyPlutusSpendingScriptWitness s) = + case s of + PlutusSpendingScriptWitnessV1 (PlutusScriptWitness _ _ _ redeemer _) -> redeemer + PlutusSpendingScriptWitnessV2 (PlutusScriptWitness _ _ _ redeemer _) -> redeemer + PlutusSpendingScriptWitnessV3 (PlutusScriptWitness _ _ _ redeemer _) -> redeemer + PlutusSpendingScriptWitnessV4 (PlutusScriptWitness _ _ _ redeemer _) -> redeemer +getAnyPlutusScriptWitnessRedeemer (AnyPlutusMintingScriptWitness (PlutusScriptWitness _ _ _ redeemer _)) = redeemer +getAnyPlutusScriptWitnessRedeemer (AnyPlutusWithdrawingScriptWitness (PlutusScriptWitness _ _ _ redeemer _)) = redeemer +getAnyPlutusScriptWitnessRedeemer (AnyPlutusCertifyingScriptWitness (PlutusScriptWitness _ _ _ redeemer _)) = redeemer +getAnyPlutusScriptWitnessRedeemer (AnyPlutusProposingScriptWitness (PlutusScriptWitness _ _ _ redeemer _)) = redeemer +getAnyPlutusScriptWitnessRedeemer (AnyPlutusVotingScriptWitness (PlutusScriptWitness _ _ _ redeemer _)) = redeemer + +updatePlutusScriptWitnessExecutionUnits + :: ExecutionUnits -> AnyPlutusScriptWitness lang purpose era -> AnyPlutusScriptWitness lang purpose era +updatePlutusScriptWitnessExecutionUnits eu (AnyPlutusSpendingScriptWitness s) = + case s of + PlutusSpendingScriptWitnessV1 (PlutusScriptWitness lang script dat redeemer _) -> + AnyPlutusSpendingScriptWitness + (PlutusSpendingScriptWitnessV1 (PlutusScriptWitness lang script dat redeemer eu)) + PlutusSpendingScriptWitnessV2 (PlutusScriptWitness lang script dat redeemer _) -> + AnyPlutusSpendingScriptWitness + (PlutusSpendingScriptWitnessV2 (PlutusScriptWitness lang script dat redeemer eu)) + PlutusSpendingScriptWitnessV3 (PlutusScriptWitness lang script dat redeemer _) -> + AnyPlutusSpendingScriptWitness + (PlutusSpendingScriptWitnessV3 (PlutusScriptWitness lang script dat redeemer eu)) + PlutusSpendingScriptWitnessV4 (PlutusScriptWitness lang script dat redeemer _) -> + AnyPlutusSpendingScriptWitness + (PlutusSpendingScriptWitnessV4 (PlutusScriptWitness lang script dat redeemer eu)) +updatePlutusScriptWitnessExecutionUnits eu (AnyPlutusMintingScriptWitness (PlutusScriptWitness lang script dat redeemer _)) = + AnyPlutusMintingScriptWitness (PlutusScriptWitness lang script dat redeemer eu) +updatePlutusScriptWitnessExecutionUnits eu (AnyPlutusWithdrawingScriptWitness (PlutusScriptWitness lang script dat redeemer _)) = + AnyPlutusWithdrawingScriptWitness (PlutusScriptWitness lang script dat redeemer eu) +updatePlutusScriptWitnessExecutionUnits eu (AnyPlutusCertifyingScriptWitness (PlutusScriptWitness lang script dat redeemer _)) = + AnyPlutusCertifyingScriptWitness (PlutusScriptWitness lang script dat redeemer eu) +updatePlutusScriptWitnessExecutionUnits eu (AnyPlutusProposingScriptWitness (PlutusScriptWitness lang script dat redeemer _)) = + AnyPlutusProposingScriptWitness (PlutusScriptWitness lang script dat redeemer eu) +updatePlutusScriptWitnessExecutionUnits eu (AnyPlutusVotingScriptWitness (PlutusScriptWitness lang script dat redeemer _)) = + AnyPlutusVotingScriptWitness (PlutusScriptWitness lang script dat redeemer eu) + +getAnyPlutusScriptWitnessLanguage + :: AnyPlutusScriptWitness lang purpose era -> L.Language +getAnyPlutusScriptWitnessLanguage (AnyPlutusSpendingScriptWitness s) = + case s of + PlutusSpendingScriptWitnessV1 s' -> getPlutusScriptWitnessLanguage s' + PlutusSpendingScriptWitnessV2 s' -> getPlutusScriptWitnessLanguage s' + PlutusSpendingScriptWitnessV3 s' -> getPlutusScriptWitnessLanguage s' + PlutusSpendingScriptWitnessV4 s' -> getPlutusScriptWitnessLanguage s' +getAnyPlutusScriptWitnessLanguage (AnyPlutusMintingScriptWitness s) = getPlutusScriptWitnessLanguage s +getAnyPlutusScriptWitnessLanguage (AnyPlutusWithdrawingScriptWitness s) = getPlutusScriptWitnessLanguage s +getAnyPlutusScriptWitnessLanguage (AnyPlutusCertifyingScriptWitness s) = getPlutusScriptWitnessLanguage s +getAnyPlutusScriptWitnessLanguage (AnyPlutusProposingScriptWitness s) = getPlutusScriptWitnessLanguage s +getAnyPlutusScriptWitnessLanguage (AnyPlutusVotingScriptWitness s) = getPlutusScriptWitnessLanguage s + +getAnyPlutusScriptData + :: L.Era era + => AnyPlutusScriptWitness lang purpose era + -> L.TxDats era +getAnyPlutusScriptData (AnyPlutusSpendingScriptWitness s) = + case s of + PlutusSpendingScriptWitnessV1 sw -> getSpendingPlutusWitnessData sw + PlutusSpendingScriptWitnessV2 sw -> getSpendingPlutusWitnessData sw + PlutusSpendingScriptWitnessV3 sw -> getSpendingPlutusWitnessData sw + PlutusSpendingScriptWitnessV4 sw -> getSpendingPlutusWitnessData sw +getAnyPlutusScriptData AnyPlutusMintingScriptWitness{} = mempty +getAnyPlutusScriptData AnyPlutusWithdrawingScriptWitness{} = mempty +getAnyPlutusScriptData AnyPlutusCertifyingScriptWitness{} = mempty +getAnyPlutusScriptData AnyPlutusProposingScriptWitness{} = mempty +getAnyPlutusScriptData AnyPlutusVotingScriptWitness{} = mempty + +getAnyPlutusWitnessPlutusScript + :: L.AlonzoEraScript era + => AnyPlutusScriptWitness lang purpose era + -> Maybe (L.Script era) +getAnyPlutusWitnessPlutusScript (AnyPlutusSpendingScriptWitness (PlutusSpendingScriptWitnessV1 s)) = + let plutusScriptRunnable = getPlutusScriptRunnable s + in L.fromPlutusScript <$> (fromPlutusRunnable L.SPlutusV1 =<< plutusScriptRunnable) +getAnyPlutusWitnessPlutusScript (AnyPlutusSpendingScriptWitness (PlutusSpendingScriptWitnessV2 s)) = + let plutusScriptRunnable = getPlutusScriptRunnable s + in L.fromPlutusScript <$> (fromPlutusRunnable L.SPlutusV2 =<< plutusScriptRunnable) +getAnyPlutusWitnessPlutusScript (AnyPlutusSpendingScriptWitness (PlutusSpendingScriptWitnessV3 s)) = + let plutusScriptRunnable = getPlutusScriptRunnable s + in L.fromPlutusScript <$> (fromPlutusRunnable L.SPlutusV3 =<< plutusScriptRunnable) +getAnyPlutusWitnessPlutusScript (AnyPlutusSpendingScriptWitness (PlutusSpendingScriptWitnessV4 s)) = + let plutusScriptRunnable = getPlutusScriptRunnable s + in L.fromPlutusScript <$> (fromPlutusRunnable L.SPlutusV4 =<< plutusScriptRunnable) +getAnyPlutusWitnessPlutusScript (AnyPlutusMintingScriptWitness s@(PlutusScriptWitness l _ _ _ _)) = + let plutusScriptRunnable = getPlutusScriptRunnable s + in L.fromPlutusScript <$> (fromPlutusRunnable l =<< plutusScriptRunnable) +getAnyPlutusWitnessPlutusScript (AnyPlutusWithdrawingScriptWitness s@(PlutusScriptWitness l _ _ _ _)) = + let plutusScriptRunnable = getPlutusScriptRunnable s + in L.fromPlutusScript <$> (fromPlutusRunnable l =<< plutusScriptRunnable) +getAnyPlutusWitnessPlutusScript (AnyPlutusCertifyingScriptWitness s@(PlutusScriptWitness l _ _ _ _)) = + let plutusScriptRunnable = getPlutusScriptRunnable s + in L.fromPlutusScript <$> (fromPlutusRunnable l =<< plutusScriptRunnable) +getAnyPlutusWitnessPlutusScript (AnyPlutusProposingScriptWitness s@(PlutusScriptWitness l _ _ _ _)) = + let plutusScriptRunnable = getPlutusScriptRunnable s + in L.fromPlutusScript <$> (fromPlutusRunnable l =<< plutusScriptRunnable) +getAnyPlutusWitnessPlutusScript (AnyPlutusVotingScriptWitness s@(PlutusScriptWitness l _ _ _ _)) = + let plutusScriptRunnable = getPlutusScriptRunnable s + in L.fromPlutusScript <$> (fromPlutusRunnable l =<< plutusScriptRunnable) + +-- 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.AlonzoEraScript era + => L.SLanguage lang + -> L.PlutusRunnable lang + -> Maybe (L.PlutusScript era) +fromPlutusRunnable L.SPlutusV1 runnable = + L.mkPlutusScript $ L.plutusFromRunnable runnable +fromPlutusRunnable L.SPlutusV2 runnable = + L.mkPlutusScript $ L.plutusFromRunnable runnable +fromPlutusRunnable L.SPlutusV3 runnable = + L.mkPlutusScript $ L.plutusFromRunnable runnable +fromPlutusRunnable L.SPlutusV4 runnable = + L.mkPlutusScript $ L.plutusFromRunnable runnable + +data AnyScriptWitness era where + AnyScriptWitnessSimple :: SimpleScriptOrReferenceInput era -> AnyScriptWitness era + AnyScriptWitnessPlutus :: AnyPlutusScriptWitness lang purpose era -> AnyScriptWitness era + +deriving instance Show (AnyScriptWitness era) + +instance Eq (AnyScriptWitness era) where + (AnyScriptWitnessSimple s1) == (AnyScriptWitnessSimple s2) = s1 == s2 + (AnyScriptWitnessPlutus (AnyPlutusSpendingScriptWitness s1)) == (AnyScriptWitnessPlutus (AnyPlutusSpendingScriptWitness s2)) = s1 == s2 + (AnyScriptWitnessPlutus (AnyPlutusMintingScriptWitness s1)) == (AnyScriptWitnessPlutus (AnyPlutusMintingScriptWitness s2)) = + case langTypeEquality s1 s2 of + Just Refl -> s1 == s2 + Nothing -> False + (AnyScriptWitnessPlutus (AnyPlutusWithdrawingScriptWitness s1)) == (AnyScriptWitnessPlutus (AnyPlutusWithdrawingScriptWitness s2)) = + case langTypeEquality s1 s2 of + Just Refl -> s1 == s2 + Nothing -> False + (AnyScriptWitnessPlutus (AnyPlutusCertifyingScriptWitness s1)) == (AnyScriptWitnessPlutus (AnyPlutusCertifyingScriptWitness s2)) = + case langTypeEquality s1 s2 of + Just Refl -> s1 == s2 + Nothing -> False + (AnyScriptWitnessPlutus (AnyPlutusProposingScriptWitness s1)) == (AnyScriptWitnessPlutus (AnyPlutusProposingScriptWitness s2)) = + case langTypeEquality s1 s2 of + Just Refl -> s1 == s2 + Nothing -> False + (AnyScriptWitnessPlutus (AnyPlutusVotingScriptWitness s1)) == (AnyScriptWitnessPlutus (AnyPlutusVotingScriptWitness s2)) = + case langTypeEquality s1 s2 of + Just Refl -> s1 == s2 + Nothing -> False + _ == _ = False + +langTypeEquality + :: (Typeable langA, Typeable langB) + => PlutusScriptWitness langA purpose era + -> PlutusScriptWitness langB purpose era + -> Maybe (langA :~: langB) +langTypeEquality _ _ = eqT diff --git a/cardano-api/src/Cardano/Api/Experimental/Era.hs b/cardano-api/src/Cardano/Api/Experimental/Era.hs index 8e7453e9f3..a97122dcf6 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Era.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Era.hs @@ -55,6 +55,7 @@ import Cardano.Ledger.Conway qualified as Ledger import Cardano.Ledger.Core qualified as Ledger import Cardano.Ledger.Hashes qualified as L import Cardano.Ledger.State qualified as L +import Cardano.Ledger.Val qualified as L import Control.Monad.Error.Class import Data.Aeson (FromJSON (..), ToJSON, withText) @@ -298,6 +299,7 @@ obtainConwayConstraints ConwayEra a = a type EraCommonConstraints era = ( L.AllegraEraScript (LedgerEra era) + , L.AlonzoEraScript (LedgerEra era) , L.AlonzoEraTx (LedgerEra era) , L.BabbageEraPParams (LedgerEra era) , L.BabbageEraTxBody (LedgerEra era) @@ -309,11 +311,13 @@ type EraCommonConstraints era = , L.EraTxCert (LedgerEra era) , L.EraTxOut (LedgerEra era) , L.EraUTxO (LedgerEra era) + , L.Val (L.Value (LedgerEra era)) , L.Value (LedgerEra era) ~ L.MaryValue , FromCBOR (ChainDepState (ConsensusProtocol era)) , L.NativeScript (LedgerEra era) ~ L.Timelock (LedgerEra era) , PraosProtocolSupportsNode (ConsensusProtocol era) , ShelleyLedgerEra era ~ LedgerEra era + , LedgerEra era ~ ShelleyLedgerEra era , ToJSON (ChainDepState (ConsensusProtocol era)) , L.HashAnnotated (Ledger.TxBody (LedgerEra era)) L.EraIndependentTxBody , Api.IsCardanoEra era diff --git a/cardano-api/src/Cardano/Api/Experimental/Plutus.hs b/cardano-api/src/Cardano/Api/Experimental/Plutus.hs index b4d21e8768..e3924fdbc6 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Plutus.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Plutus.hs @@ -1,11 +1,19 @@ module Cardano.Api.Experimental.Plutus ( -- * Plutus Script PlutusScriptInEra (..) + , deserialisePlutusScriptInEra + , hashPlutusScriptInEra + , plutusScriptInEraLanguage + , plutusScriptInEraSLanguage + , plutusScriptInEraToScript -- * Legacy Scripts + , convertToNewScriptWitness , legacyWitnessToScriptRequirements , legacyWitnessConversion , toPlutusSLanguage + , fromPlutusSLanguage + , mkLegacyPolicyId -- * Plutus Script Witness , PlutusScriptWitness (..) @@ -16,7 +24,7 @@ module Cardano.Api.Experimental.Plutus , PlutusScriptPurpose (..) , PlutusScriptDatum (..) , NoScriptDatum (..) - , mkPlutusScriptWitness + -- , mkPlutusScriptWitness , getPlutusScriptWitnessLanguage -- ** Constuct an indexed plutus script witness. diff --git a/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/IndexedPlutusScriptWitness.hs b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/IndexedPlutusScriptWitness.hs index 1f23cee0fd..e7f85877a5 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/IndexedPlutusScriptWitness.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/IndexedPlutusScriptWitness.hs @@ -29,6 +29,7 @@ where import Cardano.Api.Address import Cardano.Api.Era.Internal.Eon.AlonzoEraOnwards import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra +import Cardano.Api.Experimental.AnyScriptWitness import Cardano.Api.Experimental.Plutus.Internal.ScriptWitness import Cardano.Api.Experimental.Tx.Internal.AnyWitness import Cardano.Api.Ledger qualified as L @@ -54,7 +55,7 @@ data IndexedPlutusScriptWitness witnessable (lang :: L.Language) (purpose :: Plu :: L.AlonzoEraScript era => Witnessable witnessable era -> (L.PlutusPurpose L.AsIx era) - -> (PlutusScriptWitness lang purpose era) + -> AnyPlutusScriptWitness lang purpose era -> IndexedPlutusScriptWitness witnessable lang purpose era deriving instance Show (IndexedPlutusScriptWitness witnessable lang purpose era) @@ -147,7 +148,7 @@ createIndexedPlutusScriptWitness :: L.AlonzoEraScript era => Word32 -> Witnessable witnessable era - -> PlutusScriptWitness lang purpose era + -> AnyPlutusScriptWitness lang purpose era -> IndexedPlutusScriptWitness witnessable lang purpose era createIndexedPlutusScriptWitness index witnessable = IndexedPlutusScriptWitness witnessable (toPlutusScriptPurpose index witnessable) @@ -169,33 +170,32 @@ createIndexedPlutusScriptWitnesses witnessableThings = -- script. The ledger basically reconstructs the indicies (redeemer pointers) of this map can then look up the relevant -- execution units/redeemer pairing. NB: the redeemer pointer has been renamed to 'PlutusPurpose AsIndex' in the ledger. getAnyWitnessRedeemerPointerMap - :: AlonzoEraOnwards era - -> [(Witnessable witnessable (ShelleyLedgerEra era), AnyWitness (ShelleyLedgerEra era))] - -> L.Redeemers (ShelleyLedgerEra era) -getAnyWitnessRedeemerPointerMap eon anyWit = - constructRedeeemerPointerMap eon $ - alonzoEraOnwardsConstraints eon $ - createIndexedPlutusScriptWitnesses anyWit + :: L.AlonzoEraScript era + => [(Witnessable witnessable era, AnyWitness era)] + -> L.Redeemers era +getAnyWitnessRedeemerPointerMap anyWit = + constructRedeeemerPointerMap $ + createIndexedPlutusScriptWitnesses anyWit -- | An 'IndexedPlutusScriptWitness' contains everything we need to construct a single -- entry in the redeemer pointer map. constructRedeemerPointer - :: AlonzoEraOnwards era - -> AnyIndexedPlutusScriptWitness (ShelleyLedgerEra 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))] + :: L.Era era + => AnyIndexedPlutusScriptWitness era + -> L.Redeemers era +constructRedeemerPointer (AnyIndexedPlutusScriptWitness (IndexedPlutusScriptWitness _ purpose scriptWit)) = + let redeemer = getAnyPlutusScriptWitnessRedeemer scriptWit + execUnits = getAnyPlutusScriptWitnessExecutionUnits scriptWit + in L.Redeemers $ + fromList [(purpose, (toAlonzoData redeemer, toAlonzoExUnits execUnits))] constructRedeeemerPointerMap - :: AlonzoEraOnwards era - -> [AnyIndexedPlutusScriptWitness (ShelleyLedgerEra era)] - -> L.Redeemers (ShelleyLedgerEra era) -constructRedeeemerPointerMap eon scriptWits = - let redeemerPointers = map (constructRedeemerPointer eon) scriptWits - in alonzoEraOnwardsConstraints eon $ mconcat redeemerPointers + :: L.AlonzoEraScript era + => [AnyIndexedPlutusScriptWitness era] + -> L.Redeemers era +constructRedeeemerPointerMap scriptWits = + let redeemerPointers = map constructRedeemerPointer scriptWits + in mconcat redeemerPointers obtainAlonzoScriptPurposeConstraints :: AlonzoEraOnwards era diff --git a/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Script.hs b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Script.hs index bb1a12e4de..06b43898f7 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Script.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Script.hs @@ -1,19 +1,45 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} module Cardano.Api.Experimental.Plutus.Internal.Script ( PlutusScriptInEra (..) , PlutusScriptOrReferenceInput (..) + , AsType (..) + , deserialisePlutusScriptInEra + , hashPlutusScriptInEra + , plutusScriptInEraLanguage + , plutusScriptInEraSLanguage + , plutusScriptInEraToScript ) where +import Cardano.Api.Experimental.Era +import Cardano.Api.HasTypeProxy +import Cardano.Api.Ledger.Internal.Reexport qualified as L +import Cardano.Api.Plutus.Internal.Script (removePlutusScriptDoubleEncoding) +import Cardano.Api.Serialise.Cbor +import Cardano.Api.Serialise.TextEnvelope.Internal import Cardano.Api.Tx.Internal.TxIn (TxIn) +import Cardano.Binary qualified as CBOR +import Cardano.Ledger.Core qualified as L import Cardano.Ledger.Plutus.Language (PlutusRunnable) import Cardano.Ledger.Plutus.Language qualified as L +import Cardano.Ledger.Plutus.Language qualified as Plutus + +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as LBS +import Data.ByteString.Short qualified as SBS +import Data.Text qualified as Text +import Data.Typeable +import Prettyprinter -- | A Plutus script in a particular era. -- Why PlutusRunnable? Mainly for deserialization benefits. @@ -32,12 +58,91 @@ import Cardano.Ledger.Plutus.Language qualified as L -- 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 + PlutusScriptInEra :: L.PlutusLanguage lang => PlutusRunnable lang -> PlutusScriptInEra lang era deriving instance Show (PlutusScriptInEra lang era) deriving instance Eq (PlutusScriptInEra lang era) +instance + (Typeable era, Typeable lang, HasTypeProxy (Plutus.SLanguage lang)) + => HasTypeProxy (PlutusScriptInEra lang era) + where + data AsType (PlutusScriptInEra lang era) = AsPlutusScriptInEra (AsType (L.SLanguage lang)) + proxyToAsType _ = AsPlutusScriptInEra (proxyToAsType (Proxy @(L.SLanguage lang))) + +instance + (Plutus.PlutusLanguage lang, L.Era era, HasTypeProxy (Plutus.SLanguage lang)) + => HasTextEnvelope (PlutusScriptInEra lang era) + where + textEnvelopeType _ = + case L.plutusLanguage (Proxy @lang) of + L.PlutusV1 -> "PlutusScriptV1" + L.PlutusV2 -> "PlutusScriptV2" + L.PlutusV3 -> "PlutusScriptV3" + L.PlutusV4 -> "PlutusScriptV4" + +instance + ( L.Era era + , Typeable era + , Typeable lang + , Plutus.PlutusLanguage lang + , HasTypeProxy (Plutus.SLanguage lang) + ) + => SerialiseAsCBOR (PlutusScriptInEra (lang :: L.Language) era) + where + serialiseToCBOR (PlutusScriptInEra s) = + L.serialize' (L.eraProtVerHigh @era) s + + deserialiseFromCBOR _ bs = do + let v = L.eraProtVerLow @era + scriptShortBs = SBS.toShort $ removePlutusScriptDoubleEncoding $ LBS.fromStrict bs + let plutusScript :: Plutus.Plutus lang + plutusScript = L.Plutus $ L.PlutusBinary scriptShortBs + + case Plutus.decodePlutusRunnable v plutusScript of + Left e -> + Left $ + CBOR.DecoderErrorCustom "PlutusLedgerApi.Common.ScriptDecodeError" (Text.pack . show $ pretty e) + Right s -> Right $ PlutusScriptInEra s + +deserialisePlutusScriptInEra + :: forall era lang + . (Plutus.PlutusLanguage lang, HasTypeProxy (Plutus.SLanguage lang)) + => IsEra era + => L.SLanguage lang + -> BS.ByteString + -> Either CBOR.DecoderError (PlutusScriptInEra lang (LedgerEra era)) +deserialisePlutusScriptInEra _ bs = + obtainCommonConstraints (useEra @era) $ + deserialiseFromCBOR (AsPlutusScriptInEra (proxyToAsType (Proxy @(L.SLanguage lang)))) bs + +hashPlutusScriptInEra + :: forall era lang. IsEra era => PlutusScriptInEra lang (LedgerEra era) -> L.ScriptHash +hashPlutusScriptInEra (PlutusScriptInEra pr) = + case useEra @era of + ConwayEra -> L.hashPlutusScript $ L.plutusFromRunnable pr + DijkstraEra -> L.hashPlutusScript $ L.plutusFromRunnable pr + +plutusScriptInEraSLanguage + :: forall lang era. L.PlutusLanguage lang => PlutusScriptInEra lang era -> L.SLanguage lang +plutusScriptInEraSLanguage (PlutusScriptInEra _) = + L.plutusSLanguage (Proxy @lang) + +plutusScriptInEraLanguage + :: forall lang era. L.PlutusLanguage lang => PlutusScriptInEra lang era -> L.Language +plutusScriptInEraLanguage (PlutusScriptInEra _) = + L.plutusLanguage (Proxy @lang) + +plutusScriptInEraToScript + :: forall lang era. L.AlonzoEraScript era => PlutusScriptInEra lang era -> L.Script era +plutusScriptInEraToScript (PlutusScriptInEra pr) = + case L.fromPlutusScript <$> L.mkPlutusScript (L.plutusFromRunnable pr) of + Nothing -> + error + "plutusScriptInEraToScript: Impossible as the failure would have occurred at the point of deserialising the PlutusRunnable value." + Just script -> script + -- | 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. diff --git a/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/ScriptWitness.hs b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/ScriptWitness.hs index 085c292a7c..0a514420bf 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/ScriptWitness.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/ScriptWitness.hs @@ -20,22 +20,24 @@ module Cardano.Api.Experimental.Plutus.Internal.ScriptWitness , PlutusScriptPurpose (..) , PlutusScriptDatum (..) , NoScriptDatum (..) - , mkPlutusScriptWitness -- * Helpers + , getSpendingPlutusWitnessData + , getPlutusScriptRunnable , getPlutusScriptWitnessLanguage ) where -import Cardano.Api.Era.Internal.Eon.AlonzoEraOnwards -import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra import Cardano.Api.Experimental.Plutus.Internal.Script import Cardano.Api.Ledger qualified as L import Cardano.Api.Plutus.Internal.Script (ExecutionUnits) import Cardano.Api.Plutus.Internal.ScriptData +import Cardano.Ledger.Plutus.Data qualified as Plutus import Cardano.Ledger.Plutus.Language qualified as L +import GHC.IsList + {- To construct a plutus script witness you need: 1. The plutus script or reference input @@ -68,6 +70,42 @@ data PlutusScriptWitness (lang :: L.Language) (purpose :: PlutusScriptPurpose) e deriving instance Show (PlutusScriptWitness lang purpose era) +instance Eq (PlutusScriptWitness L.PlutusV1 SpendingScript era) where + (==) (PlutusScriptWitness s1 l1 d1 r1 eu1) (PlutusScriptWitness s2 l2 d2 r2 eu2) = + l1 == l2 && d1 == d2 && r1 == r2 && eu1 == eu2 && s1 == s2 + +instance Eq (PlutusScriptWitness L.PlutusV2 SpendingScript era) where + (==) (PlutusScriptWitness s1 l1 d1 r1 eu1) (PlutusScriptWitness s2 l2 d2 r2 eu2) = + l1 == l2 && d1 == d2 && r1 == r2 && eu1 == eu2 && s1 == s2 + +instance Eq (PlutusScriptWitness L.PlutusV3 SpendingScript era) where + (==) (PlutusScriptWitness s1 l1 d1 r1 eu1) (PlutusScriptWitness s2 l2 d2 r2 eu2) = + l1 == l2 && d1 == d2 && r1 == r2 && eu1 == eu2 && s1 == s2 + +instance Eq (PlutusScriptWitness L.PlutusV4 SpendingScript era) where + (==) (PlutusScriptWitness s1 l1 d1 r1 eu1) (PlutusScriptWitness s2 l2 d2 r2 eu2) = + l1 == l2 && d1 == d2 && r1 == r2 && eu1 == eu2 && s1 == s2 + +instance Eq (PlutusScriptWitness lang MintingScript era) where + (==) (PlutusScriptWitness s1 l1 d1 r1 eu1) (PlutusScriptWitness s2 l2 d2 r2 eu2) = + l1 == l2 && d1 == d2 && r1 == r2 && eu1 == eu2 && s1 == s2 + +instance Eq (PlutusScriptWitness lang WithdrawingScript era) where + (==) (PlutusScriptWitness s1 l1 d1 r1 eu1) (PlutusScriptWitness s2 l2 d2 r2 eu2) = + l1 == l2 && d1 == d2 && r1 == r2 && eu1 == eu2 && s1 == s2 + +instance Eq (PlutusScriptWitness lang CertifyingScript era) where + (==) (PlutusScriptWitness s1 l1 d1 r1 eu1) (PlutusScriptWitness s2 l2 d2 r2 eu2) = + l1 == l2 && d1 == d2 && r1 == r2 && eu1 == eu2 && s1 == s2 + +instance Eq (PlutusScriptWitness lang ProposingScript era) where + (==) (PlutusScriptWitness s1 l1 d1 r1 eu1) (PlutusScriptWitness s2 l2 d2 r2 eu2) = + l1 == l2 && d1 == d2 && r1 == r2 && eu1 == eu2 && s1 == s2 + +instance Eq (PlutusScriptWitness lang VotingScript era) where + (==) (PlutusScriptWitness s1 l1 d1 r1 eu1) (PlutusScriptWitness s2 l2 d2 r2 eu2) = + l1 == l2 && d1 == d2 && r1 == r2 && eu1 == eu2 && s1 == s2 + getPlutusScriptWitnessLanguage :: PlutusScriptWitness lang purpose era -> L.Language getPlutusScriptWitnessLanguage (PlutusScriptWitness l _ _ _ _) = case l of @@ -76,6 +114,49 @@ getPlutusScriptWitnessLanguage (PlutusScriptWitness l _ _ _ _) = L.SPlutusV3 -> L.plutusLanguage l L.SPlutusV4 -> L.plutusLanguage l +getSpendingPlutusWitnessData + :: forall era lang + . L.Era era + => PlutusScriptWitness lang SpendingScript era + -> L.TxDats era +getSpendingPlutusWitnessData (PlutusScriptWitness L.SPlutusV1 _ d _ _) = + case d of + SpendingScriptDatum sd -> + let d' :: Plutus.Data era = toAlonzoData sd + in L.TxDats $ fromList [(Plutus.hashData d', d')] + InlineDatum -> mempty + NoScriptDatum -> mempty +getSpendingPlutusWitnessData (PlutusScriptWitness L.SPlutusV2 _ d _ _) = + case d of + SpendingScriptDatum sd -> + let d' :: Plutus.Data era = toAlonzoData sd + in L.TxDats $ fromList [(Plutus.hashData d', d')] + InlineDatum -> mempty + NoScriptDatum -> mempty +getSpendingPlutusWitnessData (PlutusScriptWitness L.SPlutusV3 _ d _ _) = + case d of + SpendingScriptDatum mSd -> case mSd of + Just sd -> + let d' :: Plutus.Data era = toAlonzoData sd + in L.TxDats $ fromList [(Plutus.hashData d', d')] + Nothing -> mempty + InlineDatum -> mempty + NoScriptDatum -> mempty +getSpendingPlutusWitnessData (PlutusScriptWitness L.SPlutusV4 _ d _ _) = + case d of + SpendingScriptDatum mSd -> case mSd of + Just sd -> + let d' :: Plutus.Data era = toAlonzoData sd + in L.TxDats $ fromList [(Plutus.hashData d', d')] + Nothing -> mempty + InlineDatum -> mempty + NoScriptDatum -> mempty + +getPlutusScriptRunnable :: PlutusScriptWitness lang purpose era -> Maybe (L.PlutusRunnable lang) +getPlutusScriptRunnable (PlutusScriptWitness _ (PScript (PlutusScriptInEra plutusScriptRunnable)) _ _ _) = + Just plutusScriptRunnable +getPlutusScriptRunnable (PlutusScriptWitness _ PReferenceScript{} _ _ _) = Nothing + -- | Every Plutus script has a purpose that indicates -- what that script is witnessing. data PlutusScriptPurpose @@ -92,7 +173,7 @@ data PlutusScriptPurpose | -- | Witnesses a vote VotingScript -data NoScriptDatum = NoScriptDatumAllowed deriving Show +data NoScriptDatum = NoScriptDatumAllowed deriving (Eq, 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 @@ -130,21 +211,57 @@ data PlutusScriptDatum (lang :: L.Language) (purpose :: PlutusScriptPurpose) whe NoScriptDatum :: PlutusScriptDatum lang purpose +instance Eq (PlutusScriptDatum L.PlutusV1 SpendingScript) where + (==) (SpendingScriptDatum d1) (SpendingScriptDatum d2) = d1 == d2 + (==) InlineDatum InlineDatum = True + (==) NoScriptDatum NoScriptDatum = True + (==) _ _ = False + +instance Eq (PlutusScriptDatum L.PlutusV2 SpendingScript) where + (==) (SpendingScriptDatum d1) (SpendingScriptDatum d2) = d1 == d2 + (==) InlineDatum InlineDatum = True + (==) NoScriptDatum NoScriptDatum = True + (==) _ _ = False + +instance Eq (PlutusScriptDatum L.PlutusV3 SpendingScript) where + (==) (SpendingScriptDatum d1) (SpendingScriptDatum d2) = d1 == d2 + (==) InlineDatum InlineDatum = True + (==) NoScriptDatum NoScriptDatum = True + (==) _ _ = False + +instance Eq (PlutusScriptDatum L.PlutusV4 SpendingScript) where + (==) (SpendingScriptDatum d1) (SpendingScriptDatum d2) = d1 == d2 + (==) InlineDatum InlineDatum = True + (==) NoScriptDatum NoScriptDatum = True + (==) _ _ = False + +instance Eq (PlutusScriptDatum lang MintingScript) where + (==) InlineDatum InlineDatum = True + (==) NoScriptDatum NoScriptDatum = True + (==) _ _ = False + +instance Eq (PlutusScriptDatum lang WithdrawingScript) where + (==) InlineDatum InlineDatum = True + (==) NoScriptDatum NoScriptDatum = True + (==) _ _ = False + +instance Eq (PlutusScriptDatum lang CertifyingScript) where + (==) InlineDatum InlineDatum = True + (==) NoScriptDatum NoScriptDatum = True + (==) _ _ = False + +instance Eq (PlutusScriptDatum lang ProposingScript) where + (==) InlineDatum InlineDatum = True + (==) NoScriptDatum NoScriptDatum = True + (==) _ _ = False + +instance Eq (PlutusScriptDatum lang VotingScript) where + (==) InlineDatum InlineDatum = True + (==) NoScriptDatum NoScriptDatum = True + (==) _ _ = False + instance Show (PlutusScriptDatum lang purpose) where show = \case SpendingScriptDatum _d -> "Datum" InlineDatum -> "InlineDatum" NoScriptDatum -> "NoScriptDatum" - -mkPlutusScriptWitness - :: AlonzoEraOnwards era - -> L.SLanguage plutuslang - -> L.PlutusRunnable plutuslang - -> PlutusScriptDatum plutuslang purpose - -> ScriptRedeemer - -> ExecutionUnits - -> PlutusScriptWitness plutuslang purpose (ShelleyLedgerEra era) -mkPlutusScriptWitness _ l plutusScriptRunnable = - PlutusScriptWitness - l - (PScript $ PlutusScriptInEra plutusScriptRunnable) diff --git a/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Shim/LegacyScripts.hs b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Shim/LegacyScripts.hs index 009a701f74..4da8b20cc8 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Shim/LegacyScripts.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Shim/LegacyScripts.hs @@ -11,20 +11,29 @@ {-# LANGUAGE TypeFamilyDependencies #-} module Cardano.Api.Experimental.Plutus.Internal.Shim.LegacyScripts - ( legacyWitnessToScriptRequirements + ( convertToNewScriptWitness + , legacyWitnessToScriptRequirements , legacyWitnessConversion + , obtainMonoidConstraint , toPlutusSLanguage + , fromPlutusSLanguage + , mkLegacyPolicyId ) where import Cardano.Api.Era.Internal.Eon.AlonzoEraOnwards import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra +import Cardano.Api.Experimental.AnyScriptWitness +import Cardano.Api.Experimental.Era (obtainCommonConstraints) +import Cardano.Api.Experimental.Era qualified as Exp import Cardano.Api.Experimental.Plutus.Internal.IndexedPlutusScriptWitness import Cardano.Api.Experimental.Plutus.Internal.Script import Cardano.Api.Experimental.Plutus.Internal.ScriptWitness import Cardano.Api.Experimental.Simple.Script import Cardano.Api.Experimental.Tx.Internal.AnyWitness -import Cardano.Api.Experimental.Tx.Internal.TxScriptWitnessRequirements +import Cardano.Api.Experimental.Tx.Internal.TxScriptWitnessRequirements hiding + ( obtainMonoidConstraint + ) import Cardano.Api.Plutus.Internal.Script ( ExecutionUnits , Witness @@ -32,14 +41,18 @@ import Cardano.Api.Plutus.Internal.Script import Cardano.Api.Plutus.Internal.Script qualified as Old import Cardano.Api.Pretty import Cardano.Api.Tx.Internal.BuildTxWith +import Cardano.Api.Tx.Internal.TxIn +import Cardano.Api.Value.Internal qualified as Old 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.Mary.Value qualified as L import Cardano.Ledger.Plutus.Language qualified as L import Data.Text qualified as Text +import Data.Typeable -- | This module is concerned with converting legacy api scripts and by extension -- script witnesses to the new api. @@ -80,6 +93,7 @@ convertToNewScriptWitness eon (Old.PlutusScriptWitness _ v scriptOrRefInput datu obtainConstraints v $ toNewPlutusScriptWitness eon + witnessable v scriptOrRefInput scriptRedeemer @@ -102,7 +116,7 @@ createPlutusScriptDatum :: Witnessable thing era -> Old.PlutusScriptVersion lang -> Old.ScriptDatum witctx - -> PlutusScriptDatum (Old.ToLedgerPlutusLanguage lang) SpendingScript + -> PlutusScriptDatum (Old.ToLedgerPlutusLanguage lang) (ThingToPurpose thing) createPlutusScriptDatum missingContext plutusVersion oldDatum = case (missingContext, oldDatum) of (w@WitTxIn{}, d@Old.ScriptDatumForTxIn{}) -> toPlutusScriptDatum w plutusVersion d @@ -136,20 +150,21 @@ toPlutusScriptDatum WitTxIn{} Old.PlutusScriptV1 (Old.ScriptDatumForTxIn Nothing toPlutusScriptDatum WitTxIn{} Old.PlutusScriptV2 (Old.ScriptDatumForTxIn Nothing) = NoScriptDatum toNewPlutusScriptWitness - :: forall era lang purpose + :: forall era lang thing . L.PlutusLanguage (Old.ToLedgerPlutusLanguage lang) => AlonzoEraOnwards era + -> Witnessable thing (ShelleyLedgerEra era) -> Old.PlutusScriptVersion lang -> Old.PlutusScriptOrReferenceInput lang -> ScriptRedeemer -> ExecutionUnits - -> PlutusScriptDatum (Old.ToLedgerPlutusLanguage lang) purpose + -> PlutusScriptDatum (Old.ToLedgerPlutusLanguage lang) (ThingToPurpose thing) -> Either CBOR.DecoderError ( AnyWitness (ShelleyLedgerEra era) ) -toNewPlutusScriptWitness eon l (Old.PScript (Old.PlutusScriptSerialised scriptShortBs)) scriptRedeemer execUnits datum = do +toNewPlutusScriptWitness eon w l (Old.PScript (Old.PlutusScriptSerialised scriptShortBs)) scriptRedeemer execUnits datum = do let protocolVersion = getVersion eon plutusScript = L.Plutus $ L.PlutusBinary scriptShortBs @@ -158,18 +173,195 @@ toNewPlutusScriptWitness eon l (Old.PScript (Old.PlutusScriptSerialised scriptSh Left $ CBOR.DecoderErrorCustom "PlutusLedgerApi.Common.ScriptDecodeError" (Text.pack . show $ pretty e) Right plutusScriptRunnable -> - return - . AnyPlutusScriptWitness - $ mkPlutusScriptWitness + return $ + mkPlutusScriptWitness eon + w (toPlutusSLanguage l) plutusScriptRunnable datum scriptRedeemer execUnits -toNewPlutusScriptWitness _ l (Old.PReferenceScript refInput) scriptRedeemer execUnits datum = - return . AnyPlutusScriptWitness $ - PlutusScriptWitness (toPlutusSLanguage l) (PReferenceScript refInput) datum scriptRedeemer execUnits +toNewPlutusScriptWitness _ w l (Old.PReferenceScript refInput) scriptRedeemer execUnits datum = + return $ + mkReferencePlutusScriptWitness w (toPlutusSLanguage l) refInput datum scriptRedeemer execUnits + +type family ThingToPurpose thing where + ThingToPurpose TxInItem = SpendingScript + ThingToPurpose CertItem = CertifyingScript + ThingToPurpose MintItem = MintingScript + ThingToPurpose WithdrawalItem = WithdrawingScript + ThingToPurpose VoterItem = VotingScript + ThingToPurpose ProposalItem = ProposingScript + +mkPlutusScriptWitness + :: forall era thing plutuslang + . L.PlutusLanguage plutuslang + => AlonzoEraOnwards era + -> Witnessable thing (ShelleyLedgerEra era) + -> L.SLanguage plutuslang + -> L.PlutusRunnable plutuslang + -> PlutusScriptDatum plutuslang (ThingToPurpose thing) + -> ScriptRedeemer + -> ExecutionUnits + -> AnyWitness (ShelleyLedgerEra era) +mkPlutusScriptWitness eon w l plutusScriptRunnable d r e = + let script' :: PlutusScriptOrReferenceInput plutuslang (ShelleyLedgerEra era) + script' = (PScript $ PlutusScriptInEra plutusScriptRunnable) + in case w of + WitTxIn{} -> + let + s + :: AlonzoEraOnwards era + -> L.SLanguage plutuslang + -> PlutusScriptWitness plutuslang SpendingScript (ShelleyLedgerEra era) + s _eon lang = PlutusScriptWitness lang script' d r e + in + AnyPlutusScriptWitness $ + AnyPlutusSpendingScriptWitness $ + case l of + L.SPlutusV1 -> + PlutusSpendingScriptWitnessV1 (s eon l) + L.SPlutusV2 -> + PlutusSpendingScriptWitnessV2 (s eon l) + L.SPlutusV3 -> + PlutusSpendingScriptWitnessV3 (s eon l) + L.SPlutusV4 -> + PlutusSpendingScriptWitnessV4 (s eon l) + WitTxCert{} -> + AnyPlutusScriptWitness $ + AnyPlutusCertifyingScriptWitness + ( PlutusScriptWitness + l + script' + d + r + e + ) + WitMint{} -> + AnyPlutusScriptWitness $ + AnyPlutusMintingScriptWitness + ( PlutusScriptWitness + l + script' + d + r + e + ) + WitWithdrawal{} -> + AnyPlutusScriptWitness $ + AnyPlutusWithdrawingScriptWitness + ( PlutusScriptWitness + l + (PScript $ PlutusScriptInEra plutusScriptRunnable) + d + r + e + ) + WitVote{} -> + AnyPlutusScriptWitness $ + AnyPlutusVotingScriptWitness + ( PlutusScriptWitness + l + (PScript $ PlutusScriptInEra plutusScriptRunnable) + d + r + e + ) + WitProposal{} -> + AnyPlutusScriptWitness $ + AnyPlutusProposingScriptWitness + ( PlutusScriptWitness + l + (PScript $ PlutusScriptInEra plutusScriptRunnable) + d + r + e + ) + +mkReferencePlutusScriptWitness + :: forall thing era plutuslang + . Typeable plutuslang + => Witnessable thing (ShelleyLedgerEra era) + -> L.SLanguage plutuslang + -> TxIn + -> PlutusScriptDatum plutuslang (ThingToPurpose thing) + -> ScriptRedeemer + -> ExecutionUnits + -> AnyWitness (ShelleyLedgerEra era) +mkReferencePlutusScriptWitness w l txIn d r e = + case w of + WitTxIn{} -> + let s + :: L.SLanguage plutuslang + -> PlutusScriptWitness plutuslang SpendingScript (ShelleyLedgerEra era) + s lang = PlutusScriptWitness lang (PReferenceScript txIn) d r e + in AnyPlutusScriptWitness $ + AnyPlutusSpendingScriptWitness $ + case l of + L.SPlutusV1 -> + PlutusSpendingScriptWitnessV1 (s l) + L.SPlutusV2 -> + PlutusSpendingScriptWitnessV2 (s l) + L.SPlutusV3 -> + PlutusSpendingScriptWitnessV3 (s l) + L.SPlutusV4 -> + PlutusSpendingScriptWitnessV4 (s l) + WitTxCert{} -> + AnyPlutusScriptWitness $ + AnyPlutusCertifyingScriptWitness + ( PlutusScriptWitness + l + (PReferenceScript txIn) + d + r + e + ) + WitMint{} -> + AnyPlutusScriptWitness $ + AnyPlutusMintingScriptWitness + ( PlutusScriptWitness + l + (PReferenceScript txIn) + d + r + e + ) + WitWithdrawal{} -> + AnyPlutusScriptWitness $ + AnyPlutusWithdrawingScriptWitness + ( PlutusScriptWitness + l + (PReferenceScript txIn) + d + r + e + ) + WitVote{} -> + AnyPlutusScriptWitness $ + AnyPlutusVotingScriptWitness + ( PlutusScriptWitness + l + (PReferenceScript txIn) + d + r + e + ) + WitProposal{} -> + AnyPlutusScriptWitness $ + AnyPlutusProposingScriptWitness + ( PlutusScriptWitness + l + (PReferenceScript txIn) + d + r + e + ) + +-- PlutusScriptWitness +-- l +-- (PScript $ PlutusScriptInEra plutusScriptRunnable) +-- -- | When it comes to using plutus scripts we need to provide -- the following to the tx: @@ -192,7 +384,10 @@ legacyWitnessToScriptRequirements -> Either CBOR.DecoderError (TxScriptWitnessRequirements (ShelleyLedgerEra era)) legacyWitnessToScriptRequirements eon wits = do r <- legacyWitnessConversion eon wits - return $ getTxScriptWitnessesRequirements eon r + return $ + alonzoEraOnwardsConstraints eon $ + obtainMonoidConstraint eon $ + getTxScriptWitnessesRequirements r -- Misc helpers @@ -210,6 +405,16 @@ obtainConstraints v = Old.PlutusScriptV3 -> id Old.PlutusScriptV4 -> id +obtainMonoidConstraint + :: AlonzoEraOnwards era + -> (Monoid (TxScriptWitnessRequirements (ShelleyLedgerEra era)) => a) + -> a +obtainMonoidConstraint eon = case eon of + AlonzoEraOnwardsAlonzo -> id + AlonzoEraOnwardsBabbage -> id + AlonzoEraOnwardsConway -> id + AlonzoEraOnwardsDijkstra -> id + toPlutusSLanguage :: Old.PlutusScriptVersion lang -> L.SLanguage (Old.ToLedgerPlutusLanguage lang) toPlutusSLanguage = \case @@ -217,3 +422,17 @@ toPlutusSLanguage = \case Old.PlutusScriptV2 -> L.SPlutusV2 Old.PlutusScriptV3 -> L.SPlutusV3 Old.PlutusScriptV4 -> L.SPlutusV4 + +fromPlutusSLanguage + :: L.SLanguage lang -> Old.PlutusScriptVersion (Old.FromLedgerPlutusLanguage lang) +fromPlutusSLanguage = \case + L.SPlutusV1 -> Old.PlutusScriptV1 + L.SPlutusV2 -> Old.PlutusScriptV2 + L.SPlutusV3 -> Old.PlutusScriptV3 + L.SPlutusV4 -> Old.PlutusScriptV4 + +mkLegacyPolicyId :: forall era. Exp.IsEra era => L.Script (Exp.LedgerEra era) -> Old.PolicyId +mkLegacyPolicyId s = + let h :: L.ScriptHash = obtainCommonConstraints (Exp.useEra @era) $ L.hashScript s + pid = L.PolicyID h + in Old.fromMaryPolicyID pid diff --git a/cardano-api/src/Cardano/Api/Experimental/Simple/Script.hs b/cardano-api/src/Cardano/Api/Experimental/Simple/Script.hs index d426db729b..c668c18648 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Simple/Script.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Simple/Script.hs @@ -1,25 +1,71 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Cardano.Api.Experimental.Simple.Script ( SimpleScript (..) , SimpleScriptOrReferenceInput (..) + , deserialiseSimpleScript + , hashSimpleScript ) where +import Cardano.Api.Experimental.Era +import Cardano.Api.HasTypeProxy +import Cardano.Api.Ledger.Internal.Reexport qualified as L +import Cardano.Api.Serialise.Cbor import Cardano.Api.Tx.Internal.TxIn (TxIn) -import Cardano.Ledger.Core qualified as Ledger +import Cardano.Ledger.Alonzo.Scripts qualified as Alonzo +import Cardano.Ledger.Binary qualified as CBOR +import Cardano.Ledger.Core qualified as L + +import Data.ByteString qualified as BS -- | 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.EraScript era => Ledger.NativeScript era -> SimpleScript era + SimpleScript :: L.EraScript era => L.NativeScript era -> SimpleScript era deriving instance Show (SimpleScript era) deriving instance Eq (SimpleScript era) +instance L.Era era => HasTypeProxy (SimpleScript era) where + data AsType (SimpleScript era) = AsSimpleScriptEra (Proxy era) + proxyToAsType _ = AsSimpleScriptEra Proxy + +instance + (L.Era era, L.EraScript era) + => SerialiseAsCBOR (SimpleScript era) + where + serialiseToCBOR (SimpleScript ns) = L.serialize' (L.eraProtVerHigh @era) ns + + deserialiseFromCBOR _ bs = do + r <- + CBOR.runAnnotator + <$> CBOR.decodeFull' (L.eraProtVerHigh @era) bs + return $ SimpleScript $ r $ CBOR.Full $ BS.fromStrict bs + +deserialiseSimpleScript + :: forall era + . L.EraScript era + => BS.ByteString + -> Either CBOR.DecoderError (SimpleScript era) +deserialiseSimpleScript bs = + deserialiseFromCBOR (proxyToAsType (Proxy @(SimpleScript era))) bs + +hashSimpleScript + :: forall era. IsEra era => SimpleScript (LedgerEra era) -> L.ScriptHash +hashSimpleScript (SimpleScript ns) = + case useEra @era of + ConwayEra -> L.hashScript $ Alonzo.NativeScript ns + DijkstraEra -> L.hashScript $ Alonzo.NativeScript ns + data SimpleScriptOrReferenceInput era = SScript (SimpleScript era) | SReferenceScript TxIn diff --git a/cardano-api/src/Cardano/Api/Experimental/Tx.hs b/cardano-api/src/Cardano/Api/Experimental/Tx.hs index 6872ff7a72..47e529940c 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx.hs @@ -124,6 +124,48 @@ module Cardano.Api.Experimental.Tx , convertTxBodyToUnsignedTx , hashTxBody + -- * TxBodyContent + , TxBodyContent (..) + , defaultTxBodyContent + , mkTxCertificates + , mkTxVotingProcedures + , mkTxProposalProcedures + , setTxAuxScripts + , setTxCertificates + , setTxCollateral + , setTxCurrentTreasuryValue + , setTxExtraKeyWits + , setTxFee + , setTxIns + , setTxInsCollateral + , setTxInsReference + , setTxMetadata + , setTxMintValue + , setTxOuts + , setTxProposalProcedures + , setTxProtocolParams + , setTxScriptValidity + , setTxTreasuryDonation + , setTxValidityLowerBound + , setTxValidityUpperBound + , setTxVotingProcedures + , setTxWithdrawals + + -- * Legacy Conversions + , legacyDatumToDatum + , fromLegacyTxOut + + -- * TxBodyContent sub type + , TxCertificates (..) + , TxMintValue (..) + , TxOut (..) + , TxProposalProcedures (..) + , TxVotingProcedures (..) + , TxWithdrawals (..) + , TxCollateral (..) + , TxExtraKeyWitnesses (..) + , TxInsReference (..) + -- * Witness -- ** Any witness (key, simple script, plutus script). @@ -146,27 +188,25 @@ module Cardano.Api.Experimental.Tx ) where -import Cardano.Api.Era.Internal.Core (ToCardanoEra (toCardanoEra), forEraInEon) -import Cardano.Api.Era.Internal.Eon.Convert +import Cardano.Api.Era.Internal.Core qualified as Api import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra -import Cardano.Api.Era.Internal.Feature import Cardano.Api.Experimental.Era import Cardano.Api.Experimental.Tx.Internal.AnyWitness -import Cardano.Api.Experimental.Tx.Internal.Body +import Cardano.Api.Experimental.Tx.Internal.BodyContent.New import Cardano.Api.Experimental.Tx.Internal.TxScriptWitnessRequirements +import Cardano.Api.Experimental.Tx.Internal.Type import Cardano.Api.HasTypeProxy (HasTypeProxy (..), Proxy, asType) -import Cardano.Api.Ledger.Internal.Reexport (StrictMaybe (..), maybeToStrictMaybe) import Cardano.Api.Ledger.Internal.Reexport qualified as L import Cardano.Api.Pretty (docToString, pretty) +import Cardano.Api.ProtocolParameters import Cardano.Api.Serialise.Raw ( SerialiseAsRawBytes (..) , SerialiseAsRawBytesError (SerialiseAsRawBytesError) ) -import Cardano.Api.Tx.Internal.Body import Cardano.Api.Tx.Internal.Sign import Cardano.Crypto.Hash qualified as Hash -import Cardano.Ledger.Alonzo.TxBody qualified as L +import Cardano.Ledger.Alonzo.Tx qualified as L import Cardano.Ledger.Api qualified as L import Cardano.Ledger.Binary qualified as Ledger import Cardano.Ledger.Core qualified as Ledger @@ -176,150 +216,11 @@ import Control.Exception (displayException) import Data.Bifunctor (bimap) import Data.ByteString.Lazy (fromStrict) import Data.Set qualified as Set -import GHC.Exts (IsList (..)) import GHC.Stack import Lens.Micro --- | A transaction that can contain everything --- except key witnesses. -data UnsignedTx era - = L.EraTx (LedgerEra era) => UnsignedTx (Ledger.Tx (LedgerEra era)) - -instance HasTypeProxy era => HasTypeProxy (UnsignedTx era) where - data AsType (UnsignedTx era) = AsUnsignedTx (AsType era) - proxyToAsType :: Proxy (UnsignedTx era) -> AsType (UnsignedTx era) - proxyToAsType _ = AsUnsignedTx (asType @era) - -instance - ( HasTypeProxy era - , L.EraTx (LedgerEra era) - ) - => SerialiseAsRawBytes (UnsignedTx era) - where - serialiseToRawBytes (UnsignedTx tx) = - Ledger.serialize' (Ledger.eraProtVerHigh @(LedgerEra era)) tx - deserialiseFromRawBytes _ = - bimap wrapError UnsignedTx - . Ledger.decodeFullAnnotator - (Ledger.eraProtVerHigh @(LedgerEra era)) - "UnsignedTx" - Ledger.decCBOR - . fromStrict - where - wrapError - :: Ledger.DecoderError -> SerialiseAsRawBytesError - wrapError = SerialiseAsRawBytesError . displayException - -deriving instance Eq (UnsignedTx era) - -deriving instance Show (UnsignedTx era) - newtype UnsignedTxError - = UnsignedTxError TxBodyError - -makeUnsignedTx - :: Era era - -> TxBodyContent BuildTx era - -> Either TxBodyError (UnsignedTx era) -makeUnsignedTx DijkstraEra _ = error "makeUnsignedTx: Dijkstra era not supported yet" -makeUnsignedTx era@ConwayEra 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 - apiScriptValidity = txScriptValidity bc - apiMintValue = txMintValue bc - apiProtocolParameters = txProtocolParams bc - apiCollateralTxIns = txInsCollateral bc - apiReferenceInputs = txInsReference bc - apiExtraKeyWitnesses = txExtraKeyWits bc - apiReturnCollateral = txReturnCollateral bc - apiTotalCollateral = txTotalCollateral bc - - -- Ledger types - txins = convTxIns $ txIns bc - collTxIns = convCollateralTxIns apiCollateralTxIns - refTxIns = convReferenceInputs apiReferenceInputs - outs = convTxOuts sbe apiTxOuts - fee = convTransactionFee sbe $ txFee bc - withdrawals = convWithdrawals $ txWithdrawals bc - returnCollateral = convReturnCollateral sbe apiReturnCollateral - totalCollateral = convTotalCollateral apiTotalCollateral - certs = convCertificates sbe $ txCertificates bc - txAuxData = toAuxiliaryData sbe (txMetadata bc) (txAuxScripts bc) - scriptIntegrityHash = - convPParamsToScriptIntegrityHash - aeon - apiProtocolParameters - redeemers - datums - languages - - let setMint = convMintValue apiMintValue - setReqSignerHashes = convExtraKeyWitnesses apiExtraKeyWitnesses - ledgerTxBody = - L.mkBasicTxBody - & L.inputsTxBodyL .~ txins - & L.collateralInputsTxBodyL .~ collTxIns - & L.referenceInputsTxBodyL .~ refTxIns - & L.outputsTxBodyL .~ outs - & L.totalCollateralTxBodyL .~ totalCollateral - & L.collateralReturnTxBodyL .~ returnCollateral - & L.feeTxBodyL .~ fee - & L.vldtTxBodyL . L.invalidBeforeL .~ convValidityLowerBound (txValidityLowerBound bc) - & L.vldtTxBodyL . L.invalidHereAfterL .~ convValidityUpperBound sbe (txValidityUpperBound bc) - & L.reqSignerHashesTxBodyL .~ setReqSignerHashes - & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash - & L.withdrawalsTxBodyL .~ withdrawals - & L.certsTxBodyL .~ certs - & L.mintTxBodyL .~ setMint - & L.auxDataHashTxBodyL .~ maybe SNothing (SJust . Ledger.hashTxAuxData) txAuxData - - scriptWitnesses = - L.mkBasicTxWits - & L.scriptTxWitsL - .~ fromList - [ (L.hashScript sw, sw) - | sw <- scripts - ] - & L.datsTxWitsL .~ datums - & L.rdmrsTxWitsL .~ redeemers - - let eraSpecificTxBody = eraSpecificLedgerTxBody era ledgerTxBody bc - - return . UnsignedTx $ - L.mkBasicTx eraSpecificTxBody - & L.witsTxL .~ scriptWitnesses - & L.auxDataTxL .~ maybeToStrictMaybe (toAuxiliaryData sbe (txMetadata bc) (txAuxScripts bc)) - & L.isValidTxL .~ txScriptValidityToIsValid apiScriptValidity - -eraSpecificLedgerTxBody - :: Era era - -> Ledger.TxBody (LedgerEra era) - -> TxBodyContent BuildTx era - -> Ledger.TxBody (LedgerEra era) -eraSpecificLedgerTxBody era ledgerbody bc = - body era - where - body e = - let propProcedures = txProposalProcedures bc - voteProcedures = txVotingProcedures bc - treasuryDonation = txTreasuryDonation bc - currentTresuryValue = txCurrentTreasuryValue bc - in obtainCommonConstraints e $ - ledgerbody - & L.proposalProceduresTxBodyL - .~ convProposalProcedures (maybe TxProposalProceduresNone unFeatured propProcedures) - & L.votingProceduresTxBodyL - .~ convVotingProcedures (maybe TxVotingProceduresNone unFeatured voteProcedures) - & L.treasuryDonationTxBodyL - .~ maybe (L.Coin 0) unFeatured treasuryDonation - & L.currentTreasuryValueTxBodyL - .~ L.maybeToStrictMaybe (unFeatured =<< currentTresuryValue) + = UnsignedTxError String hashTxBody :: L.HashAnnotated (Ledger.TxBody era) L.EraIndependentTxBody @@ -398,8 +299,8 @@ signTx era bootstrapWits shelleyKeyWits (UnsignedTx unsigned) = convertTxBodyToUnsignedTx :: HasCallStack => ShelleyBasedEra era -> TxBody era -> UnsignedTx era convertTxBodyToUnsignedTx sbe txbody = - forEraInEon - (toCardanoEra sbe) + Api.forEraInEon + (Api.toCardanoEra sbe) (error $ "convertTxBodyToUnsignedTx: Error - unsupported era " <> docToString (pretty sbe)) ( \w -> do let ShelleyTx _ unsignedLedgerTx = makeSignedTransaction [] txbody diff --git a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/AnyWitness.hs b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/AnyWitness.hs index dc38bb7d5b..ab994c6bc0 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/AnyWitness.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/AnyWitness.hs @@ -1,39 +1,33 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} module Cardano.Api.Experimental.Tx.Internal.AnyWitness ( -- * Any witness (key, simple script, plutus script). AnyWitness (..) , getAnyWitnessScript + , getAnyWitnessSimpleScript , getAnyWitnessPlutusLanguage , getAnyWitnessScriptData + , getPlutusDatum ) where -import Cardano.Api.Era.Internal.Eon.AlonzoEraOnwards -import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra - ( ShelleyBasedEra (..) - , ShelleyLedgerEra - , forShelleyBasedEraInEon - ) -import Cardano.Api.Experimental.Plutus.Internal.Script +import Cardano.Api.Experimental.AnyScriptWitness import Cardano.Api.Experimental.Plutus.Internal.ScriptWitness import Cardano.Api.Experimental.Simple.Script ( SimpleScript (SimpleScript) , SimpleScriptOrReferenceInput (..) ) -import Cardano.Api.Ledger qualified as L +import Cardano.Api.Internal.Orphans.Misc () +import Cardano.Api.Ledger.Internal.Reexport qualified as L import Cardano.Api.Plutus.Internal.ScriptData -import Cardano.Ledger.Alonzo.Scripts 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.Dijkstra.Scripts qualified as Dijkstra -import Cardano.Ledger.Plutus.Data qualified as L -import Cardano.Ledger.Plutus.Language qualified as L -import GHC.Exts +import Data.Type.Equality -- | Here we consider three types of witnesses in Cardano: -- * key witnesses @@ -47,135 +41,74 @@ import GHC.Exts data AnyWitness era where AnyKeyWitnessPlaceholder :: AnyWitness era AnySimpleScriptWitness :: SimpleScriptOrReferenceInput era -> AnyWitness era - AnyPlutusScriptWitness :: PlutusScriptWitness lang purpose era -> AnyWitness era + AnyPlutusScriptWitness :: AnyPlutusScriptWitness lang purpose era -> AnyWitness era deriving instance Show (AnyWitness era) +instance Eq (AnyWitness era) where + AnyKeyWitnessPlaceholder == AnyKeyWitnessPlaceholder = True + (AnySimpleScriptWitness s1) == (AnySimpleScriptWitness s2) = s1 == s2 + (AnyPlutusScriptWitness (AnyPlutusSpendingScriptWitness s1)) == (AnyPlutusScriptWitness (AnyPlutusSpendingScriptWitness s2)) = + s1 == s2 + (AnyPlutusScriptWitness (AnyPlutusMintingScriptWitness s1)) == (AnyPlutusScriptWitness (AnyPlutusMintingScriptWitness s2)) = + case langTypeEquality s1 s2 of + Just Refl -> s1 == s2 + Nothing -> False + (AnyPlutusScriptWitness (AnyPlutusWithdrawingScriptWitness s1)) == (AnyPlutusScriptWitness (AnyPlutusWithdrawingScriptWitness s2)) = + case langTypeEquality s1 s2 of + Just Refl -> s1 == s2 + Nothing -> False + AnyPlutusScriptWitness (AnyPlutusCertifyingScriptWitness s1) == (AnyPlutusScriptWitness (AnyPlutusCertifyingScriptWitness s2)) = + case langTypeEquality s1 s2 of + Just Refl -> s1 == s2 + Nothing -> False + AnyPlutusScriptWitness (AnyPlutusProposingScriptWitness s1) == (AnyPlutusScriptWitness (AnyPlutusProposingScriptWitness s2)) = + case langTypeEquality s1 s2 of + Just Refl -> s1 == s2 + Nothing -> False + AnyPlutusScriptWitness (AnyPlutusVotingScriptWitness s1) == (AnyPlutusScriptWitness (AnyPlutusVotingScriptWitness s2)) = + case langTypeEquality s1 s2 of + Just Refl -> s1 == s2 + Nothing -> False + _ == _ = False + getAnyWitnessPlutusLanguage :: AnyWitness era -> Maybe L.Language getAnyWitnessPlutusLanguage AnyKeyWitnessPlaceholder = Nothing getAnyWitnessPlutusLanguage (AnySimpleScriptWitness _) = Nothing -getAnyWitnessPlutusLanguage (AnyPlutusScriptWitness swit) = Just $ getPlutusScriptWitnessLanguage swit +getAnyWitnessPlutusLanguage (AnyPlutusScriptWitness swit) = Just $ getAnyPlutusScriptWitnessLanguage swit getAnyWitnessSimpleScript - :: AnyWitness (ShelleyLedgerEra era) -> Maybe (L.NativeScript (ShelleyLedgerEra era)) + :: AnyWitness era -> Maybe (L.Script era) getAnyWitnessSimpleScript AnyKeyWitnessPlaceholder = Nothing getAnyWitnessSimpleScript (AnySimpleScriptWitness simpleScriptOrRefInput) = case simpleScriptOrRefInput of - SScript (SimpleScript simpleScript) -> Just simpleScript + SScript (SimpleScript simpleScript) -> Just $ L.fromNativeScript simpleScript SReferenceScript{} -> Nothing getAnyWitnessSimpleScript (AnyPlutusScriptWitness _) = Nothing getAnyWitnessPlutusScript - :: AlonzoEraOnwards era - -> AnyWitness (ShelleyLedgerEra era) - -> Maybe (L.PlutusScript (ShelleyLedgerEra era)) -getAnyWitnessPlutusScript _ AnyKeyWitnessPlaceholder = Nothing -getAnyWitnessPlutusScript _ (AnySimpleScriptWitness _) = Nothing + :: L.AlonzoEraScript era + => AnyWitness era + -> Maybe (L.Script era) +getAnyWitnessPlutusScript AnyKeyWitnessPlaceholder = Nothing +getAnyWitnessPlutusScript (AnySimpleScriptWitness _) = Nothing getAnyWitnessPlutusScript - eon ( AnyPlutusScriptWitness - (PlutusScriptWitness l (PScript (PlutusScriptInEra plutusScriptRunnable)) _ _ _) - ) = fromPlutusRunnable l eon plutusScriptRunnable -getAnyWitnessPlutusScript _ (AnyPlutusScriptWitness (PlutusScriptWitness _ (PReferenceScript{}) _ _ _)) = - Nothing + s + ) = getAnyPlutusWitnessPlutusScript s -- | NB this does not include datums from inline datums existing at tx outputs! getAnyWitnessScriptData - :: AlonzoEraOnwards era -> AnyWitness (ShelleyLedgerEra era) -> L.TxDats (ShelleyLedgerEra era) -getAnyWitnessScriptData eon AnyKeyWitnessPlaceholder = 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)] + :: L.Era era => AnyWitness era -> L.TxDats era +getAnyWitnessScriptData AnyKeyWitnessPlaceholder = mempty +getAnyWitnessScriptData AnySimpleScriptWitness{} = mempty +getAnyWitnessScriptData (AnyPlutusScriptWitness s) = getAnyPlutusScriptData s getAnyWitnessScript - :: ShelleyBasedEra era -> AnyWitness (ShelleyLedgerEra era) -> Maybe (L.Script (ShelleyLedgerEra era)) -getAnyWitnessScript _ AnyKeyWitnessPlaceholder = Nothing -getAnyWitnessScript era ss@(AnySimpleScriptWitness{}) = - case era of - ShelleyBasedEraShelley -> getAnyWitnessSimpleScript ss - ShelleyBasedEraAllegra -> getAnyWitnessSimpleScript ss - ShelleyBasedEraMary -> getAnyWitnessSimpleScript ss - ShelleyBasedEraAlonzo -> L.NativeScript <$> getAnyWitnessSimpleScript ss - ShelleyBasedEraBabbage -> L.NativeScript <$> getAnyWitnessSimpleScript ss - ShelleyBasedEraConway -> L.NativeScript <$> getAnyWitnessSimpleScript ss - ShelleyBasedEraDijkstra -> L.NativeScript <$> 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 - AlonzoEraOnwardsDijkstra -> 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.SPlutusV1 eon runnable = - case eon of - AlonzoEraOnwardsAlonzo -> - let plutusScript = L.plutusFromRunnable runnable - in Just $ L.AlonzoPlutusV1 plutusScript - AlonzoEraOnwardsBabbage -> - let plutusScript = L.plutusFromRunnable runnable - in Just $ L.BabbagePlutusV1 plutusScript - AlonzoEraOnwardsConway -> - let plutusScript = L.plutusFromRunnable runnable - in Just $ L.ConwayPlutusV1 plutusScript - AlonzoEraOnwardsDijkstra -> - let plutusScript = L.plutusFromRunnable runnable - in Just $ Dijkstra.DijkstraPlutusV1 plutusScript -fromPlutusRunnable L.SPlutusV2 eon runnable = - case eon of - AlonzoEraOnwardsAlonzo -> Nothing - AlonzoEraOnwardsBabbage -> - let plutusScript = L.plutusFromRunnable runnable - in Just $ L.BabbagePlutusV2 plutusScript - AlonzoEraOnwardsConway -> - let plutusScript = L.plutusFromRunnable runnable - in Just $ L.ConwayPlutusV2 plutusScript - AlonzoEraOnwardsDijkstra -> - let plutusScript = L.plutusFromRunnable runnable - in Just $ Dijkstra.DijkstraPlutusV2 plutusScript -fromPlutusRunnable L.SPlutusV3 eon runnable = - case eon of - AlonzoEraOnwardsAlonzo -> Nothing - AlonzoEraOnwardsBabbage -> Nothing - AlonzoEraOnwardsConway -> - let plutusScript = L.plutusFromRunnable runnable - in Just $ L.ConwayPlutusV3 plutusScript - AlonzoEraOnwardsDijkstra -> - let plutusScript = L.plutusFromRunnable runnable - in Just $ Dijkstra.DijkstraPlutusV3 plutusScript -fromPlutusRunnable L.SPlutusV4 eon runnable = - case eon of - AlonzoEraOnwardsAlonzo -> Nothing - AlonzoEraOnwardsBabbage -> Nothing - AlonzoEraOnwardsConway -> - let plutusScript = L.plutusFromRunnable runnable - in Just $ error "fromPlutusRunnable: ConwayPlutusV4" plutusScript - AlonzoEraOnwardsDijkstra -> - let plutusScript = L.plutusFromRunnable runnable - in Just $ Dijkstra.DijkstraPlutusV4 plutusScript - -toAlonzoDatum - :: AlonzoEraOnwards era - -> L.SLanguage lang - -> PlutusScriptDatum 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 + :: L.AlonzoEraScript era => AnyWitness era -> Maybe (L.Script era) +getAnyWitnessScript AnyKeyWitnessPlaceholder = Nothing +getAnyWitnessScript ss@(AnySimpleScriptWitness{}) = getAnyWitnessSimpleScript ss +getAnyWitnessScript ps@(AnyPlutusScriptWitness{}) = getAnyWitnessPlutusScript ps getPlutusDatum :: L.SLanguage lang -> PlutusScriptDatum lang purpose -> Maybe HashableScriptData diff --git a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Body.hs b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Body.hs deleted file mode 100644 index 031a9d9774..0000000000 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Body.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Cardano.Api.Experimental.Tx.Internal.Body - ( extractAllIndexedPlutusScriptWitnesses - ) -where - -import Cardano.Api.Era -import Cardano.Api.Experimental.Era -import Cardano.Api.Experimental.Plutus -import Cardano.Api.Plutus.Internal.Script -import Cardano.Api.Tx.Internal.Body - -import Cardano.Binary qualified as CBOR - -extractAllIndexedPlutusScriptWitnesses - :: forall era - . Era era - -> TxBodyContent BuildTx era - -> Either - CBOR.DecoderError - [AnyIndexedPlutusScriptWitness (LedgerEra era)] -extractAllIndexedPlutusScriptWitnesses era b = obtainCommonConstraints era $ do - let sbe = convert era - aeon = convert era - legacyTxInWits = extractWitnessableTxIns aeon $ txIns b - legacyCertWits = extractWitnessableCertificates aeon $ txCertificates b - legacyMintWits = extractWitnessableMints aeon $ txMintValue b - proposalWits - :: [(Witnessable ProposalItem (ShelleyLedgerEra era), BuildTxWith BuildTx (Witness WitCtxStake era))] = - caseShelleyToBabbageOrConwayEraOnwards - (const []) - (`extractWitnessableProposals` txProposalProcedures b) - sbe - legacyWithdrawalWits = extractWitnessableWithdrawals aeon $ txWithdrawals b - legacyVoteWits - :: [(Witnessable VoterItem (ShelleyLedgerEra era), BuildTxWith BuildTx (Witness WitCtxStake era))] = - caseShelleyToBabbageOrConwayEraOnwards - (const []) - (`extractWitnessableVotes` txVotingProcedures b) - sbe - - txInWits <- legacyWitnessConversion aeon legacyTxInWits - let indexedScriptTxInWits = alonzoEraOnwardsConstraints aeon $ createIndexedPlutusScriptWitnesses txInWits - - certWits <- legacyWitnessConversion aeon legacyCertWits - let indexedCertScriptWits = alonzoEraOnwardsConstraints aeon $ createIndexedPlutusScriptWitnesses certWits - - mintWits <- legacyWitnessConversion aeon legacyMintWits - let indexedMintScriptWits = alonzoEraOnwardsConstraints aeon $ createIndexedPlutusScriptWitnesses mintWits - - withdrawalWits <- legacyWitnessConversion aeon legacyWithdrawalWits - let indexedWithdrawalScriptWits = alonzoEraOnwardsConstraints aeon $ createIndexedPlutusScriptWitnesses withdrawalWits - - proposalScriptWits <- legacyWitnessConversion aeon proposalWits - let indexedProposalScriptWits = alonzoEraOnwardsConstraints aeon $ createIndexedPlutusScriptWitnesses proposalScriptWits - - voteWits <- legacyWitnessConversion aeon legacyVoteWits - let indexedVoteScriptWits = alonzoEraOnwardsConstraints aeon $ createIndexedPlutusScriptWitnesses voteWits - return $ - mconcat - [ indexedScriptTxInWits - , indexedMintScriptWits - , indexedCertScriptWits - , indexedWithdrawalScriptWits - , indexedProposalScriptWits - , indexedVoteScriptWits - ] diff --git a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/BodyContent/New.hs b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/BodyContent/New.hs new file mode 100644 index 0000000000..deecf1e25d --- /dev/null +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/BodyContent/New.hs @@ -0,0 +1,813 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +module Cardano.Api.Experimental.Tx.Internal.BodyContent.New + ( TxCertificates (..) + , TxCollateral (..) + , TxExtraKeyWitnesses (..) + , TxInsReference (..) + , TxMintValue (..) + , TxOut (..) + , TxProposalProcedures (..) + , TxValidityLowerBound (..) + , TxVotingProcedures (..) + , TxWithdrawals (..) + , TxBodyContent (..) + , Datum (..) + , defaultTxBodyContent + , collectTxBodyScriptWitnessRequirements + , makeUnsignedTx + , extractAllIndexedPlutusScriptWitnesses + , txMintValueToValue + , mkTxCertificates + , mkTxVotingProcedures + , mkTxProposalProcedures + + -- * Getters and Setters + , setTxAuxScripts + , setTxCertificates + , setTxCollateral + , setTxCurrentTreasuryValue + , setTxExtraKeyWits + , setTxFee + , setTxIns + , setTxInsCollateral + , setTxInsReference + , setTxMetadata + , setTxMintValue + , setTxOuts + , setTxProposalProcedures + , setTxProtocolParams + , setTxScriptValidity + , setTxTreasuryDonation + , setTxValidityLowerBound + , setTxValidityUpperBound + , setTxVotingProcedures + , setTxWithdrawals + + -- * Internal conversions + , convProposalProcedures + + -- * Legacy conversions + , legacyDatumToDatum + , fromLegacyTxOut + ) +where + +import Cardano.Api.Address +import Cardano.Api.Experimental.Certificate qualified as Exp +import Cardano.Api.Experimental.Era +import Cardano.Api.Experimental.Plutus + ( AnyIndexedPlutusScriptWitness (..) + , Witnessable (..) + , WitnessableItem (..) + , createIndexedPlutusScriptWitnesses + ) +import Cardano.Api.Experimental.Simple.Script +import Cardano.Api.Experimental.Tx.Internal.AnyWitness + ( AnyWitness (..) + ) +import Cardano.Api.Experimental.Tx.Internal.Certificate.Compatible (getTxCertWitness) +import Cardano.Api.Experimental.Tx.Internal.TxScriptWitnessRequirements + ( TxScriptWitnessRequirements (..) + , getTxScriptWitnessesRequirements + ) +import Cardano.Api.Experimental.Tx.Internal.Type +import Cardano.Api.Governance.Internal.Action.VotingProcedure + ( VotesMergingConflict (..) + , mergeVotingProcedures + ) +import Cardano.Api.Key.Internal +import Cardano.Api.Ledger.Internal.Reexport (StrictMaybe (..)) +import Cardano.Api.Ledger.Internal.Reexport qualified as L +import Cardano.Api.Plutus.Internal.ScriptData qualified as Api +import Cardano.Api.Tx.Internal.Body + ( CtxTx + , TxIn + , toShelleyTxIn + , toShelleyWithdrawal + ) +import Cardano.Api.Tx.Internal.Output qualified as OldApi +import Cardano.Api.Tx.Internal.Sign +import Cardano.Api.Tx.Internal.TxMetadata +import Cardano.Api.Value.Internal (PolicyAssets, PolicyId, Value, policyAssetsToValue, toMaryValue) + +import Cardano.Binary qualified as CBOR +import Cardano.Ledger.Alonzo.Scripts qualified as L +import Cardano.Ledger.Alonzo.Tx qualified as L +import Cardano.Ledger.Alonzo.TxBody qualified as L +import Cardano.Ledger.Alonzo.TxWits qualified as L +import Cardano.Ledger.Api qualified as L +import Cardano.Ledger.Core qualified as Ledger +import Cardano.Ledger.Keys qualified as L +import Cardano.Ledger.Plutus.Language qualified as Plutus + +import Control.Monad +import Data.Functor +import Data.List qualified as List +import Data.Map.Ordered.Strict (OMap) +import Data.Map.Ordered.Strict qualified as OMap +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe +import Data.OSet.Strict (OSet) +import Data.OSet.Strict qualified as OSet +import Data.Sequence.Strict qualified as Seq +import Data.Set (Set) +import Data.Set qualified as Set +import GHC.Exts (IsList (..)) +import Lens.Micro + +makeUnsignedTx + :: forall era + . Era era + -> TxBodyContent (LedgerEra era) + -> UnsignedTx era +makeUnsignedTx DijkstraEra _ = error "makeUnsignedTx: Dijkstra era not supported yet" +makeUnsignedTx era@ConwayEra bc = obtainCommonConstraints era $ do + let TxScriptWitnessRequirements languages scripts datums redeemers = collectTxBodyScriptWitnessRequirements bc + + -- cardano-api types + let apiMintValue = txMintValue bc + apiReferenceInputs = txInsReference bc + apiExtraKeyWitnesses = txExtraKeyWits bc + + -- Ledger types + txins = convTxIns $ txIns bc + collTxIns = convCollateralTxIns bc + refTxIns = convReferenceInputs apiReferenceInputs + outs = fromList [o | TxOut o _ <- txOuts bc] + protocolParameters = txProtocolParams bc + fee = txFee bc + withdrawals = convWithdrawals $ txWithdrawals bc + certs = convCertificates $ txCertificates bc + retCollateral = returnCollateral <$> txCollateral bc + totCollateral = totalCollateral <$> txCollateral bc + txAuxData = toAuxiliaryData (txMetadata bc) (txAuxScripts bc) + scriptValidity = scriptValidityToIsValid $ txScriptValidity bc + scriptIntegrityHash = + convPParamsToScriptIntegrityHash + protocolParameters + redeemers + datums + languages + + let setMint = convMintValue apiMintValue + setReqSignerHashes = convExtraKeyWitnesses apiExtraKeyWitnesses + ledgerTxBody = + L.mkBasicTxBody + & L.inputsTxBodyL .~ txins + & L.collateralInputsTxBodyL .~ collTxIns + & L.referenceInputsTxBodyL .~ refTxIns + & L.outputsTxBodyL .~ outs + & L.totalCollateralTxBodyL .~ L.maybeToStrictMaybe totCollateral + & L.collateralReturnTxBodyL .~ L.maybeToStrictMaybe retCollateral + & L.feeTxBodyL .~ fee + & L.vldtTxBodyL . L.invalidBeforeL .~ txValidityLowerBound bc + & L.vldtTxBodyL . L.invalidHereAfterL .~ txValidityUpperBound bc + & L.reqSignerHashesTxBodyL .~ setReqSignerHashes + & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash + & L.withdrawalsTxBodyL .~ withdrawals + & L.certsTxBodyL .~ certs + & L.mintTxBodyL .~ setMint + & L.auxDataHashTxBodyL .~ L.maybeToStrictMaybe (Ledger.hashTxAuxData <$> txAuxData) + + scriptWitnesses = + L.mkBasicTxWits + & L.scriptTxWitsL + .~ fromList + [ (L.hashScript sw, sw) + | sw <- scripts + ] + & L.datsTxWitsL .~ datums + & L.rdmrsTxWitsL .~ redeemers + + let eraSpecificTxBody = eraSpecificLedgerTxBody era ledgerTxBody bc + UnsignedTx $ + L.mkBasicTx eraSpecificTxBody + & L.witsTxL .~ scriptWitnesses + & L.auxDataTxL .~ L.maybeToStrictMaybe (toAuxiliaryData (txMetadata bc) (txAuxScripts bc)) + & L.isValidTxL .~ scriptValidity + +convTxIns :: [(TxIn, AnyWitness era)] -> Set L.TxIn +convTxIns inputs = + Set.fromList [toShelleyTxIn txin | (txin, _) <- inputs] + +convCollateralTxIns :: TxBodyContent (LedgerEra era) -> Set L.TxIn +convCollateralTxIns b = + fromList (map toShelleyTxIn $ txInsCollateral b) + +convReferenceInputs :: TxInsReference era -> Set L.TxIn +convReferenceInputs (TxInsReference ins _) = + fromList $ map toShelleyTxIn ins + +convWithdrawals :: TxWithdrawals era -> L.Withdrawals +convWithdrawals (TxWithdrawals ws) = + toShelleyWithdrawal ws + +convMintValue :: TxMintValue era -> L.MultiAsset +convMintValue v = do + let L.MaryValue _coin multiAsset = toMaryValue $ txMintValueToValue v + multiAsset + +convExtraKeyWitnesses + :: TxExtraKeyWitnesses -> Set (L.KeyHash L.Witness) +convExtraKeyWitnesses (TxExtraKeyWitnesses khs) = + fromList + [ L.asWitness kh + | PaymentKeyHash kh <- khs + ] + +convCertificates + :: TxCertificates (LedgerEra era) + -> Seq.StrictSeq (L.TxCert (LedgerEra era)) +convCertificates (TxCertificates cs) = + fromList . map (\(Exp.Certificate c, _) -> c) $ toList cs + +convPParamsToScriptIntegrityHash + :: forall era + . IsEra era + => Maybe (Ledger.PParams (LedgerEra era)) + -> L.Redeemers (LedgerEra era) + -> L.TxDats (LedgerEra era) + -> Set Plutus.Language + -> StrictMaybe L.ScriptIntegrityHash +convPParamsToScriptIntegrityHash mTxProtocolParams redeemers datums languages = obtainCommonConstraints (useEra @era) $ do + pp <- L.maybeToStrictMaybe mTxProtocolParams + -- This logic is copied from ledger, because their code is not reusable + -- c.f. https://github.com/IntersectMBO/cardano-ledger/commit/5a975d9af507c9ee835a86d3bb77f3e2670ad228#diff-8236dfec9688f22550b91fc9a87af9915523ab9c5bd817218ecceec8ca7a789bR282 + let shouldCalculateHash = + not $ + null (redeemers ^. L.unRedeemersL) + && null (datums ^. L.unTxDatsL) + && null languages + guard shouldCalculateHash + let scriptIntegrity = L.ScriptIntegrity redeemers datums (Set.map (L.getLanguageView pp) languages) + pure $ L.hashScriptIntegrity scriptIntegrity + +convProposalProcedures + :: forall era + . IsEra era + => Maybe (TxProposalProcedures (LedgerEra era)) -> OSet (L.ProposalProcedure (LedgerEra era)) +convProposalProcedures Nothing = OSet.empty +convProposalProcedures (Just (TxProposalProcedures proposals)) = + obtainCommonConstraints (useEra @era) $ fromList $ fst <$> toList proposals + +convVotingProcedures + :: Maybe (TxVotingProcedures (LedgerEra era)) -> L.VotingProcedures (LedgerEra era) +convVotingProcedures (Just (TxVotingProcedures vps _)) = vps +convVotingProcedures Nothing = L.VotingProcedures mempty + +-- | Auxiliary data consists of the tx metadata +-- and the auxiliary scripts, and the auxiliary script data. +toAuxiliaryData + :: forall era + . IsEra era + => TxMetadata + -> [SimpleScript (LedgerEra era)] + -> Maybe (L.TxAuxData (LedgerEra era)) +toAuxiliaryData txMData ss' = + let ms = toShelleyMetadata $ unTxMetadata txMData + in case useEra @era of + ConwayEra -> + -- guard (not (Map.null ms && null ss)) $> + let ss = [L.NativeScript s | SimpleScript s <- ss'] + in guard (not (Map.null ms && null ss)) $> L.mkAlonzoTxAuxData ms ss + DijkstraEra -> + let ss = [L.NativeScript s | SimpleScript s <- ss'] + in guard (not (Map.null ms && null ss)) $> L.mkAlonzoTxAuxData ms ss + +eraSpecificLedgerTxBody + :: Era era + -> L.TxBody (LedgerEra era) + -> TxBodyContent (LedgerEra era) + -> L.TxBody (LedgerEra era) +eraSpecificLedgerTxBody era ledgerbody bc = + body era + where + body e = + let propProcedures = txProposalProcedures bc + voteProcedures = txVotingProcedures bc + treasuryDonation = txTreasuryDonation bc + currentTresuryValue = txCurrentTreasuryValue bc + in obtainCommonConstraints e $ + ledgerbody + & L.proposalProceduresTxBodyL + .~ convProposalProcedures propProcedures + & L.votingProceduresTxBodyL + .~ convVotingProcedures voteProcedures + & L.treasuryDonationTxBodyL + .~ fromMaybe (L.Coin 0) treasuryDonation + & L.currentTreasuryValueTxBodyL + .~ L.maybeToStrictMaybe currentTresuryValue + +data TxOut ctx era where + TxOut :: L.EraTxOut era => L.TxOut era -> Maybe (Datum ctx era) -> TxOut ctx era + +deriving instance (Show (TxOut ctx era)) + +deriving instance (Eq (TxOut ctx era)) + +data Datum ctx era where + TxOutDatumHash + :: L.DataHash + -> Datum ctx era + TxOutSupplementalDatum + :: L.DataHash + -> L.Data era + -> Datum CtxTx era + TxOutDatumInline + :: L.DataHash + -> L.Data era + -> Datum ctx era + +deriving instance (Show (Datum ctx era)) + +deriving instance (Eq (Datum ctx era)) + +extractDatumsAndHashes :: Datum ctx era -> Maybe (L.DataHash, L.Data era) +extractDatumsAndHashes TxOutDatumHash{} = Nothing +extractDatumsAndHashes (TxOutSupplementalDatum h d) = Just (h, d) +extractDatumsAndHashes (TxOutDatumInline h d) = Just (h, d) + +hashableScriptDatumToDatumAndHash :: L.Era era => Api.HashableScriptData -> (L.DataHash, L.Data era) +hashableScriptDatumToDatumAndHash sd = + (Api.unScriptDataHash $ Api.hashScriptDataBytes sd, Api.toAlonzoData sd) + +legacyDatumToDatum + :: forall era. IsEra era => OldApi.TxOutDatum CtxTx era -> Maybe (Datum CtxTx (LedgerEra era)) +legacyDatumToDatum (OldApi.TxOutDatumHash _ h) = Just (TxOutDatumHash $ Api.unScriptDataHash h) +legacyDatumToDatum (OldApi.TxOutSupplementalDatum _ hd) = do + let (hash, d) = obtainCommonConstraints (useEra @era) $ hashableScriptDatumToDatumAndHash hd + Just (TxOutSupplementalDatum hash d) +legacyDatumToDatum (OldApi.TxOutDatumInline _ hd) = do + let (hash, d) = obtainCommonConstraints (useEra @era) $ hashableScriptDatumToDatumAndHash hd + Just (TxOutDatumInline hash d) +legacyDatumToDatum OldApi.TxOutDatumNone = Nothing + +fromLegacyTxOut :: forall era. IsEra era => OldApi.TxOut CtxTx era -> TxOut CtxTx (LedgerEra era) +fromLegacyTxOut tOut@(OldApi.TxOut _ _ d _) = + let o = OldApi.toShelleyTxOutAny (convert $ useEra @era) tOut + in obtainCommonConstraints (useEra @era) $ TxOut o (legacyDatumToDatum d) + +data TxInsReference era = TxInsReference [TxIn] (Set (Datum CtxTx era)) + +data TxCollateral era + = TxCollateral + { totalCollateral :: L.Coin + , returnCollateral :: L.TxOut era + } + +newtype TxValidityLowerBound = TxValidityLowerBound L.SlotNo + +newtype TxExtraKeyWitnesses = TxExtraKeyWitnesses [Hash PaymentKey] + +newtype TxWithdrawals era = TxWithdrawals {unTxWithdrawals :: [(StakeAddress, L.Coin, AnyWitness era)]} + deriving (Eq, Show) + +newtype TxCertificates era + = TxCertificates + {unTxCertificates :: OMap (Exp.Certificate era) (Maybe (StakeCredential, AnyWitness era))} + deriving (Show, Eq) + +-- | Create 'TxCertificates'. Note that 'Certificate era' will be deduplicated. Only Certificates with a +-- stake credential will be in the result. +-- +-- Note that, when building a transaction in Conway era, a witness is not required for staking credential +-- registration, but this is only the case during the transitional period of Conway era and only for staking +-- credential registration certificates without a deposit. Future eras will require a witness for +-- registration certificates, because the one without a deposit will be removed. +mkTxCertificates + :: forall era + . Era era + -> [(Exp.Certificate (LedgerEra era), AnyWitness (LedgerEra era))] + -> TxCertificates (LedgerEra era) +mkTxCertificates era certs = TxCertificates . OMap.fromList $ map getStakeCred certs + where + getStakeCred + :: (Exp.Certificate (LedgerEra era), AnyWitness (LedgerEra era)) + -> ( Exp.Certificate (LedgerEra era) + , Maybe (StakeCredential, AnyWitness (LedgerEra era)) + ) + getStakeCred (c@(Exp.Certificate cert), wit) = + (c, (,wit) <$> getTxCertWitness (convert era) (obtainCommonConstraints era cert)) + +-- This is incorrect. Only scripts can witness minting! +newtype TxMintValue era + = TxMintValue + { unTxMintValue + :: Map + PolicyId + ( PolicyAssets + , AnyWitness era + ) + } + deriving (Eq, Show) + +-- | Convert 'TxMintValue' to a more handy 'Value'. +txMintValueToValue :: TxMintValue era -> Value +txMintValueToValue (TxMintValue policiesWithAssets) = + mconcat + [ policyAssetsToValue policyId assets + | (policyId, (assets, _witness)) <- toList policiesWithAssets + ] + +newtype TxProposalProcedures era + = TxProposalProcedures + ( OMap + (L.ProposalProcedure era) + (AnyWitness era) + ) + deriving (Show, Eq) + +-- | A smart constructor for 'TxProposalProcedures'. It makes sure that the value produced is consistent - the +-- witnessed proposals are also present in the first constructor parameter. +mkTxProposalProcedures + :: forall era + . IsEra era + => [(L.ProposalProcedure (LedgerEra era), AnyWitness (LedgerEra era))] + -> TxProposalProcedures (LedgerEra era) +mkTxProposalProcedures proposals = do + TxProposalProcedures $ + obtainCommonConstraints (useEra @era) $ + OMap.fromList proposals + +data TxVotingProcedures era + = TxVotingProcedures + (L.VotingProcedures era) + (Map L.Voter (AnyWitness era)) + deriving (Eq, Show) + +-- | Create voting procedures from map of voting procedures and optional witnesses. +-- Validates the function argument, to make sure the list of votes is legal. +-- See 'mergeVotingProcedures' for validation rules. +mkTxVotingProcedures + :: forall era + . [(L.VotingProcedures era, AnyWitness era)] + -> Either (VotesMergingConflict era) (TxVotingProcedures era) +mkTxVotingProcedures votingProcedures = do + procedure <- + foldM f (L.VotingProcedures Map.empty) votingProcedures + pure $ TxVotingProcedures procedure votingScriptWitnessMap + where + votingScriptWitnessMap :: Map L.Voter (AnyWitness era) + votingScriptWitnessMap = + foldl + (\acc next -> acc `Map.union` uncurry votingScriptWitnessSingleton next) + Map.empty + votingProcedures + + f + :: L.VotingProcedures era + -> (L.VotingProcedures era, AnyWitness era) + -> Either (VotesMergingConflict era) (L.VotingProcedures era) + f acc (procedure, _witness) = mergeVotingProcedures acc procedure + + votingScriptWitnessSingleton + :: L.VotingProcedures era + -> AnyWitness era + -> Map L.Voter (AnyWitness era) + votingScriptWitnessSingleton votingProcedures' scriptWitness = do + let voter = fromJust $ getVotingScriptCredentials votingProcedures' + Map.singleton voter scriptWitness + + getVotingScriptCredentials + :: L.VotingProcedures era + -> Maybe L.Voter + getVotingScriptCredentials (L.VotingProcedures m) = + listToMaybe $ Map.keys m + +data TxBodyContent era + = TxBodyContent + { txIns :: [(TxIn, AnyWitness era)] + , txInsCollateral :: [TxIn] + , txInsReference :: TxInsReference era + , txOuts :: [TxOut CtxTx era] + , txCollateral :: Maybe (TxCollateral era) + , txFee :: L.Coin + , txValidityLowerBound :: Maybe L.SlotNo + , txValidityUpperBound :: Maybe L.SlotNo + , txMetadata :: TxMetadata + , txAuxScripts :: [SimpleScript era] + , txExtraKeyWits :: TxExtraKeyWitnesses + , txProtocolParams :: Maybe (L.PParams era) + , txWithdrawals :: TxWithdrawals era + , txCertificates :: TxCertificates era + , txMintValue :: TxMintValue era + , txScriptValidity :: ScriptValidity + , txProposalProcedures :: Maybe (TxProposalProcedures era) + , txVotingProcedures :: Maybe (TxVotingProcedures era) + , txCurrentTreasuryValue :: Maybe L.Coin + , -- -- ^ Current treasury value + txTreasuryDonation :: Maybe L.Coin + -- -- ^ Treasury donation to perform + } + +defaultTxBodyContent + :: TxBodyContent era +defaultTxBodyContent = + TxBodyContent + { txIns = [] + , txInsCollateral = [] + , txInsReference = TxInsReference mempty Set.empty + , txOuts = [] + , txCollateral = Nothing + , txFee = 0 + , txValidityLowerBound = Nothing + , txValidityUpperBound = Nothing + , txMetadata = TxMetadata mempty + , txAuxScripts = [] + , txExtraKeyWits = TxExtraKeyWitnesses [] + , txProtocolParams = Nothing + , txWithdrawals = TxWithdrawals mempty + , txCertificates = TxCertificates OMap.empty + , txMintValue = TxMintValue mempty + , txScriptValidity = ScriptValid + , txProposalProcedures = Nothing + , txVotingProcedures = Nothing + , txCurrentTreasuryValue = Nothing + , txTreasuryDonation = Nothing + } + +extractAllIndexedPlutusScriptWitnesses + :: forall era + . Era era + -> TxBodyContent (LedgerEra era) + -> Either + CBOR.DecoderError + [AnyIndexedPlutusScriptWitness (LedgerEra era)] +extractAllIndexedPlutusScriptWitnesses era b = obtainCommonConstraints era $ do + let txInWits = extractWitnessableTxIns $ txIns b + certWits = extractWitnessableCertificates $ txCertificates b + mintWits = extractWitnessableMints $ txMintValue b + withdrawalWits = extractWitnessableWithdrawals $ txWithdrawals b + proposalScriptWits = extractWitnessableProposals $ txProposalProcedures b + voteWits = extractWitnessableVotes $ txVotingProcedures b + + let indexedScriptTxInWits = obtainCommonConstraints era $ createIndexedPlutusScriptWitnesses txInWits + indexedCertScriptWits = obtainCommonConstraints era $ createIndexedPlutusScriptWitnesses certWits + indexedMintScriptWits = obtainCommonConstraints era $ createIndexedPlutusScriptWitnesses mintWits + indexedWithdrawalScriptWits = obtainCommonConstraints era $ createIndexedPlutusScriptWitnesses withdrawalWits + indexedProposalScriptWits = obtainCommonConstraints era $ createIndexedPlutusScriptWitnesses proposalScriptWits + indexedVoteScriptWits = obtainCommonConstraints era $ createIndexedPlutusScriptWitnesses voteWits + return $ + mconcat + [ indexedScriptTxInWits + , indexedMintScriptWits + , indexedCertScriptWits + , indexedWithdrawalScriptWits + , indexedProposalScriptWits + , indexedVoteScriptWits + ] + +extractWitnessableTxIns + :: forall era + . IsEra era + => [(TxIn, AnyWitness (LedgerEra era))] + -> [(Witnessable TxInItem (LedgerEra era), AnyWitness (LedgerEra era))] +extractWitnessableTxIns tIns = + obtainCommonConstraints (useEra @era) $ + List.nub [(WitTxIn txin, wit) | (txin, wit) <- tIns] + +extractWitnessableCertificates + :: forall era + . IsEra era + => TxCertificates (LedgerEra era) + -> [(Witnessable CertItem (LedgerEra era), AnyWitness (LedgerEra era))] +extractWitnessableCertificates txCerts = + obtainCommonConstraints (useEra @era) $ + List.nub + [ ( WitTxCert cert stakeCred + , wit + ) + | (Exp.Certificate cert, Just (stakeCred, wit)) <- getCertificates txCerts + ] + where + getCertificates (TxCertificates txcs) = toList txcs + +extractWitnessableMints + :: forall era + . IsEra era + => TxMintValue (LedgerEra era) + -> [(Witnessable MintItem (LedgerEra era), AnyWitness (LedgerEra era))] +extractWitnessableMints mVal = + obtainCommonConstraints (useEra @era) $ + List.nub + [ (WitMint policyId policyAssets, wit) + | (policyId, (policyAssets, wit)) <- getMints mVal + ] + where + getMints (TxMintValue txms) = toList txms + +extractWitnessableWithdrawals + :: forall era + . IsEra era + => TxWithdrawals (LedgerEra era) + -> [(Witnessable WithdrawalItem (LedgerEra era), AnyWitness (LedgerEra era))] +extractWitnessableWithdrawals txWithDrawals = + obtainCommonConstraints (useEra @era) $ + List.nub + [ (WitWithdrawal addr withAmt, wit) + | (addr, withAmt, wit) <- getWithdrawals txWithDrawals + ] + where + getWithdrawals (TxWithdrawals txws) = txws + +extractWitnessableVotes + :: forall era + . IsEra era + => Maybe (TxVotingProcedures (LedgerEra era)) + -> [(Witnessable VoterItem (LedgerEra era), AnyWitness (LedgerEra era))] +extractWitnessableVotes Nothing = [] +extractWitnessableVotes (Just txVoteProc) = + case useEra @era of + DijkstraEra -> error "extractWitnessableVotes: Dijkstra era not supported" + ConwayEra -> + List.nub + [ (WitVote vote, wit) + | (vote, wit) <- getVotes txVoteProc + ] + where + getVotes + :: TxVotingProcedures (LedgerEra era) + -> [(L.Voter, AnyWitness (LedgerEra era))] + getVotes (TxVotingProcedures allVotingProcedures scriptWitnessedVotes) = + [ (voter, wit) + | (voter, _) <- toList $ L.unVotingProcedures allVotingProcedures + , wit <- maybe [] return (Map.lookup voter scriptWitnessedVotes) + ] + +extractWitnessableProposals + :: forall era + . IsEra era + => Maybe + (TxProposalProcedures (LedgerEra era)) + -> [(Witnessable ProposalItem (LedgerEra era), AnyWitness (LedgerEra era))] +extractWitnessableProposals Nothing = [] +extractWitnessableProposals (Just txPropProcedures) = + List.nub + [ (obtainCommonConstraints (useEra @era) (WitProposal prop), wit) + | (prop, wit) <- + getProposals txPropProcedures + ] + where + getProposals + :: TxProposalProcedures (LedgerEra era) + -> [(L.ProposalProcedure (LedgerEra era), AnyWitness (LedgerEra era))] + getProposals (TxProposalProcedures txps) = + obtainCommonConstraints (useEra @era) (toList txps) + +collectTxBodyScriptWitnessRequirements + :: forall era + . IsEra era + => TxBodyContent (LedgerEra era) + -> TxScriptWitnessRequirements (LedgerEra era) +collectTxBodyScriptWitnessRequirements + TxBodyContent + { txIns + , txInsReference + , txOuts + , txCertificates + , txMintValue + , txWithdrawals + , txVotingProcedures + , txProposalProcedures + } = obtainCommonConstraints (useEra @era) $ do + let supplementaldatums = + TxScriptWitnessRequirements + mempty + mempty + (getDatums txInsReference txOuts) + mempty + + let txInWits = + obtainMonoidConstraint (useEra @era) getTxScriptWitnessesRequirements $ + extractWitnessableTxIns txIns + txWithdrawalWits = + obtainMonoidConstraint (useEra @era) getTxScriptWitnessesRequirements $ + extractWitnessableWithdrawals txWithdrawals + txCertWits = + obtainMonoidConstraint (useEra @era) getTxScriptWitnessesRequirements $ + extractWitnessableCertificates txCertificates + txMintWits = + obtainMonoidConstraint (useEra @era) getTxScriptWitnessesRequirements $ + extractWitnessableMints txMintValue + txVotingWits = + obtainMonoidConstraint (useEra @era) getTxScriptWitnessesRequirements $ + extractWitnessableVotes txVotingProcedures + txProposalWits = + obtainMonoidConstraint (useEra @era) getTxScriptWitnessesRequirements $ + extractWitnessableProposals txProposalProcedures + + obtainMonoidConstraint (useEra @era) $ + mconcat + [ supplementaldatums + , txInWits + , txWithdrawalWits + , txCertWits + , txMintWits + , txVotingWits + , txProposalWits + ] + +obtainMonoidConstraint + :: Era era + -> (Monoid (TxScriptWitnessRequirements (LedgerEra era)) => a) + -> a +obtainMonoidConstraint eon = case eon of + ConwayEra -> id + DijkstraEra -> id + +-- | Extract datum: +-- 1. supplemental datums from transaction outputs +-- 2. datums from reference inputs +-- +-- Note that this function does not check whose datum hashes are present in the reference inputs. This means if there +-- are redundant datums in 'TxInsReference', a submission of such transaction will fail. +getDatums + :: forall era + . IsEra era + => TxInsReference (LedgerEra era) + -- ^ reference inputs + -> [TxOut CtxTx (LedgerEra era)] + -> L.TxDats (LedgerEra era) +getDatums txInsRef txOutsFromTx = do + let TxInsReference _ datumSet = txInsRef + refInDatums = mapMaybe extractDatumsAndHashes $ Set.toList datumSet + -- use only supplemental datum + txOutsDats = + [(h, d) | TxOut _ (Just (TxOutSupplementalDatum h d)) <- txOutsFromTx] + :: [(L.DataHash, L.Data (LedgerEra era))] + obtainCommonConstraints (useEra @era) $ + L.TxDats $ + fromList $ + refInDatums <> txOutsDats + +-- Getters and Setters + +setTxAuxScripts :: [SimpleScript era] -> TxBodyContent era -> TxBodyContent era +setTxAuxScripts v txBodyContent = txBodyContent{txAuxScripts = v} + +setTxExtraKeyWits :: TxExtraKeyWitnesses -> TxBodyContent era -> TxBodyContent era +setTxExtraKeyWits v txBodyContent = txBodyContent{txExtraKeyWits = v} + +setTxIns :: [(TxIn, AnyWitness era)] -> TxBodyContent era -> TxBodyContent era +setTxIns v txBodyContent = txBodyContent{txIns = v} + +setTxInsCollateral :: [TxIn] -> TxBodyContent era -> TxBodyContent era +setTxInsCollateral v txBodyContent = txBodyContent{txInsCollateral = v} + +setTxInsReference :: TxInsReference era -> TxBodyContent era -> TxBodyContent era +setTxInsReference v txBodyContent = txBodyContent{txInsReference = v} + +setTxProtocolParams :: L.PParams era -> TxBodyContent era -> TxBodyContent era +setTxProtocolParams v txBodyContent = txBodyContent{txProtocolParams = Just v} + +setTxCollateral :: TxCollateral era -> TxBodyContent era -> TxBodyContent era +setTxCollateral v txBodyContent = txBodyContent{txCollateral = Just v} + +setTxValidityLowerBound :: L.SlotNo -> TxBodyContent era -> TxBodyContent era +setTxValidityLowerBound v txBodyContent = txBodyContent{txValidityLowerBound = Just v} + +setTxValidityUpperBound :: L.SlotNo -> TxBodyContent era -> TxBodyContent era +setTxValidityUpperBound v txBodyContent = txBodyContent{txValidityUpperBound = Just v} + +setTxMetadata :: TxMetadata -> TxBodyContent era -> TxBodyContent era +setTxMetadata v txBodyContent = txBodyContent{txMetadata = v} + +setTxFee :: L.Coin -> TxBodyContent era -> TxBodyContent era +setTxFee v txBodyContent = txBodyContent{txFee = v} + +setTxOuts :: [TxOut CtxTx era] -> TxBodyContent era -> TxBodyContent era +setTxOuts v txBodyContent = txBodyContent{txOuts = v} + +setTxMintValue :: TxMintValue era -> TxBodyContent era -> TxBodyContent era +setTxMintValue v txBodyContent = txBodyContent{txMintValue = v} + +setTxScriptValidity :: ScriptValidity -> TxBodyContent era -> TxBodyContent era +setTxScriptValidity v txBodyContent = txBodyContent{txScriptValidity = v} + +setTxCertificates :: TxCertificates era -> TxBodyContent era -> TxBodyContent era +setTxCertificates v txBodyContent = txBodyContent{txCertificates = v} + +setTxWithdrawals :: TxWithdrawals era -> TxBodyContent era -> TxBodyContent era +setTxWithdrawals v txBodyContent = txBodyContent{txWithdrawals = v} + +setTxVotingProcedures :: TxVotingProcedures era -> TxBodyContent era -> TxBodyContent era +setTxVotingProcedures v txBodyContent = txBodyContent{txVotingProcedures = Just v} + +setTxProposalProcedures :: TxProposalProcedures era -> TxBodyContent era -> TxBodyContent era +setTxProposalProcedures v txBodyContent = txBodyContent{txProposalProcedures = Just v} + +setTxCurrentTreasuryValue :: L.Coin -> TxBodyContent era -> TxBodyContent era +setTxCurrentTreasuryValue v txBodyContent = txBodyContent{txCurrentTreasuryValue = Just v} + +setTxTreasuryDonation :: L.Coin -> TxBodyContent era -> TxBodyContent era +setTxTreasuryDonation v txBodyContent = txBodyContent{txTreasuryDonation = Just v} diff --git a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Compatible.hs b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Compatible.hs deleted file mode 100644 index c6e248828d..0000000000 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Compatible.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} - -module Cardano.Api.Experimental.Tx.Internal.Compatible - ( mkTxCertificates - ) -where - -import Cardano.Api.Address qualified as Api -import Cardano.Api.Era.Internal.Eon.Convert -import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra -import Cardano.Api.Experimental.Era -import Cardano.Api.Experimental.Plutus.Internal.Script qualified as Exp -import Cardano.Api.Experimental.Plutus.Internal.ScriptWitness qualified as Exp -import Cardano.Api.Experimental.Simple.Script qualified as Exp -import Cardano.Api.Experimental.Tx.Internal.AnyWitness -import Cardano.Api.Experimental.Tx.Internal.Certificate qualified as Exp -import Cardano.Api.Experimental.Tx.Internal.Certificate.Compatible qualified as Api -import Cardano.Api.Ledger.Internal.Reexport qualified as L -import Cardano.Api.Plutus.Internal.Script (fromAllegraTimelock, sbeToSimpleScriptLanguageInEra) -import Cardano.Api.Plutus.Internal.Script qualified as Api -import Cardano.Api.Tx.Internal.Body (TxCertificates (..)) -import Cardano.Api.Tx.Internal.Body qualified as Api - -import Cardano.Ledger.Allegra.Scripts qualified as L -import Cardano.Ledger.Alonzo.Scripts qualified as L -import Cardano.Ledger.Plutus.Language qualified as L -import Cardano.Ledger.Plutus.Language qualified as Plutus - -import GHC.Exts (IsList (..)) - -mkTxCertificates - :: forall era - . IsEra era - => [(Exp.Certificate (ShelleyLedgerEra era), AnyWitness (LedgerEra era))] - -> Api.TxCertificates Api.BuildTx era -mkTxCertificates [] = TxCertificatesNone -mkTxCertificates certs = - TxCertificates (convert useEra) $ fromList $ map (getStakeCred useEra) certs - where - getStakeCred - :: Era era - -> (Exp.Certificate (ShelleyLedgerEra era), AnyWitness (LedgerEra era)) - -> ( Exp.Certificate (ShelleyLedgerEra era) - , Api.BuildTxWith - Api.BuildTx - (Maybe (Api.StakeCredential, Api.Witness Api.WitCtxStake era)) - ) - getStakeCred era (cert, witness) = - case era of - ConwayEra -> do - let Exp.Certificate c = cert - mStakeCred = Api.getTxCertWitness (convert era) c - wit = - case witness of - AnyKeyWitnessPlaceholder -> Api.KeyWitness Api.KeyWitnessForStakeAddr - AnySimpleScriptWitness ss -> - Api.ScriptWitness Api.ScriptWitnessForStakeAddr $ newToOldSimpleScriptWitness era ss - AnyPlutusScriptWitness psw -> - Api.ScriptWitness Api.ScriptWitnessForStakeAddr $ - newToOldPlutusCertificateScriptWitness ConwayEra psw - (cert, pure $ (,wit) <$> mStakeCred) - DijkstraEra -> do - let Exp.Certificate c = cert - mStakeCred = Api.getTxCertWitness (convert era) c - wit = - case witness of - AnyKeyWitnessPlaceholder -> Api.KeyWitness Api.KeyWitnessForStakeAddr - AnySimpleScriptWitness ss -> - Api.ScriptWitness Api.ScriptWitnessForStakeAddr $ newToOldSimpleScriptWitness era ss - AnyPlutusScriptWitness psw -> - Api.ScriptWitness Api.ScriptWitnessForStakeAddr $ - newToOldPlutusCertificateScriptWitness DijkstraEra psw - (cert, pure $ (,wit) <$> mStakeCred) - -newToOldSimpleScriptWitness - :: L.AllegraEraScript (LedgerEra era) - => Era era -> Exp.SimpleScriptOrReferenceInput (LedgerEra era) -> Api.ScriptWitness Api.WitCtxStake era -newToOldSimpleScriptWitness era simple = - case simple of - Exp.SScript (Exp.SimpleScript script) -> - Api.SimpleScriptWitness - (sbeToSimpleScriptLanguageInEra $ convert era) - (Api.SScript $ fromAllegraTimelock script) - Exp.SReferenceScript inp -> - Api.SimpleScriptWitness - (sbeToSimpleScriptLanguageInEra $ convert era) - (Api.SReferenceScript inp) - -newToOldPlutusCertificateScriptWitness - :: Era era - -> Exp.PlutusScriptWitness lang purpose (LedgerEra era) - -> Api.ScriptWitness Api.WitCtxStake era -newToOldPlutusCertificateScriptWitness ConwayEra (Exp.PlutusScriptWitness Plutus.SPlutusV1 scriptOrRef _ redeemer execUnits) = - Api.PlutusScriptWitness - Api.PlutusScriptV1InConway - Api.PlutusScriptV1 - (newToOldPlutusScriptOrReferenceInput scriptOrRef) - Api.NoScriptDatumForStake - redeemer - execUnits -newToOldPlutusCertificateScriptWitness ConwayEra (Exp.PlutusScriptWitness Plutus.SPlutusV2 scriptOrRef _ redeemer execUnits) = - Api.PlutusScriptWitness - Api.PlutusScriptV2InConway - Api.PlutusScriptV2 - (newToOldPlutusScriptOrReferenceInput scriptOrRef) - Api.NoScriptDatumForStake - redeemer - execUnits -newToOldPlutusCertificateScriptWitness ConwayEra (Exp.PlutusScriptWitness Plutus.SPlutusV3 scriptOrRef _ redeemer execUnits) = - Api.PlutusScriptWitness - Api.PlutusScriptV3InConway - Api.PlutusScriptV3 - (newToOldPlutusScriptOrReferenceInput scriptOrRef) - Api.NoScriptDatumForStake - redeemer - execUnits -newToOldPlutusCertificateScriptWitness ConwayEra (Exp.PlutusScriptWitness Plutus.SPlutusV4 _ _ _ _) = - error "newToOldPlutusCertificateScriptWitness: PlutusV4 script not possible in Conway era" -newToOldPlutusCertificateScriptWitness DijkstraEra (Exp.PlutusScriptWitness Plutus.SPlutusV1 scriptOrRef _ redeemer execUnits) = - Api.PlutusScriptWitness - Api.PlutusScriptV1InDijkstra - Api.PlutusScriptV1 - (newToOldPlutusScriptOrReferenceInput scriptOrRef) - Api.NoScriptDatumForStake - redeemer - execUnits -newToOldPlutusCertificateScriptWitness DijkstraEra (Exp.PlutusScriptWitness Plutus.SPlutusV2 scriptOrRef _ redeemer execUnits) = - Api.PlutusScriptWitness - Api.PlutusScriptV2InDijkstra - Api.PlutusScriptV2 - (newToOldPlutusScriptOrReferenceInput scriptOrRef) - Api.NoScriptDatumForStake - redeemer - execUnits -newToOldPlutusCertificateScriptWitness DijkstraEra (Exp.PlutusScriptWitness Plutus.SPlutusV3 scriptOrRef _ redeemer execUnits) = - Api.PlutusScriptWitness - Api.PlutusScriptV3InDijkstra - Api.PlutusScriptV3 - (newToOldPlutusScriptOrReferenceInput scriptOrRef) - Api.NoScriptDatumForStake - redeemer - execUnits -newToOldPlutusCertificateScriptWitness DijkstraEra (Exp.PlutusScriptWitness Plutus.SPlutusV4 scriptOrRef _ redeemer execUnits) = - Api.PlutusScriptWitness - Api.PlutusScriptV4InDijkstra - Api.PlutusScriptV4 - (newToOldPlutusScriptOrReferenceInput scriptOrRef) - Api.NoScriptDatumForStake - redeemer - execUnits - -newToOldPlutusScriptOrReferenceInput - :: Exp.PlutusScriptOrReferenceInput lang (LedgerEra era) - -> Api.PlutusScriptOrReferenceInput oldlang -newToOldPlutusScriptOrReferenceInput (Exp.PReferenceScript txin) = Api.PReferenceScript txin -newToOldPlutusScriptOrReferenceInput (Exp.PScript (Exp.PlutusScriptInEra plutusRunnable)) = - let oldScript = L.unPlutusBinary . L.plutusBinary $ L.plutusFromRunnable plutusRunnable - in Api.PScript $ Api.PlutusScriptSerialised oldScript diff --git a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Fee.hs b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Fee.hs index 25709fc88c..e575cce5e5 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Fee.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Fee.hs @@ -1,35 +1,101 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} module Cardano.Api.Experimental.Tx.Internal.Fee - ( estimateBalancedTxBody + ( collectTxBodyScriptWitnesses + , estimateBalancedTxBody + , evaluateTransactionFee ) where import Cardano.Api.Address import Cardano.Api.Certificate.Internal import Cardano.Api.Era.Internal.Eon.Convert +import Cardano.Api.Experimental.AnyScriptWitness +import Cardano.Api.Experimental.AnyScriptWitness qualified as Exp import Cardano.Api.Experimental.Era +import Cardano.Api.Experimental.Tx.Internal.AnyWitness +import Cardano.Api.Experimental.Tx.Internal.BodyContent.New +import Cardano.Api.Experimental.Tx.Internal.Certificate qualified as Exp +import Cardano.Api.Experimental.Tx.Internal.Type +import Cardano.Api.Key.Internal qualified as Api import Cardano.Api.Ledger.Internal.Reexport qualified as L -import Cardano.Api.Plutus +import Cardano.Api.ProtocolParameters import Cardano.Api.Tx.Internal.Body -import Cardano.Api.Tx.Internal.Fee qualified as Fee + ( CtxTx + , ScriptWitnessIndex (..) + , toScriptIndex + ) +import Cardano.Api.Tx.Internal.TxIn import Cardano.Api.Value.Internal import Cardano.Ledger.Alonzo.Core qualified as Ledger +import Cardano.Ledger.Api qualified as L +import Cardano.Ledger.Coin qualified as L +import Cardano.Ledger.Conway.Governance qualified as L import Cardano.Ledger.Credential as Ledger (Credential) +import Cardano.Ledger.State qualified as L +import Cardano.Ledger.Val qualified as L +import Data.Bifunctor +import Data.Function (on, (&)) +import Data.List (sortBy) +import Data.List qualified as List +import Data.Map.Ordered () +import Data.Map.Ordered.Strict qualified as OMap import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Maybe +import Data.OSet.Strict qualified as OSet +import Data.Ratio import Data.Set (Set) +import Data.Set qualified as Set +import GHC.Exts (IsList (..)) import GHC.Stack +import Lens.Micro ((.~), (^.)) + +data TxBodyErrorAutoBalance era + = -- | There is not enough ada and non-ada to cover both the outputs and the fees. + -- The transaction should be changed to provide more input assets, or + -- otherwise adjusted to need less (e.g. outputs, script etc). + TxBodyErrorBalanceNegative L.Coin L.MultiAsset + | -- | There is enough ada to cover both the outputs and the fees, but the + -- resulting change is too small: it is under the minimum value for + -- new UTXO entries. The transaction should be changed to provide more + -- input ada. + TxBodyErrorAdaBalanceTooSmall + (TxOut CtxTx era) + -- ^ Offending TxOut + L.Coin + -- ^ Minimum UTxO + L.Coin + -- ^ Tx balance + | -- | The minimum spendable UTxO threshold has not been met. + TxBodyErrorMinUTxONotMet + (TxOut CtxTx era) + -- ^ Offending TxOut + L.Coin + -- ^ Minimum UTXO + | TxBodyErrorNonAdaAssetsUnbalanced Value + | TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap + ScriptWitnessIndex + (Map ScriptWitnessIndex ExecutionUnits) + deriving Show -- | Use when you do not have access to the UTxOs you intend to spend estimateBalancedTxBody :: HasCallStack => Era era - -> TxBodyContent BuildTx era + -> TxBodyContent (LedgerEra era) -> L.PParams (LedgerEra era) -> Set PoolId -- ^ The set of registered stake pools, being @@ -52,9 +118,9 @@ estimateBalancedTxBody -- ^ The size of all reference scripts in bytes. -> AddressInEra era -- ^ Change address. - -> Value + -> L.Value (LedgerEra era) -- ^ Total value of UTXOs being spent. - -> Either (Fee.TxFeeEstimationError era) (Fee.BalancedTxBody era) + -> Either (TxFeeEstimationError era) (TxBodyContent (LedgerEra era)) estimateBalancedTxBody w txbodycontent @@ -64,11 +130,811 @@ estimateBalancedTxBody drepDelegDeposits exUnitsMap = obtainCommonConstraints w $ - Fee.estimateBalancedTxBody - (convert w) + estimateBalancedTxBody' txbodycontent pparams poolids stakeDelegDeposits drepDelegDeposits (Map.mapKeys (toScriptIndex (convert w)) exUnitsMap) + +data TxFeeEstimationError era + = TxFeeEstimationScriptExecutionError (TxBodyErrorAutoBalance era) + | TxFeeEstimationBalanceError (TxBodyErrorAutoBalance (LedgerEra era)) + deriving Show + +-- | Use when you do not have access to the UTxOs you intend to spend +estimateBalancedTxBody' + :: forall era + . HasCallStack + => IsEra era + => TxBodyContent (LedgerEra era) + -> L.PParams (LedgerEra era) + -> Set PoolId + -- ^ The set of registered stake pools, being + -- unregistered in this transaction. + -> Map StakeCredential L.Coin + -- ^ A map of all deposits for stake credentials that are being + -- unregistered in this transaction. + -> Map (Ledger.Credential Ledger.DRepRole) L.Coin + -- ^ A map of all deposits for DRep credentials that are being + -- unregistered in this transaction. + -> Map ScriptWitnessIndex ExecutionUnits + -- ^ Plutus script execution units. + -> Coin + -- ^ Total potential collateral amount. + -> Int + -- ^ The number of key witnesses to be added to the transaction. + -> Int + -- ^ The number of Byron key witnesses to be added to the transaction. + -> Int + -- ^ The size of all reference scripts in bytes. + -> AddressInEra era + -- ^ Change address. + -> L.MaryValue + -- ^ Total value of UTXOs being spent. + -> Either (TxFeeEstimationError era) (TxBodyContent (LedgerEra era)) +estimateBalancedTxBody' + txbodycontent + pparams + poolids + stakeDelegDeposits + drepDelegDeposits + exUnitsMap + totalPotentialCollateral + intendedKeyWits + byronwits + sizeOfAllReferenceScripts + changeaddr + totalUTxOValue = do + -- Step 1. Substitute those execution units into the tx + + txbodycontent1 <- + first TxFeeEstimationScriptExecutionError $ + substituteExecutionUnits exUnitsMap txbodycontent + + -- Step 2. We need to calculate the current balance of the tx. The user + -- must at least provide the total value of the UTxOs they intend to spend + -- for us to calulate the balance. NB: We must: + -- 1. Subtract certificate and proposal deposits + -- from the total available Ada value! + -- Page 24 Shelley ledger spec + let certificates :: [L.TxCert (LedgerEra era)] = + [ cert + | (Exp.Certificate cert, _) <- toList . unTxCertificates $ txCertificates txbodycontent1 + ] + + proposalProcedures :: OSet.OSet (L.ProposalProcedure (LedgerEra era)) + proposalProcedures = + convProposalProcedures $ txProposalProcedures txbodycontent1 + + totalDeposits :: L.Coin + totalDeposits = + -- Because we do not have access to the ledger state and to reduce the complexity of this function's + -- type signature, we assume the user is trying to register a stake pool that has not been + -- registered before and has not included duplicate stake pool registration certificates. + let assumeStakePoolHasNotBeenRegistered = const False + in sum + [ obtainCommonConstraints (useEra @era) $ + L.getTotalDepositsTxCerts pparams assumeStakePoolHasNotBeenRegistered certificates + , obtainCommonConstraints (useEra @era) $ + mconcat $ + map (^. L.pProcDepositL) $ + toList proposalProcedures + ] + availableUTxOValue :: L.MaryValue + availableUTxOValue = totalUTxOValue L.<+> L.inject totalDeposits + + let + partialChange = + calculatePartialChangeValue availableUTxOValue txbodycontent1 + maxLovelaceChange = L.Coin (2 ^ (64 :: Integer)) - 1 + changeWithMaxLovelace = L.modifyCoin (const maxLovelaceChange) partialChange + changeTxOut :: L.TxOut (LedgerEra era) + changeTxOut = + obtainCommonConstraints (useEra @era) $ + L.mkBasicTxOut (toShelleyAddr changeaddr) changeWithMaxLovelace + + let mDummyCollateral = maybeDummyTotalCollAndCollReturnOutput txbodycontent changeaddr + + -- Step 3. Create a tx body with out max lovelace fee. This is strictly for + -- calculating our fee with evaluateTransactionFee. + let maxLovelaceFee = L.Coin (2 ^ (32 :: Integer) - 1) + let txbody1ForFeeEstimateOnly = + makeUnsignedTx + useEra + txbodycontent1 + { txFee = maxLovelaceFee + , txOuts = + obtainCommonConstraints (useEra @era) (TxOut changeTxOut Nothing) + : txOuts txbodycontent + , txCollateral = mDummyCollateral + } + let fee = + evaluateTransactionFee + pparams + txbody1ForFeeEstimateOnly + (fromIntegral intendedKeyWits) + (fromIntegral byronwits) + sizeOfAllReferenceScripts + + -- Step 4. We use the fee to calculate the required collateral + maybeTxCollateral = + obtainCommonConstraints (useEra @era) $ + calcReturnAndTotalCollateral + fee + pparams + (txInsCollateral txbodycontent) + (txCollateral txbodycontent) + changeaddr + (L.inject totalPotentialCollateral) + + -- Step 5. Now we can calculate the balance of the tx. What matter here are: + -- 1. The original outputs + -- 2. Tx fee + -- 3. Return and total collateral + let txbody2 = + makeUnsignedTx + useEra + txbodycontent1 + { txFee = fee + , txCollateral = maybeTxCollateral + } + + let fakeUTxO = createFakeUTxO txbodycontent1 $ L.coin availableUTxOValue + balance :: Ledger.Value (LedgerEra era) = + evaluateTransactionBalance pparams poolids stakeDelegDeposits drepDelegDeposits fakeUTxO txbody2 + balanceTxOut :: TxOut CtxTx (LedgerEra era) + balanceTxOut = + obtainCommonConstraints (useEra @era) $ + TxOut (L.mkBasicTxOut (toShelleyAddr changeaddr) balance) Nothing + + -- Step 6. Check all txouts have the min required UTxO value + -- TOOD: Fix me. You need a new error type to accomodate your new types + first (TxFeeEstimationBalanceError . uncurry TxBodyErrorMinUTxONotMet) + . mapM_ (checkMinUTxOValue pparams) + $ txOuts txbodycontent1 + + -- check if the balance is positive or negative + -- in one case we can produce change, in the other the inputs are insufficient + finalTxOuts <- + first TxFeeEstimationBalanceError $ + checkAndIncludeChange pparams balanceTxOut (txOuts txbodycontent1) + + -- Step 7. + + -- Create the txbody with the final fee and change output. This should work + -- provided that the fee and change are less than 2^32-1, and so will + -- fit within the encoding size we picked above when calculating the fee. + -- Yes this could be an over-estimate by a few bytes if the fee or change + -- would fit within 2^16-1. That's a possible optimisation. + let finalTxBodyContent = + txbodycontent1 + { txFee = fee + , txOuts = finalTxOuts + , txCollateral = maybeTxCollateral + } + + return finalTxBodyContent + +data IsEmpty = Empty | NonEmpty + deriving (Eq, Show) + +checkNonNegative + :: forall era + . IsEra era + => Ledger.PParams (LedgerEra era) + -> TxOut CtxTx (LedgerEra era) + -> Either (TxBodyErrorAutoBalance (LedgerEra era)) IsEmpty + -- ^ result of check if txout is empty +checkNonNegative bpparams txout@(TxOut balance _) = do + let outValue@(L.MaryValue coin multiAsset) = balance ^. obtainCommonConstraints (useEra @era) L.valueTxOutL + isPositiveValue = L.pointwise (>) outValue mempty + if + | L.isZero outValue -> pure Empty -- empty TxOut - ok, it's removed at the end + | L.isZero coin -> + -- no ADA, just non-ADA assets: positive lovelace is required in such case + Left $ + TxBodyErrorAdaBalanceTooSmall + txout + (calculateMinimumUTxO bpparams txout) + coin + | not isPositiveValue -> Left $ TxBodyErrorBalanceNegative coin multiAsset + | otherwise -> pure NonEmpty + +-- | In the event of spending the exact amount of lovelace and non-ada assets in +-- the specified input(s), this function excludes the change +-- output. Note that this does not save any fees because by default +-- the fee calculation includes a change address for simplicity and +-- we make no attempt to recalculate the tx fee without a change address. +checkAndIncludeChange + :: forall era + . IsEra era + => Ledger.PParams (LedgerEra era) + -> TxOut CtxTx (LedgerEra era) + -> [TxOut CtxTx (LedgerEra era)] + -> Either (TxBodyErrorAutoBalance (LedgerEra era)) [TxOut CtxTx (LedgerEra era)] +checkAndIncludeChange pp change@(TxOut changeOutput _) rest = do + isChangeEmpty <- checkNonNegative pp change + if isChangeEmpty == Empty + then pure rest + else do + let coin = changeOutput ^. L.coinTxOutL + first ((coin &) . uncurry TxBodyErrorAdaBalanceTooSmall) $ + checkMinUTxOValue pp change + -- We append change at the end so a client can predict the indexes of the outputs. + pure $ rest <> [change] + +checkMinUTxOValue + :: Ledger.PParams (LedgerEra era) + -> TxOut CtxTx (LedgerEra era) + -> Either (TxOut CtxTx (LedgerEra era), Coin) () + -- ^ @Left (offending txout, minimum required utxo)@ or @Right ()@ when txout is ok +checkMinUTxOValue bpp txout@(TxOut out _) = do + let minUTxO = calculateMinimumUTxO bpp txout + if out ^. L.coinTxOutL >= minUTxO + then Right () + else Left (txout, minUTxO) + +calculateMinimumUTxO + :: HasCallStack + => Ledger.PParams (LedgerEra era) + -> TxOut CtxTx (LedgerEra era) + -> L.Coin +calculateMinimumUTxO pp (TxOut txout _) = + let txOutWithMinCoin = L.setMinCoinTxOut pp txout + in txOutWithMinCoin ^. L.coinTxOutL + +-- | Compute the total balance of the proposed transaction. Ultimately, a valid +-- transaction must be fully balanced, which means that it has a total value +-- of zero. +-- +-- Finding the (non-zero) balance of a partially constructed transaction is +-- useful for adjusting a transaction to be fully balanced. +evaluateTransactionBalance + :: forall era + . IsEra era + => Ledger.PParams (LedgerEra era) + -> Set PoolId + -> Map StakeCredential L.Coin + -> Map (Ledger.Credential Ledger.DRepRole) L.Coin + -> L.UTxO (LedgerEra era) + -> UnsignedTx era + -> L.Value (LedgerEra era) +evaluateTransactionBalance pp poolids stakeDelegDeposits drepDelegDeposits utxo (UnsignedTx unsignedTx) = + let txbody = unsignedTx ^. L.bodyTxL + in obtainCommonConstraints (useEra @era) $ + L.evalBalanceTxBody + pp + lookupDelegDeposit + lookupDRepDeposit + isRegPool + utxo + txbody + where + isRegPool :: Ledger.KeyHash Ledger.StakePool -> Bool + isRegPool kh = Api.StakePoolKeyHash kh `Set.member` poolids + + lookupDelegDeposit + :: Ledger.Credential 'Ledger.Staking -> Maybe L.Coin + lookupDelegDeposit stakeCred = + Map.lookup (fromShelleyStakeCredential stakeCred) stakeDelegDeposits + + lookupDRepDeposit + :: Ledger.Credential 'Ledger.DRepRole -> Maybe L.Coin + lookupDRepDeposit drepCred = + Map.lookup drepCred drepDelegDeposits + +-- | This is used in the balance calculation in the event where +-- the user does not supply the UTxO(s) they intend to spend +-- but they must supply their total balance of ADA. +-- evaluateTransactionBalance calls evalBalanceTxBody which requires a UTxO value. +-- This eventually calls getConsumedMaryValue which retrieves the balance +-- from the transaction itself. This necessitated a function to create a "fake" UTxO +-- to still use evalBalanceTxBody however this will fail for transactions +-- containing multi-assets, refunds and withdrawals. +-- TODO: Include multiassets +createFakeUTxO :: TxBodyContent era -> Coin -> L.UTxO era +createFakeUTxO txbodycontent totalAdaInUTxO = + let singleTxIn = maybe [] (return . toShelleyTxIn . fst) $ List.uncons [txin | (txin, _) <- txIns txbodycontent] + singleTxOut = + maybe [] (\(TxOut firstOut _, _rest) -> return $ firstOut & L.coinTxOutL .~ totalAdaInUTxO) $ + List.uncons $ + txOuts txbodycontent + in -- Take one txin and one txout. Replace the out value with totalAdaInUTxO + -- Return an empty UTxO if there are no txins or txouts + L.UTxO $ fromList $ zip singleTxIn singleTxOut + +-- Calculation taken from validateInsufficientCollateral: +-- https://github.com/input-output-hk/cardano-ledger/blob/389b266d6226dedf3d2aec7af640b3ca4984c5ea/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs#L335 +-- TODO: Bug Jared to expose a function from the ledger that returns total and +-- return collateral. +calcReturnAndTotalCollateral + :: forall era + . Ledger.AlonzoEraPParams (LedgerEra era) + => IsEra era + => L.Coin + -- ^ Fee + -> Ledger.PParams (LedgerEra era) + -> [TxIn] + -- ^ Collateral inputs the initial TxBodyContent + -> Maybe (TxCollateral (LedgerEra era)) + -- ^ From the initial TxBodyContent + -> AddressInEra era + -- ^ Change address + -> L.MaryValue + -- ^ Total available collateral (can include non-ada) + -> Maybe (TxCollateral (LedgerEra era)) +calcReturnAndTotalCollateral _ _ [] _ _ _ = Nothing +calcReturnAndTotalCollateral fee pp' _ mTxCollateral cAddr totalAvailableCollateral = do + let colPerc = pp' ^. Ledger.ppCollateralPercentageL + -- We must first figure out how much lovelace we have committed + -- as collateral and we must determine if we have enough lovelace at our + -- collateral tx inputs to cover the tx + totalCollateralLovelace = obtainCommonConstraints (useEra @era) $ L.coin totalAvailableCollateral + requiredCollateral@(L.Coin reqAmt) = fromIntegral colPerc * fee + totalCollateral = + L.rationalToCoinViaCeiling $ + reqAmt % 100 + -- Why * 100? requiredCollateral is the product of the collateral percentage and the tx fee + -- We choose to multiply 100 rather than divide by 100 to make the calculation + -- easier to manage. At the end of the calculation we then use % 100 to perform our division + -- and round the returnCollateral down which has the effect of potentially slightly + -- overestimating the required collateral. + L.Coin returnCollateralAmount = totalCollateralLovelace * 100 - requiredCollateral + returnAdaCollateral = L.inject $ L.rationalToCoinViaFloor $ returnCollateralAmount % 100 + -- non-ada collateral is not used, so just return it as is in the return collateral output + nonAdaCollateral = L.modifyCoin (const mempty) totalAvailableCollateral + returnCollateral = returnAdaCollateral <> nonAdaCollateral + case mTxCollateral of + Just (TxCollateral{}) -> mTxCollateral + Nothing + | returnCollateralAmount < 0 -> + Nothing + | otherwise -> + Just $ + TxCollateral + { totalCollateral = totalCollateral + , returnCollateral = + obtainCommonConstraints (useEra @era) $ L.mkBasicTxOut (toShelleyAddr cAddr) returnCollateral + } + +-- case (txReturnCollateral, txTotalCollateral) of +-- (rc@TxReturnCollateral{}, tc@TxTotalCollateral{}) -> +-- (rc, tc) +-- (rc@TxReturnCollateral{}, TxTotalCollateralNone) -> +-- (rc, TxTotalCollateralNone) +-- (TxReturnCollateralNone, tc@TxTotalCollateral{}) -> +-- (TxReturnCollateralNone, tc) +-- (TxReturnCollateralNone, TxTotalCollateralNone) +-- | returnCollateralAmount < 0 -> +-- (TxReturnCollateralNone, TxTotalCollateralNone) +-- | otherwise -> +-- ( TxReturnCollateral +-- w +-- ( TxOut +-- cAddr +-- (TxOutValueShelleyBased sbe returnCollateral) +-- TxOutDatumNone +-- ReferenceScriptNone +-- ) +-- , totalCollateral +-- ) + +-- | Transaction fees can be computed for a proposed transaction based on the +-- expected number of key witnesses (i.e. signatures). +-- +-- When possible, use 'calculateMinTxFee', as it provides a more accurate +-- estimate: +evaluateTransactionFee + :: Ledger.PParams (LedgerEra era) + -> UnsignedTx era + -> Word + -- ^ The number of Shelley key witnesses + -> Word + -- ^ The number of Byron key witnesses + -> Int + -- ^ Reference script size in bytes + -> L.Coin +evaluateTransactionFee pp (UnsignedTx tx) keywitcount byronwitcount refScriptsSize = + L.estimateMinFeeTx pp tx (fromIntegral keywitcount) (fromIntegral byronwitcount) refScriptsSize + +-- Essentially we check for the existence of collateral inputs. If they exist we +-- create a fictitious collateral return output. Why? Because we need to put dummy values +-- to get a fee estimate (i.e we overestimate the fee). The required collateral depends +-- on the tx fee as per the Alonzo spec. +maybeDummyTotalCollAndCollReturnOutput + :: forall era + . IsEra era + => TxBodyContent (LedgerEra era) + -> AddressInEra era + -> Maybe (TxCollateral (LedgerEra era)) +maybeDummyTotalCollAndCollReturnOutput TxBodyContent{txInsCollateral, txCollateral} cAddr = + if null txInsCollateral + then Nothing + else + let dummyRetCol = + obtainCommonConstraints (useEra @era) $ + L.mkBasicTxOut (toShelleyAddr cAddr) (L.inject $ L.Coin (2 ^ (64 :: Integer)) - 1) + + dummyTotCol = L.Coin (2 ^ (32 :: Integer) - 1) + in case txCollateral of + Just col -> Just col + Nothing -> + return $ + TxCollateral + { returnCollateral = dummyRetCol + , totalCollateral = dummyTotCol + } + +-- | Calculate the partial change - this does not include certificates' deposits +calculatePartialChangeValue + :: forall era + . IsEra era + => L.MaryValue + -> TxBodyContent (LedgerEra era) + -> L.MaryValue +calculatePartialChangeValue incoming txbodycontent = do + let outgoing = newUtxoValue + mintedValue = + mconcat + [ toMaryValue $ policyAssetsToValue pid pAssets + | (pid, (pAssets, _)) <- Map.toList . unTxMintValue $ txMintValue txbodycontent + ] + incoming L.<+> mintedValue L.<+> L.invert outgoing + where + newUtxoValue = + mconcat + [out ^. obtainCommonConstraints (useEra @era) L.valueTxOutL | (TxOut out _) <- txOuts txbodycontent] + +substituteExecutionUnits + :: forall era + . IsEra era + => Map ScriptWitnessIndex ExecutionUnits + -> TxBodyContent (LedgerEra era) + -> Either (TxBodyErrorAutoBalance era) (TxBodyContent (LedgerEra era)) +substituteExecutionUnits + exUnitsMap + txbodycontent@( TxBodyContent + txIns + _ + _ + _ + _ + _ + _ + _ + _ + _ + _ + _ + txWithdrawals + txCertificates + txMintValue + _ + txProposalProcedures + txVotingProcedures + _ + _ + ) = do + mappedTxIns <- mapScriptWitnessesTxIns txIns + mappedWithdrawals <- mapScriptWitnessesWithdrawals txWithdrawals + mappedMintedVals <- mapScriptWitnessesMinting txMintValue + mappedTxCertificates <- mapScriptWitnessesCertificates txCertificates + mappedVotes <- mapScriptWitnessesVotes txVotingProcedures + mappedProposals <- mapScriptWitnessesProposals txProposalProcedures + + Right $ + txbodycontent + & setTxIns mappedTxIns + & setTxCertificates mappedTxCertificates + & setTxWithdrawals mappedWithdrawals + & setTxMintValue mappedMintedVals + & setTxVotingProcedures mappedVotes + & setTxProposalProcedures mappedProposals + where + substituteExecUnits + :: ScriptWitnessIndex + -> AnyWitness (LedgerEra era) + -> Either (TxBodyErrorAutoBalance era) (AnyWitness (LedgerEra era)) + substituteExecUnits _ w@AnyKeyWitnessPlaceholder = Right w + substituteExecUnits _ w@AnySimpleScriptWitness{} = Right w + substituteExecUnits idx (AnyPlutusScriptWitness psw) = + case Map.lookup idx exUnitsMap of + Nothing -> + Left $ TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap idx exUnitsMap + Just exunits -> + Right $ + AnyPlutusScriptWitness $ + updatePlutusScriptWitnessExecutionUnits exunits psw + + mapScriptWitnessesTxIns + :: [(TxIn, AnyWitness (LedgerEra era))] + -> Either (TxBodyErrorAutoBalance era) [(TxIn, AnyWitness (LedgerEra era))] + mapScriptWitnessesTxIns txins = + let mappedScriptWitnesses + :: [ ( TxIn + , Either (TxBodyErrorAutoBalance era) (AnyWitness (LedgerEra era)) + ) + ] + mappedScriptWitnesses = + [ (txin, wit') + | (ix, txin, wit) <- indexTxIns txins + , let wit' = substituteExecUnits ix wit + ] + in traverse + (\(txIn, eWitness) -> (txIn,) <$> eWitness) + mappedScriptWitnesses + + mapScriptWitnessesWithdrawals + :: TxWithdrawals (LedgerEra era) + -> Either (TxBodyErrorAutoBalance era) (TxWithdrawals (LedgerEra era)) + mapScriptWitnessesWithdrawals txWithdrawals'@(TxWithdrawals _) = + let mappedWithdrawals + :: [ ( StakeAddress + , L.Coin + , Either (TxBodyErrorAutoBalance era) (AnyWitness (LedgerEra era)) + ) + ] + mappedWithdrawals = + [ (addr, withdrawal, mappedWitness) + | (ix, addr, withdrawal, wit) <- indexTxWithdrawals txWithdrawals' + , let mappedWitness = substituteExecUnits ix wit + ] + in TxWithdrawals + <$> traverse + (\(sAddr, ll, eWitness) -> (sAddr,ll,) <$> eWitness) + mappedWithdrawals + + mapScriptWitnessesCertificates + :: TxCertificates (LedgerEra era) + -> Either (TxBodyErrorAutoBalance era) (TxCertificates (LedgerEra era)) + mapScriptWitnessesCertificates txCertificates' = do + let mappedScriptWitnesses + :: [ ( Exp.Certificate (LedgerEra era) + , Either + (TxBodyErrorAutoBalance era) + ( Maybe + ( StakeCredential + , AnyWitness (LedgerEra era) + ) + ) + ) + ] + mappedScriptWitnesses = + [ (cert, Just . (stakeCred,) <$> eWitness') + | (ix, cert, stakeCred, witness) <- indexTxCertificates txCertificates' + , let eWitness' = substituteExecUnits ix witness + ] + TxCertificates . fromList <$> traverseScriptWitnesses mappedScriptWitnesses + + mapScriptWitnessesMinting + :: TxMintValue (LedgerEra era) + -> Either (TxBodyErrorAutoBalance era) (TxMintValue (LedgerEra era)) + mapScriptWitnessesMinting txMintValue' = do + let mappedScriptWitnesses = + [ (policyId, (assets,) <$> substitutedWitness) + | (ix, policyId, assets, witness) <- indexTxMintValue txMintValue' + , let substitutedWitness = substituteExecUnits ix witness + ] + -- merge map values, wit1 == wit2 will always hold + mergeValues (assets1, wit1) (assets2, _wit2) = (assets1 <> assets2, wit1) + final <- Map.fromListWith mergeValues <$> traverseScriptWitnesses mappedScriptWitnesses + pure $ TxMintValue final + + mapScriptWitnessesVotes + :: Maybe (TxVotingProcedures (LedgerEra era)) + -> Either + (TxBodyErrorAutoBalance era) + (TxVotingProcedures (LedgerEra era)) + mapScriptWitnessesVotes Nothing = return $ TxVotingProcedures (L.VotingProcedures mempty) mempty + mapScriptWitnessesVotes (Just v@(TxVotingProcedures vProcedures _)) = do + let eSubstitutedExecutionUnits = + [ (vote, updatedWitness) + | (ix, vote, witness) <- indexTxVotingProcedures v + , let updatedWitness = substituteExecUnits ix witness + ] + + substitutedExecutionUnits <- traverseScriptWitnesses eSubstitutedExecutionUnits + + return + (TxVotingProcedures vProcedures (fromList substitutedExecutionUnits)) + + mapScriptWitnessesProposals + :: Maybe (TxProposalProcedures (LedgerEra era)) + -> Either + (TxBodyErrorAutoBalance era) + (TxProposalProcedures (LedgerEra era)) + mapScriptWitnessesProposals Nothing = return $ TxProposalProcedures OMap.empty + mapScriptWitnessesProposals (Just proposals) = do + let indexed = indexWitnessedTxProposalProcedures proposals + eSubstitutedExecutionUnits = + [ (p, updatedWit) + | (p, (i, anyWit)) <- indexed + , let updatedWit = substituteExecUnits i anyWit + ] + substitutedExecutionUnits <- traverseScriptWitnesses eSubstitutedExecutionUnits + pure $ + mkTxProposalProcedures substitutedExecutionUnits + +collectTxBodyScriptWitnesses + :: forall era + . IsEra era + => TxBodyContent (LedgerEra era) + -> [(ScriptWitnessIndex, Exp.AnyScriptWitness (LedgerEra era))] +collectTxBodyScriptWitnesses + TxBodyContent + { txIns + , txWithdrawals + , txCertificates + , txMintValue + , txVotingProcedures + , txProposalProcedures + } = + concat + [ scriptWitnessesTxIns txIns + , scriptWitnessesWithdrawals txWithdrawals + , scriptWitnessesCertificates txCertificates + , scriptWitnessesMinting txMintValue + , maybe [] scriptWitnessesVoting txVotingProcedures + , maybe [] scriptWitnessesProposing txProposalProcedures + ] + where + scriptWitnessesTxIns + :: [(TxIn, AnyWitness (LedgerEra era))] + -> [(ScriptWitnessIndex, Exp.AnyScriptWitness (LedgerEra era))] + scriptWitnessesTxIns txIns' = + List.nub + [ (ix, anyScriptWitness) + | (ix, _, Just anyScriptWitness) <- fmap toAnyScriptWitness <$> indexTxIns txIns' + ] + + scriptWitnessesWithdrawals + :: TxWithdrawals (LedgerEra era) + -> [(ScriptWitnessIndex, Exp.AnyScriptWitness (LedgerEra era))] + scriptWitnessesWithdrawals txw = + List.nub + [ (ix, anyScriptWitness) + | (ix, _, _, Just anyScriptWitness) <- fmap toAnyScriptWitness <$> indexTxWithdrawals txw + ] + + scriptWitnessesCertificates + :: TxCertificates (LedgerEra era) + -> [(ScriptWitnessIndex, Exp.AnyScriptWitness (LedgerEra era))] + scriptWitnessesCertificates txc = + List.nub + [ (ix, anyScriptWitness) + | (ix, _, _, Just anyScriptWitness) <- fmap toAnyScriptWitness <$> indexTxCertificates txc + ] + + scriptWitnessesMinting + :: TxMintValue (LedgerEra era) + -> [(ScriptWitnessIndex, Exp.AnyScriptWitness (LedgerEra era))] + scriptWitnessesMinting txMintValue' = + List.nub + [ (ix, anyScriptWitness) + | (ix, _, _, Just anyScriptWitness) <- fmap toAnyScriptWitness <$> indexTxMintValue txMintValue' + ] + + scriptWitnessesVoting + :: TxVotingProcedures (LedgerEra era) + -> [(ScriptWitnessIndex, Exp.AnyScriptWitness (LedgerEra era))] + scriptWitnessesVoting txv = + List.nub + [ (ix, anyScriptWitness) + | (ix, _, Just anyScriptWitness) <- fmap toAnyScriptWitness <$> indexTxVotingProcedures txv + ] + + scriptWitnessesProposing + :: TxProposalProcedures (LedgerEra era) + -> [(ScriptWitnessIndex, Exp.AnyScriptWitness (LedgerEra era))] + scriptWitnessesProposing txp = + List.nub + [ (ix, anyScriptWitness) + | (_, (ix, Just anyScriptWitness)) <- + (fmap . fmap) toAnyScriptWitness <$> indexWitnessedTxProposalProcedures txp + ] + +toAnyScriptWitness :: AnyWitness era -> Maybe (Exp.AnyScriptWitness era) +toAnyScriptWitness AnyKeyWitnessPlaceholder = Nothing +toAnyScriptWitness (AnySimpleScriptWitness ssw) = Just $ AnyScriptWitnessSimple ssw +toAnyScriptWitness (AnyPlutusScriptWitness psw) = Just $ AnyScriptWitnessPlutus psw + +traverseScriptWitnesses + :: [(a, Either (TxBodyErrorAutoBalance era) b)] + -> Either (TxBodyErrorAutoBalance era) [(a, b)] +traverseScriptWitnesses = + traverse (\(item, eRes) -> eRes >>= (\res -> Right (item, res))) + +-- | Index transaction inputs ordered by TxIn +-- Please note that the result can contain also 'KeyWitness'es. +-- See section 4.1 of https://github.com/intersectmbo/cardano-ledger/releases/latest/download/alonzo-ledger.pdf +indexTxIns + :: [(TxIn, AnyWitness (LedgerEra era))] + -> [(ScriptWitnessIndex, TxIn, AnyWitness (LedgerEra era))] +indexTxIns txins = + [ (ScriptWitnessIndexTxIn ix, txIn, witness) + | (ix, (txIn, witness)) <- zip [0 ..] $ orderTxIns txins + ] + where + -- This relies on the TxId Ord instance being consistent with the + -- Ledger.TxId Ord instance via the toShelleyTxId conversion + -- This is checked by prop_ord_distributive_TxId + orderTxIns :: [(TxIn, v)] -> [(TxIn, v)] + orderTxIns = sortBy (compare `on` fst) + +-- | Index the withdrawals with witnesses in the order of stake addresses. +-- See section 4.1 of https://github.com/intersectmbo/cardano-ledger/releases/latest/download/alonzo-ledger.pdf +indexTxWithdrawals + :: TxWithdrawals era + -> [(ScriptWitnessIndex, StakeAddress, L.Coin, AnyWitness era)] +indexTxWithdrawals (TxWithdrawals withdrawals) = + [ (ScriptWitnessIndexWithdrawal ix, addr, coin, witness) + | (ix, (addr, coin, witness)) <- zip [0 ..] (orderStakeAddrs withdrawals) + ] + where + -- This relies on the StakeAddress Ord instance being consistent with the + -- Shelley.RewardAcnt Ord instance via the toShelleyStakeAddr conversion + -- This is checked by prop_ord_distributive_StakeAddress + orderStakeAddrs :: [(StakeAddress, x, v)] -> [(StakeAddress, x, v)] + orderStakeAddrs = sortBy (compare `on` (\(k, _, _) -> k)) + +-- | Index certificates with witnesses by the order they appear in the list (in the transaction). +-- See section 4.1 of https://github.com/intersectmbo/cardano-ledger/releases/latest/download/alonzo-ledger.pdf +indexTxCertificates + :: TxCertificates (LedgerEra era) + -> [ ( ScriptWitnessIndex + , Exp.Certificate (LedgerEra era) + , StakeCredential + , AnyWitness (LedgerEra era) + ) + ] +indexTxCertificates (TxCertificates certsWits) = + [ (ScriptWitnessIndexCertificate ix, cert, stakeCred, witness) + | (ix, (cert, Just (stakeCred, witness))) <- zip [0 ..] $ toList certsWits + ] + +-- | Index the assets with witnesses in the order of policy ids. +-- See section 4.1 of https://github.com/intersectmbo/cardano-ledger/releases/latest/download/alonzo-ledger.pdf +indexTxMintValue + :: TxMintValue era + -> [ ( ScriptWitnessIndex + , PolicyId + , PolicyAssets + , AnyWitness era + ) + ] +indexTxMintValue (TxMintValue policiesWithAssets) = + [ (ScriptWitnessIndexMint ix, policyId, assets, witness) + | (ix, (policyId, (assets, witness))) <- zip [0 ..] $ toList policiesWithAssets + ] + +-- | Index voting procedures by the order of the votes ('Ord'). +indexTxVotingProcedures + :: TxVotingProcedures era + -> [ ( ScriptWitnessIndex + , L.Voter + , AnyWitness era + ) + ] +indexTxVotingProcedures (TxVotingProcedures vProcedures sWitMap) = + [ (ScriptWitnessIndexVoting $ fromIntegral index, vote, scriptWitness) + | let allVoteMap = L.unVotingProcedures vProcedures + , (vote, scriptWitness) <- toList sWitMap + , index <- maybeToList $ Map.lookupIndex vote allVoteMap + ] + +-- | Index proposal procedures by their order ('Ord'). +indexWitnessedTxProposalProcedures + :: forall era + . IsEra era + => TxProposalProcedures (LedgerEra era) + -> [ ( L.ProposalProcedure (LedgerEra era) + , (ScriptWitnessIndex, AnyWitness (LedgerEra era)) + ) + ] +indexWitnessedTxProposalProcedures (TxProposalProcedures proposals) = do + let allProposalsList = zip [0 ..] $ obtainCommonConstraints (useEra @era) $ toList proposals + [ (proposal, (ScriptWitnessIndexProposing ix, anyWitness)) + | (ix, (proposal, anyWitness)) <- allProposalsList + ] diff --git a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/TxScriptWitnessRequirements.hs b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/TxScriptWitnessRequirements.hs index b73287832f..a30c83c105 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/TxScriptWitnessRequirements.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/TxScriptWitnessRequirements.hs @@ -17,9 +17,7 @@ module Cardano.Api.Experimental.Tx.Internal.TxScriptWitnessRequirements ) where -import Cardano.Api.Era.Internal.Eon.AlonzoEraOnwards -import Cardano.Api.Era.Internal.Eon.Convert (Convert (convert)) -import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra +import Cardano.Api.Experimental.Era qualified as Exp import Cardano.Api.Experimental.Plutus.Internal.IndexedPlutusScriptWitness import Cardano.Api.Experimental.Tx.Internal.AnyWitness import Cardano.Api.Ledger qualified as L @@ -69,38 +67,36 @@ instance Monoid (TxScriptWitnessRequirements L.DijkstraEra) where mempty = TxScriptWitnessRequirements mempty mempty mempty mempty getTxScriptWitnessRequirements - :: AlonzoEraOnwards era - -> [(Witnessable witnessable (ShelleyLedgerEra era), AnyWitness (ShelleyLedgerEra era))] - -> TxScriptWitnessRequirements (ShelleyLedgerEra era) -getTxScriptWitnessRequirements era wits = + :: L.AlonzoEraScript era + => Monoid (TxScriptWitnessRequirements era) + => (Witnessable witnessable era, AnyWitness era) + -> TxScriptWitnessRequirements era +getTxScriptWitnessRequirements wit@(_, anyWit) = let TxScriptWitnessRequirements l s d _ = - obtainMonoidConstraint era $ - mconcat - [ TxScriptWitnessRequirements - (maybe mempty Set.singleton $ getAnyWitnessPlutusLanguage anyWit) - (maybe mempty return $ getAnyWitnessScript (convert era) anyWit) - (getAnyWitnessScriptData era anyWit) - (alonzoEraOnwardsConstraints era mempty) - | (_, anyWit) <- wits - ] - in TxScriptWitnessRequirements l s d (getAnyWitnessRedeemerPointerMap era wits) + mconcat + [ TxScriptWitnessRequirements + (maybe mempty Set.singleton $ getAnyWitnessPlutusLanguage anyWit) + (maybe mempty return $ getAnyWitnessScript anyWit) + (getAnyWitnessScriptData anyWit) + mempty + ] + in TxScriptWitnessRequirements l s d (getAnyWitnessRedeemerPointerMap [wit]) getTxScriptWitnessesRequirements - :: AlonzoEraOnwards era - -> [(Witnessable witnessable (ShelleyLedgerEra era), AnyWitness (ShelleyLedgerEra era))] - -> TxScriptWitnessRequirements (ShelleyLedgerEra era) -getTxScriptWitnessesRequirements eon wits = - obtainMonoidConstraint eon $ getTxScriptWitnessRequirements eon wits + :: L.AlonzoEraScript era + => Monoid (TxScriptWitnessRequirements era) + => [(Witnessable witnessable era, AnyWitness era)] + -> TxScriptWitnessRequirements era +getTxScriptWitnessesRequirements wits = + mconcat $ map getTxScriptWitnessRequirements wits obtainMonoidConstraint - :: AlonzoEraOnwards era - -> (Monoid (TxScriptWitnessRequirements (ShelleyLedgerEra era)) => a) + :: Exp.Era era + -> (Monoid (TxScriptWitnessRequirements (Exp.LedgerEra era)) => a) -> a obtainMonoidConstraint eon = case eon of - AlonzoEraOnwardsAlonzo -> id - AlonzoEraOnwardsBabbage -> id - AlonzoEraOnwardsConway -> id - AlonzoEraOnwardsDijkstra -> id + Exp.ConwayEra -> id + Exp.DijkstraEra -> id extractExecutionUnits :: TxScriptWitnessRequirements era -> [ExecutionUnits] extractExecutionUnits (TxScriptWitnessRequirements _ _ _ redeemers) = diff --git a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Type.hs b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Type.hs new file mode 100644 index 0000000000..da74dc00ed --- /dev/null +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Type.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Cardano.Api.Experimental.Tx.Internal.Type + ( UnsignedTx (..) + ) +where + +import Cardano.Api.Experimental.Era +import Cardano.Api.HasTypeProxy (HasTypeProxy (..), Proxy, asType) +import Cardano.Api.Ledger.Internal.Reexport qualified as L +import Cardano.Api.ProtocolParameters +import Cardano.Api.Serialise.Raw + ( SerialiseAsRawBytes (..) + , SerialiseAsRawBytesError (SerialiseAsRawBytesError) + ) + +import Cardano.Ledger.Binary qualified as Ledger +import Cardano.Ledger.Core qualified as Ledger + +import Control.Exception (displayException) +import Data.Bifunctor (bimap) +import Data.ByteString.Lazy (fromStrict) + +-- | A transaction that can contain everything +-- except key witnesses. +data UnsignedTx era + = L.EraTx (LedgerEra era) => UnsignedTx (Ledger.Tx (LedgerEra era)) + +instance HasTypeProxy era => HasTypeProxy (UnsignedTx era) where + data AsType (UnsignedTx era) = AsUnsignedTx (AsType era) + proxyToAsType :: Proxy (UnsignedTx era) -> AsType (UnsignedTx era) + proxyToAsType _ = AsUnsignedTx (asType @era) + +instance + ( HasTypeProxy era + , L.EraTx (LedgerEra era) + ) + => SerialiseAsRawBytes (UnsignedTx era) + where + serialiseToRawBytes (UnsignedTx tx) = + Ledger.serialize' (Ledger.eraProtVerHigh @(LedgerEra era)) tx + deserialiseFromRawBytes _ = + bimap wrapError UnsignedTx + . Ledger.decodeFullAnnotator + (Ledger.eraProtVerHigh @(LedgerEra era)) + "UnsignedTx" + Ledger.decCBOR + . fromStrict + where + wrapError + :: Ledger.DecoderError -> SerialiseAsRawBytesError + wrapError = SerialiseAsRawBytesError . displayException + +deriving instance Eq (UnsignedTx era) + +deriving instance Show (UnsignedTx era) diff --git a/cardano-api/src/Cardano/Api/Governance/Internal/Action/VotingProcedure.hs b/cardano-api/src/Cardano/Api/Governance/Internal/Action/VotingProcedure.hs index f2e65edf8b..ab7ca71012 100644 --- a/cardano-api/src/Cardano/Api/Governance/Internal/Action/VotingProcedure.hs +++ b/cardano-api/src/Cardano/Api/Governance/Internal/Action/VotingProcedure.hs @@ -153,17 +153,17 @@ instance Error (VotesMergingConflict era) where -- or fails if the votes are incompatible. mergeVotingProcedures :: () - => VotingProcedures era + => L.VotingProcedures era -- ^ Votes to merge - -> VotingProcedures era + -> L.VotingProcedures era -- ^ Votes to merge - -> Either (VotesMergingConflict era) (VotingProcedures era) + -> Either (VotesMergingConflict era) (L.VotingProcedures era) -- ^ Either the conflict found, or the merged votes mergeVotingProcedures vpsa vpsb = - VotingProcedures . L.VotingProcedures <$> foldM mergeVotesOfOneVoter Map.empty allVoters + L.VotingProcedures <$> foldM mergeVotesOfOneVoter Map.empty allVoters where - mapa = L.unVotingProcedures (unVotingProcedures vpsa) - mapb = L.unVotingProcedures (unVotingProcedures vpsb) + mapa = L.unVotingProcedures vpsa + mapb = L.unVotingProcedures vpsb allVoters = Set.union (Map.keysSet mapa) (Map.keysSet mapb) mergeVotesOfOneVoter acc voter = Map.union acc <$> case (Map.lookup voter mapa, Map.lookup voter mapb) of diff --git a/cardano-api/src/Cardano/Api/Internal/Orphans/Misc.hs b/cardano-api/src/Cardano/Api/Internal/Orphans/Misc.hs index 1ef74386cb..f9de88f739 100644 --- a/cardano-api/src/Cardano/Api/Internal/Orphans/Misc.hs +++ b/cardano-api/src/Cardano/Api/Internal/Orphans/Misc.hs @@ -28,6 +28,7 @@ import Cardano.Ledger.Binary qualified as CBOR import Cardano.Ledger.Coin qualified as L import Cardano.Ledger.Conway.PParams qualified as Ledger import Cardano.Ledger.HKD (NoUpdate (..)) +import Cardano.Ledger.Plutus.Language qualified as L import Cardano.Ledger.Shelley.PParams qualified as Ledger import Ouroboros.Consensus.Cardano.Block (EraMismatch (..)) import PlutusLedgerApi.Common qualified as P @@ -39,6 +40,7 @@ import Data.ListMap qualified as ListMap import Data.Maybe.Strict (StrictMaybe (..)) import Data.Monoid import Data.Text.Encoding.Error qualified as T +import Data.Type.Equality import Data.Typeable import GHC.Exts (IsList (..)) import Network.Mux qualified as Mux @@ -295,3 +297,11 @@ instance Error P.ParseError where prettyError = pretty . show deriving via ShowOf TypeRep instance Pretty TypeRep + +instance TestEquality L.SLanguage where + testEquality s1 s2 = case (s1, s2) of + (L.SPlutusV1, L.SPlutusV1) -> Just Refl + (L.SPlutusV2, L.SPlutusV2) -> Just Refl + (L.SPlutusV3, L.SPlutusV3) -> Just Refl + (L.SPlutusV4, L.SPlutusV4) -> Just Refl + _ -> Nothing diff --git a/cardano-api/src/Cardano/Api/Internal/Orphans/Serialisation.hs b/cardano-api/src/Cardano/Api/Internal/Orphans/Serialisation.hs index 22713af1bd..6909516e96 100644 --- a/cardano-api/src/Cardano/Api/Internal/Orphans/Serialisation.hs +++ b/cardano-api/src/Cardano/Api/Internal/Orphans/Serialisation.hs @@ -67,6 +67,7 @@ import Cardano.Ledger.HKD (NoUpdate (..)) import Cardano.Ledger.Hashes qualified as L hiding (KeyHash) import Cardano.Ledger.Keys qualified as L.Keys import Cardano.Ledger.Mary.Value qualified as L +import Cardano.Ledger.Plutus.Language qualified as L import Cardano.Ledger.Shelley.API.Mempool qualified as L import Cardano.Ledger.Shelley.PParams qualified as Ledger import Cardano.Ledger.Shelley.Rules qualified as L @@ -470,3 +471,19 @@ instance SerialiseAsRawBytes L.GovActionId where L.GovActionId . toShelleyTxId <$> deserialiseFromRawBytes AsTxId txIdBs <*> deserialiseFromRawBytes AsGovActionIx index + +instance HasTypeProxy (L.SLanguage L.PlutusV1) where + data AsType (L.SLanguage L.PlutusV1) = AsPlutusScriptV1 + proxyToAsType _ = AsPlutusScriptV1 + +instance HasTypeProxy (L.SLanguage L.PlutusV2) where + data AsType (L.SLanguage L.PlutusV2) = AsPlutusScriptV2 + proxyToAsType _ = AsPlutusScriptV2 + +instance HasTypeProxy (L.SLanguage L.PlutusV3) where + data AsType (L.SLanguage L.PlutusV3) = AsPlutusScriptV3 + proxyToAsType _ = AsPlutusScriptV3 + +instance HasTypeProxy (L.SLanguage L.PlutusV4) where + data AsType (L.SLanguage L.PlutusV4) = AsPlutusScriptV4 + proxyToAsType _ = AsPlutusScriptV4 diff --git a/cardano-api/src/Cardano/Api/Ledger/Internal/Reexport.hs b/cardano-api/src/Cardano/Api/Ledger/Internal/Reexport.hs index da9c72a30b..7615234c9f 100644 --- a/cardano-api/src/Cardano/Api/Ledger/Internal/Reexport.hs +++ b/cardano-api/src/Cardano/Api/Ledger/Internal/Reexport.hs @@ -45,6 +45,7 @@ module Cardano.Api.Ledger.Internal.Reexport , pattern GenesisDelegTxCert , pattern UpdateDRepTxCert -- Core + , Addr , Coin (..) , Compactible (..) , partialCompactFL @@ -54,20 +55,26 @@ module Cardano.Api.Ledger.Internal.Reexport , EraTxOut , Network (..) , PoolCert (..) + , PolicyID (..) , PParams (..) , PParamsUpdate + , SLanguage (..) + , SlotNo (..) , TxId (..) , TxIn (..) + , TxOut , Value , MaryValue (..) , MultiAsset (..) , addDeltaCoin , castSafeHash + , mkBasicTxOut , toDeltaCoin , toEraCBOR , fromEraCBOR , ppMinFeeAL , ppMinUTxOValueL + , valueFromList -- Dijkstra , DijkstraPlutusPurpose (..) -- Conway @@ -195,7 +202,7 @@ module Cardano.Api.Ledger.Internal.Reexport where import Cardano.Crypto.Hash.Class (hashFromBytes, hashToBytes) -import Cardano.Ledger.Address (RewardAccount (..)) +import Cardano.Ledger.Address (Addr (..), RewardAccount (..)) import Cardano.Ledger.Allegra.Scripts (showTimelock) import Cardano.Ledger.Alonzo.Core ( AlonzoEraScript (..) @@ -319,8 +326,10 @@ import Cardano.Ledger.Core , EraTxOut , PParams (..) , PoolCert (..) + , TxOut , Value , fromEraCBOR + , mkBasicTxOut , ppMinFeeAL , ppMinUTxOValueL , toEraCBOR @@ -344,9 +353,15 @@ import Cardano.Ledger.Keys , hashWithSerialiser , toVRFVerKeyHash ) -import Cardano.Ledger.Mary.Value (MaryValue (..), MultiAsset (..)) +import Cardano.Ledger.Mary.Value (MaryValue (..), MultiAsset (..), PolicyID (..), valueFromList) import Cardano.Ledger.Plutus.Data (Data (..), unData) -import Cardano.Ledger.Plutus.Language (Language, Plutus, languageToText, plutusBinary) +import Cardano.Ledger.Plutus.Language + ( Language + , Plutus + , SLanguage (..) + , languageToText + , plutusBinary + ) import Cardano.Ledger.Shelley.API ( ChainAccountState (..) , GenDelegPair (..) @@ -374,4 +389,4 @@ import Cardano.Ledger.Shelley.TxCert import Cardano.Ledger.State (PoolMetadata (..), PoolParams (..), StakePoolRelay (..)) import Cardano.Ledger.TxIn (TxId (..), TxIn (..)) import Cardano.Protocol.Crypto (Crypto, StandardCrypto) -import Cardano.Slotting.Slot (EpochNo (..)) +import Cardano.Slotting.Slot (EpochNo (..), SlotNo (..)) diff --git a/cardano-api/src/Cardano/Api/Plutus.hs b/cardano-api/src/Cardano/Api/Plutus.hs index 4b6674cc56..023bacc305 100644 --- a/cardano-api/src/Cardano/Api/Plutus.hs +++ b/cardano-api/src/Cardano/Api/Plutus.hs @@ -12,6 +12,7 @@ module Cardano.Api.Plutus , IsPlutusScriptLanguage (..) , IsScriptLanguage (..) , ToLedgerPlutusLanguage + , FromLedgerPlutusLanguage -- * Scripts in a specific language , Script (..) diff --git a/cardano-api/src/Cardano/Api/Plutus/Internal/Script.hs b/cardano-api/src/Cardano/Api/Plutus/Internal/Script.hs index 8c30f37b44..d1bb73bd7e 100644 --- a/cardano-api/src/Cardano/Api/Plutus/Internal/Script.hs +++ b/cardano-api/src/Cardano/Api/Plutus/Internal/Script.hs @@ -29,6 +29,7 @@ module Cardano.Api.Plutus.Internal.Script , IsPlutusScriptLanguage (..) , IsScriptLanguage (..) , ToLedgerPlutusLanguage + , FromLedgerPlutusLanguage -- * Scripts in a specific language , Script (..) @@ -1466,6 +1467,12 @@ type family ToLedgerPlutusLanguage lang where ToLedgerPlutusLanguage PlutusScriptV3 = Plutus.PlutusV3 ToLedgerPlutusLanguage PlutusScriptV4 = Plutus.PlutusV4 +type family FromLedgerPlutusLanguage lang where + FromLedgerPlutusLanguage Plutus.PlutusV1 = PlutusScriptV1 + FromLedgerPlutusLanguage Plutus.PlutusV2 = PlutusScriptV2 + FromLedgerPlutusLanguage Plutus.PlutusV3 = PlutusScriptV3 + FromLedgerPlutusLanguage Plutus.PlutusV4 = PlutusScriptV4 + data PlutusScriptInEra era lang where PlutusScriptInEra :: PlutusScript lang -> PlutusScriptInEra era lang diff --git a/cardano-api/src/Cardano/Api/Plutus/Internal/ScriptData.hs b/cardano-api/src/Cardano/Api/Plutus/Internal/ScriptData.hs index eac5fa129d..b2b36bbfbf 100644 --- a/cardano-api/src/Cardano/Api/Plutus/Internal/ScriptData.hs +++ b/cardano-api/src/Cardano/Api/Plutus/Internal/ScriptData.hs @@ -155,7 +155,7 @@ instance HasTypeProxy ScriptData where -- newtype instance Hash ScriptData - = ScriptDataHash Plutus.DataHash + = ScriptDataHash {unScriptDataHash :: Plutus.DataHash} deriving stock (Eq, Ord) deriving (Show, Pretty) via UsingRawBytesHex (Hash ScriptData) deriving (ToJSON, FromJSON) via UsingRawBytesHex (Hash ScriptData) diff --git a/cardano-api/src/Cardano/Api/Tx/Internal/Body.hs b/cardano-api/src/Cardano/Api/Tx/Internal/Body.hs index 8d89606ec7..85783dd13c 100644 --- a/cardano-api/src/Cardano/Api/Tx/Internal/Body.hs +++ b/cardano-api/src/Cardano/Api/Tx/Internal/Body.hs @@ -207,6 +207,7 @@ module Cardano.Api.Tx.Internal.Body , toShelleyTxIn , toShelleyTxOut , toShelleyTxOutAny + , toShelleyWithdrawal , fromShelleyTxId , fromShelleyTxIn , fromShelleyTxOut @@ -253,7 +254,9 @@ import Cardano.Api.Experimental.Plutus.Internal.IndexedPlutusScriptWitness import Cardano.Api.Experimental.Plutus.Internal.Shim.LegacyScripts import Cardano.Api.Experimental.Tx.Internal.Certificate qualified as Exp import Cardano.Api.Experimental.Tx.Internal.Certificate.Compatible (getTxCertWitness) -import Cardano.Api.Experimental.Tx.Internal.TxScriptWitnessRequirements +import Cardano.Api.Experimental.Tx.Internal.TxScriptWitnessRequirements hiding + ( obtainMonoidConstraint + ) import Cardano.Api.Governance.Internal.Action.ProposalProcedure import Cardano.Api.Governance.Internal.Action.VotingProcedure import Cardano.Api.Key.Internal @@ -733,10 +736,10 @@ deriving instance Show (TxVotingProcedures build era) mkTxVotingProcedures :: Applicative (BuildTxWith build) => [(VotingProcedures era, Maybe (ScriptWitness WitCtxStake era))] - -> Either (VotesMergingConflict era) (TxVotingProcedures build era) + -> Either (VotesMergingConflict (ShelleyLedgerEra era)) (TxVotingProcedures build era) mkTxVotingProcedures votingProcedures = do - VotingProcedures procedure <- - foldM f emptyVotingProcedures votingProcedures + procedure <- + foldM f (L.VotingProcedures Map.empty) votingProcedures pure $ TxVotingProcedures procedure (pure votingScriptWitnessMap) where votingScriptWitnessMap = @@ -744,7 +747,8 @@ mkTxVotingProcedures votingProcedures = do (\acc next -> acc `Map.union` uncurry votingScriptWitnessSingleton next) Map.empty votingProcedures - f acc (procedure, _witness) = mergeVotingProcedures acc procedure + + f acc (VotingProcedures procedure, _witness) = mergeVotingProcedures acc procedure votingScriptWitnessSingleton :: VotingProcedures era diff --git a/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs b/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs index 62043afb49..5301a0db7b 100644 --- a/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs +++ b/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs @@ -31,6 +31,7 @@ module Cardano.Api.Tx.Internal.Output , toShelleyTxOutAny , convTxOuts , fromLedgerTxOuts + , toBabbageTxOutDatum , toByronTxOut -- ** An Output Value , TxOutValue (..) diff --git a/cardano-api/src/Cardano/Api/Value.hs b/cardano-api/src/Cardano/Api/Value.hs index 8cf035cf76..c35aa31542 100644 --- a/cardano-api/src/Cardano/Api/Value.hs +++ b/cardano-api/src/Cardano/Api/Value.hs @@ -54,6 +54,7 @@ module Cardano.Api.Value , fromByronLovelace , fromShelleyDeltaLovelace , toMaryValue + , fromMaryPolicyID , fromMaryValue , fromMultiAsset , fromLedgerValue diff --git a/cardano-api/src/Cardano/Api/Value/Internal.hs b/cardano-api/src/Cardano/Api/Value/Internal.hs index 777f2a6046..5c0abffc0d 100644 --- a/cardano-api/src/Cardano/Api/Value/Internal.hs +++ b/cardano-api/src/Cardano/Api/Value/Internal.hs @@ -63,6 +63,7 @@ module Cardano.Api.Value.Internal , fromMultiAsset , fromLedgerValue , toLedgerValue + , fromMaryPolicyID -- * Data family instances , AsType (..) diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs index e222ced05f..2bdfd6f7e5 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs @@ -2,6 +2,7 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Test.Cardano.Api.Experimental @@ -12,6 +13,7 @@ where import Cardano.Api qualified as Api import Cardano.Api.Experimental qualified as Exp import Cardano.Api.Experimental.Era (convert) +import Cardano.Api.Experimental.Tx qualified as Exp import Cardano.Api.Genesis qualified as Genesis import Cardano.Api.Ledger qualified as Ledger import Cardano.Api.Plutus qualified as Script @@ -73,7 +75,7 @@ prop_created_transaction_with_both_apis_are_the_same = H.propertyOnce $ do let sbe = Api.convert era signedTxTraditional <- exampleTransactionTraditionalWay sbe - signedTxExperimental <- exampleTransactionExperimentalWay era sbe + signedTxExperimental <- exampleTransactionExperimentalWay era let oldStyleTx :: Api.Tx Api.ConwayEra = ShelleyTx sbe signedTxExperimental @@ -84,7 +86,7 @@ prop_created_transaction_with_both_apis_are_the_same = H.propertyOnce $ do => Api.ShelleyBasedEra Exp.ConwayEra -> m (Tx Exp.ConwayEra) exampleTransactionTraditionalWay sbe = do - txBodyContent <- exampleTxBodyContent Api.AsConwayEra sbe + txBodyContent <- exampleTxBodyContent sbe signingKey <- exampleSigningKey txBody <- H.evalEither $ Api.createTransactionBody sbe txBodyContent @@ -96,14 +98,13 @@ prop_created_transaction_with_both_apis_are_the_same = H.propertyOnce $ do exampleTransactionExperimentalWay :: H.MonadTest m => Exp.Era Exp.ConwayEra - -> Api.ShelleyBasedEra Exp.ConwayEra -> m (Ledger.Tx (Exp.LedgerEra Exp.ConwayEra)) - exampleTransactionExperimentalWay era sbe = do - txBodyContent <- exampleTxBodyContent Api.AsConwayEra sbe + exampleTransactionExperimentalWay era = do + txBodyContent <- exampleTxBodyContentExperimental era signingKey <- exampleSigningKey - unsignedTx <- H.evalEither $ Exp.makeUnsignedTx era txBodyContent - let witness = Exp.makeKeyWitness era unsignedTx (Api.WitnessPaymentKey signingKey) + let unsignedTx = Exp.makeUnsignedTx era txBodyContent + witness = Exp.makeKeyWitness era unsignedTx (Api.WitnessPaymentKey signingKey) let bootstrapWitnesses = [] keyWitnesses = [witness] @@ -118,15 +119,20 @@ prop_balance_transaction_two_ways = H.propertyOnce $ do let meo = Api.MaryEraOnwardsConway changeAddress <- getExampleChangeAddress sbe - - txBodyContent <- exampleTxBodyContent Api.AsConwayEra sbe + (txBodyContent, newTxBodyContent) <- exampleOldAndNewStyleTxBodyContent era txBody <- H.evalEither $ Api.createTransactionBody sbe txBodyContent -- Simple way (fee calculation) - let fees = Api.evaluateTransactionFee sbe exampleProtocolParams txBody 0 1 0 - H.note_ $ "Fees 1: " <> show fees + -- OLD API + let oldFees = Api.evaluateTransactionFee sbe exampleProtocolParams txBody 0 1 0 + -- NEW API + newFees = Exp.evaluateTransactionFee exampleProtocolParams (Exp.makeUnsignedTx era newTxBodyContent) 0 1 0 + H.note_ $ "Fees 1: " <> show oldFees + + oldFees H.=== newFees -- Balance without ledger context (other that protocol parameters) + -- Old api Api.BalancedTxBody _txBodyContent2 _txBody2 @@ -147,8 +153,27 @@ prop_balance_transaction_two_ways = H.propertyOnce $ do 0 changeAddress $ Api.lovelaceToValue 12_000_000 + -- New api + balancedTxBodyContent <- + H.evalEither $ + Exp.estimateBalancedTxBody + era + newTxBodyContent + exampleProtocolParams + mempty + mempty + mempty + mempty + 0 + 1 + 0 + 0 + changeAddress + (Ledger.valueFromList 12_000_000 []) + fees2 H.=== Exp.txFee balancedTxBodyContent H.note_ $ "Fees 2: " <> show fees2 + -- H.note_ $ "New TxBody 2: " <> show txBody2 -- H.note_ $ "New TxBodyContent 2: " <> show txBodyContent2 -- H.note_ $ "Change output 2: " <> show changeOutput2 @@ -244,13 +269,23 @@ getExampleSrcTxId = do return $ Api.TxIn srcTxId srcTxIx getExampleDestAddress - :: (H.MonadTest m, Api.IsCardanoEra era) => Script.AsType era -> m (Api.AddressInEra era) -getExampleDestAddress eraAsType = do + :: forall m era. (H.MonadTest m, Api.IsCardanoEra era) => m (Api.AddressInEra era) +getExampleDestAddress = do H.evalMaybe $ Api.deserialiseAddress - (Api.AsAddressInEra eraAsType) + (Api.AsAddressInEra (Api.proxyToAsType (Api.Proxy @era))) "addr_test1vzpfxhjyjdlgk5c0xt8xw26avqxs52rtf69993j4tajehpcue4v2v" +getExampleDestAddressExp + :: H.MonadTest m => m Ledger.Addr +getExampleDestAddressExp = do + Api.toShelleyAddr + <$> H.evalMaybe + ( Api.deserialiseAddress + (Api.AsAddressInEra (Api.proxyToAsType (Api.Proxy @Api.ConwayEra))) + "addr_test1vzpfxhjyjdlgk5c0xt8xw26avqxs52rtf69993j4tajehpcue4v2v" + ) + getExampleChangeAddress :: H.MonadTest m => Api.ShelleyBasedEra era -> m (Api.AddressInEra era) getExampleChangeAddress sbe = do signingKey <- exampleSigningKey @@ -261,14 +296,40 @@ getExampleChangeAddress sbe = do (Api.PaymentCredentialByKey $ Api.verificationKeyHash $ Api.getVerificationKey signingKey) Api.NoStakeAddress +exampleTxBodyContentExperimental + :: forall m era + . H.MonadTest m + => Exp.Era era + -> m (Exp.TxBodyContent (Exp.LedgerEra era)) +exampleTxBodyContentExperimental era = do + srcTxIn <- getExampleSrcTxId + addr <- getExampleDestAddressExp + let value = Ledger.valueFromList 10_000_000 [] + out :: Ledger.TxOut (Exp.LedgerEra era) + out = Exp.obtainCommonConstraints era $ Ledger.mkBasicTxOut addr value + let txBodyContent = + Exp.defaultTxBodyContent + & Exp.setTxIns + [ + ( srcTxIn + , Exp.AnyKeyWitnessPlaceholder + ) + ] + & Exp.setTxOuts + [ Exp.obtainCommonConstraints era $ Exp.TxOut out Nothing + ] + & Exp.setTxFee 2_000_000 + return txBodyContent + exampleTxBodyContent - :: (Api.ShelleyBasedEraConstraints era, H.MonadTest m) - => Api.AsType era - -> Api.ShelleyBasedEra era + :: forall m era + . H.MonadTest m + => Api.IsCardanoEra era + => Api.ShelleyBasedEra era -> m (Api.TxBodyContent Api.BuildTx era) -exampleTxBodyContent eraAsType sbe = do +exampleTxBodyContent sbe = do srcTxIn <- getExampleSrcTxId - destAddress <- getExampleDestAddress eraAsType + destAddress <- getExampleDestAddress @_ @era let txBodyContent = Api.defaultTxBodyContent sbe & Api.setTxIns @@ -288,6 +349,55 @@ exampleTxBodyContent eraAsType sbe = do return txBodyContent +exampleOldAndNewStyleTxBodyContent + :: forall m era + . H.MonadTest m + => Api.IsCardanoEra era + => Exp.Era era + -> m + ( Api.TxBodyContent Api.BuildTx era + , Exp.TxBodyContent (Exp.LedgerEra era) + ) +exampleOldAndNewStyleTxBodyContent era = do + let sbe = convert era + srcTxIn <- getExampleSrcTxId + destAddress <- getExampleDestAddress @_ @era + let txBodyContentOldApi = + Api.defaultTxBodyContent sbe + & Api.setTxIns + [ + ( srcTxIn + , Api.BuildTxWith (Api.KeyWitness Api.KeyWitnessForSpending) + ) + ] + & Api.setTxOuts + [ Api.TxOut + destAddress + (Api.lovelaceToTxOutValue sbe 10_000_000) + Api.TxOutDatumNone + Script.ReferenceScriptNone + ] + & Api.setTxFee (Api.TxFeeExplicit sbe 2_000_000) + + let txBodyContentNewApi = + Exp.defaultTxBodyContent + & Exp.setTxIns + [ + ( srcTxIn + , Exp.AnyKeyWitnessPlaceholder + ) + ] + & Exp.setTxOuts + [ Exp.obtainCommonConstraints era $ + Exp.TxOut + ( Exp.obtainCommonConstraints era $ + Ledger.mkBasicTxOut (Api.toShelleyAddr destAddress) (Ledger.valueFromList 10_000_000 []) + ) + Nothing + ] + & Exp.setTxFee 2_000_000 + return (txBodyContentOldApi, txBodyContentNewApi) + exampleSigningKey :: H.MonadTest m => m (Api.SigningKey Api.PaymentKey) exampleSigningKey = H.evalEither $ diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Autobalance.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Autobalance.hs index 8273c64e1f..a780f67f0c 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Autobalance.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Autobalance.hs @@ -14,10 +14,10 @@ where import Cardano.Api import Cardano.Api.Experimental qualified as Exp -import Cardano.Api.Experimental.Tx +import Cardano.Api.Experimental.Tx qualified as Exp import Cardano.Api.Ledger qualified as L import Cardano.Api.Parser.Text qualified as P -import Cardano.Api.Tx qualified as L +import Cardano.Api.Tx qualified as Api import Cardano.Ledger.Alonzo.Core qualified as L import Cardano.Ledger.Coin qualified as L @@ -296,7 +296,7 @@ prop_make_transaction_body_autobalance_return_correct_fee_for_multi_asset = H.pr , executionMemory = 325_610 } ] - === extractExecutionUnits scriptWitReqsWithAsset + === Exp.extractExecutionUnits scriptWitReqsWithAsset -- the correct amount with manual balancing of assets 335_299 === feeWithTxoutAsset @@ -326,7 +326,7 @@ prop_make_transaction_body_autobalance_return_correct_fee_for_multi_asset = H.pr , executionMemory = 325_610 } ] - === extractExecutionUnits scriptWitReqsBalanced + === Exp.extractExecutionUnits scriptWitReqsBalanced H.noteShow_ feeWithTxoutAsset H.noteShow_ fee @@ -465,7 +465,7 @@ prop_make_transaction_body_autobalance_multi_asset_collateral = H.propertyOnce $ , executionMemory = 325_610 } ] - === extractExecutionUnits scriptWitReqsBalanced + === Exp.extractExecutionUnits scriptWitReqsBalanced 335_299 === fee TxReturnCollateral _ (TxOut _ txOutValue _ _) <- H.noteShow $ txReturnCollateral balancedContent @@ -484,7 +484,7 @@ prop_calcReturnAndTotalCollateral = H.withTests 400 . H.property $ do era = convert beo feeCoin@(L.Coin fee) <- forAll genLovelace totalCollateral <- forAll $ genLedgerValueForTxOut sbe - let totalCollateralAda = totalCollateral ^. L.adaAssetL sbe + let totalCollateralAda = totalCollateral ^. Api.adaAssetL sbe pparams <- H.readJsonFileOk "test/cardano-api-test/files/input/protocol-parameters/conway.json" requiredCollateralPct <- H.noteShow . fromIntegral $ pparams ^. L.ppCollateralPercentageL @@ -518,7 +518,7 @@ prop_calcReturnAndTotalCollateral = H.withTests 400 . H.property $ do collBalance = totalCollateral <-> resRetCollValue resTotCollValue <- - H.noteShow $ mconcat [L.mkAdaValue sbe lovelace | TxTotalCollateral _ lovelace <- pure resTotColl] + H.noteShow $ mconcat [Api.mkAdaValue sbe lovelace | TxTotalCollateral _ lovelace <- pure resTotColl] if | txInsColl == TxInsCollateralNone -> do diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Body/Plutus/Scripts.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Body/Plutus/Scripts.hs index 7912a8eb09..f9c481a5cf 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Body/Plutus/Scripts.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Body/Plutus/Scripts.hs @@ -11,25 +11,12 @@ where import Cardano.Api (AlonzoEraOnwards (..)) import Cardano.Api qualified as Api import Cardano.Api.Experimental +import Cardano.Api.Experimental qualified as Exp +import Cardano.Api.Experimental.AnyScriptWitness import Cardano.Api.Experimental.Plutus -import Cardano.Api.Experimental.Tx +import Cardano.Api.Experimental.Tx qualified as Exp import Cardano.Api.Ledger qualified as L -import Cardano.Api.Tx - ( extractWitnessableCertificates - , extractWitnessableMints - , extractWitnessableProposals - , extractWitnessableTxIns - , extractWitnessableVotes - , extractWitnessableWithdrawals - , setTxCertificates - , setTxIns - , setTxMintValue - , setTxProposalProcedures - , setTxVotingProcedures - , setTxWithdrawals - ) -import Cardano.Binary qualified as CBOR import Cardano.Ledger.Alonzo.TxWits qualified as L import Cardano.Ledger.Conway qualified as L @@ -37,19 +24,14 @@ import Prelude import Data.Function import Data.List qualified as List +import Data.Map.Ordered qualified as OMap import Data.Map.Strict qualified as Map +import Test.Gen.Cardano.Api.Experimental qualified as Exp import Test.Gen.Cardano.Api.Typed ( genIndexedPlutusScriptWitness , genMintWitnessable - , genScriptWitnessedTxCertificates - , genScriptWitnessedTxIn - , genScriptWitnessedTxMintValue - , genScriptWitnessedTxProposals - , genScriptWitnessedTxWithdrawals - , genScriptWitnesssedTxVotingProcedures , genSimpleScriptMintWitness - , genTxBodyContent , genWitnessable ) @@ -67,7 +49,6 @@ import Test.Tasty.Hedgehog (testProperty) -- in the redeemer pointer map. prop_getAnyWitnessRedeemerPointerMap :: Property prop_getAnyWitnessRedeemerPointerMap = property $ do - let eon = AlonzoEraOnwardsConway l <- forAll $ Gen.int (Range.linear 2 5) witnessables <- forAll $ Gen.list (Range.singleton l) $ genWitnessable @L.ConwayEra wits <- @@ -83,7 +64,7 @@ prop_getAnyWitnessRedeemerPointerMap = property $ do expectedRedeemerPointerMapLength = length zipped finalWits = take expectedRedeemerPointerMapLength wits - L.Redeemers constructedRedeemerPointerMap = getAnyWitnessRedeemerPointerMap eon zipped + L.Redeemers constructedRedeemerPointerMap = getAnyWitnessRedeemerPointerMap zipped annotate "Constructed redeemer pointer map" annotateShow constructedRedeemerPointerMap @@ -97,7 +78,7 @@ prop_getAnyWitnessRedeemerPointerMap = property $ do let initialRedeemers = [ redeemer | IndexedPlutusScriptWitness _ _ swit <- finalWits - , let PlutusScriptWitness _ _ _ redeemer _ = swit + , let redeemer = getAnyPlutusScriptWitnessRedeemer swit ] ledgerRedeemers :: [L.Data L.ConwayEra] @@ -147,63 +128,66 @@ prop_toAnyWitness = prop_extractAllIndexedPlutusScriptWitnesses :: Property prop_extractAllIndexedPlutusScriptWitnesses = property $ do - let era = ConwayEra + let era :: Era ConwayEra = ConwayEra -- Generate plutus script witnesses for each possible plutus purpose - plutusScriptwitnessedTxIns <- forAll $ genScriptWitnessedTxIn era - plutusScriptWitnessedMint <- forAll $ genScriptWitnessedTxMintValue era - plutusScriptWitnessedTxCerts <- forAll $ genScriptWitnessedTxCertificates era - plutusScriptWitnessesTxWithdrawals <- forAll $ genScriptWitnessedTxWithdrawals era + plutusScriptwitnessedTxIns <- + forAll $ Gen.list (Range.linear 0 3) $ Exp.genScriptWitnessedTxIn @(LedgerEra ConwayEra) + plutusScriptWitnessedMint <- forAll $ Exp.genScriptWitnessedTxMintValue @(LedgerEra ConwayEra) + plutusScriptWitnessedTxCerts <- forAll $ Exp.genScriptWitnessedTxCertificates @(LedgerEra ConwayEra) + plutusScriptWitnessesTxWithdrawals <- + forAll $ Exp.genScriptWitnessedTxWithdrawals @(LedgerEra ConwayEra) plutusScriptWitnesssedTxVotingProcedures <- - Api.mkFeatured <$> forAll (genScriptWitnesssedTxVotingProcedures era) + forAll $ Exp.genScriptWitnesssedTxVotingProcedures @(LedgerEra ConwayEra) plutusScriptWitnessedTxProposalProcedures <- - Api.mkFeatured <$> forAll (genScriptWitnessedTxProposals era) - txBodyContent <- forAll $ genTxBodyContent (Api.convert era) + forAll $ Exp.genScriptWitnessedTxProposals @(LedgerEra ConwayEra) -- Populate the stripped `TxBodyContent` value with our generated plutus script -- witnesses let txBodyContentWithPlutusWitnesses = - txBodyContent - & setTxIns plutusScriptwitnessedTxIns - & setTxMintValue plutusScriptWitnessedMint - & setTxCertificates plutusScriptWitnessedTxCerts - & setTxWithdrawals plutusScriptWitnessesTxWithdrawals - & setTxVotingProcedures plutusScriptWitnesssedTxVotingProcedures - & setTxProposalProcedures plutusScriptWitnessedTxProposalProcedures + Exp.defaultTxBodyContent + & Exp.setTxIns plutusScriptwitnessedTxIns + & Exp.setTxMintValue plutusScriptWitnessedMint + & Exp.setTxCertificates plutusScriptWitnessedTxCerts + & Exp.setTxWithdrawals plutusScriptWitnessesTxWithdrawals + & Exp.setTxVotingProcedures plutusScriptWitnesssedTxVotingProcedures + & Exp.setTxProposalProcedures plutusScriptWitnessedTxProposalProcedures extractedPlutusScriptWitnesses <- - evalEither $ extractAllIndexedPlutusScriptWitnesses era txBodyContentWithPlutusWitnesses - - -- This type transformation is not needed however this property test will be - -- improved when we define an Eq instance for `AnyIndexedPlutusScriptWitness`. - -- This necessitates changes to the experimental api so for now we settle for comparing the number - -- of plutus script witnesses present in the `TxBodyContent`. - generatedTxInWits <- - evalEither $ fromLegacyTxInWitness Api.AlonzoEraOnwardsConway plutusScriptwitnessedTxIns - generatedTxMintWits <- - evalEither $ fromLegacyMintWitness Api.AlonzoEraOnwardsConway plutusScriptWitnessedMint - - generatedTxCertWits <- - evalEither $ fromLegacyTxCertificates Api.AlonzoEraOnwardsConway plutusScriptWitnessedTxCerts - - generatedTxWithdrawals <- - evalEither $ fromLegacyTxWithdrawals Api.AlonzoEraOnwardsConway plutusScriptWitnessesTxWithdrawals + evalEither $ Exp.extractAllIndexedPlutusScriptWitnesses era txBodyContentWithPlutusWitnesses - generatedTxVotingprocedures <- - evalEither $ - fromLegacyTxVotingProcedures Api.ConwayEraOnwardsConway plutusScriptWitnesssedTxVotingProcedures - - generatedTxProposalProcedures <- - evalEither $ - fromLegacyTxProposalProcedures Api.ConwayEraOnwardsConway plutusScriptWitnessedTxProposalProcedures + let generatedTxInWits = plutusScriptwitnessedTxIns + generatedTxMintWits = plutusScriptWitnessedMint + generatedTxCertWits = plutusScriptWitnessedTxCerts + generatedTxWithdrawals = plutusScriptWitnessesTxWithdrawals + generatedTxVotingprocedures = plutusScriptWitnesssedTxVotingProcedures + generatedTxProposalProcedures = plutusScriptWitnessedTxProposalProcedures let allGeneratedPlutusScriptWitnesses = mconcat - [ createIndexedPlutusScriptWitnesses generatedTxInWits - , createIndexedPlutusScriptWitnesses generatedTxMintWits - , createIndexedPlutusScriptWitnesses generatedTxCertWits - , createIndexedPlutusScriptWitnesses generatedTxWithdrawals - , createIndexedPlutusScriptWitnesses generatedTxVotingprocedures - , createIndexedPlutusScriptWitnesses generatedTxProposalProcedures + [ createIndexedPlutusScriptWitnesses $ [(Exp.WitTxIn tIn, sWit) | (tIn, sWit) <- generatedTxInWits] + , createIndexedPlutusScriptWitnesses $ + [ (Exp.WitMint pid pAssets, sWit) + | (pid, (pAssets, sWit)) <- Map.toList $ Exp.unTxMintValue generatedTxMintWits + ] + , createIndexedPlutusScriptWitnesses + [ (Exp.WitTxCert c scred, wit) + | (Certificate c, Just (scred, wit)) <- + OMap.toAscList $ Exp.unTxCertificates generatedTxCertWits + ] + , createIndexedPlutusScriptWitnesses + [ (Exp.WitWithdrawal sAddr deposit, wit) + | (sAddr, deposit, wit) <- Exp.unTxWithdrawals generatedTxWithdrawals + ] + , createIndexedPlutusScriptWitnesses + [ (Exp.WitVote v, wit) + | let Exp.TxVotingProcedures _ vMap = generatedTxVotingprocedures + , (v, wit) <- Map.toList vMap + ] + , createIndexedPlutusScriptWitnesses + [ (Exp.WitProposal p, wit) + | let Exp.TxProposalProcedures pMap = generatedTxProposalProcedures + , (p, wit) <- OMap.toAscList pMap + ] ] H.note_ "All generated script witnesses" @@ -213,101 +197,6 @@ prop_extractAllIndexedPlutusScriptWitnesses = length allGeneratedPlutusScriptWitnesses === length extractedPlutusScriptWitnesses -fromLegacyMintWitness - :: Api.AlonzoEraOnwards era - -> Api.TxMintValue Api.BuildTx era - -> Either - CBOR.DecoderError - [ ( Witnessable MintItem (Api.ShelleyLedgerEra era) - , AnyWitness (Api.ShelleyLedgerEra era) - ) - ] -fromLegacyMintWitness aeon = do - legacyWitnessConversion - aeon - . extractWitnessableMints aeon - -fromLegacyTxCertificates - :: forall era - . Api.AlonzoEraOnwards era - -> Api.TxCertificates Api.BuildTx era - -> Either - CBOR.DecoderError - [ ( Witnessable CertItem (Api.ShelleyLedgerEra era) - , AnyWitness (Api.ShelleyLedgerEra era) - ) - ] -fromLegacyTxCertificates aeon = do - legacyWitnessConversion - aeon - . extractWitnessableCertificates aeon - -fromLegacyTxWithdrawals - :: Api.AlonzoEraOnwards era - -> Api.TxWithdrawals Api.BuildTx era - -> Either - CBOR.DecoderError - [ ( Witnessable WithdrawalItem (Api.ShelleyLedgerEra era) - , AnyWitness (Api.ShelleyLedgerEra era) - ) - ] -fromLegacyTxWithdrawals aeon = - legacyWitnessConversion - aeon - . extractWitnessableWithdrawals aeon - -fromLegacyTxVotingProcedures - :: Api.ConwayEraOnwards era - -> Maybe - ( Api.Featured - eon - era - (Api.TxVotingProcedures Api.BuildTx era) - ) - -> Either - CBOR.DecoderError - [ ( Witnessable VoterItem (Api.ShelleyLedgerEra era) - , AnyWitness (Api.ShelleyLedgerEra era) - ) - ] -fromLegacyTxVotingProcedures aeon = do - legacyWitnessConversion - (Api.convert aeon) - . extractWitnessableVotes aeon - -fromLegacyTxProposalProcedures - :: Api.ConwayEraOnwards era - -> Maybe - ( Api.Featured - eon - era - (Api.TxProposalProcedures Api.BuildTx era) - ) - -> Either - CBOR.DecoderError - [ ( Witnessable ProposalItem (Api.ShelleyLedgerEra era) - , AnyWitness (Api.ShelleyLedgerEra era) - ) - ] -fromLegacyTxProposalProcedures aeon = do - legacyWitnessConversion - (Api.convert aeon) - . extractWitnessableProposals aeon - -fromLegacyTxInWitness - :: Api.AlonzoEraOnwards era - -> [(Api.TxIn, Api.BuildTxWith Api.BuildTx (Api.Witness Api.WitCtxTxIn era))] - -> Either - CBOR.DecoderError - [ ( Witnessable TxInItem (Api.ShelleyLedgerEra era) - , AnyWitness (Api.ShelleyLedgerEra era) - ) - ] -fromLegacyTxInWitness aeon = do - legacyWitnessConversion - (Api.convert aeon) - . extractWitnessableTxIns aeon - -- | We exclude reference scripts because they do not end up in the resulting transaction. isReferenceScript :: Api.Witness witctx era -> Bool isReferenceScript (Api.ScriptWitness _ (Api.SimpleScriptWitness _ (Api.SReferenceScript{}))) = True