← Back to branch summary

~zinigor/cardano-node/trunk

« back to all changes in this revision

Viewing changes to cardano-cli/src/Cardano/CLI/Shelley/Run/Governance.hs

  • Committer: Igor Zinovyev
  • Date: 2021-08-13 19:12:27 UTC
  • Revision ID: zinigor@gmail.com-20210813191227-stlnsj3mc5ypwn0c
Tags: upstream-1.27.0
Import upstream version 1.27.0

Show diffs side-by-side

added added

removed removed

Lines of Context:
cardano-cli/src/Cardano/CLI/Shelley/Run/Governance.hs
 
1
module Cardano.CLI.Shelley.Run.Governance
 
2
  ( ShelleyGovernanceCmdError
 
3
  , renderShelleyGovernanceError
 
4
  , runGovernanceCmd
 
5
  ) where
 
6
 
 
7
import           Cardano.Prelude
 
8
 
 
9
import qualified Data.Text as Text
 
10
 
 
11
import           Control.Monad.Trans.Except.Extra (firstExceptT, left, newExceptT)
 
12
 
 
13
import           Cardano.Api
 
14
import           Cardano.Api.Shelley
 
15
 
 
16
import           Cardano.CLI.Shelley.Key (InputDecodeError, VerificationKeyOrHashOrFile,
 
17
                   readVerificationKeyOrHashOrFile, readVerificationKeyOrHashOrTextEnvFile)
 
18
import           Cardano.CLI.Shelley.Parsers
 
19
import           Cardano.CLI.Types
 
20
 
 
21
import qualified Shelley.Spec.Ledger.TxBody as Shelley
 
22
 
 
23
 
 
24
data ShelleyGovernanceCmdError
 
25
  = ShelleyGovernanceCmdTextEnvReadError !(FileError TextEnvelopeError)
 
26
  | ShelleyGovernanceCmdKeyReadError !(FileError InputDecodeError)
 
27
  | ShelleyGovernanceCmdTextEnvWriteError !(FileError ())
 
28
  | ShelleyGovernanceCmdEmptyUpdateProposalError
 
29
  | ShelleyGovernanceCmdMIRCertificateKeyRewardMistmach
 
30
      !FilePath
 
31
      !Int
 
32
      -- ^ Number of stake verification keys
 
33
      !Int
 
34
      -- ^ Number of reward amounts
 
35
  deriving Show
 
36
 
 
37
renderShelleyGovernanceError :: ShelleyGovernanceCmdError -> Text
 
38
renderShelleyGovernanceError err =
 
39
  case err of
 
40
    ShelleyGovernanceCmdTextEnvReadError fileErr -> Text.pack (displayError fileErr)
 
41
    ShelleyGovernanceCmdKeyReadError fileErr -> Text.pack (displayError fileErr)
 
42
    ShelleyGovernanceCmdTextEnvWriteError fileErr -> Text.pack (displayError fileErr)
 
43
    -- TODO: The equality check is still not working for empty update proposals.
 
44
    ShelleyGovernanceCmdEmptyUpdateProposalError ->
 
45
      "Empty update proposals are not allowed"
 
46
    ShelleyGovernanceCmdMIRCertificateKeyRewardMistmach fp numVKeys numRwdAmts ->
 
47
       "Error creating the MIR certificate at: " <> textShow fp
 
48
       <> " The number of staking keys: " <> textShow numVKeys
 
49
       <> " and the number of reward amounts: " <> textShow numRwdAmts
 
50
       <> " are not equivalent."
 
51
  where
 
52
    textShow x = Text.pack (show x)
 
53
 
 
54
 
 
55
runGovernanceCmd :: GovernanceCmd -> ExceptT ShelleyGovernanceCmdError IO ()
 
56
runGovernanceCmd (GovernanceMIRPayStakeAddressesCertificate mirpot vKeys rewards out) =
 
57
  runGovernanceMIRCertificatePayStakeAddrs mirpot vKeys rewards out
 
58
runGovernanceCmd (GovernanceMIRTransfer amt out direction) =
 
59
  runGovernanceMIRCertificateTransfer amt out direction
 
60
runGovernanceCmd (GovernanceGenesisKeyDelegationCertificate genVk genDelegVk vrfVk out) =
 
61
  runGovernanceGenesisKeyDelegationCertificate genVk genDelegVk vrfVk out
 
62
runGovernanceCmd (GovernanceUpdateProposal out eNo genVKeys ppUp) =
 
63
  runGovernanceUpdateProposal out eNo genVKeys ppUp
 
64
 
 
65
runGovernanceMIRCertificatePayStakeAddrs
 
66
  :: Shelley.MIRPot
 
67
  -> [StakeAddress] -- ^ Stake addresses
 
68
  -> [Lovelace]     -- ^ Corresponding reward amounts (same length)
 
69
  -> OutputFile
 
70
  -> ExceptT ShelleyGovernanceCmdError IO ()
 
71
runGovernanceMIRCertificatePayStakeAddrs mirPot sAddrs rwdAmts (OutputFile oFp) = do
 
72
 
 
73
    unless (length sAddrs == length rwdAmts) $
 
74
      left $ ShelleyGovernanceCmdMIRCertificateKeyRewardMistmach
 
75
               oFp (length sAddrs) (length rwdAmts)
 
