Merge pull request #256 from input-output-hk/newhoggy/simplify-stake-…

…address-stake-delegation-certificate-command-across-eras Simplify `stake-address stake-delegation-certificate` command across eras
IntersectMBO · Sep 8, 2023 · bad0fe8 · bad0fe8
2 parents 51fb8ee + 6b90889
commit bad0fe8
Show file tree

Hide file tree

Showing 2 changed files with 35 additions and 49 deletions.
diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/StakeAddress.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/StakeAddress.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
 {- HLINT ignore "Monad law, left identity" -}
@@ -25,7 +26,6 @@ import           Cardano.CLI.EraBased.Commands.StakeAddress
 import           Cardano.CLI.Read
 import           Cardano.CLI.Types.Common
 import           Cardano.CLI.Types.Errors.ShelleyStakeAddressCmdError
-import           Cardano.CLI.Types.Errors.StakeAddressDelegationError
 import           Cardano.CLI.Types.Errors.StakeAddressRegistrationError
 import           Cardano.CLI.Types.Key
 
@@ -172,62 +172,51 @@ runStakeAddressStakeDelegationCertificateCmd :: ()
   -> ExceptT ShelleyStakeAddressCmdError IO ()
 runStakeAddressStakeDelegationCertificateCmd sbe stakeVerifier poolVKeyOrHashOrFile outFp =
   shelleyBasedEraConstraints sbe $ do
-    StakePoolKeyHash poolStakeVKeyHash <-
+    poolStakeVKeyHash <-
       lift (readVerificationKeyOrHashOrFile AsStakePoolKey poolVKeyOrHashOrFile)
         & onLeft (left . ShelleyStakeAddressCmdReadKeyFileError)
 
-    let delegatee = Ledger.DelegStake poolStakeVKeyHash
-
     stakeCred <-
       getStakeCredentialFromIdentifier stakeVerifier
         & firstExceptT ShelleyStakeAddressCmdStakeCredentialError
 
-    req <- firstExceptT StakeDelegationError . hoistEither
-            $ createDelegationCertRequirements sbe stakeCred delegatee
-
-    let delegCert = makeStakeAddressDelegationCertificate req
+    let certificate = createStakeDelegationCertificate stakeCred poolStakeVKeyHash sbe
 
     firstExceptT ShelleyStakeAddressCmdWriteFileError
       . newExceptT
       $ writeLazyByteStringFile outFp
