Merge pull request #110 from input-output-hk/jordan/drep-registration…

…-command

Add DRep registration certificate command

cardano-cli/src/Cardano/CLI/EraBased/Certificate.hs

@@ -7,6 +7,9 @@
 module Cardano.CLI.EraBased.Certificate
   ( EraBasedDelegationError(..)
   , runGovernanceDelegrationCertificate
+
+  , EraBasedRegistrationError(..)
+  , runGovernanceRegistrationCertificate
   ) where
 
 import           Cardano.Api
@@ -21,6 +24,9 @@ import           Control.Monad.Trans.Except (ExceptT)
 import           Control.Monad.Trans.Except.Extra
 import           Data.Function
 
+
+-- Delegation Certificate related
+
 data EraBasedDelegationError
   = EraBasedDelegReadError !(FileError InputDecodeError)
   | EraBasedCredentialError !ShelleyStakeAddressCmdError -- TODO: Refactor. We shouldn't be using legacy error types
@@ -93,3 +99,166 @@ toLedgerDelegatee t =
       right $ Ledger.DelegStakeVote
                 (conwayEraOnwardsConstraints cOnwards kHash)
                 (conwayEraOnwardsConstraints cOnwards drepCred)
+
+--------------------------------------------------------------------------------
+
+-- Registration Certificate related
+
+
+data EraBasedRegistrationError
+  = EraBasedRegistReadError !(FileError InputDecodeError)
+  | EraBasedRegistWriteFileError !(FileError ())
+  | EraBasedRegistStakeCredReadError !ShelleyStakeAddressCmdError -- TODO: Conway era - don't use legacy error type
+  | EraBasedRegistStakeError StakeAddressRegistrationError
+
+runGovernanceRegistrationCertificate
+  :: AnyRegistrationTarget
+  -> File () Out
+  -> ExceptT EraBasedRegistrationError IO ()
+runGovernanceRegistrationCertificate anyReg outfp =
+  case anyReg of
+    ShelleyToBabbageStakePoolRegTarget stoB regReqs -> do
+      -- Pool verification key
+      stakePoolVerKey <- firstExceptT EraBasedRegistReadError
+        . newExceptT
+        $ readVerificationKeyOrFile AsStakePoolKey $ sprStakePoolKey regReqs
+      let stakePoolId' = verificationKeyHash stakePoolVerKey
+
+      -- VRF verification key
+      vrfVerKey <- firstExceptT EraBasedRegistReadError
+        . newExceptT
+        $ readVerificationKeyOrFile AsVrfKey $ sprVrfKey regReqs
+      let vrfKeyHash' = verificationKeyHash vrfVerKey
+
+      -- Pool reward account
+      rwdStakeVerKey <- firstExceptT EraBasedRegistReadError
+        . newExceptT
+        $ readVerificationKeyOrFile AsStakeKey $ sprRewardAccountKey regReqs
+      let stakeCred = StakeCredentialByKey (verificationKeyHash rwdStakeVerKey)
+          rewardAccountAddr = makeStakeAddress (sprNetworkId regReqs) stakeCred
+
+      -- Pool owner(s)
+      sPoolOwnerVkeys <-
+        mapM
+          (firstExceptT EraBasedRegistReadError
+            . newExceptT
+            . readVerificationKeyOrFile AsStakeKey
+          )
+          (spoPoolOwnerKeys regReqs)
+      let stakePoolOwners' = map verificationKeyHash sPoolOwnerVkeys
+
+      let stakePoolParams =
+            StakePoolParameters
+              { stakePoolId = stakePoolId'
+              , stakePoolVRF = vrfKeyHash'
+              , stakePoolCost = sprPoolCost regReqs
+              , stakePoolMargin = sprPoolMargin regReqs
+              , stakePoolRewardAccount = rewardAccountAddr
+              , stakePoolPledge = sprPoolPledge regReqs
+              , stakePoolOwners = stakePoolOwners'
+              , stakePoolRelays = sprRelays regReqs
+              , stakePoolMetadata = sprMetadata regReqs
+              }
+
+      let ledgerStakePoolParams = toShelleyPoolParams stakePoolParams
+          req = StakePoolRegistrationRequirementsPreConway stoB $ shelleyCertificateConstraints stoB ledgerStakePoolParams
+          registrationCert = makeStakePoolRegistrationCertificate req
+          description = Just @TextEnvelopeDescr "Stake Pool Registration Certificate"
+      firstExceptT EraBasedRegistWriteFileError
+        . newExceptT
+        . writeLazyByteStringFile outfp
+        $ shelleyCertificateConstraints stoB
+        $ textEnvelopeToJSON description registrationCert
+
+    ShelleyToBabbageStakeKeyRegTarget sToB stakeIdentifier -> do
+      stakeCred <- firstExceptT EraBasedRegistStakeCredReadError
+                     $ getStakeCredentialFromIdentifier stakeIdentifier
+      let req = StakeAddrRegistrationPreConway sToB stakeCred
+          registrationCert = makeStakeAddressRegistrationCertificate req
+          description = Just @TextEnvelopeDescr "Stake Key Registration Certificate"
+      firstExceptT EraBasedRegistWriteFileError
+        . newExceptT
+        . writeLazyByteStringFile outfp
+        $ shelleyCertificateConstraints sToB
+        $ textEnvelopeToJSON description registrationCert
+
+    ConwayOnwardRegTarget _ regTarget ->
+      case regTarget of
+        RegisterStakePool cOnwards regReqs -> do
+          -- Pool verification key
+          stakePoolVerKey <- firstExceptT EraBasedRegistReadError
+            . newExceptT
+            $ readVerificationKeyOrFile AsStakePoolKey $ sprStakePoolKey regReqs
+          let stakePoolId' = verificationKeyHash stakePoolVerKey
+          -- VRF verification key
+          vrfVerKey <- firstExceptT EraBasedRegistReadError
+                         . newExceptT
+                         $ readVerificationKeyOrFile AsVrfKey $ sprVrfKey regReqs
+          let vrfKeyHash' = verificationKeyHash vrfVerKey
+          -- Pool reward account
+          rwdStakeVerKey <- firstExceptT EraBasedRegistReadError
+                              . newExceptT
+                              $ readVerificationKeyOrFile AsStakeKey $ sprRewardAccountKey regReqs
+          let stakeCred = StakeCredentialByKey (verificationKeyHash rwdStakeVerKey)
+              rewardAccountAddr = makeStakeAddress (sprNetworkId regReqs) stakeCred
+          -- Pool owner(s)
+          sPoolOwnerVkeys <-
+                mapM
+                  (firstExceptT EraBasedRegistReadError
+                    . newExceptT
+                    . readVerificationKeyOrFile AsStakeKey
+                  )
+                  (spoPoolOwnerKeys regReqs)
+          let stakePoolOwners' = map verificationKeyHash sPoolOwnerVkeys
+
+          let stakePoolParams =
+                StakePoolParameters
+                  { stakePoolId = stakePoolId'
+                  , stakePoolVRF = vrfKeyHash'
+                  , stakePoolCost = sprPoolCost regReqs
+                  , stakePoolMargin = sprPoolMargin regReqs
+                  , stakePoolRewardAccount = rewardAccountAddr
+                  , stakePoolPledge = sprPoolPledge regReqs
+                  , stakePoolOwners = stakePoolOwners'
+                  , stakePoolRelays = sprRelays regReqs
+                  , stakePoolMetadata = sprMetadata regReqs
+                  }
+
+          let ledgerStakePoolParams = toShelleyPoolParams stakePoolParams
+              req = StakePoolRegistrationRequirementsConwayOnwards cOnwards
+                      $ conwayCertificateConstraints cOnwards ledgerStakePoolParams
+              registrationCert = makeStakePoolRegistrationCertificate req
+              description = Just @TextEnvelopeDescr "Stake Pool Registration Certificate"
+          firstExceptT EraBasedRegistWriteFileError
+            . newExceptT
+            . writeLazyByteStringFile outfp
+            $ conwayCertificateConstraints cOnwards
+            $ textEnvelopeToJSON description registrationCert
+        RegisterStakeKey cOnwards sIdentifier deposit -> do
+          stakeCred <- firstExceptT EraBasedRegistStakeCredReadError
+                         $ getStakeCredentialFromIdentifier sIdentifier
+          let req = StakeAddrRegistrationConway cOnwards deposit stakeCred
+              registrationCert = makeStakeAddressRegistrationCertificate req
+              description = Just @TextEnvelopeDescr "Stake Key Registration Certificate"
+          firstExceptT EraBasedRegistWriteFileError
+            . newExceptT
+            . writeLazyByteStringFile outfp
+            $ conwayCertificateConstraints cOnwards
+            $ textEnvelopeToJSON description registrationCert
+        RegisterDRep cOnwards drepVKey deposit -> do
+          DRepKeyHash drepKeyHash <- firstExceptT EraBasedRegistReadError
+            . newExceptT
+            $ readVerificationKeyOrHashOrFile AsDRepKey drepVKey
+          let drepCred = Ledger.KeyHashObj $ conwayCertificateConstraints cOnwards drepKeyHash
+              votingCredential = VotingCredential drepCred
+              req = DRepRegistrationRequirements cOnwards votingCredential deposit
+              registrationCert = makeDrepRegistrationCertificate req
+              description = Just @TextEnvelopeDescr "DRep Key Registration Certificate"
+
+          firstExceptT EraBasedRegistWriteFileError
+            . newExceptT
+            . writeLazyByteStringFile outfp
+            $ conwayCertificateConstraints cOnwards
+            $ textEnvelopeToJSON description registrationCert
+
+--------------------------------------------------------------------------------

