Merge pull request #275 from input-output-hk/newhoggy/era-based-stake…

…-pool-command

Era-based `stake-pool` command

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

@@ -19,6 +19,7 @@ import           Cardano.CLI.EraBased.Commands.Key
 import           Cardano.CLI.EraBased.Commands.Node
 import           Cardano.CLI.EraBased.Commands.Query
 import           Cardano.CLI.EraBased.Commands.StakeAddress
+import           Cardano.CLI.EraBased.Commands.StakePool
 import           Cardano.CLI.EraBased.Commands.TextView
 import           Cardano.CLI.EraBased.Commands.Transaction
 import           Cardano.CLI.EraBased.Options.Address
@@ -29,6 +30,7 @@ import           Cardano.CLI.EraBased.Options.Key
 import           Cardano.CLI.EraBased.Options.Node
 import           Cardano.CLI.EraBased.Options.Query
 import           Cardano.CLI.EraBased.Options.StakeAddress
+import           Cardano.CLI.EraBased.Options.StakePool
 import           Cardano.CLI.EraBased.Options.TextView
 import           Cardano.CLI.EraBased.Options.Transaction
 
@@ -53,6 +55,7 @@ data Cmds era
   | NodeCmds            (NodeCmds era)
   | QueryCmds           (QueryCmds era)
   | StakeAddressCmds    (StakeAddressCmds era)
+  | StakePoolCmds       (StakePoolCmds era)
   | TextViewCmds        (TextViewCmds era)
   | TransactionCmds     (TransactionCmds era)
 
@@ -72,6 +75,8 @@ renderCmds = \case
     renderQueryCmds cmd
   StakeAddressCmds cmd ->
     renderStakeAddressCmds cmd
+  StakePoolCmds cmd ->
+    renderStakePoolCmds cmd
   TextViewCmds cmd ->
     renderTextViewCmds cmd
   TransactionCmds cmd ->
@@ -134,6 +139,10 @@ pCmds envCli era =
         $ Opt.info (QueryCmds <$> pQueryCmds envCli)
         $ Opt.progDesc "Era-based query commands"
     , fmap StakeAddressCmds <$> pStakeAddressCmds era envCli
+    , Just
+        $ subParser "stake-pool"
+        $ Opt.info (StakePoolCmds <$> pStakePoolCmds era envCli)
+        $ Opt.progDesc "Era-based text-view commands"
     , Just
         $ subParser "text-view"
         $ Opt.info (TextViewCmds <$> pTextViewCmds)

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

@@ -23,6 +23,7 @@ import           Cardano.CLI.EraBased.Run.Key
 import           Cardano.CLI.EraBased.Run.Node
 import           Cardano.CLI.EraBased.Run.Query
 import           Cardano.CLI.EraBased.Run.StakeAddress
+import           Cardano.CLI.EraBased.Run.StakePool
 import           Cardano.CLI.EraBased.Run.TextView
 import           Cardano.CLI.EraBased.Run.Transaction
 import           Cardano.CLI.Types.Errors.CmdError
@@ -61,6 +62,9 @@ runCmds = \case
   StakeAddressCmds cmd ->
     runStakeAddressCmds cmd
       & firstExceptT CmdStakeAddressError
+  StakePoolCmds cmd ->
+    runStakePoolCmds cmd
+      & firstExceptT CmdStakePoolError
   TextViewCmds cmd ->
     runTextViewCmds cmd
       & firstExceptT CmdTextViewError

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

@@ -1,9 +1,12 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
 
 module Cardano.CLI.EraBased.Run.StakePool
