Fix witness error in compatible transaction transaction-sign in shell…

…ey era

Add test: compatible shelley transaction signed-transaction results in different witnesses than legacy command

t pus; On branch mgalazyn/test/compatible-tx-sign-different-witnesses

cardano-cli/src/Cardano/CLI/Compatible/Transaction.hs

@@ -270,67 +270,24 @@ runCompatibleTransactionCmd
           )
           sbe
 
-      let certsRefInputs =
-            [ refInput
-            | (_, Just sWit) <- certsAndMaybeScriptWits
-            , refInput <- maybeToList $ getScriptWitnessReferenceInput sWit
-            ]
-
-          votesRefInputs =
-            [ refInput
-            | VotingProcedures _ (TxVotingProcedures _ (BuildTxWith voteMap)) <- [votes]
-            , sWit <- Map.elems voteMap
-            , refInput <- maybeToList $ getScriptWitnessReferenceInput sWit
-            ]
+    let txCerts = mkTxCertificates sbe certsAndMaybeScriptWits
 
-          proposalsRefInputs =
-            [ refInput
-            | ProposalProcedures _ (TxProposalProcedures proposalMap) <- [protocolUpdates]
-            , BuildTxWith (Just sWit) <- map snd $ toList proposalMap
-            , refInput <- maybeToList $ getScriptWitnessReferenceInput sWit
-            ]
+    transaction@(ShelleyTx _ ledgerTx) <-
+      firstExceptT CompatiblePParamsConversionError . hoistEither $
+        createCompatibleTx sbe ins allOuts fee protocolUpdates votes txCerts
 
-      validatedRefInputs <-
-        fromEitherCli . validateTxInsReference $
-          certsRefInputs <> votesRefInputs <> proposalsRefInputs
-      let txCerts = mkTxCertificates sbe certsAndMaybeScriptWits
-
-      -- this body is only for witnesses
-      apiTxBody <-
-        fromEitherCli $
-          createTransactionBody sbe $
-            defaultTxBodyContent sbe
-              & setTxIns (map (,BuildTxWith (KeyWitness KeyWitnessForSpending)) ins)
-              & setTxOuts allOuts
-              & setTxFee (TxFeeExplicit sbe fee)
-              & setTxCertificates txCerts
-              & setTxInsReference validatedRefInputs
+    let txBody = ledgerTx ^. A.txToTxBodyL sbe
 
       let (sksByron, sksShelley) = partitionSomeWitnesses $ map categoriseSomeSigningWitness sks
 
-      byronWitnesses <-
-        fromEitherCli $
-          mkShelleyBootstrapWitnesses sbe mNetworkId apiTxBody sksByron
-
-      let newShelleyKeyWits = map (makeShelleyKeyWitness sbe apiTxBody) sksShelley
-          allKeyWits = newShelleyKeyWits ++ byronWitnesses
-
-      signedTx <-
-        fromEitherCli $
-          createCompatibleSignedTx sbe ins allOuts allKeyWits fee protocolUpdates votes txCerts
+    byronWitnesses <-
+      firstExceptT CompatibleBootstrapWitnessError . liftEither $
+        forM sksByron $
+          mkShelleyBootstrapWitness sbe mNetworkId txBody
 
-      fromEitherIOCli $
+    firstExceptT CompatibleFileError $
+      newExceptT $
         writeTxFileTextEnvelopeCddl sbe outputFp signedTx
-   where
-    validateTxInsReference
-      :: [TxIn]
-      -> Either TxCmdError (TxInsReference era)
-    validateTxInsReference [] = return TxInsReferenceNone
-    validateTxInsReference allRefIns = do
-      let era = toCardanoEra era
-          eraMismatchError = Left $ TxCmdTxFeatureMismatch (anyCardanoEra era) TxFeatureReferenceInputs
-      w <- maybe eraMismatchError Right $ forEraMaybeEon era
-      pure $ TxInsReference w allRefIns
 
 readUpdateProposalFile
   :: Featured ShelleyToBabbageEra era (Maybe UpdateProposalFile)

cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs

@@ -18,8 +18,7 @@
 {- HLINT ignore "Avoid lambda using `infix`" -}
 
 module Cardano.CLI.EraBased.Run.Transaction