cardano-cli/src/Cardano/CLI/EraBased/Legacy.hs

@@ -15,6 +15,7 @@ module Cardano.CLI.EraBased.Legacy
   , parseTxIn
 
   , pKeyRegistDeposit
+  , pStakePoolRegistrationParserRequirements
   , pStakePoolVerificationKeyOrHashOrFile
   ) where
 
@@ -27,8 +28,8 @@ import           Cardano.CLI.Environment (EnvCli (..))
 import           Cardano.CLI.EraBased.Governance
 import           Cardano.CLI.EraBased.Options.Common
 import           Cardano.CLI.Types.Key (DelegationTarget (..), PaymentVerifier (..),
-                   VerificationKeyOrFile (..), VerificationKeyOrHashOrFile (..),
-                   VerificationKeyTextOrFile (..))
+                   StakePoolRegistrationParserRequirements (..), VerificationKeyOrFile (..),
+                   VerificationKeyOrHashOrFile (..), VerificationKeyTextOrFile (..))
 import           Cardano.CLI.Types.Legacy
 import qualified Cardano.Ledger.BaseTypes as Shelley
 import           Cardano.Prelude (ConvertText (..))
@@ -3033,6 +3034,23 @@ pStakePoolRegistrationCert envCli =
     <*> pNetworkId envCli
     <*> pOutputFile
 
