Skip to content

Commit 02d8383

Browse files
errfromerrfrom
committed
Add builder steps for proposals and voting procedures
1 parent 48866bd commit 02d8383

File tree

4 files changed

+175
-54
lines changed

4 files changed

+175
-54
lines changed

‎.tidyrc.json

+10
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,10 @@
1+
{
2+
"importSort": "ide",
3+
"importWrap": "auto",
4+
"indent": 2,
5+
"operatorsFile": null,
6+
"ribbon": 1,
7+
"typeArrowPlacement": "first",
8+
"unicode": "never",
9+
"width": 80
10+
}

‎src/Cardano/Transaction/Builder.purs

+109-32
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,8 @@ module Cardano.Transaction.Builder
55
, MintAsset
66
, IssueCertificate
77
, WithdrawRewards
8+
, SubmitProposal
9+
, SubmitVotingProcedure
810
)
911
, OutputWitness(NativeScriptOutput, PlutusScriptOutput)
1012
, CredentialWitness(NativeScriptCredential, PlutusScriptCredential)
@@ -20,6 +22,7 @@ module Cardano.Transaction.Builder
2022
, DatumWitnessNotProvided
2123
, UnneededDatumWitness
2224
, UnneededDeregisterWitness
25+
, UnneededSpoVoteWitness
2326
, UnableToAddMints
2427
, RedeemerIndexingError
2528
, RedeemerIndexingInternalError
@@ -31,6 +34,7 @@ module Cardano.Transaction.Builder
3134
( StakeCert
3235
, Withdrawal
3336
, Minting
37+
, Voting
3438
)
3539
, buildTransaction
3640
, modifyTransaction
@@ -42,7 +46,7 @@ import Prelude
4246
import Cardano.AsCbor (encodeCbor)
4347
import Cardano.Transaction.Edit
4448
( DetachedRedeemer
45-
, RedeemerPurpose(ForCert, ForReward, ForSpend, ForMint)
49+
, RedeemerPurpose(ForCert, ForReward, ForSpend, ForMint, ForVote)
4650
, fromEditableTransactionSafe
4751
, toEditableTransactionSafe
4852
)
@@ -85,6 +89,7 @@ import Cardano.Types.Credential
8589
)
8690
import Cardano.Types.Credential as Credential
8791
import Cardano.Types.DataHash as PlutusData
92+
import Cardano.Types.GovernanceActionId (GovernanceActionId)
8893
import Cardano.Types.Int as Int
8994
import Cardano.Types.Mint as Mint
9095
import Cardano.Types.NativeScript as NativeScript
@@ -96,10 +101,21 @@ import Cardano.Types.StakeCredential (StakeCredential)
96101
import Cardano.Types.StakePubKeyHash (StakePubKeyHash)
97102
import Cardano.Types.Transaction (_body, _witnessSet)
98103
import Cardano.Types.Transaction as Transaction
104+
import Cardano.Types.TransactionBody (_votingProcedures, _votingProposals)
99105
import Cardano.Types.TransactionInput (TransactionInput)
100106
import Cardano.Types.TransactionOutput (TransactionOutput, _address, _datum)
101-
import Cardano.Types.TransactionUnspentOutput (TransactionUnspentOutput, _output)
102-
import Cardano.Types.TransactionWitnessSet (_nativeScripts, _plutusData, _plutusScripts)
107+
import Cardano.Types.TransactionUnspentOutput
108+
( TransactionUnspentOutput
109+
, _output
110+
)
111+
import Cardano.Types.TransactionWitnessSet
112+
( _nativeScripts
113+
, _plutusData
114+
, _plutusScripts
115+
)
116+
import Cardano.Types.Voter (Voter(Cc, Drep, Spo))
117+
import Cardano.Types.VotingProcedure (VotingProcedure)
118+
import Cardano.Types.VotingProposal (VotingProposal)
103119
import Control.Monad.Error.Class (throwError)
104120
import Control.Monad.Except (Except, runExcept)
105121
import Control.Monad.State (StateT, modify_, runStateT)
@@ -110,7 +126,9 @@ import Data.ByteArray (byteArrayToHex)
110126
import Data.Either (Either(Left, Right), either, note)
111127
import Data.Generic.Rep (class Generic)
112128
import Data.Lens (Lens', view, (%=), (.~), (^.))
129+
import Data.Lens.Iso.Newtype (_Newtype)
113130
import Data.Lens.Record (prop)
131+
import Data.Map (Map)
114132
import Data.Map as Map
115133
import Data.Maybe (Maybe(Just, Nothing), isJust, maybe)
116134
import Data.Newtype (unwrap, wrap)
@@ -126,6 +144,9 @@ data TransactionBuilderStep
126144
| MintAsset ScriptHash AssetName Int.Int CredentialWitness
127145
| IssueCertificate Certificate (Maybe CredentialWitness)
128146
| WithdrawRewards StakeCredential Coin (Maybe CredentialWitness)
147+
| SubmitProposal VotingProposal
148+
| SubmitVotingProcedure Voter (Map GovernanceActionId VotingProcedure)
149+
(Maybe CredentialWitness)
129150

130151
derive instance Generic TransactionBuilderStep _
131152
derive instance Eq TransactionBuilderStep
@@ -244,6 +265,7 @@ data CredentialAction
244265
= StakeCert Certificate
245266
| Withdrawal RewardAddress
246267
| Minting ScriptHash
268+
| Voting Voter
247269

248270
derive instance Generic CredentialAction _
249271
derive instance Eq CredentialAction
@@ -254,6 +276,7 @@ explainCredentialAction :: CredentialAction -> String
254276
explainCredentialAction (StakeCert _) = "This stake certificate"
255277
explainCredentialAction (Withdrawal _) = "This stake rewards withdrawal"
256278
explainCredentialAction (Minting _) = "This mint"
279+
explainCredentialAction (Voting _) = "This voting procedure"
257280

258281
data TxBuildError
259282
= WrongSpendWitnessType TransactionUnspentOutput
@@ -265,6 +288,7 @@ data TxBuildError
265288
| DatumWitnessNotProvided TransactionUnspentOutput
266289
| UnneededDatumWitness TransactionUnspentOutput DatumWitness
267290
| UnneededDeregisterWitness StakeCredential CredentialWitness
291+
| UnneededSpoVoteWitness Credential CredentialWitness
268292
| UnableToAddMints Mint Mint
269293
| RedeemerIndexingError Redeemer
270294
| RedeemerIndexingInternalError Transaction (Array TransactionBuilderStep)
@@ -290,15 +314,23 @@ explainTxBuildError (IncorrectDatumHash utxo datum datumHash) =
290314
<> "\n UTxO: "
291315
<> show utxo
292316
explainTxBuildError (IncorrectScriptHash (Left nativeScript) hash) =
293-
"Provided script hash (" <> show hash <> ") does not match the provided native script (" <> show nativeScript <> ")"
317+
"Provided script hash (" <> show hash
318+
<> ") does not match the provided native script ("
319+
<> show nativeScript
320+
<> ")"
294321
explainTxBuildError (IncorrectScriptHash (Right plutusScript) hash) =
295-
"Provided script hash (" <> show hash <> ") does not match the provided Plutus script (" <> show plutusScript <> ")"
322+
"Provided script hash (" <> show hash
323+
<> ") does not match the provided Plutus script ("
324+
<> show plutusScript
325+
<> ")"
296326
explainTxBuildError (WrongOutputType ScriptHashWitness utxo) =
297-
"The UTxO you provided requires no witness, because the payment credential of the address is a `PubKeyHash`. UTxO: " <> show
298-
utxo
327+
"The UTxO you provided requires no witness, because the payment credential of the address is a `PubKeyHash`. UTxO: "
328+
<> show
329+
utxo
299330
explainTxBuildError (WrongOutputType PubKeyHashWitness utxo) =
300-
"The UTxO you provided requires a `ScriptHash` witness to unlock, because the payment credential of the address is a `ScriptHash`. UTxO: " <>
301-
show utxo
331+
"The UTxO you provided requires a `ScriptHash` witness to unlock, because the payment credential of the address is a `ScriptHash`. UTxO: "
332+
<>
333+
show utxo
302334
explainTxBuildError
303335
(WrongStakeCredentialType operation expWitnessType stakeCredential) =
304336
explainCredentialAction operation <> " (" <> show operation <> ") requires a "
@@ -314,15 +346,29 @@ explainTxBuildError (UnneededDatumWitness utxo witness) =
314346
<> " for the UTxO: "
315347
<> show utxo
316348
explainTxBuildError (UnneededDeregisterWitness stakeCredential witness) =
317-
"You've provided an optional `CredentialWitness`, but the stake credential you are trying to issue a deregistering certificate for is a PubKeyHash credential. You should omit the provided credential witness for this credential: " <> show stakeCredential <> ". Provided witness: " <> show witness
349+
"You've provided an optional `CredentialWitness`, but the stake credential you are trying to issue a deregistering certificate for is a PubKeyHash credential. You should omit the provided credential witness for this credential: "
350+
<> show stakeCredential
351+
<> ". Provided witness: "
352+
<> show witness
353+
explainTxBuildError (UnneededSpoVoteWitness cred witness) =
354+
"You've provided an optional `CredentialWitness`, but the corresponding Voter is SPO (Stake Pool Operator). You should omit the provided credential witness for this credential: "
355+
<> show cred
356+
<> ". Provided witness: "
357+
<> show witness
318358
explainTxBuildError (UnableToAddMints a b) =
319359
"Numeric overflow: unable to add `Mint`s: " <> show a <> " and " <> show b
320360
explainTxBuildError (RedeemerIndexingError redeemer) =
321-
"Redeemer indexing error. Problematic redeemer that does not have a valid index: " <> show redeemer
361+
"Redeemer indexing error. Problematic redeemer that does not have a valid index: "
362+
<> show redeemer
322363
explainTxBuildError (RedeemerIndexingInternalError tx steps) =
323-
"Internal redeemer indexing error. Please report as bug: " <> bugTrackerUrl <> "\nDebug info: Transaction: " <> show tx <> ", steps: " <> show steps
364+
"Internal redeemer indexing error. Please report as bug: " <> bugTrackerUrl
365+
<> "\nDebug info: Transaction: "
366+
<> show tx
367+
<> ", steps: "
368+
<> show steps
324369
explainTxBuildError (WrongNetworkId address) =
325-
"The following `Address` that was specified in one of the UTxOs has a `NetworkId` different from the one `TransactionBody` has: " <> show address
370+
"The following `Address` that was specified in one of the UTxOs has a `NetworkId` different from the one `TransactionBody` has: "
371+
<> show address
326372
explainTxBuildError NoTransactionNetworkId =
327373
"You are editing a transaction without a `NetworkId` set. To create a `RewardAddress`, a NetworkId is needed: set it in the `TransactionBody`"
328374

@@ -340,7 +386,8 @@ modifyTransaction
340386
-> Either TxBuildError Transaction
341387
modifyTransaction tx steps = do
342388
context <- do
343-
editableTransaction <- lmap RedeemerIndexingError $ toEditableTransactionSafe tx
389+
editableTransaction <- lmap RedeemerIndexingError $
390+
toEditableTransactionSafe tx
344391
pure $ merge editableTransaction
345392
{ networkId: editableTransaction.transaction ^. _body <<< _networkId }
346393
let
@@ -368,12 +415,20 @@ processConstraint = case _ of
368415
-- intentionally not using pushUnique: we can
369416
-- create multiple outputs of the same shape
370417
%= flip append [ output ]
371-
MintAsset scriptHash assetName amount mintWitness -> do
418+
MintAsset scriptHash assetName amount mintWitness ->
372419
useMintAssetWitness scriptHash assetName amount mintWitness
373420
IssueCertificate cert witness -> do
421+
_transaction <<< _body <<< _certs %= pushUnique cert
374422
useCertificateWitness cert witness
375-
WithdrawRewards stakeCredential amount witness -> do
423+
WithdrawRewards stakeCredential amount witness ->
376424
useWithdrawRewardsWitness stakeCredential amount witness
425+
SubmitProposal proposal ->
426+
_transaction <<< _body <<< _votingProposals
427+
%= pushUnique proposal
428+
SubmitVotingProcedure voter votes witness -> do
429+
_transaction <<< _body <<< _votingProcedures <<< _Newtype
430+
%= Map.insert voter votes
431+
useVotingProcedureWitness voter witness
377432

378433
assertNetworkId :: Address -> BuilderM Unit
379434
assertNetworkId addr = do
@@ -386,7 +441,8 @@ assertNetworkId addr = do
386441
unless (networkId == addrNetworkId) do
387442
throwError (WrongNetworkId addr)
388443

389-
assertOutputType :: ExpectedWitnessType -> TransactionUnspentOutput -> BuilderM Unit
444+
assertOutputType
445+
:: ExpectedWitnessType -> TransactionUnspentOutput -> BuilderM Unit
390446
assertOutputType outputType utxo = do
391447
let
392448
mbCredential =
@@ -426,45 +482,63 @@ useMintAssetWitness scriptHash assetName amount witness = do
426482
maybe (throwError $ UnableToAddMints mint thisMint) pure
427483
modify_ $ _transaction <<< _body <<< _mint .~ Just newMint
428484

429-
assertScriptHashMatchesCredentialWitness :: ScriptHash -> CredentialWitness -> BuilderM Unit
485+
assertScriptHashMatchesCredentialWitness
486+
:: ScriptHash -> CredentialWitness -> BuilderM Unit
430487
assertScriptHashMatchesCredentialWitness scriptHash witness = do
431488
let
432489
mbScript = case witness of
433-
PlutusScriptCredential (ScriptValue plutusScript) _ -> Just (Right plutusScript)
434-
NativeScriptCredential (ScriptValue nativeScript) -> Just (Left nativeScript)
490+
PlutusScriptCredential (ScriptValue plutusScript) _ -> Just
491+
(Right plutusScript)
492+
NativeScriptCredential (ScriptValue nativeScript) -> Just
493+
(Left nativeScript)
435494
_ -> Nothing
436495
for_ mbScript \eiScript -> do
437496
let hash = either NativeScript.hash PlutusScript.hash eiScript
438497
unless (scriptHash == hash) do
439498
throwError $ IncorrectScriptHash eiScript scriptHash
440499

500+
useVotingProcedureWitness :: Voter -> Maybe CredentialWitness -> BuilderM Unit
501+
useVotingProcedureWitness voter mbWitness = do
502+
cred <- case voter of
503+
Spo poolKeyHash -> do
504+
let cred = PubKeyHashCredential poolKeyHash
505+
case mbWitness of
506+
Just witness -> throwError $ UnneededSpoVoteWitness cred witness
507+
Nothing -> pure cred
508+
Cc cred -> pure cred
509+
Drep cred -> pure cred
510+
useCredentialWitness (Voting voter) (wrap cred) mbWitness
511+
441512
useCertificateWitness :: Certificate -> Maybe CredentialWitness -> BuilderM Unit
442-
useCertificateWitness cert mbWitness = do
443-
_transaction <<< _body <<< _certs %= pushUnique cert
513+
useCertificateWitness cert mbWitness =
444514
case cert of
445515
StakeDeregistration stakeCredential -> do
446516
case stakeCredential, mbWitness of
447-
StakeCredential (PubKeyHashCredential _), Just witness -> do
517+
StakeCredential (PubKeyHashCredential _), Just witness ->
448518
throwError $ UnneededDeregisterWitness stakeCredential witness
449519
StakeCredential (PubKeyHashCredential _), Nothing -> pure unit
450-
StakeCredential (ScriptHashCredential _), Nothing -> do
520+
StakeCredential (ScriptHashCredential _), Nothing ->
451521
throwError $
452-
WrongStakeCredentialType (StakeCert cert) PubKeyHashWitness stakeCredential
453-
StakeCredential (ScriptHashCredential scriptHash), Just witness -> do
522+
WrongStakeCredentialType (StakeCert cert) PubKeyHashWitness
523+
stakeCredential
524+
StakeCredential (ScriptHashCredential scriptHash), Just witness ->
454525
assertScriptHashMatchesCredentialWitness scriptHash witness
455526
useCredentialWitness (StakeCert cert) stakeCredential mbWitness
456-
StakeDelegation stakeCredential _ -> do
527+
StakeDelegation stakeCredential _ ->
457528
useCredentialWitness (StakeCert cert) stakeCredential mbWitness
458529
StakeRegistration _ -> pure unit
459530
PoolRegistration _ -> pure unit
460531
PoolRetirement _ -> pure unit
461532
_ -> pure unit -- TODO
462533

463534
useCredentialWitness
464-
:: CredentialAction -> StakeCredential -> Maybe CredentialWitness -> BuilderM Unit
465-
useCredentialWitness credentialAction stakeCredential witness = do
535+
:: CredentialAction
536+
-> StakeCredential
537+
-> Maybe CredentialWitness
538+
-> BuilderM Unit
539+
useCredentialWitness credentialAction stakeCredential witness =
466540
case witness of
467-
Nothing -> do
541+
Nothing ->
468542
assertStakeCredentialType credentialAction PubKeyHashWitness
469543
stakeCredential
470544
Just (NativeScriptCredential nsWitness) -> do
@@ -481,6 +555,7 @@ useCredentialWitness credentialAction stakeCredential witness = do
481555
Withdrawal rewardAddress -> ForReward rewardAddress
482556
StakeCert cert -> ForCert cert
483557
Minting scriptHash -> ForMint scriptHash
558+
Voting voter -> ForVote voter
484559
-- ForSpend is not possible: for that we use OutputWitness
485560
, datum: redeemerDatum
486561
}
@@ -502,7 +577,8 @@ useWithdrawRewardsWitness stakeCredential amount witness = do
502577

