Skip to content

Commit

Permalink
Re-order generators in Hydra.Tx.Gen
Browse files Browse the repository at this point in the history
  • Loading branch information
ch1bo authored and locallycompact committed Oct 9, 2024
1 parent 9826b88 commit 3dc8a72
Show file tree
Hide file tree
Showing 5 changed files with 159 additions and 174 deletions.
50 changes: 0 additions & 50 deletions hydra-node/src/Hydra/Ledger/Cardano.hs
Original file line number Diff line number Diff line change
Expand Up @@ -245,56 +245,6 @@ mkOneTransfer networkId recipientSk (utxo, sender, txs) _ = do
_ ->
error "Couldn't generate transaction sequence: need exactly one UTXO."

-- | Generate a 'Babbage' era 'TxOut', which may contain arbitrary assets
-- addressed to public keys and scripts, as well as datums.
--
-- NOTE: This generator does
-- * not produce byron addresses as most of the cardano ecosystem dropped support for that (including plutus),
-- * not produce reference scripts as they are not fully "visible" from plutus,
-- * replace stake pointers with null references as nobody uses that.
genTxOut :: Gen (TxOut ctx)
genTxOut =
(noRefScripts . noStakeRefPtr <$> gen)
`suchThat` notByronAddress
where
gen =
modifyTxOutValue (<> (lovelaceToValue $ Coin 10_000_000))
<$> oneof
[ fromLedgerTxOut <$> arbitrary
, notMultiAsset . fromLedgerTxOut <$> arbitrary
]
notMultiAsset =
modifyTxOutValue (lovelaceToValue . selectLovelace)

notByronAddress (TxOut addr _ _ _) = case addr of
ByronAddressInEra{} -> False
_ -> True

noStakeRefPtr out@(TxOut addr val dat refScript) = case addr of
ShelleyAddressInEra (ShelleyAddress _ cre sr) ->
case sr of
Ledger.StakeRefPtr _ ->
TxOut (ShelleyAddressInEra (ShelleyAddress Ledger.Testnet cre Ledger.StakeRefNull)) val dat refScript
_ ->
TxOut (ShelleyAddressInEra (ShelleyAddress Ledger.Testnet cre sr)) val dat refScript
_ -> out

noRefScripts out =
out{txOutReferenceScript = ReferenceScriptNone}

-- | Generate a 'TxOut' with a byron address. This is usually not supported by
-- Hydra or Plutus.
genTxOutByron :: Gen (TxOut ctx)
genTxOutByron = do
addr <- ByronAddressInEra <$> arbitrary
value <- genValue
pure $ TxOut addr value TxOutDatumNone ReferenceScriptNone

-- | Generate UTXO entries that do not contain any assets. Useful to test /
-- measure cases where
genAdaOnlyUTxO :: Gen UTxO
genAdaOnlyUTxO = fmap adaOnly <$> arbitrary

-- * Orphans