+
+pStakePoolRegistrationParserRequirements
+  :: EnvCli -> Parser StakePoolRegistrationParserRequirements
+pStakePoolRegistrationParserRequirements envCli =
+  StakePoolRegistrationParserRequirements
+    <$> pStakePoolVerificationKeyOrFile
+    <*> pVrfVerificationKeyOrFile
+    <*> pPoolPledge
+    <*> pPoolCost
+    <*> pPoolMargin
+    <*> pRewardAcctVerificationKeyOrFile
+    <*> some pPoolOwnerVerificationKeyOrFile
+    <*> many pPoolRelay
+    <*> pStakePoolMetadataReference
+    <*> pNetworkId envCli
+
+
 pStakePoolRetirementCert :: EnvCli -> Parser PoolCmd
 pStakePoolRetirementCert envCli =
   PoolRetirementCert

cardano-cli/src/Cardano/CLI/EraBased/Options/Governance.hs

@@ -41,6 +41,9 @@ data EraBasedGovernanceCmd era
       StakeIdentifier
       AnyDelegationTarget
       (File () Out)
+  | EraBasedGovernanceRegistrationCertificateCmd
+      AnyRegistrationTarget
+      (File () Out)
 
 renderEraBasedGovernanceCmd :: EraBasedGovernanceCmd era -> Text
 renderEraBasedGovernanceCmd = \case
