{-# LANGUAGE DuplicateRecordFields #-}

module Hydra.Chain.Direct.WalletSpec where

import Hydra.Prelude
import Test.Hydra.Prelude

import Cardano.Ledger.Api (EraTx (getMinFeeTx), EraTxBody (feeTxBodyL, inputsTxBodyL), PParams, bodyTxL, coinTxOutL, outputsTxBodyL)
import Cardano.Ledger.Babbage.Tx (AlonzoTx (..))
import Cardano.Ledger.Babbage.TxBody (BabbageTxBody (..), BabbageTxOut (..))
import Cardano.Ledger.BaseTypes qualified as Ledger
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core (Tx, Value)
import Cardano.Ledger.SafeHash qualified as SafeHash
import Cardano.Ledger.Shelley.API qualified as Ledger
import Cardano.Ledger.Val (Val (..), invert)
import Control.Concurrent (newEmptyMVar, putMVar, takeMVar)
import Control.Lens (set, 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 (
  ChainPoint (ChainPoint),
  Hash (HeaderHash),
  LedgerEra,
  PaymentCredential (PaymentCredentialByKey),
  PaymentKey,
  SlotNo,
  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.Fixture qualified as Fixture
import Hydra.Chain.Direct.Wallet (
  Address,
  ChainQuery,
  TinyWallet (..),
  TxIn,
  TxOut,
  WalletInfoOnChain (..),
  applyTxs,
  coverFee_,
  findLargestUTxO,
  newTinyWallet,
 )
import Hydra.Ledger.Cardano (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 (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) (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)
        Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
utxo <- STM IO (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
-> IO (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
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 (BabbageEra StandardCrypto))
utxo Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
-> (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)) -> Bool)
-> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
m -> Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)) -> Int
forall k a. Map k a -> Int
Map.size Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
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 (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 (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)
        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 (EraCrypto (BabbageEra StandardCrypto)))
  (TxOut (BabbageEra StandardCrypto))
walletUTxO <- UTxO (BabbageEra StandardCrypto)
-> Map
     (TxIn (EraCrypto (BabbageEra StandardCrypto)))
     (TxOut (BabbageEra StandardCrypto))
forall era. UTxO era -> Map (TxIn (EraCrypto era)) (TxOut era)
Ledger.unUTxO (UTxO (BabbageEra StandardCrypto)
 -> Map
      (TxIn (EraCrypto (BabbageEra StandardCrypto)))
      (TxOut (BabbageEra StandardCrypto)))
-> (UTxO -> UTxO (BabbageEra StandardCrypto))
-> UTxO
-> Map
     (TxIn (EraCrypto (BabbageEra StandardCrypto)))
     (TxOut (BabbageEra StandardCrypto))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO -> UTxO LedgerEra
UTxO -> UTxO (BabbageEra StandardCrypto)
toLedgerUTxO (UTxO
 -> Map
      (TxIn (EraCrypto (BabbageEra StandardCrypto)))
      (TxOut (BabbageEra StandardCrypto)))
-> IO UTxO
-> IO
     (Map
        (TxIn (EraCrypto (BabbageEra StandardCrypto)))
        (TxOut (BabbageEra StandardCrypto)))
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 (EraCrypto (BabbageEra StandardCrypto)))
  (TxOut (BabbageEra StandardCrypto))
walletUTxO :: Map
  (TxIn (EraCrypto (BabbageEra StandardCrypto)))
  (TxOut (BabbageEra StandardCrypto))
$sel:walletUTxO:WalletInfoOnChain :: Map TxIn TxOut
walletUTxO
        , $sel:pparams:WalletInfoOnChain :: PParams LedgerEra
pparams = PParams LedgerEra
Fixture.pparams
        , $sel:systemStart:WalletInfoOnChain :: SystemStart
systemStart = SystemStart
Fixture.systemStart
        , $sel:epochInfo:WalletInfoOnChain :: EpochInfo (Either Text)
epochInfo = EpochInfo (Either Text)
forall (m :: * -> *). Monad m => EpochInfo m
Fixture.epochInfo
        , 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 StandardCrypto
cred StakeReference StandardCrypto
_ = Address ShelleyAddr
addr
  PaymentCredential StandardCrypto -> PaymentCredential
fromShelleyPaymentCredential PaymentCredential StandardCrypto
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 (EraCrypto (BabbageEra StandardCrypto)))
  (TxOut (BabbageEra StandardCrypto))
walletUTxO <- UTxO (BabbageEra StandardCrypto)
-> Map
     (TxIn (EraCrypto (BabbageEra StandardCrypto)))
     (TxOut (BabbageEra StandardCrypto))
forall era. UTxO era -> Map (TxIn (EraCrypto era)) (TxOut era)
Ledger.unUTxO (UTxO (BabbageEra StandardCrypto)
 -> Map
      (TxIn (EraCrypto (BabbageEra StandardCrypto)))
      (TxOut (BabbageEra StandardCrypto)))
-> (UTxO -> UTxO (BabbageEra StandardCrypto))
-> UTxO
-> Map
     (TxIn (EraCrypto (BabbageEra StandardCrypto)))
     (TxOut (BabbageEra StandardCrypto))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO -> UTxO LedgerEra
UTxO -> UTxO (BabbageEra StandardCrypto)
toLedgerUTxO (UTxO
 -> Map
      (TxIn (EraCrypto (BabbageEra StandardCrypto)))
      (TxOut (BabbageEra StandardCrypto)))
-> IO UTxO
-> IO
     (Map
        (TxIn (EraCrypto (BabbageEra StandardCrypto)))
        (TxOut (BabbageEra StandardCrypto)))
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 (EraCrypto (BabbageEra StandardCrypto)))
  (TxOut (BabbageEra StandardCrypto))
$sel:walletUTxO:WalletInfoOnChain :: Map TxIn TxOut
walletUTxO :: Map
  (TxIn (EraCrypto (BabbageEra StandardCrypto)))
  (TxOut (BabbageEra StandardCrypto))
walletUTxO
      , $sel:pparams:WalletInfoOnChain :: PParams LedgerEra
pparams = PParams LedgerEra
Fixture.pparams
      , $sel:systemStart:WalletInfoOnChain :: SystemStart
systemStart = SystemStart
Fixture.systemStart
      , $sel:epochInfo:WalletInfoOnChain :: EpochInfo (Either Text)
epochInfo = EpochInfo (Either Text)
forall (m :: * -> *). Monad m => EpochInfo m
Fixture.epochInfo
      , ChainPoint
$sel:tip:WalletInfoOnChain :: ChainPoint
tip :: ChainPoint
tip
      }

--
-- Generators
--

prop_wellSuitedGenerators ::
  Property
prop_wellSuitedGenerators :: Property
prop_wellSuitedGenerators =
  Gen (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
-> (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
    -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
Gen (Map TxIn TxOut)
genUTxO ((Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)) -> Property)
 -> Property)