instance Arbitrary (Hash PaymentKey) where
Expand Down
6 changes: 1 addition & 5 deletions hydra-node/test/Hydra/Chain/Direct/StateSpec.hs
Original file line number Diff line number Diff line change
Expand Up @@ -102,10 +102,6 @@ import Hydra.Chain.Direct.Tx (
)
import Hydra.Contract.HeadTokens qualified as HeadTokens
import Hydra.Contract.Initial qualified as Initial
import Hydra.Ledger.Cardano (
genTxOut,
genTxOutByron,
)
import Hydra.Ledger.Cardano.Evaluate (
evaluateTx,
genValidityBoundsFromContestationPeriod,
Expand All @@ -125,7 +121,7 @@ import PlutusLedgerApi.Test.Examples qualified as Plutus
import PlutusLedgerApi.V2 qualified as Plutus
import Test.Aeson.GenericSpecs (roundtripAndGoldenSpecs)
import Test.Hydra.Tx.Fixture (slotLength, systemStart, testNetworkId)
import Test.Hydra.Tx.Gen (genOutput, genTxOutAdaOnly, genUTxO1, genUTxOSized)
import Test.Hydra.Tx.Gen (genOutput, genTxOut, genTxOutAdaOnly, genTxOutByron, genUTxO1, genUTxOSized)
import Test.Hydra.Tx.Mutation (
Mutation (..),
applyMutation,
Expand Down
29 changes: 18 additions & 11 deletions hydra-node/test/Hydra/Ledger/CardanoSpec.hs
Original file line number Diff line number Diff line change
Expand Up @@ -17,16 +17,24 @@ import Hydra.Cardano.Api.Pretty (renderTx)
import Hydra.Chain.ChainState (ChainSlot (ChainSlot))
import Hydra.JSONSchema (prop_validateJSONSchema)
import Hydra.Ledger (applyTransactions)
import Hydra.Ledger.Cardano (
cardanoLedger,
genSequenceOfSimplePaymentTransactions,
genTxOut,
)
import Hydra.Ledger.Cardano (cardanoLedger, genSequenceOfSimplePaymentTransactions)
import Test.Aeson.GenericSpecs (roundtripAndGoldenSpecs)
import Test.Cardano.Ledger.Babbage.Arbitrary ()
import Test.Hydra.Node.Fixture (defaultGlobals, defaultLedgerEnv, defaultPParams)
import Test.Hydra.Tx.Gen (genOneUTxOFor, genOutput, genUTxOAdaOnlyOfSize, genUTxOAlonzo, genUTxOFor, genValue)
import Test.QuickCheck (Property, checkCoverage, conjoin, counterexample, cover, forAll, forAllBlind, property, sized, vectorOf, withMaxSuccess, (===))
import Test.Hydra.Tx.Gen (genOneUTxOFor, genOutput, genTxOut, genUTxO, genUTxOAdaOnlyOfSize, genUTxOFor, genValue)
import Test.QuickCheck (
Property,
checkCoverage,
conjoin,
counterexample,
cover,
forAll,
forAllBlind,
property,
sized,
vectorOf,
(===),
)
import Test.Util (propCollisionResistant)

spec :: Spec
Expand All @@ -53,9 +61,8 @@ spec =

describe "Tx" $ do
prop "JSON encoding of Tx according to schema" $
withMaxSuccess 5 $
prop_validateJSONSchema @Tx "api.json" $
key "components" . key "schemas" . key "Transaction"
prop_validateJSONSchema @Tx "api.json" $
key "components" . key "schemas" . key "Transaction"

describe "applyTransactions" $ do
prop "works with valid transaction" appliesValidTransaction
Expand All @@ -66,7 +73,7 @@ spec =
propCollisionResistant "arbitrary @TxId" (arbitrary @TxId)
propCollisionResistant "arbitrary @(VerificationKey PaymentKey)" (arbitrary @(VerificationKey PaymentKey))
propCollisionResistant "arbitrary @(Hash PaymentKey)" (arbitrary @(Hash PaymentKey))
propDoesNotCollapse "genUTxOAlonzo" genUTxOAlonzo
propDoesNotCollapse "genUTxO" genUTxO
propDoesNotCollapse "genUTxOAdaOnlyOfSize" (sized genUTxOAdaOnlyOfSize)
propCollisionResistant "genUTxOFor" (genUTxOFor (arbitrary `generateWith` 42))
propCollisionResistant "genOneUTxOFor" (genOneUTxOFor (arbitrary `generateWith` 42))
Expand Down
2 changes: 1 addition & 1 deletion hydra-node/testlib/Hydra/JSONSchema.hs
Original file line number Diff line number Diff line change
Expand Up @@ -90,7 +90,7 @@ validateJSON schemaFilePath selector value = do

-- | Validate an 'Arbitrary' value against a JSON schema.
--
-- NOTE: This property runs with a fixed `maxSuccess` of 1, but generates 100
-- NOTE: This property runs with a fixed `maxSuccess` of 1, but generates 1000
-- values of 'a' to reduce the number of calls to the external schema validation
-- (which is slow).
--
Expand Down
Loading

0 comments on commit 3dc8a72

Please sign in to comment.