{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Dijkstra.Imp.UtxoSpec (spec) where

import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
import Cardano.Ledger.Dijkstra.Core
import Cardano.Ledger.Dijkstra.Rules (DijkstraUtxoPredFailure (..))
import Cardano.Ledger.Dijkstra.State
import Cardano.Ledger.Dijkstra.UTxO (dijkstraConsumed)
import Cardano.Ledger.Mary.Value (
  AssetName,
  MaryValue (..),
  PolicyID (..),
  multiAssetFromList,
 )
import Cardano.Ledger.Plutus
import qualified Cardano.Ledger.Shelley.AdaPots as AdaPots
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Scripts (pattern RequireSignature)
import Cardano.Ledger.Shelley.UTxO (produced)
import Cardano.Ledger.Tools (ensureMinCoinTxOut)
import Cardano.Ledger.TxIn
import Cardano.Ledger.Val
import qualified Data.Map.Strict as Map
import qualified Data.OMap.Strict as OMap
import qualified Data.Sequence.Strict as StrictSeq
import qualified Data.Set as Set
import Data.Typeable (Typeable)
import Lens.Micro
import Test.Cardano.Ledger.Core.Utils (txInAt)
import Test.Cardano.Ledger.Dijkstra.ImpTest
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples (alwaysFailsWithDatum, alwaysSucceedsWithDatum)

spec ::
  forall era.
  DijkstraEraImp era =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
DijkstraEraImp era =>
SpecWith (ImpInit (LedgerSpec era))
spec = String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"UTXO" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Collaterals" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    -- https://github.com/IntersectMBO/formal-ledger-specifications/issues/1264
    -- TODO: Re-enable after issue is resolved, by removing this override
    String
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"Fails to submit a transaction containing a Ptr in collateral return" (ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
      cred <- KeyHash Payment -> Credential Payment
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash Payment -> Credential Payment)
-> ImpM (LedgerSpec era) (KeyHash Payment)
-> ImpM (LedgerSpec era) (Credential Payment)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash Payment)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      ptr <- arbitrary
      pp <- getsPParams id
      let
        ptrAddr = Network -> Credential Payment -> StakeReference -> Addr
Addr Network
Testnet Credential Payment
cred (Ptr -> StakeReference
StakeRefPtr Ptr
ptr)
        ptrOutput = PParams era -> TxOut era -> TxOut era
forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
ensureMinCoinTxOut PParams era
pp (TxOut era -> TxOut era) -> TxOut era -> TxOut era
forall a b. (a -> b) -> a -> b
$ Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
ptrAddr (Value era -> TxOut era)
-> (Coin -> Value era) -> Coin -> TxOut era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> Value era
forall t s. Inject t s => t -> s
inject (Coin -> TxOut era) -> Coin -> TxOut era
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
100
        tx =
          TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
            Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((StrictMaybe (TxOut era) -> Identity (StrictMaybe (TxOut era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (StrictMaybe (TxOut era) -> Identity (StrictMaybe (TxOut era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe (TxOut era) -> Identity (StrictMaybe (TxOut era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era.
BabbageEraTxBody era =>
Lens' (TxBody TopTx era) (StrictMaybe (TxOut era))
Lens' (TxBody TopTx era) (StrictMaybe (TxOut era))
collateralReturnTxBodyL ((StrictMaybe (TxOut era) -> Identity (StrictMaybe (TxOut era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> StrictMaybe (TxOut era) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxOut era -> StrictMaybe (TxOut era)
forall a. a -> StrictMaybe a
SJust TxOut era
ptrOutput
      submitFailingTx tx [injectFailure $ PtrPresentInCollateralReturn ptrOutput]

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"value produced by a transaction" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"counts each new pool deposit at most once across the batch" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      pp <- Lens' (PParams era) (PParams era) -> ImpTestM era (PParams era)
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (PParams era -> f (PParams era)) -> PParams era -> f (PParams era)
forall a. a -> a
Lens' (PParams era) (PParams era)
id
      let genTx = do
            poolKh <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
            tx <- registerPoolTxWithSubTxs [poolKh] [[poolKh], [poolKh]]
            -- just the pool deposits are in `produced` because the transaction is not fixed up
            expectProduced tx $ inject (pp ^. ppPoolDepositL)
            pure tx
      submitInAllModes genTx

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"counts distinct pool deposits in top and sub separately" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      let genTx :: ImpM (LedgerSpec era) (Tx TopTx era)
genTx = do
            pp <- Lens' (PParams era) (PParams era) -> ImpTestM era (PParams era)
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (PParams era -> f (PParams era)) -> PParams era -> f (PParams era)
forall a. a -> a
Lens' (PParams era) (PParams era)
id
            poolA <- freshKeyHash
            poolB <- freshKeyHash
            tx <- registerPoolTxWithSubTxs [poolB, poolA, poolB] [[poolA, poolA, poolB], [poolA, poolB]]
            expectProduced tx $ inject ((2 :: Int) <×> (pp ^. ppPoolDepositL))
            pure tx
      HasCallStack =>
ImpM (LedgerSpec era) (Tx TopTx era) -> ImpM (LedgerSpec era) ()
ImpM (LedgerSpec era) (Tx TopTx era) -> ImpM (LedgerSpec era) ()
submitInAllModes ImpM (LedgerSpec era) (Tx TopTx era)
genTx

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"includes sub-tx cert deposits when top has no certs" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      pp <- Lens' (PParams era) (PParams era) -> ImpTestM era (PParams era)
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (PParams era -> f (PParams era)) -> PParams era -> f (PParams era)
forall a. a -> a
Lens' (PParams era) (PParams era)
id
      let genTx = do
            poolKh <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
            tx <- registerPoolTxWithSubTxs [] [[poolKh]]
            expectProduced tx $ inject (pp ^. ppPoolDepositL)
            pure tx
      submitInAllModes genTx

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does not count re-registrations of an already-registered pool across the batch" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      let genTx :: ImpM (LedgerSpec era) (Tx TopTx era)
genTx = do
            poolKh <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
            registerPool poolKh
            tx <- registerPoolTxWithSubTxs [poolKh] [[poolKh]]
            expectProduced tx mempty
            pure tx
      HasCallStack =>
ImpM (LedgerSpec era) (Tx TopTx era) -> ImpM (LedgerSpec era) ()
ImpM (LedgerSpec era) (Tx TopTx era) -> ImpM (LedgerSpec era) ()
submitInAllModes ImpM (LedgerSpec era) (Tx TopTx era)
genTx

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"dedupes across multiple subtransactions registering the same fresh pool" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      pp <- Lens' (PParams era) (PParams era) -> ImpTestM era (PParams era)
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (PParams era -> f (PParams era)) -> PParams era -> f (PParams era)
forall a. a -> a
Lens' (PParams era) (PParams era)
id
      let genTx = do
            poolKh <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
            tx <- registerPoolTxWithSubTxs [] [[poolKh], [poolKh]]
            expectProduced tx $ inject (pp ^. ppPoolDepositL)
            pure tx
      submitInAllModes genTx

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"sums outputs, fee, treasury donations and deposits across the batch" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      pp <- Lens' (PParams era) (PParams era) -> ImpTestM era (PParams era)
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (PParams era -> f (PParams era)) -> PParams era -> f (PParams era)
forall a. a -> a
Lens' (PParams era) (PParams era)
id
      let genTx = do
            let poolDeposit :: Coin
poolDeposit = PParams era
pp PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era.
(EraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppPoolDepositL
                dRepDeposit :: Coin
dRepDeposit = PParams era
pp PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era. ConwayEraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppDRepDepositL

            let freshPoolCert :: ImpM (LedgerSpec era) (TxCert era)
freshPoolCert = do
                  poolKh <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
                  pps <- freshPoolParams poolKh =<< registerAccountAddress
                  pure $ RegPoolTxCert @era pps
            topPoolCert <- ImpM (LedgerSpec era) (TxCert era)
freshPoolCert
            subPoolCert <- freshPoolCert

            let freshDRepCert = do
                  kh <- ImpM (LedgerSpec era) (KeyHash DRepRole)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
                  pure $ RegDRepTxCert @era (KeyHashObj kh) dRepDeposit SNothing
            topDRepCert <- freshDRepCert
            subDRepCert <- freshDRepCert

            subDDAccount <- registerAccountAddress
            subDDAmount <- (Coin 1 <>) <$> arbitrary

            topOut <- freshTxOut
            subOut <- freshTxOut
            topTreasury <- arbitrary
            subTreasury <- arbitrary
            -- we are setting the fee manually in order to verify the `produced` value before the fixup.
            topFee <- (Coin 3_000_000 <>) <$> arbitrary

            let subTx :: Tx SubTx era
                subTx =
                  TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$
                    TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
                      TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> StrictSeq (TxOut era) -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (StrictSeq (TxOut era))
TxOut era
subOut]
                      TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL
                        ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> StrictSeq (TxCert era) -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (StrictSeq (TxCert era))
TxCert era
subPoolCert, Item (StrictSeq (TxCert era))
TxCert era
subDRepCert]
                      TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
ConwayEraTxBody era =>
Lens' (TxBody l era) Coin
forall (l :: TxLevel). Lens' (TxBody l era) Coin
treasuryDonationTxBodyL ((Coin -> Identity Coin)
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> Coin -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
subTreasury
                      TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (DirectDeposits -> Identity DirectDeposits)
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
DijkstraEraTxBody era =>
Lens' (TxBody l era) DirectDeposits
forall (l :: TxLevel). Lens' (TxBody l era) DirectDeposits
directDepositsTxBodyL ((DirectDeposits -> Identity DirectDeposits)
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> DirectDeposits -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map AccountAddress Coin -> DirectDeposits
DirectDeposits [(AccountAddress
subDDAccount, Coin
subDDAmount)]
                topTx :: Tx TopTx era
                topTx =
                  TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody TopTx era -> Tx TopTx era)
-> TxBody TopTx era -> Tx TopTx era
forall a b. (a -> b) -> a -> b
$
                    TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
                      TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> StrictSeq (TxOut era) -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (StrictSeq (TxOut era))
TxOut era
topOut]
                      TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx era) Coin
feeTxBodyL ((Coin -> Identity Coin)
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> Coin -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
topFee
                      TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL
                        ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> StrictSeq (TxCert era) -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (StrictSeq (TxCert era))
TxCert era
topPoolCert, Item (StrictSeq (TxCert era))
TxCert era
topDRepCert]
                      TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
ConwayEraTxBody era =>
Lens' (TxBody l era) Coin
forall (l :: TxLevel). Lens' (TxBody l era) Coin
treasuryDonationTxBodyL ((Coin -> Identity Coin)
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> Coin -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
topTreasury
                      TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (OMap TxId (Tx SubTx era) -> Identity (OMap TxId (Tx SubTx era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era.
DijkstraEraTxBody era =>
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
subTransactionsTxBodyL ((OMap TxId (Tx SubTx era) -> Identity (OMap TxId (Tx SubTx era)))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> OMap TxId (Tx SubTx era) -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (OMap TxId (Tx SubTx era))
Tx SubTx era
subTx]
                -- we're not adding direct deposits at the top level
                -- in order to be able to submit this transaction when switched to legacy mode
                -- (which doesn't support direct deposits)
                expectedCoin =
                  (TxOut era
topOut TxOut era -> Getting Coin (TxOut era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxOut era) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL)
                    Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> (TxOut era
subOut TxOut era -> Getting Coin (TxOut era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxOut era) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL)
                    Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
topFee
                    Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
topTreasury
                    Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
subTreasury
                    Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> ((Int
2 :: Int) Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> Coin
poolDeposit)
                    Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> ((Int
2 :: Int) Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> Coin
dRepDeposit)
                    Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
subDDAmount
            expectProduced topTx $ inject expectedCoin
            checkDepositCalculation
              (topTx ^. bodyTxL)
              (((2 :: Int) <×> poolDeposit) <> ((2 :: Int) <×> dRepDeposit))
              (poolDeposit <> dRepDeposit)
            pure topTx

      submitInAllModes genTx

    String
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"sums assets burned by the top and the sub transaction" (ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
      let genTx :: ImpM (LedgerSpec era) (Tx TopTx era)
genTx = do
            -- Mint upfront the tokens that the batch is going to burn: one output for the top
            -- transaction to spend and one for the sub transaction.
            policyId <- ScriptHash -> PolicyID
PolicyID (ScriptHash -> PolicyID)
-> ImpM (LedgerSpec era) ScriptHash
-> ImpM (LedgerSpec era) PolicyID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NativeScript era -> ImpM (LedgerSpec era) ScriptHash
forall era.
EraScript era =>
NativeScript era -> ImpTestM era ScriptHash
impAddNativeScript (NativeScript era -> ImpM (LedgerSpec era) ScriptHash)
-> (KeyHash Witness -> NativeScript era)
-> KeyHash Witness
-> ImpM (LedgerSpec era) ScriptHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyHash Witness -> NativeScript era
forall era.
ShelleyEraScript era =>
KeyHash Witness -> NativeScript era
RequireSignature (KeyHash Witness -> ImpM (LedgerSpec era) ScriptHash)
-> ImpM (LedgerSpec era) (KeyHash Witness)
-> ImpM (LedgerSpec era) ScriptHash
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImpM (LedgerSpec era) (KeyHash Witness)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash)
            assetName <- arbitrary @AssetName
            topBurnAmount <- getPositive <$> arbitrary
            subBurnAmount <- getPositive <$> arbitrary
            tokenAddr <- freshKeyAddr_
            let tokens Integer
n = [(PolicyID, AssetName, Integer)] -> MultiAsset
multiAssetFromList [(PolicyID
policyId, AssetName
assetName, Integer
n)]
            mintTx <-
              submitTx $
                mkBasicTx $
                  mkBasicTxBody
                    & mintTxBodyL .~ tokens (topBurnAmount + subBurnAmount)
                    & outputsTxBodyL
                      .~ [ mkBasicTxOut tokenAddr (MaryValue mempty (tokens topBurnAmount))
                         , mkBasicTxOut tokenAddr (MaryValue mempty (tokens subBurnAmount))
                         ]
            topOut <- freshTxOut
            subOut <- freshTxOut
            topFee <- (Coin 3_000_000 <>) <$> arbitrary
            let subTx :: Tx SubTx era
                subTx =
                  TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$
                    TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
                      TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> Set TxIn -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Int -> Tx TopTx era -> TxIn
forall era (l :: TxLevel).
(HasCallStack, EraTx era) =>
Int -> Tx l era -> TxIn
txInAt (Int
1 :: Int) Tx TopTx era
mintTx]
                      TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> StrictSeq (TxOut era) -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (StrictSeq (TxOut era))
TxOut era
subOut]
                      TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (MultiAsset -> Identity MultiAsset)
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
MaryEraTxBody era =>
Lens' (TxBody l era) MultiAsset
forall (l :: TxLevel). Lens' (TxBody l era) MultiAsset
mintTxBodyL ((MultiAsset -> Identity MultiAsset)
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> MultiAsset -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> MultiAsset
tokens (Integer -> Integer
forall a. Num a => a -> a
negate Integer
subBurnAmount)
                topTx :: Tx TopTx era
                topTx =
                  TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody TopTx era -> Tx TopTx era)
-> TxBody TopTx era -> Tx TopTx era
forall a b. (a -> b) -> a -> b
$
                    TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
                      TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> Set TxIn -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Int -> Tx TopTx era -> TxIn
forall era (l :: TxLevel).
(HasCallStack, EraTx era) =>
Int -> Tx l era -> TxIn
txInAt (Int
0 :: Int) Tx TopTx era
mintTx]
                      TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> StrictSeq (TxOut era) -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (StrictSeq (TxOut era))
TxOut era
topOut]
                      TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx era) Coin
feeTxBodyL ((Coin -> Identity Coin)
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> Coin -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
topFee
                      TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (MultiAsset -> Identity MultiAsset)
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
MaryEraTxBody era =>
Lens' (TxBody l era) MultiAsset
forall (l :: TxLevel). Lens' (TxBody l era) MultiAsset
mintTxBodyL ((MultiAsset -> Identity MultiAsset)
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> MultiAsset -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> MultiAsset
tokens (Integer -> Integer
forall a. Num a => a -> a
negate Integer
topBurnAmount)
                      TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (OMap TxId (Tx SubTx era) -> Identity (OMap TxId (Tx SubTx era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era.
DijkstraEraTxBody era =>
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
subTransactionsTxBodyL ((OMap TxId (Tx SubTx era) -> Identity (OMap TxId (Tx SubTx era)))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> OMap TxId (Tx SubTx era) -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (OMap TxId (Tx SubTx era))
Tx SubTx era
subTx]
                expected =
                  Coin -> MultiAsset -> MaryValue
MaryValue
                    ((TxOut era
topOut TxOut era -> Getting Coin (TxOut era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxOut era) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL) Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> (TxOut era
subOut TxOut era -> Getting Coin (TxOut era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxOut era) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL) Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
topFee)
                    (Integer -> MultiAsset
tokens (Integer
topBurnAmount Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
subBurnAmount))
            expectProduced topTx expected
            pure topTx
      HasCallStack =>
ImpM (LedgerSpec era) (Tx TopTx era) -> ImpM (LedgerSpec era) ()
ImpM (LedgerSpec era) (Tx TopTx era) -> ImpM (LedgerSpec era) ()
submitInAllModes ImpM (LedgerSpec era) (Tx TopTx era)
genTx

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"value consumed by a transaction" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"sums inputs, withdrawals and refunds across the batch" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      let genTx :: ImpM (LedgerSpec era) (Tx TopTx era)
genTx = do
            keyDeposit <- Lens' (PParams era) Coin -> ImpM (LedgerSpec era) Coin
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (Coin -> f Coin) -> PParams era -> f (PParams era)
forall era.
(EraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL
            dRepDeposit <- getsPParams ppDRepDepositL

            -- accounts and DReps that the batch unregisters, one of each in the top
            -- transaction and one of each in the sub-transaction
            topCred <- freshRegisteredStakeCred
            subCred <- freshRegisteredStakeCred
            topDRep <- KeyHashObj <$> registerDRep
            subDRep <- KeyHashObj <$> registerDRep

            -- accounts that the batch withdraws from. They are distinct from the ones
            -- above, because an account with a non-zero balance cannot be unregistered.
            (topAccount, topWithdrawal) <- freshFundedAccount
            (subAccount, subWithdrawal) <- freshFundedAccount

            topInAmount <- Coin <$> choose (1_000_000, 2_000_000)
            topIn <- txInWithFunds topInAmount
            subInAmount <- Coin <$> choose (1_000_000, 2_000_000)
            subIn <- txInWithFunds subInAmount

            let subTx :: Tx SubTx era
                subTx =
                  TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$
                    TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
                      TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> Set TxIn -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
subIn]
                      TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (Withdrawals -> Identity Withdrawals)
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) Withdrawals
forall (l :: TxLevel). Lens' (TxBody l era) Withdrawals
withdrawalsTxBodyL ((Withdrawals -> Identity Withdrawals)
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> Withdrawals -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map AccountAddress Coin -> Withdrawals
Withdrawals [(AccountAddress
subAccount, Coin
subWithdrawal)]
                      TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL
                        ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> StrictSeq (TxCert era) -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ Credential Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential Staking -> Coin -> TxCert era
UnRegDepositTxCert Credential Staking
subCred Coin
keyDeposit
                           , Credential DRepRole -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential DRepRole -> Coin -> TxCert era
UnRegDRepTxCert Credential DRepRole
subDRep Coin
dRepDeposit
                           ]
                topTx :: Tx TopTx era
                topTx =
                  TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody TopTx era -> Tx TopTx era)
-> TxBody TopTx era -> Tx TopTx era
forall a b. (a -> b) -> a -> b
$
                    TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
                      TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> Set TxIn -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
topIn]
                      TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (Withdrawals -> Identity Withdrawals)
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) Withdrawals
forall (l :: TxLevel). Lens' (TxBody l era) Withdrawals
withdrawalsTxBodyL ((Withdrawals -> Identity Withdrawals)
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> Withdrawals -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map AccountAddress Coin -> Withdrawals
Withdrawals [(AccountAddress
topAccount, Coin
topWithdrawal)]
                      TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL
                        ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> StrictSeq (TxCert era) -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ Credential Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential Staking -> Coin -> TxCert era
UnRegDepositTxCert Credential Staking
topCred Coin
keyDeposit
                           , Credential DRepRole -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential DRepRole -> Coin -> TxCert era
UnRegDRepTxCert Credential DRepRole
topDRep Coin
dRepDeposit
                           ]
                      TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (OMap TxId (Tx SubTx era) -> Identity (OMap TxId (Tx SubTx era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era.
DijkstraEraTxBody era =>
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
subTransactionsTxBodyL ((OMap TxId (Tx SubTx era) -> Identity (OMap TxId (Tx SubTx era)))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> OMap TxId (Tx SubTx era) -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (OMap TxId (Tx SubTx era))
Tx SubTx era
subTx]
                batchRefunds = ((Int
2 :: Int) Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> Coin
keyDeposit) Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> ((Int
2 :: Int) Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> Coin
dRepDeposit)
                expectedCoin =
                  Coin
topInAmount
                    Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
subInAmount
                    Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
topWithdrawal
                    Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
subWithdrawal
                    Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
batchRefunds
            expectConsumed topTx $ inject expectedCoin
            checkRefundCalculation (topTx ^. bodyTxL) batchRefunds (keyDeposit <> dRepDeposit)
            pure topTx
      HasCallStack =>
ImpM (LedgerSpec era) (Tx TopTx era) -> ImpM (LedgerSpec era) ()
ImpM (LedgerSpec era) (Tx TopTx era) -> ImpM (LedgerSpec era) ()
submitInAllModes ImpM (LedgerSpec era) (Tx TopTx era)
genTx

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"includes sub-tx cert refunds when top has no certs" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      let genTx :: ImpM (LedgerSpec era) (Tx TopTx era)
genTx = do
            keyDeposit <- Lens' (PParams era) Coin -> ImpM (LedgerSpec era) Coin
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (Coin -> f Coin) -> PParams era -> f (PParams era)
forall era.
(EraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL
            dRepDeposit <- getsPParams ppDRepDepositL
            subCred <- freshRegisteredStakeCred
            subDRep <- KeyHashObj <$> registerDRep
            let subTx :: Tx SubTx era
                subTx =
                  TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$
                    TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
                      TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL
                        ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> StrictSeq (TxCert era) -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ Credential Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential Staking -> Coin -> TxCert era
UnRegDepositTxCert Credential Staking
subCred Coin
keyDeposit
                           , Credential DRepRole -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential DRepRole -> Coin -> TxCert era
UnRegDRepTxCert Credential DRepRole
subDRep Coin
dRepDeposit
                           ]
                topTx = [Tx SubTx era] -> Tx TopTx era
forall era. DijkstraEraImp era => [Tx SubTx era] -> Tx TopTx era
mkTopTxWithSubTxs [Item [Tx SubTx era]
Tx SubTx era
subTx]
            expectConsumed topTx $ inject (keyDeposit <> dRepDeposit)
            checkRefundCalculation (topTx ^. bodyTxL) (keyDeposit <> dRepDeposit) mempty
            pure topTx
      HasCallStack =>
ImpM (LedgerSpec era) (Tx TopTx era) -> ImpM (LedgerSpec era) ()
ImpM (LedgerSpec era) (Tx TopTx era) -> ImpM (LedgerSpec era) ()
submitInAllModes ImpM (LedgerSpec era) (Tx TopTx era)
genTx

    -- Refunds are collected from the values in the certificates, rather than from the
    -- state, which is why a deposit that is only paid within the same batch can still be
    -- refunded by it.
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"refunds deposits that are paid earlier in the same batch" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      keyDeposit <- Lens' (PParams era) Coin -> ImpM (LedgerSpec era) Coin
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (Coin -> f Coin) -> PParams era -> f (PParams era)
forall era.
(EraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL
      dRepDeposit <- getsPParams ppDRepDepositL
      cred <- KeyHashObj <$> freshKeyHash
      dRep <- KeyHashObj <$> freshKeyHash
      let subTx :: Tx SubTx era
          subTx =
            TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$
              TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
                TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL
                  ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> StrictSeq (TxCert era) -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ Credential Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential Staking -> Coin -> TxCert era
RegDepositTxCert Credential Staking
cred Coin
keyDeposit
                     , Credential DRepRole -> Coin -> StrictMaybe Anchor -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential DRepRole -> Coin -> StrictMaybe Anchor -> TxCert era
RegDRepTxCert Credential DRepRole
dRep Coin
dRepDeposit StrictMaybe Anchor
forall a. StrictMaybe a
SNothing
                     ]
          -- the batch can unregister what it has just registered
          topTx :: Tx TopTx era
          topTx =
            TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody TopTx era -> Tx TopTx era)
-> TxBody TopTx era -> Tx TopTx era
forall a b. (a -> b) -> a -> b
$
              TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
                TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL
                  ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> StrictSeq (TxCert era) -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ Credential Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential Staking -> Coin -> TxCert era
UnRegDepositTxCert Credential Staking
cred Coin
keyDeposit
                     , Credential DRepRole -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential DRepRole -> Coin -> TxCert era
UnRegDRepTxCert Credential DRepRole
dRep Coin
dRepDeposit
                     ]
                TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (OMap TxId (Tx SubTx era) -> Identity (OMap TxId (Tx SubTx era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era.
DijkstraEraTxBody era =>
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
subTransactionsTxBodyL ((OMap TxId (Tx SubTx era) -> Identity (OMap TxId (Tx SubTx era)))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> OMap TxId (Tx SubTx era) -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (OMap TxId (Tx SubTx era))
Tx SubTx era
subTx]
      expectConsumed topTx $ inject (keyDeposit <> dRepDeposit)
      expectProduced topTx $ inject (keyDeposit <> dRepDeposit)
      checkRefundCalculation (topTx ^. bodyTxL) (keyDeposit <> dRepDeposit) (keyDeposit <> dRepDeposit)

      depositedBefore <- getsNES $ nesEsL . esLStateL . lsUTxOStateL . utxosDepositedL
      submitTx_ topTx
      expectStakeCredNotRegistered cred
      depositedAfter <- getsNES $ nesEsL . esLStateL . lsUTxOStateL . utxosDepositedL
      depositedAfter `shouldBe` depositedBefore

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"refunds the deposit in the certificate, not the one in the protocol parameters" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      keyDeposit <- Lens' (PParams era) Coin -> ImpM (LedgerSpec era) Coin
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (Coin -> f Coin) -> PParams era -> f (PParams era)
forall era.
(EraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL
      dRepDeposit <- getsPParams ppDRepDepositL
      topCred <- freshRegisteredStakeCred
      subCred <- freshRegisteredStakeCred
      topDRep <- KeyHashObj <$> registerDRep
      subDRep <- KeyHashObj <$> registerDRep
      -- Overwrite the deposit protocol parameters in order to ensure they do not affect
      -- the refunds that the batch collects
      modifyPParams $ \PParams era
pp ->
        PParams era
pp
          PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> PParams era -> Identity (PParams era)
forall era.
(EraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL ((Coin -> Identity Coin) -> PParams era -> Identity (PParams era))
-> Coin -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
1
          PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> PParams era -> Identity (PParams era)
forall era. ConwayEraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppDRepDepositL ((Coin -> Identity Coin) -> PParams era -> Identity (PParams era))
-> Coin -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
2
      let subTx :: Tx SubTx era
          subTx =
            TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$
              TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
                TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL
                  ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> StrictSeq (TxCert era) -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ Credential Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential Staking -> Coin -> TxCert era
UnRegDepositTxCert Credential Staking
subCred Coin
keyDeposit
                     , Credential DRepRole -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential DRepRole -> Coin -> TxCert era
UnRegDRepTxCert Credential DRepRole
subDRep Coin
dRepDeposit
                     ]
          topTx :: Tx TopTx era
          topTx =
            TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody TopTx era -> Tx TopTx era)
-> TxBody TopTx era -> Tx TopTx era
forall a b. (a -> b) -> a -> b
$
              TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
                TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL
                  ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> StrictSeq (TxCert era) -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ Credential Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential Staking -> Coin -> TxCert era
UnRegDepositTxCert Credential Staking
topCred Coin
keyDeposit
                     , Credential DRepRole -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential DRepRole -> Coin -> TxCert era
UnRegDRepTxCert Credential DRepRole
topDRep Coin
dRepDeposit
                     ]
                TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (OMap TxId (Tx SubTx era) -> Identity (OMap TxId (Tx SubTx era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era.
DijkstraEraTxBody era =>
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
subTransactionsTxBodyL ((OMap TxId (Tx SubTx era) -> Identity (OMap TxId (Tx SubTx era)))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> OMap TxId (Tx SubTx era) -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (OMap TxId (Tx SubTx era))
Tx SubTx era
subTx]
          batchRefunds = ((Int
2 :: Int) Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> Coin
keyDeposit) Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> ((Int
2 :: Int) Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> Coin
dRepDeposit)
      expectConsumed topTx $ inject batchRefunds
      checkRefundCalculation (topTx ^. bodyTxL) batchRefunds (keyDeposit <> dRepDeposit)
      submitTx_ topTx

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Value preservation" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    let mkSubTx :: BatchAmounts -> ImpTestM era (Tx SubTx era)
        mkSubTx :: BatchAmounts -> ImpTestM era (Tx SubTx era)
mkSubTx BatchAmounts {Coin
baSubTxIn :: Coin
baSubTxOut :: Coin
baSubDirectDeposit :: Coin
baTopTxIn :: Coin
baTopWithdrawal :: Coin
baTopTxOut :: Coin
baFee :: Coin
baScriptTxIn :: Coin
baScriptTxIn :: BatchAmounts -> Coin
baFee :: BatchAmounts -> Coin
baTopTxOut :: BatchAmounts -> Coin
baTopWithdrawal :: BatchAmounts -> Coin
baTopTxIn :: BatchAmounts -> Coin
baSubDirectDeposit :: BatchAmounts -> Coin
baSubTxOut :: BatchAmounts -> Coin
baSubTxIn :: BatchAmounts -> Coin
..} = do
          txIn <- Coin -> ImpM (LedgerSpec era) TxIn
txInWithFunds Coin
baSubTxIn
          txOut <- mkTxOut baSubTxOut
          account <- registerAccountAddress
          pure $
            mkBasicTx $
              mkBasicTxBody
                & inputsTxBodyL .~ [txIn]
                & outputsTxBodyL .~ [txOut]
                & directDepositsTxBodyL .~ DirectDeposits [(account, baSubDirectDeposit)]

    let mkTopTx :: BatchAmounts -> ImpTestM era (Tx TopTx era)
        mkTopTx :: BatchAmounts -> ImpM (LedgerSpec era) (Tx TopTx era)
mkTopTx amounts :: BatchAmounts
amounts@BatchAmounts {Coin
baScriptTxIn :: BatchAmounts -> Coin
baFee :: BatchAmounts -> Coin
baTopTxOut :: BatchAmounts -> Coin
baTopWithdrawal :: BatchAmounts -> Coin
baTopTxIn :: BatchAmounts -> Coin
baSubDirectDeposit :: BatchAmounts -> Coin
baSubTxOut :: BatchAmounts -> Coin
baSubTxIn :: BatchAmounts -> Coin
baSubTxIn :: Coin
baSubTxOut :: Coin
baSubDirectDeposit :: Coin
baTopTxIn :: Coin
baTopWithdrawal :: Coin
baTopTxOut :: Coin
baFee :: Coin
baScriptTxIn :: Coin
..} = do
          txIn <- Coin -> ImpM (LedgerSpec era) TxIn
txInWithFunds Coin
baTopTxIn
          txOut <- mkTxOut baTopTxOut
          account <- registerAccountAddress
          fundAccountBalance account baTopWithdrawal
          subTx <- mkSubTx amounts
          pure $
            mkBasicTx $
              mkBasicTxBody
                & inputsTxBodyL .~ [txIn]
                & outputsTxBodyL .~ [txOut]
                & feeTxBodyL .~ baFee
                & withdrawalsTxBodyL .~ Withdrawals [(account, baTopWithdrawal)]
                & subTransactionsTxBodyL .~ OMap.singleton subTx

    let mkTopTxLegacyMode :: BatchAmounts -> Tx TopTx era -> ImpTestM era (Tx TopTx era)
        mkTopTxLegacyMode :: BatchAmounts
-> Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era)
mkTopTxLegacyMode BatchAmounts {Coin
baScriptTxIn :: BatchAmounts -> Coin
baFee :: BatchAmounts -> Coin
baTopTxOut :: BatchAmounts -> Coin
baTopWithdrawal :: BatchAmounts -> Coin
baTopTxIn :: BatchAmounts -> Coin
baSubDirectDeposit :: BatchAmounts -> Coin
baSubTxOut :: BatchAmounts -> Coin
baSubTxIn :: BatchAmounts -> Coin
baSubTxIn :: Coin
baSubTxOut :: Coin
baSubDirectDeposit :: Coin
baTopTxIn :: Coin
baTopWithdrawal :: Coin
baTopTxOut :: Coin
baFee :: Coin
baScriptTxIn :: Coin
..} Tx TopTx era
tx = do
          scriptTxIn <- ScriptHash -> Coin -> ImpM (LedgerSpec era) TxIn
produceScriptAt (Plutus 'PlutusV3 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus 'PlutusV3 -> ScriptHash) -> Plutus 'PlutusV3 -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV3 -> Plutus 'PlutusV3
forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsWithDatum SLanguage 'PlutusV3
SPlutusV3) Coin
baScriptTxIn
          pure $
            tx
              & bodyTxL . inputsTxBodyL <>~ Set.singleton scriptTxIn
              & bodyTxL . feeTxBodyL <>~ baScriptTxIn

    let mkTopTxLegacyModePhase2Invalid :: BatchAmounts -> Tx TopTx era -> ImpTestM era (Tx TopTx era)
        mkTopTxLegacyModePhase2Invalid :: BatchAmounts
-> Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era)
mkTopTxLegacyModePhase2Invalid BatchAmounts {Coin
baScriptTxIn :: BatchAmounts -> Coin
baFee :: BatchAmounts -> Coin
baTopTxOut :: BatchAmounts -> Coin
baTopWithdrawal :: BatchAmounts -> Coin
baTopTxIn :: BatchAmounts -> Coin
baSubDirectDeposit :: BatchAmounts -> Coin
baSubTxOut :: BatchAmounts -> Coin
baSubTxIn :: BatchAmounts -> Coin
baSubTxIn :: Coin
baSubTxOut :: Coin
baSubDirectDeposit :: Coin
baTopTxIn :: Coin
baTopWithdrawal :: Coin
baTopTxOut :: Coin
baFee :: Coin
baScriptTxIn :: Coin
..} Tx TopTx era
tx = do
          scriptTxIn <- ScriptHash -> Coin -> ImpM (LedgerSpec era) TxIn
produceScriptAt (Plutus 'PlutusV3 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus 'PlutusV3 -> ScriptHash) -> Plutus 'PlutusV3 -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV3 -> Plutus 'PlutusV3
forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsWithDatum SLanguage 'PlutusV3
SPlutusV3) Coin
baScriptTxIn
          pure $
            tx
              & bodyTxL . inputsTxBodyL <>~ Set.singleton scriptTxIn
              & bodyTxL . feeTxBodyL <>~ baScriptTxIn

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"tx balanced across the batch and at the top level - normal mode" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      amounts <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genFullyBalancedAmounts
      topTx <- mkTopTx amounts
      withFixup noBalanceFixup $ submitTx_ topTx

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"tx balanced across the batch and at the top level - legacy mode" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      amounts <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genFullyBalancedAmounts
      topTx <- mkTopTx amounts
      topTxLegacy <- mkTopTxLegacyMode amounts topTx
      withFixup noBalanceFixup $ submitTx_ topTxLegacy

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"tx balanced across the batch and at the top level - legacy mode, phase2 invalid" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      amounts <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genFullyBalancedAmounts
      topTxInvalid <- mkTopTxLegacyModePhase2Invalid amounts =<< mkTopTx amounts
      withFixup noBalanceFixup $ submitPhase2Invalid_ topTxInvalid

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"tx balanced across the batch and unbalanced at the top level - normal mode" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      amounts <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genBatchOnlyBalancedAmounts
      topTx <- mkTopTx amounts
      withFixup noBalanceFixup $ submitTx_ topTx

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"tx balanced across the batch and unbalanced at the top level - legacy mode" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      amounts <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genBatchOnlyBalancedAmounts
      topTx <- mkTopTx amounts
      topTxLegacy <- mkTopTxLegacyMode amounts topTx
      let balances = Bool -> BatchAmounts -> BatchBalances
batchBalances Bool
True BatchAmounts
amounts
      withFixup noBalanceFixup $
        submitFailingTx
          topTxLegacy
          [ injectFailure $
              ValueNotConservedInLegacyMode
                Mismatch
                  { mismatchSupplied = inject (bbTopConsumed balances)
                  , mismatchExpected = inject (bbTopProduced balances)
                  }
          ]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"tx balanced at the top level and unbalanced across the batch - normal mode" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      amounts <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genTopOnlyBalancedAmounts
      topTx <- mkTopTx amounts
      let balances = Bool -> BatchAmounts -> BatchBalances
batchBalances Bool
False BatchAmounts
amounts
      withFixup noBalanceFixup $
        submitFailingTx
          topTx
          [ injectFailure $
              ValueNotConservedUTxO
                Mismatch
                  { mismatchSupplied = inject (bbBatchConsumed balances)
                  , mismatchExpected = inject (bbBatchProduced balances)
                  }
          ]
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"tx balanced at the top level and unbalanced across the batch - legacy mode" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      amounts <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genTopOnlyBalancedAmounts
      topTx <- mkTopTx amounts
      topTxLegacy <- mkTopTxLegacyMode amounts topTx
      let balances = Bool -> BatchAmounts -> BatchBalances
batchBalances Bool
True BatchAmounts
amounts
      withFixup noBalanceFixup $
        submitFailingTx
          topTxLegacy
          [ injectFailure $
              ValueNotConservedUTxO
                Mismatch
                  { mismatchSupplied = inject (bbBatchConsumed balances)
                  , mismatchExpected = inject (bbBatchProduced balances)
                  }
          ]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"tx unbalanced across the batch and at the top level - normal mode" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      amounts <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genFullyUnbalancedAmounts
      topTx <- mkTopTx amounts
      let balances = Bool -> BatchAmounts -> BatchBalances
batchBalances Bool
False BatchAmounts
amounts
      withFixup noBalanceFixup $
        submitFailingTx
          topTx
          [ injectFailure $
              ValueNotConservedUTxO
                Mismatch
                  { mismatchSupplied = inject (bbBatchConsumed balances)
                  , mismatchExpected = inject (bbBatchProduced balances)
                  }
          ]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"tx unbalanced across the batch and at the top level - legacy mode" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      amounts <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genFullyUnbalancedAmounts
      topTx <- mkTopTx amounts
      topTxLegacy <- mkTopTxLegacyMode amounts topTx
      let balances = Bool -> BatchAmounts -> BatchBalances
batchBalances Bool
True BatchAmounts
amounts
      withFixup noBalanceFixup $
        submitFailingTx
          topTxLegacy
          [ injectFailure $
              ValueNotConservedInLegacyMode
                Mismatch
                  { mismatchSupplied = inject (bbTopConsumed balances)
                  , mismatchExpected = inject (bbTopProduced balances)
                  }
          , injectFailure $
              ValueNotConservedUTxO
                Mismatch
                  { mismatchSupplied = inject (bbBatchConsumed balances)
                  , mismatchExpected = inject (bbBatchProduced balances)
                  }
          ]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a failing phase-1 check suppresses the script failure" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      pp <- Lens' (PParams era) (PParams era) -> ImpTestM era (PParams era)
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (PParams era -> f (PParams era)) -> PParams era -> f (PParams era)
forall a. a -> a
Lens' (PParams era) (PParams era)
id
      amounts <- do
        balanced <- genFullyBalancedAmounts
        pure balanced {baTopTxIn = baTopTxIn balanced <> pp ^. ppPoolDepositL}

      poolKh <- freshKeyHash
      poolParams <- freshPoolParams poolKh =<< registerAccountAddress
      let addPoolCert :: forall l. Tx l era -> Tx l era
          addPoolCert = (TxBody l era -> Identity (TxBody l era))
-> Tx l era -> Identity (Tx l era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody l era -> Identity (TxBody l era))
 -> Tx l era -> Identity (Tx l era))
-> ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
    -> TxBody l era -> Identity (TxBody l era))
-> (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> Tx l era
-> Identity (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody l era -> Identity (TxBody l era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> Tx l era -> Identity (Tx l era))
-> StrictSeq (TxCert era) -> Tx l era -> Tx l era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [StakePoolParams era -> TxCert era
forall era. EraTxCert era => StakePoolParams era -> TxCert era
RegPoolTxCert StakePoolParams era
poolParams]

      topTx <- mkTopTx amounts
      -- the sub-transaction registers the pool, the top-level transaction re-registers it
      withCerts <- traverseSubTxs (pure . addPoolCert) (addPoolCert topTx)
      withFailingScript <- mkTopTxLegacyModePhase2Invalid amounts withCerts

      -- exactly one failure: no `ValidationTagMismatch` alongside it
      let balances = Bool -> BatchAmounts -> BatchBalances
batchBalances Bool
True BatchAmounts
amounts
      withFixup noBalanceFixup $
        submitFailingTx
          withFailingScript
          [ injectFailure $
              ValueNotConservedInLegacyMode
                Mismatch
                  { mismatchSupplied = inject (bbTopConsumed balances)
                  , mismatchExpected = inject (bbTopProduced balances)
                  }
          ]

    String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"fixup function for balancing subtransactions" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
      String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"top-only balanced - normal mode" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
        amounts <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genTopOnlyBalancedAmounts
        topTx <- mkTopTx amounts
        balanced <- balanceSubTransactions topTx
        withFixup noBalanceFixup $ submitTx_ balanced

      String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"top-only balanced - legacy mode" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
        amounts <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genTopOnlyBalancedAmounts
        topTx <- mkTopTx amounts
        topTxLegacy <- mkTopTxLegacyMode amounts topTx
        balanced <- balanceSubTransactions topTxLegacy
        withFixup noBalanceFixup $ submitTx_ balanced

      String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"balanced on both levels keeps it balanced" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
        amounts <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genFullyBalancedAmounts
        topTx <- mkTopTx amounts
        balanced <- balanceSubTransactions topTx
        withFixup noBalanceFixup $ submitTx_ balanced
  where
    submitInAllModes :: HasCallStack => ImpTestM era (Tx TopTx era) -> ImpTestM era ()
    submitInAllModes :: HasCallStack =>
ImpM (LedgerSpec era) (Tx TopTx era) -> ImpM (LedgerSpec era) ()
submitInAllModes ImpM (LedgerSpec era) (Tx TopTx era)
genTx = do
      Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitTx_ (Tx TopTx era -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) (Tx TopTx era) -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImpM (LedgerSpec era) (Tx TopTx era)
genTx
      Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitTx_ (Tx TopTx era -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) (Tx TopTx era) -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era)
forall era.
DijkstraEraImp era =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
switchTxToLegacyMode (Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era))
-> ImpM (LedgerSpec era) (Tx TopTx era)
-> ImpM (LedgerSpec era) (Tx TopTx era)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImpM (LedgerSpec era) (Tx TopTx era)
genTx
      Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitPhase2Invalid_ (Tx TopTx era -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) (Tx TopTx era) -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era)
forall era.
DijkstraEraImp era =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
switchTxToPhase2InvalidLegacyMode (Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era))
-> ImpM (LedgerSpec era) (Tx TopTx era)
-> ImpM (LedgerSpec era) (Tx TopTx era)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImpM (LedgerSpec era) (Tx TopTx era)
genTx
    -- TODO add switchTxToFailing, after Plutus V4 support is complete
    registerPoolTxWithSubTxs ::
      [KeyHash StakePool] -> -- top's pool certs
      [[KeyHash StakePool]] -> -- one sub-tx per inner list, with one pool cert per key
      ImpTestM era (Tx TopTx era)
    registerPoolTxWithSubTxs :: [KeyHash StakePool]
-> [[KeyHash StakePool]] -> ImpM (LedgerSpec era) (Tx TopTx era)
registerPoolTxWithSubTxs [KeyHash StakePool]
topKhs [[KeyHash StakePool]]
subKhs = do
      top <- forall (l :: TxLevel).
Typeable l =>
[KeyHash StakePool] -> ImpTestM era (Tx l era)
registerPoolTx @TopTx [KeyHash StakePool]
topKhs
      subs <- traverse (registerPoolTx @SubTx) subKhs
      pure $ top & bodyTxL . subTransactionsTxBodyL .~ OMap.fromFoldable subs
    registerPoolTx :: forall l. Typeable l => [KeyHash StakePool] -> ImpTestM era (Tx l era)
    registerPoolTx :: forall (l :: TxLevel).
Typeable l =>
[KeyHash StakePool] -> ImpTestM era (Tx l era)
registerPoolTx [KeyHash StakePool]
khPools = do
      certs <-
        (KeyHash StakePool -> ImpM (LedgerSpec era) (TxCert era))
-> [KeyHash StakePool] -> ImpM (LedgerSpec era) [TxCert era]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse
          ( \KeyHash StakePool
khPool ->
              forall era. EraTxCert era => StakePoolParams era -> TxCert era
RegPoolTxCert @era (StakePoolParams era -> TxCert era)
-> ImpTestM era (StakePoolParams era)
-> ImpM (LedgerSpec era) (TxCert era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (KeyHash StakePool
-> AccountAddress -> ImpTestM era (StakePoolParams era)
forall era.
ShelleyEraImp era =>
KeyHash StakePool
-> AccountAddress -> ImpTestM era (StakePoolParams era)
freshPoolParams KeyHash StakePool
khPool (AccountAddress -> ImpTestM era (StakePoolParams era))
-> ImpM (LedgerSpec era) AccountAddress
-> ImpTestM era (StakePoolParams era)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImpM (LedgerSpec era) AccountAddress
forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era AccountAddress
registerAccountAddress)
          )
          [KeyHash StakePool]
khPools
      pure $ mkBasicTx mkBasicTxBody & bodyTxL . certsTxBodyL .~ StrictSeq.fromList certs
    expectProduced :: Tx TopTx era -> Value era -> ImpTestM era ()
    expectProduced :: Tx TopTx era -> Value era -> ImpM (LedgerSpec era) ()
expectProduced Tx TopTx era
tx Value era
expected = do
      pp <- Lens' (PParams era) (PParams era) -> ImpTestM era (PParams era)
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (PParams era -> f (PParams era)) -> PParams era -> f (PParams era)
forall a. a -> a
Lens' (PParams era) (PParams era)
id
      pState <- getPState
      produced pp pState (tx ^. bodyTxL) `shouldBe` expected

    expectConsumed :: Tx TopTx era -> Value era -> ImpTestM era ()
    expectConsumed :: Tx TopTx era -> Value era -> ImpM (LedgerSpec era) ()
expectConsumed Tx TopTx era
tx Value era
expected = do
      pp <- Lens' (PParams era) (PParams era) -> ImpTestM era (PParams era)
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (PParams era -> f (PParams era)) -> PParams era -> f (PParams era)
forall a. a -> a
Lens' (PParams era) (PParams era)
id
      utxo <- getUTxO
      dijkstraConsumed pp utxo (tx ^. bodyTxL) `shouldBe` expected

    -- Check that `certsTotalDepositsTxBody` (used to set deposits in `UTxOState` and `AdaPots` calculations)
    -- returns the batch deposits, while `getTotalDepositsTxBody` returns the top-level deposits
    checkDepositCalculation :: TxBody TopTx era -> Coin -> Coin -> ImpM (LedgerSpec era) ()
checkDepositCalculation TxBody TopTx era
topBody Coin
batchDeposits Coin
topLevelDeposits = do
      pp <- Lens' (PParams era) (PParams era) -> ImpTestM era (PParams era)
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (PParams era -> f (PParams era)) -> PParams era -> f (PParams era)
forall a. a -> a
Lens' (PParams era) (PParams era)
id
      certState <- getsNES $ nesEsL . esLStateL . lsCertStateL
      AdaPots.proDeposits (AdaPots.producedTxBody topBody pp certState)
        `shouldBe` batchDeposits
      let isPoolReg = (KeyHash StakePool -> Map (KeyHash StakePool) StakePoolState -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` (CertState era
certState CertState era
-> Getting
     (Map (KeyHash StakePool) StakePoolState)
     (CertState era)
     (Map (KeyHash StakePool) StakePoolState)
-> Map (KeyHash StakePool) StakePoolState
forall s a. s -> Getting a s a -> a
^. (PState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
-> CertState era
-> Const (Map (KeyHash StakePool) StakePoolState) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL ((PState era
  -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
 -> CertState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (CertState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Const
          (Map (KeyHash StakePool) StakePoolState)
          (Map (KeyHash StakePool) StakePoolState))
    -> PState era
    -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
-> Getting
     (Map (KeyHash StakePool) StakePoolState)
     (CertState era)
     (Map (KeyHash StakePool) StakePoolState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyHash StakePool) StakePoolState
 -> Const
      (Map (KeyHash StakePool) StakePoolState)
      (Map (KeyHash StakePool) StakePoolState))
-> PState era
-> Const (Map (KeyHash StakePool) StakePoolState) (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash StakePool) StakePoolState
 -> f (Map (KeyHash StakePool) StakePoolState))
-> PState era -> f (PState era)
psStakePoolsL))
      getTotalDepositsTxBody pp isPoolReg topBody `shouldBe` topLevelDeposits

    -- Check that `certsTotalRefundsTxBody` (used to update the deposits in `UTxOState` and in
    -- `AdaPots` calculations) returns the batch refunds, while `getTotalRefundsTxBody` returns
    -- the top-level refunds
    checkRefundCalculation :: TxBody l era -> Coin -> Coin -> ImpM (LedgerSpec era) ()
checkRefundCalculation TxBody l era
topBody Coin
batchRefunds Coin
topLevelRefunds = do
      pp <- Lens' (PParams era) (PParams era) -> ImpTestM era (PParams era)
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (PParams era -> f (PParams era)) -> PParams era -> f (PParams era)
forall a. a -> a
Lens' (PParams era) (PParams era)
id
      certState <- getsNES $ nesEsL . esLStateL . lsCertStateL
      utxo <- getUTxO
      AdaPots.conRefunds (AdaPots.consumedTxBody topBody pp certState utxo)
        `shouldBe` batchRefunds
      -- refunds do not depend on the state, hence the deposit lookup is irrelevant
      getTotalRefundsTxBody pp (const Nothing) topBody `shouldBe` topLevelRefunds

    freshRegisteredStakeCred :: ImpM (LedgerSpec era) (Credential Staking)
freshRegisteredStakeCred = do
      cred <- KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash Staking -> Credential Staking)
-> ImpM (LedgerSpec era) (KeyHash Staking)
-> ImpM (LedgerSpec era) (Credential Staking)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      cred <$ registerStakeCredential cred

    -- An account with a freshly funded, non-zero balance
    freshFundedAccount :: ImpM (LedgerSpec era) (AccountAddress, Coin)
freshFundedAccount = do
      account <- ImpM (LedgerSpec era) AccountAddress
forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era AccountAddress
registerAccountAddress
      amount <- (Coin 1 <>) <$> arbitrary
      fundAccountBalance account amount
      pure (account, amount)

    freshTxOut :: ImpM (LedgerSpec era) (TxOut era)
freshTxOut = do
      pp <- Lens' (PParams era) (PParams era) -> ImpTestM era (PParams era)
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (PParams era -> f (PParams era)) -> PParams era -> f (PParams era)
forall a. a -> a
Lens' (PParams era) (PParams era)
id
      addr <- freshKeyAddr_
      amount <- arbitrary @Coin
      pure $ ensureMinCoinTxOut pp (mkBasicTxOut addr (inject amount))
    fundAccountBalance :: AccountAddress -> Coin -> ImpTestM era ()
    fundAccountBalance :: AccountAddress -> Coin -> ImpM (LedgerSpec era) ()
fundAccountBalance AccountAddress
account Coin
amount = do
      Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitTx_ (Tx TopTx era -> ImpM (LedgerSpec era) ())
-> Tx TopTx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
        TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody TopTx era -> Tx TopTx era)
-> TxBody TopTx era -> Tx TopTx era
forall a b. (a -> b) -> a -> b
$
          TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
            TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (DirectDeposits -> Identity DirectDeposits)
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
DijkstraEraTxBody era =>
Lens' (TxBody l era) DirectDeposits
forall (l :: TxLevel). Lens' (TxBody l era) DirectDeposits
directDepositsTxBodyL ((DirectDeposits -> Identity DirectDeposits)
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> DirectDeposits -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map AccountAddress Coin -> DirectDeposits
DirectDeposits [(AccountAddress
account, Coin
amount)]
    txInWithFunds :: Coin -> ImpTestM era TxIn
    txInWithFunds :: Coin -> ImpM (LedgerSpec era) TxIn
txInWithFunds Coin
amount = ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_ ImpM (LedgerSpec era) Addr
-> (Addr -> ImpM (LedgerSpec era) TxIn)
-> ImpM (LedgerSpec era) TxIn
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Addr
a -> Addr -> Coin -> ImpM (LedgerSpec era) TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Coin -> ImpTestM era TxIn
sendCoinTo Addr
a Coin
amount
    mkTxOut :: Coin -> ImpTestM era (TxOut era)
    mkTxOut :: Coin -> ImpM (LedgerSpec era) (TxOut era)
mkTxOut Coin
amount = ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_ ImpM (LedgerSpec era) Addr
-> (Addr -> ImpM (LedgerSpec era) (TxOut era))
-> ImpM (LedgerSpec era) (TxOut era)
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Addr
a -> TxOut era -> ImpM (LedgerSpec era) (TxOut era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxOut era -> ImpM (LedgerSpec era) (TxOut era))
-> TxOut era -> ImpM (LedgerSpec era) (TxOut era)
forall a b. (a -> b) -> a -> b
$ Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
a (Coin -> MaryValue
forall t s. Inject t s => t -> s
inject Coin
amount)
    produceScriptAt :: ScriptHash -> Coin -> ImpTestM era TxIn
    produceScriptAt :: ScriptHash -> Coin -> ImpM (LedgerSpec era) TxIn
produceScriptAt ScriptHash
scriptHash Coin
amount = do
      let addr :: Addr
addr = ScriptHash -> StakeReference -> Addr
forall p s.
(MakeCredential p Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr ScriptHash
scriptHash StakeReference
StakeRefNull
      let tx :: Tx TopTx era
tx =
            TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
              Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> StrictSeq (TxOut era) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr (Coin -> Value era
forall t s. Inject t s => t -> s
inject Coin
amount)]
      Int -> Tx TopTx era -> TxIn
forall era (l :: TxLevel).
(HasCallStack, EraTx era) =>
Int -> Tx l era -> TxIn
txInAt Int
0 (Tx TopTx era -> TxIn)
-> ImpM (LedgerSpec era) (Tx TopTx era)
-> ImpM (LedgerSpec era) TxIn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
submitTx Tx TopTx era
tx

noBalanceFixup ::
  ( HasCallStack
  , DijkstraEraImp era
  ) =>
  Tx TopTx era ->
  ImpTestM era (Tx TopTx era)
noBalanceFixup :: forall era.
(HasCallStack, DijkstraEraImp era) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
noBalanceFixup =
  Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era.
(HasCallStack, DijkstraEraImp era) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
fixupSubTransactions
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
ShelleyEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
addNativeScriptTxWits
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (m :: * -> *) (l :: TxLevel).
(EraTx era, Applicative m) =>
Tx l era -> m (Tx l era)
fixupAuxDataHash
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era.
AlonzoEraImp era =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
addCollateralInput
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupScriptWits
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupOutputDatums
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
(HasCallStack, AlonzoEraImp era) =>
Tx l era -> ImpTestM era (Tx l era)
fixupDatums
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupRedeemerIndices
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
(ShelleyEraImp era, HasCallStack) =>
Tx l era -> ImpTestM era (Tx l era)
fixupTxOuts
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era.
(ShelleyEraImp era, BabbageEraTxBody era) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
fixupCollateralReturn
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era.
(AlonzoEraImp era, HasCallStack) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
fixupRedeemers
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupPPHash
    (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
(HasCallStack, ShelleyEraImp era) =>
Tx l era -> ImpTestM era (Tx l era)
updateAddrTxWits

-- A template for creating a transaction with exactly one subtransaction,
-- with values for different fields that contribute to consumed and produced.
data BatchAmounts = BatchAmounts
  { BatchAmounts -> Coin
baSubTxIn :: Coin
  , BatchAmounts -> Coin
baSubTxOut :: Coin
  , BatchAmounts -> Coin
baSubDirectDeposit :: Coin
  , BatchAmounts -> Coin
baTopTxIn :: Coin
  , BatchAmounts -> Coin
baTopWithdrawal :: Coin
  , BatchAmounts -> Coin
baTopTxOut :: Coin
  , BatchAmounts -> Coin
baFee :: Coin
  , BatchAmounts -> Coin
baScriptTxIn :: Coin
  }

genBatchOnlyBalancedAmounts :: ImpTestM era BatchAmounts
genBatchOnlyBalancedAmounts :: forall era. ImpTestM era BatchAmounts
genBatchOnlyBalancedAmounts = do
  -- we are restricted in the lower bound by min utxo size
  -- and in the upper bound by the hardcoded collateral in `makeCollateralInput`
  m <- Integer -> Coin
Coin (Integer -> Coin)
-> ImpM (LedgerSpec era) Integer -> ImpM (LedgerSpec era) Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Integer) -> ImpM (LedgerSpec era) Integer
forall a. Random a => (a, a) -> ImpM (LedgerSpec era) a
forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Integer
1_000_000, Integer
2_000_000)
  pure $ mkAmounts m
  where
    mkAmounts :: Coin -> BatchAmounts
mkAmounts Coin
m =
      -- These values create an unbalanced sub-transaction, with:
      --      consumed = subTxIn   = 1
      --      produced = subTxOut + subDirectDeposit  =  2 + 3
      -- and an unbalanced top transaction, with:
      --      consumed = topTxIn + topWithdrawal = 8 + 5
      --      produced = topTxOut + fee    = 6 + 3
      -- Legacy variant adds scriptTxIn on both sides (input + fee)
      -- On the batch level, the transaction is balancing out.
      let amounts :: BatchAmounts
amounts =
            BatchAmounts
              { baSubTxIn :: Coin
baSubTxIn = (Int
1 :: Int) Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> Coin
m
              , baSubTxOut :: Coin
baSubTxOut = (Int
2 :: Int) Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> Coin
m
              , baSubDirectDeposit :: Coin
baSubDirectDeposit = (Int
3 :: Int) Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> Coin
m
              , baTopTxIn :: Coin
baTopTxIn = (Int
8 :: Int) Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> Coin
m
              , baTopWithdrawal :: Coin
baTopWithdrawal = (Int
5 :: Int) Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> Coin
m
              , baTopTxOut :: Coin
baTopTxOut = (Int
6 :: Int) Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> Coin
m
              , baFee :: Coin
baFee = (Int
3 :: Int) Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> Coin
m
              , baScriptTxIn :: Coin
baScriptTxIn = (Int
4 :: Int) Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> Coin
m
              }
       in HasCallStack => BatchAmounts -> BatchAmounts
BatchAmounts -> BatchAmounts
assertBatchBalanced BatchAmounts
amounts

-- Amounts for a transaction that balances out both at batch level, and at top level
genFullyBalancedAmounts :: ImpTestM era BatchAmounts
genFullyBalancedAmounts :: forall era. ImpTestM era BatchAmounts
genFullyBalancedAmounts = do
  batchBalanced@BatchAmounts {..} <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genBatchOnlyBalancedAmounts
  let BatchBalances {..} = batchBalances False batchBalanced
      mismatch = Coin
bbTopConsumed Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Coin
bbTopProduced
      fullyBalanced =
        BatchAmounts
batchBalanced
          { -- because the batch is balanced, we can fix both top and sub balances with the same `mismatch`
            baTopTxOut = baTopTxOut <> mismatch
          , baSubTxIn = baSubTxIn <> mismatch
          }
  pure $
    fullyBalanced
      & assertBatchBalanced
      & assertTopBalanced
      & assertSubBalanced

-- Amounts for a transaction that doesn't balance out - neither at top or batch level
genFullyUnbalancedAmounts :: ImpTestM era BatchAmounts
genFullyUnbalancedAmounts :: forall era. ImpTestM era BatchAmounts
genFullyUnbalancedAmounts = do
  balanced@BatchAmounts {..} <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genFullyBalancedAmounts
  extra <- Coin . getPositive <$> arbitrary
  pure $ balanced {baTopTxIn = baTopTxIn <> extra}

genTopOnlyBalancedAmounts :: ImpTestM era BatchAmounts
genTopOnlyBalancedAmounts :: forall era. ImpTestM era BatchAmounts
genTopOnlyBalancedAmounts = do
  balanced@BatchAmounts {..} <- ImpTestM era BatchAmounts
forall era. ImpTestM era BatchAmounts
genFullyBalancedAmounts
  extra <- Coin . getPositive <$> arbitrary
  pure $ balanced {baSubTxIn = baSubTxIn <> extra}

data BatchBalances = BatchBalances
  { BatchBalances -> Coin
bbSubConsumed :: Coin
  , BatchBalances -> Coin
bbSubProduced :: Coin
  , BatchBalances -> Coin
bbTopConsumed :: Coin
  , BatchBalances -> Coin
bbTopProduced :: Coin
  , BatchBalances -> Coin
bbBatchConsumed :: Coin
  , BatchBalances -> Coin
bbBatchProduced :: Coin
  }

assertBatchBalanced :: HasCallStack => BatchAmounts -> BatchAmounts
assertBatchBalanced :: HasCallStack => BatchAmounts -> BatchAmounts
assertBatchBalanced BatchAmounts
ba
  | BatchBalances -> Coin
bbBatchConsumed BatchBalances
bb Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
== BatchBalances -> Coin
bbBatchProduced BatchBalances
bb = BatchAmounts
ba
  | Bool
otherwise =
      String -> BatchAmounts
forall a. HasCallStack => String -> a
error (String -> BatchAmounts) -> String -> BatchAmounts
forall a b. (a -> b) -> a -> b
$
        String
"Impossible: batch amounts are not balanced: consumed = "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall a. Show a => a -> String
show (BatchBalances -> Coin
bbBatchConsumed BatchBalances
bb)
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", produced = "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall a. Show a => a -> String
show (BatchBalances -> Coin
bbBatchProduced BatchBalances
bb)
  where
    bb :: BatchBalances
bb = Bool -> BatchAmounts -> BatchBalances
batchBalances Bool
False BatchAmounts
ba

assertTopBalanced :: HasCallStack => BatchAmounts -> BatchAmounts
assertTopBalanced :: HasCallStack => BatchAmounts -> BatchAmounts
assertTopBalanced BatchAmounts
ba
  | BatchBalances -> Coin
bbTopConsumed BatchBalances
bb Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
== BatchBalances -> Coin
bbTopProduced BatchBalances
bb = BatchAmounts
ba
  | Bool
otherwise =
      String -> BatchAmounts
forall a. HasCallStack => String -> a
error (String -> BatchAmounts) -> String -> BatchAmounts
forall a b. (a -> b) -> a -> b
$
        String
"Impossible: top transaction amounts are not balanced: consumed = "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall a. Show a => a -> String
show (BatchBalances -> Coin
bbTopConsumed BatchBalances
bb)
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", produced = "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall a. Show a => a -> String
show (BatchBalances -> Coin
bbTopProduced BatchBalances
bb)
  where
    bb :: BatchBalances
bb = Bool -> BatchAmounts -> BatchBalances
batchBalances Bool
False BatchAmounts
ba

assertSubBalanced :: HasCallStack => BatchAmounts -> BatchAmounts
assertSubBalanced :: HasCallStack => BatchAmounts -> BatchAmounts
assertSubBalanced BatchAmounts
ba
  | BatchBalances -> Coin
bbSubConsumed BatchBalances
bb Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
== BatchBalances -> Coin
bbSubProduced BatchBalances
bb = BatchAmounts
ba
  | Bool
otherwise =
      String -> BatchAmounts
forall a. HasCallStack => String -> a
error (String -> BatchAmounts) -> String -> BatchAmounts
forall a b. (a -> b) -> a -> b
$
        String
"Impossible: sub-transaction amounts are not balanced: consumed = "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall a. Show a => a -> String
show (BatchBalances -> Coin
bbSubConsumed BatchBalances
bb)
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", produced = "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall a. Show a => a -> String
show (BatchBalances -> Coin
bbSubProduced BatchBalances
bb)
  where
    bb :: BatchBalances
bb = Bool -> BatchAmounts -> BatchBalances
batchBalances Bool
False BatchAmounts
ba

batchBalances :: Bool -> BatchAmounts -> BatchBalances
batchBalances :: Bool -> BatchAmounts -> BatchBalances
batchBalances Bool
isLegacy BatchAmounts {Coin
baScriptTxIn :: BatchAmounts -> Coin
baFee :: BatchAmounts -> Coin
baTopTxOut :: BatchAmounts -> Coin
baTopWithdrawal :: BatchAmounts -> Coin
baTopTxIn :: BatchAmounts -> Coin
baSubDirectDeposit :: BatchAmounts -> Coin
baSubTxOut :: BatchAmounts -> Coin
baSubTxIn :: BatchAmounts -> Coin
baSubTxIn :: Coin
baSubTxOut :: Coin
baSubDirectDeposit :: Coin
baTopTxIn :: Coin
baTopWithdrawal :: Coin
baTopTxOut :: Coin
baFee :: Coin
baScriptTxIn :: Coin
..} =
  let script :: Coin
script = if Bool
isLegacy then Coin
baScriptTxIn else Coin
forall a. Monoid a => a
mempty
      subConsumed :: Coin
subConsumed = Coin
baSubTxIn
      subProduced :: Coin
subProduced = Coin
baSubTxOut Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
baSubDirectDeposit
      topConsumed :: Coin
topConsumed = Coin
baTopTxIn Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
baTopWithdrawal Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
script
      topProduced :: Coin
topProduced = Coin
baTopTxOut Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
baFee Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
script
   in BatchBalances
        { bbSubConsumed :: Coin
bbSubConsumed = Coin
subConsumed
        , bbSubProduced :: Coin
bbSubProduced = Coin
subProduced
        , bbTopConsumed :: Coin
bbTopConsumed = Coin
topConsumed
        , bbTopProduced :: Coin
bbTopProduced = Coin
topProduced
        , bbBatchConsumed :: Coin
bbBatchConsumed = Coin
subConsumed Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
topConsumed
        , bbBatchProduced :: Coin
bbBatchProduced = Coin
subProduced Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
topProduced
        }