Add Cardano.Api.Tx.Compatible

This module exposes createCompatibleSignedTx which is intended to be
used in testing only. It allows creation of simple unbalanced
transactions that can submit protocol updates in any era.

cardano-api/cardano-api.cabal

@@ -144,6 +144,7 @@ library internal
     Cardano.Api.SpecialByron
     Cardano.Api.StakePoolMetadata
     Cardano.Api.Tx.Body
+    Cardano.Api.Tx.Compatible
     Cardano.Api.Tx.Sign
     Cardano.Api.TxIn
     Cardano.Api.TxMetadata
@@ -236,6 +237,7 @@ library
     Cardano.Api.Byron
     Cardano.Api.ChainSync.Client
     Cardano.Api.ChainSync.ClientPipelined
+    Cardano.Api.Compatible
     Cardano.Api.Crypto.Ed25519Bip32
     Cardano.Api.Experimental
     Cardano.Api.Ledger

cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs

@@ -216,6 +216,7 @@ type ShelleyBasedEraConstraints era =
   , L.EraTxBody (ShelleyLedgerEra era)
   , L.EraTxOut (ShelleyLedgerEra era)
   , L.EraUTxO (ShelleyLedgerEra era)
+  , L.EraTxWits (ShelleyLedgerEra era)
   , L.HashAnnotated (L.TxBody (ShelleyLedgerEra era)) L.EraIndependentTxBody L.StandardCrypto
   , L.ShelleyEraTxCert (ShelleyLedgerEra era)
   , FromCBOR (Consensus.ChainDepState (ConsensusProtocol era))

cardano-api/internal/Cardano/Api/Tx/Compatible.hs

