Fix signing of a transaction in compatible shelley transaction signed-transaction command by not using an incomplete body for signing

cabal.project

@@ -14,7 +14,8 @@ repository cardano-haskell-packages
 -- you need to run if you change them
 index-state:
   , hackage.haskell.org 2024-12-24T12:56:48Z
-  , cardano-haskell-packages 2025-02-15T18:39:38Z
+  , cardano-haskell-packages 2025-02-28T13:16:07Z
+
 
 packages:
   cardano-cli

cardano-cli/cardano-cli.cabal

@@ -235,7 +235,7 @@ library
     binary,
     bytestring,
     canonical-json,
-    cardano-api ^>=10.9,
+    cardano-api ^>=10.10,
     cardano-binary,
     cardano-crypto,
     cardano-crypto-class ^>=2.1.2,

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

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
@@ -12,6 +13,7 @@ where
 
 import Cardano.Api
 import Cardano.Api.Compatible
+import Cardano.Api.Ledger qualified as L
 import Cardano.Api.Shelley hiding (VotingProcedures)
 
 import Cardano.CLI.Compatible.Exception
@@ -25,14 +27,21 @@ import Cardano.CLI.EraBased.Script.Vote.Type
 import Cardano.CLI.EraBased.Transaction.Run
 import Cardano.CLI.Read
 import Cardano.CLI.Type.Common
-import Cardano.CLI.Type.Error.TxCmdError
-import Cardano.CLI.Type.TxFeature
 
 import Control.Monad
-import Data.Function
-import Data.Map.Strict qualified as Map
-import Data.Maybe
-import GHC.Exts (toList)
+import Lens.Micro
+
+data CompatibleTransactionError
+  = forall err. Error err => CompatibleFileError (FileError err)
+  | CompatibleProposalError !ProposalError
+
+instance Show CompatibleTransactionError where
+  show = show . prettyError
+
+instance Error CompatibleTransactionError where
+  prettyError = \case
+    CompatibleFileError e -> prettyError e
+    CompatibleProposalError e -> pshow e
 
 runCompatibleTransactionCmd
   :: forall era e
@@ -51,108 +60,67 @@ runCompatibleTransactionCmd
       fee
       certificates
       outputFp
