Split compatible transaction building into separate building and witn…

…essing functions
IntersectMBO · Feb 17, 2025 · 4bdc261 · 4bdc261
1 parent 5858356
commit 4bdc261
Show file tree

Hide file tree

Showing 4 changed files with 77 additions and 45 deletions.
diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs
@@ -461,7 +461,9 @@ module Cardano.Api
   , makeByronKeyWitness
   , ShelleyWitnessSigningKey (..)
   , makeShelleyKeyWitness
+  , makeShelleyKeyWitness'
   , makeShelleyBootstrapWitness
+  , makeShelleyBasedBootstrapWitness
 
     -- * Transaction metadata
 

diff --git a/cardano-api/src/Cardano/Api/Internal/Tx/Compatible.hs b/cardano-api/src/Cardano/Api/Internal/Tx/Compatible.hs
@@ -10,7 +10,8 @@
 module Cardano.Api.Internal.Tx.Compatible
   ( AnyProtocolUpdate (..)
   , AnyVote (..)
-  , createCompatibleSignedTx
+  , createCompatibleTx
+  , addWitnesses
   )
 where
 
@@ -25,7 +26,7 @@ import           Cardano.Api.Internal.Eon.ShelleyToBabbageEra
 import           Cardano.Api.Internal.Eras
 import           Cardano.Api.Internal.ProtocolParameters
 import           Cardano.Api.Internal.Script
-import           Cardano.Api.Internal.Tx.Body
+import           Cardano.Api.Internal.Tx.Body hiding (txMetadata)
 import           Cardano.Api.Internal.Tx.Sign
 import           Cardano.Api.Internal.Value
 
@@ -60,19 +61,19 @@ data AnyVote era where
     -> AnyVote era
   NoVotes :: AnyVote era
 
-createCompatibleSignedTx
+-- | Create a transaction in any shelley based era
+createCompatibleTx
   :: forall era
    . ShelleyBasedEra era
   -> [TxIn]
   -> [TxOut CtxTx era]
-  -> [KeyWitness era]
   -> Lovelace
   -- ^ Fee
   -> AnyProtocolUpdate era
   -> AnyVote era
   -> TxCertificates BuildTx era
   -> Either ProtocolParametersConversionError (Tx era)
-createCompatibleSignedTx sbe ins outs witnesses txFee' anyProtocolUpdate anyVote txCertificates' =
+createCompatibleTx sbe ins outs txFee' anyProtocolUpdate anyVote txCertificates' =
   shelleyBasedEraConstraints sbe $ do
     (updateTxBody, extraScriptWitnesses) <-
       case anyProtocolUpdate of
@@ -125,7 +126,7 @@ createCompatibleSignedTx sbe ins outs witnesses txFee' anyProtocolUpdate anyVote
       . ShelleyTx sbe
       $ L.mkBasicTx txbody
         & L.witsTxL
-          .~ allWitnesses (apiScriptWitnesses <> extraScriptWitnesses) allShelleyToBabbageWitnesses
+          %~ setScriptWitnesses (apiScriptWitnesses <> extraScriptWitnesses)
         & updateVotingProcedures
  where
   era = toCardanoEra sbe
@@ -164,11 +165,11 @@ createCompatibleSignedTx sbe ins outs witnesses txFee' anyProtocolUpdate anyVote
     :: [(ScriptWitnessIndex, Certificate era, StakeCredential, Witness WitCtxStake era)]
   indexedTxCerts = indexTxCertificates txCertificates'
 
-  allWitnesses
+  setScriptWitnesses
     :: [(ScriptWitnessIndex, AnyScriptWitness era)]
     -> L.TxWits (ShelleyLedgerEra era)
     -> L.TxWits (ShelleyLedgerEra era)
-  allWitnesses scriptWitnesses =
+  setScriptWitnesses scriptWitnesses =
     appEndos
       [ monoidForEraInEon
           era
@@ -191,21 +192,6 @@ createCompatibleSignedTx sbe ins outs witnesses txFee' anyProtocolUpdate anyVote
           )
       ]
 