-> (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
    -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
utxo ->
    Gen [AlonzoTx (BabbageEra StandardCrypto)]
-> ([AlonzoTx (BabbageEra StandardCrypto)] -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Map TxIn TxOut -> Gen [Tx LedgerEra]
genTxsSpending Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
Map TxIn TxOut
utxo) (([AlonzoTx (BabbageEra StandardCrypto)] -> Property) -> Property)
-> ([AlonzoTx (BabbageEra StandardCrypto)] -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \[AlonzoTx (BabbageEra StandardCrypto)]
txs ->
      Bool -> Property
forall prop. Testable prop => prop -> Property
property ([AlonzoTx (BabbageEra StandardCrypto)] -> Bool
forall {t :: * -> *} {a}. Foldable t => t a -> Bool
smallTxSets [AlonzoTx (BabbageEra StandardCrypto)]
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 (BabbageEra StandardCrypto))
-> [AlonzoTx (BabbageEra StandardCrypto)] -> Bool
noneIsOurs Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
utxo [AlonzoTx (BabbageEra StandardCrypto)]
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 (BabbageEra StandardCrypto))
-> [AlonzoTx (BabbageEra StandardCrypto)] -> Bool
someAreDependent Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
utxo [AlonzoTx (BabbageEra StandardCrypto)]
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 [AlonzoTx (BabbageEra StandardCrypto)]
[Tx LedgerEra]
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 [AlonzoTx (BabbageEra StandardCrypto)]
[Tx LedgerEra]
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 (BabbageEra StandardCrypto))
Map TxIn TxOut
utxo [AlonzoTx (BabbageEra StandardCrypto)]
[Tx LedgerEra]
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 (BabbageEra StandardCrypto))
Map TxIn TxOut
utxo [AlonzoTx (BabbageEra StandardCrypto)]
[Tx LedgerEra]
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 (BabbageEra StandardCrypto))
-> [AlonzoTx (BabbageEra StandardCrypto)] -> Bool
noneIsOurs Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
utxo [AlonzoTx (BabbageEra StandardCrypto)]
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 (BabbageEra StandardCrypto))
Map TxIn TxOut
utxo [AlonzoTx (BabbageEra StandardCrypto)]
[Tx LedgerEra]
txs) Bool -> Bool -> Bool
&& [BabbageTxOut (BabbageEra StandardCrypto)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Map TxIn TxOut -> [Tx LedgerEra] -> [TxOut]
ourOutputs Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
Map TxIn TxOut
utxo [AlonzoTx (BabbageEra StandardCrypto)]
[Tx LedgerEra]
txs)

  someAreDependent :: Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
-> [AlonzoTx (BabbageEra StandardCrypto)] -> Bool
someAreDependent Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
utxo [AlonzoTx (BabbageEra StandardCrypto)]
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 (BabbageEra StandardCrypto))
Map TxIn TxOut
utxo [AlonzoTx (BabbageEra StandardCrypto)]
[Tx LedgerEra]
txs) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [BabbageTxOut (BabbageEra StandardCrypto)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Map TxIn TxOut -> [Tx LedgerEra] -> [TxOut]
ourOutputs Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
Map TxIn TxOut
utxo [AlonzoTx (BabbageEra StandardCrypto)]
[Tx LedgerEra]
txs)

--
-- applyTxs
--

prop_reducesWhenNotOurs :: Property
prop_reducesWhenNotOurs :: Property
prop_reducesWhenNotOurs =
  Gen (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
-> (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
    -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
Gen (Map TxIn TxOut)
genUTxO ((Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)) -> Property)
 -> Property)
-> (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
    -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
utxo ->
    Gen [AlonzoTx (BabbageEra StandardCrypto)]
-> ([AlonzoTx (BabbageEra StandardCrypto)] -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Map TxIn TxOut -> Gen [Tx LedgerEra]
genTxsSpending Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
Map TxIn TxOut
utxo) (([AlonzoTx (BabbageEra StandardCrypto)] -> Property) -> Property)
-> ([AlonzoTx (BabbageEra StandardCrypto)] -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \[AlonzoTx (BabbageEra StandardCrypto)]
txs ->
      let utxo' :: Map TxIn TxOut
utxo' = [Tx] -> (Address -> Bool) -> Map TxIn TxOut -> Map TxIn TxOut
applyTxs (AlonzoTx (BabbageEra StandardCrypto) -> Tx
Tx LedgerEra -> Tx
fromLedgerTx (AlonzoTx (BabbageEra StandardCrypto) -> Tx)
-> [AlonzoTx (BabbageEra StandardCrypto)] -> [Tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AlonzoTx (BabbageEra StandardCrypto)]
txs) (Bool -> Address -> Bool
forall a b. a -> b -> a
const Bool
False) Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
Map TxIn TxOut
utxo
       in (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)) -> Int
forall a. Map TxIn a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
Map TxIn TxOut
utxo' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)) -> Int
forall a. Map TxIn a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
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 (BabbageEra StandardCrypto)) -> String
forall b a. (Show a, IsString b) => a -> b
show Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
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 (BabbageEra StandardCrypto)) -> Int
forall a. Map TxIn a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
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 (BabbageEra StandardCrypto)) -> Int
forall a. Map TxIn a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
Map TxIn TxOut
utxo'))

prop_seenInputsAreConsumed :: Property
prop_seenInputsAreConsumed :: Property
prop_seenInputsAreConsumed =
  Gen (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
-> (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
    -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
Gen (Map TxIn TxOut)
genUTxO ((Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)) -> Property)
 -> Property)
-> (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
    -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
utxo ->
    Gen [AlonzoTx (BabbageEra StandardCrypto)]
-> ([AlonzoTx (BabbageEra StandardCrypto)] -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Map TxIn TxOut -> Gen [Tx LedgerEra]
genTxsSpending Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
Map TxIn TxOut
utxo) (([AlonzoTx (BabbageEra StandardCrypto)] -> Property) -> Property)
-> ([AlonzoTx (BabbageEra StandardCrypto)] -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \[AlonzoTx (BabbageEra StandardCrypto)]
txs ->
      let utxo' :: Map TxIn TxOut
utxo' = [Tx] -> (Address -> Bool) -> Map TxIn TxOut -> Map TxIn TxOut
applyTxs (AlonzoTx (BabbageEra StandardCrypto) -> Tx
Tx LedgerEra -> Tx
fromLedgerTx (AlonzoTx (BabbageEra StandardCrypto) -> Tx)
-> [AlonzoTx (BabbageEra StandardCrypto)] -> [Tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AlonzoTx (BabbageEra StandardCrypto)]
txs) (Map TxIn TxOut -> Address -> Bool
isOurs Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
Map TxIn TxOut
utxo) Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
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 (BabbageEra StandardCrypto))
Map TxIn TxOut
utxo [AlonzoTx (BabbageEra StandardCrypto)]
[Tx LedgerEra]
txs
       in Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)) -> Bool
