diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 6e614e7983..f25aaf7038 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -245,6 +245,7 @@ library gen hs-source-dirs: gen exposed-modules: Test.Gen.Cardano.Api + Test.Gen.Cardano.Api.Byron Test.Gen.Cardano.Api.Era Test.Gen.Cardano.Api.Metadata Test.Gen.Cardano.Api.Typed diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Byron.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Byron.hs new file mode 100644 index 0000000000..80db9b0e04 --- /dev/null +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Byron.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} + +module Test.Gen.Cardano.Api.Byron + ( tests + ) where + +import Cardano.Api hiding (txIns) + +import Data.Proxy + +import Test.Gen.Cardano.Api.Typed + +import Hedgehog +import Test.Hedgehog.Roundtrip.CBOR +import Test.Tasty +import Test.Tasty.Hedgehog + +prop_byron_roundtrip_txbody_CBOR :: Property +prop_byron_roundtrip_txbody_CBOR = property $ do + let byron = ByronEra + x <- forAll $ makeSignedTransaction [] <$> genTxBodyByron + tripping x (serialiseTxLedgerCddl byron) (deserialiseTxLedgerCddl byron) + + +prop_byron_roundtrip_tx_CBOR :: Property +prop_byron_roundtrip_tx_CBOR = property $ do + let byron = ByronEra + x <- forAll genTxByron + cardanoEraConstraints byron $ trippingCbor (proxyToAsType Proxy) x + + +prop_byron_roundtrip_witness_CBOR :: Property +prop_byron_roundtrip_witness_CBOR = property $ do + let byron = ByronEra + x <- forAll genByronKeyWitness + cardanoEraConstraints byron $ trippingCbor (AsKeyWitness (proxyToAsType Proxy)) x + + +prop_byron_roundtrip_Tx_Cddl :: Property +prop_byron_roundtrip_Tx_Cddl = property $ do + let byron = ByronEra + x <- forAll genTxByron + tripping x (serialiseTxLedgerCddl byron) (deserialiseTxLedgerCddl byron) + +tests :: TestTree +tests = testGroup "Test.Gen.Cardano.Api.Byron" + [ testProperty "Byron roundtrip txbody CBOR" prop_byron_roundtrip_txbody_CBOR + , testProperty "Byron roundtrip tx certificate CBOR" prop_byron_roundtrip_tx_CBOR + , testProperty "Byron roundtrip witness CBOR" prop_byron_roundtrip_witness_CBOR + , testProperty "Byron roundtrip tx CBOR" prop_byron_roundtrip_Tx_Cddl + ] + diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 0dea0ee6ac..e76fc3a277 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -15,7 +15,13 @@ module Test.Gen.Cardano.Api.Typed ( genFeaturedInEra , genMaybeFeaturedInEra + -- * Byron + , genAddressInEraByron , genAddressByron + , genTxBodyByron + , genTxByron + , genWitnessesByron + , genAddressInEra , genAddressShelley , genCertificate @@ -130,11 +136,12 @@ import Cardano.Api hiding (txIns) import qualified Cardano.Api as Api import Cardano.Api.Byron (KeyWitness (ByronKeyWitness), WitnessNetworkIdOrByronAddress (..)) -import Cardano.Api.Governance.Actions.VotingProcedure -import Cardano.Api.Script (scriptInEraToRefScript) -import Cardano.Api.Shelley +import Cardano.Api.Eon.AllegraEraOnwards (allegraEraOnwardsToShelleyBasedEra) import qualified Cardano.Api.Ledger as L import qualified Cardano.Api.Ledger.Lens as A +import Cardano.Api.Script (scriptInEraToRefScript) +import Cardano.Api.Shelley +import qualified Cardano.Api.Shelley as ShelleyApi import qualified Cardano.Binary as CBOR import qualified Cardano.Crypto.Hash as Crypto @@ -181,16 +188,11 @@ genAddressShelley = makeShelleyAddress <$> genNetworkId <*> genPaymentCredential <*> genStakeAddressReference -genAddressInEra :: CardanoEra era -> Gen (AddressInEra era) -genAddressInEra = - inEonForEra - (byronAddressInEra <$> genAddressByron) - (\sbe -> - Gen.choice - [ byronAddressInEra <$> genAddressByron - , shelleyAddressInEra sbe <$> genAddressShelley - ] - ) +genAddressInEra :: ShelleyBasedEra era -> Gen (AddressInEra era) +genAddressInEra sbe = shelleyAddressInEra sbe <$> genAddressShelley + +_genAddressInEraByron :: Gen (AddressInEra era) +_genAddressInEraByron = byronAddressInEra <$> genAddressByron genKESPeriod :: Gen KESPeriod genKESPeriod = KESPeriod <$> Gen.word Range.constantBounded @@ -305,12 +307,13 @@ genScriptInAnyLang = [ ScriptInAnyLang lang <$> genScript lang | AnyScriptLanguage lang <- [minBound..maxBound] ] -genScriptInEra :: CardanoEra era -> Gen (ScriptInEra era) +genScriptInEra :: ShelleyBasedEra era -> Gen (ScriptInEra era) genScriptInEra era = Gen.choice [ ScriptInEra langInEra <$> genScript lang | AnyScriptLanguage lang <- [minBound..maxBound] - , Just langInEra <- [scriptLanguageSupportedInEra era lang] ] + -- TODO: scriptLanguageSupportedInEra should be parameterized on ShelleyBasedEra + , Just langInEra <- [scriptLanguageSupportedInEra (toCardanoEra era) lang] ] genScriptHash :: Gen ScriptHash genScriptHash = do @@ -463,7 +466,7 @@ genPaymentCredential = do vKey <- genVerificationKey AsPaymentKey return . PaymentCredentialByKey $ verificationKeyHash vKey -genSigningKey :: Key keyrole => AsType keyrole -> Gen (SigningKey keyrole) +genSigningKey :: Key keyrole => ShelleyApi.AsType keyrole -> Gen (SigningKey keyrole) genSigningKey roletoken = do seed <- genSeed (fromIntegral seedSize) let sk = deterministicSigningKey roletoken seed @@ -504,34 +507,27 @@ genTxId = TxId <$> genShelleyHash genTxIndex :: Gen TxIx genTxIndex = TxIx . fromIntegral <$> Gen.word16 Range.constantBounded -genTxOutValue :: CardanoEra era -> Gen (TxOutValue era) -genTxOutValue = - caseByronOrShelleyBasedEra - (\w -> TxOutValueByron w <$> genPositiveLovelace) - (\sbe -> TxOutValueShelleyBased sbe <$> genValueForTxOut sbe) +genTxOutValue :: ShelleyBasedEra era -> Gen (TxOutValue era) +genTxOutValue sbe = shelleyBasedEraConstraints sbe $ TxOutValueShelleyBased sbe <$> genValueForTxOut sbe -genTxOutTxContext :: CardanoEra era -> Gen (TxOut CtxTx era) +genTxOutTxContext :: ShelleyBasedEra era -> Gen (TxOut CtxTx era) genTxOutTxContext era = TxOut <$> genAddressInEra era <*> genTxOutValue era <*> genTxOutDatumHashTxContext era <*> genReferenceScript era -genTxOutUTxOContext :: CardanoEra era -> Gen (TxOut CtxUTxO era) +genTxOutUTxOContext :: ShelleyBasedEra era -> Gen (TxOut CtxUTxO era) genTxOutUTxOContext era = TxOut <$> genAddressInEra era <*> genTxOutValue era <*> genTxOutDatumHashUTxOContext era <*> genReferenceScript era -genReferenceScript :: CardanoEra era -> Gen (ReferenceScript era) -genReferenceScript era = - caseByronToAlonzoOrBabbageEraOnwards - (const (return ReferenceScriptNone)) - (const (scriptInEraToRefScript <$> genScriptInEra era)) - era +genReferenceScript :: ShelleyBasedEra era -> Gen (ReferenceScript era) +genReferenceScript era = scriptInEraToRefScript <$> genScriptInEra era -genUTxO :: CardanoEra era -> Gen (UTxO era) +genUTxO :: ShelleyBasedEra era -> Gen (UTxO era) genUTxO era = UTxO <$> Gen.map (Range.constant 0 5) ((,) <$> genTxIn <*> (toCtxUTxOTxOut <$> genTxOutTxContext era)) @@ -566,11 +562,12 @@ genTxMetadataInEra = ] ) -genTxAuxScripts :: CardanoEra era -> Gen (TxAuxScripts era) +genTxAuxScripts :: ShelleyBasedEra era -> Gen (TxAuxScripts era) genTxAuxScripts era = - forEraInEon era + forEraInEon (toCardanoEra era) (pure TxAuxScriptsNone) - (\w -> TxAuxScripts w <$> Gen.list (Range.linear 0 3) (genScriptInEra era)) + (\w -> TxAuxScripts w <$> Gen.list (Range.linear 0 3) + (genScriptInEra (allegraEraOnwardsToShelleyBasedEra w))) genTxWithdrawals :: CardanoEra era -> Gen (TxWithdrawals BuildTx era) genTxWithdrawals = @@ -635,19 +632,20 @@ genTxMintValue = ] ) -genTxBodyContent :: CardanoEra era -> Gen (TxBodyContent BuildTx era) -genTxBodyContent era = do +genTxBodyContent :: ShelleyBasedEra era -> Gen (TxBodyContent BuildTx era) +genTxBodyContent sbe = do + let era = shelleyBasedToCardanoEra sbe txIns <- map (, BuildTxWith (KeyWitness KeyWitnessForSpending)) <$> Gen.list (Range.constant 1 10) genTxIn txInsCollateral <- genTxInsCollateral era txInsReference <- genTxInsReference era - txOuts <- Gen.list (Range.constant 1 10) (genTxOutTxContext era) + txOuts <- Gen.list (Range.constant 1 10) (genTxOutTxContext sbe) txTotalCollateral <- genTxTotalCollateral era - txReturnCollateral <- genTxReturnCollateral era + txReturnCollateral <- genTxReturnCollateral sbe txFee <- genTxFee era txValidityLowerBound <- genTxValidityLowerBound era txValidityUpperBound <- genTxValidityUpperBound era txMetadata <- genTxMetadataInEra era - txAuxScripts <- genTxAuxScripts era + txAuxScripts <- genTxAuxScripts sbe let txExtraKeyWits = TxExtraKeyWitnessesNone --TODO: Alonzo era: Generate witness key hashes txProtocolParams <- BuildTxWith <$> forEraInEon era (pure Nothing) (Gen.maybe . genValidProtocolParameters) txWithdrawals <- genTxWithdrawals era @@ -680,6 +678,7 @@ genTxBodyContent era = do , Api.txVotingProcedures } + genTxInsCollateral :: CardanoEra era -> Gen (TxInsCollateral era) genTxInsCollateral = inEonForEra @@ -696,9 +695,9 @@ genTxInsReference = (const (pure TxInsReferenceNone)) (\w -> TxInsReference w <$> Gen.list (Range.linear 0 10) genTxIn) -genTxReturnCollateral :: CardanoEra era -> Gen (TxReturnCollateral CtxTx era) +genTxReturnCollateral :: ShelleyBasedEra era -> Gen (TxReturnCollateral CtxTx era) genTxReturnCollateral era = - forEraInEon era + forEraInEon (toCardanoEra era) (pure TxReturnCollateralNone) (\w -> TxReturnCollateral w <$> genTxOutTxContext era) @@ -714,9 +713,43 @@ genTxFee = (pure . TxFeeImplicit) (\w -> TxFeeExplicit w <$> genLovelace) -genTxBody :: CardanoEra era -> Gen (TxBody era) +genAddressInEraByron :: Gen (AddressInEra ByronEra) +genAddressInEraByron = byronAddressInEra <$> genAddressByron + +genTxByron :: Gen (Tx ByronEra) +genTxByron = + makeSignedTransaction + <$> genWitnessesByron + <*> genTxBodyByron + +genTxOutValueByron :: Gen (TxOutValue ByronEra) +genTxOutValueByron = TxOutValueByron <$> genPositiveLovelace + +genTxOutByron :: Gen (TxOut CtxTx ByronEra) +genTxOutByron = + TxOut <$> genAddressInEraByron + <*> genTxOutValueByron + <*> pure TxOutDatumNone + <*> pure ReferenceScriptNone + +genTxBodyByron :: Gen (TxBody ByronEra) +genTxBodyByron = do + txIns <- map (, BuildTxWith (KeyWitness KeyWitnessForSpending)) <$> Gen.list (Range.constant 1 10) genTxIn + txOuts <- Gen.list (Range.constant 1 10) genTxOutByron + let byronTxBodyContent = (defaultTxBodyContent ByronEra) + { Api.txIns + , Api.txOuts + } + case Api.createAndValidateTransactionBody ByronEra byronTxBodyContent of + Left err -> fail (displayError err) + Right txBody -> pure txBody + +genWitnessesByron :: Gen [KeyWitness ByronEra] +genWitnessesByron = Gen.list (Range.constant 1 10) genByronKeyWitness + +genTxBody :: ShelleyBasedEra era -> Gen (TxBody era) genTxBody era = do - res <- Api.createAndValidateTransactionBody era <$> genTxBodyContent era + res <- Api.createAndValidateTransactionBody (toCardanoEra era) <$> genTxBodyContent era case res of Left err -> fail (displayError err) Right txBody -> pure txBody @@ -751,22 +784,19 @@ genScriptValidity :: Gen ScriptValidity genScriptValidity = Gen.element [ScriptInvalid, ScriptValid] genTx :: () - => CardanoEra era + => ShelleyBasedEra era -> Gen (Tx era) genTx era = makeSignedTransaction <$> genWitnesses era <*> genTxBody era -genWitnesses :: CardanoEra era -> Gen [KeyWitness era] -genWitnesses = - caseByronOrShelleyBasedEra - (Gen.list (Range.constant 1 10) . genByronKeyWitness) - (\sbe -> do - bsWits <- Gen.list (Range.constant 0 10) (genShelleyBootstrapWitness sbe) - keyWits <- Gen.list (Range.constant 0 10) (genShelleyKeyWitness sbe) - return $ bsWits ++ keyWits - ) +genWitnesses :: ShelleyBasedEra era -> Gen [KeyWitness era] +genWitnesses sbe = do + bsWits <- Gen.list (Range.constant 0 10) (genShelleyBootstrapWitness sbe) + keyWits <- Gen.list (Range.constant 0 10) (genShelleyKeyWitness sbe) + return $ bsWits ++ keyWits + genVerificationKey :: () #if MIN_VERSION_base(4,17,0) @@ -775,7 +805,7 @@ genVerificationKey :: () => HasTypeProxy keyrole #endif => Key keyrole - => AsType keyrole + => ShelleyApi.AsType keyrole -> Gen (VerificationKey keyrole) genVerificationKey roletoken = getVerificationKey <$> genSigningKey roletoken @@ -786,13 +816,13 @@ genVerificationKeyHash :: () => HasTypeProxy keyrole #endif => Key keyrole - => AsType keyrole + => ShelleyApi.AsType keyrole -> Gen (Hash keyrole) genVerificationKeyHash roletoken = verificationKeyHash <$> genVerificationKey roletoken -genByronKeyWitness :: ByronEraOnly era -> Gen (KeyWitness era) -genByronKeyWitness ByronEraOnlyByron = do +genByronKeyWitness :: Gen (KeyWitness ByronEra) +genByronKeyWitness = do pmId <- genProtocolMagicId txinWitness <- genVKWitness pmId return $ ByronKeyWitness txinWitness @@ -810,7 +840,7 @@ genShelleyBootstrapWitness :: () genShelleyBootstrapWitness sbe = makeShelleyBootstrapWitness sbe <$> genWitnessNetworkIdOrByronAddress - <*> genTxBody (shelleyBasedToCardanoEra sbe) + <*> genTxBody sbe <*> genSigningKey AsByronKey genShelleyKeyWitness :: () @@ -818,7 +848,7 @@ genShelleyKeyWitness :: () -> Gen (KeyWitness era) genShelleyKeyWitness sbe = makeShelleyKeyWitness sbe - <$> genTxBody (shelleyBasedToCardanoEra sbe) + <$> genTxBody sbe <*> genShelleyWitnessSigningKey genShelleyWitness :: () @@ -841,9 +871,9 @@ genShelleyWitnessSigningKey = ] genCardanoKeyWitness :: () - => CardanoEra era + => ShelleyBasedEra era -> Gen (KeyWitness era) -genCardanoKeyWitness = caseByronOrShelleyBasedEra genByronKeyWitness genShelleyWitness +genCardanoKeyWitness = genShelleyWitness genSeed :: Int -> Gen Crypto.Seed genSeed n = Crypto.mkSeedFromBytes <$> Gen.bytes (Range.singleton n) @@ -974,50 +1004,54 @@ genExecutionUnits = ExecutionUnits <$> Gen.integral (Range.constant 0 1000) genExecutionUnitPrices :: Gen ExecutionUnitPrices genExecutionUnitPrices = ExecutionUnitPrices <$> genRational <*> genRational -genTxOutDatumHashTxContext :: CardanoEra era -> Gen (TxOutDatum CtxTx era) +genTxOutDatumHashTxContext :: ShelleyBasedEra era -> Gen (TxOutDatum CtxTx era) genTxOutDatumHashTxContext era = case era of - ByronEra -> pure TxOutDatumNone - ShelleyEra -> pure TxOutDatumNone - AllegraEra -> pure TxOutDatumNone - MaryEra -> pure TxOutDatumNone - AlonzoEra -> Gen.choice - [ pure TxOutDatumNone - , TxOutDatumHash AlonzoEraOnwardsAlonzo <$> genHashScriptData - , TxOutDatumInTx AlonzoEraOnwardsAlonzo <$> genHashableScriptData - ] - BabbageEra -> Gen.choice - [ pure TxOutDatumNone - , TxOutDatumHash AlonzoEraOnwardsBabbage <$> genHashScriptData - , TxOutDatumInTx AlonzoEraOnwardsBabbage <$> genHashableScriptData - , TxOutDatumInline BabbageEraOnwardsBabbage <$> genHashableScriptData - ] - ConwayEra -> Gen.choice - [ pure TxOutDatumNone - , TxOutDatumHash AlonzoEraOnwardsConway <$> genHashScriptData - , TxOutDatumInTx AlonzoEraOnwardsConway <$> genHashableScriptData - , TxOutDatumInline BabbageEraOnwardsConway <$> genHashableScriptData - ] - -genTxOutDatumHashUTxOContext :: CardanoEra era -> Gen (TxOutDatum CtxUTxO era) + ShelleyBasedEraShelley -> pure TxOutDatumNone + ShelleyBasedEraAllegra -> pure TxOutDatumNone + ShelleyBasedEraMary -> pure TxOutDatumNone + ShelleyBasedEraAlonzo -> + Gen.choice + [ pure TxOutDatumNone + , TxOutDatumHash AlonzoEraOnwardsAlonzo <$> genHashScriptData + , TxOutDatumInTx AlonzoEraOnwardsAlonzo <$> genHashableScriptData + ] + ShelleyBasedEraBabbage -> + Gen.choice + [ pure TxOutDatumNone + , TxOutDatumHash AlonzoEraOnwardsBabbage <$> genHashScriptData + , TxOutDatumInTx AlonzoEraOnwardsBabbage <$> genHashableScriptData + , TxOutDatumInline BabbageEraOnwardsBabbage <$> genHashableScriptData + ] + ShelleyBasedEraConway -> + Gen.choice + [ pure TxOutDatumNone + , TxOutDatumHash AlonzoEraOnwardsConway <$> genHashScriptData + , TxOutDatumInTx AlonzoEraOnwardsConway <$> genHashableScriptData + , TxOutDatumInline BabbageEraOnwardsConway <$> genHashableScriptData + ] + +genTxOutDatumHashUTxOContext :: ShelleyBasedEra era -> Gen (TxOutDatum CtxUTxO era) genTxOutDatumHashUTxOContext era = case era of - ByronEra -> pure TxOutDatumNone - ShelleyEra -> pure TxOutDatumNone - AllegraEra -> pure TxOutDatumNone - MaryEra -> pure TxOutDatumNone - AlonzoEra -> Gen.choice - [ pure TxOutDatumNone - , TxOutDatumHash AlonzoEraOnwardsAlonzo <$> genHashScriptData - ] - BabbageEra -> Gen.choice - [ pure TxOutDatumNone - , TxOutDatumHash AlonzoEraOnwardsBabbage <$> genHashScriptData - , TxOutDatumInline BabbageEraOnwardsBabbage <$> genHashableScriptData - ] - ConwayEra -> Gen.choice - [ pure TxOutDatumNone - , TxOutDatumHash AlonzoEraOnwardsConway <$> genHashScriptData - , TxOutDatumInline BabbageEraOnwardsConway <$> genHashableScriptData - ] + ShelleyBasedEraShelley -> pure TxOutDatumNone + ShelleyBasedEraAllegra -> pure TxOutDatumNone + ShelleyBasedEraMary -> pure TxOutDatumNone + ShelleyBasedEraAlonzo -> + Gen.choice + [ pure TxOutDatumNone + , TxOutDatumHash AlonzoEraOnwardsAlonzo <$> genHashScriptData + ] + ShelleyBasedEraBabbage -> + Gen.choice + [ pure TxOutDatumNone + , TxOutDatumHash AlonzoEraOnwardsBabbage <$> genHashScriptData + , TxOutDatumInline BabbageEraOnwardsBabbage <$> genHashableScriptData + ] + ShelleyBasedEraConway -> + Gen.choice + [ pure TxOutDatumNone + , TxOutDatumHash AlonzoEraOnwardsConway <$> genHashScriptData + , TxOutDatumInline BabbageEraOnwardsConway <$> genHashableScriptData + ] mkDummyHash :: forall h a. CRYPTO.HashAlgorithm h => Int -> CRYPTO.Hash h a mkDummyHash = coerce . CRYPTO.hashWithSerialiser @h CBOR.toCBOR @@ -1051,7 +1085,7 @@ genProposal :: ConwayEraOnwards era -> Gen (Proposal era) genProposal w = conwayEraOnwardsTestConstraints w $ fmap Proposal Q.arbitrary -genVotingProcedures :: ConwayEraOnwards era -> Gen (VotingProcedures era) +genVotingProcedures :: ConwayEraOnwards era -> Gen (ShelleyApi.VotingProcedures era) genVotingProcedures w = conwayEraOnwardsConstraints w - $ VotingProcedures <$> Q.arbitrary + $ ShelleyApi.VotingProcedures <$> Q.arbitrary diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index 26fa68e9e2..441e519adf 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -9,8 +9,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} @@ -92,7 +90,7 @@ import Data.Ratio import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Text as Text -import Lens.Micro ((^.), (.~)) +import Lens.Micro ((.~), (^.)) import Prettyprinter import Prettyprinter.Render.String @@ -776,7 +774,7 @@ makeTransactionBodyAutoBalance sbe systemstart history lpp@(LedgerProtocolParame txbody0 <- first TxBodyError $ createAndValidateTransactionBody era txbodycontent { txOuts = txOuts txbodycontent ++ - [TxOut changeaddr (lovelaceToTxOutValue era 0) TxOutDatumNone ReferenceScriptNone] + [TxOut changeaddr (lovelaceToTxOutValue sbe 0) TxOutDatumNone ReferenceScriptNone] --TODO: think about the size of the change output -- 1,2,4 or 8 bytes? } @@ -820,7 +818,7 @@ makeTransactionBodyAutoBalance sbe systemstart history lpp@(LedgerProtocolParame let change = mconcat [incoming, minted, negateLedgerValue sbe outgoing] let changeWithMaxLovelace = change & A.adaAssetL sbe .~ lovelaceToCoin maxLovelaceChange let changeTxOut = forShelleyBasedEraInEon sbe - (lovelaceToTxOutValue era maxLovelaceChange) + (lovelaceToTxOutValue sbe maxLovelaceChange) (\w -> maryEraOnwardsConstraints w $ TxOutValueShelleyBased sbe changeWithMaxLovelace) let (dummyCollRet, dummyTotColl) = maybeDummyTotalCollAndCollReturnOutput txbodycontent changeaddr @@ -902,7 +900,7 @@ makeTransactionBodyAutoBalance sbe systemstart history lpp@(LedgerProtocolParame let dummyRetCol = TxReturnCollateral w ( TxOut cAddr - (lovelaceToTxOutValue era $ Lovelace (2^(64 :: Integer)) - 1) + (lovelaceToTxOutValue sbe $ Lovelace (2^(64 :: Integer)) - 1) TxOutDatumNone ReferenceScriptNone ) dummyTotCol = TxTotalCollateral w (Lovelace (2^(32 :: Integer) - 1)) @@ -963,7 +961,7 @@ makeTransactionBodyAutoBalance sbe systemstart history lpp@(LedgerProtocolParame then ( TxReturnCollateral retColSup - (TxOut cAddr (lovelaceToTxOutValue era returnCollateral) TxOutDatumNone ReferenceScriptNone) + (TxOut cAddr (lovelaceToTxOutValue sbe returnCollateral) TxOutDatumNone ReferenceScriptNone) , totalCollateral ) else (TxReturnCollateralNone, TxTotalCollateralNone) diff --git a/cardano-api/internal/Cardano/Api/InMode.hs b/cardano-api/internal/Cardano/Api/InMode.hs index d37d0dc035..499cfe2213 100644 --- a/cardano-api/internal/Cardano/Api/InMode.hs +++ b/cardano-api/internal/Cardano/Api/InMode.hs @@ -69,8 +69,7 @@ data TxInMode where -- delegation certs. -- TxInByronSpecial - :: ByronEraOnly era - -> Consensus.GenTx Consensus.ByronBlock + :: Consensus.GenTx Consensus.ByronBlock -> TxInMode deriving instance Show TxInMode @@ -81,7 +80,7 @@ fromConsensusGenTx :: () -> TxInMode fromConsensusGenTx = \case Consensus.HardForkGenTx (Consensus.OneEraGenTx (Z tx')) -> - TxInByronSpecial ByronEraOnlyByron tx' + TxInByronSpecial tx' Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (Z tx'))) -> let Consensus.ShelleyTx _txid shelleyEraTx = tx' in TxInMode ShelleyEra (ShelleyTx ShelleyBasedEraShelley shelleyEraTx) @@ -113,7 +112,7 @@ toConsensusGenTx (TxInMode w (ByronTx ByronEraOnlyByron tx)) = --TODO: add the above as mkByronTx to the consensus code, -- matching mkShelleyTx below -toConsensusGenTx (TxInByronSpecial ByronEraOnlyByron gtx) = +toConsensusGenTx (TxInByronSpecial gtx) = Consensus.HardForkGenTx (Consensus.OneEraGenTx (Z gtx)) toConsensusGenTx (TxInMode ShelleyEra (ShelleyTx _ tx)) = diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index e69ea2322a..f6e8e07252 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE EmptyCase #-} @@ -159,6 +158,7 @@ import Cardano.Api.Eon.ByronEraOnly import Cardano.Api.Eon.ConwayEraOnwards import Cardano.Api.Eon.MaryEraOnwards import Cardano.Api.Eon.ShelleyBasedEra +import Cardano.Api.Eon.ShelleyToAllegraEra import Cardano.Api.Eon.ShelleyToBabbageEra import Cardano.Api.Eras.Case import Cardano.Api.Eras.Core @@ -678,13 +678,13 @@ fromByronTxOut :: ByronEraOnly era -> Byron.TxOut -> TxOut ctx era fromByronTxOut ByronEraOnlyByron (Byron.TxOut addr value) = TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress addr)) - (TxOutValueByron ByronEraOnlyByron (fromByronLovelace value)) + (TxOutValueByron (fromByronLovelace value)) TxOutDatumNone ReferenceScriptNone toByronTxOut :: ByronEraOnly era -> TxOut ctx era -> Maybe Byron.TxOut toByronTxOut ByronEraOnlyByron = \case - TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress addr)) (TxOutValueByron _ value) _ _ -> + TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress addr)) (TxOutValueByron value) _ _ -> Byron.TxOut addr <$> toByronLovelace value TxOut (AddressInEra ByronAddressInAnyEra (ByronAddress _)) (TxOutValueShelleyBased w _) _ _ -> case w of {} @@ -698,8 +698,10 @@ toShelleyTxOut :: forall era ledgerera. -> TxOut CtxUTxO era -> Ledger.TxOut ledgerera toShelleyTxOut sbe = \case -- jky simplify - TxOut _ (TxOutValueByron ByronEraOnlyByron _) _ _ -> - case sbe of {} + TxOut _ (TxOutValueByron _) _ _ -> + -- TODO: Temporary until we have basic tx + -- construction functionality + error "toShelleyTxOut: Expected a Shelley value" TxOut addr (TxOutValueShelleyBased _ value) txoutdata refScript -> let cEra = shelleyBasedToCardanoEra sbe in @@ -838,8 +840,7 @@ deriving instance Show (TxInsReference build era) data TxOutValue era where TxOutValueByron - :: ByronEraOnly era - -> Lovelace + :: Lovelace -> TxOutValue era TxOutValueShelleyBased @@ -855,34 +856,30 @@ deriving instance Show (TxOutValue era) instance IsCardanoEra era => ToJSON (TxOutValue era) where toJSON = \case - TxOutValueByron _ ll -> + TxOutValueByron ll -> toJSON ll TxOutValueShelleyBased sbe val -> shelleyBasedEraConstraints sbe $ toJSON (fromLedgerValue sbe val) -instance IsCardanoEra era => FromJSON (TxOutValue era) where +instance IsShelleyBasedEra era => FromJSON (TxOutValue era) where parseJSON = withObject "TxOutValue" $ \o -> - caseByronOrShelleyBasedEra - (\bo -> do + caseShelleyToAllegraOrMaryEraOnwards + (\shelleyToAlleg -> do ll <- o .: "lovelace" - pure $ TxOutValueByron bo $ selectLovelace ll + pure + $ shelleyBasedEraConstraints (shelleyToAllegraEraToShelleyBasedEra shelleyToAlleg) + $ TxOutValueShelleyBased (shelleyToAllegraEraToShelleyBasedEra shelleyToAlleg) + $ A.mkAdaValue (shelleyToAllegraEraToShelleyBasedEra shelleyToAlleg) $ lovelaceToCoin ll ) - (\sbe -> - caseShelleyToAllegraOrMaryEraOnwards - (const $ do - ll <- o .: "lovelace" - pure - $ TxOutValueShelleyBased sbe - $ A.mkAdaValue sbe $ lovelaceToCoin ll - ) - (\w -> do - let l = KeyMap.toList o - vals <- mapM decodeAssetId l - pure $ TxOutValueShelleyBased sbe $ toLedgerValue w $ mconcat vals - ) - sbe + (\w -> do + let l = KeyMap.toList o + vals <- mapM decodeAssetId l + pure $ shelleyBasedEraConstraints (maryEraOnwardsToShelleyBasedEra w) + $ TxOutValueShelleyBased (maryEraOnwardsToShelleyBasedEra w) + $ toLedgerValue w $ mconcat vals ) - cardanoEra + (shelleyBasedEra @era) + where decodeAssetId :: (Aeson.Key, Aeson.Value) -> Aeson.Parser Value decodeAssetId (polid, Aeson.Object assetNameHm) = do @@ -914,26 +911,28 @@ 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 :: () - => CardanoEra era + => ShelleyBasedEra era -> Lovelace -> TxOutValue era lovelaceToTxOutValue era ll = - caseByronOrShelleyBasedEra - (\w -> TxOutValueByron w ll) - (\w -> TxOutValueShelleyBased w $ A.mkAdaValue w $ lovelaceToCoin ll) - era + shelleyBasedEraConstraints era + $ TxOutValueShelleyBased era + $ A.mkAdaValue era + $ lovelaceToCoin ll + txOutValueToLovelace :: TxOutValue era -> Lovelace txOutValueToLovelace tv = case tv of - TxOutValueByron _ l -> l + TxOutValueByron l -> l TxOutValueShelleyBased sbe v -> coinToLovelace $ v ^. A.adaAssetL sbe txOutValueToValue :: TxOutValue era -> Value txOutValueToValue tv = case tv of - TxOutValueByron _ l -> lovelaceToValue l + TxOutValueByron l -> lovelaceToValue l TxOutValueShelleyBased sbe v -> fromLedgerValue sbe v prettyRenderTxOut :: TxOutInAnyEra -> Text @@ -2010,8 +2009,11 @@ createAndValidateTransactionBody :: () => CardanoEra era -> TxBodyContent BuildTx era -> Either TxBodyError (TxBody era) -createAndValidateTransactionBody = - caseByronOrShelleyBasedEra makeByronTransactionBody makeShelleyTransactionBody +createAndValidateTransactionBody era txBodyContent = + caseByronOrShelleyBasedEra + (\eon -> makeByronTransactionBody eon (txIns txBodyContent) (txOuts txBodyContent)) + (\eon -> makeShelleyTransactionBody eon txBodyContent) + era pattern TxBody :: TxBodyContent ViewTx era -> TxBody era pattern TxBody txbodycontent <- (getTxBodyContent -> txbodycontent) @@ -2399,9 +2401,10 @@ fromLedgerTxMintValue sbe body = makeByronTransactionBody :: () => ByronEraOnly era - -> TxBodyContent BuildTx era + -> TxIns BuildTx era + -> [TxOut CtxTx era] -> Either TxBodyError (TxBody era) -makeByronTransactionBody eon TxBodyContent { txIns, txOuts } = do +makeByronTransactionBody eon txIns txOuts = do ins' <- NonEmpty.nonEmpty (map fst txIns) ?! TxBodyEmptyTxIns for_ ins' $ \txin@(TxIn _ (TxIx txix)) -> guard (fromIntegral txix <= maxByronTxInIx) ?! TxBodyInIxOverflow txin @@ -2424,7 +2427,7 @@ makeByronTransactionBody eon TxBodyContent { txIns, txOuts } = do classifyRangeError :: ByronEraOnly era -> TxOut CtxTx era -> TxBodyError classifyRangeError ByronEraOnlyByron txout = case txout of - TxOut (AddressInEra ByronAddressInAnyEra ByronAddress{}) (TxOutValueByron ByronEraOnlyByron value) _ _ + TxOut (AddressInEra ByronAddressInAnyEra ByronAddress{}) (TxOutValueByron value) _ _ | value < 0 -> TxBodyOutputNegative (lovelaceToQuantity value) (txOutInAnyEra ByronEra txout) | otherwise -> TxBodyOutputOverflow (lovelaceToQuantity value) (txOutInAnyEra ByronEra txout) @@ -3099,8 +3102,10 @@ toShelleyTxOutAny :: forall ctx era ledgerera. -> TxOut ctx era -> Ledger.TxOut ledgerera toShelleyTxOutAny sbe = \case - TxOut _ (TxOutValueByron ByronEraOnlyByron _) _ _ -> - case sbe of {} + TxOut _ (TxOutValueByron _) _ _ -> + -- TODO: Temporary until we have basic tx + -- construction functionality + error "toShelleyTxOutAny: Expected a Shelley value" TxOut addr (TxOutValueShelleyBased _ value) txoutdata refScript -> let cEra = shelleyBasedToCardanoEra sbe in diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs index 704bea3d79..740a5f19cc 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs @@ -27,27 +27,27 @@ prop_json_roundtrip_alonzo_genesis = H.property $ do prop_json_roundtrip_utxo :: Property prop_json_roundtrip_utxo = H.property $ do - utxo <- forAll $ genUTxO BabbageEra + utxo <- forAll $ genUTxO ShelleyBasedEraBabbage tripping utxo encode eitherDecode prop_json_roundtrip_reference_scripts :: Property prop_json_roundtrip_reference_scripts = H.property $ do - rScript <- forAll $ genReferenceScript BabbageEra + rScript <- forAll $ genReferenceScript ShelleyBasedEraBabbage tripping rScript encode eitherDecode prop_json_roundtrip_txoutvalue :: Property prop_json_roundtrip_txoutvalue = H.property $ do - oVal <- forAll $ genTxOutValue BabbageEra + oVal <- forAll $ genTxOutValue ShelleyBasedEraBabbage tripping oVal encode eitherDecode prop_json_roundtrip_txout_tx_context :: Property prop_json_roundtrip_txout_tx_context = H.property $ do - txOut <- forAll $ genTxOutTxContext BabbageEra + txOut <- forAll $ genTxOutTxContext ShelleyBasedEraBabbage tripping txOut encode eitherDecode prop_json_roundtrip_txout_utxo_context :: Property prop_json_roundtrip_txout_utxo_context = H.property $ do - txOut <- forAll $ genTxOutUTxOContext BabbageEra + txOut <- forAll $ genTxOutUTxOContext ShelleyBasedEraBabbage tripping txOut encode eitherDecode prop_json_roundtrip_scriptdata_detailed_json :: Property 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 511306e998..317cbf7d8e 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 @@ -30,21 +30,21 @@ import Test.Tasty.Hedgehog (testProperty) prop_roundtrip_txbody_CBOR :: Property prop_roundtrip_txbody_CBOR = H.property $ do - AnyCardanoEra era <- H.forAll $ Gen.element [minBound..AnyCardanoEra BabbageEra] + AnyShelleyBasedEra era <- H.forAll $ Gen.element [minBound..maxBound] x <- H.forAll $ makeSignedTransaction [] <$> genTxBody era - H.tripping x (serialiseTxLedgerCddl era) (deserialiseTxLedgerCddl era) + H.tripping x (serialiseTxLedgerCddl $ toCardanoEra era) (deserialiseTxLedgerCddl $ toCardanoEra era) prop_roundtrip_tx_CBOR :: Property prop_roundtrip_tx_CBOR = H.property $ do - AnyCardanoEra era <- H.forAll $ Gen.element [minBound..AnyCardanoEra BabbageEra] + AnyShelleyBasedEra era <- H.forAll $ Gen.element [minBound..maxBound] x <- H.forAll $ genTx era - cardanoEraConstraints era $ H.trippingCbor (proxyToAsType Proxy) x + cardanoEraConstraints (toCardanoEra 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] + AnyShelleyBasedEra era <- H.forAll $ Gen.element [minBound..maxBound] x <- H.forAll $ genCardanoKeyWitness era - cardanoEraConstraints era $ H.trippingCbor (AsKeyWitness (proxyToAsType Proxy)) x + cardanoEraConstraints (toCardanoEra era) $ H.trippingCbor (AsKeyWitness (proxyToAsType Proxy)) x prop_roundtrip_operational_certificate_CBOR :: Property prop_roundtrip_operational_certificate_CBOR = H.property $ do @@ -169,9 +169,9 @@ prop_roundtrip_UpdateProposal_CBOR = H.property $ do prop_roundtrip_Tx_Cddl :: Property prop_roundtrip_Tx_Cddl = H.property $ do - AnyCardanoEra era <- H.forAll $ Gen.element [minBound..maxBound] + AnyShelleyBasedEra era <- H.forAll $ Gen.element [minBound..maxBound] x <- forAll $ genTx era - H.tripping x (serialiseTxLedgerCddl era) (deserialiseTxLedgerCddl era) + H.tripping x (serialiseTxLedgerCddl $ toCardanoEra era) (deserialiseTxLedgerCddl $ toCardanoEra era) prop_roundtrip_TxWitness_Cddl :: Property prop_roundtrip_TxWitness_Cddl = H.property $ do 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 5474c45b99..22cc2ff378 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 @@ -26,7 +26,7 @@ prop_roundtrip_txbodycontent_txouts:: Property prop_roundtrip_txbodycontent_txouts = H.property $ do let era = BabbageEra - content <- H.forAll $ genTxBodyContent era + content <- H.forAll $ genTxBodyContent ShelleyBasedEraBabbage -- Create the ledger body & auxiliaries body <- case createAndValidateTransactionBody era content of Left err -> annotateShow err >> failure diff --git a/cardano-api/test/cardano-api-test/cardano-api-test.hs b/cardano-api/test/cardano-api-test/cardano-api-test.hs index 0946866b1c..76529522ca 100644 --- a/cardano-api/test/cardano-api-test/cardano-api-test.hs +++ b/cardano-api/test/cardano-api-test/cardano-api-test.hs @@ -4,6 +4,8 @@ import Cardano.Crypto.Libsodium (sodiumInit) import System.IO (BufferMode (LineBuffering), hSetBuffering, hSetEncoding, stdout, utf8) +import qualified Test.Gen.Cardano.Api.Byron + import qualified Test.Cardano.Api.Crypto import qualified Test.Cardano.Api.Eras import qualified Test.Cardano.Api.IO @@ -34,7 +36,8 @@ main = do tests :: TestTree tests = testGroup "Cardano.Api" - [ Test.Cardano.Api.Crypto.tests + [ Test.Gen.Cardano.Api.Byron.tests + , Test.Cardano.Api.Crypto.tests , Test.Cardano.Api.Eras.tests , Test.Cardano.Api.IO.tests , Test.Cardano.Api.Json.tests