-  allShelleyToBabbageWitnesses
-    :: L.EraTxWits (ShelleyLedgerEra era)
-    => L.EraCrypto (ShelleyLedgerEra era) ~ L.StandardCrypto
-    => L.TxWits (ShelleyLedgerEra era)
-  allShelleyToBabbageWitnesses = do
-    let shelleyKeywitnesses =
-          fromList [w | ShelleyKeyWitness _ w <- witnesses]
-    let shelleyBootstrapWitnesses =
-          fromList [w | ShelleyBootstrapWitness _ w <- witnesses]
-    L.mkBasicTxWits
-      & L.addrTxWitsL
-        .~ shelleyKeywitnesses
-      & L.bootAddrTxWitsL
-        .~ shelleyBootstrapWitnesses
-
 createCommonTxBody
   :: HasCallStack
   => ShelleyBasedEra era
@@ -224,3 +210,31 @@ createCommonTxBody era ins outs txFee' =
             .~ Seq.fromList txOuts'
           & L.feeTxBodyL
             .~ txFee'
+
+-- | Add provided witnesses to the transaction
+addWitnesses
+  :: forall era
+   . [KeyWitness era]
+  -> Tx era
+  -> Tx era
+  -- ^ a signed transaction
+addWitnesses witnesses (ShelleyTx sbe tx) =
+  shelleyBasedEraConstraints sbe $
+    ShelleyTx sbe txCommon
+ where
+  txCommon
+    :: forall ledgerera
+     . ShelleyLedgerEra era ~ ledgerera
+    => L.EraCrypto ledgerera ~ L.StandardCrypto
+    => L.EraTx ledgerera
+    => L.Tx ledgerera
+  txCommon =
+    tx
+      & L.witsTxL
+        %~ ( ( L.addrTxWitsL
+                 %~ (<> fromList [w | ShelleyKeyWitness _ w <- witnesses])
+             )
+               . ( L.bootAddrTxWitsL
+                     %~ (<> fromList [w | ShelleyBootstrapWitness _ w <- witnesses])
+                 )
+           )
diff --git a/cardano-api/src/Cardano/Api/Internal/Tx/Sign.hs b/cardano-api/src/Cardano/Api/Internal/Tx/Sign.hs
@@ -2,7 +2,6 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
@@ -14,8 +13,6 @@
 -- not export any from this API. We also use them unticked as nature intended.
 {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
 
-{- HLINT ignore "Avoid lambda using `infix`" -}
-
 -- | Complete, signed transactions
 module Cardano.Api.Internal.Tx.Sign
   ( -- * Signing transactions
@@ -43,8 +40,11 @@ module Cardano.Api.Internal.Tx.Sign
   , makeByronKeyWitness
   , ShelleyWitnessSigningKey (..)
   , makeShelleyKeyWitness
+  , makeShelleyKeyWitness'
   , WitnessNetworkIdOrByronAddress (..)
   , makeShelleyBootstrapWitness
+  -- TOOD rename
+  , makeShelleyBasedBootstrapWitness
   , makeShelleySignature
   , getShelleyKeyWitnessVerificationKey
   , getTxBodyAndWitnesses
@@ -86,6 +86,7 @@ import           Cardano.Api.Internal.Keys.Shelley
 import           Cardano.Api.Internal.NetworkId
 import           Cardano.Api.Internal.SerialiseCBOR
 import           Cardano.Api.Internal.SerialiseTextEnvelope
+import qualified Cardano.Api.Ledger.Lens as A
 
 import qualified Cardano.Chain.Common as Byron
 import qualified Cardano.Chain.UTxO as Byron
@@ -127,6 +128,12 @@ data Tx era where
     -> L.Tx (ShelleyLedgerEra era)
     -> Tx era
 
+-- | This pattern will be deprecated in the future. We advise against introducing new usage of it.
+pattern Tx :: TxBody era -> [KeyWitness era] -> Tx era
+pattern Tx txbody ws <- (getTxBodyAndWitnesses -> (txbody, ws))
+  where
+    Tx txbody ws = makeSignedTransaction ws txbody
+
 instance Show (InAnyCardanoEra Tx) where
   show (InAnyCardanoEra _ tx) = show tx
 
@@ -749,12 +756,6 @@ instance IsCardanoEra era => HasTextEnvelope (KeyWitness era) where
 getTxBodyAndWitnesses :: Tx era -> (TxBody era, [KeyWitness era])
 getTxBodyAndWitnesses tx = (getTxBody tx, getTxWitnesses tx)
 
--- | This pattern will be deprecated in the future. We advise against introducing new usage of it.
-pattern Tx :: TxBody era -> [KeyWitness era] -> Tx era
-pattern Tx txbody ws <- (getTxBodyAndWitnesses -> (txbody, ws))
-  where
-    Tx txbody ws = makeSignedTransaction ws txbody
-
 {-# COMPLETE Tx #-}
 
 data ShelleyWitnessSigningKey
@@ -1106,19 +1107,27 @@ makeShelleyKeyWitness
   -> TxBody era
   -> ShelleyWitnessSigningKey
   -> KeyWitness era
-makeShelleyKeyWitness sbe = \case
-  ShelleyTxBody _ txbody _ _ _ _ ->
-    shelleyBasedEraConstraints sbe $
-      let txhash :: Shelley.Hash StandardCrypto Ledger.EraIndependentTxBody
-          txhash = Ledger.extractHash @StandardCrypto (Ledger.hashAnnotated txbody)
-       in -- To allow sharing of the txhash computation across many signatures we
-          -- define and share the txhash outside the lambda for the signing key:
-          \wsk ->
-            let sk = toShelleySigningKey wsk
-                vk = getShelleyKeyWitnessVerificationKey sk
-                signature = makeShelleySignature txhash sk
-             in ShelleyKeyWitness sbe $
-                  L.WitVKey vk signature
+makeShelleyKeyWitness sbe (ShelleyTxBody _ txBody _ _ _ _) =
+  makeShelleyKeyWitness' sbe (A.TxBody txBody)
+
+makeShelleyKeyWitness'
+  :: forall era
+   . ()
+  => ShelleyBasedEra era
+  -> A.TxBody era
+  -> ShelleyWitnessSigningKey
+  -> KeyWitness era
+makeShelleyKeyWitness' sbe (A.TxBody txBody) wsk =
+  shelleyBasedEraConstraints sbe $ do
+    let txhash :: Shelley.Hash StandardCrypto Ledger.EraIndependentTxBody
+        txhash = Ledger.extractHash @StandardCrypto (Ledger.hashAnnotated txBody)
+        -- To allow sharing of the txhash computation across many signatures we
+        -- define and share the txhash outside the lambda for the signing key:
+        sk = toShelleySigningKey wsk
+        vk = getShelleyKeyWitnessVerificationKey sk
+        signature = makeShelleySignature txhash sk
+    ShelleyKeyWitness sbe $
+      L.WitVKey vk signature
 
 toShelleySigningKey :: ShelleyWitnessSigningKey -> ShelleySigningKey
 toShelleySigningKey key = case key of

diff --git a/cardano-api/src/Cardano/Api/Ledger/Lens.hs b/cardano-api/src/Cardano/Api/Ledger/Lens.hs
@@ -22,6 +22,7 @@ module Cardano.Api.Ledger.Lens
   , ttlAsInvalidHereAfterTxBodyL
   , updateTxBodyL
   , txBodyL
+  , txToTxBodyL
   , mintTxBodyL
   , scriptIntegrityHashTxBodyL
   , collateralInputsTxBodyL
@@ -83,6 +84,12 @@ strictMaybeL = lens g s
   s :: StrictMaybe a -> Maybe a -> StrictMaybe a
   s _ = maybe SNothing SJust
 
+txToTxBodyL :: ShelleyBasedEra era -> Lens' (L.Tx (ShelleyLedgerEra era)) (TxBody era)
+txToTxBodyL sbe = shelleyBasedEraConstraints sbe $ L.bodyTxL . reTxBodyL
+ where
+  reTxBodyL :: Lens' (L.TxBody (ShelleyLedgerEra era)) (TxBody era)
+  reTxBodyL = lens TxBody (\_ x -> unTxBody x)
+
 txBodyL :: Lens' (TxBody era) (L.TxBody (ShelleyLedgerEra era))
 txBodyL = lens unTxBody (\_ x -> TxBody x)