-
Notifications
You must be signed in to change notification settings - Fork 17
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
1 parent
bd11054
commit 52daacd
Showing
6 changed files
with
317 additions
and
40 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
140 changes: 139 additions & 1 deletion
140
cardano-cli/src/Cardano/CLI/Compatible/StakeAddress/Run.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -1 +1,139 @@ | ||
| module Cardano.CLI.Compatible.StakeAddress.Run where | ||
| {-# LANGUAGE DataKinds #-} | ||
| {-# LANGUAGE GADTs #-} | ||
| {-# LANGUAGE LambdaCase #-} | ||
| {-# LANGUAGE TypeApplications #-} | ||
|
|
||
| module Cardano.CLI.Compatible.StakeAddress.Run | ||
| ( runCompatibleStakeAddressCmds | ||
| ) | ||
| where | ||
|
|
||
| import Cardano.Api | ||
| import Cardano.Api.Ledger qualified as L | ||
| import Cardano.Api.Shelley | ||
|
|
||
| import Cardano.CLI.Compatible.StakeAddress.Commands | ||
| import Cardano.CLI.Read | ||
| import Cardano.CLI.Types.Errors.StakeAddressCmdError | ||
| import Cardano.CLI.Types.Errors.StakeAddressRegistrationError | ||
| import Cardano.CLI.Types.Key | ||
|
|
||
| import Data.Function ((&)) | ||
|
|
||
| -- TODO remove ExceptT | ||
|
|
||
| runCompatibleStakeAddressCmds | ||
| :: () | ||
| => CompatibleStakeAddressCmds era | ||
| -> ExceptT StakeAddressCmdError IO () | ||
| runCompatibleStakeAddressCmds = \case | ||
| CompatibleStakeAddressRegistrationCertificateCmd sbe stakeIdentifier mDeposit outputFp -> | ||
| runStakeAddressRegistrationCertificateCmd sbe stakeIdentifier mDeposit outputFp | ||
| CompatibleStakeAddressStakeDelegationCertificateCmd | ||
| sbe | ||
| stakeIdentifier | ||
| stkPoolVerKeyHashOrFp | ||
| outputFp -> | ||
| runStakeAddressStakeDelegationCertificateCmd sbe stakeIdentifier stkPoolVerKeyHashOrFp outputFp | ||
|
|
||
| runStakeAddressRegistrationCertificateCmd | ||
| :: () | ||
| => ShelleyBasedEra era | ||
| -> StakeIdentifier | ||
| -> Maybe Lovelace | ||
| -- ^ Deposit required in conway era | ||
| -> File () Out | ||
| -> ExceptT StakeAddressCmdError IO () | ||
| runStakeAddressRegistrationCertificateCmd sbe stakeIdentifier mDeposit oFp = do | ||
| stakeCred <- | ||
| getStakeCredentialFromIdentifier stakeIdentifier | ||
| & firstExceptT StakeAddressCmdStakeCredentialError | ||
|
|
||
| req <- | ||
| firstExceptT StakeAddressCmdRegistrationError | ||
| . hoistEither | ||
| $ createRegistrationCertRequirements sbe stakeCred mDeposit | ||
|
|
||
| let regCert = makeStakeAddressRegistrationCertificate req | ||
|
|
||
| firstExceptT StakeAddressCmdWriteFileError | ||
| . newExceptT | ||
| $ writeLazyByteStringFile oFp | ||
| $ shelleyBasedEraConstraints sbe | ||
| $ textEnvelopeToJSON (Just regCertDesc) regCert | ||
| where | ||
| regCertDesc :: TextEnvelopeDescr | ||
| regCertDesc = "Stake Address Registration Certificate" | ||
|
|
||
| createRegistrationCertRequirements | ||
| :: () | ||
| => ShelleyBasedEra era | ||
| -> StakeCredential | ||
| -> Maybe Lovelace | ||
| -- ^ Deposit required in conway era | ||
| -> Either StakeAddressRegistrationError (StakeAddressRequirements era) | ||
| createRegistrationCertRequirements sbe stakeCred mdeposit = | ||
| case sbe of | ||
| ShelleyBasedEraShelley -> | ||
| return $ StakeAddrRegistrationPreConway ShelleyToBabbageEraShelley stakeCred | ||
| ShelleyBasedEraAllegra -> | ||
| return $ StakeAddrRegistrationPreConway ShelleyToBabbageEraAllegra stakeCred | ||
| ShelleyBasedEraMary -> | ||
| return $ StakeAddrRegistrationPreConway ShelleyToBabbageEraMary stakeCred | ||
| ShelleyBasedEraAlonzo -> | ||
| return $ StakeAddrRegistrationPreConway ShelleyToBabbageEraAlonzo stakeCred | ||
| ShelleyBasedEraBabbage -> | ||
| return $ StakeAddrRegistrationPreConway ShelleyToBabbageEraBabbage stakeCred | ||
| ShelleyBasedEraConway -> | ||
| case mdeposit of | ||
| Nothing -> | ||
| -- This case is made impossible by the parser, that distinguishes between Conway | ||
| -- and pre-Conway. | ||
| Left StakeAddressRegistrationDepositRequired | ||
| Just dep -> | ||
| return $ StakeAddrRegistrationConway ConwayEraOnwardsConway dep stakeCred | ||
|
|
||
| runStakeAddressStakeDelegationCertificateCmd | ||
| :: () | ||
| => ShelleyBasedEra era | ||
| -> StakeIdentifier | ||
| -- ^ Delegator stake verification key, verification key file or script file. | ||
| -> VerificationKeyOrHashOrFile StakePoolKey | ||
| -- ^ Delegatee stake pool verification key or verification key file or | ||
| -- verification key hash. | ||
| -> File () Out | ||
| -> ExceptT StakeAddressCmdError IO () | ||
| runStakeAddressStakeDelegationCertificateCmd sbe stakeVerifier poolVKeyOrHashOrFile outFp = | ||
| shelleyBasedEraConstraints sbe $ do | ||
| poolStakeVKeyHash <- | ||
| modifyError StakeAddressCmdReadKeyFileError $ | ||
| readVerificationKeyOrHashOrFile AsStakePoolKey poolVKeyOrHashOrFile | ||
|
|
||
| stakeCred <- | ||
| getStakeCredentialFromIdentifier stakeVerifier | ||
| & firstExceptT StakeAddressCmdStakeCredentialError | ||
|
|
||
| let certificate = createStakeDelegationCertificate stakeCred poolStakeVKeyHash sbe | ||
|
|
||
| firstExceptT StakeAddressCmdWriteFileError | ||
| . newExceptT | ||
| $ writeLazyByteStringFile outFp | ||
| $ textEnvelopeToJSON (Just @TextEnvelopeDescr "Stake Delegation Certificate") certificate | ||
|
|
||
| createStakeDelegationCertificate | ||
| :: StakeCredential | ||
| -> Hash StakePoolKey | ||
| -> ShelleyBasedEra era | ||
| -> Certificate era | ||
| createStakeDelegationCertificate stakeCredential (StakePoolKeyHash poolStakeVKeyHash) = do | ||
| caseShelleyToBabbageOrConwayEraOnwards | ||
| ( \w -> | ||
| shelleyToBabbageEraConstraints w $ | ||
| ShelleyRelatedCertificate w $ | ||
| L.mkDelegStakeTxCert (toShelleyStakeCredential stakeCredential) poolStakeVKeyHash | ||
| ) | ||
| ( \w -> | ||
| conwayEraOnwardsConstraints w $ | ||
| ConwayCertificate w $ | ||
| L.mkDelegTxCert (toShelleyStakeCredential stakeCredential) (L.DelegStake poolStakeVKeyHash) | ||
| ) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -1 +1,126 @@ | ||
| module Cardano.CLI.Compatible.StakePool.Run where | ||
| {-# LANGUAGE LambdaCase #-} | ||
| {-# LANGUAGE NamedFieldPuns #-} | ||
|
|
||
| module Cardano.CLI.Compatible.StakePool.Run | ||
| ( runCompatibleStakePoolCmds | ||
| ) | ||
| where | ||
|
|
||
| import Cardano.Api.Ledger qualified as L | ||
| import Cardano.Api.Shelley | ||
|
|
||
| import Cardano.CLI.Commands.Hash qualified as Cmd | ||
| import Cardano.CLI.Compatible.StakePool.Commands | ||
| import Cardano.CLI.EraBased.StakePool.Internal.Metadata | ||
| import Cardano.CLI.Run.Hash (allSchemes, getByteStringFromURL, httpsAndIpfsSchemes) | ||
| import Cardano.CLI.Types.Common | ||
| import Cardano.CLI.Types.Errors.HashCmdError (FetchURLError (..)) | ||
| import Cardano.CLI.Types.Errors.StakePoolCmdError | ||
| import Cardano.CLI.Types.Key (readVerificationKeyOrFile) | ||
|
|
||
| import Control.Monad (when) | ||
| import Data.ByteString.Char8 qualified as BS | ||
|
|
||
| runCompatibleStakePoolCmds | ||
| :: () | ||
| => CompatibleStakePoolCmds era | ||
| -> ExceptT StakePoolCmdError IO () | ||
| runCompatibleStakePoolCmds = \case | ||
| CompatibleStakePoolRegistrationCertificateCmd args -> runStakePoolRegistrationCertificateCmd args | ||
|
|
||
| runStakePoolRegistrationCertificateCmd | ||
| :: () | ||
| => CompatibleStakePoolRegistrationCertificateCmdArgs era | ||
| -> ExceptT StakePoolCmdError IO () | ||
| runStakePoolRegistrationCertificateCmd | ||
| CompatibleStakePoolRegistrationCertificateCmdArgs | ||
| { sbe | ||
| , poolVerificationKeyOrFile | ||
| , vrfVerificationKeyOrFile | ||
| , poolPledge | ||
| , poolCost | ||
| , poolMargin | ||
| , rewardStakeVerificationKeyOrFile | ||
| , ownerStakeVerificationKeyOrFiles | ||
| , relays | ||
| , mMetadata | ||
| , network | ||
| , outFile | ||
| } = | ||
| shelleyBasedEraConstraints sbe $ do | ||
| -- Pool verification key | ||
| stakePoolVerKey <- | ||
| firstExceptT StakePoolCmdReadKeyFileError $ | ||
| readVerificationKeyOrFile AsStakePoolKey poolVerificationKeyOrFile | ||
| let stakePoolId' = verificationKeyHash stakePoolVerKey | ||
|
|
||
| -- VRF verification key | ||
| vrfVerKey <- | ||
| firstExceptT StakePoolCmdReadKeyFileError $ | ||
| readVerificationKeyOrFile AsVrfKey vrfVerificationKeyOrFile | ||
| let vrfKeyHash' = verificationKeyHash vrfVerKey | ||
|
|
||
| -- Pool reward account | ||
| rwdStakeVerKey <- | ||
| firstExceptT StakePoolCmdReadKeyFileError $ | ||
| readVerificationKeyOrFile AsStakeKey rewardStakeVerificationKeyOrFile | ||
| let stakeCred = StakeCredentialByKey (verificationKeyHash rwdStakeVerKey) | ||
| rewardAccountAddr = makeStakeAddress network stakeCred | ||
|
|
||
| -- Pool owner(s) | ||
| sPoolOwnerVkeys <- | ||
| mapM | ||
| ( firstExceptT StakePoolCmdReadKeyFileError | ||
| . readVerificationKeyOrFile AsStakeKey | ||
| ) | ||
| ownerStakeVerificationKeyOrFiles | ||
| let stakePoolOwners' = map verificationKeyHash sPoolOwnerVkeys | ||
|
|
||
| let stakePoolParams = | ||
| StakePoolParameters | ||
| { stakePoolId = stakePoolId' | ||
| , stakePoolVRF = vrfKeyHash' | ||
| , stakePoolCost = poolCost | ||
| , stakePoolMargin = poolMargin | ||
| , stakePoolRewardAccount = rewardAccountAddr | ||
| , stakePoolPledge = poolPledge | ||
| , stakePoolOwners = stakePoolOwners' | ||
| , stakePoolRelays = relays | ||
| , stakePoolMetadata = pcaAnchor <$> mMetadata | ||
| } | ||
|
|
||
| let ledgerStakePoolParams = toShelleyPoolParams stakePoolParams | ||
| req = | ||
| createStakePoolRegistrationRequirements sbe $ | ||
| shelleyBasedEraConstraints sbe ledgerStakePoolParams | ||
| registrationCert = makeStakePoolRegistrationCertificate req | ||
|
|
||
| mapM_ carryHashChecks mMetadata | ||
|
|
||
| firstExceptT StakePoolCmdWriteFileError | ||
| . newExceptT | ||
| $ writeLazyByteStringFile outFile | ||
| $ textEnvelopeToJSON (Just registrationCertDesc) registrationCert | ||
| where | ||
| registrationCertDesc :: TextEnvelopeDescr | ||
| registrationCertDesc = "Stake Pool Registration Certificate" | ||
|
|
||
| createStakePoolRegistrationRequirements | ||
| :: () | ||
| => ShelleyBasedEra era | ||
| -> L.PoolParams (L.EraCrypto (ShelleyLedgerEra era)) | ||
| -> StakePoolRegistrationRequirements era | ||
| createStakePoolRegistrationRequirements sbe pparams = | ||
| case sbe of | ||
| ShelleyBasedEraShelley -> | ||
| StakePoolRegistrationRequirementsPreConway ShelleyToBabbageEraShelley pparams | ||
| ShelleyBasedEraAllegra -> | ||
| StakePoolRegistrationRequirementsPreConway ShelleyToBabbageEraAllegra pparams | ||
| ShelleyBasedEraMary -> | ||
| StakePoolRegistrationRequirementsPreConway ShelleyToBabbageEraMary pparams | ||
| ShelleyBasedEraAlonzo -> | ||
| StakePoolRegistrationRequirementsPreConway ShelleyToBabbageEraAlonzo pparams | ||
| ShelleyBasedEraBabbage -> | ||
| StakePoolRegistrationRequirementsPreConway ShelleyToBabbageEraBabbage pparams | ||
| ShelleyBasedEraConway -> | ||
| StakePoolRegistrationRequirementsConwayOnwards ConwayEraOnwardsConway pparams |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Oops, something went wrong.