@@ -49,15 +52,58 @@ renderEraBasedGovernanceCmd = \case
   EraBasedGovernanceMIRPayStakeAddressesCertificate {} -> "TODO EraBasedGovernanceMIRPayStakeAddressesCertificate"
   EraBasedGovernanceMIRTransfer {} -> "TODO EraBasedGovernanceMIRTransfer"
   EraBasedGovernanceDelegationCertificateCmd {} -> "governance delegation-certificate"
+  EraBasedGovernanceRegistrationCertificateCmd {} -> "governance registration-certificate"
 
--- TODO: Conway era - move to Cardano.CLI.Conway.Parsers
 pEraBasedGovernanceCmd :: EnvCli -> CardanoEra era -> Parser (EraBasedGovernanceCmd era)
 pEraBasedGovernanceCmd envCli era =
   asum $ catMaybes
-    [ pEraBasedDelegationCertificateCmd envCli era
+    [ pEraBasedRegistrationCertificateCmd envCli era
+    , pEraBasedDelegationCertificateCmd envCli era
     , pCreateMirCertificatesCmds era
     ]
 
+
+-- Registration Certificate related
+
+
+pEraBasedRegistrationCertificateCmd
+  :: EnvCli -> CardanoEra era -> Maybe (Parser (EraBasedGovernanceCmd era))
+pEraBasedRegistrationCertificateCmd envCli =
+  featureInEra Nothing $ \w ->
+    Just
+      $ subParser "registration-certificate"
+      $ Opt.info (pEraCmd envCli w)
+      $ Opt.progDesc "Create a registration certificate."
+ where
+  pEraCmd :: EnvCli -> AnyEraDecider era -> Parser (EraBasedGovernanceCmd era)
+  pEraCmd envCli' = \case
+    AnyEraDeciderShelleyToBabbage sToB ->
+      EraBasedGovernanceRegistrationCertificateCmd
+        <$> asum [ ShelleyToBabbageStakePoolRegTarget sToB
+                     <$> pStakePoolRegistrationParserRequirements envCli'
+                 , ShelleyToBabbageStakeKeyRegTarget sToB
+                     <$> pStakeIdentifier
+                 ]
+        <*> pOutputFile
+
+    AnyEraDeciderConwayOnwards cOn ->
+      EraBasedGovernanceRegistrationCertificateCmd . ConwayOnwardRegTarget cOn
+        <$> asum [ RegisterStakePool cOn
+                     <$> pStakePoolRegistrationParserRequirements envCli'
+                 , RegisterStakeKey cOn
+                     <$> pStakeIdentifier
+                     <*> pKeyRegistDeposit
+                 , RegisterDRep cOn
+                     <$> pDRepVerificationKeyOrHashOrFile
+                     <*> pKeyRegistDeposit
+                 ]
+        <*> pOutputFile
+
+
+
+--------------------------------------------------------------------------------
+
+
 data AnyEraDecider era where
   AnyEraDeciderShelleyToBabbage :: ShelleyToBabbageEra era -> AnyEraDecider era
   AnyEraDeciderConwayOnwards :: ConwayEraOnwards era -> AnyEraDecider era
@@ -72,13 +118,15 @@ instance FeatureInEra AnyEraDecider where
     BabbageEra  -> yes $ AnyEraDeciderShelleyToBabbage ShelleyToBabbageEraBabbage
     ConwayEra   -> yes $ AnyEraDeciderConwayOnwards ConwayEraOnwardsConway
 
+-- Delegation Certificate related
+
 pEraBasedDelegationCertificateCmd :: EnvCli -> CardanoEra era -> Maybe (Parser (EraBasedGovernanceCmd era))
 pEraBasedDelegationCertificateCmd _envCli =
   featureInEra Nothing $ \w ->
     Just
       $ subParser "delegation-certificate"
       $ Opt.info (pCmd w)
-      $ Opt.progDesc "Post conway era governance command" -- TODO: We can render the help message based on the era
+      $ Opt.progDesc "Delegation certificate creation."
  where
   pCmd :: AnyEraDecider era -> Parser (EraBasedGovernanceCmd era)
   pCmd w =
@@ -98,6 +146,7 @@ pEraBasedDelegationCertificateCmd _envCli =
       AnyEraDeciderConwayOnwards cOnwards ->
         ConwayOnwardDelegTarget cOnwards
           <$> pStakeTarget cOnwards
+
 -- TODO: Conway era AFTER sancho net. We probably want to
 -- differentiate between delegating voting stake and reward stake
 pStakeTarget :: ConwayEraOnwards era -> Parser (StakeTarget era)
@@ -153,6 +202,7 @@ pDRepVerificationKeyFile =
     , Opt.completer (Opt.bashCompleter "file")
     ]
 