-  ( mkShelleyBootstrapWitnesses
-  , partitionSomeWitnesses
+  ( partitionSomeWitnesses
   , runTransactionCmds
   , runTransactionBuildCmd
   , runTransactionBuildRawCmd
@@ -1449,9 +1448,9 @@ runTransactionSignCmd
 runTransactionSignCmd
   Cmd.TransactionSignCmdArgs
     { txOrTxBodyFile = txOrTxBody
-    , witnessSigningData = witnessSigningData
-    , mNetworkId = mNetworkId
-    , outTxFile = outTxFile
+    , witnessSigningData
+    , mNetworkId
+    , outTxFile
     } = do
     sks <- forM witnessSigningData $ \d ->
       lift (readWitnessSigningData d)
@@ -1464,17 +1463,18 @@ runTransactionSignCmd
         inputTxFile <- liftIO $ fileOrPipe inputTxFilePath
         anyTx <- lift (readFileTx inputTxFile) & onLeft (left . TxCmdTextEnvCddlError)
 
-        InAnyShelleyBasedEra sbe tx <- pure anyTx
+        InAnyShelleyBasedEra sbe tx@(ShelleyTx _ ledgerTx) <- pure anyTx
 
-        let (txbody, existingTxKeyWits) = getTxBodyAndWitnesses tx
+        let (apiTxBody, existingTxKeyWits) = getTxBodyAndWitnesses tx
 
         byronWitnesses <-
-          pure (mkShelleyBootstrapWitnesses sbe mNetworkId txbody sksByron)
-            & onLeft (left . TxCmdBootstrapWitnessError)
+          firstExceptT TxCmdBootstrapWitnessError . liftEither $
+            forM sksByron $
+              mkShelleyBootstrapWitness sbe mNetworkId (ledgerTx ^. A.txToTxBodyL sbe)
 
-        let newShelleyKeyWits = map (makeShelleyKeyWitness sbe txbody) sksShelley
+        let newShelleyKeyWits = map (makeShelleyKeyWitness sbe apiTxBody) sksShelley
             allKeyWits = existingTxKeyWits ++ newShelleyKeyWits ++ byronWitnesses
-            signedTx = makeSignedTransaction allKeyWits txbody
+            signedTx = makeSignedTransaction allKeyWits apiTxBody
 
         lift (writeTxFileTextEnvelopeCddl sbe outTxFile signedTx)
           & onLeft (left . TxCmdWriteFileError)
@@ -1486,14 +1486,14 @@ runTransactionSignCmd
 
         case unwitnessed of
           IncompleteCddlTxBody anyTxBody -> do
-            InAnyShelleyBasedEra sbe txbody <- pure anyTxBody
+            InAnyShelleyBasedEra sbe txbody@(ShelleyTxBody _ ledgerTxBody _ _ _ _) <- pure anyTxBody
 
             -- Byron witnesses require the network ID. This can either be provided
             -- directly or derived from a provided Byron address.
             byronWitnesses <-
-              firstExceptT TxCmdBootstrapWitnessError
-                . hoistEither
-                $ mkShelleyBootstrapWitnesses sbe mNetworkId txbody sksByron
+              firstExceptT TxCmdBootstrapWitnessError . liftEither $
+                forM sksByron $
+                  mkShelleyBootstrapWitness sbe mNetworkId (A.TxBody ledgerTxBody)
 
             let shelleyKeyWitnesses = map (makeShelleyKeyWitness sbe txbody) sksShelley
                 tx = makeSignedTransaction (byronWitnesses ++ shelleyKeyWitnesses) txbody
@@ -1764,34 +1764,6 @@ partitionSomeWitnesses = reversePartitionedWits . Foldable.foldl' go mempty
       AShelleyKeyWitness shelleyKeyWit ->
         (byronAcc, shelleyKeyWit : shelleyKeyAcc)
 
--- | Construct a Shelley bootstrap witness (i.e. a Byron key witness in the
--- Shelley era).
-mkShelleyBootstrapWitness
-  :: ()
-  => ShelleyBasedEra era
-  -> Maybe NetworkId
-  -> TxBody era
-  -> ShelleyBootstrapWitnessSigningKeyData
-  -> Either BootstrapWitnessError (KeyWitness era)
-mkShelleyBootstrapWitness _ Nothing _ (ShelleyBootstrapWitnessSigningKeyData _ Nothing) =
-  Left MissingNetworkIdOrByronAddressError
-mkShelleyBootstrapWitness sbe (Just nw) txBody (ShelleyBootstrapWitnessSigningKeyData skey Nothing) =
-  Right $ makeShelleyBootstrapWitness sbe (Byron.WitnessNetworkId nw) txBody skey
-mkShelleyBootstrapWitness sbe _ txBody (ShelleyBootstrapWitnessSigningKeyData skey (Just addr)) =
-  Right $ makeShelleyBootstrapWitness sbe (Byron.WitnessByronAddress addr) txBody skey
-
--- | Attempt to construct Shelley bootstrap witnesses until an error is
--- encountered.
-mkShelleyBootstrapWitnesses
-  :: ()
-  => ShelleyBasedEra era
-  -> Maybe NetworkId
-  -> TxBody era
-  -> [ShelleyBootstrapWitnessSigningKeyData]
-  -> Either BootstrapWitnessError [KeyWitness era]
-mkShelleyBootstrapWitnesses sbe mnw txBody =
-  mapM (mkShelleyBootstrapWitness sbe mnw txBody)
-
 -- ----------------------------------------------------------------------------
 -- Other misc small commands
 --
@@ -1857,7 +1829,7 @@ runTransactionWitnessCmd
         readFileTxBody txbodyFile
     case unwitnessed of
       IncompleteCddlTxBody anyTxBody -> do
-        InAnyShelleyBasedEra sbe txbody <- pure anyTxBody
+        InAnyShelleyBasedEra sbe txbody@(ShelleyTxBody _ ledgerTxBody _ _ _ _) <- pure anyTxBody
         someWit <-
           firstExceptT TxCmdReadWitnessSigningDataError
             . newExceptT
@@ -1867,9 +1839,8 @@ runTransactionWitnessCmd
             -- Byron witnesses require the network ID. This can either be provided
             -- directly or derived from a provided Byron address.
             AByronWitness bootstrapWitData ->
-              firstExceptT TxCmdBootstrapWitnessError
-                . hoistEither
-                $ mkShelleyBootstrapWitness sbe mNetworkId txbody bootstrapWitData
+              firstExceptT TxCmdBootstrapWitnessError . liftEither $
+                mkShelleyBootstrapWitness sbe mNetworkId ledgerTxBody bootstrapWitData
             AShelleyKeyWitness skShelley ->
               pure $ makeShelleyKeyWitness sbe txbody skShelley
 

cardano-cli/src/Cardano/CLI/Read.hs

@@ -40,6 +40,7 @@ module Cardano.CLI.Read
   , renderReadWitnessSigningDataError
   , SomeSigningWitness (..)
   , ByronOrShelleyWitness (..)
+  , mkShelleyBootstrapWitness
   , ShelleyBootstrapWitnessSigningKeyData (..)
   , CddlWitnessError (..)
   , readFileTxKeyWitness
@@ -95,6 +96,7 @@ module Cardano.CLI.Read
 where
 
 import Cardano.Api as Api
+import Cardano.Api.Byron qualified as Byron
 import Cardano.Api.Ledger qualified as L
 import Cardano.Api.Shelley as Api
 
@@ -108,6 +110,7 @@ import Cardano.CLI.EraBased.Script.Types
 import Cardano.CLI.EraBased.Script.Vote.Read
 import Cardano.CLI.EraBased.Script.Vote.Types
 import Cardano.CLI.Types.Common
+import Cardano.CLI.Types.Errors.BootstrapWitnessError
 import Cardano.CLI.Types.Errors.DelegationError
 import Cardano.CLI.Types.Errors.PlutusScriptDecodeError
 import Cardano.CLI.Types.Errors.ScriptDataError
@@ -116,6 +119,7 @@ import Cardano.CLI.Types.Errors.StakeCredentialError
 import Cardano.CLI.Types.Governance
 import Cardano.CLI.Types.Key
 import Cardano.Crypto.Hash qualified as Crypto
+import Cardano.Ledger.Api qualified as L
 
 import Prelude
 
@@ -520,6 +524,22 @@ data ShelleyBootstrapWitnessSigningKeyData
       -- If specified, both the network ID and derivation path are extracted
       -- from the address and used in the construction of the Byron witness.
 
+-- | Construct a Shelley bootstrap witness (i.e. a Byron key witness in the
+-- Shelley era).
+mkShelleyBootstrapWitness
+  :: ()
+  => ShelleyBasedEra era
+  -> Maybe NetworkId
+  -> L.TxBody (ShelleyLedgerEra era)
+  -> ShelleyBootstrapWitnessSigningKeyData
+  -> Either BootstrapWitnessError (KeyWitness era)
+mkShelleyBootstrapWitness _ Nothing _ (ShelleyBootstrapWitnessSigningKeyData _ Nothing) =
+  Left MissingNetworkIdOrByronAddressError
+mkShelleyBootstrapWitness sbe (Just nw) txBody (ShelleyBootstrapWitnessSigningKeyData skey Nothing) =
+  Right $ makeShelleyBasedBootstrapWitness sbe (Byron.WitnessNetworkId nw) txBody skey
+mkShelleyBootstrapWitness sbe _ txBody (ShelleyBootstrapWitnessSigningKeyData skey (Just addr)) =
+  Right $ makeShelleyBasedBootstrapWitness sbe (Byron.WitnessByronAddress addr) txBody skey
+
 -- | Some kind of Byron or Shelley witness.
 data ByronOrShelleyWitness
   = AByronWitness !ShelleyBootstrapWitnessSigningKeyData