-    ) = do
-    shelleyBasedEraConstraints sbe $ do
-      sks <- mapM (fromEitherIOCli . readWitnessSigningData) witnesses
-
-      allOuts <- fromExceptTCli $ mapM (toTxOutInAnyEra sbe) outs
-
-      certFilesAndMaybeScriptWits <-
-        fromExceptTCli $
-          readCertificateScriptWitnesses sbe certificates
-
-      certsAndMaybeScriptWits <-
-        liftIO $
-          sequenceA
-            [ fmap (,cswScriptWitness <$> mSwit) $
-                fromEitherIOCli $
-                  readFileTextEnvelope AsCertificate $
-                    File certFile
-            | (CertificateFile certFile, mSwit) <- certFilesAndMaybeScriptWits
-            ]
-
-      (protocolUpdates, votes) :: (AnyProtocolUpdate era, AnyVote era) <-
-        caseShelleyToBabbageOrConwayEraOnwards
-          ( const $ do
-              case mUpdateProposal of
-                Nothing -> return (NoPParamsUpdate sbe, NoVotes)
-                Just p -> do
-                  pparamUpdate <- readUpdateProposalFile p
-                  return (pparamUpdate, NoVotes)
-          )
-          ( \w ->
-              case mProposalProcedure of
-                Nothing -> return (NoPParamsUpdate sbe, NoVotes)
-                Just prop -> do
-                  pparamUpdate <- readProposalProcedureFile prop
-                  votesAndWits <- fromEitherIOCli $ readVotingProceduresFiles w mVotes
-                  votingProcedures <-
-                    fromEitherCli $ mkTxVotingProcedures [(v, vswScriptWitness <$> mSwit) | (v, mSwit) <- votesAndWits]
-                  return (pparamUpdate, VotingProcedures w votingProcedures)
-          )
-          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
-            ]
-
-          proposalsRefInputs =
-            [ refInput
-            | ProposalProcedures _ (TxProposalProcedures proposalMap) <- [protocolUpdates]
-            , BuildTxWith (Just sWit) <- map snd $ toList proposalMap
-            , refInput <- maybeToList $ getScriptWitnessReferenceInput sWit
-            ]
-
-      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 (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
-
-      fromEitherIOCli $
-        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
+    ) = shelleyBasedEraConstraints sbe $ do
+    sks <- mapM (fromEitherIOCli . readWitnessSigningData) witnesses
+
+    allOuts <- fromEitherIOCli . runExceptT $ mapM (toTxOutInAnyEra sbe) outs
+
+    certFilesAndMaybeScriptWits <-
+      fromExceptTCli $
+        readCertificateScriptWitnesses sbe certificates
+
+    certsAndMaybeScriptWits <-
+      liftIO $
+        sequenceA
+          [ fmap (,cswScriptWitness <$> mSwit) $
+              fromEitherIOCli $
+                readFileTextEnvelope AsCertificate $
+                  File certFile
+          | (CertificateFile certFile, mSwit) <- certFilesAndMaybeScriptWits
+          ]
+
+    (protocolUpdates, votes) :: (AnyProtocolUpdate era, AnyVote era) <-
+      caseShelleyToBabbageOrConwayEraOnwards
+        ( const $ do
+            case mUpdateProposal of
+              Nothing -> return (NoPParamsUpdate sbe, NoVotes)
+              Just p -> do
+                pparamUpdate <- readUpdateProposalFile p
+                return (pparamUpdate, NoVotes)
+        )
+        ( \w ->
+            case mProposalProcedure of
+              Nothing -> return (NoPParamsUpdate sbe, NoVotes)
+              Just prop -> do
+                pparamUpdate <- readProposalProcedureFile prop
+                votesAndWits <- fromEitherIOCli (readVotingProceduresFiles w mVotes)
+                votingProcedures <-
+                  fromEitherCli $ mkTxVotingProcedures [(v, vswScriptWitness <$> mSwit) | (v, mSwit) <- votesAndWits]
+                return (pparamUpdate, VotingProcedures w votingProcedures)
+        )
+        sbe
+
+    let txCerts = mkTxCertificates sbe certsAndMaybeScriptWits
+
+    transaction@(ShelleyTx _ ledgerTx) <-
+      fromEitherCli $
+        createCompatibleTx sbe ins allOuts fee protocolUpdates votes txCerts
+
+    let txBody = ledgerTx ^. L.bodyTxL
+
+    let (sksByron, sksShelley) = partitionSomeWitnesses $ map categoriseSomeSigningWitness sks
+
+    byronWitnesses <-
+      forM sksByron $
+        fromEitherCli
+          . mkShelleyBootstrapWitness sbe mNetworkId txBody
+
+    let newShelleyKeyWits = makeShelleyKeyWitness' sbe txBody <$> sksShelley
+        allKeyWits = newShelleyKeyWits ++ byronWitnesses
+        signedTx = addWitnesses allKeyWits transaction
+
+    fromEitherIOCli $
+      writeTxFileTextEnvelopeCddl sbe outputFp signedTx
 
 readUpdateProposalFile
   :: Featured ShelleyToBabbageEra era (Maybe UpdateProposalFile)

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

@@ -18,8 +18,7 @@
 {- HLINT ignore "Avoid lambda using `infix`" -}
 
 module Cardano.CLI.EraBased.Transaction.Run
-  ( mkShelleyBootstrapWitnesses
-  , partitionSomeWitnesses
+  ( partitionSomeWitnesses
   , runTransactionCmds
   , runTransactionBuildCmd
   , runTransactionBuildRawCmd
@@ -70,7 +69,6 @@ import Cardano.CLI.EraBased.Transaction.Internal.HashCheck
 import Cardano.CLI.Orphan ()
 import Cardano.CLI.Read
 import Cardano.CLI.Type.Common
-import Cardano.CLI.Type.Error.BootstrapWitnessError
 import Cardano.CLI.Type.Error.NodeEraMismatchError
 import Cardano.CLI.Type.Error.TxCmdError
 import Cardano.CLI.Type.Error.TxValidationError
@@ -1449,9 +1447,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 +1462,19 @@ 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 $
+              shelleyBasedEraConstraints sbe $
+                mkShelleyBootstrapWitness sbe mNetworkId (ledgerTx ^. L.bodyTxL)
 
-        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 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