+--------------------------------------------------------------------------------
 
 pCreateMirCertificatesCmds :: CardanoEra era -> Maybe (Parser (EraBasedGovernanceCmd era))
 pCreateMirCertificatesCmds =

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

@@ -49,16 +49,21 @@ runEraBasedGovernanceCmd = \case
   EraBasedGovernancePostConwayCmd w ->
     runEraBasedGovernancePostConwayCmd w
   EraBasedGovernanceMIRPayStakeAddressesCertificate w mirpot vKeys rewards out ->
-    firstExceptT (const ()) -- TODO fix error handling
+    firstExceptT (const ()) -- TODO: Conway era - fix error handling
       $ runGovernanceMIRCertificatePayStakeAddrs w mirpot vKeys rewards out
+
   EraBasedGovernanceMIRTransfer w ll oFp direction ->
-    firstExceptT (const ()) -- TODO fix error handling
+    firstExceptT (const ()) -- TODO: Conway era - fix error handling
       $ runGovernanceMIRCertificateTransfer w ll oFp direction
 
   EraBasedGovernanceDelegationCertificateCmd stakeIdentifier delegationTarget outFp ->
-    firstExceptT (const ()) -- TODO fix error handling
+    firstExceptT (const ()) -- TODO: Conway era - fix error handling
       $ runGovernanceDelegrationCertificate stakeIdentifier delegationTarget outFp
 
+  EraBasedGovernanceRegistrationCertificateCmd regTarget outFp ->
+    firstExceptT (const ()) -- TODO: Conway era - fix error handling
+      $ runGovernanceRegistrationCertificate regTarget outFp
+
 runEraBasedGovernancePreConwayCmd
   :: ShelleyToBabbageEra era
   -> ExceptT () IO ()

cardano-cli/src/Cardano/CLI/Run/Legacy/StakeAddress.hs

@@ -16,6 +16,9 @@ module Cardano.CLI.Run.Legacy.StakeAddress
 
   , StakeAddressDelegationError(..)
   , createDelegationCertRequirements
+
+  , StakeAddressRegistrationError(..)
+  , createRegistrationCertRequirements
   ) where
 
 import           Cardano.Api