503578
-- | Tries to modify the transaction to make it consume a given output.
504579
-- | Uses a `SpendWitness` to try to satisfy spending requirements.
505-
useSpendWitness :: TransactionUnspentOutput -> Maybe OutputWitness -> BuilderM Unit
580+
useSpendWitness
581+
:: TransactionUnspentOutput -> Maybe OutputWitness -> BuilderM Unit
506582
useSpendWitness utxo = case _ of
507583
Nothing -> do
508584
assertOutputType PubKeyHashWitness utxo
@@ -601,4 +677,5 @@ pushUnique :: forall a. Ord a => a -> Array a -> Array a
601677
pushUnique x xs = nub $ xs <> [ x ]
602678

603679
bugTrackerUrl :: String
604-
bugTrackerUrl = "https://github.com/mlabs-haskell/purescript-cardano-transaction-builder/issues"
680+
bugTrackerUrl =
681+
"https://github.com/mlabs-haskell/purescript-cardano-transaction-builder/issues"

‎src/Cardano/Transaction/Edit.purs

+20-4
Original file line numberDiff line numberDiff line change
@@ -36,7 +36,18 @@ module Cardano.Transaction.Edit
3636

3737
import Prelude
3838

39-
import Cardano.Types (Certificate, Redeemer(Redeemer), RedeemerTag(Mint, Spend, Reward, Cert, Propose, Vote), RewardAddress, ScriptHash, Transaction(Transaction), TransactionBody(TransactionBody), TransactionInput, _redeemers, _witnessSet)
39+
import Cardano.Types
40+
( Certificate
41+
, Redeemer(Redeemer)
42+
, RedeemerTag(Mint, Spend, Reward, Cert, Propose, Vote)
43+
, RewardAddress
44+
, ScriptHash
45+
, Transaction(Transaction)
46+
, TransactionBody(TransactionBody)
47+
, TransactionInput
48+
, _redeemers
49+
, _witnessSet
50+
)
4051
import Cardano.Types.BigNum as BigNum
4152
import Cardano.Types.ExUnits as ExUnits
4253
import Cardano.Types.RedeemerDatum (RedeemerDatum)
@@ -156,7 +167,8 @@ attachRedeemer ctx { purpose, datum } = do
156167
ForVote voter -> findIndex (eq voter) ctx.voters <#> \index ->
157168
{ tag: Vote, index }
158169
pure $
159-
Redeemer { tag, index: BigNum.fromInt index, data: datum, exUnits: ExUnits.empty }
170+
Redeemer
171+
{ tag, index: BigNum.fromInt index, data: datum, exUnits: ExUnits.empty }
160172

161173
-- | A transaction with redeemers detached.
162174
type EditableTransaction =
@@ -181,7 +193,10 @@ toEditableTransaction tx =
181193
}
182194
where
183195
partitionWith
184-
:: forall a b. (a -> Maybe b) -> Array a -> { no :: Array a, yes :: Array b }
196+
:: forall a b
197+
. (a -> Maybe b)
198+
-> Array a
199+
-> { no :: Array a, yes :: Array b }
185200
partitionWith f =
186201
map (\x -> note x (f x)) >>> \arr ->
187202
{ no: arr # map blush # catMaybes
@@ -242,7 +257,8 @@ editTransaction f tx =
242257
let
243258
editableTx = toEditableTransaction tx
244259
processedTransaction = f editableTx.transaction
245-
{ redeemers: newValidRedeemers } = toEditableTransaction processedTransaction
260+
{ redeemers: newValidRedeemers } = toEditableTransaction
261+
processedTransaction
246262
editedTx = editableTx
247263
{ transaction = processedTransaction
248264
, redeemers = nub $ editableTx.redeemers <> newValidRedeemers

0 commit comments

Comments
 (0)