From 099db6e7ec8cdbfee8c394e470de334ca241bda3 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 13 Oct 2023 00:45:25 +1100 Subject: [PATCH] Use ShelleyBasedEra instead of IsShelleyBasedEra. Use CardanoEra instead of IsCardanoEra. --- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 63 +++---- cardano-api/internal/Cardano/Api/Address.hs | 63 ++++--- cardano-api/internal/Cardano/Api/Block.hs | 42 +++-- .../Cardano/Api/Convenience/Construction.hs | 12 +- .../Cardano/Api/Eon/ShelleyBasedEra.hs | 20 +- cardano-api/internal/Cardano/Api/Eras/Core.hs | 14 +- cardano-api/internal/Cardano/Api/Fees.hs | 178 +++++++++--------- .../internal/Cardano/Api/LedgerState.hs | 6 +- .../Cardano/Api/ProtocolParameters.hs | 9 +- .../Cardano/Api/SerialiseLedgerCddl.hs | 45 +++-- cardano-api/internal/Cardano/Api/Tx.hs | 104 +++++----- cardano-api/internal/Cardano/Api/TxBody.hs | 95 +++++----- .../Test/Golden/ErrorsSpec.hs | 2 +- .../Test/Cardano/Api/Typed/CBOR.hs | 10 +- .../Test/Cardano/Api/Typed/Ord.hs | 2 +- .../Test/Cardano/Api/Typed/TxBody.hs | 5 +- 16 files changed, 331 insertions(+), 339 deletions(-) diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 748028f905..d45fc17668 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -188,10 +188,10 @@ genAddressInEra era = LegacyByronEra -> byronAddressInEra <$> genAddressByron - ShelleyBasedEra _ -> + ShelleyBasedEra sbe -> Gen.choice - [ byronAddressInEra <$> genAddressByron - , shelleyAddressInEra <$> genAddressShelley + [ byronAddressInEra <$> genAddressByron + , shelleyAddressInEra sbe <$> genAddressShelley ] genKESPeriod :: Gen KESPeriod @@ -717,9 +717,9 @@ genTxFee = (pure . TxFeeImplicit) (\w -> TxFeeExplicit w <$> genLovelace) -genTxBody :: IsCardanoEra era => CardanoEra era -> Gen (TxBody era) +genTxBody :: CardanoEra era -> Gen (TxBody era) genTxBody era = do - res <- Api.createAndValidateTransactionBody <$> genTxBodyContent era + res <- Api.createAndValidateTransactionBody era <$> genTxBodyContent era case res of Left err -> fail (displayError err) Right txBody -> pure txBody @@ -753,7 +753,9 @@ genTxScriptValidity = genScriptValidity :: Gen ScriptValidity genScriptValidity = Gen.element [ScriptInvalid, ScriptValid] -genTx :: forall era. IsCardanoEra era => CardanoEra era -> Gen (Tx era) +genTx :: () + => CardanoEra era + -> Gen (Tx era) genTx era = makeSignedTransaction <$> genWitnesses era @@ -762,12 +764,10 @@ genTx era = genWitnesses :: CardanoEra era -> Gen [KeyWitness era] genWitnesses era = case cardanoEraStyle era of - LegacyByronEra -> Gen.list (Range.constant 1 10) genByronKeyWitness - ShelleyBasedEra _ -> do - bsWits <- Gen.list (Range.constant 0 10) - (genShelleyBootstrapWitness era) - keyWits <- Gen.list (Range.constant 0 10) - (genShelleyKeyWitness era) + LegacyByronEra -> Gen.list (Range.constant 1 10) genByronKeyWitness + ShelleyBasedEra sbe -> do + bsWits <- Gen.list (Range.constant 0 10) (genShelleyBootstrapWitness sbe) + keyWits <- Gen.list (Range.constant 0 10) (genShelleyKeyWitness sbe) return $ bsWits ++ keyWits genVerificationKey :: () @@ -806,33 +806,30 @@ genWitnessNetworkIdOrByronAddress = , WitnessByronAddress <$> genAddressByron ] -genShelleyBootstrapWitness - :: IsShelleyBasedEra era - => CardanoEra era +genShelleyBootstrapWitness :: () + => ShelleyBasedEra era -> Gen (KeyWitness era) -genShelleyBootstrapWitness era = - makeShelleyBootstrapWitness +genShelleyBootstrapWitness sbe = + makeShelleyBootstrapWitness sbe <$> genWitnessNetworkIdOrByronAddress - <*> genTxBody era + <*> genTxBody (shelleyBasedToCardanoEra sbe) <*> genSigningKey AsByronKey -genShelleyKeyWitness - :: IsShelleyBasedEra era - => CardanoEra era +genShelleyKeyWitness :: () + => ShelleyBasedEra era -> Gen (KeyWitness era) -genShelleyKeyWitness era = - makeShelleyKeyWitness - <$> genTxBody era +genShelleyKeyWitness sbe = + makeShelleyKeyWitness sbe + <$> genTxBody (shelleyBasedToCardanoEra sbe) <*> genShelleyWitnessSigningKey -genShelleyWitness - :: IsShelleyBasedEra era - => CardanoEra era +genShelleyWitness :: () + => ShelleyBasedEra era -> Gen (KeyWitness era) -genShelleyWitness era = +genShelleyWitness sbe = Gen.choice - [ genShelleyKeyWitness era - , genShelleyBootstrapWitness era + [ genShelleyKeyWitness sbe + , genShelleyBootstrapWitness sbe ] genShelleyWitnessSigningKey :: Gen ShelleyWitnessSigningKey @@ -845,12 +842,12 @@ genShelleyWitnessSigningKey = , WitnessGenesisUTxOKey <$> genSigningKey AsGenesisUTxOKey ] -genCardanoKeyWitness - :: CardanoEra era +genCardanoKeyWitness :: () + => CardanoEra era -> Gen (KeyWitness era) genCardanoKeyWitness era = case cardanoEraStyle era of LegacyByronEra -> genByronKeyWitness - ShelleyBasedEra _ -> genShelleyWitness era + ShelleyBasedEra sbe -> genShelleyWitness sbe genSeed :: Int -> Gen Crypto.Seed genSeed n = Crypto.mkSeedFromBytes <$> Gen.bytes (Range.singleton n) diff --git a/cardano-api/internal/Cardano/Api/Address.hs b/cardano-api/internal/Cardano/Api/Address.hs index df00798c2b..9182d20008 100644 --- a/cardano-api/internal/Cardano/Api/Address.hs +++ b/cardano-api/internal/Cardano/Api/Address.hs @@ -6,6 +6,7 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {- HLINT ignore "Avoid lambda using `infix`" -} @@ -373,9 +374,11 @@ instance IsCardanoEra era => ToJSON (AddressInEra era) where toJSON = Aeson.String . serialiseAddress instance IsShelleyBasedEra era => FromJSON (AddressInEra era) where - parseJSON = withText "AddressInEra" $ \txt -> do - addressAny <- runParsecParser parseAddressAny txt - pure $ anyAddressInShelleyBasedEra addressAny + parseJSON = + let sbe = shelleyBasedEra @era in + withText "AddressInEra" $ \txt -> do + addressAny <- runParsecParser parseAddressAny txt + pure $ anyAddressInShelleyBasedEra sbe addressAny parseAddressAny :: Parsec.Parser AddressAny parseAddressAny = do @@ -467,15 +470,20 @@ byronAddressInEra :: Address ByronAddr -> AddressInEra era byronAddressInEra = AddressInEra ByronAddressInAnyEra -shelleyAddressInEra :: IsShelleyBasedEra era - => Address ShelleyAddr -> AddressInEra era -shelleyAddressInEra = AddressInEra (ShelleyAddressInEra shelleyBasedEra) - +shelleyAddressInEra :: () + => ShelleyBasedEra era + -> Address ShelleyAddr + -> AddressInEra era +shelleyAddressInEra sbe = + AddressInEra (ShelleyAddressInEra sbe) -anyAddressInShelleyBasedEra :: IsShelleyBasedEra era - => AddressAny -> AddressInEra era -anyAddressInShelleyBasedEra (AddressByron addr) = byronAddressInEra addr -anyAddressInShelleyBasedEra (AddressShelley addr) = shelleyAddressInEra addr +anyAddressInShelleyBasedEra :: () + => ShelleyBasedEra era + -> AddressAny + -> AddressInEra era +anyAddressInShelleyBasedEra sbe = \case + AddressByron addr -> byronAddressInEra addr + AddressShelley addr -> shelleyAddressInEra sbe addr anyAddressInEra :: CardanoEra era @@ -500,13 +508,14 @@ makeByronAddressInEra nw vk = byronAddressInEra (makeByronAddress nw vk) -makeShelleyAddressInEra :: IsShelleyBasedEra era - => NetworkId - -> PaymentCredential - -> StakeAddressReference - -> AddressInEra era -makeShelleyAddressInEra nw pc scr = - shelleyAddressInEra (makeShelleyAddress nw pc scr) +makeShelleyAddressInEra :: () + => ShelleyBasedEra era + -> NetworkId + -> PaymentCredential + -> StakeAddressReference + -> AddressInEra era +makeShelleyAddressInEra sbe nw pc scr = + shelleyAddressInEra sbe (makeShelleyAddress nw pc scr) -- ---------------------------------------------------------------------------- @@ -659,15 +668,15 @@ toShelleyStakeReference (StakeAddressByPointer ptr) = toShelleyStakeReference NoStakeAddress = Shelley.StakeRefNull -fromShelleyAddrIsSbe :: IsShelleyBasedEra era - => Shelley.Addr StandardCrypto -> AddressInEra era -fromShelleyAddrIsSbe (Shelley.AddrBootstrap (Shelley.BootstrapAddress addr)) = - AddressInEra ByronAddressInAnyEra (ByronAddress addr) - -fromShelleyAddrIsSbe (Shelley.Addr nw pc scr) = - AddressInEra - (ShelleyAddressInEra shelleyBasedEra) - (ShelleyAddress nw pc scr) +fromShelleyAddrIsSbe :: () + => ShelleyBasedEra era + -> Shelley.Addr StandardCrypto + -> AddressInEra era +fromShelleyAddrIsSbe sbe = \case + Shelley.AddrBootstrap (Shelley.BootstrapAddress addr) -> + AddressInEra ByronAddressInAnyEra (ByronAddress addr) + Shelley.Addr nw pc scr -> + AddressInEra (ShelleyAddressInEra sbe) (ShelleyAddress nw pc scr) fromShelleyAddr :: ShelleyBasedEra era diff --git a/cardano-api/internal/Cardano/Api/Block.hs b/cardano-api/internal/Cardano/Api/Block.hs index 6220a3b73f..56f076f648 100644 --- a/cardano-api/internal/Cardano/Api/Block.hs +++ b/cardano-api/internal/Cardano/Api/Block.hs @@ -200,7 +200,11 @@ getShelleyBlockTxs era (Ledger.Block _header txs) = -- different block types for all the eras. It is used in the ChainSync protocol. -- data BlockInMode mode where - BlockInMode :: IsCardanoEra era => Block era -> EraInMode era mode -> BlockInMode mode + BlockInMode + :: CardanoEra era + -> Block era + -> EraInMode era mode + -> BlockInMode mode deriving instance Show (BlockInMode mode) @@ -213,41 +217,41 @@ fromConsensusBlock :: ConsensusBlockForMode mode ~ block fromConsensusBlock ByronMode = \b -> case b of Consensus.DegenBlock b' -> - BlockInMode (ByronBlock b') ByronEraInByronMode + BlockInMode cardanoEra (ByronBlock b') ByronEraInByronMode fromConsensusBlock ShelleyMode = \b -> case b of Consensus.DegenBlock b' -> - BlockInMode (ShelleyBlock ShelleyBasedEraShelley b') + BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraShelley b') ShelleyEraInShelleyMode fromConsensusBlock CardanoMode = \b -> case b of Consensus.BlockByron b' -> - BlockInMode (ByronBlock b') ByronEraInCardanoMode + BlockInMode cardanoEra (ByronBlock b') ByronEraInCardanoMode Consensus.BlockShelley b' -> - BlockInMode (ShelleyBlock ShelleyBasedEraShelley b') + BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraShelley b') ShelleyEraInCardanoMode Consensus.BlockAllegra b' -> - BlockInMode (ShelleyBlock ShelleyBasedEraAllegra b') + BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraAllegra b') AllegraEraInCardanoMode Consensus.BlockMary b' -> - BlockInMode (ShelleyBlock ShelleyBasedEraMary b') + BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraMary b') MaryEraInCardanoMode Consensus.BlockAlonzo b' -> - BlockInMode (ShelleyBlock ShelleyBasedEraAlonzo b') + BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraAlonzo b') AlonzoEraInCardanoMode Consensus.BlockBabbage b' -> - BlockInMode (ShelleyBlock ShelleyBasedEraBabbage b') + BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraBabbage b') BabbageEraInCardanoMode Consensus.BlockConway b' -> - BlockInMode (ShelleyBlock ShelleyBasedEraConway b') + BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraConway b') ConwayEraInCardanoMode toConsensusBlock @@ -260,19 +264,19 @@ toConsensusBlock toConsensusBlock bInMode = case bInMode of -- Byron mode - BlockInMode (ByronBlock b') ByronEraInByronMode -> Consensus.DegenBlock b' + BlockInMode _ (ByronBlock b') ByronEraInByronMode -> Consensus.DegenBlock b' -- Shelley mode - BlockInMode (ShelleyBlock ShelleyBasedEraShelley b') ShelleyEraInShelleyMode -> Consensus.DegenBlock b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraShelley b') ShelleyEraInShelleyMode -> Consensus.DegenBlock b' -- Cardano mode - BlockInMode (ByronBlock b') ByronEraInCardanoMode -> Consensus.BlockByron b' - BlockInMode (ShelleyBlock ShelleyBasedEraShelley b') ShelleyEraInCardanoMode -> Consensus.BlockShelley b' - BlockInMode (ShelleyBlock ShelleyBasedEraAllegra b') AllegraEraInCardanoMode -> Consensus.BlockAllegra b' - BlockInMode (ShelleyBlock ShelleyBasedEraMary b') MaryEraInCardanoMode -> Consensus.BlockMary b' - BlockInMode (ShelleyBlock ShelleyBasedEraAlonzo b') AlonzoEraInCardanoMode -> Consensus.BlockAlonzo b' - BlockInMode (ShelleyBlock ShelleyBasedEraBabbage b') BabbageEraInCardanoMode -> Consensus.BlockBabbage b' - BlockInMode (ShelleyBlock ShelleyBasedEraConway b') ConwayEraInCardanoMode -> Consensus.BlockConway b' + BlockInMode _ (ByronBlock b') ByronEraInCardanoMode -> Consensus.BlockByron b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraShelley b') ShelleyEraInCardanoMode -> Consensus.BlockShelley b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraAllegra b') AllegraEraInCardanoMode -> Consensus.BlockAllegra b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraMary b') MaryEraInCardanoMode -> Consensus.BlockMary b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraAlonzo b') AlonzoEraInCardanoMode -> Consensus.BlockAlonzo b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraBabbage b') BabbageEraInCardanoMode -> Consensus.BlockBabbage b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraConway b') ConwayEraInCardanoMode -> Consensus.BlockConway b' -- ---------------------------------------------------------------------------- -- Block headers diff --git a/cardano-api/internal/Cardano/Api/Convenience/Construction.hs b/cardano-api/internal/Cardano/Api/Convenience/Construction.hs index 16d3e5ddac..79cc8c1790 100644 --- a/cardano-api/internal/Cardano/Api/Convenience/Construction.hs +++ b/cardano-api/internal/Cardano/Api/Convenience/Construction.hs @@ -41,9 +41,9 @@ import qualified Data.Text as Text -- See Cardano.Api.Convenience.Query.queryStateForBalancedTx for a -- convenient way of querying the node to get the required arguements -- for constructBalancedTx. -constructBalancedTx - :: IsShelleyBasedEra era - => TxBodyContent BuildTx era +constructBalancedTx :: () + => ShelleyBasedEra era + -> TxBodyContent BuildTx era -> AddressInEra era -- ^ Change address -> Maybe Word -- ^ Override key witnesses -> UTxO era -- ^ Just the transaction inputs, not the entire 'UTxO'. @@ -55,17 +55,17 @@ constructBalancedTx -> Map.Map (L.Credential L.DRepRole L.StandardCrypto) Lovelace -> [ShelleyWitnessSigningKey] -> Either TxBodyErrorAutoBalance (Tx era) -constructBalancedTx txbodcontent changeAddr mOverrideWits utxo lpp +constructBalancedTx sbe txbodcontent changeAddr mOverrideWits utxo lpp ledgerEpochInfo systemStart stakePools stakeDelegDeposits drepDelegDeposits shelleyWitSigningKeys = do BalancedTxBody _ txbody _txBalanceOutput _fee <- makeTransactionBodyAutoBalance - systemStart ledgerEpochInfo + sbe systemStart ledgerEpochInfo lpp stakePools stakeDelegDeposits drepDelegDeposits utxo txbodcontent changeAddr mOverrideWits - let keyWits = map (makeShelleyKeyWitness txbody) shelleyWitSigningKeys + let keyWits = map (makeShelleyKeyWitness sbe txbody) shelleyWitSigningKeys return $ makeSignedTransaction keyWits txbody data TxInsExistError diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs index 7cb2ee7a2c..8f3eb4272d 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs @@ -178,8 +178,7 @@ instance IsShelleyBasedEra ConwayEra where data AnyShelleyBasedEra where AnyShelleyBasedEra - :: IsShelleyBasedEra era -- Provide class constraint - => ShelleyBasedEra era -- and explicit value. + :: ShelleyBasedEra era -> AnyShelleyBasedEra deriving instance Show AnyShelleyBasedEra @@ -237,10 +236,10 @@ instance FromJSON AnyShelleyBasedEra where -- is not statically known, for example when deserialising from a file. -- data InAnyShelleyBasedEra thing where - InAnyShelleyBasedEra :: IsShelleyBasedEra era -- Provide class constraint - => ShelleyBasedEra era -- and explicit value. - -> thing era - -> InAnyShelleyBasedEra thing + InAnyShelleyBasedEra + :: ShelleyBasedEra era + -> thing era + -> InAnyShelleyBasedEra thing -- | Converts a 'ShelleyBasedEra' to the broader 'CardanoEra'. @@ -265,10 +264,11 @@ shelleyBasedToCardanoEra ShelleyBasedEraConway = ConwayEra -- the Shelley-based eras can often be treated uniformly. -- data CardanoEraStyle era where - LegacyByronEra :: CardanoEraStyle ByronEra - ShelleyBasedEra :: IsShelleyBasedEra era -- Also provide class constraint - => ShelleyBasedEra era - -> CardanoEraStyle era + LegacyByronEra :: CardanoEraStyle ByronEra + + ShelleyBasedEra + :: ShelleyBasedEra era + -> CardanoEraStyle era deriving instance Eq (CardanoEraStyle era) deriving instance Ord (CardanoEraStyle era) diff --git a/cardano-api/internal/Cardano/Api/Eras/Core.hs b/cardano-api/internal/Cardano/Api/Eras/Core.hs index 1a0cde248b..2c6f2329a1 100644 --- a/cardano-api/internal/Cardano/Api/Eras/Core.hs +++ b/cardano-api/internal/Cardano/Api/Eras/Core.hs @@ -270,9 +270,9 @@ instance IsCardanoEra ConwayEra where cardanoEra = ConwayEra data AnyCardanoEra where - AnyCardanoEra :: IsCardanoEra era -- Provide class constraint - => CardanoEra era -- and explicit value. - -> AnyCardanoEra + AnyCardanoEra + :: CardanoEra era + -> AnyCardanoEra deriving instance Show AnyCardanoEra @@ -346,10 +346,10 @@ anyCardanoEra = \case -- not statically known, for example when deserialising from a file. -- data InAnyCardanoEra thing where - InAnyCardanoEra :: IsCardanoEra era -- Provide class constraint - => CardanoEra era -- and explicit value. - -> thing era - -> InAnyCardanoEra thing + InAnyCardanoEra + :: CardanoEra era + -> thing era + -> InAnyCardanoEra thing -- ---------------------------------------------------------------------------- -- Conversion to ledger library types diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index d19af134be..c8309b17f7 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -107,22 +107,21 @@ import Prettyprinter.Render.String -- This function is simple, but if you are doing input selection then you -- probably want to consider estimateTransactionFee. -- -transactionFee :: forall era. - IsShelleyBasedEra era - => Lovelace -- ^ The fixed tx fee - -> Lovelace -- ^ The tx fee per byte - -> Tx era - -> Lovelace -transactionFee txFeeFixed txFeePerByte tx = +transactionFee :: () + => ShelleyBasedEra era + -> Lovelace -- ^ The fixed tx fee + -> Lovelace -- ^ The tx fee per byte + -> Tx era + -> Lovelace +transactionFee sbe txFeeFixed txFeePerByte tx = let a = toInteger txFeePerByte b = toInteger txFeeFixed - in case tx of - ShelleyTx _ tx' -> - let x = shelleyBasedEraConstraints (shelleyBasedEra @era) $ tx' ^. L.sizeTxF - in Lovelace (a * x + b) - --TODO: This can be made to work for Byron txs too. Do that: fill in this case - -- and remove the IsShelleyBasedEra constraint. - ByronTx _ -> case shelleyBasedEra @era of {} + in + case tx of + ShelleyTx _ tx' -> + let x = shelleyBasedEraConstraints sbe $ tx' ^. L.sizeTxF in Lovelace (a * x + b) + --TODO: This can be made to work for Byron txs too. + ByronTx _ -> case sbe of {} {-# DEPRECATED transactionFee "Use 'evaluateTransactionFee' instead" #-} @@ -137,30 +136,34 @@ transactionFee txFeeFixed txFeePerByte tx = -- contain all the things not subject to coin selection (such as script inputs, -- metadata, withdrawals, certs etc) -- -estimateTransactionFee :: forall era. - IsShelleyBasedEra era - => NetworkId - -> Lovelace -- ^ The fixed tx fee - -> Lovelace -- ^ The tx fee per byte - -> Tx era - -> Int -- ^ The number of extra UTxO transaction inputs - -> Int -- ^ The number of extra transaction outputs - -> Int -- ^ The number of extra Shelley key witnesses - -> Int -- ^ The number of extra Byron key witnesses - -> Lovelace -estimateTransactionFee nw txFeeFixed txFeePerByte (ShelleyTx era tx) = - let Lovelace baseFee = transactionFee txFeeFixed txFeePerByte (ShelleyTx era tx) - in \nInputs nOutputs nShelleyKeyWitnesses nByronKeyWitnesses -> - - --TODO: this is fragile. Move something like this to the ledger and - -- make it robust, based on the txsize calculation. - let extraBytes :: Int - extraBytes = nInputs * sizeInput - + nOutputs * sizeOutput - + nByronKeyWitnesses * sizeByronKeyWitnesses - + nShelleyKeyWitnesses * sizeShelleyKeyWitnesses - - in Lovelace (baseFee + toInteger txFeePerByte * toInteger extraBytes) +estimateTransactionFee :: () + => ShelleyBasedEra era + -> NetworkId + -> Lovelace -- ^ The fixed tx fee + -> Lovelace -- ^ The tx fee per byte + -> Tx era + -> Int -- ^ The number of extra UTxO transaction inputs + -> Int -- ^ The number of extra transaction outputs + -> Int -- ^ The number of extra Shelley key witnesses + -> Int -- ^ The number of extra Byron key witnesses + -> Lovelace +estimateTransactionFee sbe nw txFeeFixed txFeePerByte = \case + -- TODO: This can be made to work for Byron txs too. + ByronTx _ -> + case sbe of {} + ShelleyTx era tx -> + let Lovelace baseFee = transactionFee sbe txFeeFixed txFeePerByte (ShelleyTx era tx) + in \nInputs nOutputs nShelleyKeyWitnesses nByronKeyWitnesses -> + --TODO: this is fragile. Move something like this to the ledger and + -- make it robust, based on the txsize calculation. + let extraBytes :: Int + extraBytes = + nInputs * sizeInput + + nOutputs * sizeOutput + + nByronKeyWitnesses * sizeByronKeyWitnesses + + nShelleyKeyWitnesses * sizeShelleyKeyWitnesses + + in Lovelace (baseFee + toInteger txFeePerByte * toInteger extraBytes) where sizeInput = smallArray + uint + hashObj sizeOutput = smallArray + uint + address @@ -193,11 +196,6 @@ estimateTransactionFee nw txFeeFixed txFeePerByte (ShelleyTx era tx) = Byron.aaNetworkMagic = toByronNetworkMagic nw } ---TODO: This can be made to work for Byron txs too. Do that: fill in this case --- and remove the IsShelleyBasedEra constraint. -estimateTransactionFee _ _ _ (ByronTx _) = - case shelleyBasedEra @era of {} - --TODO: also deprecate estimateTransactionFee: --{-# DEPRECATED estimateTransactionFee "Use 'evaluateTransactionFee' instead" #-} @@ -208,25 +206,23 @@ estimateTransactionFee _ _ _ (ByronTx _) = -- -- TODO: we need separate args for Shelley vs Byron key sigs -- -evaluateTransactionFee :: forall era. - IsShelleyBasedEra era - => Ledger.PParams (ShelleyLedgerEra era) - -> TxBody era - -> Word -- ^ The number of Shelley key witnesses - -> Word -- ^ The number of Byron key witnesses - -> Lovelace -evaluateTransactionFee _ _ _ byronwitcount | byronwitcount > 0 = +evaluateTransactionFee :: forall era. () + => ShelleyBasedEra era + -> Ledger.PParams (ShelleyLedgerEra era) + -> TxBody era + -> Word -- ^ The number of Shelley key witnesses + -> Word -- ^ The number of Byron key witnesses + -> Lovelace +evaluateTransactionFee _ _ _ _ byronwitcount | byronwitcount > 0 = error "evaluateTransactionFee: TODO support Byron key witnesses" -evaluateTransactionFee pp txbody keywitcount _byronwitcount = +evaluateTransactionFee sbe pp txbody keywitcount _byronwitcount = + shelleyBasedEraConstraints sbe $ case makeSignedTransaction [] txbody of - ByronTx{} -> case shelleyBasedEra :: ShelleyBasedEra era of {} + ByronTx{} -> case sbe of {} --TODO: we could actually support Byron here, it'd be different but simpler - ShelleyTx sbe tx -> - shelleyBasedEraConstraints sbe - $ fromShelleyLovelace - $ Ledger.evaluateTransactionFee pp tx keywitcount + ShelleyTx _ tx -> fromShelleyLovelace $ Ledger.evaluateTransactionFee pp tx keywitcount -- | Give an approximate count of the number of key witnesses (i.e. signatures) -- a transaction will need. @@ -562,21 +558,20 @@ evaluateTransactionExecutionUnitsShelley sbe systemstart epochInfo (LedgerProtoc -- Finding the (non-zero) balance of partially constructed transaction is -- useful for adjusting a transaction to be fully balanced. -- -evaluateTransactionBalance :: forall era. - IsShelleyBasedEra era - => Ledger.PParams (ShelleyLedgerEra era) +evaluateTransactionBalance :: forall era. () + => ShelleyBasedEra era + -> Ledger.PParams (ShelleyLedgerEra era) -> Set PoolId -> Map StakeCredential Lovelace -> Map (Ledger.Credential Ledger.DRepRole Ledger.StandardCrypto) Lovelace -> UTxO era -> TxBody era -> TxOutValue era -evaluateTransactionBalance _ _ _ _ _ (ByronTxBody _) = - case shelleyBasedEra :: ShelleyBasedEra era of {} - --TODO: we could actually support Byron here, it'd be different but simpler +evaluateTransactionBalance sbe _ _ _ _ _ (ByronTxBody _) = + -- TODO: we could actually support Byron here, it'd be different but simpler + case sbe of {} -evaluateTransactionBalance pp poolids stakeDelegDeposits drepDelegDeposits utxo - (ShelleyTxBody sbe txbody _ _ _ _) = +evaluateTransactionBalance sbe pp poolids stakeDelegDeposits drepDelegDeposits utxo (ShelleyTxBody _ txbody _ _ _ _) = caseShelleyToAllegraOrMaryEraOnwards evalAdaOnly evalMultiAsset @@ -772,10 +767,9 @@ data BalancedTxBody era -- To do this it needs more information than 'makeTransactionBody', all of -- which can be queried from a local node. -- -makeTransactionBodyAutoBalance - :: forall era. - IsShelleyBasedEra era - => SystemStart +makeTransactionBodyAutoBalance :: forall era. () + => ShelleyBasedEra era + -> SystemStart -> LedgerEpochInfo -> LedgerProtocolParameters era -> Set PoolId -- ^ The set of registered stake pools, that are being @@ -791,7 +785,7 @@ makeTransactionBodyAutoBalance -> AddressInEra era -- ^ Change address -> Maybe Word -- ^ Override key witnesses -> Either TxBodyErrorAutoBalance (BalancedTxBody era) -makeTransactionBodyAutoBalance systemstart history lpp@(LedgerProtocolParameters pp) poolids stakeDelegDeposits +makeTransactionBodyAutoBalance sbe systemstart history lpp@(LedgerProtocolParameters pp) poolids stakeDelegDeposits drepDelegDeposits utxo txbodycontent changeaddr mnkeys = do -- Our strategy is to: -- 1. evaluate all the scripts to get the exec units, update with ex units @@ -799,9 +793,9 @@ makeTransactionBodyAutoBalance systemstart history lpp@(LedgerProtocolParameters -- 3. update tx with fees -- 4. balance the transaction and update tx change output txbody0 <- - first TxBodyError $ createAndValidateTransactionBody txbodycontent + first TxBodyError $ createAndValidateTransactionBody era txbodycontent { txOuts = txOuts txbodycontent ++ - [TxOut changeaddr (lovelaceToTxOutValue 0) TxOutDatumNone ReferenceScriptNone] + [TxOut changeaddr (lovelaceToTxOutValue era 0) TxOutDatumNone ReferenceScriptNone] --TODO: think about the size of the change output -- 1,2,4 or 8 bytes? } @@ -846,13 +840,13 @@ makeTransactionBodyAutoBalance systemstart history lpp@(LedgerProtocolParameters ] let changeTxOut = caseByronToAllegraOrMaryEraOnwards - (const (lovelaceToTxOutValue $ Lovelace (2^(64 :: Integer)) - 1)) + (const $ lovelaceToTxOutValue era $ Lovelace (2^(64 :: Integer)) - 1) (\w -> TxOutValue w (lovelaceToValue (Lovelace (2^(64 :: Integer)) - 1) <> nonAdaChange)) - (cardanoEra @era) + era let (dummyCollRet, dummyTotColl) = maybeDummyTotalCollAndCollReturnOutput txbodycontent changeaddr txbody1 <- first TxBodyError $ -- TODO: impossible to fail now - createAndValidateTransactionBody txbodycontent1 { + createAndValidateTransactionBody era txbodycontent1 { txFee = TxFeeExplicit sbe $ Lovelace (2^(32 :: Integer) - 1), txOuts = TxOut changeaddr changeTxOut @@ -865,7 +859,7 @@ makeTransactionBodyAutoBalance systemstart history lpp@(LedgerProtocolParameters let nkeys = fromMaybe (estimateTransactionKeyWitnessCount txbodycontent1) mnkeys - fee = evaluateTransactionFee pp txbody1 nkeys 0 --TODO: byron keys + fee = evaluateTransactionFee sbe pp txbody1 nkeys 0 --TODO: byron keys (retColl, reqCol) = caseShelleyToAlonzoOrBabbageEraOnwards (const (TxReturnCollateralNone, TxTotalCollateralNone)) @@ -881,12 +875,12 @@ makeTransactionBodyAutoBalance systemstart history lpp@(LedgerProtocolParameters -- Here we do not want to start with any change output, since that's what -- we need to calculate. txbody2 <- first TxBodyError $ -- TODO: impossible to fail now - createAndValidateTransactionBody txbodycontent1 { + createAndValidateTransactionBody era txbodycontent1 { txFee = TxFeeExplicit sbe fee, txReturnCollateral = retColl, txTotalCollateral = reqCol } - let balance = evaluateTransactionBalance pp poolids stakeDelegDeposits drepDelegDeposits utxo txbody2 + let balance = evaluateTransactionBalance sbe pp poolids stakeDelegDeposits drepDelegDeposits utxo txbody2 forM_ (txOuts txbodycontent1) $ \txout -> checkMinUTxOValue txout pp @@ -914,7 +908,7 @@ makeTransactionBodyAutoBalance systemstart history lpp@(LedgerProtocolParameters first TxBodyError $ -- TODO: impossible to fail now. We need to implement a function -- that simply creates a transaction body because we have already -- validated the transaction body earlier within makeTransactionBodyAutoBalance - createAndValidateTransactionBody finalTxBodyContent + createAndValidateTransactionBody era finalTxBodyContent return (BalancedTxBody finalTxBodyContent txbody3 (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) fee) where -- Essentially we check for the existence of collateral inputs. If they exist we @@ -926,13 +920,13 @@ makeTransactionBodyAutoBalance systemstart history lpp@(LedgerProtocolParameters case txInsCollateral of TxInsCollateralNone -> (TxReturnCollateralNone, TxTotalCollateralNone) TxInsCollateral{} -> - forEraInEon era' + forEraInEon era (TxReturnCollateralNone, TxTotalCollateralNone) (\w -> let dummyRetCol = TxReturnCollateral w ( TxOut cAddr - (lovelaceToTxOutValue $ Lovelace (2^(64 :: Integer)) - 1) + (lovelaceToTxOutValue era $ Lovelace (2^(64 :: Integer)) - 1) TxOutDatumNone ReferenceScriptNone ) dummyTotCol = TxTotalCollateral w (Lovelace (2^(32 :: Integer) - 1)) @@ -957,7 +951,8 @@ makeTransactionBodyAutoBalance systemstart history lpp@(LedgerProtocolParameters -> (TxReturnCollateral CtxTx era, TxTotalCollateral era) calcReturnAndTotalCollateral _ _ _ TxInsCollateralNone _ _ _ _= (TxReturnCollateralNone, TxTotalCollateralNone) calcReturnAndTotalCollateral _ _ _ _ rc@TxReturnCollateral{} tc@TxTotalCollateral{} _ _ = (rc,tc) - calcReturnAndTotalCollateral retColSup fee pp' (TxInsCollateral _ collIns) txReturnCollateral txTotalCollateral cAddr (UTxO utxo') = do + calcReturnAndTotalCollateral retColSup fee pp' (TxInsCollateral _ collIns) txReturnCollateral txTotalCollateral cAddr (UTxO utxo') = + shelleyBasedEraConstraints sbe $ do let colPerc = pp' ^. Ledger.ppCollateralPercentageL -- We must first figure out how much lovelace we have committed -- as collateral and we must determine if we have enough lovelace at our @@ -992,16 +987,13 @@ makeTransactionBodyAutoBalance systemstart history lpp@(LedgerProtocolParameters then ( TxReturnCollateral retColSup - (TxOut cAddr (lovelaceToTxOutValue returnCollateral) TxOutDatumNone ReferenceScriptNone) + (TxOut cAddr (lovelaceToTxOutValue era returnCollateral) TxOutDatumNone ReferenceScriptNone) , totalCollateral ) else (TxReturnCollateralNone, TxTotalCollateralNone) - sbe :: ShelleyBasedEra era - sbe = shelleyBasedEra - - era' :: CardanoEra era - era' = cardanoEra + era :: CardanoEra era + era = shelleyBasedToCardanoEra sbe -- In the event of spending the exact amount of lovelace in -- the specified input(s), this function excludes the change @@ -1040,12 +1032,10 @@ makeTransactionBodyAutoBalance systemstart history lpp@(LedgerProtocolParameters -> Ledger.PParams (ShelleyLedgerEra era) -> Either TxBodyErrorAutoBalance () checkMinUTxOValue txout@(TxOut _ v _ _) bpp = do - let minUTxO = calculateMinimumUTxO sbe txout bpp - if txOutValueToLovelace v >= minUTxO - then Right () - else Left $ TxBodyErrorMinUTxONotMet - (txOutInAnyEra txout) - minUTxO + let minUTxO = calculateMinimumUTxO sbe txout bpp + if txOutValueToLovelace v >= minUTxO + then Right () + else Left $ TxBodyErrorMinUTxONotMet (txOutInAnyEra era txout) minUTxO substituteExecutionUnits :: Map ScriptWitnessIndex ExecutionUnits -> TxBodyContent BuildTx era diff --git a/cardano-api/internal/Cardano/Api/LedgerState.hs b/cardano-api/internal/Cardano/Api/LedgerState.hs index 21c52589f9..2db1434c3e 100644 --- a/cardano-api/internal/Cardano/Api/LedgerState.hs +++ b/cardano-api/internal/Cardano/Api/LedgerState.hs @@ -473,7 +473,7 @@ foldBlocks nodeConfigFilePath socketPath validationMode state0 accumulate = do -> CSP.ClientStNext n (BlockInMode CardanoMode) ChainPoint ChainTip IO () clientNextN n knownLedgerStates = CSP.ClientStNext { - CSP.recvMsgRollForward = \blockInMode@(BlockInMode block@(Block (BlockHeader slotNo _ currBlockNo) _) _era) serverChainTip -> do + CSP.recvMsgRollForward = \blockInMode@(BlockInMode _ block@(Block (BlockHeader slotNo _ currBlockNo) _) _era) serverChainTip -> do let newLedgerStateE = applyBlock env (maybe @@ -589,7 +589,7 @@ chainSyncClientWithLedgerState env ledgerState0 validationMode (CS.ChainSyncClie goClientStIdle (Left err) <$> CS.runChainSyncClient (recvMsgRollBackward point tip) ) goClientStNext (Right history) (CS.ClientStNext recvMsgRollForward recvMsgRollBackward) = CS.ClientStNext - (\blkInMode@(BlockInMode blk@(Block (BlockHeader slotNo _ _) _) _) tip -> CS.ChainSyncClient $ let + (\blkInMode@(BlockInMode _ blk@(Block (BlockHeader slotNo _ _) _) _) tip -> CS.ChainSyncClient $ let newLedgerStateE = case Seq.lookup 0 history of Nothing -> error "Impossible! History should always be non-empty" Just (_, Left err, _) -> Left err @@ -677,7 +677,7 @@ chainSyncClientPipelinedWithLedgerState env ledgerState0 validationMode (CSP.Cha goClientPipelinedStIdle (Left err) n <$> recvMsgRollBackward point tip ) goClientStNext (Right history) n (CSP.ClientStNext recvMsgRollForward recvMsgRollBackward) = CSP.ClientStNext - (\blkInMode@(BlockInMode blk@(Block (BlockHeader slotNo _ _) _) _) tip -> let + (\blkInMode@(BlockInMode _ blk@(Block (BlockHeader slotNo _ _) _) _) tip -> let newLedgerStateE = case Seq.lookup 0 history of Nothing -> error "Impossible! History should always be non-empty" Just (_, Left err, _) -> Left err diff --git a/cardano-api/internal/Cardano/Api/ProtocolParameters.hs b/cardano-api/internal/Cardano/Api/ProtocolParameters.hs index bc68e62601..c254b6a636 100644 --- a/cardano-api/internal/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/internal/Cardano/Api/ProtocolParameters.hs @@ -1840,8 +1840,7 @@ fromConwayPParams :: BabbageEraPParams ledgerera -> ProtocolParameters fromConwayPParams = fromBabbagePParams -checkProtocolParameters - :: forall era. IsCardanoEra era +checkProtocolParameters :: () => ShelleyBasedEra era -> ProtocolParameters -> Either ProtocolParametersError () @@ -1854,7 +1853,6 @@ checkProtocolParameters sbe ProtocolParameters{..} = ShelleyBasedEraBabbage -> checkBabbageParams ShelleyBasedEraConway -> checkBabbageParams where - era :: CardanoEra era era = shelleyBasedToCardanoEra sbe costPerWord = isJust protocolParamUTxOCostPerWord @@ -1912,9 +1910,8 @@ checkProtocolParameters sbe ProtocolParameters{..} = checkMinUTxOVal :: Either ProtocolParametersError () checkMinUTxOVal = if isJust protocolParamMinUTxOValue - then return () - else Left . PParamsErrorMissingMinUTxoValue - $ AnyCardanoEra era + then return () + else Left . PParamsErrorMissingMinUTxoValue $ cardanoEraConstraints era $ AnyCardanoEra era data ProtocolParametersError diff --git a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs index ce3b6c938d..e87bc7cfd7 100644 --- a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs +++ b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs @@ -123,14 +123,15 @@ instance Error TextEnvelopeCddlError where displayError TextEnvelopeCddlErrByronKeyWitnessUnsupported = "TextEnvelopeCddl error: Byron key witnesses are currently unsupported." -serialiseTxLedgerCddl :: forall era. IsCardanoEra era => Tx era -> TextEnvelopeCddl -serialiseTxLedgerCddl tx = - TextEnvelopeCddl - { teCddlType = genType tx - , teCddlDescription = "Ledger Cddl Format" - , teCddlRawCBOR = serialiseToCBOR tx - -- The SerialiseAsCBOR (Tx era) instance serializes to the Cddl format - } +serialiseTxLedgerCddl :: CardanoEra era -> Tx era -> TextEnvelopeCddl +serialiseTxLedgerCddl era tx = + cardanoEraConstraints era $ + TextEnvelopeCddl + { teCddlType = genType tx + , teCddlDescription = "Ledger Cddl Format" + , teCddlRawCBOR = serialiseToCBOR tx + -- The SerialiseAsCBOR (Tx era) instance serializes to the Cddl format + } where genType :: Tx era -> Text genType tx' = case getTxWitnesses tx' of @@ -138,7 +139,7 @@ serialiseTxLedgerCddl tx = _ -> "Witnessed " <> genTxType genTxType :: Text genTxType = - case cardanoEra :: CardanoEra era of + case era of ByronEra -> "Tx ByronEra" ShelleyEra -> "Tx ShelleyEra" AllegraEra -> "Tx AllegraEra" @@ -147,27 +148,23 @@ serialiseTxLedgerCddl tx = BabbageEra -> "Tx BabbageEra" ConwayEra -> "Tx ConwayEra" -deserialiseTxLedgerCddl - :: IsCardanoEra era +deserialiseTxLedgerCddl :: () => CardanoEra era -> TextEnvelopeCddl -> Either TextEnvelopeCddlError (Tx era) deserialiseTxLedgerCddl era tec = first TextEnvelopeCddlErrCBORDecodingError . deserialiseTx era $ teCddlRawCBOR tec -deserialiseTx - :: forall era. IsCardanoEra era +deserialiseTx :: () => CardanoEra era -> ByteString -> Either DecoderError (Tx era) deserialiseTx era bs = case era of - ByronEra -> ByronTx <$> CBOR.decodeFullAnnotatedBytes - CBOR.byronProtVer "Byron Tx" CBOR.decCBOR (LBS.fromStrict bs) - _ -> deserialiseFromCBOR (AsTx ttoken) bs - where - ttoken :: AsType era - ttoken = proxyToAsType Proxy + ByronEra -> + ByronTx + <$> CBOR.decodeFullAnnotatedBytes CBOR.byronProtVer "Byron Tx" CBOR.decCBOR (LBS.fromStrict bs) + _ -> cardanoEraConstraints era $ deserialiseFromCBOR (AsTx (proxyToAsType Proxy)) bs serialiseWitnessLedgerCddl :: forall era. ShelleyBasedEra era -> KeyWitness era -> TextEnvelopeCddl serialiseWitnessLedgerCddl sbe kw = @@ -216,16 +213,16 @@ deserialiseWitnessLedgerCddl sbe TextEnvelopeCddl{teCddlRawCBOR,teCddlDescriptio Right $ ShelleyKeyWitness sbe w _ -> Left TextEnvelopeCddlUnknownKeyWitness -writeTxFileTextEnvelopeCddl - :: IsCardanoEra era - => File content Out +writeTxFileTextEnvelopeCddl :: () + => CardanoEra era + -> File content Out -> Tx era -> IO (Either (FileError ()) ()) -writeTxFileTextEnvelopeCddl path tx = +writeTxFileTextEnvelopeCddl era path tx = runExceptT $ do handleIOExceptT (FileIOError (unFile path)) $ LBS.writeFile (unFile path) txJson where - txJson = encodePretty' textEnvelopeCddlJSONConfig (serialiseTxLedgerCddl tx) <> "\n" + txJson = encodePretty' textEnvelopeCddlJSONConfig (serialiseTxLedgerCddl era tx) <> "\n" writeTxWitnessFileTextEnvelopeCddl :: ShelleyBasedEra era diff --git a/cardano-api/internal/Cardano/Api/Tx.hs b/cardano-api/internal/Cardano/Api/Tx.hs index 2c1ade81cd..b469544adb 100644 --- a/cardano-api/internal/Cardano/Api/Tx.hs +++ b/cardano-api/internal/Cardano/Api/Tx.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -621,29 +622,23 @@ data WitnessNetworkIdOrByronAddress -- both the network ID and derivation path will be extracted from the -- address and used in the construction of the witness. -makeShelleyBootstrapWitness :: forall era. - IsShelleyBasedEra era - => WitnessNetworkIdOrByronAddress - -> TxBody era - -> SigningKey ByronKey - -> KeyWitness era -makeShelleyBootstrapWitness _ ByronTxBody{} _ = - case shelleyBasedEra :: ShelleyBasedEra era of {} - -makeShelleyBootstrapWitness nwOrAddr (ShelleyTxBody sbe txbody _ _ _ _) sk = - shelleyBasedEraConstraints sbe $ - makeShelleyBasedBootstrapWitness sbe nwOrAddr txbody sk - -makeShelleyBasedBootstrapWitness :: forall era. - (Ledger.HashAnnotated - (Ledger.TxBody (ShelleyLedgerEra era)) - Ledger.EraIndependentTxBody - StandardCrypto) - => ShelleyBasedEra era - -> WitnessNetworkIdOrByronAddress - -> Ledger.TxBody (ShelleyLedgerEra era) - -> SigningKey ByronKey - -> KeyWitness era +makeShelleyBootstrapWitness :: forall era. () + => ShelleyBasedEra era + -> WitnessNetworkIdOrByronAddress + -> TxBody era + -> SigningKey ByronKey + -> KeyWitness era +makeShelleyBootstrapWitness sbe nwOrAddr txBody sk = + case txBody of + ByronTxBody{} -> case sbe of {} + ShelleyTxBody _ txbody _ _ _ _ -> makeShelleyBasedBootstrapWitness sbe nwOrAddr txbody sk + +makeShelleyBasedBootstrapWitness :: forall era. () + => ShelleyBasedEra era + -> WitnessNetworkIdOrByronAddress + -> Ledger.TxBody (ShelleyLedgerEra era) + -> SigningKey ByronKey + -> KeyWitness era makeShelleyBasedBootstrapWitness sbe nwOrAddr txbody (ByronSigningKey sk) = ShelleyBootstrapWitness sbe $ -- Byron era witnesses were weird. This reveals all that weirdness. @@ -675,7 +670,7 @@ makeShelleyBasedBootstrapWitness sbe nwOrAddr txbody (ByronSigningKey sk) = (ShelleyExtendedSigningKey (Byron.unSigningKey sk)) txhash :: Shelley.Hash StandardCrypto Ledger.EraIndependentTxBody - txhash = Ledger.extractHash (Ledger.hashAnnotated txbody) + txhash = shelleyBasedEraConstraints sbe $ Ledger.extractHash (Ledger.hashAnnotated txbody) --TODO: use Shelley.eraIndTxBodyHash txbody once that function has a -- suitably general type. @@ -733,34 +728,26 @@ data ShelleyWitnessSigningKey = | WitnessCommitteeHotKey (SigningKey CommitteeHotKey) -makeShelleyKeyWitness :: forall era - . IsShelleyBasedEra era - => TxBody era - -> ShelleyWitnessSigningKey - -> KeyWitness era -makeShelleyKeyWitness (ShelleyTxBody sbe txbody _ _ _ _) = - shelleyBasedEraConstraints sbe $ makeShelleyBasedKeyWitness txbody - where - makeShelleyBasedKeyWitness :: Ledger.HashAnnotated (Ledger.TxBody (ShelleyLedgerEra era)) Ledger.EraIndependentTxBody StandardCrypto - => Ledger.TxBody (ShelleyLedgerEra era) - -> ShelleyWitnessSigningKey - -> KeyWitness era - makeShelleyBasedKeyWitness txbody' = - - let txhash :: Shelley.Hash StandardCrypto Ledger.EraIndependentTxBody - txhash = Ledger.extractHash @StandardCrypto (Ledger.hashAnnotated txbody') - - -- To allow sharing of the txhash computation across many signatures we - -- define and share the txhash outside the lambda for the signing key: - in \wsk -> - let sk = toShelleySigningKey wsk - vk = getShelleyKeyWitnessVerificationKey sk - signature = makeShelleySignature txhash sk - in ShelleyKeyWitness sbe $ - L.WitVKey vk signature - -makeShelleyKeyWitness ByronTxBody{} = - case shelleyBasedEra :: ShelleyBasedEra era of {} +makeShelleyKeyWitness :: forall era. () + => ShelleyBasedEra era + -> TxBody era + -> ShelleyWitnessSigningKey + -> KeyWitness era +makeShelleyKeyWitness sbe = \case + ShelleyTxBody _ txbody _ _ _ _ -> + shelleyBasedEraConstraints sbe $ + let txhash :: Shelley.Hash StandardCrypto Ledger.EraIndependentTxBody + txhash = Ledger.extractHash @StandardCrypto (Ledger.hashAnnotated txbody) + + -- To allow sharing of the txhash computation across many signatures we + -- define and share the txhash outside the lambda for the signing key: + in \wsk -> + let sk = toShelleySigningKey wsk + vk = getShelleyKeyWitnessVerificationKey sk + signature = makeShelleySignature txhash sk + in ShelleyKeyWitness sbe $ + L.WitVKey vk signature + ByronTxBody{} -> case sbe of {} -- | We support making key witnesses with both normal and extended signing keys. @@ -863,12 +850,13 @@ signByronTransaction nw txbody sks = witnesses = map (makeByronKeyWitness nw txbody) sks -- signing keys is a set -signShelleyTransaction :: IsShelleyBasedEra era - => TxBody era - -> [ShelleyWitnessSigningKey] - -> Tx era -signShelleyTransaction txbody sks = +signShelleyTransaction :: () + => ShelleyBasedEra era + -> TxBody era + -> [ShelleyWitnessSigningKey] + -> Tx era +signShelleyTransaction sbe txbody sks = makeSignedTransaction witnesses txbody where - witnesses = map (makeShelleyKeyWitness txbody) sks + witnesses = map (makeShelleyKeyWitness sbe txbody) sks diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index da87ed11a7..6bff16608a 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -340,8 +340,8 @@ instance Eq TxOutInAnyEra where Nothing -> False -- | Convenience constructor for 'TxOutInAnyEra' -txOutInAnyEra :: IsCardanoEra era => TxOut CtxTx era -> TxOutInAnyEra -txOutInAnyEra = TxOutInAnyEra cardanoEra +txOutInAnyEra :: CardanoEra era -> TxOut CtxTx era -> TxOutInAnyEra +txOutInAnyEra = TxOutInAnyEra toCtxUTxOTxOut :: TxOut CtxTx era -> TxOut CtxUTxO era toCtxUTxOTxOut (TxOut addr val d refS) = @@ -938,12 +938,15 @@ instance IsCardanoEra era => FromJSON (TxOutValue era) where Nothing -> fail $ "Expected a Bounded number but got: " <> show sci decodeQuantity wrong = fail $ "Expected aeson Number but got: " <> show wrong -lovelaceToTxOutValue :: IsCardanoEra era => Lovelace -> TxOutValue era -lovelaceToTxOutValue l = +lovelaceToTxOutValue :: () + => CardanoEra era + -> Lovelace + -> TxOutValue era +lovelaceToTxOutValue era l = caseByronToAllegraOrMaryEraOnwards (\w -> TxOutAdaOnly w l) (\w -> TxOutValue w (lovelaceToValue l)) - cardanoEra + era txOutValueToLovelace :: TxOutValue era -> Lovelace txOutValueToLovelace tv = @@ -1052,12 +1055,11 @@ data TxFee era where deriving instance Eq (TxFee era) deriving instance Show (TxFee era) -defaultTxFee :: forall era. IsCardanoEra era => TxFee era +defaultTxFee :: CardanoEra era -> TxFee era defaultTxFee = caseByronOrShelleyBasedEra TxFeeImplicit (\w -> TxFeeExplicit w mempty) - (cardanoEra @era) -- ---------------------------------------------------------------------------- -- Transaction validity range @@ -1078,12 +1080,13 @@ data TxValidityUpperBound era where deriving instance Eq (TxValidityUpperBound era) deriving instance Show (TxValidityUpperBound era) -defaultTxValidityUpperBound :: forall era. IsCardanoEra era => TxValidityUpperBound era +defaultTxValidityUpperBound :: () + => CardanoEra era + -> TxValidityUpperBound era defaultTxValidityUpperBound = caseByronAndAllegraEraOnwardsOrShelleyEraOnly TxValidityNoUpperBound (\w -> TxValidityUpperBound (shelleyEraOnlyToShelleyBasedEra w) maxBound) - (cardanoEra @era) data TxValidityLowerBound era where @@ -1241,16 +1244,18 @@ data TxBodyContent build era = } deriving (Eq, Show) -defaultTxBodyContent :: IsCardanoEra era => TxBodyContent BuildTx era -defaultTxBodyContent = TxBodyContent +defaultTxBodyContent :: () + => CardanoEra era + -> TxBodyContent BuildTx era +defaultTxBodyContent era = TxBodyContent { txIns = [] , txInsCollateral = TxInsCollateralNone , txInsReference = TxInsReferenceNone , txOuts = [] , txTotalCollateral = TxTotalCollateralNone , txReturnCollateral = TxReturnCollateralNone - , txFee = defaultTxFee - , txValidityRange = (TxValidityNoLowerBound, defaultTxValidityUpperBound) + , txFee = defaultTxFee era + , txValidityRange = (TxValidityNoLowerBound, defaultTxValidityUpperBound era) , txMetadata = TxMetadataNone , txAuxScripts = TxAuxScriptsNone , txExtraKeyWits = TxExtraKeyWitnessesNone @@ -2055,13 +2060,15 @@ validateTxInsCollateral txInsCollateral languages = guardShelleyTxInsOverflow collateralTxIns validateTxOuts :: ShelleyBasedEra era -> [TxOut CtxTx era] -> Either TxBodyError () -validateTxOuts era txOuts = do - let cEra = shelleyBasedToCardanoEra era - cardanoEraConstraints cEra $ - sequence_ [ do positiveOutput (txOutValueToValue v) txout - outputDoesNotExceedMax (txOutValueToValue v) txout - | txout@(TxOut _ v _ _) <- txOuts - ] +validateTxOuts sbe txOuts = do + let era = shelleyBasedToCardanoEra sbe + cardanoEraConstraints era $ + sequence_ + [ do + positiveOutput era (txOutValueToValue v) txout + outputDoesNotExceedMax era (txOutValueToValue v) txout + | txout@(TxOut _ v _ _) <- txOuts + ] validateMintValue :: TxMintValue build era -> Either TxBodyError () validateMintValue txMintValue = @@ -2075,20 +2082,25 @@ inputIndexDoesNotExceedMax txIns = for_ txIns $ \(txin@(TxIn _ (TxIx txix)), _) -> guard (fromIntegral txix <= maxShelleyTxInIx) ?! TxBodyInIxOverflow txin -outputDoesNotExceedMax - :: IsCardanoEra era => Value -> TxOut CtxTx era -> Either TxBodyError () -outputDoesNotExceedMax v txout = +outputDoesNotExceedMax :: () + => CardanoEra era + -> Value + -> TxOut CtxTx era + -> Either TxBodyError () +outputDoesNotExceedMax era v txout = case [ q | (_,q) <- valueToList v, q > maxTxOut ] of [] -> Right () - q:_ -> Left (TxBodyOutputOverflow q (txOutInAnyEra txout)) + q:_ -> Left (TxBodyOutputOverflow q (txOutInAnyEra era txout)) -positiveOutput - :: IsCardanoEra era - => Value -> TxOut CtxTx era -> Either TxBodyError () -positiveOutput v txout = - case [ q | (_, q) <- valueToList v, q < 0 ] of - [] -> Right () - q:_ -> Left (TxBodyOutputNegative q (txOutInAnyEra txout)) +positiveOutput :: () + => CardanoEra era + -> Value + -> TxOut CtxTx era + -> Either TxBodyError () +positiveOutput era v txout = + case [ q | (_, q) <- valueToList v, q < 0 ] of + [] -> Right () + q:_ -> Left (TxBodyOutputNegative q (txOutInAnyEra era txout)) txBodyContentHasTxIns :: TxIns BuildTx era -> Either TxBodyError () txBodyContentHasTxIns txIns = guard (not (null txIns)) ?! TxBodyEmptyTxIns @@ -2099,15 +2111,14 @@ maxShelleyTxInIx = fromIntegral $ maxBound @Word16 maxTxOut :: Quantity maxTxOut = fromIntegral (maxBound :: Word64) -createAndValidateTransactionBody - :: forall era. - IsCardanoEra era - => TxBodyContent BuildTx era +createAndValidateTransactionBody :: () + => CardanoEra era + -> TxBodyContent BuildTx era -> Either TxBodyError (TxBody era) -createAndValidateTransactionBody = - case cardanoEraStyle (cardanoEra :: CardanoEra era) of - LegacyByronEra -> makeByronTransactionBody - ShelleyBasedEra sbe -> makeShelleyTransactionBody sbe +createAndValidateTransactionBody era = + case cardanoEraStyle era of + LegacyByronEra -> makeByronTransactionBody + ShelleyBasedEra sbe -> makeShelleyTransactionBody sbe pattern TxBody :: TxBodyContent ViewTx era -> TxBody era pattern TxBody txbodycontent <- (getTxBodyContent -> txbodycontent) @@ -2570,10 +2581,8 @@ makeByronTransactionBody TxBodyContent { txIns, txOuts } = do classifyRangeError txout@(TxOut (AddressInEra ByronAddressInAnyEra ByronAddress{}) (TxOutAdaOnly ByronToAllegraEraByron value) _ _) - | value < 0 = TxBodyOutputNegative (lovelaceToQuantity value) - (txOutInAnyEra txout) - | otherwise = TxBodyOutputOverflow (lovelaceToQuantity value) - (txOutInAnyEra txout) + | value < 0 = TxBodyOutputNegative (lovelaceToQuantity value) (txOutInAnyEra ByronEra txout) + | otherwise = TxBodyOutputOverflow (lovelaceToQuantity value) (txOutInAnyEra ByronEra txout) classifyRangeError (TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress _)) diff --git a/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs b/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs index 45977d3561..bcdf002a7a 100644 --- a/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs +++ b/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs @@ -122,7 +122,7 @@ txout1 :: TxOut ctx AllegraEra txout1 = TxOut changeaddr1 txOutValue1 TxOutDatumNone ReferenceScriptNone txOutInAnyEra1 :: TxOutInAnyEra -txOutInAnyEra1 = txOutInAnyEra txout1 +txOutInAnyEra1 = txOutInAnyEra AllegraEra txout1 poolId :: Hash StakePoolKey poolId = fromJust $ hush $ deserialiseFromRawBytesHex (AsHash AsStakePoolKey) diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs index ad5544d877..511306e998 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs @@ -32,19 +32,19 @@ prop_roundtrip_txbody_CBOR :: Property prop_roundtrip_txbody_CBOR = H.property $ do AnyCardanoEra era <- H.forAll $ Gen.element [minBound..AnyCardanoEra BabbageEra] x <- H.forAll $ makeSignedTransaction [] <$> genTxBody era - H.tripping x serialiseTxLedgerCddl (deserialiseTxLedgerCddl era) + H.tripping x (serialiseTxLedgerCddl era) (deserialiseTxLedgerCddl era) prop_roundtrip_tx_CBOR :: Property prop_roundtrip_tx_CBOR = H.property $ do AnyCardanoEra era <- H.forAll $ Gen.element [minBound..AnyCardanoEra BabbageEra] x <- H.forAll $ genTx era - H.trippingCbor (proxyToAsType Proxy) x + cardanoEraConstraints era $ H.trippingCbor (proxyToAsType Proxy) x prop_roundtrip_witness_CBOR :: Property prop_roundtrip_witness_CBOR = H.property $ do AnyCardanoEra era <- H.forAll $ Gen.element [minBound..maxBound] x <- H.forAll $ genCardanoKeyWitness era - H.trippingCbor (AsKeyWitness (proxyToAsType Proxy)) x + cardanoEraConstraints era $ H.trippingCbor (AsKeyWitness (proxyToAsType Proxy)) x prop_roundtrip_operational_certificate_CBOR :: Property prop_roundtrip_operational_certificate_CBOR = H.property $ do @@ -171,12 +171,12 @@ prop_roundtrip_Tx_Cddl :: Property prop_roundtrip_Tx_Cddl = H.property $ do AnyCardanoEra era <- H.forAll $ Gen.element [minBound..maxBound] x <- forAll $ genTx era - H.tripping x serialiseTxLedgerCddl (deserialiseTxLedgerCddl era) + H.tripping x (serialiseTxLedgerCddl era) (deserialiseTxLedgerCddl era) prop_roundtrip_TxWitness_Cddl :: Property prop_roundtrip_TxWitness_Cddl = H.property $ do AnyShelleyBasedEra sbe <- H.forAll $ Gen.element [minBound..maxBound] - x <- forAll $ genShelleyKeyWitness $ shelleyBasedToCardanoEra sbe + x <- forAll $ genShelleyKeyWitness sbe tripping x (serialiseWitnessLedgerCddl sbe) (deserialiseWitnessLedgerCddl sbe) prop_roundtrip_GovernancePoll_CBOR :: Property diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Ord.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Ord.hs index 8a780268f5..5a5bb95d8a 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Ord.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/Ord.hs @@ -38,7 +38,7 @@ prop_ord_distributive_Address = ord_distributive genAddressShelley (toShelleyAddr . toAddressInAnyEra) where toAddressInAnyEra :: Address ShelleyAddr -> AddressInEra ShelleyEra - toAddressInAnyEra = anyAddressInShelleyBasedEra . toAddressAny + toAddressInAnyEra = anyAddressInShelleyBasedEra ShelleyBasedEraShelley . toAddressAny prop_ord_distributive_StakeAddress :: Property prop_ord_distributive_StakeAddress = diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs index 6261216b76..5474c45b99 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs @@ -25,9 +25,10 @@ import Test.Tasty.Hedgehog (testProperty) prop_roundtrip_txbodycontent_txouts:: Property prop_roundtrip_txbodycontent_txouts = H.property $ do - content <- H.forAll $ genTxBodyContent BabbageEra + let era = BabbageEra + content <- H.forAll $ genTxBodyContent era -- Create the ledger body & auxiliaries - body <- case createAndValidateTransactionBody content of + body <- case createAndValidateTransactionBody era content of Left err -> annotateShow err >> failure Right body -> pure body annotateShow body