{-# LANGUAGE DuplicateRecordFields #-}

module Hydra.Chain.Direct.WalletSpec where

import Hydra.Prelude
import Test.Hydra.Prelude

import Cardano.Ledger.Api (AlonzoEraTxWits (rdmrsTxWitsL), ConwayEra, EraTx (getMinFeeTx, witsTxL), EraTxBody (feeTxBodyL, inputsTxBodyL), PParams, bodyTxL, coinTxOutL, outputsTxBodyL)
import Cardano.Ledger.Babbage.Tx (AlonzoTx (..))
import Cardano.Ledger.Babbage.TxBody (BabbageTxOut (..))
import Cardano.Ledger.BaseTypes qualified as Ledger
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.TxBody (ConwayTxBody (..))
import Cardano.Ledger.Core (Tx, Value)
import Cardano.Ledger.Hashes (hashAnnotated)
import Cardano.Ledger.Shelley.API qualified as Ledger
import Cardano.Ledger.Slot (EpochInfo)
import Cardano.Ledger.Val (Val (..), invert)
import Control.Concurrent (newEmptyMVar, putMVar, takeMVar)
import Control.Lens (view, (.~), (<>~), (^.))
import Control.Tracer (nullTracer)
import Data.Map.Strict qualified as Map
import Data.Sequence.Strict qualified as StrictSeq
import Data.Set qualified as Set
import Hydra.Cardano.Api (
  LedgerEra,
  PaymentCredential (PaymentCredentialByKey),
  PaymentKey,
  VerificationKey,
  fromLedgerTx,
  fromLedgerTxOut,
  fromLedgerUTxO,
  genTxIn,
  selectLovelace,
  toLedgerTxIn,
  toLedgerUTxO,
  txOutValue,
  verificationKeyHash,
 )
import Hydra.Cardano.Api qualified as Api
import Hydra.Cardano.Api.Prelude (fromShelleyPaymentCredential)
import Hydra.Cardano.Api.Pretty (renderTx)
import Hydra.Cardano.Api.Tx (signTx, toLedgerTx)
import Hydra.Chain.CardanoClient (QueryPoint (..))
import Hydra.Chain.Direct.Wallet (
  Address,
  ChainQuery,
  TinyWallet (..),
  TxIn,
  TxOut,
  WalletInfoOnChain (..),
  applyTxs,
  coverFee_,
  findLargestUTxO,
  newTinyWallet,
 )
import Test.Hydra.Tx.Fixture qualified as Fixture
import Test.Hydra.Tx.Gen (genKeyPair, genOneUTxOFor, genSigningKey)
import Test.QuickCheck (
  Property,
  checkCoverage,
  conjoin,
  counterexample,
  cover,
  forAll,
  forAllBlind,
  frequency,
  generate,
  getSize,
  property,
  resize,
  scale,
  suchThat,
  vectorOf,
  (.&&.),
 )
import Prelude qualified

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
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"genTxsSpending / genUTxO" (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
"are well-suited for testing" Property
prop_wellSuitedGenerators

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"applyTxs" (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
"only reduces the UTXO set when no address is ours" Property
prop_reducesWhenNotOurs
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Seen inputs are consumed and not in the resulting UTXO" Property
prop_seenInputsAreConsumed

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"coverFee" (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
"sets min utxo values" Property
prop_setsMinUTxOValue
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"balances transaction with fees" Property
prop_balanceTransaction
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"prefers largest utxo" Property
prop_picksLargestUTxOToPayTheFees

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"newTinyWallet" (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
"initialises wallet by querying UTxO" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> ((VerificationKey PaymentKey, SigningKey PaymentKey) -> IO ())
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair (((VerificationKey PaymentKey, SigningKey PaymentKey) -> IO ())
 -> Property)
-> ((VerificationKey PaymentKey, SigningKey PaymentKey) -> IO ())
-> Property
forall a b. (a -> b) -> a -> b
$ \(VerificationKey PaymentKey
vk, SigningKey PaymentKey
sk) -> do
        TinyWallet IO
wallet <- Tracer IO TinyWalletLog
-> NetworkId
-> (VerificationKey PaymentKey, SigningKey PaymentKey)
-> ChainQuery IO
-> IO (EpochInfo (Either Text))
-> IO (PParams ConwayEra)
-> IO (TinyWallet IO)
newTinyWallet Tracer IO TinyWalletLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer NetworkId
Fixture.testNetworkId (VerificationKey PaymentKey
vk, SigningKey PaymentKey
sk) (VerificationKey PaymentKey -> ChainQuery IO
mockChainQuery VerificationKey PaymentKey
vk) IO (EpochInfo (Either Text))
mockQueryEpochInfo IO (PParams ConwayEra)
mockQueryPParams
        Map TxIn (BabbageTxOut ConwayEra)
utxo <- STM IO (Map TxIn (BabbageTxOut ConwayEra))
-> IO (Map TxIn (BabbageTxOut ConwayEra))
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TinyWallet IO -> STM IO (Map TxIn TxOut)
forall (m :: * -> *). TinyWallet m -> STM m (Map TxIn TxOut)
getUTxO TinyWallet IO
wallet)
        Map TxIn (BabbageTxOut ConwayEra)
utxo Map TxIn (BabbageTxOut ConwayEra)
-> (Map TxIn (BabbageTxOut ConwayEra) -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \Map TxIn (BabbageTxOut ConwayEra)
m -> Map TxIn (BabbageTxOut ConwayEra) -> Int
forall k a. Map k a -> Int
Map.size Map TxIn (BabbageTxOut ConwayEra)
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0

    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"re-queries UTxO from the tip, even on reset" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> ((VerificationKey PaymentKey, SigningKey PaymentKey) -> IO ())
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair (((VerificationKey PaymentKey, SigningKey PaymentKey) -> IO ())
 -> Property)
-> ((VerificationKey PaymentKey, SigningKey PaymentKey) -> IO ())
-> Property
forall a b. (a -> b) -> a -> b
$ \(VerificationKey PaymentKey
vk, SigningKey PaymentKey
sk) -> do
        (ChainQuery IO
queryFn, QueryPoint -> IO ()
assertQueryPoint) <- VerificationKey PaymentKey
-> IO (ChainQuery IO, QueryPoint -> IO ())
setupQuery VerificationKey PaymentKey
vk
        TinyWallet IO
wallet <- Tracer IO TinyWalletLog
-> NetworkId
-> (VerificationKey PaymentKey, SigningKey PaymentKey)
-> ChainQuery IO
-> IO (EpochInfo (Either Text))
-> IO (PParams ConwayEra)
-> IO (TinyWallet IO)
newTinyWallet Tracer IO TinyWalletLog
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer NetworkId
Fixture.testNetworkId (VerificationKey PaymentKey
vk, SigningKey PaymentKey
sk) ChainQuery IO
queryFn IO (EpochInfo (Either Text))
mockQueryEpochInfo IO (PParams ConwayEra)
mockQueryPParams
        QueryPoint -> IO ()
assertQueryPoint QueryPoint
QueryTip
        TinyWallet IO -> IO ()
forall (m :: * -> *). TinyWallet m -> m ()
reset TinyWallet IO
wallet
        QueryPoint -> IO ()
assertQueryPoint QueryPoint
QueryTip

setupQuery ::
  VerificationKey PaymentKey ->
  IO (ChainQuery IO, QueryPoint -> Expectation)
setupQuery :: VerificationKey PaymentKey
-> IO (ChainQuery IO, QueryPoint -> IO ())
setupQuery VerificationKey PaymentKey
vk = do
  MVar QueryPoint
queryPointMVar <- IO (MVar QueryPoint)
forall a. IO (MVar a)
newEmptyMVar
  (ChainQuery IO, QueryPoint -> IO ())
-> IO (ChainQuery IO, QueryPoint -> IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MVar QueryPoint -> ChainQuery IO
queryFn MVar QueryPoint
queryPointMVar, MVar QueryPoint -> QueryPoint -> IO ()
forall {a}. (Show a, Eq a) => MVar a -> a -> IO ()
assertQueryPoint MVar QueryPoint
queryPointMVar)
 where
  queryFn :: MVar QueryPoint -> ChainQuery IO
queryFn MVar QueryPoint
queryPointMVar QueryPoint
point Address ShelleyAddr
_addr = do
    MVar QueryPoint -> QueryPoint -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar QueryPoint
queryPointMVar QueryPoint
point
    Map TxIn (TxOut ConwayEra)
walletUTxO <- UTxO ConwayEra -> Map TxIn (TxOut ConwayEra)
forall era. UTxO era -> Map TxIn (TxOut era)
Ledger.unUTxO (UTxO ConwayEra -> Map TxIn (TxOut ConwayEra))
-> (UTxO -> UTxO ConwayEra) -> UTxO -> Map TxIn (TxOut ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO -> UTxO LedgerEra
UTxO -> UTxO ConwayEra
toLedgerUTxO (UTxO -> Map TxIn (TxOut ConwayEra))
-> IO UTxO -> IO (Map TxIn (TxOut ConwayEra))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen UTxO -> IO UTxO
forall a. Gen a -> IO a
generate (VerificationKey PaymentKey -> Gen UTxO
genOneUTxOFor VerificationKey PaymentKey
vk)
    ChainPoint
tip <- Gen ChainPoint -> IO ChainPoint
forall a. Gen a -> IO a
generate Gen ChainPoint
forall a. Arbitrary a => Gen a
arbitrary
    WalletInfoOnChain -> IO WalletInfoOnChain
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WalletInfoOnChain -> IO WalletInfoOnChain)
-> WalletInfoOnChain -> IO WalletInfoOnChain
forall a b. (a -> b) -> a -> b
$
      WalletInfoOnChain
        { Map TxIn TxOut
Map TxIn (TxOut ConwayEra)
walletUTxO :: Map TxIn (TxOut ConwayEra)
$sel:walletUTxO:WalletInfoOnChain :: Map TxIn TxOut
walletUTxO
        , $sel:systemStart:WalletInfoOnChain :: SystemStart
systemStart = SystemStart
Fixture.systemStart
        , ChainPoint
tip :: ChainPoint
$sel:tip:WalletInfoOnChain :: ChainPoint
tip
        }

  assertQueryPoint :: MVar a -> a -> IO ()
assertQueryPoint MVar a
queryPointMVar a
point =
    MVar a -> IO a
forall a. MVar a -> IO a
takeMVar MVar a
queryPointMVar IO a -> a -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` a
point

mockChainQuery :: VerificationKey PaymentKey -> ChainQuery IO
mockChainQuery :: VerificationKey PaymentKey -> ChainQuery IO
mockChainQuery VerificationKey PaymentKey
vk QueryPoint
_point Address ShelleyAddr
addr = do
  let Api.ShelleyAddress Network
_ PaymentCredential
cred StakeReference
_ = Address ShelleyAddr
addr
  PaymentCredential -> PaymentCredential
fromShelleyPaymentCredential PaymentCredential
cred PaymentCredential -> PaymentCredential -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Hash PaymentKey -> PaymentCredential
PaymentCredentialByKey (VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash VerificationKey PaymentKey
vk)
  Map TxIn (TxOut ConwayEra)
walletUTxO <- UTxO ConwayEra -> Map TxIn (TxOut ConwayEra)
forall era. UTxO era -> Map TxIn (TxOut era)
Ledger.unUTxO (UTxO ConwayEra -> Map TxIn (TxOut ConwayEra))
-> (UTxO -> UTxO ConwayEra) -> UTxO -> Map TxIn (TxOut ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO -> UTxO LedgerEra
UTxO -> UTxO ConwayEra
toLedgerUTxO (UTxO -> Map TxIn (TxOut ConwayEra))
-> IO UTxO -> IO (Map TxIn (TxOut ConwayEra))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen UTxO -> IO UTxO
forall a. Gen a -> IO a
generate (VerificationKey PaymentKey -> Gen UTxO
genOneUTxOFor VerificationKey PaymentKey
vk)
  ChainPoint
tip <- Gen ChainPoint -> IO ChainPoint
forall a. Gen a -> IO a
generate Gen ChainPoint
forall a. Arbitrary a => Gen a
arbitrary
  WalletInfoOnChain -> IO WalletInfoOnChain
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WalletInfoOnChain -> IO WalletInfoOnChain)
-> WalletInfoOnChain -> IO WalletInfoOnChain
forall a b. (a -> b) -> a -> b
$
    WalletInfoOnChain
      { Map TxIn TxOut
Map TxIn (TxOut ConwayEra)
$sel:walletUTxO:WalletInfoOnChain :: Map TxIn TxOut
walletUTxO :: Map TxIn (TxOut ConwayEra)
walletUTxO
      , $sel:systemStart:WalletInfoOnChain :: SystemStart
systemStart = SystemStart
Fixture.systemStart
      , ChainPoint
$sel:tip:WalletInfoOnChain :: ChainPoint
tip :: ChainPoint
tip
      }

mockQueryEpochInfo :: IO (EpochInfo (Either Text))
mockQueryEpochInfo :: IO (EpochInfo (Either Text))
mockQueryEpochInfo = EpochInfo (Either Text) -> IO (EpochInfo (Either Text))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EpochInfo (Either Text)
forall (m :: * -> *). Monad m => EpochInfo m
Fixture.epochInfo

mockQueryPParams :: IO (PParams ConwayEra)
mockQueryPParams :: IO (PParams ConwayEra)
mockQueryPParams = PParams ConwayEra -> IO (PParams ConwayEra)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PParams LedgerEra
PParams ConwayEra
Fixture.pparams

--
-- Generators
--

prop_wellSuitedGenerators ::
  Property
prop_wellSuitedGenerators :: Property
prop_wellSuitedGenerators =
  Gen (Map TxIn (BabbageTxOut ConwayEra))
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (Map TxIn (BabbageTxOut ConwayEra))
Gen (Map TxIn TxOut)
genUTxO ((Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property)
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Map TxIn (BabbageTxOut ConwayEra)
utxo ->
    Gen [AlonzoTx ConwayEra]
-> ([AlonzoTx ConwayEra] -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Map TxIn TxOut -> Gen [Tx LedgerEra]
genTxsSpending Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo) (([AlonzoTx ConwayEra] -> Property) -> Property)
-> ([AlonzoTx ConwayEra] -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \[AlonzoTx ConwayEra]
txs ->
      Bool -> Property
forall prop. Testable prop => prop -> Property
property ([AlonzoTx ConwayEra] -> Bool
forall {t :: * -> *} {a}. Foldable t => t a -> Bool
smallTxSets [AlonzoTx ConwayEra]
txs)
        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
0.3 (Map TxIn (BabbageTxOut ConwayEra) -> [AlonzoTx ConwayEra] -> Bool
noneIsOurs Map TxIn (BabbageTxOut ConwayEra)
utxo [AlonzoTx ConwayEra]
txs) String
"has no tx that are ours"
        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
0.2 (Map TxIn (BabbageTxOut ConwayEra) -> [AlonzoTx ConwayEra] -> Bool
someAreDependent Map TxIn (BabbageTxOut ConwayEra)
utxo [AlonzoTx ConwayEra]
txs) String
"has dependent txs"
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& Property -> Property
forall prop. Testable prop => prop -> Property
checkCoverage
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"All TxIns: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show (Set TxIn -> Int
forall a. Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Set TxIn -> Int) -> Set TxIn -> Int
forall a b. (a -> b) -> a -> b
$ [Tx LedgerEra] -> Set TxIn
allTxIns [Tx LedgerEra]
[AlonzoTx ConwayEra]
txs))
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"All TxOuts: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show ([TxOut] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TxOut] -> Int) -> [TxOut] -> Int
forall a b. (a -> b) -> a -> b
$ [Tx LedgerEra] -> [TxOut]
allTxOuts [Tx LedgerEra]
[AlonzoTx ConwayEra]
txs))
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Our TxIns: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show ([TxIn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TxIn] -> Int) -> [TxIn] -> Int
forall a b. (a -> b) -> a -> b
$ Map TxIn TxOut -> [Tx LedgerEra] -> [TxIn]
ourDirectInputs Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo [Tx LedgerEra]
[AlonzoTx ConwayEra]
txs))
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Our TxOuts: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show ([TxOut] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TxOut] -> Int) -> [TxOut] -> Int
forall a b. (a -> b) -> a -> b
$ Map TxIn TxOut -> [Tx LedgerEra] -> [TxOut]
ourOutputs Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo [Tx LedgerEra]
[AlonzoTx ConwayEra]
txs))
 where
  smallTxSets :: t a -> Bool
smallTxSets t a
txs =
    t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
txs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
10

  noneIsOurs :: Map TxIn (BabbageTxOut ConwayEra) -> [AlonzoTx ConwayEra] -> Bool
noneIsOurs Map TxIn (BabbageTxOut ConwayEra)
utxo [AlonzoTx ConwayEra]
txs =
    [TxIn] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Map TxIn TxOut -> [Tx LedgerEra] -> [TxIn]
ourDirectInputs Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo [Tx LedgerEra]
[AlonzoTx ConwayEra]
txs) Bool -> Bool -> Bool
&& [BabbageTxOut ConwayEra] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Map TxIn TxOut -> [Tx LedgerEra] -> [TxOut]
ourOutputs Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo [Tx LedgerEra]
[AlonzoTx ConwayEra]
txs)

  someAreDependent :: Map TxIn (BabbageTxOut ConwayEra) -> [AlonzoTx ConwayEra] -> Bool
someAreDependent Map TxIn (BabbageTxOut ConwayEra)
utxo [AlonzoTx ConwayEra]
txs =
    [TxIn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Map TxIn TxOut -> [Tx LedgerEra] -> [TxIn]
ourDirectInputs Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo [Tx LedgerEra]
[AlonzoTx ConwayEra]
txs) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [BabbageTxOut ConwayEra] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Map TxIn TxOut -> [Tx LedgerEra] -> [TxOut]
ourOutputs Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo [Tx LedgerEra]
[AlonzoTx ConwayEra]
txs)

--
-- applyTxs
--

prop_reducesWhenNotOurs :: Property
prop_reducesWhenNotOurs :: Property
prop_reducesWhenNotOurs =
  Gen (Map TxIn (BabbageTxOut ConwayEra))
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (Map TxIn (BabbageTxOut ConwayEra))
Gen (Map TxIn TxOut)
genUTxO ((Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property)
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Map TxIn (BabbageTxOut ConwayEra)
utxo ->
    Gen [AlonzoTx ConwayEra]
-> ([AlonzoTx ConwayEra] -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Map TxIn TxOut -> Gen [Tx LedgerEra]
genTxsSpending Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo) (([AlonzoTx ConwayEra] -> Property) -> Property)
-> ([AlonzoTx ConwayEra] -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \[AlonzoTx ConwayEra]
txs ->
      let utxo' :: Map TxIn TxOut
utxo' = [Tx] -> (Address -> Bool) -> Map TxIn TxOut -> Map TxIn TxOut
applyTxs (Tx LedgerEra -> Tx
AlonzoTx ConwayEra -> Tx
forall era.
IsShelleyBasedEra era =>
Tx (ShelleyLedgerEra era) -> Tx era
fromLedgerTx (AlonzoTx ConwayEra -> Tx) -> [AlonzoTx ConwayEra] -> [Tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AlonzoTx ConwayEra]
txs) (Bool -> Address -> Bool
forall a b. a -> b -> a
const Bool
False) Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo
       in (Map TxIn (BabbageTxOut ConwayEra) -> Int
forall a. Map TxIn a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Map TxIn (BabbageTxOut ConwayEra) -> Int
forall a. Map TxIn a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Map TxIn (BabbageTxOut ConwayEra)
utxo)
            Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"New UTXO: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Map TxIn (BabbageTxOut ConwayEra) -> String
forall b a. (Show a, IsString b) => a -> b
show Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo')
            Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"UTXO size:     " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show (Map TxIn (BabbageTxOut ConwayEra) -> Int
forall a. Map TxIn a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Map TxIn (BabbageTxOut ConwayEra)
utxo))
            Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"New UTXO size: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show (Map TxIn (BabbageTxOut ConwayEra) -> Int
forall a. Map TxIn a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo'))

prop_seenInputsAreConsumed :: Property
prop_seenInputsAreConsumed :: Property
prop_seenInputsAreConsumed =
  Gen (Map TxIn (BabbageTxOut ConwayEra))
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (Map TxIn (BabbageTxOut ConwayEra))
Gen (Map TxIn TxOut)
genUTxO ((Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property)
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Map TxIn (BabbageTxOut ConwayEra)
utxo ->
    Gen [AlonzoTx ConwayEra]
-> ([AlonzoTx ConwayEra] -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Map TxIn TxOut -> Gen [Tx LedgerEra]
genTxsSpending Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo) (([AlonzoTx ConwayEra] -> Property) -> Property)
-> ([AlonzoTx ConwayEra] -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \[AlonzoTx ConwayEra]
txs ->
      let utxo' :: Map TxIn TxOut
utxo' = [Tx] -> (Address -> Bool) -> Map TxIn TxOut -> Map TxIn TxOut
applyTxs (Tx LedgerEra -> Tx
AlonzoTx ConwayEra -> Tx
forall era.
IsShelleyBasedEra era =>
Tx (ShelleyLedgerEra era) -> Tx era
fromLedgerTx (AlonzoTx ConwayEra -> Tx) -> [AlonzoTx ConwayEra] -> [Tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AlonzoTx ConwayEra]
txs) (Map TxIn TxOut -> Address -> Bool
isOurs Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo) Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo
          seenInputs :: Set TxIn
seenInputs = [Item (Set TxIn)] -> Set TxIn
forall l. IsList l => [Item l] -> l
fromList ([Item (Set TxIn)] -> Set TxIn) -> [Item (Set TxIn)] -> Set TxIn
forall a b. (a -> b) -> a -> b
$ Map TxIn TxOut -> [Tx LedgerEra] -> [TxIn]
ourDirectInputs Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo [Tx LedgerEra]
[AlonzoTx ConwayEra]
txs
       in Map TxIn (BabbageTxOut ConwayEra) -> Bool
forall a. Map TxIn a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Map TxIn (BabbageTxOut ConwayEra)
-> Set TxIn -> Map TxIn (BabbageTxOut ConwayEra)
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo' Set TxIn
seenInputs)
            Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Seen inputs: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Set TxIn -> String
forall b a. (Show a, IsString b) => a -> b
show Set TxIn
seenInputs)
            Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"New UTXO:    " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Map TxIn (BabbageTxOut ConwayEra) -> String
forall b a. (Show a, IsString b) => a -> b
show Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo')

--
-- coverFee
--

prop_setsMinUTxOValue :: Property
prop_setsMinUTxOValue :: Property
prop_setsMinUTxOValue =
  Gen (AlonzoTx ConwayEra)
-> (AlonzoTx ConwayEra -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Int -> Gen (AlonzoTx ConwayEra) -> Gen (AlonzoTx ConwayEra)
forall a. HasCallStack => Int -> Gen a -> Gen a
resize Int
0 Gen (Tx LedgerEra)
Gen (AlonzoTx ConwayEra)
genLedgerTx) ((AlonzoTx ConwayEra -> Property) -> Property)
-> (AlonzoTx ConwayEra -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \AlonzoTx ConwayEra
tx ->
    Gen (Map TxIn (BabbageTxOut ConwayEra))
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Gen (Map TxIn TxOut) -> Gen (Map TxIn TxOut)
forall a. Gen a -> Gen a
reasonablySized (Gen (Map TxIn TxOut) -> Gen (Map TxIn TxOut))
-> Gen (Map TxIn TxOut) -> Gen (Map TxIn TxOut)
forall a b. (a -> b) -> a -> b
$ Tx LedgerEra -> Gen (Map TxIn TxOut)
genOutputsForInputs Tx LedgerEra
AlonzoTx ConwayEra
tx) ((Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property)
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Map TxIn (BabbageTxOut ConwayEra)
lookupUTxO ->
      Gen (Map TxIn (BabbageTxOut ConwayEra))
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Gen (Map TxIn (BabbageTxOut ConwayEra))
-> Gen (Map TxIn (BabbageTxOut ConwayEra))
forall a. Gen a -> Gen a
reasonablySized Gen (Map TxIn (BabbageTxOut ConwayEra))
Gen (Map TxIn TxOut)
genUTxO) ((Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property)
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Map TxIn (BabbageTxOut ConwayEra)
walletUTxO ->
        Gen (TxOut ConwayEra) -> (TxOut ConwayEra -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (TxOut ConwayEra)
genTxOutWithoutADA ((TxOut ConwayEra -> Property) -> Property)
-> (TxOut ConwayEra -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \TxOut ConwayEra
txOutWithoutADA -> do
          let newTx :: AlonzoTx ConwayEra
newTx = AlonzoTx ConwayEra
tx AlonzoTx ConwayEra
-> (AlonzoTx ConwayEra -> AlonzoTx ConwayEra) -> AlonzoTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxBody ConwayEra -> Identity (TxBody ConwayEra))
-> Tx ConwayEra -> Identity (Tx ConwayEra)
(TxBody ConwayEra -> Identity (TxBody ConwayEra))
-> AlonzoTx ConwayEra -> Identity (AlonzoTx ConwayEra)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx ConwayEra) (TxBody ConwayEra)
bodyTxL ((TxBody ConwayEra -> Identity (TxBody ConwayEra))
 -> AlonzoTx ConwayEra -> Identity (AlonzoTx ConwayEra))
-> ((StrictSeq (TxOut ConwayEra)
     -> Identity (StrictSeq (TxOut ConwayEra)))
    -> TxBody ConwayEra -> Identity (TxBody ConwayEra))
-> (StrictSeq (TxOut ConwayEra)
    -> Identity (StrictSeq (TxOut ConwayEra)))
-> AlonzoTx ConwayEra
-> Identity (AlonzoTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut ConwayEra)
 -> Identity (StrictSeq (TxOut ConwayEra)))
-> TxBody ConwayEra -> Identity (TxBody ConwayEra)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody ConwayEra) (StrictSeq (TxOut ConwayEra))
outputsTxBodyL ((StrictSeq (TxOut ConwayEra)
  -> Identity (StrictSeq (TxOut ConwayEra)))
 -> AlonzoTx ConwayEra -> Identity (AlonzoTx ConwayEra))
-> StrictSeq (TxOut ConwayEra)
-> AlonzoTx ConwayEra
-> AlonzoTx ConwayEra
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ TxOut ConwayEra -> StrictSeq (TxOut ConwayEra)
forall a. a -> StrictSeq a
StrictSeq.singleton TxOut ConwayEra
txOutWithoutADA
          case PParams ConwayEra
-> SystemStart
-> EpochInfo (Either Text)
-> Map TxIn (TxOut ConwayEra)
-> Map TxIn (TxOut ConwayEra)
-> Tx ConwayEra
-> Either ErrCoverFee (Tx ConwayEra)
forall era.
(EraPlutusContext era, EraCertState era, AlonzoEraTx era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era, EraUTxO era,
 BabbageEraTxBody era) =>
PParams era
-> SystemStart
-> EpochInfo (Either Text)
-> Map TxIn (TxOut era)
-> Map TxIn (TxOut era)
-> Tx era
-> Either ErrCoverFee (Tx era)
coverFee_ PParams LedgerEra
PParams ConwayEra
Fixture.pparams SystemStart
Fixture.systemStart EpochInfo (Either Text)
forall (m :: * -> *). Monad m => EpochInfo m
Fixture.epochInfo Map TxIn (BabbageTxOut ConwayEra)
Map TxIn (TxOut ConwayEra)
lookupUTxO Map TxIn (BabbageTxOut ConwayEra)
Map TxIn (TxOut ConwayEra)
walletUTxO Tx ConwayEra
AlonzoTx ConwayEra
newTx of
            Left ErrCoverFee
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
<> ErrCoverFee -> String
forall b a. (Show a, IsString b) => a -> b
show ErrCoverFee
err)
            Right Tx ConwayEra
balancedTx -> do
              let outs :: [TxOut ConwayEra]
outs = StrictSeq (TxOut ConwayEra) -> [TxOut ConwayEra]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (TxOut ConwayEra) -> [TxOut ConwayEra])
-> StrictSeq (TxOut ConwayEra) -> [TxOut ConwayEra]
forall a b. (a -> b) -> a -> b
$ Tx ConwayEra
AlonzoTx ConwayEra
balancedTx AlonzoTx ConwayEra
-> Getting
     (StrictSeq (TxOut ConwayEra))
     (AlonzoTx ConwayEra)
     (StrictSeq (TxOut ConwayEra))
-> StrictSeq (TxOut ConwayEra)
forall s a. s -> Getting a s a -> a
^. (TxBody ConwayEra
 -> Const (StrictSeq (TxOut ConwayEra)) (TxBody ConwayEra))
-> Tx ConwayEra
-> Const (StrictSeq (TxOut ConwayEra)) (Tx ConwayEra)
(TxBody ConwayEra
 -> Const (StrictSeq (TxOut ConwayEra)) (TxBody ConwayEra))
-> AlonzoTx ConwayEra
-> Const (StrictSeq (TxOut ConwayEra)) (AlonzoTx ConwayEra)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx ConwayEra) (TxBody ConwayEra)
bodyTxL ((TxBody ConwayEra
  -> Const (StrictSeq (TxOut ConwayEra)) (TxBody ConwayEra))
 -> AlonzoTx ConwayEra
 -> Const (StrictSeq (TxOut ConwayEra)) (AlonzoTx ConwayEra))
-> ((StrictSeq (TxOut ConwayEra)
     -> Const
          (StrictSeq (TxOut ConwayEra)) (StrictSeq (TxOut ConwayEra)))
    -> TxBody ConwayEra
    -> Const (StrictSeq (TxOut ConwayEra)) (TxBody ConwayEra))
-> Getting
     (StrictSeq (TxOut ConwayEra))
     (AlonzoTx ConwayEra)
     (StrictSeq (TxOut ConwayEra))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut ConwayEra)
 -> Const
      (StrictSeq (TxOut ConwayEra)) (StrictSeq (TxOut ConwayEra)))
-> TxBody ConwayEra
-> Const (StrictSeq (TxOut ConwayEra)) (TxBody ConwayEra)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody ConwayEra) (StrictSeq (TxOut ConwayEra))
outputsTxBodyL
              Bool -> Bool
not ((TxOut ConwayEra -> Bool) -> [TxOut ConwayEra] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\TxOut ConwayEra
o -> TxOut ConwayEra
o TxOut ConwayEra -> Getting Coin (TxOut ConwayEra) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxOut ConwayEra) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut ConwayEra) Coin
coinTxOutL Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
== Coin
forall a. Monoid a => a
mempty) [TxOut ConwayEra]
outs)
                Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"No 0 ADA outputs expected:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [TxOut ConwayEra] -> String
forall b a. (Show a, IsString b) => a -> b
show [TxOut ConwayEra]
outs)
 where
  -- Generate a deliberately "under-valued" TxOut
  genTxOutWithoutADA :: Gen (TxOut ConwayEra)
genTxOutWithoutADA = Gen (TxOut ConwayEra)
forall a. Arbitrary a => Gen a
arbitrary Gen (TxOut ConwayEra)
-> (TxOut ConwayEra -> TxOut ConwayEra) -> Gen (TxOut ConwayEra)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Coin -> Identity Coin)
-> TxOut ConwayEra -> Identity (TxOut ConwayEra)
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut ConwayEra) Coin
coinTxOutL ((Coin -> Identity Coin)
 -> TxOut ConwayEra -> Identity (TxOut ConwayEra))
-> Coin -> TxOut ConwayEra -> TxOut ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
forall a. Monoid a => a
mempty

prop_balanceTransaction :: Property
prop_balanceTransaction :: Property
prop_balanceTransaction =
  Gen (AlonzoTx ConwayEra)
-> (AlonzoTx ConwayEra -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Int -> Gen (AlonzoTx ConwayEra) -> Gen (AlonzoTx ConwayEra)
forall a. HasCallStack => Int -> Gen a -> Gen a
resize Int
0 Gen (Tx LedgerEra)
Gen (AlonzoTx ConwayEra)
genLedgerTx) ((AlonzoTx ConwayEra -> Property) -> Property)
-> (AlonzoTx ConwayEra -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \AlonzoTx ConwayEra
tx ->
    Gen (Map TxIn (BabbageTxOut ConwayEra))
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Gen (Map TxIn TxOut) -> Gen (Map TxIn TxOut)
forall a. Gen a -> Gen a
reasonablySized (Gen (Map TxIn TxOut) -> Gen (Map TxIn TxOut))
-> Gen (Map TxIn TxOut) -> Gen (Map TxIn TxOut)
forall a b. (a -> b) -> a -> b
$ Tx LedgerEra -> Gen (Map TxIn TxOut)
genOutputsForInputs Tx LedgerEra
AlonzoTx ConwayEra
tx) ((Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property)
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Map TxIn (BabbageTxOut ConwayEra)
lookupUTxO ->
      Gen (Map TxIn (BabbageTxOut ConwayEra))
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Gen (Map TxIn (BabbageTxOut ConwayEra))
-> Gen (Map TxIn (BabbageTxOut ConwayEra))
forall a. Gen a -> Gen a
reasonablySized Gen (Map TxIn (BabbageTxOut ConwayEra))
Gen (Map TxIn TxOut)
genUTxO) ((Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property)
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Map TxIn (BabbageTxOut ConwayEra)
walletUTxO ->
        case PParams ConwayEra
-> SystemStart
-> EpochInfo (Either Text)
-> Map TxIn (TxOut ConwayEra)
-> Map TxIn (TxOut ConwayEra)
-> Tx ConwayEra
-> Either ErrCoverFee (Tx ConwayEra)
forall era.
(EraPlutusContext era, EraCertState era, AlonzoEraTx era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era, EraUTxO era,
 BabbageEraTxBody era) =>
PParams era
-> SystemStart
-> EpochInfo (Either Text)
-> Map TxIn (TxOut era)
-> Map TxIn (TxOut era)
-> Tx era
-> Either ErrCoverFee (Tx era)
coverFee_ PParams LedgerEra
PParams ConwayEra
Fixture.pparams SystemStart
Fixture.systemStart EpochInfo (Either Text)
forall (m :: * -> *). Monad m => EpochInfo m
Fixture.epochInfo Map TxIn (BabbageTxOut ConwayEra)
Map TxIn (TxOut ConwayEra)
lookupUTxO Map TxIn (BabbageTxOut ConwayEra)
Map TxIn (TxOut ConwayEra)
walletUTxO Tx ConwayEra
AlonzoTx ConwayEra
tx of
          Left ErrCoverFee
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
<> ErrCoverFee -> String
forall b a. (Show a, IsString b) => a -> b
show ErrCoverFee
err)
          Right Tx ConwayEra
tx' ->
            Gen (SigningKey PaymentKey)
-> (SigningKey PaymentKey -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (SigningKey PaymentKey)
genSigningKey ((SigningKey PaymentKey -> Property) -> Property)
-> (SigningKey PaymentKey -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \SigningKey PaymentKey
sk -> do
              -- NOTE: Testing the signed transaction as adding a witness
              -- changes the fee requirements.
              let signedTx :: Tx LedgerEra
signedTx = Tx -> Tx LedgerEra
forall era. Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx (Tx -> Tx LedgerEra) -> Tx -> Tx LedgerEra
forall a b. (a -> b) -> a -> b
$ SigningKey PaymentKey -> Tx -> Tx
forall era.
IsShelleyBasedEra era =>
SigningKey PaymentKey -> Tx era -> Tx era
signTx SigningKey PaymentKey
sk (Tx LedgerEra -> Tx
forall era.
IsShelleyBasedEra era =>
Tx (ShelleyLedgerEra era) -> Tx era
fromLedgerTx Tx LedgerEra
Tx ConwayEra
tx')
              [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
                [ Map TxIn TxOut -> Tx LedgerEra -> Tx LedgerEra -> Property
isBalanced (Map TxIn (BabbageTxOut ConwayEra)
lookupUTxO Map TxIn (BabbageTxOut ConwayEra)
-> Map TxIn (BabbageTxOut ConwayEra)
-> Map TxIn (BabbageTxOut ConwayEra)
forall a. Semigroup a => a -> a -> a
<> Map TxIn (BabbageTxOut ConwayEra)
walletUTxO) Tx LedgerEra
AlonzoTx ConwayEra
tx Tx LedgerEra
signedTx
                , PParams LedgerEra -> Tx LedgerEra -> Property
hasLowFees PParams LedgerEra
Fixture.pparams Tx LedgerEra
signedTx
                ]
                Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Signed tx: \n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Tx -> String
renderTx (Tx LedgerEra -> Tx
forall era.
IsShelleyBasedEra era =>
Tx (ShelleyLedgerEra era) -> Tx era
fromLedgerTx Tx LedgerEra
signedTx))
                Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Balanced tx: \n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Tx -> String
renderTx (Tx LedgerEra -> Tx
forall era.
IsShelleyBasedEra era =>
Tx (ShelleyLedgerEra era) -> Tx era
fromLedgerTx Tx LedgerEra
Tx ConwayEra
tx'))
          Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Partial tx: \n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Tx -> String
renderTx (Tx LedgerEra -> Tx
forall era.
IsShelleyBasedEra era =>
Tx (ShelleyLedgerEra era) -> Tx era
fromLedgerTx Tx LedgerEra
AlonzoTx ConwayEra
tx))
          Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Lookup UTXO: \n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (Map TxIn (BabbageTxOut ConwayEra) -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty Map TxIn (BabbageTxOut ConwayEra)
lookupUTxO))
          Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Wallet UTXO: \n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (Map TxIn (BabbageTxOut ConwayEra) -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty Map TxIn (BabbageTxOut ConwayEra)
walletUTxO))
          -- XXX: This is not exercising any script cost estimation because
          -- genLedgerTx does not generate txs spending from scripts seemingly.
          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 (AlonzoTx ConwayEra
tx AlonzoTx ConwayEra
-> Getting
     (Redeemers ConwayEra) (AlonzoTx ConwayEra) (Redeemers ConwayEra)
-> Redeemers ConwayEra
forall s a. s -> Getting a s a -> a
^. (TxWits ConwayEra
 -> Const (Redeemers ConwayEra) (TxWits ConwayEra))
-> Tx ConwayEra -> Const (Redeemers ConwayEra) (Tx ConwayEra)
(TxWits ConwayEra
 -> Const (Redeemers ConwayEra) (TxWits ConwayEra))
-> AlonzoTx ConwayEra
-> Const (Redeemers ConwayEra) (AlonzoTx ConwayEra)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx ConwayEra) (TxWits ConwayEra)
witsTxL ((TxWits ConwayEra
  -> Const (Redeemers ConwayEra) (TxWits ConwayEra))
 -> AlonzoTx ConwayEra
 -> Const (Redeemers ConwayEra) (AlonzoTx ConwayEra))
-> ((Redeemers ConwayEra
     -> Const (Redeemers ConwayEra) (Redeemers ConwayEra))
    -> TxWits ConwayEra
    -> Const (Redeemers ConwayEra) (TxWits ConwayEra))
-> Getting
     (Redeemers ConwayEra) (AlonzoTx ConwayEra) (Redeemers ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers ConwayEra
 -> Const (Redeemers ConwayEra) (Redeemers ConwayEra))
-> TxWits ConwayEra
-> Const (Redeemers ConwayEra) (TxWits ConwayEra)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits ConwayEra) (Redeemers ConwayEra)
rdmrsTxWitsL Redeemers ConwayEra -> Redeemers ConwayEra -> Bool
forall a. Eq a => a -> a -> Bool
/= Redeemers ConwayEra
forall a. Monoid a => a
mempty) String
"spending script"

hasLowFees :: PParams LedgerEra -> Tx LedgerEra -> Property
hasLowFees :: PParams LedgerEra -> Tx LedgerEra -> Property
hasLowFees PParams LedgerEra
pparams Tx LedgerEra
tx =
  String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"PParams: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PParams ConwayEra -> String
forall b a. (Show a, IsString b) => a -> b
show PParams LedgerEra
PParams ConwayEra
pparams) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    Property
notTooLow Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. Property
notTooHigh
 where
  notTooLow :: Property
notTooLow =
    Coin
actualFee Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
>= Coin
minFee
      Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Fee too low: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall b a. (Show a, IsString b) => a -> b
show Coin
actualFee String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" < " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall b a. (Show a, IsString b) => a -> b
show Coin
minFee)

  notTooHigh :: Property
notTooHigh =
    Coin
actualFee Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
< Coin
minFee Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
acceptableOverestimation
      Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Fee too high: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall b a. (Show a, IsString b) => a -> b
show Coin
actualFee String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" > " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall b a. (Show a, IsString b) => a -> b
show (Coin
minFee Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
acceptableOverestimation))

  acceptableOverestimation :: Coin
acceptableOverestimation = Integer -> Coin
Coin Integer
100_000

  actualFee :: Coin
actualFee = Tx LedgerEra
AlonzoTx ConwayEra
tx AlonzoTx ConwayEra
-> Getting Coin (AlonzoTx ConwayEra) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (TxBody ConwayEra -> Const Coin (TxBody ConwayEra))
-> Tx ConwayEra -> Const Coin (Tx ConwayEra)
(TxBody ConwayEra -> Const Coin (TxBody ConwayEra))
-> AlonzoTx ConwayEra -> Const Coin (AlonzoTx ConwayEra)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx ConwayEra) (TxBody ConwayEra)
bodyTxL ((TxBody ConwayEra -> Const Coin (TxBody ConwayEra))
 -> AlonzoTx ConwayEra -> Const Coin (AlonzoTx ConwayEra))
-> ((Coin -> Const Coin Coin)
    -> TxBody ConwayEra -> Const Coin (TxBody ConwayEra))
-> Getting Coin (AlonzoTx ConwayEra) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin)
-> TxBody ConwayEra -> Const Coin (TxBody ConwayEra)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody ConwayEra) Coin
feeTxBodyL

  minFee :: Coin
  minFee :: Coin
minFee = PParams ConwayEra -> Tx ConwayEra -> Int -> Coin
forall era. EraTx era => PParams era -> Tx era -> Int -> Coin
getMinFeeTx PParams LedgerEra
PParams ConwayEra
pparams Tx LedgerEra
Tx ConwayEra
tx Int
0

isBalanced :: Map TxIn TxOut -> Tx LedgerEra -> Tx LedgerEra -> Property
isBalanced :: Map TxIn TxOut -> Tx LedgerEra -> Tx LedgerEra -> Property
isBalanced Map TxIn TxOut
utxo Tx LedgerEra
originalTx Tx LedgerEra
balancedTx =
  let inp' :: Value LedgerEra
inp' = Map TxIn TxOut -> Tx LedgerEra -> Value LedgerEra
knownInputBalance Map TxIn TxOut
utxo Tx LedgerEra
balancedTx
      out' :: Value LedgerEra
out' = Tx LedgerEra -> Value LedgerEra
outputBalance Tx LedgerEra
balancedTx
      out :: Value LedgerEra
out = Tx LedgerEra -> Value LedgerEra
outputBalance Tx LedgerEra
originalTx
      fee :: Coin
fee = (((Coin -> Const Coin Coin)
 -> TxBody ConwayEra -> Const Coin (TxBody ConwayEra))
-> TxBody ConwayEra -> Coin
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Coin -> Const Coin Coin)
-> TxBody ConwayEra -> Const Coin (TxBody ConwayEra)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody ConwayEra) Coin
feeTxBodyL (TxBody ConwayEra -> Coin)
-> (AlonzoTx ConwayEra -> TxBody ConwayEra)
-> AlonzoTx ConwayEra
-> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoTx ConwayEra -> TxBody ConwayEra
forall era. AlonzoTx era -> TxBody era
body) Tx LedgerEra
AlonzoTx ConwayEra
balancedTx
   in MaryValue -> Coin
forall t. Val t => t -> Coin
coin (Value LedgerEra -> Value LedgerEra -> Value LedgerEra
deltaValue Value LedgerEra
out' Value LedgerEra
inp') Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
== Coin
fee
        Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Fee:             " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall b a. (Show a, IsString b) => a -> b
show Coin
fee)
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Delta value:     " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall b a. (Show a, IsString b) => a -> b
show (Value LedgerEra -> Coin
forall t. Val t => t -> Coin
coin (Value LedgerEra -> Coin) -> Value LedgerEra -> Coin
forall a b. (a -> b) -> a -> b
$ Value LedgerEra -> Value LedgerEra -> Value LedgerEra
deltaValue Value LedgerEra
out' Value LedgerEra
inp'))
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Added value:     " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall b a. (Show a, IsString b) => a -> b
show (MaryValue -> Coin
forall t. Val t => t -> Coin
coin Value LedgerEra
MaryValue
inp'))
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Outputs after:   " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall b a. (Show a, IsString b) => a -> b
show (MaryValue -> Coin
forall t. Val t => t -> Coin
coin Value LedgerEra
MaryValue
out'))
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Outputs before:  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall b a. (Show a, IsString b) => a -> b
show (MaryValue -> Coin
forall t. Val t => t -> Coin
coin Value LedgerEra
MaryValue
out))

prop_picksLargestUTxOToPayTheFees :: Property
prop_picksLargestUTxOToPayTheFees :: Property
prop_picksLargestUTxOToPayTheFees =
  Gen (Map TxIn (BabbageTxOut ConwayEra))
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (Map TxIn (BabbageTxOut ConwayEra))
Gen (Map TxIn TxOut)
genUTxO ((Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property)
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Map TxIn (BabbageTxOut ConwayEra)
utxo1 ->
    Gen (Map TxIn (BabbageTxOut ConwayEra))
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (Map TxIn (BabbageTxOut ConwayEra))
Gen (Map TxIn TxOut)
genUTxO ((Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property)
-> (Map TxIn (BabbageTxOut ConwayEra) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Map TxIn (BabbageTxOut ConwayEra)
utxo2 -> do
      let combinedUTxO :: Map TxIn (BabbageTxOut ConwayEra)
combinedUTxO = Map TxIn (BabbageTxOut ConwayEra)
-> Map TxIn (BabbageTxOut ConwayEra)
-> Map TxIn (BabbageTxOut ConwayEra)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map TxIn (BabbageTxOut ConwayEra)
utxo1 Map TxIn (BabbageTxOut ConwayEra)
utxo2
      case Map TxIn (TxOut ConwayEra) -> Maybe (TxIn, TxOut ConwayEra)
forall era.
EraTxOut era =>
Map TxIn (TxOut era) -> Maybe (TxIn, TxOut era)
findLargestUTxO Map TxIn (BabbageTxOut ConwayEra)
Map TxIn (TxOut ConwayEra)
combinedUTxO of
        Maybe (TxIn, TxOut ConwayEra)
Nothing ->
          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
"No utxo found: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (Map TxIn (BabbageTxOut ConwayEra) -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty Map TxIn (BabbageTxOut ConwayEra)
combinedUTxO))
        Just (TxIn
_, TxOut ConwayEra
txout) -> do
          let foundLovelace :: Coin
foundLovelace = Value -> Coin
selectLovelace (Value -> Coin) -> Value -> Coin
forall a b. (a -> b) -> a -> b
$ TxOut Any -> Value
forall ctx. TxOut ctx -> Value
txOutValue (TxOut -> TxOut Any
forall era ctx.
IsShelleyBasedEra era =>
TxOut (ShelleyLedgerEra era) -> TxOut ctx era
fromLedgerTxOut TxOut
TxOut ConwayEra
txout)
              mapToLovelace :: Map TxIn (BabbageTxOut ConwayEra) -> UTxO' Coin
mapToLovelace = (TxOut CtxUTxO -> Coin) -> UTxO -> UTxO' Coin
forall a b. (a -> b) -> UTxO' a -> UTxO' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Value -> Coin
selectLovelace (Value -> Coin)
-> (TxOut CtxUTxO -> Value) -> TxOut CtxUTxO -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue) (UTxO -> UTxO' Coin)
-> (Map TxIn (BabbageTxOut ConwayEra) -> UTxO)
-> Map TxIn (BabbageTxOut ConwayEra)
-> UTxO' Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO LedgerEra -> UTxO
UTxO ConwayEra -> UTxO
fromLedgerUTxO (UTxO ConwayEra -> UTxO)
-> (Map TxIn (BabbageTxOut ConwayEra) -> UTxO ConwayEra)
-> Map TxIn (BabbageTxOut ConwayEra)
-> UTxO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map TxIn (BabbageTxOut ConwayEra) -> UTxO ConwayEra
Map TxIn (TxOut ConwayEra) -> UTxO ConwayEra
forall era. Map TxIn (TxOut era) -> UTxO era
Ledger.UTxO
          Property -> Property
forall prop. Testable prop => prop -> Property
property (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            (Coin -> Bool) -> UTxO' Coin -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Coin
foundLovelace >=) (Map TxIn (BabbageTxOut ConwayEra) -> UTxO' Coin
mapToLovelace Map TxIn (BabbageTxOut ConwayEra)
utxo1)
              Bool -> Bool -> Bool
&& (Coin -> Bool) -> UTxO' Coin -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Coin
foundLovelace >=) (Map TxIn (BabbageTxOut ConwayEra) -> UTxO' Coin
mapToLovelace Map TxIn (BabbageTxOut ConwayEra)
utxo2)
              Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Found lovelace: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall b a. (Show a, IsString b) => a -> b
show Coin
foundLovelace)
              Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Found lovelace not greater than all of: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (Map TxIn (BabbageTxOut ConwayEra) -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty Map TxIn (BabbageTxOut ConwayEra)
combinedUTxO))

--
-- Generators
--

-- | Generate an arbitrary list of transactions from a UTXO set such that,
-- transactions may *sometimes* consume given UTXO and produce new ones. The
-- generator is geared towards certain use-cases,
genTxsSpending :: Map TxIn TxOut -> Gen [Tx LedgerEra]
genTxsSpending :: Map TxIn TxOut -> Gen [Tx LedgerEra]
genTxsSpending Map TxIn TxOut
utxo = (Int -> Int) -> Gen [Tx LedgerEra] -> Gen [Tx LedgerEra]
forall a. (Int -> Int) -> Gen a -> Gen a
scale (forall a b. (RealFrac a, Integral b) => a -> b
round @Double (Double -> Int) -> (Int -> Double) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double
forall a. Floating a => a -> a
sqrt (Double -> Double) -> (Int -> Double) -> Int -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (Gen [Tx LedgerEra] -> Gen [Tx LedgerEra])
-> Gen [Tx LedgerEra] -> Gen [Tx LedgerEra]
forall a b. (a -> b) -> a -> b
$ do
  StateT (Map TxIn (BabbageTxOut ConwayEra)) Gen [AlonzoTx ConwayEra]
-> Map TxIn (BabbageTxOut ConwayEra) -> Gen [AlonzoTx ConwayEra]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT (Map TxIn (BabbageTxOut ConwayEra)) Gen [AlonzoTx ConwayEra]
StateT (Map TxIn TxOut) Gen [Tx LedgerEra]
genTxs Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo
 where
  genTxs :: StateT (Map TxIn TxOut) Gen [Tx LedgerEra]
  genTxs :: StateT (Map TxIn TxOut) Gen [Tx LedgerEra]
genTxs = do
    Int
n <- Gen Int -> StateT (Map TxIn (BabbageTxOut ConwayEra)) Gen Int
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map TxIn (BabbageTxOut ConwayEra)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen Int
getSize
    Int
-> StateT
     (Map TxIn (BabbageTxOut ConwayEra)) Gen (AlonzoTx ConwayEra)
-> StateT
     (Map TxIn (BabbageTxOut ConwayEra)) Gen [AlonzoTx ConwayEra]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n StateT (Map TxIn (BabbageTxOut ConwayEra)) Gen (AlonzoTx ConwayEra)
StateT (Map TxIn TxOut) Gen (Tx LedgerEra)
genTx

  genTx :: StateT (Map TxIn TxOut) Gen (Tx LedgerEra)
  genTx :: StateT (Map TxIn TxOut) Gen (Tx LedgerEra)
genTx = do
    StateT
  (Map TxIn (BabbageTxOut ConwayEra)) Gen (ConwayTxBody ConwayEra)
genBody <-
      Gen
  (StateT
     (Map TxIn (BabbageTxOut ConwayEra)) Gen (ConwayTxBody ConwayEra))
-> StateT
     (Map TxIn (BabbageTxOut ConwayEra))
     Gen
     (StateT
        (Map TxIn (BabbageTxOut ConwayEra)) Gen (ConwayTxBody ConwayEra))
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map TxIn (BabbageTxOut ConwayEra)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen
   (StateT
      (Map TxIn (BabbageTxOut ConwayEra)) Gen (ConwayTxBody ConwayEra))
 -> StateT
      (Map TxIn (BabbageTxOut ConwayEra))
      Gen
      (StateT
         (Map TxIn (BabbageTxOut ConwayEra)) Gen (ConwayTxBody ConwayEra)))
-> Gen
     (StateT
        (Map TxIn (BabbageTxOut ConwayEra)) Gen (ConwayTxBody ConwayEra))
-> StateT
     (Map TxIn (BabbageTxOut ConwayEra))
     Gen
     (StateT
        (Map TxIn (BabbageTxOut ConwayEra)) Gen (ConwayTxBody ConwayEra))
forall a b. (a -> b) -> a -> b
$
        [(Int,
  Gen
    (StateT
       (Map TxIn (BabbageTxOut ConwayEra)) Gen (ConwayTxBody ConwayEra)))]
-> Gen
     (StateT
        (Map TxIn (BabbageTxOut ConwayEra)) Gen (ConwayTxBody ConwayEra))
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
          [ (Int
4, StateT
  (Map TxIn (BabbageTxOut ConwayEra)) Gen (ConwayTxBody ConwayEra)
-> Gen
     (StateT
        (Map TxIn (BabbageTxOut ConwayEra)) Gen (ConwayTxBody ConwayEra))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StateT
   (Map TxIn (BabbageTxOut ConwayEra)) Gen (ConwayTxBody ConwayEra)
 -> Gen
      (StateT
         (Map TxIn (BabbageTxOut ConwayEra)) Gen (ConwayTxBody ConwayEra)))
-> StateT
     (Map TxIn (BabbageTxOut ConwayEra)) Gen (ConwayTxBody ConwayEra)
-> Gen
     (StateT
        (Map TxIn (BabbageTxOut ConwayEra)) Gen (ConwayTxBody ConwayEra))
forall a b. (a -> b) -> a -> b
$ Gen (ConwayTxBody ConwayEra)
-> StateT
     (Map TxIn (BabbageTxOut ConwayEra)) Gen (ConwayTxBody ConwayEra)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map TxIn (BabbageTxOut ConwayEra)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen (ConwayTxBody ConwayEra)
forall a. Arbitrary a => Gen a
arbitrary)
          , (Int
1, StateT
  (Map TxIn (BabbageTxOut ConwayEra)) Gen (ConwayTxBody ConwayEra)
-> Gen
     (StateT
        (Map TxIn (BabbageTxOut ConwayEra)) Gen (ConwayTxBody ConwayEra))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StateT
  (Map TxIn (BabbageTxOut ConwayEra)) Gen (ConwayTxBody ConwayEra)
StateT (Map TxIn TxOut) Gen (ConwayTxBody LedgerEra)
genBodyFromUTxO)
          ]
    ConwayTxBody ConwayEra
body <- StateT
  (Map TxIn (BabbageTxOut ConwayEra)) Gen (ConwayTxBody ConwayEra)
genBody
    Gen (AlonzoTx ConwayEra)
-> StateT
     (Map TxIn (BabbageTxOut ConwayEra)) Gen (AlonzoTx ConwayEra)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map TxIn (BabbageTxOut ConwayEra)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen (AlonzoTx ConwayEra)
 -> StateT
      (Map TxIn (BabbageTxOut ConwayEra)) Gen (AlonzoTx ConwayEra))
-> Gen (AlonzoTx ConwayEra)
-> StateT
     (Map TxIn (BabbageTxOut ConwayEra)) Gen (AlonzoTx ConwayEra)
forall a b. (a -> b) -> a -> b
$
      TxBody ConwayEra
-> TxWits ConwayEra
-> IsValid
-> StrictMaybe (TxAuxData ConwayEra)
-> AlonzoTx ConwayEra
forall era.
TxBody era
-> TxWits era
-> IsValid
-> StrictMaybe (TxAuxData era)
-> AlonzoTx era
AlonzoTx TxBody ConwayEra
ConwayTxBody ConwayEra
body
        (AlonzoTxWits ConwayEra
 -> IsValid
 -> StrictMaybe (AlonzoTxAuxData ConwayEra)
 -> AlonzoTx ConwayEra)
-> Gen (AlonzoTxWits ConwayEra)
-> Gen
     (IsValid
      -> StrictMaybe (AlonzoTxAuxData ConwayEra) -> AlonzoTx ConwayEra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (AlonzoTxWits ConwayEra)
forall a. Arbitrary a => Gen a
arbitrary
        Gen
  (IsValid
   -> StrictMaybe (AlonzoTxAuxData ConwayEra) -> AlonzoTx ConwayEra)
-> Gen IsValid
-> Gen
     (StrictMaybe (AlonzoTxAuxData ConwayEra) -> AlonzoTx ConwayEra)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen IsValid
forall a. Arbitrary a => Gen a
arbitrary
        Gen (StrictMaybe (AlonzoTxAuxData ConwayEra) -> AlonzoTx ConwayEra)
-> Gen (StrictMaybe (AlonzoTxAuxData ConwayEra))
-> Gen (AlonzoTx ConwayEra)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (StrictMaybe (AlonzoTxAuxData ConwayEra))
forall a. Arbitrary a => Gen a
arbitrary

  -- Generate a TxBody by consuming a UTXO from the state, and generating a new
  -- one. The number of UTXO in the state after calling this function remains
  -- identical.
  genBodyFromUTxO :: StateT (Map TxIn TxOut) Gen (ConwayTxBody LedgerEra)
  genBodyFromUTxO :: StateT (Map TxIn TxOut) Gen (ConwayTxBody LedgerEra)
genBodyFromUTxO = do
    TxBody ConwayEra
base <- Gen (TxBody ConwayEra)
-> StateT
     (Map TxIn (BabbageTxOut ConwayEra)) Gen (TxBody ConwayEra)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map TxIn (BabbageTxOut ConwayEra)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen (TxBody ConwayEra)
forall a. Arbitrary a => Gen a
arbitrary
    (TxIn
input, TxOut ConwayEra
output) <- (Map TxIn (TxOut ConwayEra) -> (TxIn, TxOut ConwayEra))
-> StateT
     (Map TxIn (BabbageTxOut ConwayEra)) Gen (TxIn, TxOut ConwayEra)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Map TxIn (TxOut ConwayEra) -> (TxIn, TxOut ConwayEra)
forall k a. Map k a -> (k, a)
Map.findMax
    let body :: ConwayTxBody ConwayEra
body =
          TxBody ConwayEra
base
            TxBody ConwayEra
-> (TxBody ConwayEra -> TxBody ConwayEra) -> TxBody ConwayEra
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody ConwayEra -> Identity (TxBody ConwayEra)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody ConwayEra) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody ConwayEra -> Identity (TxBody ConwayEra))
-> Set TxIn -> TxBody ConwayEra -> TxBody ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
input
            TxBody ConwayEra
-> (TxBody ConwayEra -> ConwayTxBody ConwayEra)
-> ConwayTxBody ConwayEra
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut ConwayEra)
 -> Identity (StrictSeq (TxOut ConwayEra)))
-> TxBody ConwayEra -> Identity (TxBody ConwayEra)
(StrictSeq (TxOut ConwayEra)
 -> Identity (StrictSeq (TxOut ConwayEra)))
-> TxBody ConwayEra -> Identity (ConwayTxBody ConwayEra)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody ConwayEra) (StrictSeq (TxOut ConwayEra))
outputsTxBodyL ((StrictSeq (TxOut ConwayEra)
  -> Identity (StrictSeq (TxOut ConwayEra)))
 -> TxBody ConwayEra -> Identity (ConwayTxBody ConwayEra))
-> StrictSeq (TxOut ConwayEra)
-> TxBody ConwayEra
-> ConwayTxBody ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxOut ConwayEra -> StrictSeq (TxOut ConwayEra)
forall a. a -> StrictSeq a
StrictSeq.singleton TxOut ConwayEra
output
    let input' :: TxIn
input' = TxId -> TxIx -> TxIn
Ledger.TxIn (SafeHash EraIndependentTxBody -> TxId
Ledger.TxId (SafeHash EraIndependentTxBody -> TxId)
-> SafeHash EraIndependentTxBody -> TxId
forall a b. (a -> b) -> a -> b
$ ConwayTxBody ConwayEra -> SafeHash EraIndependentTxBody
forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated ConwayTxBody ConwayEra
body) (Word16 -> TxIx
Ledger.TxIx Word16
0)
    (Map TxIn (TxOut ConwayEra) -> Map TxIn (TxOut ConwayEra))
-> StateT (Map TxIn (BabbageTxOut ConwayEra)) Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\Map TxIn (TxOut ConwayEra)
m -> Map TxIn (TxOut ConwayEra)
m Map TxIn (TxOut ConwayEra)
-> (Map TxIn (TxOut ConwayEra) -> Map TxIn (TxOut ConwayEra))
-> Map TxIn (TxOut ConwayEra)
forall a b. a -> (a -> b) -> b
& TxIn -> Map TxIn (TxOut ConwayEra) -> Map TxIn (TxOut ConwayEra)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete TxIn
input Map TxIn (TxOut ConwayEra)
-> (Map TxIn (TxOut ConwayEra) -> Map TxIn (TxOut ConwayEra))
-> Map TxIn (TxOut ConwayEra)
forall a b. a -> (a -> b) -> b
& TxIn
-> TxOut ConwayEra
-> Map TxIn (TxOut ConwayEra)
-> Map TxIn (TxOut ConwayEra)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TxIn
input' TxOut ConwayEra
output)
    ConwayTxBody ConwayEra
-> StateT
     (Map TxIn (BabbageTxOut ConwayEra)) Gen (ConwayTxBody ConwayEra)
forall a. a -> StateT (Map TxIn (BabbageTxOut ConwayEra)) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConwayTxBody ConwayEra
body

genUTxO :: Gen (Map TxIn TxOut)
genUTxO :: Gen (Map TxIn TxOut)
genUTxO = do
  AlonzoTx ConwayEra
tx <- Gen (AlonzoTx ConwayEra)
forall a. Arbitrary a => Gen a
arbitrary Gen (AlonzoTx ConwayEra)
-> (AlonzoTx ConwayEra -> Bool) -> Gen (AlonzoTx ConwayEra)
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Bool -> Bool
Prelude.not (Bool -> Bool)
-> (AlonzoTx ConwayEra -> Bool) -> AlonzoTx ConwayEra -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictSeq (TxOut ConwayEra) -> Bool
forall a. StrictSeq a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
Prelude.null (StrictSeq (TxOut ConwayEra) -> Bool)
-> (AlonzoTx ConwayEra -> StrictSeq (TxOut ConwayEra))
-> AlonzoTx ConwayEra
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((StrictSeq (TxOut ConwayEra)
  -> Const
       (StrictSeq (TxOut ConwayEra)) (StrictSeq (TxOut ConwayEra)))
 -> TxBody ConwayEra
 -> Const (StrictSeq (TxOut ConwayEra)) (TxBody ConwayEra))
-> TxBody ConwayEra -> StrictSeq (TxOut ConwayEra)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (StrictSeq (TxOut ConwayEra)
 -> Const
      (StrictSeq (TxOut ConwayEra)) (StrictSeq (TxOut ConwayEra)))
-> TxBody ConwayEra
-> Const (StrictSeq (TxOut ConwayEra)) (TxBody ConwayEra)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody ConwayEra) (StrictSeq (TxOut ConwayEra))
outputsTxBodyL (TxBody ConwayEra -> StrictSeq (TxOut ConwayEra))
-> (AlonzoTx ConwayEra -> TxBody ConwayEra)
-> AlonzoTx ConwayEra
-> StrictSeq (TxOut ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoTx ConwayEra -> TxBody ConwayEra
forall era. AlonzoTx era -> TxBody era
body)
  TxIn
txIn <- TxIn -> TxIn
toLedgerTxIn (TxIn -> TxIn) -> Gen TxIn -> Gen TxIn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen TxIn
genTxIn
  let txOut :: TxOut
txOut = TxOut -> TxOut
scaleAda (TxOut -> TxOut) -> TxOut -> TxOut
forall a b. (a -> b) -> a -> b
$ [TxOut] -> TxOut
forall a. HasCallStack => [a] -> a
Prelude.head ([TxOut] -> TxOut) -> [TxOut] -> TxOut
forall a b. (a -> b) -> a -> b
$ StrictSeq TxOut -> [TxOut]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq TxOut -> [TxOut]) -> StrictSeq TxOut -> [TxOut]
forall a b. (a -> b) -> a -> b
$ AlonzoTx ConwayEra -> TxBody ConwayEra
forall era. AlonzoTx era -> TxBody era
body AlonzoTx ConwayEra
tx TxBody ConwayEra
-> Getting
     (StrictSeq (BabbageTxOut ConwayEra))
     (TxBody ConwayEra)
     (StrictSeq (BabbageTxOut ConwayEra))
-> StrictSeq (BabbageTxOut ConwayEra)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (BabbageTxOut ConwayEra))
  (TxBody ConwayEra)
  (StrictSeq (BabbageTxOut ConwayEra))
(StrictSeq (TxOut ConwayEra)
 -> Const
      (StrictSeq (BabbageTxOut ConwayEra)) (StrictSeq (TxOut ConwayEra)))
-> TxBody ConwayEra
-> Const (StrictSeq (BabbageTxOut ConwayEra)) (TxBody ConwayEra)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody ConwayEra) (StrictSeq (TxOut ConwayEra))
outputsTxBodyL
  Map TxIn (BabbageTxOut ConwayEra)
-> Gen (Map TxIn (BabbageTxOut ConwayEra))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map TxIn (BabbageTxOut ConwayEra)
 -> Gen (Map TxIn (BabbageTxOut ConwayEra)))
-> Map TxIn (BabbageTxOut ConwayEra)
-> Gen (Map TxIn (BabbageTxOut ConwayEra))
forall a b. (a -> b) -> a -> b
$ TxIn -> BabbageTxOut ConwayEra -> Map TxIn (BabbageTxOut ConwayEra)
forall k a. k -> a -> Map k a
Map.singleton TxIn
txIn BabbageTxOut ConwayEra
TxOut
txOut
 where
  scaleAda :: TxOut -> TxOut
  scaleAda :: TxOut -> TxOut
scaleAda (BabbageTxOut Address
addr Value ConwayEra
value Datum ConwayEra
datum StrictMaybe (Script ConwayEra)
refScript) =
    let value' :: MaryValue
value' = Value ConwayEra
MaryValue
value MaryValue -> MaryValue -> MaryValue
forall a. Semigroup a => a -> a -> a
<> Coin -> MaryValue
forall t s. Inject t s => t -> s
Ledger.inject (Integer -> Coin
Coin Integer
20_000_000)
     in Address
-> Value ConwayEra
-> Datum ConwayEra
-> StrictMaybe (Script ConwayEra)
-> BabbageTxOut ConwayEra
forall era.
(Era era, Val (Value era), HasCallStack) =>
Address
-> Value era
-> Datum era
-> StrictMaybe (Script era)
-> BabbageTxOut era
BabbageTxOut Address
addr Value ConwayEra
MaryValue
value' Datum ConwayEra
datum StrictMaybe (Script ConwayEra)
refScript

genOutputsForInputs :: Tx LedgerEra -> Gen (Map TxIn TxOut)
genOutputsForInputs :: Tx LedgerEra -> Gen (Map TxIn TxOut)
genOutputsForInputs AlonzoTx{TxBody ConwayEra
body :: forall era. AlonzoTx era -> TxBody era
body :: TxBody ConwayEra
body} = do
  let n :: Int
n = Set TxIn -> Int
forall a. Set a -> Int
Set.size (Getting (Set TxIn) (TxBody ConwayEra) (Set TxIn)
-> ConwayTxBody ConwayEra -> Set TxIn
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Set TxIn) (TxBody ConwayEra) (Set TxIn)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody ConwayEra) (Set TxIn)
inputsTxBodyL TxBody ConwayEra
ConwayTxBody ConwayEra
body)
  [BabbageTxOut ConwayEra]
outs <- Int -> Gen (BabbageTxOut ConwayEra) -> Gen [BabbageTxOut ConwayEra]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
n Gen (BabbageTxOut ConwayEra)
forall a. Arbitrary a => Gen a
arbitrary
  Map TxIn (BabbageTxOut ConwayEra)
-> Gen (Map TxIn (BabbageTxOut ConwayEra))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map TxIn (BabbageTxOut ConwayEra)
 -> Gen (Map TxIn (BabbageTxOut ConwayEra)))
-> Map TxIn (BabbageTxOut ConwayEra)
-> Gen (Map TxIn (BabbageTxOut ConwayEra))
forall a b. (a -> b) -> a -> b
$ [(TxIn, BabbageTxOut ConwayEra)]
-> Map TxIn (BabbageTxOut ConwayEra)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(TxIn, BabbageTxOut ConwayEra)]
 -> Map TxIn (BabbageTxOut ConwayEra))
-> [(TxIn, BabbageTxOut ConwayEra)]
-> Map TxIn (BabbageTxOut ConwayEra)
forall a b. (a -> b) -> a -> b
$ [TxIn]
-> [BabbageTxOut ConwayEra] -> [(TxIn, BabbageTxOut ConwayEra)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Set TxIn -> [TxIn]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Getting (Set TxIn) (TxBody ConwayEra) (Set TxIn)
-> ConwayTxBody ConwayEra -> Set TxIn
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Set TxIn) (TxBody ConwayEra) (Set TxIn)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody ConwayEra) (Set TxIn)
inputsTxBodyL TxBody ConwayEra
ConwayTxBody ConwayEra
body)) [BabbageTxOut ConwayEra]
outs

genLedgerTx :: Gen (Tx LedgerEra)
genLedgerTx :: Gen (Tx LedgerEra)
genLedgerTx = do
  Tx ConwayEra
tx <- Gen (Tx ConwayEra)
forall a. Arbitrary a => Gen a
arbitrary
  AlonzoTx ConwayEra -> Gen (AlonzoTx ConwayEra)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AlonzoTx ConwayEra -> Gen (AlonzoTx ConwayEra))
-> AlonzoTx ConwayEra -> Gen (AlonzoTx ConwayEra)
forall a b. (a -> b) -> a -> b
$ Tx ConwayEra
tx Tx ConwayEra
-> (Tx ConwayEra -> AlonzoTx ConwayEra) -> AlonzoTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxBody ConwayEra -> Identity (TxBody ConwayEra))
-> Tx ConwayEra -> Identity (Tx ConwayEra)
(TxBody ConwayEra -> Identity (TxBody ConwayEra))
-> Tx ConwayEra -> Identity (AlonzoTx ConwayEra)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx ConwayEra) (TxBody ConwayEra)
bodyTxL ((TxBody ConwayEra -> Identity (TxBody ConwayEra))
 -> Tx ConwayEra -> Identity (AlonzoTx ConwayEra))
-> ((Coin -> Identity Coin)
    -> TxBody ConwayEra -> Identity (TxBody ConwayEra))
-> (Coin -> Identity Coin)
-> Tx ConwayEra
-> Identity (AlonzoTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Identity Coin)
-> TxBody ConwayEra -> Identity (TxBody ConwayEra)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody ConwayEra) Coin
feeTxBodyL ((Coin -> Identity Coin)
 -> Tx ConwayEra -> Identity (AlonzoTx ConwayEra))
-> Coin -> Tx ConwayEra -> AlonzoTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
0

--
-- Helpers
--

allTxIns :: [Tx LedgerEra] -> Set TxIn
allTxIns :: [Tx LedgerEra] -> Set TxIn
allTxIns [Tx LedgerEra]
txs =
  [Set TxIn] -> Set TxIn
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (Getting (Set TxIn) (TxBody ConwayEra) (Set TxIn)
-> TxBody ConwayEra -> Set TxIn
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Set TxIn) (TxBody ConwayEra) (Set TxIn)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody ConwayEra) (Set TxIn)
inputsTxBodyL (TxBody ConwayEra -> Set TxIn)
-> (AlonzoTx ConwayEra -> TxBody ConwayEra)
-> AlonzoTx ConwayEra
-> Set TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoTx ConwayEra -> TxBody ConwayEra
forall era. AlonzoTx era -> TxBody era
body (AlonzoTx ConwayEra -> Set TxIn)
-> [AlonzoTx ConwayEra] -> [Set TxIn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tx LedgerEra]
[AlonzoTx ConwayEra]
txs)

allTxOuts :: [Tx LedgerEra] -> [TxOut]
allTxOuts :: [Tx LedgerEra] -> [TxOut]
allTxOuts [Tx LedgerEra]
txs =
  StrictSeq TxOut -> [TxOut]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq TxOut -> [TxOut]) -> StrictSeq TxOut -> [TxOut]
forall a b. (a -> b) -> a -> b
$ [StrictSeq (BabbageTxOut ConwayEra)]
-> StrictSeq (BabbageTxOut ConwayEra)
forall a. Monoid a => [a] -> a
mconcat (Getting
  (StrictSeq (BabbageTxOut ConwayEra))
  (ConwayTxBody ConwayEra)
  (StrictSeq (BabbageTxOut ConwayEra))
-> TxBody ConwayEra -> StrictSeq (BabbageTxOut ConwayEra)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (StrictSeq (BabbageTxOut ConwayEra))
  (ConwayTxBody ConwayEra)
  (StrictSeq (BabbageTxOut ConwayEra))
(StrictSeq (TxOut ConwayEra)
 -> Const
      (StrictSeq (BabbageTxOut ConwayEra)) (StrictSeq (TxOut ConwayEra)))
-> TxBody ConwayEra
-> Const (StrictSeq (BabbageTxOut ConwayEra)) (TxBody ConwayEra)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody ConwayEra) (StrictSeq (TxOut ConwayEra))
outputsTxBodyL (TxBody ConwayEra -> StrictSeq (BabbageTxOut ConwayEra))
-> (AlonzoTx ConwayEra -> TxBody ConwayEra)
-> AlonzoTx ConwayEra
-> StrictSeq (BabbageTxOut ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoTx ConwayEra -> TxBody ConwayEra
forall era. AlonzoTx era -> TxBody era
body (AlonzoTx ConwayEra -> StrictSeq (BabbageTxOut ConwayEra))
-> [AlonzoTx ConwayEra] -> [StrictSeq (BabbageTxOut ConwayEra)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tx LedgerEra]
[AlonzoTx ConwayEra]
txs)

isOurs :: Map TxIn TxOut -> Address -> Bool
isOurs :: Map TxIn TxOut -> Address -> Bool
isOurs Map TxIn TxOut
utxo Address
addr =
  Address
addr Address -> [Address] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` ((\(BabbageTxOut Address
addr' Value ConwayEra
_ Datum ConwayEra
_ StrictMaybe (Script ConwayEra)
_) -> Address
addr') (BabbageTxOut ConwayEra -> Address)
-> [BabbageTxOut ConwayEra] -> [Address]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map TxIn (BabbageTxOut ConwayEra) -> [BabbageTxOut ConwayEra]
forall k a. Map k a -> [a]
Map.elems Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo)

-- NOTE: 'direct' here means inputs that can be identified from our initial
-- UTXO set. UTXOs that are created in a transaction from that blk aren't
-- counted here.
ourDirectInputs :: Map TxIn TxOut -> [Tx LedgerEra] -> [TxIn]
ourDirectInputs :: Map TxIn TxOut -> [Tx LedgerEra] -> [TxIn]
ourDirectInputs Map TxIn TxOut
utxo [Tx LedgerEra]
txs =
  Map TxIn (BabbageTxOut ConwayEra) -> [TxIn]
forall k a. Map k a -> [k]
Map.keys (Map TxIn (BabbageTxOut ConwayEra) -> [TxIn])
-> Map TxIn (BabbageTxOut ConwayEra) -> [TxIn]
forall a b. (a -> b) -> a -> b
$ Map TxIn (BabbageTxOut ConwayEra)
-> Set TxIn -> Map TxIn (BabbageTxOut ConwayEra)
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo ([Tx LedgerEra] -> Set TxIn
allTxIns [Tx LedgerEra]
txs)

ourOutputs :: Map TxIn TxOut -> [Tx LedgerEra] -> [TxOut]
ourOutputs :: Map TxIn TxOut -> [Tx LedgerEra] -> [TxOut]
ourOutputs Map TxIn TxOut
utxo [Tx LedgerEra]
blk =
  let ours :: [BabbageTxOut ConwayEra]
ours = Map TxIn (BabbageTxOut ConwayEra) -> [BabbageTxOut ConwayEra]
forall k a. Map k a -> [a]
Map.elems Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo
   in (BabbageTxOut ConwayEra -> Bool)
-> [BabbageTxOut ConwayEra] -> [BabbageTxOut ConwayEra]
forall a. (a -> Bool) -> [a] -> [a]
filter (BabbageTxOut ConwayEra -> [BabbageTxOut ConwayEra] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [BabbageTxOut ConwayEra]
ours) ([Tx LedgerEra] -> [TxOut]
allTxOuts [Tx LedgerEra]
blk)

getValue :: TxOut -> Value LedgerEra
getValue :: TxOut -> Value LedgerEra
getValue (BabbageTxOut Address
_ Value ConwayEra
value Datum ConwayEra
_ StrictMaybe (Script ConwayEra)
_) = Value LedgerEra
Value ConwayEra
value

deltaValue :: Value LedgerEra -> Value LedgerEra -> Value LedgerEra
deltaValue :: Value LedgerEra -> Value LedgerEra -> Value LedgerEra
deltaValue Value LedgerEra
a Value LedgerEra
b
  | MaryValue -> Coin
forall t. Val t => t -> Coin
coin Value LedgerEra
MaryValue
a Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
> MaryValue -> Coin
forall t. Val t => t -> Coin
coin Value LedgerEra
MaryValue
b = Value LedgerEra
MaryValue
a MaryValue -> MaryValue -> MaryValue
forall a. Semigroup a => a -> a -> a
<> MaryValue -> MaryValue
forall t. Val t => t -> t
invert Value LedgerEra
MaryValue
b
  | Bool
otherwise = MaryValue -> MaryValue
forall t. Val t => t -> t
invert Value LedgerEra
MaryValue
a MaryValue -> MaryValue -> MaryValue
forall a. Semigroup a => a -> a -> a
<> Value LedgerEra
MaryValue
b

-- | NOTE: This does not account for withdrawals
knownInputBalance :: Map TxIn TxOut -> Tx LedgerEra -> Value LedgerEra
knownInputBalance :: Map TxIn TxOut -> Tx LedgerEra -> Value LedgerEra
knownInputBalance Map TxIn TxOut
utxo = (TxIn -> MaryValue) -> [TxIn] -> MaryValue
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxIn -> Value LedgerEra
TxIn -> MaryValue
resolve ([TxIn] -> MaryValue)
-> (AlonzoTx ConwayEra -> [TxIn])
-> AlonzoTx ConwayEra
-> MaryValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set TxIn -> [TxIn]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Set TxIn -> [TxIn])
-> (AlonzoTx ConwayEra -> Set TxIn) -> AlonzoTx ConwayEra -> [TxIn]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Set TxIn) (TxBody ConwayEra) (Set TxIn)
-> ConwayTxBody ConwayEra -> Set TxIn
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Set TxIn) (TxBody ConwayEra) (Set TxIn)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody ConwayEra) (Set TxIn)
inputsTxBodyL (ConwayTxBody ConwayEra -> Set TxIn)
-> (AlonzoTx ConwayEra -> ConwayTxBody ConwayEra)
-> AlonzoTx ConwayEra
-> Set TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoTx ConwayEra -> TxBody ConwayEra
AlonzoTx ConwayEra -> ConwayTxBody ConwayEra
forall era. AlonzoTx era -> TxBody era
body
 where
  resolve :: TxIn -> Value LedgerEra
  resolve :: TxIn -> Value LedgerEra
resolve TxIn
k = MaryValue
-> (BabbageTxOut ConwayEra -> MaryValue)
-> Maybe (BabbageTxOut ConwayEra)
-> MaryValue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe MaryValue
forall t. Val t => t
zero BabbageTxOut ConwayEra -> MaryValue
TxOut -> Value LedgerEra
getValue (TxIn
-> Map TxIn (BabbageTxOut ConwayEra)
-> Maybe (BabbageTxOut ConwayEra)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIn
k Map TxIn (BabbageTxOut ConwayEra)
Map TxIn TxOut
utxo)

-- | NOTE: This does not account for deposits
outputBalance :: Tx LedgerEra -> Value LedgerEra
outputBalance :: Tx LedgerEra -> Value LedgerEra
outputBalance =
  (BabbageTxOut ConwayEra -> MaryValue)
-> StrictSeq (BabbageTxOut ConwayEra) -> MaryValue
forall m a. Monoid m => (a -> m) -> StrictSeq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap BabbageTxOut ConwayEra -> MaryValue
TxOut -> Value LedgerEra
getValue (StrictSeq (BabbageTxOut ConwayEra) -> MaryValue)
-> (AlonzoTx ConwayEra -> StrictSeq (BabbageTxOut ConwayEra))
-> AlonzoTx ConwayEra
-> MaryValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (StrictSeq (BabbageTxOut ConwayEra))
  (ConwayTxBody ConwayEra)
  (StrictSeq (BabbageTxOut ConwayEra))
-> ConwayTxBody ConwayEra -> StrictSeq (BabbageTxOut ConwayEra)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (StrictSeq (BabbageTxOut ConwayEra))
  (ConwayTxBody ConwayEra)
  (StrictSeq (BabbageTxOut ConwayEra))
(StrictSeq (TxOut ConwayEra)
 -> Const
      (StrictSeq (BabbageTxOut ConwayEra)) (StrictSeq (TxOut ConwayEra)))
-> TxBody ConwayEra
-> Const (StrictSeq (BabbageTxOut ConwayEra)) (TxBody ConwayEra)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody ConwayEra) (StrictSeq (TxOut ConwayEra))
outputsTxBodyL (ConwayTxBody ConwayEra -> StrictSeq (BabbageTxOut ConwayEra))
-> (AlonzoTx ConwayEra -> ConwayTxBody ConwayEra)
-> AlonzoTx ConwayEra
-> StrictSeq (BabbageTxOut ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoTx ConwayEra -> TxBody ConwayEra
AlonzoTx ConwayEra -> ConwayTxBody ConwayEra
forall era. AlonzoTx era -> TxBody era
body