Skip to content

Commit 3b889d3

Browse files
carbolymercarbolymer
committed
Add certs to compatible transaction build command
* Added reference test for `compatible conway transaction singed-transaction`
1 parent eecd898 commit 3b889d3

File tree

12 files changed

+686
-41
lines changed

12 files changed

+686
-41
lines changed

‎cardano-cli/cardano-cli.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -364,6 +364,7 @@ test-suite cardano-cli-test
364364
Test.Cli.Shelley.Run.Hash
365365
Test.Cli.Shelley.Run.Query
366366
Test.Cli.Shelley.Transaction.Build
367+
Test.Cli.Shelley.Transaction.Compatible.Build
367368
Test.Cli.VerificationKey
368369

369370
ghc-options:

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

Lines changed: 109 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22
{-# LANGUAGE ExistentialQuantification #-}
33
{-# LANGUAGE GADTs #-}
44
{-# LANGUAGE LambdaCase #-}
5+
{-# LANGUAGE ScopedTypeVariables #-}
56
{-# LANGUAGE TupleSections #-}
67

78
module Cardano.CLI.Compatible.Transaction
@@ -27,10 +28,15 @@ import Cardano.CLI.Types.Common
2728
import Cardano.CLI.Types.Errors.BootstrapWitnessError
2829
import Cardano.CLI.Types.Errors.TxCmdError
2930
import Cardano.CLI.Types.Governance
31+
import Cardano.CLI.Types.TxFeature
3032

33+
import Data.Bifunctor (first)
3134
import Data.Foldable
3235
import Data.Function
36+
import qualified Data.Map.Strict as Map
37+
import Data.Maybe
3338
import Data.Text (Text)
39+
import GHC.Exts (IsList (..))
3440
import Options.Applicative
3541
import qualified Options.Applicative as Opt
3642

@@ -64,6 +70,7 @@ pCompatibleSignedTransaction env sbe =
6470
<*> many pWitnessSigningData
6571
<*> optional (pNetworkId env)
6672
<*> pTxFee
73+
<*> many (pCertificateFile sbe ManualBalance)
6774
<*> pOutputFile
6875

6976
pTxInOnly :: Parser TxIn
@@ -178,13 +185,15 @@ data CompatibleTransactionCmds era
178185
(Maybe NetworkId)
179186
!Coin
180187
-- ^ Tx fee
188+
![(CertificateFile, Maybe (ScriptWitnessFiles WitCtxStake))]
189+
-- ^ stake registering certs
181190
!(File () Out)
182191

183192
renderCompatibleTransactionCmd :: CompatibleTransactionCmds era -> Text
184193
renderCompatibleTransactionCmd _ = ""
185194

186195
data CompatibleTransactionError
187-
= CompatibleTxOutError !TxCmdError
196+
= CompatibleTxCmdError !TxCmdError
188197
| CompatibleWitnessError !ReadWitnessSigningDataError
189198
| CompatiblePParamsConversionError !ProtocolParametersConversionError
190199
| CompatibleBootstrapWitnessError !BootstrapWitnessError
@@ -193,10 +202,11 @@ data CompatibleTransactionError
193202
| CompatibleProposalError !ProposalError
194203
| CompatibleVoteError !VoteError
195204
| forall era. CompatibleVoteMergeError !(VotesMergingConflict era)
205+
| CompatibleScriptWitnessError !ScriptWitnessError
196206

197207
instance Error CompatibleTransactionError where
198208
prettyError = \case
199-
CompatibleTxOutError e -> renderTxCmdError e
209+
CompatibleTxCmdError e -> renderTxCmdError e
200210
CompatibleWitnessError e -> renderReadWitnessSigningDataError e
201211
CompatiblePParamsConversionError e -> prettyError e
202212
CompatibleBootstrapWitnessError e -> renderBootstrapWitnessError e
@@ -205,9 +215,12 @@ instance Error CompatibleTransactionError where
205215
CompatibleProposalError e -> pshow e
206216
CompatibleVoteError e -> pshow e
207217
CompatibleVoteMergeError e -> pshow e
218+
CompatibleScriptWitnessError e -> renderScriptWitnessError e
208219

209220
runCompatibleTransactionCmd
210-
:: CompatibleTransactionCmds era -> ExceptT CompatibleTransactionError IO ()
221+
:: forall era
222+
. CompatibleTransactionCmds era
223+
-> ExceptT CompatibleTransactionError IO ()
211224
runCompatibleTransactionCmd
212225
( CreateCompatibleSignedTransaction
213226
sbe
@@ -219,12 +232,72 @@ runCompatibleTransactionCmd
219232
witnesses
220233
mNetworkId
221234
fee
235+
certificates
222236
outputFp
223237
) = do
224238
sks <- firstExceptT CompatibleWitnessError $ mapM (newExceptT . readWitnessSigningData) witnesses
225239

226-
allOuts <- firstExceptT CompatibleTxOutError $ mapM (toTxOutInAnyEra sbe) outs
240+
allOuts <- firstExceptT CompatibleTxCmdError $ mapM (toTxOutInAnyEra sbe) outs
227241

242+
certFilesAndMaybeScriptWits <-
243+
firstExceptT CompatibleScriptWitnessError $
244+
readScriptWitnessFiles sbe certificates
245+
246+
certsAndMaybeScriptWits :: [(Certificate era, Maybe (ScriptWitness WitCtxStake era))] <-
247+
shelleyBasedEraConstraints sbe $
248+
sequence
249+
[ fmap
250+
(,mSwit)
251+
( firstExceptT CompatibleFileError . newExceptT $
252+
readFileTextEnvelope AsCertificate (File certFile)
253+
)
254+
| (CertificateFile certFile, mSwit) <- certFilesAndMaybeScriptWits
255+
]
256+
257+
(protocolUpdates, votes) :: (AnyProtocolUpdate era, AnyVote era) <-
258+
caseShelleyToBabbageOrConwayEraOnwards
259+
( const $ do
260+
prop <- maybe (pure $ NoPParamsUpdate sbe) readUpdateProposalFile mUpdateProposal
261+
return (prop, NoVotes)
262+
)
263+
( \w -> do
264+
prop <- maybe (pure $ NoPParamsUpdate sbe) readProposalProcedureFile mProposalProcedure
265+
votesAndWits <-
266+
firstExceptT CompatibleVoteError . newExceptT $
267+
readVotingProceduresFiles w mVotes
268+
votingProcedures <-
269+
firstExceptT CompatibleVoteMergeError . hoistEither $
270+
mkTxVotingProcedures votesAndWits
271+
return (prop, VotingProcedures w votingProcedures)
272+
)
273+
sbe
274+
275+
let certsRefInputs =
276+
[ refInput
277+
| (_, Just sWit) <- certsAndMaybeScriptWits
278+
, refInput <- maybeToList $ getScriptWitnessReferenceInput sWit
279+
]
280+
281+
votesRefInputs =
282+
[ refInput
283+
| VotingProcedures _ (TxVotingProcedures _ (BuildTxWith voteMap)) <- [votes]
284+
, sWit <- Map.elems voteMap
285+
, refInput <- maybeToList $ getScriptWitnessReferenceInput sWit
286+
]
287+
288+
proposalsRefInputs =
289+
[ refInput
290+
| ProposalProcedures _ (TxProposalProcedures _ (BuildTxWith proposalMap)) <- [protocolUpdates]
291+
, sWit <- Map.elems proposalMap
292+
, refInput <- maybeToList $ getScriptWitnessReferenceInput sWit
293+
]
294+
295+
validatedRefInputs <-
296+
liftEither . first CompatibleTxCmdError . validateTxInsReference $
297+
certsRefInputs <> votesRefInputs <> proposalsRefInputs
298+
let txCerts = convertCertificates certsAndMaybeScriptWits
299+
300+
-- this body is only for witnesses
228301
apiTxBody <-
229302
firstExceptT CompatibleTxBodyError $
230303
hoistEither $
@@ -233,39 +306,52 @@ runCompatibleTransactionCmd
233306
& setTxIns (map (,BuildTxWith (KeyWitness KeyWitnessForSpending)) ins)
234307
& setTxOuts allOuts
235308
& setTxFee (TxFeeExplicit sbe fee)
309+
& setTxCertificates txCerts
310+
& setTxInsReference validatedRefInputs
236311

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

239314
byronWitnesses <-
240-
firstExceptT CompatibleBootstrapWitnessError $
241-
hoistEither (mkShelleyBootstrapWitnesses sbe mNetworkId apiTxBody sksByron)
315+
firstExceptT CompatibleBootstrapWitnessError . hoistEither $
316+
mkShelleyBootstrapWitnesses sbe mNetworkId apiTxBody sksByron
242317

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

246-
(protocolUpdates, votes) <-
247-
caseShelleyToBabbageOrConwayEraOnwards
248-
( const $ do
249-
prop <- maybe (return $ NoPParamsUpdate sbe) readUpdateProposalFile mUpdateProposal
250-
return (prop, NoVotes)
251-
)
252-
( \w -> do
253-
prop <- maybe (return $ NoPParamsUpdate sbe) readProposalProcedureFile mProposalProcedure
254-
votesAndWits <- firstExceptT CompatibleVoteError $ newExceptT $ readVotingProceduresFiles w mVotes
255-
votingProcedures <-
256-
firstExceptT CompatibleVoteMergeError $ hoistEither $ mkTxVotingProcedures votesAndWits
257-
return (prop, VotingProcedures w votingProcedures)
258-
)
259-
sbe
260-
261321
signedTx <-
262322
firstExceptT CompatiblePParamsConversionError . hoistEither $
263-
-- FIXME https://github.com/IntersectMBO/cardano-cli/pull/972
264-
createCompatibleSignedTx sbe ins allOuts allKeyWits fee protocolUpdates votes TxCertificatesNone
323+
createCompatibleSignedTx sbe ins allOuts allKeyWits fee protocolUpdates votes txCerts
265324

266325
firstExceptT CompatibleFileError $
267326
newExceptT $
268327
writeTxFileTextEnvelopeCddl sbe outputFp signedTx
328+
where
329+
convertCertificates
330+
:: [(Certificate era, Maybe (ScriptWitness WitCtxStake era))]
331+
-> TxCertificates BuildTx era
332+
convertCertificates certsAndScriptWitnesses =
333+
TxCertificates sbe certs $ BuildTxWith reqWits
334+
where
335+
certs = map fst certsAndScriptWitnesses
336+
reqWits = fromList $ mapMaybe convert' certsAndScriptWitnesses
337+
convert'
338+
:: (Certificate era, Maybe (ScriptWitness WitCtxStake era))
339+
-> Maybe (StakeCredential, Witness WitCtxStake era)
340+
convert' (cert, mScriptWitnessFiles) = do
341+
sCred <- selectStakeCredentialWitness cert
342+
Just . (sCred,) $ case mScriptWitnessFiles of
343+
Just sWit -> ScriptWitness ScriptWitnessForStakeAddr sWit
344+
Nothing -> KeyWitness KeyWitnessForStakeAddr
345+
346+
validateTxInsReference
347+
:: [TxIn]
348+
-> Either TxCmdError (TxInsReference era)
349+
validateTxInsReference [] = return TxInsReferenceNone
350+
validateTxInsReference allRefIns = do
351+
let era = toCardanoEra era
352+
eraMismatchError = Left $ TxCmdTxFeatureMismatch (anyCardanoEra era) TxFeatureReferenceInputs
353+
w <- maybe eraMismatchError Right $ forEraMaybeEon era
354+
pure $ TxInsReference w allRefIns
269355

270356
readUpdateProposalFile
271357
:: Featured ShelleyToBabbageEra era (Maybe UpdateProposalFile)

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

Lines changed: 6 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -1227,12 +1227,12 @@ getAllReferenceInputs
12271227
votingProceduresAndMaybeScriptWits
12281228
propProceduresAnMaybeScriptWits
12291229
readOnlyRefIns = do
1230-
let txinsWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- txins]
1231-
mintingRefInputs = map getReferenceInput mintWitnesses
1232-
certsWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- certFiles]
1233-
withdrawalsWitByRefInputs = [getReferenceInput sWit | (_, _, Just sWit) <- withdrawals]
1234-
votesWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- votingProceduresAndMaybeScriptWits]
1235-
propsWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- propProceduresAnMaybeScriptWits]
1230+
let txinsWitByRefInputs = [getScriptWitnessReferenceInput sWit | (_, Just sWit) <- txins]
1231+
mintingRefInputs = map getScriptWitnessReferenceInput mintWitnesses
1232+
certsWitByRefInputs = [getScriptWitnessReferenceInput sWit | (_, Just sWit) <- certFiles]
1233+
withdrawalsWitByRefInputs = [getScriptWitnessReferenceInput sWit | (_, _, Just sWit) <- withdrawals]
1234+
votesWitByRefInputs = [getScriptWitnessReferenceInput sWit | (_, Just sWit) <- votingProceduresAndMaybeScriptWits]
1235+
propsWitByRefInputs = [getScriptWitnessReferenceInput sWit | (_, Just sWit) <- propProceduresAnMaybeScriptWits]
12361236

12371237
concatMap
12381238
catMaybes
@@ -1244,15 +1244,6 @@ getAllReferenceInputs
12441244
, propsWitByRefInputs
12451245
, map Just readOnlyRefIns
12461246
]
1247-
where
1248-
getReferenceInput
1249-
:: ScriptWitness witctx era -> Maybe TxIn
1250-
getReferenceInput sWit =
1251-
case sWit of
1252-
PlutusScriptWitness _ _ (PReferenceScript refIn) _ _ _ -> Just refIn
1253-
PlutusScriptWitness _ _ PScript{} _ _ _ -> Nothing
1254-
SimpleScriptWitness _ (SReferenceScript refIn) -> Just refIn
1255-
SimpleScriptWitness _ SScript{} -> Nothing
12561247

12571248
toAddressInAnyEra
12581249
:: CardanoEra era

0 commit comments

Comments
 (0)