forall a. Map TxIn a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
-> Set TxIn -> Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
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 (BabbageEra StandardCrypto)) -> String
forall b a. (Show a, IsString b) => a -> b
show Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
Map TxIn TxOut
utxo')

--
-- coverFee
--

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

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 (BabbageEra StandardCrypto) -> String
forall b a. (Show a, IsString b) => a -> b
show PParams LedgerEra
PParams (BabbageEra StandardCrypto)
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 = AlonzoTx (BabbageEra StandardCrypto)
Tx LedgerEra
tx AlonzoTx (BabbageEra StandardCrypto)
-> Getting Coin (AlonzoTx (BabbageEra StandardCrypto)) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (TxBody (BabbageEra StandardCrypto)
 -> Const Coin (TxBody (BabbageEra StandardCrypto)))
-> AlonzoTx (BabbageEra StandardCrypto)
-> Const Coin (AlonzoTx (BabbageEra StandardCrypto))
(TxBody (BabbageEra StandardCrypto)
 -> Const Coin (TxBody (BabbageEra StandardCrypto)))
-> Tx (BabbageEra StandardCrypto)
-> Const Coin (Tx (BabbageEra StandardCrypto))
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens'
  (Tx (BabbageEra StandardCrypto))
  (TxBody (BabbageEra StandardCrypto))
bodyTxL ((TxBody (BabbageEra StandardCrypto)
  -> Const Coin (TxBody (BabbageEra StandardCrypto)))
 -> AlonzoTx (BabbageEra StandardCrypto)
 -> Const Coin (AlonzoTx (BabbageEra StandardCrypto)))
-> ((Coin -> Const Coin Coin)
    -> TxBody (BabbageEra StandardCrypto)
    -> Const Coin (TxBody (BabbageEra StandardCrypto)))
-> Getting Coin (AlonzoTx (BabbageEra StandardCrypto)) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin)
-> TxBody (BabbageEra StandardCrypto)
-> Const Coin (TxBody (BabbageEra StandardCrypto))
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody (BabbageEra StandardCrypto)) Coin
feeTxBodyL

  minFee :: Coin
minFee = PParams (BabbageEra StandardCrypto)
-> Tx (BabbageEra StandardCrypto) -> Coin
forall era. EraTx era => PParams era -> Tx era -> Coin
getMinFeeTx PParams LedgerEra
PParams (BabbageEra StandardCrypto)
pparams Tx LedgerEra
Tx (BabbageEra StandardCrypto)
tx

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 (BabbageEra StandardCrypto)
 -> Const Coin (TxBody (BabbageEra StandardCrypto)))
-> TxBody (BabbageEra StandardCrypto) -> Coin
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Coin -> Const Coin Coin)
-> TxBody (BabbageEra StandardCrypto)
-> Const Coin (TxBody (BabbageEra StandardCrypto))
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody (BabbageEra StandardCrypto)) Coin
feeTxBodyL (TxBody (BabbageEra StandardCrypto) -> Coin)
-> (AlonzoTx (BabbageEra StandardCrypto)
    -> TxBody (BabbageEra StandardCrypto))
-> AlonzoTx (BabbageEra StandardCrypto)
-> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoTx (BabbageEra StandardCrypto)
-> TxBody (BabbageEra StandardCrypto)
forall era. AlonzoTx era -> TxBody era
body) AlonzoTx (BabbageEra StandardCrypto)
Tx LedgerEra
balancedTx
   in MaryValue StandardCrypto -> 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 StandardCrypto -> Coin
forall t. Val t => t -> Coin
coin Value LedgerEra
MaryValue StandardCrypto
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 StandardCrypto -> Coin
forall t. Val t => t -> Coin
coin Value LedgerEra
MaryValue StandardCrypto
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 StandardCrypto -> Coin
forall t. Val t => t -> Coin
coin Value LedgerEra
MaryValue StandardCrypto
out))

prop_picksLargestUTxOToPayTheFees :: Property
prop_picksLargestUTxOToPayTheFees :: Property
prop_picksLargestUTxOToPayTheFees =
  Gen (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
-> (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
    -> Property)
-> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
Gen (Map TxIn TxOut)
genUTxO ((Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)) -> Property)
 -> Property)
-> (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
    -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
utxo1 ->
    Gen (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
-> (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
    -> Property)
-> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
Gen (Map TxIn TxOut)
genUTxO ((Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)) -> Property)
 -> Property)
-> (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
    -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
utxo2 -> do
      let combinedUTxO :: Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
combinedUTxO = Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
-> Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
-> Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
utxo1 Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
utxo2
      case Map TxIn TxOut -> Maybe (TxIn, TxOut)
findLargestUTxO Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
Map TxIn TxOut
combinedUTxO of
        Maybe (TxIn, TxOut)
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 (BabbageEra StandardCrypto)) -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
combinedUTxO))
        Just (TxIn
_, TxOut
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 ctx. TxOut -> TxOut ctx Era
fromLedgerTxOut TxOut
txout)
              mapToLovelace :: Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)) -> 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 (BabbageEra StandardCrypto)) -> UTxO)
-> Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
-> UTxO' Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO LedgerEra -> UTxO
UTxO (BabbageEra StandardCrypto) -> UTxO
fromLedgerUTxO (UTxO (BabbageEra StandardCrypto) -> UTxO)
-> (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
    -> UTxO (BabbageEra StandardCrypto))
-> Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
-> UTxO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
-> UTxO (BabbageEra StandardCrypto)
Map
  (TxIn (EraCrypto (BabbageEra StandardCrypto)))
  (TxOut (BabbageEra StandardCrypto))
-> UTxO (BabbageEra StandardCrypto)
forall era. Map (TxIn (EraCrypto era)) (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 (BabbageEra StandardCrypto)) -> UTxO' Coin
mapToLovelace Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
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 (BabbageEra StandardCrypto)) -> UTxO' Coin
mapToLovelace Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
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 (BabbageEra StandardCrypto)) -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
combinedUTxO))

--
-- Generators
--

-- | Generate a chain point with a likely invalid block header hash.
genChainPoint :: Gen ChainPoint
genChainPoint :: Gen ChainPoint
genChainPoint =
  Gen SlotNo
forall a. Arbitrary a => Gen a
arbitrary Gen SlotNo -> (SlotNo -> Gen ChainPoint) -> Gen ChainPoint
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SlotNo -> Gen ChainPoint
genChainPointAt

-- | Generate a chain point at given slot with a likely invalid block header hash.
genChainPointAt :: SlotNo -> Gen ChainPoint
genChainPointAt :: SlotNo -> Gen ChainPoint
genChainPointAt SlotNo
s =
  SlotNo -> Hash BlockHeader -> ChainPoint
