Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Add certificates to CLI interface in compatible transaction-sign #972

Open
wants to merge 1 commit into
base: master
Choose a base branch
from
+680 −26
Open

Add certificates to CLI interface in compatible transaction-sign #972

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions cardano-cli/cardano-cli.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -364,6 +364,7 @@ test-suite cardano-cli-test
Test.Cli.Shelley.Run.Hash
Test.Cli.Shelley.Run.Query
Test.Cli.Shelley.Transaction.Build
Test.Cli.Shelley.Transaction.Compatible.Build
Test.Cli.VerificationKey

ghc-options:
Expand Down
132 changes: 109 additions & 23 deletions cardano-cli/src/Cardano/CLI/Compatible/Transaction.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,7 @@
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}

module Cardano.CLI.Compatible.Transaction
Expand All @@ -27,10 +28,15 @@ import Cardano.CLI.Types.Common
import Cardano.CLI.Types.Errors.BootstrapWitnessError
import Cardano.CLI.Types.Errors.TxCmdError
import Cardano.CLI.Types.Governance
import Cardano.CLI.Types.TxFeature

import Data.Bifunctor (first)
import Data.Foldable
import Data.Function
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Text (Text)
import GHC.Exts (IsList (..))
import Options.Applicative
import qualified Options.Applicative as Opt

Expand Down Expand Up @@ -64,6 +70,7 @@ pCompatibleSignedTransaction env sbe =
<*> many pWitnessSigningData
<*> optional (pNetworkId env)
<*> pTxFee
<*> many (pCertificateFile sbe ManualBalance)
<*> pOutputFile

pTxInOnly :: Parser TxIn
Expand Down Expand Up @@ -178,13 +185,15 @@ data CompatibleTransactionCmds era
(Maybe NetworkId)
!Coin
-- ^ Tx fee
![(CertificateFile, Maybe (ScriptWitnessFiles WitCtxStake))]
-- ^ stake registering certs
!(File () Out)

renderCompatibleTransactionCmd :: CompatibleTransactionCmds era -> Text
renderCompatibleTransactionCmd _ = ""

data CompatibleTransactionError
= CompatibleTxOutError !TxCmdError
= CompatibleTxCmdError !TxCmdError
| CompatibleWitnessError !ReadWitnessSigningDataError
| CompatiblePParamsConversionError !ProtocolParametersConversionError
| CompatibleBootstrapWitnessError !BootstrapWitnessError
Expand All @@ -193,10 +202,11 @@ data CompatibleTransactionError
| CompatibleProposalError !ProposalError
| CompatibleVoteError !VoteError
| forall era. CompatibleVoteMergeError !(VotesMergingConflict era)
| CompatibleScriptWitnessError !ScriptWitnessError

instance Error CompatibleTransactionError where
prettyError = \case
CompatibleTxOutError e -> renderTxCmdError e
CompatibleTxCmdError e -> renderTxCmdError e
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Why the name change? This error is TxOut related.

Copy link
Contributor Author

@carbolymer carbolymer Jan 15, 2025 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I disagree, TxCmdError is much broader than just transaction outputs. I'm also reusing it in line 296.

CompatibleWitnessError e -> renderReadWitnessSigningDataError e
CompatiblePParamsConversionError e -> prettyError e
CompatibleBootstrapWitnessError e -> renderBootstrapWitnessError e
Expand All @@ -205,9 +215,12 @@ instance Error CompatibleTransactionError where
CompatibleProposalError e -> pshow e
CompatibleVoteError e -> pshow e
CompatibleVoteMergeError e -> pshow e
CompatibleScriptWitnessError e -> renderScriptWitnessError e

runCompatibleTransactionCmd
:: CompatibleTransactionCmds era -> ExceptT CompatibleTransactionError IO ()
:: forall era
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Unnecessary forall era

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'm using scopedtypevariables to have the same era in functions in where

Copy link
Contributor

@Jimbo4350 Jimbo4350 Jan 15, 2025 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Are you using it for readability purposes? If not you can remove all mentions of era in the function body of runCompatibleTransactionCmd. It still builds:

diff --git a/cardano-cli/src/Cardano/CLI/Compatible/Transaction.hs b/cardano-cli/src/Cardano/CLI/Compatible/Transaction.hs
index 25468707e..606a0945d 100644
--- a/cardano-cli/src/Cardano/CLI/Compatible/Transaction.hs
+++ b/cardano-cli/src/Cardano/CLI/Compatible/Transaction.hs
@@ -2,7 +2,6 @@
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 
 module Cardano.CLI.Compatible.Transaction