@@ -0,0 +1,166 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeOperators #-}
+
+-- | This module provides a way to construct a simple transaction over all eras.
+-- It is exposed for testing purposes only.
+module Cardano.Api.Tx.Compatible
+  ( AnyProtocolParametersUpdate (..)
+  , createCompatibleSignedTx
+  )
+where
+
+import           Cardano.Api.Address
+import           Cardano.Api.Eon.ConwayEraOnwards
+import           Cardano.Api.Eon.ShelleyBasedEra
+import           Cardano.Api.Eon.ShelleyToBabbageEra
+import           Cardano.Api.Governance.Actions.ProposalProcedure
+import           Cardano.Api.Hash
+import           Cardano.Api.Keys.Shelley
+import           Cardano.Api.ProtocolParameters
+import           Cardano.Api.Tx.Body (TxOut, toShelleyTxOutAny)
+import           Cardano.Api.Tx.Sign
+import           Cardano.Api.TxIn
+import           Cardano.Api.Value
+
+import qualified Cardano.Ledger.Api as L
+import qualified Cardano.Ledger.BaseTypes as L
+import qualified Cardano.Ledger.Coin as L
+
+import           Data.Maybe.Strict
+import qualified Data.OSet.Strict as OSet
+import qualified Data.Sequence.Strict as Seq
+import           Data.Set (fromList)
+import           Lens.Micro
+
+data AnyProtocolParametersUpdate era where
+  ShelleyToBabbagePParamsUpdate
+    :: ShelleyToBabbageEra era
+    -> EpochNo
+    -> [Hash GenesisKey]
+    -> EraBasedProtocolParametersUpdate era
+    -> AnyProtocolParametersUpdate era
+  ConwayEraOnwardsPParamsUpdate
+    :: ConwayEraOnwards era
+    -> StrictMaybe (L.GovPurposeId L.PParamUpdatePurpose (ShelleyLedgerEra era))
+    -- ^ Previous governance id
+    -> !(StrictMaybe (L.ScriptHash L.StandardCrypto))
+    -- ^ Constitutional script hash
+    -> EraBasedProtocolParametersUpdate era
+    -- ^ Protocol parameters update
+    -> L.Network
+    -> L.Coin
+    -- ^ Deposit in lovelace
+    -> L.Anchor L.StandardCrypto
+    -- ^ Anchor
+    -> StakeCredential
+    -- ^ Deposit return stake credential
+    -> AnyProtocolParametersUpdate era
+  NoPParamsUpdate
+    :: ShelleyBasedEra era
+    -> AnyProtocolParametersUpdate era
+
+createCompatibleSignedTx
+  :: forall era ctx
+   . ShelleyBasedEra era
+  -> [TxIn]
+  -> [TxOut ctx era]
+  -> [KeyWitness era]
+  -> Lovelace
+  -- ^ Fee
+  -> AnyProtocolParametersUpdate era
+  -> Either ProtocolParametersConversionError (Tx era)
+createCompatibleSignedTx sbeF ins outs witnesses txFee' anyProtocolParametersUpdate =
+  shelleyBasedEraConstraints sbeF $
+    case anyProtocolParametersUpdate of
+      ShelleyToBabbagePParamsUpdate shelleyToBabbageEra expirationEpoch genKeyHashes pparamsUpdate -> do
+        let sbe = shelleyToBabbageEraToShelleyBasedEra shelleyToBabbageEra
+            update = fromLedgerPParamsUpdate sbe $ createEraBasedProtocolParamUpdate sbe pparamsUpdate
+            updateProposal = makeShelleyUpdateProposal update genKeyHashes expirationEpoch
+
+        ledgerPParamsUpdate <- toLedgerUpdate sbe updateProposal
+
+        let txbody = createCommonTxBody sbe ins outs txFee'
+            bodyWithProtocolUpdate =
+              shelleyToBabbageEraConstraints shelleyToBabbageEra $
+                txbody & L.updateTxBodyL .~ SJust ledgerPParamsUpdate
+            finalTx =
+              L.mkBasicTx bodyWithProtocolUpdate
+                & L.witsTxL .~ shelleyToBabbageEraConstraints shelleyToBabbageEra allKeyWitnesses
+
+        return $ ShelleyTx sbe finalTx
+      NoPParamsUpdate sbe -> do
+        let txbody = createCommonTxBody sbe ins outs txFee'
+            finalTx = L.mkBasicTx txbody & L.witsTxL .~ shelleyBasedEraConstraints sbe allKeyWitnesses
+
+        return $ ShelleyTx sbe finalTx
+      ConwayEraOnwardsPParamsUpdate
+        conwayOnwards
+        mPrevGovId
+        mGovScriptHash
+        update
+        nId
+        deposit
+        anchor
+        depositReturnCred -> do
+          let sbe = conwayEraOnwardsToShelleyBasedEra conwayOnwards
+              pparamsUpdate = createEraBasedProtocolParamUpdate sbe update
+              updatePParamsGovAction = UpdatePParams mPrevGovId pparamsUpdate mGovScriptHash
+              updateProposalProcedure =
+                unProposal $
+                  createProposalProcedure
+                    sbe
+                    nId
+                    deposit
+                    depositReturnCred
+                    updatePParamsGovAction
+                    anchor
+              txbody =
+                conwayEraOnwardsConstraints conwayOnwards $
+                  createCommonTxBody sbe ins outs txFee'
+                    & L.proposalProceduresTxBodyL
+                      .~ OSet.singleton updateProposalProcedure
+
+              finalTx =
+                L.mkBasicTx txbody
+                  & L.witsTxL
+                    .~ conwayEraOnwardsConstraints conwayOnwards allKeyWitnesses
+
+          return $ ShelleyTx sbe finalTx
+ where
+  shelleyKeywitnesses =
+    fromList [w | ShelleyKeyWitness _ w <- witnesses]
+
+  shelleyBootstrapWitnesses =
+    fromList [w | ShelleyBootstrapWitness _ w <- witnesses]
+
+  allKeyWitnesses
+    :: L.EraTxWits (ShelleyLedgerEra era)
+    => L.EraCrypto (ShelleyLedgerEra era) ~ L.StandardCrypto
+    => L.TxWits (ShelleyLedgerEra era)
+  allKeyWitnesses =
+    L.mkBasicTxWits
+      & L.addrTxWitsL
+        .~ shelleyKeywitnesses
+      & L.bootAddrTxWitsL
+        .~ shelleyBootstrapWitnesses
+
+createCommonTxBody
+  :: ShelleyBasedEra era
+  -> [TxIn]
+  -> [TxOut ctx era]
+  -> Lovelace
+  -> L.TxBody (ShelleyLedgerEra era)
+createCommonTxBody era ins outs txFee' =
+  let txIns = map toShelleyTxIn ins
+      txOuts = map (toShelleyTxOutAny era) outs
+   in shelleyBasedEraConstraints era $
+        L.mkBasicTxBody
+          & L.inputsTxBodyL
+            .~ fromList txIns
+          & L.outputsTxBodyL
+            .~ Seq.fromList txOuts
+          & L.feeTxBodyL
+            .~ txFee'

cardano-api/src/Cardano/Api/Compatible.hs

@@ -0,0 +1,6 @@
+module Cardano.Api.Compatible
+  ( module Cardano.Api.Tx.Compatible
+  )
+where
+
+import           Cardano.Api.Tx.Compatible