ChainPoint SlotNo
s (Hash BlockHeader -> ChainPoint)
-> (ShortByteString -> Hash BlockHeader)
-> ShortByteString
-> ChainPoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> Hash BlockHeader
HeaderHash (ShortByteString -> ChainPoint)
-> Gen ShortByteString -> Gen ChainPoint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ShortByteString
forall a. Arbitrary a => Gen a
arbitrary

-- | 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 (BabbageEra StandardCrypto)))
  Gen
  [AlonzoTx (BabbageEra StandardCrypto)]
-> Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
-> Gen [AlonzoTx (BabbageEra StandardCrypto)]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT
  (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
  Gen
  [AlonzoTx (BabbageEra StandardCrypto)]
StateT (Map TxIn TxOut) Gen [Tx LedgerEra]
genTxs Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
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 (BabbageEra StandardCrypto))) Gen Int
forall (m :: * -> *) a.
Monad m =>
m a
-> StateT (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen Int
getSize
    Int
-> StateT
     (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
     Gen
     (AlonzoTx (BabbageEra StandardCrypto))
-> StateT
     (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
     Gen
     [AlonzoTx (BabbageEra StandardCrypto)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n StateT
  (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
  Gen
  (AlonzoTx (BabbageEra StandardCrypto))
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 (BabbageEra StandardCrypto)))
  Gen
  (BabbageTxBody (BabbageEra StandardCrypto))
genBody <-
      Gen
  (StateT
     (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
     Gen
     (BabbageTxBody (BabbageEra StandardCrypto)))
-> StateT
     (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
     Gen
     (StateT
        (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
        Gen
        (BabbageTxBody (BabbageEra StandardCrypto)))
forall (m :: * -> *) a.
Monad m =>
m a
-> StateT (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen
   (StateT
      (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
      Gen
      (BabbageTxBody (BabbageEra StandardCrypto)))
 -> StateT
      (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
      Gen
      (StateT
         (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
         Gen
         (BabbageTxBody (BabbageEra StandardCrypto))))
-> Gen
     (StateT
        (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
        Gen
        (BabbageTxBody (BabbageEra StandardCrypto)))
-> StateT
     (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
     Gen
     (StateT
        (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
        Gen
        (BabbageTxBody (BabbageEra StandardCrypto)))
forall a b. (a -> b) -> a -> b
$
        [(Int,
  Gen
    (StateT
       (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
       Gen
       (BabbageTxBody (BabbageEra StandardCrypto))))]
-> Gen
     (StateT
        (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
        Gen
        (BabbageTxBody (BabbageEra StandardCrypto)))
forall a. [(Int, Gen a)] -> Gen a
frequency
          [ (Int
4, StateT
  (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
  Gen
  (BabbageTxBody (BabbageEra StandardCrypto))
-> Gen
     (StateT
        (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
        Gen
        (BabbageTxBody (BabbageEra StandardCrypto)))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StateT
   (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
   Gen
   (BabbageTxBody (BabbageEra StandardCrypto))
 -> Gen
      (StateT
         (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
         Gen
         (BabbageTxBody (BabbageEra StandardCrypto))))
-> StateT
     (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
     Gen
     (BabbageTxBody (BabbageEra StandardCrypto))
-> Gen
     (StateT
        (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
        Gen
        (BabbageTxBody (BabbageEra StandardCrypto)))
forall a b. (a -> b) -> a -> b
$ Gen (BabbageTxBody (BabbageEra StandardCrypto))
-> StateT
     (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
     Gen
     (BabbageTxBody (BabbageEra StandardCrypto))
forall (m :: * -> *) a.
Monad m =>
m a
-> StateT (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen (BabbageTxBody (BabbageEra StandardCrypto))
forall a. Arbitrary a => Gen a
arbitrary)
          , (Int
1, StateT
  (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
  Gen
  (BabbageTxBody (BabbageEra StandardCrypto))
-> Gen
     (StateT
        (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
        Gen
        (BabbageTxBody (BabbageEra StandardCrypto)))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StateT
  (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
  Gen
  (BabbageTxBody (BabbageEra StandardCrypto))
StateT (Map TxIn TxOut) Gen (BabbageTxBody LedgerEra)
genBodyFromUTxO)
          ]
    BabbageTxBody (BabbageEra StandardCrypto)
body <- StateT
  (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
  Gen
  (BabbageTxBody (BabbageEra StandardCrypto))
genBody
    Gen (AlonzoTx (BabbageEra StandardCrypto))
-> StateT
     (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
     Gen
     (AlonzoTx (BabbageEra StandardCrypto))
forall (m :: * -> *) a.
Monad m =>
m a
-> StateT (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen (AlonzoTx (BabbageEra StandardCrypto))
 -> StateT
      (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
      Gen
      (AlonzoTx (BabbageEra StandardCrypto)))
-> Gen (AlonzoTx (BabbageEra StandardCrypto))
-> StateT
     (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
     Gen
     (AlonzoTx (BabbageEra StandardCrypto))
forall a b. (a -> b) -> a -> b
$
      TxBody (BabbageEra StandardCrypto)
-> TxWits (BabbageEra StandardCrypto)
-> IsValid
-> StrictMaybe (TxAuxData (BabbageEra StandardCrypto))
-> AlonzoTx (BabbageEra StandardCrypto)
forall era.
TxBody era
-> TxWits era
-> IsValid
-> StrictMaybe (TxAuxData era)
-> AlonzoTx era
AlonzoTx TxBody (BabbageEra StandardCrypto)
BabbageTxBody (BabbageEra StandardCrypto)
body
        (AlonzoTxWits (BabbageEra StandardCrypto)
 -> IsValid
 -> StrictMaybe (AlonzoTxAuxData (BabbageEra StandardCrypto))
 -> AlonzoTx (BabbageEra StandardCrypto))
-> Gen (AlonzoTxWits (BabbageEra StandardCrypto))
-> Gen
     (IsValid
      -> StrictMaybe (AlonzoTxAuxData (BabbageEra StandardCrypto))
      -> AlonzoTx (BabbageEra StandardCrypto))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (AlonzoTxWits (BabbageEra StandardCrypto))
forall a. Arbitrary a => Gen a
arbitrary
        Gen
  (IsValid
   -> StrictMaybe (AlonzoTxAuxData (BabbageEra StandardCrypto))
   -> AlonzoTx (BabbageEra StandardCrypto))
-> Gen IsValid
-> Gen
     (StrictMaybe (AlonzoTxAuxData (BabbageEra StandardCrypto))
      -> AlonzoTx (BabbageEra StandardCrypto))
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 (BabbageEra StandardCrypto))
   -> AlonzoTx (BabbageEra StandardCrypto))
-> Gen (StrictMaybe (AlonzoTxAuxData (BabbageEra StandardCrypto)))
-> Gen (AlonzoTx (BabbageEra StandardCrypto))
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 (BabbageEra StandardCrypto)))
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 (BabbageTxBody LedgerEra)
  genBodyFromUTxO :: StateT (Map TxIn TxOut) Gen (BabbageTxBody LedgerEra)
genBodyFromUTxO = do
    TxBody (BabbageEra StandardCrypto)
base <- Gen (TxBody (BabbageEra StandardCrypto))
-> StateT
     (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
     Gen
     (TxBody (BabbageEra StandardCrypto))
forall (m :: * -> *) a.
Monad m =>
m a
-> StateT (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen (TxBody (BabbageEra StandardCrypto))
forall a. Arbitrary a => Gen a
arbitrary
    (TxIn (EraCrypto (BabbageEra StandardCrypto))
input, TxOut (BabbageEra StandardCrypto)
output) <- (Map
   (TxIn (EraCrypto (BabbageEra StandardCrypto)))
   (TxOut (BabbageEra StandardCrypto))
 -> (TxIn (EraCrypto (BabbageEra StandardCrypto)),
     TxOut (BabbageEra StandardCrypto)))
-> StateT
     (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
     Gen
     (TxIn (EraCrypto (BabbageEra StandardCrypto)),
      TxOut (BabbageEra StandardCrypto))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Map
  (TxIn (EraCrypto (BabbageEra StandardCrypto)))
  (TxOut (BabbageEra StandardCrypto))
-> (TxIn (EraCrypto (BabbageEra StandardCrypto)),
    TxOut (BabbageEra StandardCrypto))
forall k a. Map k a -> (k, a)
Map.findMax
    let body :: BabbageTxBody (BabbageEra StandardCrypto)
body =
          TxBody (BabbageEra StandardCrypto)
base
            TxBody (BabbageEra StandardCrypto)
-> (TxBody (BabbageEra StandardCrypto)
    -> TxBody (BabbageEra StandardCrypto))
-> TxBody (BabbageEra StandardCrypto)
forall a b. a -> (a -> b) -> b
& (Set (TxIn (EraCrypto (BabbageEra StandardCrypto)))
 -> Identity (Set (TxIn (EraCrypto (BabbageEra StandardCrypto)))))
-> TxBody (BabbageEra StandardCrypto)
-> Identity (TxBody (BabbageEra StandardCrypto))
forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
  (TxBody (BabbageEra StandardCrypto))
  (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
inputsTxBodyL ((Set (TxIn (EraCrypto (BabbageEra StandardCrypto)))
  -> Identity (Set (TxIn (EraCrypto (BabbageEra StandardCrypto)))))
 -> TxBody (BabbageEra StandardCrypto)
 -> Identity (TxBody (BabbageEra StandardCrypto)))
-> Set (TxIn (EraCrypto (BabbageEra StandardCrypto)))
-> TxBody (BabbageEra StandardCrypto)
-> TxBody (BabbageEra StandardCrypto)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn (EraCrypto (BabbageEra StandardCrypto))
-> Set (TxIn (EraCrypto (BabbageEra StandardCrypto)))
forall a. a -> Set a
Set.singleton TxIn (EraCrypto (BabbageEra StandardCrypto))
input
            TxBody (BabbageEra StandardCrypto)
-> (TxBody (BabbageEra StandardCrypto)
    -> BabbageTxBody (BabbageEra StandardCrypto))
-> BabbageTxBody (BabbageEra StandardCrypto)
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut (BabbageEra StandardCrypto))
 -> Identity (StrictSeq (TxOut (BabbageEra StandardCrypto))))
-> TxBody (BabbageEra StandardCrypto)
-> Identity (TxBody (BabbageEra StandardCrypto))
(StrictSeq (TxOut (BabbageEra StandardCrypto))
 -> Identity (StrictSeq (TxOut (BabbageEra StandardCrypto))))
-> TxBody (BabbageEra StandardCrypto)
-> Identity (BabbageTxBody (BabbageEra StandardCrypto))
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens'
  (TxBody (BabbageEra StandardCrypto))
  (StrictSeq (TxOut (BabbageEra StandardCrypto)))
outputsTxBodyL ((StrictSeq (TxOut (BabbageEra StandardCrypto))
  -> Identity (StrictSeq (TxOut (BabbageEra StandardCrypto))))
 -> TxBody (BabbageEra StandardCrypto)
 -> Identity (BabbageTxBody (BabbageEra StandardCrypto)))
-> StrictSeq (TxOut (BabbageEra StandardCrypto))
-> TxBody (BabbageEra StandardCrypto)
-> BabbageTxBody (BabbageEra StandardCrypto)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxOut (BabbageEra StandardCrypto)
-> StrictSeq (TxOut (BabbageEra StandardCrypto))
forall a. a -> StrictSeq a
StrictSeq.singleton TxOut (BabbageEra StandardCrypto)
output
    let input' :: TxIn (EraCrypto (BabbageEra StandardCrypto))
input' = TxId (EraCrypto (BabbageEra StandardCrypto))
-> TxIx -> TxIn (EraCrypto (BabbageEra StandardCrypto))
forall c. TxId c -> TxIx -> TxIn c
Ledger.TxIn (SafeHash
  (EraCrypto (BabbageEra StandardCrypto)) EraIndependentTxBody
-> TxId (EraCrypto (BabbageEra StandardCrypto))
forall c. SafeHash c EraIndependentTxBody -> TxId c
Ledger.TxId (SafeHash
   (EraCrypto (BabbageEra StandardCrypto)) EraIndependentTxBody
 -> TxId (EraCrypto (BabbageEra StandardCrypto)))
-> SafeHash
     (EraCrypto (BabbageEra StandardCrypto)) EraIndependentTxBody
-> TxId (EraCrypto (BabbageEra StandardCrypto))
forall a b. (a -> b) -> a -> b
$ BabbageTxBody (BabbageEra StandardCrypto)
-> SafeHash
     (EraCrypto (BabbageEra StandardCrypto)) EraIndependentTxBody
forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
SafeHash.hashAnnotated BabbageTxBody (BabbageEra StandardCrypto)
body) (Word64 -> TxIx
Ledger.TxIx Word64
0)
    (Map
   (TxIn (EraCrypto (BabbageEra StandardCrypto)))
   (TxOut (BabbageEra StandardCrypto))
 -> Map
      (TxIn (EraCrypto (BabbageEra StandardCrypto)))
      (TxOut (BabbageEra StandardCrypto)))
-> StateT
     (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))) Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\Map
  (TxIn (EraCrypto (BabbageEra StandardCrypto)))
  (TxOut (BabbageEra StandardCrypto))
m -> Map
  (TxIn (EraCrypto (BabbageEra StandardCrypto)))
  (TxOut (BabbageEra StandardCrypto))
m Map
  (TxIn (EraCrypto (BabbageEra StandardCrypto)))
  (TxOut (BabbageEra StandardCrypto))
-> (Map
      (TxIn (EraCrypto (BabbageEra StandardCrypto)))
      (TxOut (BabbageEra StandardCrypto))
    -> Map
         (TxIn (EraCrypto (BabbageEra StandardCrypto)))
         (TxOut (BabbageEra StandardCrypto)))
-> Map
     (TxIn (EraCrypto (BabbageEra StandardCrypto)))
     (TxOut (BabbageEra StandardCrypto))
forall a b. a -> (a -> b) -> b
& TxIn (EraCrypto (BabbageEra StandardCrypto))
-> Map
     (TxIn (EraCrypto (BabbageEra StandardCrypto)))
     (TxOut (BabbageEra StandardCrypto))
-> Map
     (TxIn (EraCrypto (BabbageEra StandardCrypto)))
     (TxOut (BabbageEra StandardCrypto))
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete TxIn (EraCrypto (BabbageEra StandardCrypto))
input Map
  (TxIn (EraCrypto (BabbageEra StandardCrypto)))
  (TxOut (BabbageEra StandardCrypto))
-> (Map
      (TxIn (EraCrypto (BabbageEra StandardCrypto)))
      (TxOut (BabbageEra StandardCrypto))
    -> Map
         (TxIn (EraCrypto (BabbageEra StandardCrypto)))
         (TxOut (BabbageEra StandardCrypto)))
-> Map
     (TxIn (EraCrypto (BabbageEra StandardCrypto)))
     (TxOut (BabbageEra StandardCrypto))
forall a b. a -> (a -> b) -> b
& TxIn (EraCrypto (BabbageEra StandardCrypto))
-> TxOut (BabbageEra StandardCrypto)
-> Map
     (TxIn (EraCrypto (BabbageEra StandardCrypto)))
     (TxOut (BabbageEra StandardCrypto))
-> Map
     (TxIn (EraCrypto (BabbageEra StandardCrypto)))
     (TxOut (BabbageEra StandardCrypto))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TxIn (EraCrypto (BabbageEra StandardCrypto))
input' TxOut (BabbageEra StandardCrypto)
output)
    BabbageTxBody (BabbageEra StandardCrypto)
-> StateT
     (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
     Gen
     (BabbageTxBody (BabbageEra StandardCrypto))
forall a.
a
-> StateT
     (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))) Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BabbageTxBody (BabbageEra StandardCrypto)
body

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

genOutputsForInputs :: Tx LedgerEra -> Gen (Map TxIn TxOut)
genOutputsForInputs :: Tx LedgerEra -> Gen (Map TxIn TxOut)
genOutputsForInputs AlonzoTx{TxBody (BabbageEra StandardCrypto)
body :: forall era. AlonzoTx era -> TxBody era
body :: TxBody (BabbageEra StandardCrypto)
body} = do
  let n :: Int
n = Set (TxIn (EraCrypto (BabbageEra StandardCrypto))) -> Int
forall a. Set a -> Int
Set.size (Getting
  (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
  (TxBody (BabbageEra StandardCrypto))
  (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
-> BabbageTxBody (BabbageEra StandardCrypto)
-> Set (TxIn (EraCrypto (BabbageEra StandardCrypto)))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
  (TxBody (BabbageEra StandardCrypto))
  (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
  (TxBody (BabbageEra StandardCrypto))
  (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
inputsTxBodyL TxBody (BabbageEra StandardCrypto)
BabbageTxBody (BabbageEra StandardCrypto)
body)
  [BabbageTxOut (BabbageEra StandardCrypto)]
outs <- Int
-> Gen (BabbageTxOut (BabbageEra StandardCrypto))
-> Gen [BabbageTxOut (BabbageEra StandardCrypto)]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
n Gen (BabbageTxOut (BabbageEra StandardCrypto))
forall a. Arbitrary a => Gen a
arbitrary
  Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
-> Gen (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
 -> Gen (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))))
-> Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
-> Gen (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
forall a b. (a -> b) -> a -> b
$ [(TxIn, BabbageTxOut (BabbageEra StandardCrypto))]
-> Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(TxIn, BabbageTxOut (BabbageEra StandardCrypto))]
 -> Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
-> [(TxIn, BabbageTxOut (BabbageEra StandardCrypto))]
-> Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
forall a b. (a -> b) -> a -> b
$ [TxIn]
-> [BabbageTxOut (BabbageEra StandardCrypto)]
-> [(TxIn, BabbageTxOut (BabbageEra StandardCrypto))]
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 (BabbageEra StandardCrypto)) (Set TxIn)
-> BabbageTxBody (BabbageEra StandardCrypto) -> Set TxIn
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Set TxIn) (TxBody (BabbageEra StandardCrypto)) (Set TxIn)
(Set (TxIn (EraCrypto (BabbageEra StandardCrypto)))
 -> Const
      (Set TxIn) (Set (TxIn (EraCrypto (BabbageEra StandardCrypto)))))
-> TxBody (BabbageEra StandardCrypto)
-> Const (Set TxIn) (TxBody (BabbageEra StandardCrypto))
forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
  (TxBody (BabbageEra StandardCrypto))
  (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
inputsTxBodyL TxBody (BabbageEra StandardCrypto)
BabbageTxBody (BabbageEra StandardCrypto)
body)) [BabbageTxOut (BabbageEra StandardCrypto)]
outs

genLedgerTx :: Gen (Tx LedgerEra)
genLedgerTx :: Gen (Tx LedgerEra)
genLedgerTx = do
  AlonzoTx (BabbageEra StandardCrypto)
tx <- Gen (AlonzoTx (BabbageEra StandardCrypto))
forall a. Arbitrary a => Gen a
arbitrary
  TxBody (BabbageEra StandardCrypto)
body <- (\TxBody (BabbageEra StandardCrypto)
x -> TxBody (BabbageEra StandardCrypto)
x TxBody (BabbageEra StandardCrypto)
-> (TxBody (BabbageEra StandardCrypto)
    -> TxBody (BabbageEra StandardCrypto))
-> TxBody (BabbageEra StandardCrypto)
forall a b. a -> (a -> b) -> b
& ASetter
  (TxBody (BabbageEra StandardCrypto))
  (TxBody (BabbageEra StandardCrypto))
  Coin
  Coin
-> Coin
-> TxBody (BabbageEra StandardCrypto)
-> TxBody (BabbageEra StandardCrypto)
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (TxBody (BabbageEra StandardCrypto))
  (TxBody (BabbageEra StandardCrypto))
  Coin
  Coin
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody (BabbageEra StandardCrypto)) Coin
feeTxBodyL (Integer -> Coin
Coin Integer
0)) (TxBody (BabbageEra StandardCrypto)
 -> TxBody (BabbageEra StandardCrypto))
-> Gen (TxBody (BabbageEra StandardCrypto))
-> Gen (TxBody (BabbageEra StandardCrypto))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (TxBody (BabbageEra StandardCrypto))
forall a. Arbitrary a => Gen a
arbitrary
  AlonzoTx (BabbageEra StandardCrypto)
-> Gen (AlonzoTx (BabbageEra StandardCrypto))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AlonzoTx (BabbageEra StandardCrypto)
 -> Gen (AlonzoTx (BabbageEra StandardCrypto)))
-> AlonzoTx (BabbageEra StandardCrypto)
-> Gen (AlonzoTx (BabbageEra StandardCrypto))
forall a b. (a -> b) -> a -> b
$ AlonzoTx (BabbageEra StandardCrypto)
tx{body, wits = mempty}

--
-- 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 (BabbageEra StandardCrypto)) (Set TxIn)
-> TxBody (BabbageEra StandardCrypto) -> Set TxIn
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Set TxIn) (TxBody (BabbageEra StandardCrypto)) (Set TxIn)
(Set (TxIn (EraCrypto (BabbageEra StandardCrypto)))
 -> Const
      (Set TxIn) (Set (TxIn (EraCrypto (BabbageEra StandardCrypto)))))
-> TxBody (BabbageEra StandardCrypto)
-> Const (Set TxIn) (TxBody (BabbageEra StandardCrypto))
forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
  (TxBody (BabbageEra StandardCrypto))
  (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
inputsTxBodyL (TxBody (BabbageEra StandardCrypto) -> Set TxIn)
-> (AlonzoTx (BabbageEra StandardCrypto)
    -> TxBody (BabbageEra StandardCrypto))
-> AlonzoTx (BabbageEra StandardCrypto)
-> Set TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoTx (BabbageEra StandardCrypto)
-> TxBody (BabbageEra StandardCrypto)
forall era. AlonzoTx era -> TxBody era
body (AlonzoTx (BabbageEra StandardCrypto) -> Set TxIn)
-> [AlonzoTx (BabbageEra StandardCrypto)] -> [Set TxIn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AlonzoTx (BabbageEra StandardCrypto)]
[Tx LedgerEra]
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 (BabbageEra StandardCrypto))]
-> StrictSeq (BabbageTxOut (BabbageEra StandardCrypto))
forall a. Monoid a => [a] -> a
mconcat (Getting
  (StrictSeq (BabbageTxOut (BabbageEra StandardCrypto)))
  (BabbageTxBody (BabbageEra StandardCrypto))
  (StrictSeq (BabbageTxOut (BabbageEra StandardCrypto)))
-> TxBody (BabbageEra StandardCrypto)
-> StrictSeq (BabbageTxOut (BabbageEra StandardCrypto))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (StrictSeq (BabbageTxOut (BabbageEra StandardCrypto)))
  (BabbageTxBody (BabbageEra StandardCrypto))
  (StrictSeq (BabbageTxOut (BabbageEra StandardCrypto)))
(StrictSeq (TxOut (BabbageEra StandardCrypto))
 -> Const
      (StrictSeq (BabbageTxOut (BabbageEra StandardCrypto)))
      (StrictSeq (TxOut (BabbageEra StandardCrypto))))
-> TxBody (BabbageEra StandardCrypto)
-> Const
     (StrictSeq (BabbageTxOut (BabbageEra StandardCrypto)))
     (TxBody (BabbageEra StandardCrypto))
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens'
  (TxBody (BabbageEra StandardCrypto))
  (StrictSeq (TxOut (BabbageEra StandardCrypto)))
outputsTxBodyL (TxBody (BabbageEra StandardCrypto)
 -> StrictSeq (BabbageTxOut (BabbageEra StandardCrypto)))
-> (AlonzoTx (BabbageEra StandardCrypto)
    -> TxBody (BabbageEra StandardCrypto))
-> AlonzoTx (BabbageEra StandardCrypto)
-> StrictSeq (BabbageTxOut (BabbageEra StandardCrypto))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoTx (BabbageEra StandardCrypto)
-> TxBody (BabbageEra StandardCrypto)
forall era. AlonzoTx era -> TxBody era
body (AlonzoTx (BabbageEra StandardCrypto)
 -> StrictSeq (BabbageTxOut (BabbageEra StandardCrypto)))
-> [AlonzoTx (BabbageEra StandardCrypto)]
-> [StrictSeq (BabbageTxOut (BabbageEra StandardCrypto))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AlonzoTx (BabbageEra StandardCrypto)]
[Tx LedgerEra]
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 Addr (EraCrypto (BabbageEra StandardCrypto))
addr' Value (BabbageEra StandardCrypto)
_ Datum (BabbageEra StandardCrypto)
_ StrictMaybe (Script (BabbageEra StandardCrypto))
_) -> Address
Addr (EraCrypto (BabbageEra StandardCrypto))
addr') (BabbageTxOut (BabbageEra StandardCrypto) -> Address)
-> [BabbageTxOut (BabbageEra StandardCrypto)] -> [Address]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
-> [BabbageTxOut (BabbageEra StandardCrypto)]
forall k a. Map k a -> [a]
Map.elems Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
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 (BabbageEra StandardCrypto)) -> [TxIn]
forall k a. Map k a -> [k]
Map.keys (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)) -> [TxIn])
-> Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)) -> [TxIn]
forall a b. (a -> b) -> a -> b
$ Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
-> Set TxIn -> Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
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 (BabbageEra StandardCrypto)]
ours = Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
-> [BabbageTxOut (BabbageEra StandardCrypto)]
forall k a. Map k a -> [a]
Map.elems Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
Map TxIn TxOut
utxo
   in (BabbageTxOut (BabbageEra StandardCrypto) -> Bool)
-> [BabbageTxOut (BabbageEra StandardCrypto)]
-> [BabbageTxOut (BabbageEra StandardCrypto)]
forall a. (a -> Bool) -> [a] -> [a]
filter (BabbageTxOut (BabbageEra StandardCrypto)
-> [BabbageTxOut (BabbageEra StandardCrypto)] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [BabbageTxOut (BabbageEra StandardCrypto)]
ours) ([Tx LedgerEra] -> [TxOut]
allTxOuts [Tx LedgerEra]
blk)

getValue :: TxOut -> Value LedgerEra
getValue :: TxOut -> Value LedgerEra
getValue (BabbageTxOut Addr (EraCrypto (BabbageEra StandardCrypto))
_ Value (BabbageEra StandardCrypto)
value Datum (BabbageEra StandardCrypto)
_ StrictMaybe (Script (BabbageEra StandardCrypto))
_) = Value LedgerEra
Value (BabbageEra StandardCrypto)
value

deltaValue :: Value LedgerEra -> Value LedgerEra -> Value LedgerEra
deltaValue :: Value LedgerEra -> Value LedgerEra -> Value LedgerEra
deltaValue Value LedgerEra
a Value LedgerEra
b
  | MaryValue StandardCrypto -> Coin
forall t. Val t => t -> Coin
coin Value LedgerEra
MaryValue StandardCrypto
a Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
> MaryValue StandardCrypto -> Coin
forall t. Val t => t -> Coin
coin Value LedgerEra
MaryValue StandardCrypto
b = Value LedgerEra
MaryValue StandardCrypto
a MaryValue StandardCrypto
-> MaryValue StandardCrypto -> MaryValue StandardCrypto
forall a. Semigroup a => a -> a -> a
<> MaryValue StandardCrypto -> MaryValue StandardCrypto
forall t. Val t => t -> t
invert Value LedgerEra
MaryValue StandardCrypto
b
  | Bool
otherwise = MaryValue StandardCrypto -> MaryValue StandardCrypto
forall t. Val t => t -> t
invert Value LedgerEra
MaryValue StandardCrypto
a MaryValue StandardCrypto
-> MaryValue StandardCrypto -> MaryValue StandardCrypto
forall a. Semigroup a => a -> a -> a
<> Value LedgerEra
MaryValue StandardCrypto
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 StandardCrypto)
-> [TxIn] -> MaryValue StandardCrypto
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 StandardCrypto
resolve ([TxIn] -> MaryValue StandardCrypto)
-> (AlonzoTx (BabbageEra StandardCrypto) -> [TxIn])
-> AlonzoTx (BabbageEra StandardCrypto)
-> MaryValue StandardCrypto
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 (BabbageEra StandardCrypto) -> Set TxIn)
-> AlonzoTx (BabbageEra StandardCrypto)
-> [TxIn]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Set TxIn) (TxBody (BabbageEra StandardCrypto)) (Set TxIn)
-> BabbageTxBody (BabbageEra StandardCrypto) -> Set TxIn
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Set TxIn) (TxBody (BabbageEra StandardCrypto)) (Set TxIn)
(Set (TxIn (EraCrypto (BabbageEra StandardCrypto)))
 -> Const
      (Set TxIn) (Set (TxIn (EraCrypto (BabbageEra StandardCrypto)))))
-> TxBody (BabbageEra StandardCrypto)
-> Const (Set TxIn) (TxBody (BabbageEra StandardCrypto))
forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
  (TxBody (BabbageEra StandardCrypto))
  (Set (TxIn (EraCrypto (BabbageEra StandardCrypto))))
inputsTxBodyL (BabbageTxBody (BabbageEra StandardCrypto) -> Set TxIn)
-> (AlonzoTx (BabbageEra StandardCrypto)
    -> BabbageTxBody (BabbageEra StandardCrypto))
-> AlonzoTx (BabbageEra StandardCrypto)
-> Set TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoTx (BabbageEra StandardCrypto)
-> TxBody (BabbageEra StandardCrypto)
AlonzoTx (BabbageEra StandardCrypto)
-> BabbageTxBody (BabbageEra StandardCrypto)
forall era. AlonzoTx era -> TxBody era
body
 where
  resolve :: TxIn -> Value LedgerEra
  resolve :: TxIn -> Value LedgerEra
resolve TxIn
k = MaryValue StandardCrypto
-> (BabbageTxOut (BabbageEra StandardCrypto)
    -> MaryValue StandardCrypto)
-> Maybe (BabbageTxOut (BabbageEra StandardCrypto))
-> MaryValue StandardCrypto
forall b a. b -> (a -> b) -> Maybe a -> b
maybe MaryValue StandardCrypto
forall t. Val t => t
zero BabbageTxOut (BabbageEra StandardCrypto)
-> MaryValue StandardCrypto
TxOut -> Value LedgerEra
getValue (TxIn
-> Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
-> Maybe (BabbageTxOut (BabbageEra StandardCrypto))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIn
k Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
Map TxIn TxOut
utxo)

-- | NOTE: This does not account for deposits
outputBalance :: Tx LedgerEra -> Value LedgerEra
outputBalance :: Tx LedgerEra -> Value LedgerEra
outputBalance =
  (BabbageTxOut (BabbageEra StandardCrypto)
 -> MaryValue StandardCrypto)
-> StrictSeq (BabbageTxOut (BabbageEra StandardCrypto))
-> MaryValue StandardCrypto
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 (BabbageEra StandardCrypto)
-> MaryValue StandardCrypto
TxOut -> Value LedgerEra
getValue (StrictSeq (BabbageTxOut (BabbageEra StandardCrypto))
 -> MaryValue StandardCrypto)
-> (AlonzoTx (BabbageEra StandardCrypto)
    -> StrictSeq (BabbageTxOut (BabbageEra StandardCrypto)))
-> AlonzoTx (BabbageEra StandardCrypto)
-> MaryValue StandardCrypto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (StrictSeq (BabbageTxOut (BabbageEra StandardCrypto)))
  (BabbageTxBody (BabbageEra StandardCrypto))
  (StrictSeq (BabbageTxOut (BabbageEra StandardCrypto)))
-> BabbageTxBody (BabbageEra StandardCrypto)
-> StrictSeq (BabbageTxOut (BabbageEra StandardCrypto))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (StrictSeq (BabbageTxOut (BabbageEra StandardCrypto)))
  (BabbageTxBody (BabbageEra StandardCrypto))
  (StrictSeq (BabbageTxOut (BabbageEra StandardCrypto)))
(StrictSeq (TxOut (BabbageEra StandardCrypto))
 -> Const
      (StrictSeq (BabbageTxOut (BabbageEra StandardCrypto)))
      (StrictSeq (TxOut (BabbageEra StandardCrypto))))
-> TxBody (BabbageEra StandardCrypto)
-> Const
     (StrictSeq (BabbageTxOut (BabbageEra StandardCrypto)))
     (TxBody (BabbageEra StandardCrypto))
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens'
  (TxBody (BabbageEra StandardCrypto))
  (StrictSeq (TxOut (BabbageEra StandardCrypto)))
outputsTxBodyL (BabbageTxBody (BabbageEra StandardCrypto)
 -> StrictSeq (BabbageTxOut (BabbageEra StandardCrypto)))
-> (AlonzoTx (BabbageEra StandardCrypto)
    -> BabbageTxBody (BabbageEra StandardCrypto))
-> AlonzoTx (BabbageEra StandardCrypto)
-> StrictSeq (BabbageTxOut (BabbageEra StandardCrypto))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoTx (BabbageEra StandardCrypto)
-> TxBody (BabbageEra StandardCrypto)
AlonzoTx (BabbageEra StandardCrypto)
-> BabbageTxBody (BabbageEra StandardCrypto)
forall era. AlonzoTx era -> TxBody era
body