-      $ textEnvelopeToJSON (Just @TextEnvelopeDescr "Stake Address Delegation Certificate") delegCert
-
-createDelegationCertRequirements :: ()
-  => ShelleyBasedEra era
-  -> StakeCredential
-  -> Ledger.Delegatee Ledger.StandardCrypto
-  -> Either StakeAddressDelegationError (StakeDelegationRequirements era)
-createDelegationCertRequirements sbe stakeCred delegatee =
-  case sbe of
-    ShelleyBasedEraShelley -> do
-      pId <- onlySpoDelegatee ShelleyToBabbageEraShelley delegatee
-      return $ StakeDelegationRequirementsPreConway ShelleyToBabbageEraShelley stakeCred pId
-    ShelleyBasedEraAllegra -> do
-      pId <- onlySpoDelegatee ShelleyToBabbageEraAllegra delegatee
-      return $ StakeDelegationRequirementsPreConway ShelleyToBabbageEraAllegra stakeCred pId
-    ShelleyBasedEraMary -> do
-      pId <- onlySpoDelegatee ShelleyToBabbageEraMary delegatee
-      return $ StakeDelegationRequirementsPreConway ShelleyToBabbageEraMary stakeCred pId
-    ShelleyBasedEraAlonzo -> do
-      pId <- onlySpoDelegatee ShelleyToBabbageEraAlonzo delegatee
-      return $ StakeDelegationRequirementsPreConway ShelleyToBabbageEraAlonzo stakeCred pId
-    ShelleyBasedEraBabbage -> do
-      pId <- onlySpoDelegatee ShelleyToBabbageEraBabbage delegatee
-      return $ StakeDelegationRequirementsPreConway ShelleyToBabbageEraBabbage stakeCred pId
-    ShelleyBasedEraConway ->
-      return $ StakeDelegationRequirementsConwayOnwards ConwayEraOnwardsConway stakeCred delegatee
-
-onlySpoDelegatee
-  :: ShelleyToBabbageEra era
-  -> Ledger.Delegatee (Ledger.EraCrypto (ShelleyLedgerEra era))
-  -> Either StakeAddressDelegationError PoolId
-onlySpoDelegatee w = \case
-  Ledger.DelegStake stakePoolKeyHash ->
-    Right $ StakePoolKeyHash $ shelleyToBabbageEraConstraints w stakePoolKeyHash
-  Ledger.DelegVote{} ->
-    Left . VoteDelegationNotSupported $ AnyShelleyToBabbageEra w
-  Ledger.DelegStakeVote{} ->
-    Left . VoteDelegationNotSupported $ AnyShelleyToBabbageEra w
+      $ textEnvelopeToJSON (Just @TextEnvelopeDescr "Stake Address Delegation Certificate") certificate
+
+-- TODO use the version in cardano-api
+caseShelleyToBabbageAndConwayEraOnwards :: forall a era. ()
+  => (ShelleyToBabbageEra era -> a)
+  -> (ConwayEraOnwards era -> a)
+  -> ShelleyBasedEra era
+  -> a
+caseShelleyToBabbageAndConwayEraOnwards l r = \case
+  ShelleyBasedEraShelley -> l ShelleyToBabbageEraShelley
+  ShelleyBasedEraAllegra -> l ShelleyToBabbageEraAllegra
+  ShelleyBasedEraMary    -> l ShelleyToBabbageEraMary
+  ShelleyBasedEraAlonzo  -> l ShelleyToBabbageEraAlonzo
+  ShelleyBasedEraBabbage -> l ShelleyToBabbageEraBabbage
+  ShelleyBasedEraConway  -> r ConwayEraOnwardsConway
+
+createStakeDelegationCertificate :: forall era. ()
+  => StakeCredential
+  -> Hash StakePoolKey
+  -> ShelleyBasedEra era
+  -> Certificate era
+createStakeDelegationCertificate stakeCredential (StakePoolKeyHash poolStakeVKeyHash) = do
+  caseShelleyToBabbageAndConwayEraOnwards
+    (\w ->
+      shelleyToBabbageEraConstraints w
+        $ ShelleyRelatedCertificate w
+        $ Ledger.mkDelegStakeTxCert (toShelleyStakeCredential stakeCredential) poolStakeVKeyHash)
+    (\w ->
+      conwayEraOnwardsConstraints w
+        $ ConwayCertificate w
+        $ Ledger.mkDelegTxCert (toShelleyStakeCredential stakeCredential) (Ledger.DelegStake poolStakeVKeyHash)
+    )
 
 runStakeAddressDeregistrationCertificateCmd :: ()
   => ShelleyBasedEra era

diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/ShelleyStakeAddressCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/ShelleyStakeAddressCmdError.hs
@@ -7,7 +7,6 @@ module Cardano.CLI.Types.Errors.ShelleyStakeAddressCmdError
 import           Cardano.Api
 
 import           Cardano.CLI.Types.Errors.ScriptDecodeError
-import           Cardano.CLI.Types.Errors.StakeAddressDelegationError
 import           Cardano.CLI.Types.Errors.StakeAddressRegistrationError
 import           Cardano.CLI.Types.Errors.StakeCredentialError
 
@@ -17,7 +16,6 @@ data ShelleyStakeAddressCmdError
   | ShelleyStakeAddressCmdStakeCredentialError !StakeCredentialError
   | ShelleyStakeAddressCmdWriteFileError !(FileError ())
   | StakeRegistrationError !StakeAddressRegistrationError
-  | StakeDelegationError !StakeAddressDelegationError
   deriving Show
 
 instance Error ShelleyStakeAddressCmdError where
@@ -26,5 +24,4 @@ instance Error ShelleyStakeAddressCmdError where
     ShelleyStakeAddressCmdReadScriptFileError e   -> displayError e
     ShelleyStakeAddressCmdStakeCredentialError e  -> displayError e
     ShelleyStakeAddressCmdWriteFileError e        -> displayError e
-    StakeDelegationError e                        -> displayError e
     StakeRegistrationError e                      -> displayError e