76
 
 
77
    let sCreds  = map stakeAddrToStakeCredential sAddrs
 
78
        mirCert = makeMIRCertificate mirPot (StakeAddressesMIR $ zip sCreds rwdAmts)
 
79
 
 
80
    firstExceptT ShelleyGovernanceCmdTextEnvWriteError
 
81
      . newExceptT
 
82
      $ writeFileTextEnvelope oFp (Just mirCertDesc) mirCert
 
83
  where
 
84
    mirCertDesc :: TextEnvelopeDescr
 
85
    mirCertDesc = "Move Instantaneous Rewards Certificate"
 
86
 
 
87
    --TODO: expose a pattern for StakeAddress that give us the StakeCredential
 
88
    stakeAddrToStakeCredential :: StakeAddress -> StakeCredential
 
89
    stakeAddrToStakeCredential (StakeAddress _ scred) =
 
90
      fromShelleyStakeCredential scred
 
91
 
 
92
runGovernanceMIRCertificateTransfer
 
93
  :: Lovelace
 
94
  -> OutputFile
 
95
  -> TransferDirection
 
96
  -> ExceptT ShelleyGovernanceCmdError IO ()
 
97
runGovernanceMIRCertificateTransfer ll (OutputFile oFp) direction = do
 
98
  mirCert <- case direction of
 
99
                 TransferToReserves ->
 
100
                   return . makeMIRCertificate Shelley.TreasuryMIR $ SendToReservesMIR ll
 
101
                 TransferToTreasury ->
 
102
                   return . makeMIRCertificate Shelley.ReservesMIR $ SendToTreasuryMIR ll
 
103
 
 
104
  firstExceptT ShelleyGovernanceCmdTextEnvWriteError
 
105
    . newExceptT
 
106
    $ writeFileTextEnvelope oFp (Just $ mirCertDesc direction) mirCert
 
107
 where
 
108
  mirCertDesc :: TransferDirection -> TextEnvelopeDescr
 
109
  mirCertDesc TransferToTreasury = "MIR Certificate Send To Treasury"
 
110
  mirCertDesc TransferToReserves = "MIR Certificate Send To Reserves"
 
111
 
 
112
 
 
113
runGovernanceGenesisKeyDelegationCertificate
 
114
  :: VerificationKeyOrHashOrFile GenesisKey
 
115
  -> VerificationKeyOrHashOrFile GenesisDelegateKey
 
116
  -> VerificationKeyOrHashOrFile VrfKey
 
117
  -> OutputFile
 
118
  -> ExceptT ShelleyGovernanceCmdError IO ()
 
119
runGovernanceGenesisKeyDelegationCertificate genVkOrHashOrFp
 
120
                                             genDelVkOrHashOrFp
 
121
                                             vrfVkOrHashOrFp
 
122
                                             (OutputFile oFp) = do
 
123
    genesisVkHash <- firstExceptT ShelleyGovernanceCmdKeyReadError
 
124
      . newExceptT
 
125
      $ readVerificationKeyOrHashOrTextEnvFile AsGenesisKey genVkOrHashOrFp
 
126
    genesisDelVkHash <-firstExceptT ShelleyGovernanceCmdKeyReadError
 
127
      . newExceptT
 
128
      $ readVerificationKeyOrHashOrTextEnvFile AsGenesisDelegateKey genDelVkOrHashOrFp
 
129
    vrfVkHash <- firstExceptT ShelleyGovernanceCmdKeyReadError
 
130
      . newExceptT
 
131
      $ readVerificationKeyOrHashOrFile AsVrfKey vrfVkOrHashOrFp
 
132
    firstExceptT ShelleyGovernanceCmdTextEnvWriteError
 
133
      . newExceptT
 
134
      $ writeFileTextEnvelope oFp (Just genKeyDelegCertDesc)
 
135
      $ makeGenesisKeyDelegationCertificate genesisVkHash genesisDelVkHash vrfVkHash
 
136
  where
 
137
    genKeyDelegCertDesc :: TextEnvelopeDescr
 
138
    genKeyDelegCertDesc = "Genesis Key Delegation Certificate"
 
139
 
 
140
runGovernanceUpdateProposal
 
141
  :: OutputFile
 
142
  -> EpochNo
 
143
  -> [VerificationKeyFile]
 
144
  -- ^ Genesis verification keys
 
145
  -> ProtocolParametersUpdate
 
146
  -> ExceptT ShelleyGovernanceCmdError IO ()
 
147
runGovernanceUpdateProposal (OutputFile upFile) eNo genVerKeyFiles upPprams = do
 
148
    when (upPprams == mempty) $ left ShelleyGovernanceCmdEmptyUpdateProposalError
 
149
    genVKeys <- sequence
 
150
                  [ firstExceptT ShelleyGovernanceCmdTextEnvReadError . newExceptT $
 
151
                      readFileTextEnvelope
 
152
                        (AsVerificationKey AsGenesisKey)
 
153
                        vkeyFile
 
154
                  | VerificationKeyFile vkeyFile <- genVerKeyFiles ]
 
155
    let genKeyHashes = map verificationKeyHash genVKeys
 
156
        upProp = makeShelleyUpdateProposal upPprams genKeyHashes eNo
 
157
    firstExceptT ShelleyGovernanceCmdTextEnvWriteError . newExceptT $
 
158
      writeFileTextEnvelope upFile Nothing upProp