Merge pull request #750 from IntersectMBO/mgalazyn/fix/compatible-tx-…

…build Split compatible transaction building and signing
IntersectMBO · Feb 20, 2025 · a1ba5b5 · a1ba5b5
2 parents b61aa25 + 9d4a145
commit a1ba5b5
Show file tree

Hide file tree

Showing 5 changed files with 71 additions and 48 deletions.
diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal
@@ -179,6 +179,7 @@ library
   other-modules:
     Cardano.Api.Internal.Anchor
     Cardano.Api.Internal.Certificate
+    Cardano.Api.Internal.Compatible.Tx
     Cardano.Api.Internal.Convenience.Construction
     Cardano.Api.Internal.Convenience.Query
     Cardano.Api.Internal.DeserialiseAnyOf
@@ -247,7 +248,6 @@ library
     Cardano.Api.Internal.SpecialByron
     Cardano.Api.Internal.StakePoolMetadata
     Cardano.Api.Internal.Tx.Body
-    Cardano.Api.Internal.Tx.Compatible
     Cardano.Api.Internal.Tx.UTxO
     Cardano.Api.Internal.TxIn
     Cardano.Api.Internal.TxMetadata

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/Compatible.hs b/cardano-api/src/Cardano/Api/Compatible.hs
@@ -1,6 +1,6 @@
 module Cardano.Api.Compatible
-  ( module Cardano.Api.Internal.Tx.Compatible
+  ( module Cardano.Api.Internal.Compatible.Tx
   )
 where
 
-import Cardano.Api.Internal.Tx.Compatible
+import Cardano.Api.Internal.Compatible.Tx
diff --git a/...src/Cardano/Api/Internal/Tx/Compatible.hs → ...src/Cardano/Api/Internal/Compatible/Tx.hs b/...src/Cardano/Api/Internal/Tx/Compatible.hs → ...src/Cardano/Api/Internal/Compatible/Tx.hs
@@ -7,10 +7,11 @@
 
 -- | This module provides a way to construct a simple transaction over all eras.
 -- It is exposed for testing purposes only.
-module Cardano.Api.Internal.Tx.Compatible
+module Cardano.Api.Internal.Compatible.Tx
   ( AnyProtocolUpdate (..)
   , AnyVote (..)
-  , createCompatibleSignedTx
+  , createCompatibleTx
+  , addWitnesses
   )
 where
 
@@ -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,10 @@ module Cardano.Api.Internal.Tx.Sign
   , makeByronKeyWitness
   , ShelleyWitnessSigningKey (..)
   , makeShelleyKeyWitness
+  , makeShelleyKeyWitness'
   , WitnessNetworkIdOrByronAddress (..)
   , makeShelleyBootstrapWitness
+  , makeShelleyBasedBootstrapWitness
   , makeShelleySignature
   , getShelleyKeyWitnessVerificationKey
   , getTxBodyAndWitnesses
@@ -127,6 +126,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 +754,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 +1105,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 txBody
+
+makeShelleyKeyWitness'
+  :: forall era
+   . ()
+  => ShelleyBasedEra era
+  -> L.TxBody (ShelleyLedgerEra era)
+  -> ShelleyWitnessSigningKey
+  -> KeyWitness era
+makeShelleyKeyWitness' sbe 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