diff --git a/cardano-api/src/Cardano/API.hs b/cardano-api/src/Cardano/API.hs index 115e6086f4e..3494002418b 100644 --- a/cardano-api/src/Cardano/API.hs +++ b/cardano-api/src/Cardano/API.hs @@ -336,8 +336,14 @@ module Cardano.API ( makeMIRCertificate, makeGenesisKeyDelegationCertificate, - NetworkMagic, + -- * Protocol parameter updates + UpdateProposal(..), + ProtocolParametersUpdate(..), makeShelleyUpdateProposal, + PraosNonce, + makePraosNonce, + + NetworkMagic, ) where import Cardano.Api.Typed diff --git a/cardano-api/src/Cardano/Api/Address.hs b/cardano-api/src/Cardano/Api/Address.hs index b0c3c8178d3..221f3b2ea97 100644 --- a/cardano-api/src/Cardano/Api/Address.hs +++ b/cardano-api/src/Cardano/Api/Address.hs @@ -47,6 +47,9 @@ module Cardano.Api.Address ( toShelleyAddr, toShelleyStakeAddr, toShelleyStakeCredential, + fromShelleyAddr, + fromShelleyStakeAddr, + fromShelleyStakeCredential, -- * Serialising addresses SerialiseAddress(..), @@ -67,7 +70,10 @@ import Control.Applicative import qualified Cardano.Chain.Common as Byron +import qualified Cardano.Ledger.Era as Ledger import Ouroboros.Consensus.Shelley.Eras (StandardShelley) +import Ouroboros.Consensus.Shelley.Protocol.Crypto (StandardCrypto) + import qualified Shelley.Spec.Ledger.Address as Shelley import qualified Shelley.Spec.Ledger.BaseTypes as Shelley import qualified Shelley.Spec.Ledger.Credential as Shelley @@ -484,45 +490,80 @@ toShelleyAddr (AddressInEra (ShelleyAddressInEra _) Shelley.Addr nw (coerceShelleyPaymentCredential pc) (coerceShelleyStakeReference scr) - where - -- The era parameter in these types is a phantom type so it is safe to cast. - -- We choose to cast because we need to use an era-independent address - -- representation, but have to produce an era-dependent format used by the - -- Shelley ledger lib. - coerceShelleyPaymentCredential :: Shelley.PaymentCredential eraA - -> Shelley.PaymentCredential eraB - coerceShelleyPaymentCredential = coerce - - coerceShelleyStakeReference :: Shelley.StakeReference eraA - -> Shelley.StakeReference eraB - coerceShelleyStakeReference = coerce - -toShelleyStakeAddr :: StakeAddress -> Shelley.RewardAcnt StandardShelley + +toShelleyStakeAddr :: StakeAddress -> Shelley.RewardAcnt ledgerera toShelleyStakeAddr (StakeAddress nw sc) = Shelley.RewardAcnt { Shelley.getRwdNetwork = nw, - Shelley.getRwdCred = sc + Shelley.getRwdCred = coerceShelleyStakeCredential sc } -toShelleyPaymentCredential :: PaymentCredential - -> Shelley.PaymentCredential StandardShelley +toShelleyPaymentCredential :: Ledger.Crypto ledgerera ~ StandardCrypto + => PaymentCredential + -> Shelley.PaymentCredential ledgerera toShelleyPaymentCredential (PaymentCredentialByKey (PaymentKeyHash kh)) = Shelley.KeyHashObj kh -toShelleyPaymentCredential (PaymentCredentialByScript (ScriptHash sh)) = - Shelley.ScriptHashObj sh +toShelleyPaymentCredential (PaymentCredentialByScript sh) = + Shelley.ScriptHashObj (toShelleyScriptHash sh) -toShelleyStakeCredential :: StakeCredential - -> Shelley.StakeCredential StandardShelley +toShelleyStakeCredential :: Ledger.Crypto ledgerera ~ StandardCrypto + => StakeCredential + -> Shelley.StakeCredential ledgerera toShelleyStakeCredential (StakeCredentialByKey (StakeKeyHash kh)) = Shelley.KeyHashObj kh -toShelleyStakeCredential (StakeCredentialByScript (ScriptHash kh)) = - Shelley.ScriptHashObj kh +toShelleyStakeCredential (StakeCredentialByScript sh) = + Shelley.ScriptHashObj (toShelleyScriptHash sh) -toShelleyStakeReference :: StakeAddressReference - -> Shelley.StakeReference StandardShelley +toShelleyStakeReference :: Ledger.Crypto ledgerera ~ StandardCrypto + => StakeAddressReference + -> Shelley.StakeReference ledgerera toShelleyStakeReference (StakeAddressByValue stakecred) = Shelley.StakeRefBase (toShelleyStakeCredential stakecred) toShelleyStakeReference (StakeAddressByPointer ptr) = Shelley.StakeRefPtr ptr toShelleyStakeReference NoStakeAddress = Shelley.StakeRefNull + + +fromShelleyAddr :: IsShelleyBasedEra era + => Shelley.Addr (ShelleyLedgerEra era) -> AddressInEra era +fromShelleyAddr (Shelley.AddrBootstrap (Shelley.BootstrapAddress addr)) = + AddressInEra ByronAddressInAnyEra (ByronAddress addr) + +fromShelleyAddr (Shelley.Addr nw pc scr) = + AddressInEra + (ShelleyAddressInEra shelleyBasedEra) + (ShelleyAddress + nw + (coerceShelleyPaymentCredential pc) + (coerceShelleyStakeReference scr)) + +fromShelleyStakeAddr :: Shelley.RewardAcnt ledgerera -> StakeAddress +fromShelleyStakeAddr (Shelley.RewardAcnt nw sc) = + StakeAddress nw (coerceShelleyStakeCredential sc) + +fromShelleyStakeCredential :: Ledger.Crypto ledgerera ~ StandardCrypto + => Shelley.StakeCredential ledgerera + -> StakeCredential +fromShelleyStakeCredential (Shelley.KeyHashObj kh) = + StakeCredentialByKey (StakeKeyHash kh) +fromShelleyStakeCredential (Shelley.ScriptHashObj sh) = + StakeCredentialByScript (fromShelleyScriptHash sh) + + +-- The era parameter in these types is a phantom type so it is safe to cast. +-- We choose to cast because we need to use an era-independent address +-- representation, but have to produce an era-dependent format used by the +-- Shelley ledger lib. +coerceShelleyPaymentCredential :: Shelley.PaymentCredential eraA + -> Shelley.PaymentCredential eraB +coerceShelleyPaymentCredential = coerce + +coerceShelleyStakeCredential :: Shelley.StakeCredential eraA + -> Shelley.StakeCredential eraB +coerceShelleyStakeCredential = coerce + +coerceShelleyStakeReference :: Shelley.StakeReference eraA + -> Shelley.StakeReference eraB +coerceShelleyStakeReference = coerce + diff --git a/cardano-api/src/Cardano/Api/Certificate.hs b/cardano-api/src/Cardano/Api/Certificate.hs index ab1a47e4bcf..c79abfc65fc 100644 --- a/cardano-api/src/Cardano/Api/Certificate.hs +++ b/cardano-api/src/Cardano/Api/Certificate.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -- | Certificates embedded in transactions @@ -26,6 +26,10 @@ module Cardano.Api.Certificate ( makeMIRCertificate, makeGenesisKeyDelegationCertificate, + -- * Internal conversion functions + toShelleyCertificate, + fromShelleyCertificate, + -- * Data family instances AsType(..) ) where @@ -34,21 +38,25 @@ import Prelude import Data.Maybe import Data.ByteString (ByteString) -import qualified Data.Text as Text +import Data.Text (Text) import qualified Data.Text.Encoding as Text import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.Sequence.Strict as Seq +import qualified Data.Foldable as Foldable import Data.IP (IPv4, IPv6) import Network.Socket (PortNumber) -import qualified Network.URI as URI import Cardano.Slotting.Slot (EpochNo (..)) import qualified Cardano.Crypto.Hash.Class as Crypto +import qualified Cardano.Ledger.Era as Ledger import Ouroboros.Consensus.Shelley.Eras (StandardShelley) -import Shelley.Spec.Ledger.BaseTypes (maybeToStrictMaybe) +import Ouroboros.Consensus.Shelley.Protocol.Crypto (StandardCrypto) + +import Shelley.Spec.Ledger.BaseTypes + (maybeToStrictMaybe, strictMaybeToMaybe) import qualified Shelley.Spec.Ledger.BaseTypes as Shelley import qualified Shelley.Spec.Ledger.TxBody as Shelley import Shelley.Spec.Ledger.TxBody (MIRPot (..)) @@ -69,86 +77,52 @@ import Cardano.Api.Value -- Certificates embedded in transactions -- -newtype Certificate = Certificate (Shelley.DCert StandardShelley) +data Certificate = + + -- Stake address certificates + StakeAddressRegistrationCertificate StakeCredential + | StakeAddressDeregistrationCertificate StakeCredential + | StakeAddressDelegationCertificate StakeCredential PoolId + + -- Stake pool certificates + | StakePoolRegistrationCertificate StakePoolParameters + | StakePoolRetirementCertificate PoolId EpochNo + + -- Special certificates + | GenesisKeyDelegationCertificate (Hash GenesisKey) + (Hash GenesisDelegateKey) + (Hash VrfKey) + | MIRCertificate MIRPot [(StakeCredential, Lovelace)] + deriving stock (Eq, Show) - deriving newtype (ToCBOR, FromCBOR) deriving anyclass SerialiseAsCBOR instance HasTypeProxy Certificate where data AsType Certificate = AsCertificate proxyToAsType _ = AsCertificate -instance HasTextEnvelope Certificate where - textEnvelopeType _ = "CertificateShelley" - textEnvelopeDefaultDescr (Certificate cert) = case cert of - Shelley.DCertDeleg Shelley.RegKey {} -> "Stake address registration" - Shelley.DCertDeleg Shelley.DeRegKey {} -> "Stake address de-registration" - Shelley.DCertDeleg Shelley.Delegate {} -> "Stake address delegation" - Shelley.DCertPool Shelley.RegPool {} -> "Pool registration" - Shelley.DCertPool Shelley.RetirePool {} -> "Pool retirement" - Shelley.DCertGenesis{} -> "Genesis key delegation" - Shelley.DCertMir{} -> "MIR" - +instance ToCBOR Certificate where + toCBOR = toCBOR . toShelleyCertificate @StandardShelley --- ---------------------------------------------------------------------------- --- Stake address certificates --- +instance FromCBOR Certificate where + fromCBOR = fromShelleyCertificate @StandardShelley <$> fromCBOR -makeStakeAddressRegistrationCertificate - :: StakeCredential - -> Certificate -makeStakeAddressRegistrationCertificate stakecred = - Certificate - . Shelley.DCertDeleg - $ Shelley.RegKey - (toShelleyStakeCredential stakecred) - -makeStakeAddressDeregistrationCertificate - :: StakeCredential - -> Certificate -makeStakeAddressDeregistrationCertificate stakecred = - Certificate - . Shelley.DCertDeleg - $ Shelley.DeRegKey - (toShelleyStakeCredential stakecred) - -makeStakeAddressDelegationCertificate - :: StakeCredential - -> PoolId - -> Certificate -makeStakeAddressDelegationCertificate stakecred (StakePoolKeyHash poolid) = - Certificate - . Shelley.DCertDeleg - . Shelley.Delegate - $ Shelley.Delegation - (toShelleyStakeCredential stakecred) - poolid +instance HasTextEnvelope Certificate where + textEnvelopeType _ = "CertificateShelley" + textEnvelopeDefaultDescr cert = case cert of + StakeAddressRegistrationCertificate{} -> "Stake address registration" + StakeAddressDeregistrationCertificate{} -> "Stake address de-registration" + StakeAddressDelegationCertificate{} -> "Stake address delegation" + StakePoolRegistrationCertificate{} -> "Pool registration" + StakePoolRetirementCertificate{} -> "Pool retirement" + GenesisKeyDelegationCertificate{} -> "Genesis key delegation" + MIRCertificate{} -> "MIR" -- ---------------------------------------------------------------------------- --- Stake pool certificates +-- Stake pool parameters -- -makeStakePoolRegistrationCertificate - :: StakePoolParameters - -> Certificate -makeStakePoolRegistrationCertificate poolparams = - Certificate - . Shelley.DCertPool - $ Shelley.RegPool - (toShelleyPoolParams poolparams) - -makeStakePoolRetirementCertificate - :: PoolId - -> EpochNo - -> Certificate -makeStakePoolRetirementCertificate (StakePoolKeyHash poolid) epochno = - Certificate - . Shelley.DCertPool - $ Shelley.RetirePool - poolid - epochno - type PoolId = Hash StakePoolKey data StakePoolParameters = @@ -183,12 +157,137 @@ data StakePoolRelay = data StakePoolMetadataReference = StakePoolMetadataReference { - stakePoolMetadataURL :: URI.URI, + stakePoolMetadataURL :: Text, stakePoolMetadataHash :: Hash StakePoolMetadata } deriving (Eq, Show) -toShelleyPoolParams :: StakePoolParameters -> Shelley.PoolParams StandardShelley + +-- ---------------------------------------------------------------------------- +-- Constructor functions +-- + +makeStakeAddressRegistrationCertificate :: StakeCredential -> Certificate +makeStakeAddressRegistrationCertificate = StakeAddressRegistrationCertificate + +makeStakeAddressDeregistrationCertificate :: StakeCredential -> Certificate +makeStakeAddressDeregistrationCertificate = StakeAddressDeregistrationCertificate + +makeStakeAddressDelegationCertificate :: StakeCredential -> PoolId -> Certificate +makeStakeAddressDelegationCertificate = StakeAddressDelegationCertificate + +makeStakePoolRegistrationCertificate :: StakePoolParameters -> Certificate +makeStakePoolRegistrationCertificate = StakePoolRegistrationCertificate + +makeStakePoolRetirementCertificate :: PoolId -> EpochNo -> Certificate +makeStakePoolRetirementCertificate = StakePoolRetirementCertificate + +makeGenesisKeyDelegationCertificate :: Hash GenesisKey + -> Hash GenesisDelegateKey + -> Hash VrfKey + -> Certificate +makeGenesisKeyDelegationCertificate = GenesisKeyDelegationCertificate + +makeMIRCertificate :: MIRPot -> [(StakeCredential, Lovelace)] -> Certificate +makeMIRCertificate = MIRCertificate + + +-- ---------------------------------------------------------------------------- +-- Internal conversion functions +-- + +toShelleyCertificate :: Ledger.Crypto ledgerera ~ StandardCrypto + => Certificate -> Shelley.DCert ledgerera +toShelleyCertificate (StakeAddressRegistrationCertificate stakecred) = + Shelley.DCertDeleg $ + Shelley.RegKey + (toShelleyStakeCredential stakecred) + +toShelleyCertificate (StakeAddressDeregistrationCertificate stakecred) = + Shelley.DCertDeleg $ + Shelley.DeRegKey + (toShelleyStakeCredential stakecred) + +toShelleyCertificate (StakeAddressDelegationCertificate + stakecred (StakePoolKeyHash poolid)) = + Shelley.DCertDeleg $ + Shelley.Delegate $ + Shelley.Delegation + (toShelleyStakeCredential stakecred) + poolid + +toShelleyCertificate (StakePoolRegistrationCertificate poolparams) = + Shelley.DCertPool $ + Shelley.RegPool + (toShelleyPoolParams poolparams) + +toShelleyCertificate (StakePoolRetirementCertificate + (StakePoolKeyHash poolid) epochno) = + Shelley.DCertPool $ + Shelley.RetirePool + poolid + epochno + +toShelleyCertificate (GenesisKeyDelegationCertificate + (GenesisKeyHash genesiskh) + (GenesisDelegateKeyHash delegatekh) + (VrfKeyHash vrfkh)) = + Shelley.DCertGenesis $ + Shelley.GenesisDelegCert + genesiskh + delegatekh + vrfkh + +toShelleyCertificate (MIRCertificate mirpot amounts) = + Shelley.DCertMir $ + Shelley.MIRCert + mirpot + (Map.fromListWith (<>) + [ (toShelleyStakeCredential sc, toShelleyLovelace v) + | (sc, v) <- amounts ]) + + +fromShelleyCertificate :: Ledger.Crypto ledgerera ~ StandardCrypto + => Shelley.DCert ledgerera -> Certificate +fromShelleyCertificate (Shelley.DCertDeleg (Shelley.RegKey stakecred)) = + StakeAddressRegistrationCertificate + (fromShelleyStakeCredential stakecred) + +fromShelleyCertificate (Shelley.DCertDeleg (Shelley.DeRegKey stakecred)) = + StakeAddressDeregistrationCertificate + (fromShelleyStakeCredential stakecred) + +fromShelleyCertificate (Shelley.DCertDeleg + (Shelley.Delegate (Shelley.Delegation stakecred poolid))) = + StakeAddressDelegationCertificate + (fromShelleyStakeCredential stakecred) + (StakePoolKeyHash poolid) + +fromShelleyCertificate (Shelley.DCertPool (Shelley.RegPool poolparams)) = + StakePoolRegistrationCertificate + (fromShelleyPoolParams poolparams) + +fromShelleyCertificate (Shelley.DCertPool (Shelley.RetirePool poolid epochno)) = + StakePoolRetirementCertificate + (StakePoolKeyHash poolid) + epochno + +fromShelleyCertificate (Shelley.DCertGenesis + (Shelley.GenesisDelegCert genesiskh delegatekh vrfkh)) = + GenesisKeyDelegationCertificate + (GenesisKeyHash genesiskh) + (GenesisDelegateKeyHash delegatekh) + (VrfKeyHash vrfkh) + +fromShelleyCertificate (Shelley.DCertMir (Shelley.MIRCert mirpot amounts)) = + MIRCertificate + mirpot + [ (fromShelleyStakeCredential sc, fromShelleyLovelace v) + | (sc, v) <- Map.toList amounts ] + + +toShelleyPoolParams :: Ledger.Crypto ledgerera ~ StandardCrypto + => StakePoolParameters -> Shelley.PoolParams ledgerera toShelleyPoolParams StakePoolParameters { stakePoolId = StakePoolKeyHash poolkh , stakePoolVRF = VrfKeyHash vrfkh @@ -206,8 +305,7 @@ toShelleyPoolParams StakePoolParameters { , Shelley._poolVrf = vrfkh , Shelley._poolPledge = toShelleyLovelace stakePoolPledge , Shelley._poolCost = toShelleyLovelace stakePoolCost - , Shelley._poolMargin = Shelley.truncateUnitInterval - (fromRational stakePoolMargin) + , Shelley._poolMargin = Shelley.unitIntervalFromRational stakePoolMargin , Shelley._poolRAcnt = toShelleyStakeAddr stakePoolRewardAccount , Shelley._poolOwners = Set.fromList [ kh | StakeKeyHash kh <- stakePoolOwners ] @@ -248,42 +346,70 @@ toShelleyPoolParams StakePoolParameters { . Shelley.textToDns . Text.decodeLatin1 - toShelleyUrl :: URI.URI -> Shelley.Url - toShelleyUrl uri = fromMaybe (error "toShelleyUrl: invalid url. TODO: proper validation") - . Shelley.textToUrl - . Text.pack - $ URI.uriToString id uri "" + toShelleyUrl :: Text -> Shelley.Url + toShelleyUrl = fromMaybe (error "toShelleyUrl: invalid url. TODO: proper validation") + . Shelley.textToUrl --- ---------------------------------------------------------------------------- --- Special certificates --- - -makeGenesisKeyDelegationCertificate - :: Hash GenesisKey - -> Hash GenesisDelegateKey - -> Hash VrfKey - -> Certificate -makeGenesisKeyDelegationCertificate (GenesisKeyHash genesiskh) - (GenesisDelegateKeyHash delegatekh) - (VrfKeyHash vrfkh) = - Certificate - . Shelley.DCertGenesis - $ Shelley.GenesisDelegCert - genesiskh - delegatekh - vrfkh - -makeMIRCertificate - :: MIRPot - -> [(StakeCredential, Lovelace)] - -> Certificate -makeMIRCertificate mirpot amounts = - Certificate - . Shelley.DCertMir - $ Shelley.MIRCert - mirpot - (Map.fromListWith (<>) - [ (toShelleyStakeCredential sc, toShelleyLovelace v) - | (sc, v) <- amounts ]) +fromShelleyPoolParams :: Ledger.Crypto ledgerera ~ StandardCrypto + => Shelley.PoolParams ledgerera + -> StakePoolParameters +fromShelleyPoolParams + Shelley.PoolParams { + Shelley._poolId + , Shelley._poolVrf + , Shelley._poolPledge + , Shelley._poolCost + , Shelley._poolMargin + , Shelley._poolRAcnt + , Shelley._poolOwners + , Shelley._poolRelays + , Shelley._poolMD + } = + StakePoolParameters { + stakePoolId = StakePoolKeyHash _poolId + , stakePoolVRF = VrfKeyHash _poolVrf + , stakePoolCost = fromShelleyLovelace _poolCost + , stakePoolMargin = Shelley.unitIntervalToRational _poolMargin + , stakePoolRewardAccount = fromShelleyStakeAddr _poolRAcnt + , stakePoolPledge = fromShelleyLovelace _poolPledge + , stakePoolOwners = map StakeKeyHash (Set.toList _poolOwners) + , stakePoolRelays = map fromShelleyStakePoolRelay + (Foldable.toList _poolRelays) + , stakePoolMetadata = fromShelleyPoolMetaData <$> + strictMaybeToMaybe _poolMD + } + where + fromShelleyStakePoolRelay :: Shelley.StakePoolRelay -> StakePoolRelay + fromShelleyStakePoolRelay (Shelley.SingleHostAddr mport mipv4 mipv6) = + StakePoolRelayIp + (strictMaybeToMaybe mipv4) + (strictMaybeToMaybe mipv6) + (fromIntegral . Shelley.portToWord16 <$> strictMaybeToMaybe mport) + + fromShelleyStakePoolRelay (Shelley.SingleHostName mport dnsname) = + StakePoolRelayDnsARecord + (fromShelleyDnsName dnsname) + (fromIntegral . Shelley.portToWord16 <$> strictMaybeToMaybe mport) + + fromShelleyStakePoolRelay (Shelley.MultiHostName dnsname) = + StakePoolRelayDnsSrvRecord + (fromShelleyDnsName dnsname) + + fromShelleyPoolMetaData :: Shelley.PoolMetaData -> StakePoolMetadataReference + fromShelleyPoolMetaData Shelley.PoolMetaData { + Shelley._poolMDUrl + , Shelley._poolMDHash + } = + StakePoolMetadataReference { + stakePoolMetadataURL = Shelley.urlToText _poolMDUrl + , stakePoolMetadataHash = StakePoolMetadataHash + . fromMaybe (error "fromShelleyPoolMetaData: invalid hash. TODO: proper validation") + . Crypto.hashFromBytes + $ _poolMDHash + } + --TODO: change the ledger rep of the DNS name to use ShortByteString + fromShelleyDnsName :: Shelley.DnsName -> ByteString + fromShelleyDnsName = Text.encodeUtf8 + . Shelley.dnsToText diff --git a/cardano-api/src/Cardano/Api/ProtocolParameters.hs b/cardano-api/src/Cardano/Api/ProtocolParameters.hs index ffdc72b2957..b2d55175a9a 100644 --- a/cardano-api/src/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/src/Cardano/Api/ProtocolParameters.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -- | Protocol parameters. @@ -15,6 +15,13 @@ module Cardano.Api.ProtocolParameters ( ProtocolParametersUpdate(..), makeShelleyUpdateProposal, + -- * PraosNonce + PraosNonce, + makePraosNonce, + + -- * Internal conversion functions + toShelleyUpdate, + -- * Data family instances AsType(..) ) where @@ -24,14 +31,21 @@ import Prelude import Numeric.Natural import Data.ByteString (ByteString) import qualified Data.Map.Strict as Map +import Data.Map.Strict (Map) import Control.Monad import Cardano.Slotting.Slot (EpochNo) import qualified Cardano.Crypto.Hash.Class as Crypto + +import qualified Cardano.Ledger.Era as Ledger import Ouroboros.Consensus.Shelley.Eras (StandardShelley) -import Shelley.Spec.Ledger.BaseTypes (maybeToStrictMaybe) +import Ouroboros.Consensus.Shelley.Protocol.Crypto (StandardCrypto) + +import Shelley.Spec.Ledger.BaseTypes + (maybeToStrictMaybe, strictMaybeToMaybe) import qualified Shelley.Spec.Ledger.BaseTypes as Shelley +import qualified Shelley.Spec.Ledger.Keys as Shelley import qualified Shelley.Spec.Ledger.PParams as Shelley import Cardano.Api.Address @@ -50,9 +64,11 @@ import Cardano.Api.Value -- Protocol updates embedded in transactions -- -newtype UpdateProposal = UpdateProposal (Shelley.Update StandardShelley) +data UpdateProposal = + UpdateProposal + !(Map (Hash GenesisKey) ProtocolParametersUpdate) + !EpochNo deriving stock (Eq, Show) - deriving newtype (ToCBOR, FromCBOR) deriving anyclass SerialiseAsCBOR instance HasTypeProxy UpdateProposal where @@ -62,6 +78,14 @@ instance HasTypeProxy UpdateProposal where instance HasTextEnvelope UpdateProposal where textEnvelopeType _ = "UpdateProposalShelley" +instance ToCBOR UpdateProposal where + toCBOR = toCBOR . toShelleyUpdate @StandardShelley + -- We have to pick a monomorphic era type for the serialisation. We use the + -- Shelley era. This makes no difference since era type is phantom. + +instance FromCBOR UpdateProposal where + fromCBOR = fromShelleyUpdate @StandardShelley <$> fromCBOR + data ProtocolParametersUpdate = ProtocolParametersUpdate { @@ -86,7 +110,7 @@ data ProtocolParametersUpdate = -- federated operators did not subtly bias the initial schedule so that -- they retain undue influence after decentralisation. -- - protocolUpdateExtraPraosEntropy :: Maybe (Maybe ByteString), + protocolUpdateExtraPraosEntropy :: Maybe (Maybe PraosNonce), -- | The maximum permitted size of a block header. -- @@ -229,18 +253,28 @@ makeShelleyUpdateProposal :: ProtocolParametersUpdate -> [Hash GenesisKey] -> EpochNo -> UpdateProposal -makeShelleyUpdateProposal params genesisKeyHashes epochno = +makeShelleyUpdateProposal params genesisKeyHashes = --TODO decide how to handle parameter validation - let ppup = toShelleyPParamsUpdate params in - UpdateProposal $ - Shelley.Update - (Shelley.ProposedPPUpdates - (Map.fromList - [ (kh, ppup) | GenesisKeyHash kh <- genesisKeyHashes ])) - epochno + UpdateProposal (Map.fromList [ (kh, params) | kh <- genesisKeyHashes ]) + + +toShelleyUpdate :: Ledger.Crypto ledgerera ~ StandardCrypto + => UpdateProposal -> Shelley.Update ledgerera +toShelleyUpdate (UpdateProposal ppup epochno) = + Shelley.Update (toShelleyProposedPPUpdates ppup) epochno + + +toShelleyProposedPPUpdates :: Ledger.Crypto ledgerera ~ StandardCrypto + => Map (Hash GenesisKey) ProtocolParametersUpdate + -> Shelley.ProposedPPUpdates ledgerera +toShelleyProposedPPUpdates = + Shelley.ProposedPPUpdates + . Map.mapKeysMonotonic (\(GenesisKeyHash kh) -> kh) + . Map.map toShelleyPParamsUpdate + toShelleyPParamsUpdate :: ProtocolParametersUpdate - -> Shelley.PParamsUpdate StandardShelley + -> Shelley.PParamsUpdate ledgerera toShelleyPParamsUpdate ProtocolParametersUpdate { protocolUpdateProtocolVersion @@ -274,13 +308,13 @@ toShelleyPParamsUpdate , Shelley._eMax = maybeToStrictMaybe protocolUpdatePoolRetireMaxEpoch , Shelley._nOpt = maybeToStrictMaybe protocolUpdateStakePoolTargetNum , Shelley._a0 = maybeToStrictMaybe protocolUpdatePoolPledgeInfluence - , Shelley._rho = Shelley.truncateUnitInterval . fromRational <$> + , Shelley._rho = Shelley.unitIntervalFromRational <$> maybeToStrictMaybe protocolUpdateMonetaryExpansion - , Shelley._tau = Shelley.truncateUnitInterval . fromRational <$> + , Shelley._tau = Shelley.unitIntervalFromRational <$> maybeToStrictMaybe protocolUpdateTreasuryCut - , Shelley._d = Shelley.truncateUnitInterval . fromRational <$> + , Shelley._d = Shelley.unitIntervalFromRational <$> maybeToStrictMaybe protocolUpdateDecentralization - , Shelley._extraEntropy = mkNonce <$> + , Shelley._extraEntropy = toShelleyNonce <$> maybeToStrictMaybe protocolUpdateExtraPraosEntropy , Shelley._protocolVersion = uncurry Shelley.ProtVer <$> maybeToStrictMaybe protocolUpdateProtocolVersion @@ -289,10 +323,88 @@ toShelleyPParamsUpdate , Shelley._minPoolCost = toShelleyLovelace <$> maybeToStrictMaybe protocolUpdateMinPoolCost } - where - mkNonce Nothing = Shelley.NeutralNonce - mkNonce (Just bs) = Shelley.Nonce - . Crypto.castHash - . Crypto.hashWith id - $ bs +fromShelleyUpdate :: Ledger.Crypto ledgerera ~ StandardCrypto + => Shelley.Update ledgerera -> UpdateProposal +fromShelleyUpdate (Shelley.Update ppup epochno) = + UpdateProposal (fromShelleyProposedPPUpdates ppup) epochno + + +fromShelleyProposedPPUpdates :: Ledger.Crypto ledgerera ~ StandardCrypto + => Shelley.ProposedPPUpdates ledgerera + -> Map (Hash GenesisKey) ProtocolParametersUpdate +fromShelleyProposedPPUpdates = + Map.map fromShelleyPParamsUpdate + . Map.mapKeysMonotonic GenesisKeyHash + . (\(Shelley.ProposedPPUpdates ppup) -> ppup) + + +fromShelleyPParamsUpdate :: Shelley.PParamsUpdate ledgerera + -> ProtocolParametersUpdate +fromShelleyPParamsUpdate + Shelley.PParams { + Shelley._minfeeA + , Shelley._minfeeB + , Shelley._maxBBSize + , Shelley._maxTxSize + , Shelley._maxBHSize + , Shelley._keyDeposit + , Shelley._poolDeposit + , Shelley._eMax + , Shelley._nOpt + , Shelley._a0 + , Shelley._rho + , Shelley._tau + , Shelley._d + , Shelley._extraEntropy + , Shelley._protocolVersion + , Shelley._minUTxOValue + , Shelley._minPoolCost + } = + ProtocolParametersUpdate { + protocolUpdateProtocolVersion = (\(Shelley.ProtVer a b) -> (a,b)) <$> + strictMaybeToMaybe _protocolVersion + , protocolUpdateDecentralization = Shelley.unitIntervalToRational <$> + strictMaybeToMaybe _d + , protocolUpdateExtraPraosEntropy = fromPraosNonce <$> + strictMaybeToMaybe _extraEntropy + , protocolUpdateMaxBlockHeaderSize = strictMaybeToMaybe _maxBHSize + , protocolUpdateMaxBlockBodySize = strictMaybeToMaybe _maxBBSize + , protocolUpdateMaxTxSize = strictMaybeToMaybe _maxTxSize + , protocolUpdateTxFeeFixed = strictMaybeToMaybe _minfeeB + , protocolUpdateTxFeePerByte = strictMaybeToMaybe _minfeeA + , protocolUpdateMinUTxOValue = fromShelleyLovelace <$> + strictMaybeToMaybe _minUTxOValue + , protocolUpdateStakeAddressDeposit = fromShelleyLovelace <$> + strictMaybeToMaybe _keyDeposit + , protocolUpdateStakePoolDeposit = fromShelleyLovelace <$> + strictMaybeToMaybe _poolDeposit + , protocolUpdateMinPoolCost = fromShelleyLovelace <$> + strictMaybeToMaybe _minPoolCost + , protocolUpdatePoolRetireMaxEpoch = strictMaybeToMaybe _eMax + , protocolUpdateStakePoolTargetNum = strictMaybeToMaybe _nOpt + , protocolUpdatePoolPledgeInfluence = strictMaybeToMaybe _a0 + , protocolUpdateMonetaryExpansion = Shelley.unitIntervalToRational <$> + strictMaybeToMaybe _rho + , protocolUpdateTreasuryCut = Shelley.unitIntervalToRational <$> + strictMaybeToMaybe _tau + } + + +-- ---------------------------------------------------------------------------- +-- Praos nonce +-- + +newtype PraosNonce = PraosNonce (Shelley.Hash StandardCrypto ByteString) + deriving (Eq, Ord, Show) + +makePraosNonce :: ByteString -> PraosNonce +makePraosNonce = PraosNonce . Crypto.hashWith id + +toShelleyNonce :: Maybe PraosNonce -> Shelley.Nonce +toShelleyNonce Nothing = Shelley.NeutralNonce +toShelleyNonce (Just (PraosNonce h)) = Shelley.Nonce (Crypto.castHash h) + +fromPraosNonce :: Shelley.Nonce -> Maybe PraosNonce +fromPraosNonce Shelley.NeutralNonce = Nothing +fromPraosNonce (Shelley.Nonce h) = Just (PraosNonce (Crypto.castHash h)) diff --git a/cardano-api/src/Cardano/Api/Script.hs b/cardano-api/src/Cardano/Api/Script.hs index 1647ebbc2c7..6afe51a6378 100644 --- a/cardano-api/src/Cardano/Api/Script.hs +++ b/cardano-api/src/Cardano/Api/Script.hs @@ -34,6 +34,10 @@ module Cardano.Api.Script ( , MultiSigScript , makeMultiSigScript + -- * Internal conversion functions + , toShelleyScriptHash + , fromShelleyScriptHash + -- * Data family instances , AsType(..) ) where @@ -192,6 +196,21 @@ scriptHash (MaryScript s) = ScriptHash Shelley.ScriptHash (Crypto.castHash sh)) $ Timelock.hashTimelockScript s +toShelleyScriptHash :: Ledger.Crypto ledgerera ~ StandardCrypto + => ScriptHash -> Shelley.ScriptHash ledgerera +toShelleyScriptHash (ScriptHash h) = coerceShelleyScriptHash h + +fromShelleyScriptHash :: Ledger.Crypto ledgerera ~ StandardCrypto + => Shelley.ScriptHash ledgerera -> ScriptHash +fromShelleyScriptHash = ScriptHash . coerceShelleyScriptHash + +coerceShelleyScriptHash :: Ledger.Crypto ledgereraA ~ Ledger.Crypto ledgereraB + => Shelley.ScriptHash ledgereraA + -> Shelley.ScriptHash ledgereraB +coerceShelleyScriptHash (Shelley.ScriptHash h) = + Shelley.ScriptHash (Crypto.castHash h) + + -- ---------------------------------------------------------------------------- -- The simple native script language diff --git a/cardano-api/src/Cardano/Api/Shelley.hs b/cardano-api/src/Cardano/Api/Shelley.hs index 9cd9004892c..0df8b7a5544 100644 --- a/cardano-api/src/Cardano/Api/Shelley.hs +++ b/cardano-api/src/Cardano/Api/Shelley.hs @@ -67,25 +67,6 @@ module Cardano.Api.Shelley fromShelleyMetaData, -- * Protocol parameter updates - UpdateProposal(UpdateProposal), - ProtocolParametersUpdate(ProtocolParametersUpdate), - protocolUpdateProtocolVersion, - protocolUpdateDecentralization, - protocolUpdateExtraPraosEntropy, - protocolUpdateMaxBlockHeaderSize, - protocolUpdateMaxBlockBodySize, - protocolUpdateMaxTxSize, - protocolUpdateTxFeeFixed, - protocolUpdateTxFeePerByte, - protocolUpdateMinUTxOValue, - protocolUpdateStakeAddressDeposit, - protocolUpdateStakePoolDeposit, - protocolUpdateMinPoolCost, - protocolUpdatePoolRetireMaxEpoch, - protocolUpdateStakePoolTargetNum, - protocolUpdatePoolPledgeInfluence, - protocolUpdateMonetaryExpansion, - protocolUpdateTreasuryCut, EpochNo(..), NetworkMagic(..), @@ -101,7 +82,9 @@ module Cardano.Api.Shelley parseScriptSig, -- * Certificates - Certificate (Certificate), + Certificate (..), + toShelleyCertificate, + fromShelleyCertificate, -- ** Operational certificates OperationalCertificate(OperationalCertificate), diff --git a/cardano-api/src/Cardano/Api/Tx.hs b/cardano-api/src/Cardano/Api/Tx.hs index c36ff79f915..078f929559b 100644 --- a/cardano-api/src/Cardano/Api/Tx.hs +++ b/cardano-api/src/Cardano/Api/Tx.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -262,7 +263,7 @@ getTxBody (ShelleyTx Shelley.Tx { Shelley._body = txbody, Shelley._metadata = txmetadata }) = - ShelleyTxBody txbody (strictMaybeToMaybe txmetadata) + ShelleyTxBody ShelleyBasedEraShelley txbody (strictMaybeToMaybe txmetadata) getTxWitnesses :: Tx era -> [Witness era] @@ -297,7 +298,7 @@ makeSignedTransaction witnesses (ByronTxBody txbody) = selectByronWitness :: Witness ByronEra -> Byron.TxInWitness selectByronWitness (ByronKeyWitness w) = w -makeSignedTransaction witnesses (ShelleyTxBody txbody txmetadata) = +makeSignedTransaction witnesses (ShelleyTxBody ShelleyBasedEraShelley txbody txmetadata) = ShelleyTx $ Shelley.Tx txbody @@ -307,11 +308,16 @@ makeSignedTransaction witnesses (ShelleyTxBody txbody txmetadata) = | ShelleyScriptWitness sw <- witnesses ]) (Set.fromList [ w | ShelleyBootstrapWitness w <- witnesses ])) (maybeToStrictMaybe txmetadata) +makeSignedTransaction _ (ShelleyTxBody ShelleyBasedEraAllegra _ _) = + error "TODO: makeSignedTransaction AllegraEra" +makeSignedTransaction _ (ShelleyTxBody ShelleyBasedEraMary _ _) = + error "TODO: makeSignedTransaction MaryEra" makeByronKeyWitness :: NetworkId -> TxBody ByronEra -> SigningKey ByronKey -> Witness ByronEra +makeByronKeyWitness _ (ShelleyTxBody era _ _) = case era of {} makeByronKeyWitness nw (ByronTxBody txbody) = let txhash :: Byron.Hash Byron.Tx txhash = Byron.hashDecoded txbody @@ -344,10 +350,12 @@ data WitnessNetworkIdOrByronAddress -- address and used in the construction of the witness. makeShelleyBootstrapWitness :: WitnessNetworkIdOrByronAddress - -> TxBody ShelleyEra + -> TxBody era -> SigningKey ByronKey - -> Witness ShelleyEra -makeShelleyBootstrapWitness nwOrAddr (ShelleyTxBody txbody _) (ByronSigningKey sk) = + -> Witness era +makeShelleyBootstrapWitness nwOrAddr + (ShelleyTxBody ShelleyBasedEraShelley txbody _) + (ByronSigningKey sk) = ShelleyBootstrapWitness $ -- Byron era witnesses were weird. This reveals all that weirdness. Shelley.BootstrapWitness { @@ -417,6 +425,14 @@ makeShelleyBootstrapWitness nwOrAddr (ShelleyTxBody txbody _) (ByronSigningKey s (Byron.aaNetworkMagic . unAddrAttrs) eitherNwOrAddr +makeShelleyBootstrapWitness _ (ShelleyTxBody ShelleyBasedEraAllegra _ _) _ = + error "TODO: makeShelleyBootstrapWitness AllegraEra" +makeShelleyBootstrapWitness _ (ShelleyTxBody ShelleyBasedEraMary _ _) _ = + error "TODO: makeShelleyBootstrapWitness MaryEra" +makeShelleyBootstrapWitness _ ByronTxBody{} _ = + error "TODO: makeShelleyBootstrapWitness ByronEra" + + data ShelleyWitnessSigningKey = WitnessPaymentKey (SigningKey PaymentKey) | WitnessPaymentExtendedKey (SigningKey PaymentExtendedKey) @@ -431,10 +447,10 @@ data ShelleyWitnessSigningKey = | WitnessGenesisUTxOKey (SigningKey GenesisUTxOKey) -makeShelleyKeyWitness :: TxBody ShelleyEra +makeShelleyKeyWitness :: TxBody era -> ShelleyWitnessSigningKey - -> Witness ShelleyEra -makeShelleyKeyWitness (ShelleyTxBody txbody _) = + -> Witness era +makeShelleyKeyWitness (ShelleyTxBody ShelleyBasedEraShelley txbody _) = let txhash :: Shelley.Hash StandardCrypto Shelley.EraIndependentTxBody txhash = Shelley.hashAnnotated txbody @@ -446,6 +462,12 @@ makeShelleyKeyWitness (ShelleyTxBody txbody _) = signature = makeShelleySignature txhash sk in ShelleyKeyWitness $ Shelley.WitVKey vk signature +makeShelleyKeyWitness (ShelleyTxBody ShelleyBasedEraAllegra _ _) = + error "TODO: makeShelleyKeyWitness AllegraEra" +makeShelleyKeyWitness (ShelleyTxBody ShelleyBasedEraMary _ _) = + error "TODO: makeShelleyKeyWitness MaryEra" +makeShelleyKeyWitness ByronTxBody{} = + error "TODO: makeShelleyKeyWitness ByronEra" -- | We support making key witnesses with both normal and extended signing keys. @@ -547,9 +569,9 @@ signByronTransaction nw txbody sks = witnesses = map (makeByronKeyWitness nw txbody) sks -- signing keys is a set -signShelleyTransaction :: TxBody ShelleyEra +signShelleyTransaction :: TxBody era -> [ShelleyWitnessSigningKey] - -> Tx ShelleyEra + -> Tx era signShelleyTransaction txbody sks = makeSignedTransaction witnesses txbody where diff --git a/cardano-api/src/Cardano/Api/TxBody.hs b/cardano-api/src/Cardano/Api/TxBody.hs index 230e989bee0..f3e58e6a4da 100644 --- a/cardano-api/src/Cardano/Api/TxBody.hs +++ b/cardano-api/src/Cardano/Api/TxBody.hs @@ -1,9 +1,12 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} @@ -12,31 +15,37 @@ -- module Cardano.Api.TxBody ( + -- * Transaction bodies + TxBody(..), + makeByronTransaction, + makeShelleyTransaction, + -- * Transaction Ids TxId(..), getTxId, - -- * Transaction inputs and outputs + -- * Transaction inputs TxIn(..), TxIx(..), + genesisUTxOPseudoTxIn, + + -- * Transaction outputs TxOut(..), TxOutValue(..), - AdaOnlyInEra(..), - MultiAssetInEra(..), - genesisUTxOPseudoTxIn, - -- * Transaction bodies - TxBody(..), + -- * Other transaction body types TTL, TxFee, MintValue(..), - makeByronTransaction, - makeShelleyTransaction, TxExtraContent(..), txExtraContentEmpty, + -- * Era-dependent transaction body features + AdaOnlyInEra(..), + MultiAssetInEra(..), + -- * Data family instances - AsType(..), + AsType(AsTxId, AsTxBody, AsByronTxBody, AsShelleyTxBody), ) where import Prelude @@ -62,6 +71,10 @@ import qualified Cardano.Crypto.Hashing as Byron import qualified Cardano.Chain.Common as Byron import qualified Cardano.Chain.UTxO as Byron +import qualified Cardano.Ledger.Era as Ledger +import qualified Cardano.Ledger.Core as Ledger +import qualified Cardano.Ledger.Shelley as Ledger +import qualified Cardano.Ledger.ShelleyMA.TxBody as Allegra import Ouroboros.Consensus.Shelley.Eras (StandardShelley) import Ouroboros.Consensus.Shelley.Protocol.Crypto (StandardCrypto) @@ -113,7 +126,8 @@ toByronTxId :: TxId -> Byron.TxId toByronTxId (TxId h) = Byron.unsafeHashFromBytes (Crypto.hashToBytes h) -toShelleyTxId :: TxId -> Shelley.TxId StandardShelley +toShelleyTxId :: Ledger.Crypto ledgerera ~ StandardCrypto + => TxId -> Shelley.TxId ledgerera toShelleyTxId (TxId h) = Shelley.TxId (Crypto.castHash h) @@ -127,16 +141,24 @@ getTxId (ByronTxBody tx) = . recoverBytes $ tx -getTxId (ShelleyTxBody tx _) = - TxId - . Crypto.castHash - . (\(Shelley.TxId txhash) -> txhash) - . Shelley.txid - $ tx +getTxId (ShelleyTxBody era tx _) = + case era of + ShelleyBasedEraShelley -> getTxIdShelley tx + ShelleyBasedEraAllegra -> getTxIdShelley tx + ShelleyBasedEraMary -> getTxIdShelley tx + where + getTxIdShelley :: Ledger.Crypto ledgerera ~ StandardCrypto + => Ledger.TxBodyConstraints ledgerera + => Ledger.TxBody ledgerera -> TxId + getTxIdShelley = + TxId + . Crypto.castHash + . (\(Shelley.TxId txhash) -> txhash) + . Shelley.txid -- ---------------------------------------------------------------------------- --- Transaction inputs and outputs +-- Transaction inputs -- data TxIn = TxIn TxId TxIx @@ -148,14 +170,27 @@ newtype TxIx = TxIx Word deriving stock (Eq, Ord, Show) deriving newtype (Enum) + +toByronTxIn :: TxIn -> Byron.TxIn +toByronTxIn (TxIn txid (TxIx txix)) = + Byron.TxInUtxo (toByronTxId txid) (fromIntegral txix) + +toShelleyTxIn :: (Ledger.Era ledgerera, + Ledger.Crypto ledgerera ~ StandardCrypto) + => TxIn -> Shelley.TxIn ledgerera +toShelleyTxIn (TxIn txid (TxIx txix)) = + Shelley.TxIn (toShelleyTxId txid) (fromIntegral txix) + + +-- ---------------------------------------------------------------------------- +-- Transaction outputs +-- + data TxOut era = TxOut (AddressInEra era) (TxOutValue era) deriving instance Eq (TxOut era) deriving instance Show (TxOut era) -toByronTxIn :: TxIn -> Byron.TxIn -toByronTxIn (TxIn txid (TxIx txix)) = - Byron.TxInUtxo (toByronTxId txid) (fromIntegral txix) toByronTxOut :: TxOut ByronEra -> Maybe Byron.TxOut toByronTxOut (TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress addr)) @@ -168,20 +203,78 @@ toByronTxOut (TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress _)) toByronTxOut (TxOut (AddressInEra (ShelleyAddressInEra era) ShelleyAddress{}) _) = case era of {} -toByronLovelace :: Lovelace -> Maybe Byron.Lovelace -toByronLovelace (Lovelace x) = - case Byron.integerToLovelace x of - Left _ -> Nothing - Right x' -> Just x' -toShelleyTxIn :: TxIn -> Shelley.TxIn StandardShelley -toShelleyTxIn (TxIn txid (TxIx txix)) = - Shelley.TxIn (toShelleyTxId txid) (fromIntegral txix) +toShelleyTxOut :: forall era ledgerera. + (ShelleyLedgerEra era ~ ledgerera, + IsShelleyBasedEra era, Ledger.ShelleyBased ledgerera) + => TxOut era -> Shelley.TxOut ledgerera +toShelleyTxOut (TxOut _ (TxOutAdaOnly AdaOnlyInByronEra _)) = + case shelleyBasedEra :: ShelleyBasedEra era of {} + +toShelleyTxOut (TxOut addr (TxOutAdaOnly AdaOnlyInShelleyEra value)) = + Shelley.TxOut (toShelleyAddr addr) (toShelleyLovelace value) -toShelleyTxOut :: TxOut ShelleyEra -> Shelley.TxOut StandardShelley -toShelleyTxOut (TxOut addr (TxOutAdaOnly _ value)) = +toShelleyTxOut (TxOut addr (TxOutAdaOnly AdaOnlyInAllegraEra value)) = Shelley.TxOut (toShelleyAddr addr) (toShelleyLovelace value) -toShelleyTxOut (TxOut _addr (TxOutValue evidence _)) = case evidence of {} + +toShelleyTxOut (TxOut addr (TxOutValue MultiAssetInMaryEra value)) = + Shelley.TxOut (toShelleyAddr addr) (toMaryValue value) + + +-- ---------------------------------------------------------------------------- +-- Era-dependent transaction body features +-- + +-- | Representation of whether only ada transactions are supported in a +-- particular era. +-- +data AdaOnlyInEra era where + + AdaOnlyInByronEra :: AdaOnlyInEra ByronEra + AdaOnlyInShelleyEra :: AdaOnlyInEra ShelleyEra + AdaOnlyInAllegraEra :: AdaOnlyInEra AllegraEra + +deriving instance Eq (AdaOnlyInEra era) +deriving instance Show (AdaOnlyInEra era) + +-- | Representation of whether multi-asset transactions are supported in a +-- particular era. +-- +data MultiAssetInEra era where + + -- | Multi-asset transactions are supported in the 'Mary' era. + MultiAssetInMaryEra :: MultiAssetInEra MaryEra + +deriving instance Eq (MultiAssetInEra era) +deriving instance Show (MultiAssetInEra era) + + +-- ---------------------------------------------------------------------------- +-- Transaction output values (era-dependent) +-- + +data TxOutValue era where + + TxOutAdaOnly :: AdaOnlyInEra era -> Lovelace -> TxOutValue era + + TxOutValue :: MultiAssetInEra era -> Value -> TxOutValue era + +deriving instance Eq (TxOutValue era) +deriving instance Show (TxOutValue era) + + +-- ---------------------------------------------------------------------------- +-- Transaction value minting (era-dependent) +-- + +data MintValue era where + + MintNothing :: MintValue era + + MintValue :: MultiAssetInEra era -> Value -> MintValue era + +deriving instance Eq (MintValue era) +deriving instance Show (MintValue era) -- ---------------------------------------------------------------------------- @@ -195,65 +288,147 @@ data TxBody era where -> TxBody ByronEra ShelleyTxBody - :: Shelley.TxBody StandardShelley + :: ShelleyBasedEra era + -> Ledger.TxBody (ShelleyLedgerEra era) -> Maybe Shelley.MetaData - -> TxBody ShelleyEra - -deriving instance Eq (TxBody ByronEra) -deriving instance Show (TxBody ByronEra) - -deriving instance Eq (TxBody ShelleyEra) -deriving instance Show (TxBody ShelleyEra) - -instance HasTypeProxy (TxBody ByronEra) where - data AsType (TxBody ByronEra) = AsByronTxBody - proxyToAsType _ = AsByronTxBody - -instance HasTypeProxy (TxBody ShelleyEra) where - data AsType (TxBody ShelleyEra) = AsShelleyTxBody - proxyToAsType _ = AsShelleyTxBody + -> TxBody era + -- The 'ShelleyBasedEra' GADT tells us what era we are in. + -- The 'ShelleyLedgerEra' type family maps that to the era type from the + -- ledger lib. The 'Ledger.TxBody' type family maps that to a specific + -- tx body type, which is different for each Shelley-based era. + + +-- The GADT in the ShelleyTxBody case requires a custom instance +instance Eq (TxBody era) where + (==) (ByronTxBody txbodyA) + (ByronTxBody txbodyB) = txbodyA == txbodyB + + (==) (ShelleyTxBody era txbodyA txmetadataA) + (ShelleyTxBody _ txbodyB txmetadataB) = + txmetadataA == txmetadataB + && case era of + ShelleyBasedEraShelley -> txbodyA == txbodyB + ShelleyBasedEraAllegra -> txbodyA == txbodyB + ShelleyBasedEraMary -> txbodyA == txbodyB + + (==) ByronTxBody{} (ShelleyTxBody era _ _) = case era of {} + + +-- The GADT in the ShelleyTxBody case requires a custom instance +instance Show (TxBody era) where + showsPrec p (ByronTxBody txbody) = + showParen (p >= 11) + ( showString "ByronTxBody " + . showsPrec 11 txbody + ) + + showsPrec p (ShelleyTxBody ShelleyBasedEraShelley txbody txmetadata) = + showParen (p >= 11) + ( showString "ShelleyTxBody ShelleyBasedEraShelley " + . showsPrec 11 txbody + . showChar ' ' + . showsPrec 11 txmetadata + ) + + showsPrec p (ShelleyTxBody ShelleyBasedEraAllegra txbody txmetadata) = + showParen (p >= 11) + ( showString "ShelleyTxBody ShelleyBasedEraAllegra " + . showsPrec 11 txbody + . showChar ' ' + . showsPrec 11 txmetadata + ) + + showsPrec p (ShelleyTxBody ShelleyBasedEraMary txbody txmetadata) = + showParen (p >= 11) + ( showString "ShelleyTxBody ShelleyBasedEraMary " + . showsPrec 11 txbody + . showChar ' ' + . showsPrec 11 txmetadata + ) + +instance HasTypeProxy era => HasTypeProxy (TxBody era) where + data AsType (TxBody era) = AsTxBody (AsType era) + proxyToAsType _ = AsTxBody (proxyToAsType (Proxy :: Proxy era)) + +pattern AsByronTxBody :: AsType (TxBody ByronEra) +pattern AsByronTxBody = AsTxBody AsByronEra +{-# COMPLETE AsByronTxBody #-} + +pattern AsShelleyTxBody :: AsType (TxBody ShelleyEra) +pattern AsShelleyTxBody = AsTxBody AsShelleyEra +{-# COMPLETE AsShelleyTxBody #-} + + +instance IsCardanoEra era => SerialiseAsCBOR (TxBody era) where - -instance SerialiseAsCBOR (TxBody ByronEra) where serialiseToCBOR (ByronTxBody txbody) = recoverBytes txbody - deserialiseFromCBOR AsByronTxBody bs = do - ByronTxBody <$> - CBOR.decodeFullAnnotatedBytes - "Byron TxBody" - CBOR.fromCBORAnnotated - (LBS.fromStrict bs) - -instance SerialiseAsCBOR (TxBody ShelleyEra) where - serialiseToCBOR (ShelleyTxBody txbody txmetadata) = - CBOR.serializeEncoding' $ - CBOR.encodeListLen 2 - <> CBOR.toCBOR txbody - <> CBOR.encodeNullMaybe CBOR.toCBOR txmetadata - - deserialiseFromCBOR AsShelleyTxBody bs = - CBOR.decodeAnnotator - "Shelley TxBody" - decodeAnnotatedPair - (LBS.fromStrict bs) - where - decodeAnnotatedPair :: CBOR.Decoder s (CBOR.Annotator (TxBody ShelleyEra)) - decodeAnnotatedPair = do - CBOR.decodeListLenOf 2 - txbody <- fromCBOR - txmetadata <- CBOR.decodeNullMaybe fromCBOR - return $ CBOR.Annotator $ \fbs -> - ShelleyTxBody - (CBOR.runAnnotator txbody fbs) - (CBOR.runAnnotator <$> txmetadata <*> pure fbs) - - -instance HasTextEnvelope (TxBody ByronEra) where - textEnvelopeType _ = "TxUnsignedByron" - -instance HasTextEnvelope (TxBody ShelleyEra) where - textEnvelopeType _ = "TxUnsignedShelley" + serialiseToCBOR (ShelleyTxBody era txbody txmetadata) = + case era of + -- Use the same serialisation impl, but at different types: + ShelleyBasedEraShelley -> serialiseShelleyBasedTxBody txbody txmetadata + ShelleyBasedEraAllegra -> serialiseShelleyBasedTxBody txbody txmetadata + ShelleyBasedEraMary -> serialiseShelleyBasedTxBody txbody txmetadata + + deserialiseFromCBOR _ bs = + case cardanoEra :: CardanoEra era of + ByronEra -> + ByronTxBody <$> + CBOR.decodeFullAnnotatedBytes + "Byron TxBody" + CBOR.fromCBORAnnotated + (LBS.fromStrict bs) + + -- Use the same derialisation impl, but at different types: + ShelleyEra -> deserialiseShelleyBasedTxBody + (ShelleyTxBody ShelleyBasedEraShelley) bs + AllegraEra -> deserialiseShelleyBasedTxBody + (ShelleyTxBody ShelleyBasedEraAllegra) bs + MaryEra -> deserialiseShelleyBasedTxBody + (ShelleyTxBody ShelleyBasedEraMary) bs + +-- | The serialisation format for the different Shelley-based eras are not the +-- same, but they can be handled generally with one overloaded implementation. +-- +serialiseShelleyBasedTxBody :: forall txbody metadata. + (ToCBOR txbody, ToCBOR metadata) + => txbody -> Maybe metadata -> ByteString +serialiseShelleyBasedTxBody txbody txmetadata = + CBOR.serializeEncoding' $ + CBOR.encodeListLen 2 + <> CBOR.toCBOR txbody + <> CBOR.encodeNullMaybe CBOR.toCBOR txmetadata + +deserialiseShelleyBasedTxBody :: forall txbody metadata pair. + (FromCBOR (CBOR.Annotator txbody), + FromCBOR (CBOR.Annotator metadata)) + => (txbody -> Maybe metadata -> pair) + -> ByteString + -> Either CBOR.DecoderError pair +deserialiseShelleyBasedTxBody mkTxBody bs = + CBOR.decodeAnnotator + "Shelley TxBody" + decodeAnnotatedPair + (LBS.fromStrict bs) + where + decodeAnnotatedPair :: CBOR.Decoder s (CBOR.Annotator pair) + decodeAnnotatedPair = do + CBOR.decodeListLenOf 2 + txbody <- fromCBOR + txmetadata <- CBOR.decodeNullMaybe fromCBOR + return $ CBOR.Annotator $ \fbs -> + mkTxBody + (CBOR.runAnnotator txbody fbs) + (CBOR.runAnnotator <$> txmetadata <*> pure fbs) + +instance IsCardanoEra era => HasTextEnvelope (TxBody era) where + textEnvelopeType _ = + case cardanoEra :: CardanoEra era of + ByronEra -> "TxUnsignedByron" + ShelleyEra -> "TxUnsignedShelley" + AllegraEra -> "TxBodyAllegra" + MaryEra -> "TxBodyMary" data ByronTxBodyConversionError = @@ -302,12 +477,14 @@ txExtraContentEmpty = type TxFee = Lovelace type TTL = SlotNo -makeShelleyTransaction :: TxExtraContent +makeShelleyTransaction :: forall era. + IsShelleyBasedEra era + => TxExtraContent -> TTL -> TxFee -> [TxIn] - -> [TxOut ShelleyEra] - -> TxBody ShelleyEra + -> [TxOut era] + -> TxBody era makeShelleyTransaction TxExtraContent { txMetadata, txWithdrawals, @@ -315,32 +492,63 @@ makeShelleyTransaction TxExtraContent { txUpdateProposal } ttl fee ins outs = --TODO: validate the txins are not empty, and tx out coin values are in range - ShelleyTxBody - (Shelley.TxBody - (Set.fromList (map toShelleyTxIn ins)) - (Seq.fromList (map toShelleyTxOut outs)) - (Seq.fromList [ cert | Certificate cert <- txCertificates ]) - (toShelleyWdrl txWithdrawals) - (toShelleyLovelace fee) - ttl - (toShelleyUpdate <$> maybeToStrictMaybe txUpdateProposal) - (toShelleyMetadataHash <$> maybeToStrictMaybe txMetadata)) - (toShelleyMetadata <$> txMetadata) - where - toShelleyUpdate (UpdateProposal p) = p - - toShelleyMetadata (TxMetadataShelley m) = m - toShelleyMetadataHash (TxMetadataShelley m) = Shelley.hashMetaData m - - toShelleyWdrl :: [(StakeAddress, Lovelace)] -> Shelley.Wdrl StandardShelley - toShelleyWdrl wdrls = - Shelley.Wdrl $ - Map.fromList - [ (toShelleyStakeAddr stakeAddr, toShelleyLovelace value) - | (stakeAddr, value) <- wdrls ] - + case shelleyBasedEra :: ShelleyBasedEra era of + ShelleyBasedEraShelley -> + ShelleyTxBody + ShelleyBasedEraShelley + (Shelley.TxBody + (Set.fromList (map toShelleyTxIn ins)) + (Seq.fromList (map toShelleyTxOut outs)) + (Seq.fromList (map toShelleyCertificate txCertificates)) + (toShelleyWithdrawal txWithdrawals) + (toShelleyLovelace fee) + ttl + (toShelleyUpdate <$> maybeToStrictMaybe txUpdateProposal) + (toShelleyMetadataHash <$> maybeToStrictMaybe txMetadata)) + (toShelleyMetadata <$> txMetadata) + + ShelleyBasedEraAllegra -> + ShelleyTxBody + ShelleyBasedEraAllegra + (Allegra.TxBody + (Set.fromList (map toShelleyTxIn ins)) + (Seq.fromList (map toShelleyTxOut outs)) + (Seq.fromList (map toShelleyCertificate txCertificates)) + (toShelleyWithdrawal txWithdrawals) + (toShelleyLovelace fee) + (error "TODO: support validity interval") + (toShelleyUpdate <$> maybeToStrictMaybe txUpdateProposal) + (toShelleyMetadataHash <$> maybeToStrictMaybe txMetadata) + mempty) -- No minting in Allegra, only Mary + (toShelleyMetadata <$> txMetadata) + + ShelleyBasedEraMary -> + ShelleyTxBody + ShelleyBasedEraMary + (Allegra.TxBody + (Set.fromList (map toShelleyTxIn ins)) + (Seq.fromList (map toShelleyTxOut outs)) + (Seq.fromList (map toShelleyCertificate txCertificates)) + (toShelleyWithdrawal txWithdrawals) + (toShelleyLovelace fee) + (error "TODO: makeShelleyTransaction support validity interval") + (toShelleyUpdate <$> maybeToStrictMaybe txUpdateProposal) + (toShelleyMetadataHash <$> maybeToStrictMaybe txMetadata) + (error "TODO: makeShelleyTransaction support minting")) + (toShelleyMetadata <$> txMetadata) + + +toShelleyWithdrawal :: [(StakeAddress, Lovelace)] -> Shelley.Wdrl ledgerera +toShelleyWithdrawal withdrawals = + Shelley.Wdrl $ + Map.fromList + [ (toShelleyStakeAddr stakeAddr, toShelleyLovelace value) + | (stakeAddr, value) <- withdrawals ] +-- ---------------------------------------------------------------------------- +-- Other utilities helpful with making transaction bodies +-- -- | Compute the 'TxIn' of the initial UTxO pseudo-transaction corresponding -- to the given address in the genesis initial funds. @@ -369,4 +577,3 @@ genesisUTxOPseudoTxIn nw (GenesisUTxOKeyHash kh) = fromShelleyTxId :: Shelley.TxId StandardShelley -> TxId fromShelleyTxId (Shelley.TxId h) = TxId (Crypto.castHash h) - diff --git a/cardano-api/src/Cardano/Api/TxMetadata.hs b/cardano-api/src/Cardano/Api/TxMetadata.hs index 004c78e91f0..b4d899c2a23 100644 --- a/cardano-api/src/Cardano/Api/TxMetadata.hs +++ b/cardano-api/src/Cardano/Api/TxMetadata.hs @@ -25,6 +25,10 @@ module Cardano.Api.TxMetadata ( TxMetadataJsonError (..), TxMetadataJsonSchemaError (..), + -- * Internal conversion functions + toShelleyMetadata, + toShelleyMetadataHash, + -- * Data family instances AsType(..) ) where @@ -61,6 +65,7 @@ import Control.Monad (guard, when) import qualified Cardano.Binary as CBOR +import qualified Cardano.Ledger.Era as Ledger import qualified Shelley.Spec.Ledger.MetaData as Shelley import Cardano.Api.Eras @@ -151,6 +156,13 @@ fromShelleyMetaData (Shelley.MetaData mdMap) = fromShelleyMetaDatum v) | (k,v) <- xs ] +toShelleyMetadata :: TxMetadata -> Shelley.MetaData +toShelleyMetadata (TxMetadataShelley m) = m + +toShelleyMetadataHash :: Ledger.Era ledgerera + => TxMetadata -> Shelley.MetaDataHash ledgerera +toShelleyMetadataHash (TxMetadataShelley m) = Shelley.hashMetaData m + -- ---------------------------------------------------------------------------- -- Validate tx metaData diff --git a/cardano-api/src/Cardano/Api/Typed.hs b/cardano-api/src/Cardano/Api/Typed.hs index 2519147667a..1fcdb5ccbcf 100644 --- a/cardano-api/src/Cardano/Api/Typed.hs +++ b/cardano-api/src/Cardano/Api/Typed.hs @@ -148,6 +148,8 @@ module Cardano.Api.Typed ( TxExtraContent(..), txExtraContentEmpty, Certificate(..), + toShelleyCertificate, + fromShelleyCertificate, -- * Signing transactions -- | Creating transaction witnesses one by one, or all in one go. @@ -379,6 +381,8 @@ module Cardano.Api.Typed ( EpochNo(..), NetworkMagic(..), makeShelleyUpdateProposal, + PraosNonce, + makePraosNonce, -- ** Conversions --TODO: arrange not to export these diff --git a/cardano-api/src/Cardano/Api/Value.hs b/cardano-api/src/Cardano/Api/Value.hs index 1f9d100e900..a979a217841 100644 --- a/cardano-api/src/Cardano/Api/Value.hs +++ b/cardano-api/src/Cardano/Api/Value.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | Currency values -- @@ -26,14 +26,12 @@ module Cardano.Api.Value , selectLovelace , lovelaceToValue - -- * Era-dependent use of multi-assert values - , MintValue(..) - , TxOutValue(..) - , AdaOnlyInEra(..) - , MultiAssetInEra(..) - -- * Internal conversion functions + , toByronLovelace , toShelleyLovelace + , fromShelleyLovelace + , toMaryValue + , fromMaryValue ) where import Prelude @@ -44,9 +42,14 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.String (IsString) +import qualified Cardano.Chain.Common as Byron + +import qualified Cardano.Ledger.Era as Ledger import qualified Shelley.Spec.Ledger.Coin as Shelley +import qualified Cardano.Ledger.Mary.Value as Mary + +import Ouroboros.Consensus.Shelley.Protocol.Crypto (StandardCrypto) -import Cardano.Api.Eras import Cardano.Api.Script @@ -64,10 +67,20 @@ instance Semigroup Lovelace where instance Monoid Lovelace where mempty = Lovelace 0 + +toByronLovelace :: Lovelace -> Maybe Byron.Lovelace +toByronLovelace (Lovelace x) = + case Byron.integerToLovelace x of + Left _ -> Nothing + Right x' -> Just x' + toShelleyLovelace :: Lovelace -> Shelley.Coin toShelleyLovelace (Lovelace l) = Shelley.Coin l --TODO: validate bounds +fromShelleyLovelace :: Shelley.Coin -> Lovelace +fromShelleyLovelace (Shelley.Coin l) = Lovelace l + -- ---------------------------------------------------------------------------- -- Multi asset Value @@ -97,8 +110,8 @@ newtype AssetName = AssetName ByteString deriving stock (Show) deriving newtype (Eq, Ord, IsString) -data AssetId = AssetId !PolicyId !AssetName - | AdaAssetId +data AssetId = AdaAssetId + | AssetId !PolicyId !AssetName deriving (Eq, Ord, Show) @@ -158,50 +171,39 @@ lovelaceToValue :: Lovelace -> Value lovelaceToValue = Value . Map.singleton AdaAssetId . lovelaceToQuantity --- ---------------------------------------------------------------------------- --- Era-dependent use of multi-assert values --- - -data MintValue era where - - MintNothing :: MintValue era - - MintValue :: MultiAssetInEra era -> Value -> MintValue era - -deriving instance Eq (MintValue era) -deriving instance Show (MintValue era) - - -data TxOutValue era where - - TxOutAdaOnly :: AdaOnlyInEra era -> Lovelace -> TxOutValue era - - TxOutValue :: MultiAssetInEra era -> Value -> TxOutValue era - -deriving instance Eq (TxOutValue era) -deriving instance Show (TxOutValue era) - - --- | Representation of whether only ada transactions are supported in a --- particular era. --- -data AdaOnlyInEra era where - - AdaOnlyInByronEra :: AdaOnlyInEra ByronEra - AdaOnlyInShelleyEra :: AdaOnlyInEra ShelleyEra - AdaOnlyInAllegraEra :: AdaOnlyInEra AllegraEra - -deriving instance Eq (AdaOnlyInEra era) -deriving instance Show (AdaOnlyInEra era) - --- | Representation of whether multi-asset transactions are supported in a --- particular era. --- -data MultiAssetInEra era where - - -- | Multi-asset transactions are supported in the 'Mary' era. - MultiAssetInMaryEra :: MultiAssetInEra MaryEra - -deriving instance Eq (MultiAssetInEra era) -deriving instance Show (MultiAssetInEra era) +toMaryValue :: forall ledgerera. + Ledger.Crypto ledgerera ~ StandardCrypto + => Value -> Mary.Value ledgerera +toMaryValue v = + Mary.Value lovelace other + where + Quantity lovelace = selectAsset v AdaAssetId + --TODO: write QC tests to show it's ok to use Map.fromAscListWith here + other = Map.fromListWith Map.union + [ (toMaryPolicyID pid, Map.singleton (toMaryAssetName name) q) + | (AssetId pid name, Quantity q) <- valueToList v ] + + toMaryPolicyID :: PolicyId -> Mary.PolicyID ledgerera + toMaryPolicyID (PolicyId sh) = Mary.PolicyID (toShelleyScriptHash sh) + + toMaryAssetName :: AssetName -> Mary.AssetName + toMaryAssetName (AssetName n) = Mary.AssetName n + + +fromMaryValue :: forall ledgerera. + Ledger.Crypto ledgerera ~ StandardCrypto + => Mary.Value ledgerera -> Value +fromMaryValue (Mary.Value lovelace other) = + Value $ + --TODO: write QC tests to show it's ok to use Map.fromAscList here + Map.fromList $ + [ (AdaAssetId, Quantity lovelace) | lovelace /= 0 ] + ++ [ (AssetId (fromMaryPolicyID pid) (fromMaryAssetName name), Quantity q) + | (pid, as) <- Map.toList other + , (name, q) <- Map.toList as ] + where + fromMaryPolicyID :: Mary.PolicyID ledgerera -> PolicyId + fromMaryPolicyID (Mary.PolicyID sh) = PolicyId (fromShelleyScriptHash sh) + fromMaryAssetName :: Mary.AssetName -> AssetName + fromMaryAssetName (Mary.AssetName n) = AssetName n diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs index c06aa162124..1f92b80be4b 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs @@ -30,11 +30,9 @@ import Data.Attoparsec.Combinator (()) import Data.Time.Clock (UTCTime) import Data.Time.Format (defaultTimeLocale, iso8601DateFormat, parseTimeOrError) import Network.Socket (PortNumber) -import Network.URI (URI, parseURI) import Options.Applicative hiding (str) import Ouroboros.Consensus.BlockchainTime (SystemStart (..)) -import qualified Cardano.Crypto.Hash as Crypto (Blake2b_256, Hash (..), hashFromBytesAsHex) import qualified Data.Attoparsec.ByteString.Char8 as Atto import qualified Data.ByteString.Char8 as BSC import qualified Data.Char as Char @@ -1932,7 +1930,7 @@ pStakePoolMetadataReference = <$> pStakePoolMetadataUrl <*> pStakePoolMetadataHash -pStakePoolMetadataUrl :: Parser URI +pStakePoolMetadataUrl :: Parser Text pStakePoolMetadataUrl = Opt.option (readURIOfMaxLength 64) ( Opt.long "metadata-url" @@ -1949,11 +1947,9 @@ pStakePoolMetadataHash = <> Opt.help "Pool metadata hash." ) where - getHashFromHexString :: String -> Maybe (Crypto.Hash Crypto.Blake2b_256 ByteString) - getHashFromHexString = Crypto.hashFromBytesAsHex . BSC.pack - metadataHash :: String -> Maybe (Hash StakePoolMetadata) - metadataHash str = StakePoolMetadataHash <$> getHashFromHexString str + metadataHash = deserialiseFromRawBytesHex (AsHash AsStakePoolMetadata) + . BSC.pack pStakePoolRegistrationCert :: Parser PoolCmd pStakePoolRegistrationCert = @@ -2120,9 +2116,9 @@ pDecentralParam = <> Opt.help "Decentralization parameter." ) -pExtraEntropy :: Parser (Maybe ByteString) +pExtraEntropy :: Parser (Maybe PraosNonce) pExtraEntropy = - Opt.option (Just <$> readerFromAttoParser parseEntropyBytes) + Opt.option (Just <$> readerFromAttoParser parsePraosNonce) ( Opt.long "extra-entropy" <> Opt.metavar "HEX" <> Opt.help "Praos extra entropy, as a hex byte string." @@ -2132,8 +2128,13 @@ pExtraEntropy = <> Opt.help "Reset the Praos extra entropy to none." ) where + parsePraosNonce :: Atto.Parser PraosNonce + parsePraosNonce = makePraosNonce <$> parseEntropyBytes + parseEntropyBytes :: Atto.Parser ByteString - parseEntropyBytes = Atto.takeWhile1 Char.isHexDigit <&> decodeEitherBase16 >>= either fail return + parseEntropyBytes = either fail return + . decodeEitherBase16 + =<< Atto.takeWhile1 Char.isHexDigit pProtocol :: Parser Protocol pProtocol = @@ -2277,10 +2278,9 @@ readOutputFormat = do <> s <> "\". Accepted output formats are \"hex\" and \"bech32\"." -readURIOfMaxLength :: Int -> Opt.ReadM URI -readURIOfMaxLength maxLen = do - s <- readStringOfMaxLength maxLen - maybe (fail "The provided string must be a valid URI.") pure (parseURI s) +readURIOfMaxLength :: Int -> Opt.ReadM Text +readURIOfMaxLength maxLen = + Text.pack <$> readStringOfMaxLength maxLen readStringOfMaxLength :: Int -> Opt.ReadM String readStringOfMaxLength maxLen = do