From 09b8d1dd7fc19b5bf10ec23b5829d8a53fc5ed37 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Mon, 8 Jul 2024 18:52:02 +0200 Subject: [PATCH] Introduce data definition UnsignedTx Add Cardano.Api.Experimental.Tx --- cabal.project | 4 +- cardano-api/cardano-api.cabal | 5 +- .../Cardano/Api/Experimental/Eras.hs} | 12 +- .../Cardano/Api/Experimental/Script.hs | 367 ++++++++++++++++++ .../internal/Cardano/Api/Experimental/Tx.hs | 148 +++++++ .../Cardano/Api/Protocol/AvailableEras.hs | 171 +++----- .../internal/Cardano/Api/Scripts/New.hs | 172 -------- cardano-api/internal/Cardano/Api/Tx/Body.hs | 22 ++ 8 files changed, 593 insertions(+), 308 deletions(-) rename cardano-api/{src/Cardano/Api/Experimental.hs => internal/Cardano/Api/Experimental/Eras.hs} (50%) create mode 100644 cardano-api/internal/Cardano/Api/Experimental/Script.hs create mode 100644 cardano-api/internal/Cardano/Api/Experimental/Tx.hs delete mode 100644 cardano-api/internal/Cardano/Api/Scripts/New.hs diff --git a/cabal.project b/cabal.project index e411f88ec4..9726077bef 100644 --- a/cabal.project +++ b/cabal.project @@ -25,8 +25,8 @@ extra-packages: Cabal, process if impl(ghc < 9.8) constraints: interpolatedstring-perl6:setup.time source -program-options - ghc-options: -Werror +-- program-options +-- ghc-options: -Werror package cryptonite -- Using RDRAND instead of /dev/urandom as an entropy source for key diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 83fa45869e..8538a60e6e 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -132,7 +132,9 @@ library internal Cardano.Api.ReexposeNetwork Cardano.Api.Rewards Cardano.Api.Script - Cardano.Api.Scripts.New + Cardano.Api.Experimental.Eras + -- Cardano.Api.Experimental.Script + Cardano.Api.Experimental.Tx Cardano.Api.ScriptData Cardano.Api.SerialiseBech32 Cardano.Api.SerialiseCBOR @@ -238,7 +240,6 @@ library Cardano.Api.ChainSync.Client Cardano.Api.ChainSync.ClientPipelined Cardano.Api.Crypto.Ed25519Bip32 - Cardano.Api.Experimental Cardano.Api.Ledger Cardano.Api.Network Cardano.Api.Shelley diff --git a/cardano-api/src/Cardano/Api/Experimental.hs b/cardano-api/internal/Cardano/Api/Experimental/Eras.hs similarity index 50% rename from cardano-api/src/Cardano/Api/Experimental.hs rename to cardano-api/internal/Cardano/Api/Experimental/Eras.hs index d59c5f2d2a..da77bb3e25 100644 --- a/cardano-api/src/Cardano/Api/Experimental.hs +++ b/cardano-api/internal/Cardano/Api/Experimental/Eras.hs @@ -1,13 +1,9 @@ -{-# LANGUAGE PatternSynonyms #-} -module Cardano.Api.Experimental +module Cardano.Api.Experimental.Eras ( -- * New Era interface - -- BabbageEra - --, ConwayEra - AvailableEras(..) - , Era - , pattern CurrentEra - , pattern UpcomingEra + BabbageEra + , ConwayEra + , Era(..) , UseEra , AvailableErasToSbe , ToConstrainedEra diff --git a/cardano-api/internal/Cardano/Api/Experimental/Script.hs b/cardano-api/internal/Cardano/Api/Experimental/Script.hs new file mode 100644 index 0000000000..5d65311cbf --- /dev/null +++ b/cardano-api/internal/Cardano/Api/Experimental/Script.hs @@ -0,0 +1,367 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} + +module Cardano.Api.Experimental.Script where + +import Cardano.Api.HasTypeProxy +import Cardano.Api.Protocol.AvailableEras +import Cardano.Api.SerialiseCBOR (SerialiseAsCBOR (..)) +import Cardano.Api.TxIn + +import qualified Cardano.Binary as CBOR +import qualified Cardano.Ledger.Allegra.Scripts as Ledger +import qualified Cardano.Ledger.Alonzo.Scripts as Ledger +import qualified Cardano.Ledger.Alonzo.TxBody as Ledger +import qualified Cardano.Ledger.Alonzo.TxWits as Ledger +import qualified Cardano.Ledger.Babbage as Ledger +import Cardano.Ledger.Binary +import qualified Cardano.Ledger.Binary.Plain as Plain +import qualified Cardano.Ledger.Conway as Ledger +import qualified Cardano.Ledger.Conway.Governance as Ledger +import qualified Cardano.Ledger.Conway.Scripts as Ledger +import qualified Cardano.Ledger.Core as Ledger +import Cardano.Ledger.Crypto (StandardCrypto) +import qualified Cardano.Ledger.Plutus.Data as Ledger +import qualified Cardano.Ledger.TxIn as Ledger + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LBS +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe.Strict +import Data.Set (Set) +import Data.Typeable +import Data.Word +import Lens.Micro + +{- +In the current api we have PlutusScript which is a wrapper around ShortByteString +We should instead use newtype Plutus from ledger which is the same thing but +there is exposed functionality. +There is mkPlutusScript which will give us the different available scripts +for a given era (if they are available) + +We are going to start with the assumption that the user will know what +script version they are using and will indicate as such. + +I.e we will be removing ScriptInAnyLang because it depends on +the text envelope format and doesn't actually check the +script bytes. + +We have an issue regarding what is and isn't available in the various eras + +We can actually stick to the latest era and the upcoming era. We depend +on ledger to get the available script versions correctly so we should +be able to avoid parameterizing on versions. + +-} + +-- | This type wraps the serialized scripts (native or plutus) +-- for a given era. However we want to restrict the era to the +-- latest era (mainnet) and the upcoming era. This removes +-- the complexity of deciding which scripts are available in which eras. + +newtype Script availableera + = Script { unScript :: Ledger.Script (ToConstrainedEra availableera) } + +instance ( HasTypeProxy (Script availableera) + , ToCBOR (Ledger.Script (ToConstrainedEra availableera)) + , Typeable availableera + , ConstrainedDecoder availableera ledgerera + , Ledger.Era ledgerera + , DecCBOR (Ledger.Script (ToConstrainedEra availableera))) + => SerialiseAsCBOR (Script availableera) where + serialiseToCBOR (Script s) = CBOR.serialize' s + + deserialiseFromCBOR _ bs = + Plain.decodeFullDecoder + "Script" + fromCBOR + (LBS.fromStrict bs) :: Either DecoderError (Script availableera) + +instance HasTypeProxy (Script BabbageEra) where + data AsType (Script BabbageEra) = AsMainnetScript + proxyToAsType :: Proxy (Script BabbageEra) -> AsType (Script BabbageEra) + proxyToAsType _ = AsMainnetScript + +instance HasTypeProxy (Script ConwayEra) where + data AsType (Script ConwayEra) = AsUpcomingEraScript + proxyToAsType :: Proxy (Script ConwayEra) -> AsType (Script ConwayEra) + proxyToAsType _ = AsUpcomingEraScript + +instance ( Typeable availableera + , Ledger.Era ledgerera + , DecCBOR (Ledger.Script (ToConstrainedEra availableera)) + , ConstrainedDecoder availableera ledgerera + ) => FromCBOR (Script availableera) where + fromCBOR = Script <$> fromEraCBORConstrained @availableera + + + + +-- The following serialization functions depend on the ledger's CBOR serialization +-- of Plutus scripts. Taking a Plutus ShortByteString and deserializing it to +-- the ledger's types will allow us to leverage the ledger's plutus type classes. +-- + + +data NativeScriptDeserializationError + = NotAScript DecoderError + | NotASimpleScript -- We can improve this and potentially + -- tell the consumer its a plutus script + -- and which version it is. + + +deserialiseNativeScript + :: DecCBOR (Ledger.AlonzoScript (ToConstrainedEra availableera)) + => Era availableera + -> ByteString + -> Either NativeScriptDeserializationError (Ledger.NativeScript (ToConstrainedEra availableera)) +deserialiseNativeScript availableEra bs = + case availableEra of + CurrentEra -> deserialise AsMainnetScript bs + UpcomingEra -> deserialise AsUpcomingEraScript bs + where + deserialise + :: SerialiseAsCBOR (Script availableera) + => Ledger.EraScript (ToConstrainedEra availableera) + => AsType (Script availableera) + -> ByteString + -> Either NativeScriptDeserializationError (Ledger.NativeScript (ToConstrainedEra availableera)) + deserialise as bs' = + case deserialiseFromCBOR as bs' of + Right s -> case Ledger.getNativeScript $ unScript s of + Just nScript -> Right nScript + Nothing -> Left NotASimpleScript + Left e -> Left $ NotAScript e + +data PlutusScriptDeserializationError + = NotAPlutusScript + | NotAnyScript DecoderError + +deserialisePlutusScript + :: DecCBOR (Ledger.AlonzoScript (ToConstrainedEra availableera)) + => Era availableera + -> ByteString + -> Either PlutusScriptDeserializationError (Ledger.PlutusScript (ToConstrainedEra availableera)) +deserialisePlutusScript era bs = + case era of + CurrentEra -> deserialise AsMainnetScript bs + UpcomingEra -> deserialise AsUpcomingEraScript bs + where + deserialise + :: SerialiseAsCBOR (Script availableera) + => Ledger.AlonzoEraScript (ToConstrainedEra availableera) + => AsType (Script availableera) + -> ByteString + -> Either PlutusScriptDeserializationError (Ledger.PlutusScript (ToConstrainedEra availableera)) + deserialise as bs' = + case deserialiseFromCBOR as bs' of + Right s -> case Ledger.toPlutusScript $ unScript s of + Just nScript -> Right nScript + Nothing -> Left NotAPlutusScript + Left e -> Left $ NotAnyScript e + + +newtype ReferenceTxInput era + = ReferenceTxInput {unReferenceTxInput :: TxIn} + deriving Eq + +data PlutusScriptWitness era + = PlutusScriptWitness + (Ledger.TxWits (ToConstrainedEra era)) + | PlutusScriptWitnessRefInput + (Ledger.TxWits (ToConstrainedEra era)) + (ReferenceTxInput (ToConstrainedEra era)) + +deriving instance Eq (Ledger.TxWits (ToConstrainedEra era)) => Eq (PlutusScriptWitness era) + +data SimpleScriptWitness era + = SimpleScriptWitness + (Ledger.TxWits (ToConstrainedEra era)) + | SimpleScriptWitnessRefInput + (ReferenceTxInput (ToConstrainedEra era)) + +deriving instance Eq (Ledger.TxWits (ToConstrainedEra era)) => Eq (SimpleScriptWitness era) + +createPlutusScriptWitness + + :: Ledger.Script (ToConstrainedEra era) ~ Ledger.AlonzoScript (ToConstrainedEra era) + => Ledger.AlonzoEraScript (ToConstrainedEra era) + => Era era + -> Ledger.PlutusScript (ToConstrainedEra era) + -> Maybe (Ledger.BinaryData (ToConstrainedEra era)) -- ^ Datum + -> Map (Ledger.PlutusPurpose Ledger.AsIx (ToConstrainedEra era)) (Ledger.Data (ToConstrainedEra era), Ledger.ExUnits) -- ^ Redeemers + -> PlutusScriptWitness era +createPlutusScriptWitness era plutusScript mTxDatum redeemerMap = + case era of + CurrentEra -> PlutusScriptWitness $ createScriptWit $ Ledger.TxDats $ createDatumHashMap @BabbageEra mTxDatum + UpcomingEra -> PlutusScriptWitness $ createScriptWit $ Ledger.TxDats $ createDatumHashMap @ConwayEra mTxDatum + where + createScriptWit datumHashMap = + let script = Ledger.PlutusScript plutusScript + scriptHashMap = Map.singleton (Ledger.hashScript script) script + in Ledger.AlonzoTxWits mempty mempty scriptHashMap datumHashMap $ Ledger.Redeemers redeemerMap + +createDatumHashMap + :: Ledger.AlonzoEraScript (ToConstrainedEra era) + => Maybe (Ledger.BinaryData (ToConstrainedEra era)) + -> Map (Ledger.DataHash (Ledger.EraCrypto (ToConstrainedEra era))) (Ledger.Data (ToConstrainedEra era)) +createDatumHashMap = + maybe + mempty + (\binaryData -> Map.singleton (Ledger.hashBinaryData binaryData) (Ledger.binaryDataToData binaryData)) + + +createPlutusReferenceScriptWitness + :: Ledger.Script (ToConstrainedEra era) ~ Ledger.AlonzoScript (ToConstrainedEra era) + => Ledger.AlonzoEraScript (ToConstrainedEra era) + => Era era + -> ReferenceTxInput (ToConstrainedEra era) + -> Maybe (Ledger.BinaryData (ToConstrainedEra era)) -- ^ Datum + -> Map (Ledger.PlutusPurpose Ledger.AsIx (ToConstrainedEra era)) (Ledger.Data (ToConstrainedEra era), Ledger.ExUnits) -- ^ Redeemers + -> PlutusScriptWitness era +createPlutusReferenceScriptWitness era txin mTxDatum redeemerMap = + case era of + CurrentEra -> + PlutusScriptWitnessRefInput (createScriptWit (Ledger.TxDats $ createDatumHashMap @BabbageEra mTxDatum)) txin + UpcomingEra -> + PlutusScriptWitnessRefInput (createScriptWit (Ledger.TxDats $ createDatumHashMap @ConwayEra mTxDatum)) txin + where + createScriptWit datumHashMap = + Ledger.AlonzoTxWits mempty mempty mempty datumHashMap $ Ledger.Redeemers redeemerMap + +createSimpleScriptWitness + :: Ledger.AlonzoEraScript (ToConstrainedEra era) + => Ledger.Script (ToConstrainedEra era) ~ Ledger.AlonzoScript (ToConstrainedEra era) + => Ledger.NativeScript (ToConstrainedEra era) ~ Ledger.Timelock (ToConstrainedEra era) + => Era era + -> Ledger.NativeScript (ToConstrainedEra era) + -> SimpleScriptWitness era +createSimpleScriptWitness era simpleScript = case era of + CurrentEra -> SimpleScriptWitness createScriptWit + UpcomingEra -> SimpleScriptWitness createScriptWit + where + createScriptWit = + let script = Ledger.TimelockScript simpleScript + scriptHashMap = Map.singleton (Ledger.hashScript script) script + in Ledger.AlonzoTxWits mempty mempty scriptHashMap mempty (Ledger.Redeemers mempty) + + +createSimpleReferenceScriptWitness + :: Era era + -> ReferenceTxInput (ToConstrainedEra era) + -> SimpleScriptWitness era +createSimpleReferenceScriptWitness era refInput = case era of + CurrentEra -> SimpleScriptWitnessRefInput refInput + UpcomingEra -> SimpleScriptWitnessRefInput refInput + + +data RedeemerConstructionError item container + = ItemToBeWitnessedNotFound item container + + +createTxInRedeemer + :: Ledger.AlonzoEraScript (ToConstrainedEra era) + => Ledger.EraCrypto (ToConstrainedEra era) ~ StandardCrypto + => Era era + -> Ledger.TxIn StandardCrypto -- ^ Input to be witnessed by + -> Set (Ledger.TxIn StandardCrypto) + -> Ledger.BinaryData (ToConstrainedEra era) + -> Ledger.ExUnits + -> Either (RedeemerConstructionError (Ledger.TxIn StandardCrypto) (Set (Ledger.TxIn StandardCrypto))) (SingleRedeemer era) +createTxInRedeemer era toBeWitnessed allTxInputs = + createSingleRedeemerMapEntry era toBeWitnessed allTxInputs Ledger.mkSpendingPurpose + +createVotingRedeemer + :: Ledger.Voter StandardCrypto -- ^ Input to be witnessed by + -> Set (Ledger.Voter StandardCrypto) + -> Ledger.BinaryData (ToConstrainedEra ConwayEra) + -> Ledger.ExUnits + -> Either (RedeemerConstructionError (Ledger.Voter StandardCrypto) (Set (Ledger.Voter StandardCrypto))) (SingleRedeemer ConwayEra) +createVotingRedeemer toBeWitnessed allTxInputs = + createSingleRedeemerMapEntry UpcomingEra toBeWitnessed allTxInputs Ledger.mkVotingPurpose + + + +type SingleRedeemer era = (Map (Ledger.PlutusPurpose Ledger.AsIx (ToConstrainedEra era)) (Ledger.Data (ToConstrainedEra era), Ledger.ExUnits)) + +-- Helper functions +-- TODO: It would be useful to have a type class that +-- maps era -> [Language] i.e allowed script languages in a given era +createSingleRedeemerMapEntry + :: forall item container era. Ledger.Indexable item container + => Ledger.Era (ToConstrainedEra era) + => Era era + -> item -- ^ Item to be witnessed (TxIn, Cert, etc) + -> container -- ^ All items in transaction + -> (Ledger.AsIx Word32 item -> Ledger.PlutusPurpose Ledger.AsIx (ToConstrainedEra era)) + -> Ledger.BinaryData (ToConstrainedEra era) + -> Ledger.ExUnits + -> Either (RedeemerConstructionError item container) (SingleRedeemer era) +createSingleRedeemerMapEntry era toBeWitnessed allThings toPlutusPurpose redeemerBinaryData exunits = + case era of + CurrentEra -> createRedeemer + UpcomingEra -> createRedeemer + where + createRedeemer + :: Either (RedeemerConstructionError item container) (SingleRedeemer era) + createRedeemer = do + let asItem = Ledger.AsItem toBeWitnessed + + index <- maybe + (Left $ ItemToBeWitnessedNotFound toBeWitnessed allThings) + Right $ strictMaybeToMaybe $ Ledger.indexOf asItem allThings + + let plutusPurpose = toPlutusPurpose index + redeemerData = Ledger.binaryDataToData redeemerBinaryData + + return $ Map.singleton plutusPurpose (redeemerData, exunits) + + +getAllPlutusScripts + :: Ledger.EraTxWits (ToConstrainedEra era) + => [PlutusScriptWitness era] + -> [Ledger.Script (ToConstrainedEra era)] +getAllPlutusScripts [] = [] +getAllPlutusScripts plutusScriptWits = + mconcat [ Map.elems $ txWits ^. Ledger.scriptTxWitsL + | PlutusScriptWitness txWits <- plutusScriptWits + ] + +getAllSimpleScripts + :: Ledger.EraTxWits (ToConstrainedEra era) + => [SimpleScriptWitness era] + -> [Ledger.Script (ToConstrainedEra era)] +getAllSimpleScripts [] = [] +getAllSimpleScripts simpleScriptWits = + mconcat [ Map.elems $ txWits ^. Ledger.scriptTxWitsL + | SimpleScriptWitness txWits <- simpleScriptWits + ] + +class ConstrainedDecoder availableera era | availableera -> era where + fromEraCBORConstrained :: (Ledger.Era era, DecCBOR t) => Plain.Decoder s t + +instance ConstrainedDecoder BabbageEra Ledger.Babbage where + fromEraCBORConstrained = Ledger.fromEraCBOR @Ledger.Babbage + +instance ConstrainedDecoder ConwayEra Ledger.Conway where + fromEraCBORConstrained = Ledger.fromEraCBOR @Ledger.Conway + + + diff --git a/cardano-api/internal/Cardano/Api/Experimental/Tx.hs b/cardano-api/internal/Cardano/Api/Experimental/Tx.hs new file mode 100644 index 0000000000..e586d826e8 --- /dev/null +++ b/cardano-api/internal/Cardano/Api/Experimental/Tx.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} + +module Cardano.Api.Experimental.Tx where + +import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Experimental.Eras +import Cardano.Api.Feature +import Data.Bifunctor +import Cardano.Api.ReexposeLedger (StrictMaybe (..), maybeToStrictMaybe) +import qualified Cardano.Api.ReexposeLedger as L +import Cardano.Api.Tx.Body +import Cardano.Api.Tx.Sign + +import qualified Cardano.Ledger.Alonzo.TxBody as L +import qualified Cardano.Ledger.Api as L +import qualified Cardano.Ledger.Conway.TxBody as L +import qualified Cardano.Ledger.Core as Ledger + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Lens.Micro + + + +-- | A transaction that can contain everything +-- except key witnesses +newtype UnsignedTx era + = UnsignedTx (Ledger.Tx (ToConstrainedEra era)) + +newtype UnsignedTxError + = UnsignedTxError TxBodyError + +-- NB: The type classes at the top level type signature here are +-- common to both the current era and the upcoming era. +makeUnsignedTx + :: Ledger.EraCrypto (ToConstrainedEra era) ~ L.StandardCrypto + => L.AlonzoEraTx (ToConstrainedEra era) + => L.BabbageEraTxBody (ToConstrainedEra era) + => ShelleyLedgerEra (AvailableErasToSbe era) ~ ToConstrainedEra era + => Era era + -> TxBodyContent BuildTx (AvailableErasToSbe era) + -> Either UnsignedTxError (UnsignedTx era) +makeUnsignedTx era bc = do + let sbe = protocolVersionToSbe era + + -- cardano-api types + let apiTxOuts = txOuts bc + apiScriptWitnesses = collectTxBodyScriptWitnesses sbe 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) + scripts = convScripts apiScriptWitnesses + languages = convLanguages apiScriptWitnesses + sData = convScriptData sbe apiTxOuts apiScriptWitnesses + + + 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 .~ getScriptIntegrityHash apiProtocolParameters languages sData + & L.withdrawalsTxBodyL .~ withdrawals + & L.certsTxBodyL .~ certs + & L.mintTxBodyL .~ setMint + & L.auxDataHashTxBodyL .~ maybe SNothing (SJust . Ledger.hashTxAuxData) txAuxData + + scriptWitnesses = L.mkBasicTxWits + & L.scriptTxWitsL .~ Map.fromList + [ (L.hashScript sw, sw) + | sw <- scripts + ] + 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 (ToConstrainedEra era) + -> TxBodyContent BuildTx (AvailableErasToSbe era) + -> Either UnsignedTxError (Ledger.TxBody (ToConstrainedEra era)) +eraSpecificLedgerTxBody BabbageEra ledgerbody bc = do + let sbe = protocolVersionToSbe BabbageEra + + setUpdateProposal <- first UnsignedTxError $ convTxUpdateProposal sbe (txUpdateProposal bc) + + return $ ledgerbody & L.updateTxBodyL .~ setUpdateProposal +eraSpecificLedgerTxBody ConwayEra ledgerbody bc = + let propProcedures = txProposalProcedures bc + voteProcedures = txVotingProcedures bc + treasuryDonation = txTreasuryDonation bc + currentTresuryValue = txCurrentTreasuryValue bc + in return $ + 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) + +signTx + :: L.EraTx (ToConstrainedEra era) + => Ledger.EraCrypto (ToConstrainedEra era) ~ L.StandardCrypto + => [KeyWitness (AvailableErasToSbe era)] + -> UnsignedTx era + -> Ledger.Tx (ToConstrainedEra era) +signTx apiKeyWits (UnsignedTx unsigned) = + let currentScriptWitnesses = unsigned ^. L.witsTxL + keyWits = L.mkBasicTxWits + & L.addrTxWitsL + .~ Set.fromList [w | ShelleyKeyWitness _ w <- apiKeyWits] + & L.bootAddrTxWitsL + .~ Set.fromList [w | ShelleyBootstrapWitness _ w <- apiKeyWits] + signedTx = unsigned & L.witsTxL .~ (keyWits <> currentScriptWitnesses) + in signedTx diff --git a/cardano-api/internal/Cardano/Api/Protocol/AvailableEras.hs b/cardano-api/internal/Cardano/Api/Protocol/AvailableEras.hs index 6355885526..a009894e64 100644 --- a/cardano-api/internal/Cardano/Api/Protocol/AvailableEras.hs +++ b/cardano-api/internal/Cardano/Api/Protocol/AvailableEras.hs @@ -1,8 +1,10 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilyDependencies #-} -- UndecidableInstances needed for 9.2.7 and 8.10.7 @@ -12,9 +14,8 @@ -- | This module defines the protocol versions corresponding to the eras in the Cardano blockchain. module Cardano.Api.Protocol.AvailableEras - ( AvailableEras(..) - , pattern CurrentEra - , pattern UpcomingEra + ( BabbageEra + , ConwayEra , Era (..) , ToConstrainedEra , UseEra @@ -30,155 +31,77 @@ import qualified Cardano.Api.Eras.Core as Api import qualified Cardano.Ledger.Babbage as Ledger import qualified Cardano.Ledger.Conway as Ledger -import GHC.TypeLits +import Data.Kind -- | Users typically interact with the latest features on the mainnet or experiment with features -- from the upcoming era. Hence, the protocol versions are limited to the current mainnet era -- and the next era (upcoming era). +data BabbageEra -data AvailableEras - = BabbageEra - | ConwayEra +data ConwayEra -- Allows us to gradually change the api without breaking things. -- This will eventually be removed. -type family AvailableErasToSbe era where +type family AvailableErasToSbe era = (r :: Type) | r -> era where AvailableErasToSbe BabbageEra = Api.BabbageEra AvailableErasToSbe ConwayEra = Api.ConwayEra -type family ToConstrainedEra (era :: AvailableEras) where +type family ToConstrainedEra era = (r :: Type) | r -> era where ToConstrainedEra BabbageEra = Ledger.Babbage ToConstrainedEra ConwayEra = Ledger.Conway -{- | Represents the eras in Cardano's blockchain. - -Instead of enumerating every possible era, we use two constructors: -'CurrentEra' and 'UpcomingEra'. This design simplifies the handling -of eras, especially for 'cardano-api' consumers who are primarily concerned -with the current mainnet era and the next era for an upcoming hardfork. - -Usage: -- 'CurrentEra': Reflects the era currently active on mainnet. -- 'UpcomingEra': Represents the era planned for the next hardfork. - -After a hardfork, 'cardano-api' should be updated promptly to reflect -the new mainnet era in 'CurrentEra'. - --} -data Era (era :: AvailableEras) where - -- | The era currently active on Cardano's mainnet. - CurrentEraInternal :: Era BabbageEra - -- | The era planned for the next hardfork on Cardano's mainnet. - UpcomingEraInternal :: Era ConwayEra - -{- | How to deprecate an era - - 1. Add DEPRECATED pragma to the era type tag. -@ -{-# DEPRECATED BabbageEra "BabbageEra no longer supported, use ConwayEra" #-} -data BabbageEra -@ - - 2. Add a new era type tag. -@ +-- | Represents the eras in Cardano's blockchain. +-- This type represents eras currently on mainnet and new eras which are +-- in development. +-- +-- After a hardfork, the from which we hardfork from gets deprecated and +-- after deprecation period, gets removed. During deprecation period, +-- consumers of cardano-api should update their codebase to the mainnet era. data Era era where -- | The era currently active on Cardano's mainnet. - CurrentEraInternal :: Era ConwayEra - -- | The era planned for the next hardfork on Cardano's mainnet. - UpcomingEraInternal :: Era (UninhabitableType EraCurrentlyNonExistent) -@ - - 3. Update pattern synonyms. -@ -pattern CurrentEra :: Era ConwayEra -pattern CurrentEra = CurrentEraInternal - -pattern UpcomingEra :: Era (UninhabitableType EraCurrentlyNonExistent) -pattern UpcomingEra = UpcomingEraInternal -@ - - 4. Add new 'UseEra' instance and keep the deprecated era's instance. -@ -instance UseEra BabbageEra where - useEra = error "useEra: BabbageEra no longer supported, use ConwayEra" - -instance UseEra ConwayEra where - useEra = CurrentEra -@ - - 5. Update 'protocolVersionToSbe' as follows: -@ -protocolVersionToSbe - :: Era era - -> Maybe (ShelleyBasedEra (AvailableErasToSbe era)) -protocolVersionToSbe CurrentEraInternal = Just ShelleyBasedEraBabbage -protocolVersionToSbe UpcomingEraInternal = Nothing -@ --} - - -{- | 'CurrentEraInternal' and 'UpcomingEraInternal' are for internal use only. -The above restriction combined with the following pattern synonyms -prevents a user from pattern matching on 'Era era' and -avoids the following situation: - -@ -doThing :: Era era -> () -doThing = \case - CurrentEraInternal -> enableFeature - UpcomingEraInternal -> disableFeature -@ + BabbageEra :: Era BabbageEra + -- | The upcoming era in development. + ConwayEra :: Era ConwayEra -Consumers of this library must pick one of the two eras while -this library is responsibile for what happens at the boundary of the eras. --} - --- | 'CurrentEraInternal' and 'UpcomingEraInternal' are for internal use only. --- The above restriction combined with the following pattern synonyms --- prevents a user from pattern matching on 'Era era' and --- avoids the following situation: +-- | How to deprecate an era -- +-- 1. Add DEPRECATED pragma to the era type tag and the era constructor at the same time: -- @ --- doThing :: Era era -> () --- doThing = \case --- CurrentEraInternal -> enableFeature --- UpcomingEraInternal -> disableFeature +-- {-# DEPRECATED BabbageEra "BabbageEra no longer supported, use ConwayEra" #-} +-- data BabbageEra -- @ -- --- Consumers of this library must pick one of the two eras while --- this library is responsibile for what happens at the boundary of the eras. -pattern CurrentEra :: Era BabbageEra -pattern CurrentEra = CurrentEraInternal - -pattern UpcomingEra :: Era ConwayEra -pattern UpcomingEra = UpcomingEraInternal - -{-# COMPLETE CurrentEra, UpcomingEra #-} - +-- 2. Update haddock for the constructor of the deprecated era, mentioning deprecation. +-- +-- @ +-- data Era era where +-- {-# DEPRECATED BabbageEra "BabbageEra no longer supported, use ConwayEra" #-} +-- BabbageEra :: Era BabbageEra +-- -- | The era currently active on Cardano's mainnet. +-- ConwayEra :: Era ConwayEra +-- @ +-- +-- 3. Add new 'UseEra' instance and update the deprecated era instance to produce a compile-time error: +-- @ +-- instance TypeError ('Text "UseEra BabbageEra: Deprecated. Update to ConwayEra") => UseEra BabbageEra where +-- useEra = error "unreachable" +-- +-- instance UseEra ConwayEra where +-- useEra = ConwayEra +-- @ protocolVersionToSbe :: Era era - -> Maybe (ShelleyBasedEra (AvailableErasToSbe era)) -protocolVersionToSbe CurrentEraInternal = Just ShelleyBasedEraBabbage -protocolVersionToSbe UpcomingEraInternal = Nothing + -> ShelleyBasedEra (AvailableErasToSbe era) +protocolVersionToSbe BabbageEra = ShelleyBasedEraBabbage +protocolVersionToSbe ConwayEra = ShelleyBasedEraConway ------------------------------------------------------------------------- -- | Type class interface for the 'Era' type. - class UseEra era where useEra :: Era era instance UseEra BabbageEra where - useEra = CurrentEra - + useEra = BabbageEra instance UseEra ConwayEra where - useEra = UpcomingEra - --- | After a hardfork there is usually no planned upcoming era --- that we are able to experiment with. We force a type era --- in this instance. See docs above. -data EraCurrentlyNonExistent - -type family UninhabitableType a where - UninhabitableType EraCurrentlyNonExistent = - TypeError ('Text "There is currently no planned upcoming era. Use CurrentEra instead.") + useEra = ConwayEra diff --git a/cardano-api/internal/Cardano/Api/Scripts/New.hs b/cardano-api/internal/Cardano/Api/Scripts/New.hs deleted file mode 100644 index 9d6ae7d9f6..0000000000 --- a/cardano-api/internal/Cardano/Api/Scripts/New.hs +++ /dev/null @@ -1,172 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE EmptyDataDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} - -module Cardano.Api.Scripts.New where - -import Cardano.Api.HasTypeProxy -import Cardano.Api.Protocol.AvailableEras -import Cardano.Api.SerialiseCBOR (SerialiseAsCBOR (..)) - -import qualified Cardano.Binary as CBOR -import qualified Cardano.Ledger.Alonzo.Scripts as Ledger -import qualified Cardano.Ledger.Babbage as Ledger -import Cardano.Ledger.Binary -import qualified Cardano.Ledger.Binary.Plain as Plain -import qualified Cardano.Ledger.Conway as Ledger -import qualified Cardano.Ledger.Core as Ledger - -import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as LBS -import Data.Typeable - -{- -In the current api we have PlutusScript which is a wrapper around ShortByteString -We should instead use newtype Plutus from ledger which is the same thing but -there is exposed functionality. -There is mkPlutusScript which will give us the different available scripts -for a given era (if they are available) - -We are going to start with the assumption that the user will know what -script version they are using and will indicate as such. - -I.e we will be removing ScriptInAnyLang because it depends on -the text envelope format and doesn't actually check the -script bytes. - -We have an issue regarding what is and isn't available in the various eras - -We can actually stick to the latest era and the upcoming era. We depend -on ledger to get the available script versions correctly so we should -be able to avoid parameterizing on versions. - --} - --- | This type wraps the serialized scripts (native or plutus) --- for a given era. However we want to restrict the era to the --- latest era (mainnet) and the upcoming era. This removes --- the complexity of deciding which scripts are available in which eras. - -newtype Script (availableera :: AvailableEras) - = Script { unScript :: Ledger.Script (ToConstrainedEra availableera) } - -instance ( HasTypeProxy (Script availableera) - , ToCBOR (Ledger.Script (ToConstrainedEra availableera)) - , Typeable availableera - , ConstrainedDecoder availableera ledgerera - , Ledger.Era ledgerera - , DecCBOR (Ledger.Script (ToConstrainedEra availableera))) - => SerialiseAsCBOR (Script availableera) where - serialiseToCBOR (Script s) = CBOR.serialize' s - - deserialiseFromCBOR _ bs = - Plain.decodeFullDecoder - "Script" - fromCBOR - (LBS.fromStrict bs) :: Either DecoderError (Script availableera) - -instance HasTypeProxy (Script BabbageEra) where - data AsType (Script BabbageEra) = AsMainnetScript - proxyToAsType :: Proxy (Script BabbageEra) -> AsType (Script BabbageEra) - proxyToAsType _ = AsMainnetScript - -instance HasTypeProxy (Script ConwayEra) where - data AsType (Script ConwayEra) = AsUpcomingEraScript - proxyToAsType :: Proxy (Script ConwayEra) -> AsType (Script ConwayEra) - proxyToAsType _ = AsUpcomingEraScript - -instance ( Typeable availableera - , Ledger.Era ledgerera - , DecCBOR (Ledger.Script (ToConstrainedEra availableera)) - , ConstrainedDecoder availableera ledgerera - ) => FromCBOR (Script availableera) where - fromCBOR = Script <$> fromEraCBORConstrained @availableera - -class ConstrainedDecoder (availableera :: AvailableEras) era | availableera -> era where - fromEraCBORConstrained :: (Ledger.Era era, DecCBOR t) => Plain.Decoder s t - -instance ConstrainedDecoder BabbageEra Ledger.Babbage where - fromEraCBORConstrained = Ledger.fromEraCBOR @Ledger.Babbage - -instance ConstrainedDecoder ConwayEra Ledger.Conway where - fromEraCBORConstrained = Ledger.fromEraCBOR @Ledger.Conway - --- You need a function that lets a user decode a script in a given era --- The function must only try to decode script versions available in a given era --- Can we create a type class that enforces the behavior? Or a type family? -{- -data DeserializationError -deserialiseNativeScript - :: AvailableEras - -> ByteString - -> Either DeserializationError (NativeScript (ToConstrainedEra availableera)) - -} - -data NativeScriptDeserializationError - = NotAScript DecoderError - | NotASimpleScript -- We can improve this and potentially - -- tell the consumer its a plutus script - -- and which version it is. - - -deserialiseNativeScript - :: DecCBOR (Ledger.AlonzoScript (ToConstrainedEra availableera)) - => Era availableera - -> ByteString - -> Either NativeScriptDeserializationError (Ledger.NativeScript (ToConstrainedEra availableera)) -deserialiseNativeScript availableEra bs = - case availableEra of - CurrentEraInternal -> deserialise AsMainnetScript bs - UpcomingEraInternal -> deserialise AsUpcomingEraScript bs - where - deserialise - :: SerialiseAsCBOR (Script availableera) - => Ledger.EraScript (ToConstrainedEra availableera) - => AsType (Script availableera) - -> ByteString - -> Either NativeScriptDeserializationError (Ledger.NativeScript (ToConstrainedEra availableera)) - deserialise as bs' = - case deserialiseFromCBOR as bs' of - Right s -> case Ledger.getNativeScript $ unScript s of - Just nScript -> Right nScript - Nothing -> Left NotASimpleScript - Left e -> Left $ NotAScript e - -data PlutusScriptDeserializationError - = NotAPlutusScript - | NotAnyScript DecoderError - -deserialisePlutusScript - :: DecCBOR (Ledger.AlonzoScript (ToConstrainedEra availableera)) - => Era availableera - -> ByteString - -> Either PlutusScriptDeserializationError (Ledger.PlutusScript (ToConstrainedEra availableera)) -deserialisePlutusScript era bs = - case era of - CurrentEraInternal -> deserialise AsMainnetScript bs - UpcomingEraInternal -> deserialise AsUpcomingEraScript bs - where - deserialise - :: SerialiseAsCBOR (Script availableera) - => Ledger.AlonzoEraScript (ToConstrainedEra availableera) - => AsType (Script availableera) - -> ByteString - -> Either PlutusScriptDeserializationError (Ledger.PlutusScript (ToConstrainedEra availableera)) - deserialise as bs' = - case deserialiseFromCBOR as bs' of - Right s -> case Ledger.toPlutusScript $ unScript s of - Just nScript -> Right nScript - Nothing -> Left NotAPlutusScript - Left e -> Left $ NotAnyScript e - diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs index e5146e0105..358d65b480 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Body.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Body.hs @@ -132,6 +132,28 @@ module Cardano.Api.Tx.Body , scriptDataToInlineDatum -- * Internal conversion functions & types + , convCertificates + , convCollateralTxIns + , convExtraKeyWitnesses + , convLanguages + , convMintValue + , convProposalProcedures + , convReferenceInputs + , convReturnCollateral + , convScripts + , convScriptData + , convTotalCollateral + , convTransactionFee + , convTxIns + , convTxOuts + , convTxUpdateProposal + , convValidityLowerBound + , convValidityUpperBound + , convVotingProcedures + , convWithdrawals + , getScriptIntegrityHash + , mkCommonTxBody + , toAuxiliaryData , toByronTxId , toShelleyTxId , toShelleyTxIn