-  ( runStakePoolIdCmd
+  ( runStakePoolCmds
+
+  , runStakePoolIdCmd
   , runStakePoolMetadataHashCmd
   , runStakePoolRegistrationCertificateCmd
   , runStakePoolRetirementCertificateCmd
@@ -13,6 +16,7 @@ import           Cardano.Api
 import qualified Cardano.Api.Ledger as Ledger
 import           Cardano.Api.Shelley
 
+import           Cardano.CLI.EraBased.Commands.StakePool
 import           Cardano.CLI.Types.Common
 import           Cardano.CLI.Types.Errors.StakePoolCmdError
 import           Cardano.CLI.Types.Key (VerificationKeyOrFile, readVerificationKeyOrFile)
@@ -26,6 +30,19 @@ import           Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT
 import qualified Data.ByteString.Char8 as BS
 import           Data.Function ((&))
 
+runStakePoolCmds :: ()
+  => StakePoolCmds era
+  -> ExceptT StakePoolCmdError IO ()
+runStakePoolCmds = \case
+  StakePoolDeregistrationCertificateCmd sbe sPvkeyFp retireEpoch outfp ->
+    runStakePoolRetirementCertificateCmd sbe sPvkeyFp retireEpoch outfp
+  StakePoolIdCmd sPvkey outputFormat mOutFile ->
+    runStakePoolIdCmd sPvkey outputFormat mOutFile
+  StakePoolMetadataHashCmd poolMdFile mOutFile ->
+    runStakePoolMetadataHashCmd poolMdFile mOutFile
+  StakePoolRegistrationCertificateCmd sbe sPvkey vrfVkey pldg pCost pMrgn rwdVerFp ownerVerFps relays mbMetadata network outfp ->
+    runStakePoolRegistrationCertificateCmd sbe sPvkey vrfVkey pldg pCost pMrgn rwdVerFp ownerVerFps relays mbMetadata network outfp
+
 --
 -- Stake pool command implementations
 --
@@ -34,7 +51,7 @@ import           Data.Function ((&))
 -- TODO: Metadata and more stake pool relay support to be
 -- added in the future.
 runStakePoolRegistrationCertificateCmd
-  :: AnyShelleyBasedEra
+  :: ShelleyBasedEra era
   -> VerificationKeyOrFile StakePoolKey
   -- ^ Stake pool verification key.
   -> VerificationKeyOrFile VrfKey
@@ -57,7 +74,7 @@ runStakePoolRegistrationCertificateCmd
   -> File () Out
   -> ExceptT StakePoolCmdError IO ()
 runStakePoolRegistrationCertificateCmd
-  anyEra
+  sbe
   stakePoolVerKeyOrFile
   vrfVerKeyOrFile
   pldg
@@ -68,9 +85,7 @@ runStakePoolRegistrationCertificateCmd
   relays
   mbMetadata
   network
-  outfp = do
-    AnyShelleyBasedEra sbe <- pure anyEra
-
+  outfp = shelleyBasedEraConstraints sbe $ do
     -- Pool verification key
     stakePoolVerKey <- firstExceptT StakePoolCmdReadKeyFileError
       . newExceptT
@@ -126,8 +141,8 @@ runStakePoolRegistrationCertificateCmd
     registrationCertDesc :: TextEnvelopeDescr
     registrationCertDesc = "Stake Pool Registration Certificate"
 
-createStakePoolRegistrationRequirements
-  :: ShelleyBasedEra era
+createStakePoolRegistrationRequirements :: ()
+  => ShelleyBasedEra era
   -> Ledger.PoolParams (Ledger.EraCrypto (ShelleyLedgerEra era))
   -> StakePoolRegistrationRequirements era
 createStakePoolRegistrationRequirements sbe pparams =
@@ -146,15 +161,14 @@ createStakePoolRegistrationRequirements sbe pparams =
      StakePoolRegistrationRequirementsConwayOnwards ConwayEraOnwardsConway pparams
 
 
-runStakePoolRetirementCertificateCmd
-  :: AnyShelleyBasedEra
+runStakePoolRetirementCertificateCmd :: ()
+  => ShelleyBasedEra era
   -> VerificationKeyOrFile StakePoolKey
   -> Shelley.EpochNo
   -> File () Out
   -> ExceptT StakePoolCmdError IO ()
-runStakePoolRetirementCertificateCmd anyEra stakePoolVerKeyOrFile retireEpoch outfp = do
-    AnyShelleyBasedEra sbe <- pure anyEra
-
+runStakePoolRetirementCertificateCmd sbe stakePoolVerKeyOrFile retireEpoch outfp =
+  shelleyBasedEraConstraints sbe $ do
     -- Pool verification key
     stakePoolVerKey <- firstExceptT StakePoolCmdReadKeyFileError
       . newExceptT

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

@@ -57,17 +57,19 @@ runLegacyStakePoolRegistrationCertificateCmd :: ()
   -> NetworkId
   -> File () Out
   -> ExceptT StakePoolCmdError IO ()
-runLegacyStakePoolRegistrationCertificateCmd =
-  runStakePoolRegistrationCertificateCmd
+runLegacyStakePoolRegistrationCertificateCmd = \case
+  AnyShelleyBasedEra sbe ->
+    runStakePoolRegistrationCertificateCmd sbe
 
 runLegacyStakePoolDeregistrationCertificateCmd :: ()
   => AnyShelleyBasedEra
   -> VerificationKeyOrFile StakePoolKey
   -> Shelley.EpochNo
   -> File () Out
   -> ExceptT StakePoolCmdError IO ()
-runLegacyStakePoolDeregistrationCertificateCmd =
-  runStakePoolRetirementCertificateCmd
+runLegacyStakePoolDeregistrationCertificateCmd = \case
+  AnyShelleyBasedEra sbe ->
+    runStakePoolRetirementCertificateCmd sbe
 
 runLegacyStakePoolIdCmd :: ()
   => VerificationKeyOrFile StakePoolKey