{-# LANGUAGE AllowAmbiguousTypes #-}

module Hydra.Ledger.CardanoSpec where

import Hydra.Cardano.Api hiding (utxoFromTx)
import Hydra.Prelude hiding (toList)
import Test.Hydra.Prelude

import Cardano.Api.UTxO qualified as UTxO
import Cardano.Binary (decodeFull', serialize')
import Cardano.Ledger.Api (ensureMinCoinTxOut)
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Slotting.EpochInfo (EpochInfo, epochInfoSlotToRelativeTime, fixedEpochInfo, hoistEpochInfo)
import Cardano.Slotting.Time (RelativeTime (..), mkSlotLength)
import Data.Aeson (eitherDecode, encode)
import Data.Aeson qualified as Aeson
import Data.Aeson.Lens (key)
import Data.Aeson.Types (parseEither)
import Data.ByteString qualified as BS
import Data.SOP.NonEmpty (NonEmpty (NonEmptyCons, NonEmptyOne))
import Data.Text (unpack)
import GHC.IsList (IsList (..))
import Hydra.Cardano.Api.Gen (genTxIn)
import Hydra.Cardano.Api.Pretty (renderTx)
import Hydra.Chain.ChainState (ChainSlot (ChainSlot))
import Hydra.JSONSchema (prop_validateJSONSchema)
import Hydra.Ledger (applyTransactions, reapplyTransactions)
import Hydra.Ledger.Cardano (adjustUTxO, cardanoLedger)
import Hydra.Tx.IsTx (IsTx (..))
import Hydra.Tx.Secret (mkSecret)
import Ouroboros.Consensus.Block (GenesisWindow (..))
import Ouroboros.Consensus.Cardano.Block (CardanoEras)
import Ouroboros.Consensus.HardFork.History (
  Bound (..),
  EraEnd (..),
  EraParams (..),
  EraSummary (..),
  SafeZone (..),
  Summary (Summary),
  initBound,
  mkInterpreter,
  pattern NoPerasEnabled,
 )
import Ouroboros.Consensus.HardFork.History qualified as Consensus
import Ouroboros.Consensus.Shelley.Crypto (StandardCrypto)
import Test.Aeson.GenericSpecs (roundtripAndGoldenSpecs)
import Test.Cardano.Ledger.Babbage.Arbitrary ()
import Test.Gen.Cardano.Api.Typed (genChainPoint)
import Test.Hydra.Ledger.Cardano (genSequenceOfSimplePaymentTransactions, mkRangedTx)
import Test.Hydra.Node.Fixture (defaultGlobals, defaultLedgerEnv, defaultPParams, testNetworkId)
import Test.Hydra.Tx.Gen (genKeyPair, genOneUTxOFor, genOutputFor, genTxOut, genUTxOFor, genValue)
import Test.QuickCheck (
  Property,
  checkCoverage,
  choose,
  conjoin,
  counterexample,
  cover,
  forAll,
  forAllBlind,
  ioProperty,
  listOf1,
  property,
  withMaxSuccess,
  (===),
 )
import Test.QuickCheck.Hedgehog (hedgehog)
import Test.Util (propCollisionResistant, utxoNoThunks)

spec :: Spec
spec :: Spec
spec =
  Spec -> Spec
forall a. SpecWith a -> SpecWith a
parallel (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    Proxy AssetName -> Spec
forall a.
(Arbitrary a, ToJSON a, FromJSON a, Typeable a) =>
Proxy a -> Spec
roundtripAndGoldenSpecs (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @AssetName)

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"EpochInfo" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String -> Expectation -> SpecWith (Arg Expectation)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"fixedEpochInfo gives wrong slot-to-time for multi-era chains" (Expectation -> SpecWith (Arg Expectation))
-> Expectation -> SpecWith (Arg Expectation)
forall a b. (a -> b) -> a -> b
$ do
        -- On a real chain (mainnet/testnet), Byron era has 20s slots and
        -- Shelley+ has 1s slots. fixedEpochInfo uses a single slot length,
        -- which produces wrong POSIXTime conversions for Plutus scripts.
        let
          -- Byron era: 21600 slots per epoch, 20s per slot, runs for 208 epochs
          byronSlots :: Word64
byronSlots = Word64
21600 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
208 -- 4,492,800 slots
          byronSecondsPerSlot :: Word64
byronSecondsPerSlot = Word64
20
          byronDuration :: Word64
byronDuration = Word64
byronSlots Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
byronSecondsPerSlot -- seconds
          -- A slot well into the Shelley era (1s slots)
          testSlot :: SlotNo
testSlot = Word64 -> SlotNo
SlotNo (Word64
byronSlots Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1000)
          -- Expected time: byron duration + 1000 seconds (1s per Shelley slot)
          expectedRelativeTime :: Word64
expectedRelativeTime = Word64
byronDuration Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1000

          -- What fixedEpochInfo computes (assumes 1s slots from genesis):
          fixedRelativeTime :: Word64
fixedRelativeTime = SlotNo -> Word64
unSlotNo SlotNo
testSlot -- 4,493,800 seconds

        -- The actual time via era-aware interpreter
        let eraHistory :: EraHistory
eraHistory = EraHistory
multiEraHistory
            EraHistory Interpreter xs
Interpreter (CardanoEras StandardCrypto)
interpreter = EraHistory
eraHistory
        case Interpreter (CardanoEras StandardCrypto)
-> Qry (RelativeTime, SlotLength)
-> Either PastHorizonException (RelativeTime, SlotLength)
forall (xs :: [*]) a.
HasCallStack =>
Interpreter xs -> Qry a -> Either PastHorizonException a
Consensus.interpretQuery Interpreter (CardanoEras StandardCrypto)
interpreter (SlotNo -> Qry (RelativeTime, SlotLength)
Consensus.slotToWallclock SlotNo
testSlot) of
          Left PastHorizonException
err -> HasCallStack => String -> Expectation
String -> Expectation
expectationFailure (String -> Expectation) -> String -> Expectation
forall a b. (a -> b) -> a -> b
$ String
"Failed to query era history: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PastHorizonException -> String
forall b a. (Show a, IsString b) => a -> b
show PastHorizonException
err
          Right (RelativeTime
relTime, SlotLength
_slotLen) -> do
            -- Era-aware gives the correct time (byron duration + 1000s)
            RelativeTime
relTime RelativeTime -> RelativeTime -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` NominalDiffTime -> RelativeTime
RelativeTime (Word64 -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
expectedRelativeTime)
            -- This differs from what fixedEpochInfo would compute
            RelativeTime
relTime RelativeTime -> RelativeTime -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldNotBe` NominalDiffTime -> RelativeTime
RelativeTime (Word64 -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
fixedRelativeTime)

      String -> Expectation -> SpecWith (Arg Expectation)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"fixedEpochInfo causes wrong Globals for L2 Plutus evaluation on mainnet" (Expectation -> SpecWith (Arg Expectation))
-> Expectation -> SpecWith (Arg Expectation)
forall a b. (a -> b) -> a -> b
$ do
        -- This test demonstrates the actual bug: Globals constructed with
        -- fixedEpochInfo (as in newGlobals) will have a different epochInfo
        -- than Globals constructed with the correct era-aware EpochInfo.
        -- When Ledger.applyTx evaluates Plutus scripts, it uses
        -- Globals.epochInfo to convert slot numbers to POSIXTime in the
        -- ScriptContext. With the wrong epochInfo, time-sensitive Plutus
        -- scripts receive incorrect time values.
        let shelleySlotLength :: SlotLength
shelleySlotLength = NominalDiffTime -> SlotLength
mkSlotLength NominalDiffTime
1
            shelleyEpochSize :: EpochSize
shelleyEpochSize = Word64 -> EpochSize
EpochSize Word64
432000
            -- Fixed epoch info
            fixedEI :: EpochInfo (Either Text)
            fixedEI :: EpochInfo (Either Text)
fixedEI = EpochSize -> SlotLength -> EpochInfo (Either Text)
forall (m :: * -> *).
Monad m =>
EpochSize -> SlotLength -> EpochInfo m
fixedEpochInfo EpochSize
shelleyEpochSize SlotLength
shelleySlotLength
            -- Correct for multi-era
            EraHistory Interpreter xs
Interpreter (CardanoEras StandardCrypto)
interpreter = EraHistory
multiEraHistory
            eraAwareEI :: EpochInfo (Either Text)
            eraAwareEI :: EpochInfo (Either Text)
eraAwareEI =
              (forall a. Except PastHorizonException a -> Either Text a)
-> EpochInfo (Except PastHorizonException)
-> EpochInfo (Either Text)
forall (m :: * -> *) (n :: * -> *).
(forall a. m a -> n a) -> EpochInfo m -> EpochInfo n
hoistEpochInfo ((PastHorizonException -> Text)
-> Either PastHorizonException a -> Either Text a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first PastHorizonException -> Text
forall b a. (Show a, IsString b) => a -> b
show (Either PastHorizonException a -> Either Text a)
-> (Except PastHorizonException a -> Either PastHorizonException a)
-> Except PastHorizonException a
-> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Except PastHorizonException a -> Either PastHorizonException a
forall e a. Except e a -> Either e a
runExcept) (EpochInfo (Except PastHorizonException)
 -> EpochInfo (Either Text))
-> EpochInfo (Except PastHorizonException)
-> EpochInfo (Either Text)
forall a b. (a -> b) -> a -> b
$
                Interpreter (CardanoEras StandardCrypto)
-> EpochInfo (Except PastHorizonException)
forall (xs :: [*]).
Interpreter xs -> EpochInfo (Except PastHorizonException)
Consensus.interpreterToEpochInfo Interpreter (CardanoEras StandardCrypto)
interpreter
            -- A slot in the Shelley era
            testSlot :: SlotNo
testSlot = Word64 -> SlotNo
SlotNo Word64
5000000

        -- fixedEpochInfo says: slot 5000000 * 1s = 5000000s from system start
        -- Era-aware says: byron(4492800 slots * 20s) + shelley(507200 slots * 1s)
        --               = 89856000 + 507200 = 90363200s
        EpochInfo (Either Text) -> SlotNo -> Either Text RelativeTime
forall (m :: * -> *).
HasCallStack =>
EpochInfo m -> SlotNo -> m RelativeTime
epochInfoSlotToRelativeTime EpochInfo (Either Text)
fixedEI SlotNo
testSlot Either Text RelativeTime -> Either Text RelativeTime -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` RelativeTime -> Either Text RelativeTime
forall a b. b -> Either a b
Right (NominalDiffTime -> RelativeTime
RelativeTime NominalDiffTime
5000000)
        EpochInfo (Either Text) -> SlotNo -> Either Text RelativeTime
forall (m :: * -> *).
HasCallStack =>
EpochInfo m -> SlotNo -> m RelativeTime
epochInfoSlotToRelativeTime EpochInfo (Either Text)
eraAwareEI SlotNo
testSlot Either Text RelativeTime -> Either Text RelativeTime -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` RelativeTime -> Either Text RelativeTime
forall a b. b -> Either a b
Right (NominalDiffTime -> RelativeTime
RelativeTime NominalDiffTime
90363200)

    -- XXX: Move API conformance tests to API specs and add any missing ones
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"UTxO" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"JSON encoding of UTxO according to schema" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
        forall a.
(HasCallStack, ToJSON a, Arbitrary a, Show a) =>
String -> SchemaSelector -> Property
prop_validateJSONSchema @UTxO String
"api.json" (SchemaSelector -> Property) -> SchemaSelector -> Property
forall a b. (a -> b) -> a -> b
$
          Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"components" ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"schemas" ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"UTxO"

      -- TODO(SN): rather ensure we use bech32 for addresses as a test
      String -> Expectation -> SpecWith (Arg Expectation)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"parses a specific UTxO" (Expectation -> SpecWith (Arg Expectation))
-> Expectation -> SpecWith (Arg Expectation)
forall a b. (a -> b) -> a -> b
$ do
        let bs :: LByteString
bs =
              LByteString
"{\"9fdc525c20bc00d9dfa9d14904b65e01910c0dfe3bb39865523c1e20eaeb0903#0\":\
              \  {\"address\":\"addr1vx35vu6aqmdw6uuc34gkpdymrpsd3lsuh6ffq6d9vja0s6spkenss\",\
              \   \"value\":{\"lovelace\":14}}}"
        forall a. (HasCallStack, FromJSON a) => LByteString -> Expectation
shouldParseJSONAs @UTxO LByteString
bs

      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
xprop String
"round-trips TxOut with non-canonical inline datum via cardano-api FromJSON (pending cardano-api fix)" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
        Gen HashableScriptData
-> (HashableScriptData -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen HashableScriptData
genNonCanonicalHashableScriptData ((HashableScriptData -> Property) -> Property)
-> (HashableScriptData -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \HashableScriptData
hsd ->
          let (VerificationKey PaymentKey
vk, SigningKey PaymentKey
_) = Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> Int -> (VerificationKey PaymentKey, SigningKey PaymentKey)
forall a. Gen a -> Int -> a
`generateWith` Int
42
              addr :: AddressInEra Era
addr = NetworkId -> VerificationKey PaymentKey -> AddressInEra Era
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
testNetworkId VerificationKey PaymentKey
vk
              txOut :: TxOut CtxUTxO
txOut =
                AddressInEra Era
-> Value -> TxOutDatum CtxUTxO -> ReferenceScript -> TxOut CtxUTxO
forall ctx.
AddressInEra Era
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut
                  AddressInEra Era
addr
                  (Lovelace -> Value
lovelaceToValue Lovelace
2_000_000)
                  (HashableScriptData -> TxOutDatum CtxUTxO
forall ctx. HashableScriptData -> TxOutDatum ctx
TxOutDatumInline HashableScriptData
hsd)
                  ReferenceScript
ReferenceScriptNone ::
                  TxOut CtxUTxO
           in case forall a. FromJSON a => LByteString -> Either String a
Aeson.eitherDecode @(TxOut CtxUTxO) (TxOut CtxUTxO -> LByteString
forall a. ToJSON a => a -> LByteString
Aeson.encode TxOut CtxUTxO
txOut) of
                Left String
err -> String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
err Bool
False
                Right TxOut CtxUTxO
_ -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True

      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"parseTxOutFromJSON preserves hash for non-canonical inline datum" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
        Gen HashableScriptData
-> (HashableScriptData -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen HashableScriptData
genNonCanonicalHashableScriptData ((HashableScriptData -> Property) -> Property)
-> (HashableScriptData -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \HashableScriptData
hsd ->
          let (VerificationKey PaymentKey
vk, SigningKey PaymentKey
_) = Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> Int -> (VerificationKey PaymentKey, SigningKey PaymentKey)
forall a. Gen a -> Int -> a
`generateWith` Int
42
              addr :: AddressInEra Era
addr = NetworkId -> VerificationKey PaymentKey -> AddressInEra Era
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
testNetworkId VerificationKey PaymentKey
vk
              txOut :: TxOut CtxUTxO
txOut =
                AddressInEra Era
-> Value -> TxOutDatum CtxUTxO -> ReferenceScript -> TxOut CtxUTxO
forall ctx.
AddressInEra Era
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut
                  AddressInEra Era
addr
                  (Lovelace -> Value
lovelaceToValue Lovelace
2_000_000)
                  (HashableScriptData -> TxOutDatum CtxUTxO
forall ctx. HashableScriptData -> TxOutDatum ctx
TxOutDatumInline HashableScriptData
hsd)
                  ReferenceScript
ReferenceScriptNone ::
                  TxOut CtxUTxO
           in case (Value -> Parser (TxOut CtxUTxO))
-> Value -> Either String (TxOut CtxUTxO)
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser (TxOut CtxUTxO)
parseTxOutFromJSON (TxOut CtxUTxO -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON TxOut CtxUTxO
txOut) of
                Left String
err -> String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
err Bool
False
                Right (TxOut AddressInEra Era
_ Value
_ (TxOutDatumInline HashableScriptData
hsd') ReferenceScript
_) ->
                  HashableScriptData -> Hash ScriptData
hashScriptDataBytes HashableScriptData
hsd Hash ScriptData -> Hash ScriptData -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== HashableScriptData -> Hash ScriptData
hashScriptDataBytes HashableScriptData
hsd'
                Right TxOut CtxUTxO
_ ->
                  String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Expected TxOutDatumInline after round-trip" Bool
False

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"PParams" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$
      String -> (PParams ConwayEra -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Roundtrip JSON encoding" PParams LedgerEra -> Property
PParams ConwayEra -> Property
roundtripPParams

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"UTxO strictness" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"applyTransactions yields a thunk-free UTxO" Property
prop_applyTransactionsThunkFree
      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"utxoFromTx yields a thunk-free UTxO" Property
prop_utxoFromTxThunkFree
      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"applyTxTo yields a thunk-free UTxO" Property
prop_applyTxToThunkFree
      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"adjustUTxO yields a thunk-free UTxO" Property
prop_adjustUTxOThunkFree
      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"JSON decoding yields a thunk-free UTxO" Property
prop_jsonDecodeThunkFree
      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"CBOR decoding yields a thunk-free UTxO" Property
prop_cborDecodeThunkFree

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Tx" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"JSON encoding of Tx according to schema" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
        forall a.
(HasCallStack, ToJSON a, Arbitrary a, Show a) =>
String -> SchemaSelector -> Property
prop_validateJSONSchema @Tx String
"api.json" (SchemaSelector -> Property) -> SchemaSelector -> Property
forall a b. (a -> b) -> a -> b
$
          Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"components" ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"schemas" ((Value -> f Value) -> Value -> f Value)
-> ((Value -> f Value) -> Value -> f Value)
-> (Value -> f Value)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> SchemaSelector
forall t. AsValue t => Key -> Traversal' t Value
key Key
"Transaction"

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"applyTransactions" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"works with valid transaction" Property
appliesValidTransaction
      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"works with valid transaction deserialised from JSON" Property
appliesValidTransactionFromJSON
      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"is equivalent to folding applyTxTo for valid transactions" Property
applyTransactionsEquivalence
      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"reapplyTransactions produces same UTxO as applyTransactions for valid transactions" Property
reapplyEquivalence
      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"reapplyTransactions still rejects expired transactions" Property
reapplyRejectsExpired

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Generators" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String -> Gen TxIn -> Spec
forall a. (Show a, Eq a) => String -> Gen a -> Spec
propCollisionResistant String
"arbitrary @TxIn" (forall a. Arbitrary a => Gen a
arbitrary @TxIn)
      String -> Gen TxId -> Spec
forall a. (Show a, Eq a) => String -> Gen a -> Spec
propCollisionResistant String
"arbitrary @TxId" (forall a. Arbitrary a => Gen a
arbitrary @TxId)
      String -> Gen (VerificationKey PaymentKey) -> Spec
forall a. (Show a, Eq a) => String -> Gen a -> Spec
propCollisionResistant String
"arbitrary @(VerificationKey PaymentKey)" (forall a. Arbitrary a => Gen a
arbitrary @(VerificationKey PaymentKey))
      String -> Gen (Hash PaymentKey) -> Spec
forall a. (Show a, Eq a) => String -> Gen a -> Spec
propCollisionResistant String
"arbitrary @(Hash PaymentKey)" (forall a. Arbitrary a => Gen a
arbitrary @(Hash PaymentKey))
      String -> Gen (UTxO Era) -> Spec
forall a. (Show a, Eq a) => String -> Gen a -> Spec
propCollisionResistant String
"genUTxOFor" (VerificationKey PaymentKey -> Gen (UTxO Era)
genUTxOFor (Gen (VerificationKey PaymentKey)
forall a. Arbitrary a => Gen a
arbitrary Gen (VerificationKey PaymentKey)
-> Int -> VerificationKey PaymentKey
forall a. Gen a -> Int -> a
`generateWith` Int
42))
      String -> Gen (UTxO Era) -> Spec
forall a. (Show a, Eq a) => String -> Gen a -> Spec
propCollisionResistant String
"genOneUTxOFor" (VerificationKey PaymentKey -> Gen (UTxO Era)
genOneUTxOFor (Gen (VerificationKey PaymentKey)
forall a. Arbitrary a => Gen a
arbitrary Gen (VerificationKey PaymentKey)
-> Int -> VerificationKey PaymentKey
forall a. Gen a -> Int -> a
`generateWith` Int
42))

      String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"genTxOut" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$
        String -> Property -> SpecM (Arg Property) ()
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does generate good values" (Property -> SpecM (Arg Property) ())
-> Property -> SpecM (Arg Property) ()
forall a b. (a -> b) -> a -> b
$
          Gen (TxOut CtxUTxO) -> (TxOut CtxUTxO -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (TxOut CtxUTxO)
forall ctx. Gen (TxOut ctx)
genTxOut TxOut CtxUTxO -> Property
propGeneratesGoodTxOut

      String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"genOutputFor" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$
        String -> Property -> SpecM (Arg Property) ()
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"has enough lovelace to cover assets" (Property -> SpecM (Arg Property) ())
-> Property -> SpecM (Arg Property) ()
forall a b. (a -> b) -> a -> b
$
          Gen (TxOut CtxUTxO) -> (TxOut CtxUTxO -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Gen (VerificationKey PaymentKey)
forall a. Arbitrary a => Gen a
arbitrary Gen (VerificationKey PaymentKey)
-> (VerificationKey PaymentKey -> Gen (TxOut CtxUTxO))
-> Gen (TxOut CtxUTxO)
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= VerificationKey PaymentKey -> Gen (TxOut CtxUTxO)
forall ctx. VerificationKey PaymentKey -> Gen (TxOut ctx)
genOutputFor) TxOut CtxUTxO -> Property
propHasEnoughLovelace

      String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"genValue" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$
        String -> Property -> SpecM (Arg Property) ()
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"produces realistic values" (Property -> SpecM (Arg Property) ())
-> Property -> SpecM (Arg Property) ()
forall a b. (a -> b) -> a -> b
$
          Gen Value -> (Value -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen Value
genValue Value -> Property
propRealisticValue

      String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"genChainPoint" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$
        String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"generates only some genesis points" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
          Property -> Property
forall prop. Testable prop => prop -> Property
checkCoverage (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            Gen ChainPoint -> (ChainPoint -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Gen ChainPoint -> Gen ChainPoint
forall a. Gen a -> Gen a
hedgehog Gen ChainPoint
genChainPoint) ((ChainPoint -> Property) -> Property)
-> (ChainPoint -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ChainPoint
cp ->
              Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
80 (ChainPoint
cp ChainPoint -> ChainPoint -> Bool
forall a. Eq a => a -> a -> Bool
/= ChainPoint
ChainPointAtGenesis) String
"not at genesis" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True

shouldParseJSONAs :: forall a. (HasCallStack, FromJSON a) => LByteString -> Expectation
shouldParseJSONAs :: forall a. (HasCallStack, FromJSON a) => LByteString -> Expectation
shouldParseJSONAs LByteString
bs =
  case LByteString -> Either String a
forall a. FromJSON a => LByteString -> Either String a
Aeson.eitherDecode LByteString
bs of
    Left String
err -> String -> Expectation
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
err
    Right (a
_ :: a) -> () -> Expectation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Test that the 'PParams' To/FromJSON instances to roundtrip.
roundtripPParams :: PParams LedgerEra -> Property
roundtripPParams :: PParams LedgerEra -> Property
roundtripPParams PParams LedgerEra
pparams = do
  case LByteString -> Maybe (PParams ConwayEra)
forall a. FromJSON a => LByteString -> Maybe a
Aeson.decode (PParams ConwayEra -> LByteString
forall a. ToJSON a => a -> LByteString
Aeson.encode PParams LedgerEra
PParams ConwayEra
pparams) of
    Maybe (PParams ConwayEra)
Nothing ->
      Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
    Just PParams ConwayEra
actual ->
      PParams LedgerEra
PParams ConwayEra
pparams PParams ConwayEra -> PParams ConwayEra -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== PParams ConwayEra
actual

applyTransactionsEquivalence :: Property
applyTransactionsEquivalence :: Property
applyTransactionsEquivalence =
  Gen (UTxO Era, [Tx]) -> ((UTxO Era, [Tx]) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (UTxO Era, [Tx])
genSequenceOfSimplePaymentTransactions (((UTxO Era, [Tx]) -> Property) -> Property)
-> ((UTxO Era, [Tx]) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(UTxO Era
utxo, [Tx]
txs) ->
    let ledger :: Ledger Tx
ledger = Globals -> LedgerEnv LedgerEra -> Ledger Tx
cardanoLedger Globals
defaultGlobals LedgerEnv LedgerEra
defaultLedgerEnv
        slot :: ChainSlot
slot = Natural -> ChainSlot
ChainSlot Natural
0
        viaLedger :: Either (Tx, ValidationError) (UTxOType Tx)
viaLedger = Ledger Tx
-> ChainSlot
-> UTxOType Tx
-> [Tx]
-> Either (Tx, ValidationError) (UTxOType Tx)
forall tx.
Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactions Ledger Tx
ledger ChainSlot
slot UTxOType Tx
UTxO Era
utxo [Tx]
txs
        viaApplyTxTo :: UTxO Era
viaApplyTxTo = (UTxO Era -> Tx -> UTxO Era) -> UTxO Era -> [Tx] -> UTxO Era
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((Tx -> UTxO Era -> UTxO Era) -> UTxO Era -> Tx -> UTxO Era
forall a b c. (a -> b -> c) -> b -> a -> c
flip Tx -> UTxOType Tx -> UTxOType Tx
Tx -> UTxO Era -> UTxO Era
forall tx. IsTx tx => tx -> UTxOType tx -> UTxOType tx
applyTxTo) UTxO Era
utxo [Tx]
txs
     in Either (Tx, ValidationError) (UTxOType Tx)
Either (Tx, ValidationError) (UTxO Era)
viaLedger Either (Tx, ValidationError) (UTxO Era)
-> Either (Tx, ValidationError) (UTxO Era) -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== UTxO Era -> Either (Tx, ValidationError) (UTxO Era)
forall a b. b -> Either a b
Right UTxO Era
viaApplyTxTo

appliesValidTransaction :: Property
appliesValidTransaction :: Property
appliesValidTransaction =
  Gen (UTxO Era, [Tx]) -> ((UTxO Era, [Tx]) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (UTxO Era, [Tx])
genSequenceOfSimplePaymentTransactions (((UTxO Era, [Tx]) -> Property) -> Property)
-> ((UTxO Era, [Tx]) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(UTxO Era
utxo, [Tx]
txs) ->
    let result :: Either (Tx, ValidationError) (UTxOType Tx)
result = Ledger Tx
-> ChainSlot
-> UTxOType Tx
-> [Tx]
-> Either (Tx, ValidationError) (UTxOType Tx)
forall tx.
Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactions (Globals -> LedgerEnv LedgerEra -> Ledger Tx
cardanoLedger Globals
defaultGlobals LedgerEnv LedgerEra
defaultLedgerEnv) (Natural -> ChainSlot
ChainSlot Natural
0) UTxOType Tx
UTxO Era
utxo [Tx]
txs
     in case Either (Tx, ValidationError) (UTxOType Tx)
result of
          Right UTxOType Tx
_ -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
          Left (Tx
tx, ValidationError
err) ->
            Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
              Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ValidationError -> String
forall b a. (Show a, IsString b) => a -> b
show ValidationError
err)
              Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Failing tx: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Tx -> String
renderTx Tx
tx)
              Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"All txs: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ [Tx] -> ByteString
forall a. ToJSON a => a -> ByteString
prettyPrintJSON [Tx]
txs))
              Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Initial UTxO: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ UTxO Era -> ByteString
forall a. ToJSON a => a -> ByteString
prettyPrintJSON UTxO Era
utxo))

appliesValidTransactionFromJSON :: Property
appliesValidTransactionFromJSON :: Property
appliesValidTransactionFromJSON =
  Gen (UTxO Era, [Tx]) -> ((UTxO Era, [Tx]) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (UTxO Era, [Tx])
genSequenceOfSimplePaymentTransactions (((UTxO Era, [Tx]) -> Property) -> Property)
-> ((UTxO Era, [Tx]) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(UTxO Era
utxo, [Tx]
txs) ->
    let encoded :: LByteString
encoded = [Tx] -> LByteString
forall a. ToJSON a => a -> LByteString
encode [Tx]
txs
        result :: Either String (UTxO Era)
result = LByteString -> Either String [Tx]
forall a. FromJSON a => LByteString -> Either String a
eitherDecode LByteString
encoded Either String [Tx]
-> ([Tx] -> Either String (UTxO Era)) -> Either String (UTxO Era)
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Tx, ValidationError) -> String)
-> Either (Tx, ValidationError) (UTxO Era)
-> Either String (UTxO Era)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Tx, ValidationError) -> String
forall b a. (Show a, IsString b) => a -> b
show (Either (Tx, ValidationError) (UTxO Era)
 -> Either String (UTxO Era))
-> ([Tx] -> Either (Tx, ValidationError) (UTxO Era))
-> [Tx]
-> Either String (UTxO Era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ledger Tx
-> ChainSlot
-> UTxOType Tx
-> [Tx]
-> Either (Tx, ValidationError) (UTxOType Tx)
forall tx.
Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactions (Globals -> LedgerEnv LedgerEra -> Ledger Tx
cardanoLedger Globals
defaultGlobals LedgerEnv LedgerEra
defaultLedgerEnv) (Natural -> ChainSlot
ChainSlot Natural
0) UTxOType Tx
UTxO Era
utxo
     in Either String (UTxO Era) -> Bool
forall a b. Either a b -> Bool
isRight Either String (UTxO Era)
result
          Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Result: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Either String (UTxO Era) -> String
forall b a. (Show a, IsString b) => a -> b
show Either String (UTxO Era)
result)
          Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"All txs: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ [Tx] -> ByteString
forall a. ToJSON a => a -> ByteString
prettyPrintJSON [Tx]
txs))
          Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Initial UTxO: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ UTxO Era -> ByteString
forall a. ToJSON a => a -> ByteString
prettyPrintJSON UTxO Era
utxo))

reapplyEquivalence :: Property
reapplyEquivalence :: Property
reapplyEquivalence =
  Gen (UTxO Era, [Tx]) -> ((UTxO Era, [Tx]) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (UTxO Era, [Tx])
genSequenceOfSimplePaymentTransactions (((UTxO Era, [Tx]) -> Property) -> Property)
-> ((UTxO Era, [Tx]) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(UTxO Era
utxo, [Tx]
txs) ->
    let ledger :: Ledger Tx
ledger = Globals -> LedgerEnv LedgerEra -> Ledger Tx
cardanoLedger Globals
defaultGlobals LedgerEnv LedgerEra
defaultLedgerEnv
        slot :: ChainSlot
slot = Natural -> ChainSlot
ChainSlot Natural
0
     in Ledger Tx
-> ChainSlot
-> UTxOType Tx
-> [Tx]
-> Either (Tx, ValidationError) (UTxOType Tx)
forall tx.
Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactions Ledger Tx
ledger ChainSlot
slot UTxOType Tx
UTxO Era
utxo [Tx]
txs
          Either (Tx, ValidationError) (UTxO Era)
-> Either (Tx, ValidationError) (UTxO Era) -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Ledger Tx
-> ChainSlot
-> UTxOType Tx
-> [Tx]
-> Either (Tx, ValidationError) (UTxOType Tx)
forall tx.
Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
reapplyTransactions Ledger Tx
ledger ChainSlot
slot UTxOType Tx
UTxO Era
utxo [Tx]
txs

reapplyRejectsExpired :: Property
reapplyRejectsExpired :: Property
reapplyRejectsExpired =
  Gen (UTxO Era, Tx) -> ((UTxO Era, Tx) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (UTxO Era, Tx)
genExpiringTransaction (((UTxO Era, Tx) -> Property) -> Property)
-> ((UTxO Era, Tx) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(UTxO Era
utxo, Tx
tx) ->
    let ledger :: Ledger Tx
ledger = Globals -> LedgerEnv LedgerEra -> Ledger Tx
cardanoLedger Globals
defaultGlobals LedgerEnv LedgerEra
defaultLedgerEnv
        expiredSlot :: ChainSlot
expiredSlot = Natural -> ChainSlot
ChainSlot Natural
1000
     in Ledger Tx
-> ChainSlot
-> UTxOType Tx
-> [Tx]
-> Either (Tx, ValidationError) (UTxOType Tx)
forall tx.
Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactions Ledger Tx
ledger ChainSlot
expiredSlot UTxOType Tx
UTxO Era
utxo [Tx
tx]
          Either (Tx, ValidationError) (UTxO Era)
-> Either (Tx, ValidationError) (UTxO Era) -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Ledger Tx
-> ChainSlot
-> UTxOType Tx
-> [Tx]
-> Either (Tx, ValidationError) (UTxOType Tx)
forall tx.
Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
reapplyTransactions Ledger Tx
ledger ChainSlot
expiredSlot UTxOType Tx
UTxO Era
utxo [Tx
tx]
 where
  genExpiringTransaction :: Gen (UTxO Era, Tx)
genExpiringTransaction = do
    (VerificationKey PaymentKey
vk, SigningKey PaymentKey
sk) <- Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair
    TxOut CtxUTxO
txOut <- VerificationKey PaymentKey -> Gen (TxOut CtxUTxO)
forall ctx. VerificationKey PaymentKey -> Gen (TxOut ctx)
genOutputFor VerificationKey PaymentKey
vk
    TxIn
txIn <- Gen TxIn
genTxIn
    (TxIn, TxOut CtxUTxO)
-> (AddressInEra Era, Value)
-> Secret (SigningKey PaymentKey)
-> (Maybe TxValidityLowerBound, Maybe TxValidityUpperBound)
-> Either TxBodyError Tx
mkRangedTx
      (TxIn
txIn, TxOut CtxUTxO
txOut)
      (NetworkId -> VerificationKey PaymentKey -> AddressInEra Era
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
testNetworkId VerificationKey PaymentKey
vk, TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
txOut)
      (SigningKey PaymentKey -> Secret (SigningKey PaymentKey)
forall a. a -> Secret a
mkSecret SigningKey PaymentKey
sk)
      (Maybe TxValidityLowerBound
forall a. Maybe a
Nothing, TxValidityUpperBound -> Maybe TxValidityUpperBound
forall a. a -> Maybe a
Just (TxValidityUpperBound -> Maybe TxValidityUpperBound)
-> TxValidityUpperBound -> Maybe TxValidityUpperBound
forall a b. (a -> b) -> a -> b
$ SlotNo -> TxValidityUpperBound
TxValidityUpperBound (Word64 -> SlotNo
SlotNo Word64
10))
      Either TxBodyError Tx
-> (Either TxBodyError Tx -> Gen (UTxO Era, Tx))
-> Gen (UTxO Era, Tx)
forall a b. a -> (a -> b) -> b
& \case
        Left TxBodyError
_ -> Text -> Gen (UTxO Era, Tx)
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"cannot generate expiring tx"
        Right Tx
tx -> (UTxO Era, Tx) -> Gen (UTxO Era, Tx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn -> TxOut CtxUTxO -> UTxO Era
forall era. TxIn -> TxOut CtxUTxO era -> UTxO era
UTxO.singleton TxIn
txIn TxOut CtxUTxO
txOut, Tx
tx)

-- | A transaction or transaction output can usually only contain a realistic
-- number of native asset entries. This property checks a realistic order of
-- magnitude (100).
propRealisticValue :: Value -> Property
propRealisticValue :: Value -> Property
propRealisticValue Value
value =
  Int
numberOfAssets Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
100
    Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"too many individual assets: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
numberOfAssets)
 where
  numberOfAssets :: Int
numberOfAssets = [(AssetId, Quantity)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Value -> [Item Value]
forall l. IsList l => l -> [Item l]
toList Value
value)

-- | Check that an output has enough lovelace to cover asset deposits.
propHasEnoughLovelace :: TxOut CtxUTxO -> Property
propHasEnoughLovelace :: TxOut CtxUTxO -> Property
propHasEnoughLovelace TxOut CtxUTxO
txOut =
  PParams ConwayEra -> TxOut ConwayEra -> TxOut ConwayEra
forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
ensureMinCoinTxOut PParams LedgerEra
PParams ConwayEra
defaultPParams (TxOut CtxUTxO -> TxOut LedgerEra
forall era.
(HasCallStack, IsShelleyBasedEra era) =>
TxOut CtxUTxO era -> TxOut (ShelleyLedgerEra era)
toLedgerTxOut TxOut CtxUTxO
txOut) TxOut ConwayEra -> TxOut ConwayEra -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== TxOut CtxUTxO -> TxOut LedgerEra
forall era.
(HasCallStack, IsShelleyBasedEra era) =>
TxOut CtxUTxO era -> TxOut (ShelleyLedgerEra era)
toLedgerTxOut TxOut CtxUTxO
txOut
    Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"ensureMinCoinTxOut deemed not enough lovelace in txOut"

-- | Check that the given 'TxOut' fulfills several requirements and does not use
-- unsupported features. See 'genTxOut' for rationale.
propGeneratesGoodTxOut :: TxOut CtxUTxO -> Property
propGeneratesGoodTxOut :: TxOut CtxUTxO -> Property
propGeneratesGoodTxOut TxOut CtxUTxO
txOut =
  Property -> Property
forall prop. Testable prop => prop -> Property
checkCoverage (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
      [ Property
propNoReferenceScript
      , Property
propNoByronAddress
      , Value -> Property
propRealisticValue (TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
txOut)
      , TxOut CtxUTxO -> Property
propHasEnoughLovelace TxOut CtxUTxO
txOut
      ]
      Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
5 Bool
hasDatum String
"has datum"
      Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
5 Bool
isVKOutput String
"is VK output"
      Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
5 Bool
isScriptOutput String
"is Script output"
      Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
1 Bool
hasOnlyADA String
"has only ADA"
      Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
1 Bool
hasMultiAssets String
"has multiple assets "
 where
  propNoReferenceScript :: Property
propNoReferenceScript =
    TxOut CtxUTxO -> ReferenceScript
forall ctx. TxOut ctx -> ReferenceScript
txOutReferenceScript TxOut CtxUTxO
txOut
      ReferenceScript -> ReferenceScript -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ReferenceScript
ReferenceScriptNone
      Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"generated reference script"

  propNoByronAddress :: Property
propNoByronAddress = case TxOut CtxUTxO -> AddressInEra Era
forall ctx. TxOut ctx -> AddressInEra Era
txOutAddress TxOut CtxUTxO
txOut of
    ByronAddressInEra ByronAddress{} -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"generated byron address"
    ShelleyAddressInEra ShelleyAddress{} -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True

  hasDatum :: Bool
hasDatum = TxOut CtxUTxO -> TxOutDatum CtxUTxO
forall ctx. TxOut ctx -> TxOutDatum ctx
txOutDatum TxOut CtxUTxO
txOut TxOutDatum CtxUTxO -> TxOutDatum CtxUTxO -> Bool
forall a. Eq a => a -> a -> Bool
/= TxOutDatum CtxUTxO
forall ctx. TxOutDatum ctx
TxOutDatumNone

  hasOnlyADA :: Bool
hasOnlyADA = ((AssetId, Quantity) -> Bool) -> [(AssetId, Quantity)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(AssetId
an, Quantity
_) -> AssetId
an AssetId -> AssetId -> Bool
forall a. Eq a => a -> a -> Bool
== AssetId
AdaAssetId) [(AssetId, Quantity)]
[Item Value]
assets

  hasMultiAssets :: Bool
hasMultiAssets = ((AssetId, Quantity) -> Bool) -> [(AssetId, Quantity)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(AssetId
an, Quantity
_) -> AssetId
an AssetId -> AssetId -> Bool
forall a. Eq a => a -> a -> Bool
/= AssetId
AdaAssetId) [(AssetId, Quantity)]
[Item Value]
assets

  assets :: [Item Value]
assets = Value -> [Item Value]
forall l. IsList l => l -> [Item l]
toList (Value -> [Item Value]) -> Value -> [Item Value]
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
txOut

  isVKOutput :: Bool
isVKOutput = case TxOut CtxUTxO -> AddressInEra Era
forall ctx. TxOut ctx -> AddressInEra Era
txOutAddress TxOut CtxUTxO
txOut of
    ByronAddressInEra ByronAddress{} -> Bool
False
    ShelleyAddressInEra (ShelleyAddress Network
_ Credential Payment
cred StakeReference
_) ->
      case Credential Payment
cred of
        KeyHashObj{} -> Bool
True
        ScriptHashObj{} -> Bool
False

  isScriptOutput :: Bool
isScriptOutput = case TxOut CtxUTxO -> AddressInEra Era
forall ctx. TxOut ctx -> AddressInEra Era
txOutAddress TxOut CtxUTxO
txOut of
    ByronAddressInEra ByronAddress{} -> Bool
False
    ShelleyAddressInEra (ShelleyAddress Network
_ Credential Payment
cred StakeReference
_) ->
      case Credential Payment
cred of
        KeyHashObj{} -> Bool
False
        ScriptHashObj{} -> Bool
True

-- UTXO strictness properties

-- the workhorse: deep heap inspection, no instances needed
utxoIsThunkFree :: UTxO -> Property
utxoIsThunkFree :: UTxO Era -> Property
utxoIsThunkFree UTxO Era
utxo = IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
  Maybe ThunkInfo
mThunk <- UTxO Era -> IO (Maybe ThunkInfo)
utxoNoThunks UTxO Era
utxo
  Property -> IO Property
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> IO Property) -> Property -> IO Property
forall a b. (a -> b) -> a -> b
$
    Maybe ThunkInfo -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ThunkInfo
mThunk
      Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Thunk found: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe ThunkInfo -> String
forall b a. (Show a, IsString b) => a -> b
show Maybe ThunkInfo
mThunk)

prop_applyTransactionsThunkFree :: Property
prop_applyTransactionsThunkFree :: Property
prop_applyTransactionsThunkFree =
  Gen (UTxO Era, [Tx]) -> ((UTxO Era, [Tx]) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (UTxO Era, [Tx])
genSequenceOfSimplePaymentTransactions (((UTxO Era, [Tx]) -> Property) -> Property)
-> ((UTxO Era, [Tx]) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(UTxO Era
utxo, [Tx]
txs) ->
    -- Force the input first: with an empty transaction list the input is
    -- returned unchanged, so the guarantee is compositional, like for
    -- adjustUTxO.
    case Ledger Tx
-> ChainSlot
-> UTxOType Tx
-> [Tx]
-> Either (Tx, ValidationError) (UTxOType Tx)
forall tx.
Ledger tx
-> ChainSlot
-> UTxOType tx
-> [tx]
-> Either (tx, ValidationError) (UTxOType tx)
applyTransactions (Globals -> LedgerEnv LedgerEra -> Ledger Tx
cardanoLedger Globals
defaultGlobals LedgerEnv LedgerEra
defaultLedgerEnv) (Natural -> ChainSlot
ChainSlot Natural
0) (UTxO Era -> UTxO Era
forceUTxO UTxO Era
utxo) [Tx]
txs of
      Left (Tx
_tx, ValidationError
err) -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"tx did not apply: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ValidationError -> String
forall b a. (Show a, IsString b) => a -> b
show ValidationError
err)
      Right UTxOType Tx
utxo' -> UTxO Era -> Property
utxoIsThunkFree UTxOType Tx
UTxO Era
utxo'

-- NOTE: The following three properties use raw ledger-generated transactions
-- (covering datums, multi-assets and reference scripts) which are large, so
-- the number of cases is capped to keep the suite fast.

prop_utxoFromTxThunkFree :: Property
prop_utxoFromTxThunkFree :: Property
prop_utxoFromTxThunkFree =
  Int -> Property -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
20 (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    Gen Tx -> (Tx -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (forall a. Arbitrary a => Gen a
arbitrary @Tx) ((Tx -> Property) -> Property) -> (Tx -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Tx
tx ->
      UTxO Era -> Property
utxoIsThunkFree (Tx -> UTxOType Tx
forall tx. IsTx tx => tx -> UTxOType tx
utxoFromTx Tx
tx)

prop_adjustUTxOThunkFree :: Property
prop_adjustUTxOThunkFree :: Property
prop_adjustUTxOThunkFree =
  Int -> Property -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
20 (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    Gen (Tx, UTxO Era) -> ((Tx, UTxO Era) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (Tx, UTxO Era)
forall a. Arbitrary a => Gen a
arbitrary (((Tx, UTxO Era) -> Property) -> Property)
-> ((Tx, UTxO Era) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(Tx
tx, UTxO Era
utxo) ->
      -- Force the input first: adjustUTxO only guarantees a thunk-free
      -- result for a thunk-free input, since carried-over entries are
      -- moved by reference, not rebuilt.
      UTxO Era -> Property
utxoIsThunkFree (Tx -> UTxO Era -> UTxO Era
adjustUTxO Tx
tx (UTxO Era -> UTxO Era
forceUTxO UTxO Era
utxo))

prop_applyTxToThunkFree :: Property
prop_applyTxToThunkFree :: Property
prop_applyTxToThunkFree =
  Int -> Property -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
20 (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    Gen (Tx, UTxO Era) -> ((Tx, UTxO Era) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (Tx, UTxO Era)
forall a. Arbitrary a => Gen a
arbitrary (((Tx, UTxO Era) -> Property) -> Property)
-> ((Tx, UTxO Era) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(Tx
tx, UTxO Era
utxo) ->
      UTxO Era -> Property
utxoIsThunkFree (forall tx. IsTx tx => tx -> UTxOType tx -> UTxOType tx
applyTxTo @Tx Tx
tx (UTxO Era -> UTxO Era
forceUTxO UTxO Era
utxo))

-- NOTE: Deserialization is an ingress point for UTxO into the head logic
-- (persisted state, network messages, client API), so decoding must yield
-- thunk-free values without relying on the input having been forced.

prop_jsonDecodeThunkFree :: Property
prop_jsonDecodeThunkFree :: Property
prop_jsonDecodeThunkFree =
  Int -> Property -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
20 (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    Gen (UTxO Era) -> (UTxO Era -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (forall a. Arbitrary a => Gen a
arbitrary @UTxO) ((UTxO Era -> Property) -> Property)
-> (UTxO Era -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \UTxO Era
utxo ->
      case LByteString -> Either String (UTxO Era)
forall a. FromJSON a => LByteString -> Either String a
Aeson.eitherDecode (UTxO Era -> LByteString
forall a. ToJSON a => a -> LByteString
Aeson.encode UTxO Era
utxo) of
        Left String
err -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"decoding failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err)
        Right UTxO Era
utxo' -> UTxO Era -> Property
utxoIsThunkFree UTxO Era
utxo'

prop_cborDecodeThunkFree :: Property
prop_cborDecodeThunkFree :: Property
prop_cborDecodeThunkFree =
  Int -> Property -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
20 (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    Gen (UTxO Era) -> (UTxO Era -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (forall a. Arbitrary a => Gen a
arbitrary @UTxO) ((UTxO Era -> Property) -> Property)
-> (UTxO Era -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \UTxO Era
utxo ->
      case ByteString -> Either DecoderError (UTxO Era)
forall a. FromCBOR a => ByteString -> Either DecoderError a
decodeFull' (UTxO Era -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize' UTxO Era
utxo) of
        Left DecoderError
err -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"decoding failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> DecoderError -> String
forall b a. (Show a, IsString b) => a -> b
show DecoderError
err)
        Right UTxO Era
utxo' -> UTxO Era -> Property
utxoIsThunkFree UTxO Era
utxo'

-- | A realistic multi-era 'EraHistory' mimicking mainnet/testnet where:
-- - Byron era: 21600 slots/epoch, 20s/slot, runs for 208 epochs (4,492,800 slots)
-- - Shelley+ era: 432000 slots/epoch, 1s/slot, open-ended
--
-- This causes slot-to-time conversions to differ from a simple fixedEpochInfo
-- because Byron slots are 20x longer than Shelley slots.
multiEraHistory :: EraHistory
multiEraHistory :: EraHistory
multiEraHistory =
  Interpreter (CardanoEras StandardCrypto) -> EraHistory
forall (xs :: [*]).
(CardanoBlock StandardCrypto ~ HardForkBlock xs) =>
Interpreter xs -> EraHistory
EraHistory (Summary (CardanoEras StandardCrypto)
-> Interpreter (CardanoEras StandardCrypto)
forall (xs :: [*]). Summary xs -> Interpreter xs
mkInterpreter Summary (CardanoEras StandardCrypto)
summary)
 where
  byronSlotsPerEpoch :: Word64
byronSlotsPerEpoch = Word64
21600
  byronEpochs :: Word64
byronEpochs = Word64
208
  byronSlots :: Word64
byronSlots = Word64
byronSlotsPerEpoch Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
byronEpochs -- 4,492,800
  byronSlotLength :: SlotLength
byronSlotLength = NominalDiffTime -> SlotLength
mkSlotLength NominalDiffTime
20
  byronDurationSeconds :: NominalDiffTime
byronDurationSeconds = Word64 -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
byronSlots NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
20 -- 89,856,000 seconds
  summary :: Summary (CardanoEras StandardCrypto)
  summary :: Summary (CardanoEras StandardCrypto)
summary =
    NonEmpty (CardanoEras StandardCrypto) EraSummary
-> Summary (CardanoEras StandardCrypto)
forall (xs :: [*]). NonEmpty xs EraSummary -> Summary xs
Summary (NonEmpty (CardanoEras StandardCrypto) EraSummary
 -> Summary (CardanoEras StandardCrypto))
-> NonEmpty (CardanoEras StandardCrypto) EraSummary
-> Summary (CardanoEras StandardCrypto)
forall a b. (a -> b) -> a -> b
$
      EraSummary
-> NonEmpty (CardanoShelleyEras StandardCrypto) EraSummary
-> NonEmpty (CardanoEras StandardCrypto) EraSummary
forall a (xs1 :: [*]) x.
a -> NonEmpty xs1 a -> NonEmpty (x : xs1) a
NonEmptyCons
        EraSummary
byronEra
        ( EraSummary
-> NonEmpty (CardanoShelleyEras StandardCrypto) EraSummary
forall a x (xs1 :: [*]). a -> NonEmpty (x : xs1) a
NonEmptyOne EraSummary
shelleyEra
        )

  byronEra :: EraSummary
byronEra =
    EraSummary
      { eraStart :: Bound
eraStart = Bound
initBound
      , eraEnd :: EraEnd
eraEnd =
          Bound -> EraEnd
EraEnd
            Bound
              { boundTime :: RelativeTime
boundTime = NominalDiffTime -> RelativeTime
RelativeTime NominalDiffTime
byronDurationSeconds
              , boundSlot :: SlotNo
boundSlot = Word64 -> SlotNo
SlotNo Word64
byronSlots
              , boundEpoch :: EpochNo
boundEpoch = Word64 -> EpochNo
EpochNo Word64
byronEpochs
              , boundPerasRound :: PerasEnabled PerasRoundNo
boundPerasRound = PerasEnabled PerasRoundNo
forall a. PerasEnabled a
NoPerasEnabled
              }
      , eraParams :: EraParams
eraParams =
          EraParams
            { eraEpochSize :: EpochSize
eraEpochSize = Word64 -> EpochSize
EpochSize Word64
byronSlotsPerEpoch
            , eraSlotLength :: SlotLength
eraSlotLength = SlotLength
byronSlotLength
            , eraSafeZone :: SafeZone
eraSafeZone = Word64 -> SafeZone
StandardSafeZone (Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
byronSlotsPerEpoch)
            , eraGenesisWin :: GenesisWindow
eraGenesisWin = Word64 -> GenesisWindow
GenesisWindow (Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
byronSlotsPerEpoch)
            , eraPerasRoundLength :: PerasEnabled PerasRoundLength
eraPerasRoundLength = PerasEnabled PerasRoundLength
forall a. PerasEnabled a
NoPerasEnabled
            }
      }

  shelleyEra :: EraSummary
shelleyEra =
    EraSummary
      { eraStart :: Bound
eraStart =
          Bound
            { boundTime :: RelativeTime
boundTime = NominalDiffTime -> RelativeTime
RelativeTime NominalDiffTime
byronDurationSeconds
            , boundSlot :: SlotNo
boundSlot = Word64 -> SlotNo
SlotNo Word64
byronSlots
            , boundEpoch :: EpochNo
boundEpoch = Word64 -> EpochNo
EpochNo Word64
byronEpochs
            , boundPerasRound :: PerasEnabled PerasRoundNo
boundPerasRound = PerasEnabled PerasRoundNo
forall a. PerasEnabled a
NoPerasEnabled
            }
      , eraEnd :: EraEnd
eraEnd = EraEnd
EraUnbounded
      , eraParams :: EraParams
eraParams =
          EraParams
            { eraEpochSize :: EpochSize
eraEpochSize = Word64 -> EpochSize
EpochSize Word64
432000
            , eraSlotLength :: SlotLength
eraSlotLength = NominalDiffTime -> SlotLength
mkSlotLength NominalDiffTime
1
            , eraSafeZone :: SafeZone
eraSafeZone = SafeZone
UnsafeIndefiniteSafeZone
            , eraGenesisWin :: GenesisWindow
eraGenesisWin = Word64 -> GenesisWindow
GenesisWindow Word64
432000
            , eraPerasRoundLength :: PerasEnabled PerasRoundLength
eraPerasRoundLength = PerasEnabled PerasRoundLength
forall a. PerasEnabled a
NoPerasEnabled
            }
      }

-- | Generate 'HashableScriptData' whose CBOR uses a definite-length array for
-- constructor fields instead of the Plutus-canonical indefinite-length form.
-- Both encodings are valid on L1, but cardano-api's 'FromJSON' re-canonicalises,
-- producing a different hash — the root cause of the replay crash-loop.
genNonCanonicalHashableScriptData :: Gen HashableScriptData
genNonCanonicalHashableScriptData :: Gen HashableScriptData
genNonCanonicalHashableScriptData = do
  Int
constrIdx <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
6 :: Int)
  [Int]
args <- Gen Int -> Gen [Int]
forall a. Gen a -> Gen [a]
listOf1 (Gen Int -> Gen [Int]) -> Gen Int -> Gen [Int]
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
23 :: Int)
  let tagBytes :: [Word8]
tagBytes = [Word8
0xd8, Word8
0x79 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
constrIdx] :: [Word8]
      arrayHdr :: [Word8]
arrayHdr = [Word8
0x80 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
args)] :: [Word8]
      argBytes :: [Word8]
argBytes = (Int -> Word8) -> [Int] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Int]
args :: [Word8]
      bytes :: ByteString
bytes = [Word8] -> ByteString
BS.pack ([Word8]
tagBytes [Word8] -> [Word8] -> [Word8]
forall a. Semigroup a => a -> a -> a
<> [Word8]
arrayHdr [Word8] -> [Word8] -> [Word8]
forall a. Semigroup a => a -> a -> a
<> [Word8]
argBytes)
  case AsType HashableScriptData
-> ByteString -> Either DecoderError HashableScriptData
forall a.
SerialiseAsCBOR a =>
AsType a -> ByteString -> Either DecoderError a
deserialiseFromCBOR AsType HashableScriptData
AsHashableScriptData ByteString
bytes of
    Left DecoderError
_ -> Gen HashableScriptData
genNonCanonicalHashableScriptData
    Right HashableScriptData
hsd -> HashableScriptData -> Gen HashableScriptData
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashableScriptData
hsd