@@ -218,8 +217,7 @@ instance Error CompatibleTransactionError where
     CompatibleScriptWitnessError e -> renderScriptWitnessError e
 
 runCompatibleTransactionCmd
-  :: forall era
-   . CompatibleTransactionCmds era
+  :: CompatibleTransactionCmds era
   -> ExceptT CompatibleTransactionError IO ()
 runCompatibleTransactionCmd
   ( CreateCompatibleSignedTransaction
@@ -243,7 +241,7 @@ runCompatibleTransactionCmd
       firstExceptT CompatibleScriptWitnessError $
         readScriptWitnessFiles sbe certificates
 
-    certsAndMaybeScriptWits :: [(Certificate era, Maybe (ScriptWitness WitCtxStake era))] <-
+    certsAndMaybeScriptWits  <-
       shelleyBasedEraConstraints sbe $
         sequence
           [ fmap
@@ -254,7 +252,7 @@ runCompatibleTransactionCmd
           | (CertificateFile certFile, mSwit) <- certFilesAndMaybeScriptWits
           ]
 
-    (protocolUpdates, votes) :: (AnyProtocolUpdate era, AnyVote era) <-
+    (protocolUpdates, votes) <-
       caseShelleyToBabbageOrConwayEraOnwards
         ( const $ do
             prop <- maybe (pure $ NoPParamsUpdate sbe) readUpdateProposalFile mUpdateProposal
@@ -326,26 +324,17 @@ runCompatibleTransactionCmd
       newExceptT $
         writeTxFileTextEnvelopeCddl sbe outputFp signedTx
    where
-    convertCertificates
-      :: [(Certificate era, Maybe (ScriptWitness WitCtxStake era))]
-      -> TxCertificates BuildTx era
     convertCertificates certsAndScriptWitnesses =
       TxCertificates sbe certs $ BuildTxWith reqWits
      where
       certs = map fst certsAndScriptWitnesses
       reqWits = fromList $ mapMaybe convert' certsAndScriptWitnesses
-      convert'
-        :: (Certificate era, Maybe (ScriptWitness WitCtxStake era))
-        -> Maybe (StakeCredential, Witness WitCtxStake era)
       convert' (cert, mScriptWitnessFiles) = do
         sCred <- selectStakeCredentialWitness cert
         Just . (sCred,) $ case mScriptWitnessFiles of
           Just sWit -> ScriptWitness ScriptWitnessForStakeAddr sWit
           Nothing -> KeyWitness KeyWitnessForStakeAddr
 
-    validateTxInsReference
-      :: [TxIn]
-      -> Either TxCmdError (TxInsReference era)
     validateTxInsReference [] = return TxInsReferenceNone
     validateTxInsReference allRefIns = do
       let era = toCardanoEra era

Copy link
Contributor Author

@carbolymer carbolymer Jan 16, 2025 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Yes it's mostly for readability. If you prefer to not have type signatures, I can remove them.

. CompatibleTransactionCmds era
-> ExceptT CompatibleTransactionError IO ()
runCompatibleTransactionCmd
( CreateCompatibleSignedTransaction
sbe
Expand All @@ -219,12 +232,72 @@ runCompatibleTransactionCmd
witnesses
mNetworkId
fee
certificates
outputFp
) = do
sks <- firstExceptT CompatibleWitnessError $ mapM (newExceptT . readWitnessSigningData) witnesses

allOuts <- firstExceptT CompatibleTxOutError $ mapM (toTxOutInAnyEra sbe) outs
allOuts <- firstExceptT CompatibleTxCmdError $ mapM (toTxOutInAnyEra sbe) outs

certFilesAndMaybeScriptWits <-
firstExceptT CompatibleScriptWitnessError $
readScriptWitnessFiles sbe certificates

certsAndMaybeScriptWits :: [(Certificate era, Maybe (ScriptWitness WitCtxStake era))] <-
shelleyBasedEraConstraints sbe $
sequence
[ fmap
(,mSwit)
( firstExceptT CompatibleFileError . newExceptT $
readFileTextEnvelope AsCertificate (File certFile)
)
| (CertificateFile certFile, mSwit) <- certFilesAndMaybeScriptWits
]

(protocolUpdates, votes) :: (AnyProtocolUpdate era, AnyVote era) <-
caseShelleyToBabbageOrConwayEraOnwards
( const $ do
prop <- maybe (pure $ NoPParamsUpdate sbe) readUpdateProposalFile mUpdateProposal
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I guess it's not possible to move this one out of the case, to share the code between the two branches?

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

not really, those are two different files with different purposes

return (prop, NoVotes)
)
( \w -> do
prop <- maybe (pure $ NoPParamsUpdate sbe) readProposalProcedureFile mProposalProcedure
votesAndWits <-
firstExceptT CompatibleVoteError . newExceptT $
readVotingProceduresFiles w mVotes
votingProcedures <-
firstExceptT CompatibleVoteMergeError . hoistEither $
mkTxVotingProcedures votesAndWits
return (prop, 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 _ (BuildTxWith proposalMap)) <- [protocolUpdates]
, sWit <- Map.elems proposalMap
, refInput <- maybeToList $ getScriptWitnessReferenceInput sWit
]

validatedRefInputs <-
liftEither . first CompatibleTxCmdError . validateTxInsReference $
certsRefInputs <> votesRefInputs <> proposalsRefInputs
let txCerts = convertCertificates certsAndMaybeScriptWits

-- this body is only for witnesses
apiTxBody <-
firstExceptT CompatibleTxBodyError $
hoistEither $
Expand All @@ -233,39 +306,52 @@ runCompatibleTransactionCmd
& setTxIns (map (,BuildTxWith (KeyWitness KeyWitnessForSpending)) ins)
& setTxOuts allOuts
& setTxFee (TxFeeExplicit sbe fee)
& setTxCertificates txCerts
& setTxInsReference validatedRefInputs

let (sksByron, sksShelley) = partitionSomeWitnesses $ map categoriseSomeSigningWitness sks

byronWitnesses <-
firstExceptT CompatibleBootstrapWitnessError $
hoistEither (mkShelleyBootstrapWitnesses sbe mNetworkId apiTxBody sksByron)
firstExceptT CompatibleBootstrapWitnessError . hoistEither $
mkShelleyBootstrapWitnesses sbe mNetworkId apiTxBody sksByron

let newShelleyKeyWits = map (makeShelleyKeyWitness sbe apiTxBody) sksShelley
allKeyWits = newShelleyKeyWits ++ byronWitnesses

(protocolUpdates, votes) <-
caseShelleyToBabbageOrConwayEraOnwards
( const $ do
prop <- maybe (return $ NoPParamsUpdate sbe) readUpdateProposalFile mUpdateProposal
return (prop, NoVotes)
)
( \w -> do
prop <- maybe (return $ NoPParamsUpdate sbe) readProposalProcedureFile mProposalProcedure
votesAndWits <- firstExceptT CompatibleVoteError $ newExceptT $ readVotingProceduresFiles w mVotes
votingProcedures <-
firstExceptT CompatibleVoteMergeError $ hoistEither $ mkTxVotingProcedures votesAndWits
return (prop, VotingProcedures w votingProcedures)
)
sbe

signedTx <-
firstExceptT CompatiblePParamsConversionError . hoistEither $
-- FIXME https://github.com/IntersectMBO/cardano-cli/pull/972
createCompatibleSignedTx sbe ins allOuts allKeyWits fee protocolUpdates votes TxCertificatesNone
createCompatibleSignedTx sbe ins allOuts allKeyWits fee protocolUpdates votes txCerts

firstExceptT CompatibleFileError $
newExceptT $
writeTxFileTextEnvelopeCddl sbe outputFp signedTx
where
convertCertificates
:: [(Certificate era, Maybe (ScriptWitness WitCtxStake era))]
-> TxCertificates BuildTx era
convertCertificates certsAndScriptWitnesses =
TxCertificates sbe certs $ BuildTxWith reqWits
where
certs = map fst certsAndScriptWitnesses
reqWits = fromList $ mapMaybe convert' certsAndScriptWitnesses
convert'
:: (Certificate era, Maybe (ScriptWitness WitCtxStake era))
-> Maybe (StakeCredential, Witness WitCtxStake era)
convert' (cert, mScriptWitnessFiles) = do
sCred <- selectStakeCredentialWitness cert
Just . (sCred,) $ case mScriptWitnessFiles of
Just sWit -> ScriptWitness ScriptWitnessForStakeAddr sWit
Nothing -> KeyWitness KeyWitnessForStakeAddr

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)
Expand Down
Loading
Loading