{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Api.Tx.Body (spec) where

import Cardano.Ledger.Api.Era
import Cardano.Ledger.Api.Tx.Body
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin
import Cardano.Ledger.Compactible
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.State hiding (consumed)
import Cardano.Ledger.Val
import Data.Foldable
import qualified Data.Map.Strict as Map
import Data.MapExtras as Map (extract)
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Lens.Micro
import Test.Cardano.Ledger.Api.Arbitrary ()
import Test.Cardano.Ledger.Common

totalTxDeposits ::
  (EraTxBody era, EraCertState era) =>
  Network ->
  PParams era ->
  CertState era ->
  TxBody l era ->
  Coin
totalTxDeposits :: forall era (l :: TxLevel).
(EraTxBody era, EraCertState era) =>
Network -> PParams era -> CertState era -> TxBody l era -> Coin
totalTxDeposits Network
network PParams era
pp CertState era
dpstate TxBody l era
txb =
  Int
numKeys Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> 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 => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> (Map (KeyHash StakePool) StakePoolParams, Coin) -> Coin
forall a b. (a, b) -> b
snd (((Map (KeyHash StakePool) StakePoolParams, Coin)
 -> TxCert era -> (Map (KeyHash StakePool) StakePoolParams, Coin))
-> (Map (KeyHash StakePool) StakePoolParams, Coin)
-> [TxCert era]
-> (Map (KeyHash StakePool) StakePoolParams, Coin)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Map (KeyHash StakePool) StakePoolParams, Coin)
-> TxCert era -> (Map (KeyHash StakePool) StakePoolParams, Coin)
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTxCert era) =>
(Map (KeyHash StakePool) StakePoolParams, Coin)
-> TxCert era -> (Map (KeyHash StakePool) StakePoolParams, Coin)
accum (Map (KeyHash StakePool) StakePoolParams
regpools, Integer -> Coin
Coin Integer
0) [TxCert era]
certs)
  where
    certs :: [TxCert era]
certs = StrictSeq (TxCert era) -> [TxCert era]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (TxBody l era
txb TxBody l era
-> Getting
     (StrictSeq (TxCert era)) (TxBody l era) (StrictSeq (TxCert era))
-> StrictSeq (TxCert era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (TxCert era)) (TxBody l era) (StrictSeq (TxCert 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)
    numKeys :: Int
numKeys = [TxCert era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TxCert era] -> Int) -> [TxCert era] -> Int
forall a b. (a -> b) -> a -> b
$ (TxCert era -> Bool) -> [TxCert era] -> [TxCert era]
forall a. (a -> Bool) -> [a] -> [a]
filter TxCert era -> Bool
forall era. EraTxCert era => TxCert era -> Bool
isRegStakeTxCert [TxCert era]
certs
    regpools :: Map (KeyHash StakePool) StakePoolParams
regpools =
      (KeyHash StakePool -> StakePoolState -> StakePoolParams)
-> Map (KeyHash StakePool) StakePoolState
-> Map (KeyHash StakePool) StakePoolParams
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (KeyHash StakePool -> Network -> StakePoolState -> StakePoolParams
`stakePoolStateToStakePoolParams` Network
network) (Map (KeyHash StakePool) StakePoolState
 -> Map (KeyHash StakePool) StakePoolParams)
-> Map (KeyHash StakePool) StakePoolState
-> Map (KeyHash StakePool) StakePoolParams
forall a b. (a -> b) -> a -> b
$ PState era -> Map (KeyHash StakePool) StakePoolState
forall era. PState era -> Map (KeyHash StakePool) StakePoolState
psStakePools (CertState era
dpstate CertState era
-> Getting (PState era) (CertState era) (PState era) -> PState era
forall s a. s -> Getting a s a -> a
^. Getting (PState era) (CertState era) (PState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL)
    accum :: (Map (KeyHash StakePool) StakePoolParams, Coin)
-> TxCert era -> (Map (KeyHash StakePool) StakePoolParams, Coin)
accum (!Map (KeyHash StakePool) StakePoolParams
pools, !Coin
ans) (RegPoolTxCert StakePoolParams
stakePoolParams) =
      -- We don't pay a deposit on a pool that is already registered
      if KeyHash StakePool
-> Map (KeyHash StakePool) StakePoolParams -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member (StakePoolParams -> KeyHash StakePool
sppId StakePoolParams
stakePoolParams) Map (KeyHash StakePool) StakePoolParams
pools
        then (Map (KeyHash StakePool) StakePoolParams
pools, Coin
ans)
        else (KeyHash StakePool
-> StakePoolParams
-> Map (KeyHash StakePool) StakePoolParams
-> Map (KeyHash StakePool) StakePoolParams
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (StakePoolParams -> KeyHash StakePool
sppId StakePoolParams
stakePoolParams) StakePoolParams
stakePoolParams Map (KeyHash StakePool) StakePoolParams
pools, Coin
ans Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> 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)
    accum (Map (KeyHash StakePool) StakePoolParams, Coin)
ans TxCert era
_ = (Map (KeyHash StakePool) StakePoolParams, Coin)
ans

keyTxRefunds ::
  (EraTxBody era, ShelleyEraTxCert era, EraCertState era) =>
  PParams era ->
  CertState era ->
  TxBody l era ->
  Coin
keyTxRefunds :: forall era (l :: TxLevel).
(EraTxBody era, ShelleyEraTxCert era, EraCertState era) =>
PParams era -> CertState era -> TxBody l era -> Coin
keyTxRefunds PParams era
pp CertState era
dpstate TxBody l era
tx =
  case ((Map (Credential Staking) (AccountState era),
  Set (Credential Staking), Coin)
 -> TxCert era
 -> (Map (Credential Staking) (AccountState era),
     Set (Credential Staking), Coin))
-> (Map (Credential Staking) (AccountState era),
    Set (Credential Staking), Coin)
-> StrictSeq (TxCert era)
-> (Map (Credential Staking) (AccountState era),
    Set (Credential Staking), Coin)
forall b a. (b -> a -> b) -> b -> StrictSeq a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Map (Credential Staking) (AccountState era),
 Set (Credential Staking), Coin)
-> TxCert era
-> (Map (Credential Staking) (AccountState era),
    Set (Credential Staking), Coin)
forall {era} {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ProtVerIsInBounds
   "at most"
   era
   11
   (OrdCond (CmpNat (ProtVerLow era) 11) 'True 'True 'False),
 ShelleyEraTxCert era, EraAccounts era) =>
(Map (Credential Staking) (AccountState era),
 Set (Credential Staking), Coin)
-> TxCert era
-> (Map (Credential Staking) (AccountState era),
    Set (Credential Staking), Coin)
accum (Map (Credential Staking) (AccountState era)
initAccountsMap, Set (Credential Staking)
forall a. Set a
Set.empty, Coin
forall a. Monoid a => a
mempty) StrictSeq (TxCert era)
certs of
    (Map (Credential Staking) (AccountState era)
_, Set (Credential Staking)
_, Coin
res) -> Coin
res
  where
    certs :: StrictSeq (TxCert era)
certs = TxBody l era
tx TxBody l era
-> Getting
     (StrictSeq (TxCert era)) (TxBody l era) (StrictSeq (TxCert era))
-> StrictSeq (TxCert era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (TxCert era)) (TxBody l era) (StrictSeq (TxCert 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
    initAccountsMap :: Map (Credential Staking) (AccountState era)
initAccountsMap = CertState era
dpstate CertState era
-> Getting
     (Map (Credential Staking) (AccountState era))
     (CertState era)
     (Map (Credential Staking) (AccountState era))
-> Map (Credential Staking) (AccountState era)
forall s a. s -> Getting a s a -> a
^. (DState era
 -> Const
      (Map (Credential Staking) (AccountState era)) (DState era))
-> CertState era
-> Const
     (Map (Credential Staking) (AccountState era)) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era
  -> Const
       (Map (Credential Staking) (AccountState era)) (DState era))
 -> CertState era
 -> Const
      (Map (Credential Staking) (AccountState era)) (CertState era))
-> ((Map (Credential Staking) (AccountState era)
     -> Const
          (Map (Credential Staking) (AccountState era))
          (Map (Credential Staking) (AccountState era)))
    -> DState era
    -> Const
         (Map (Credential Staking) (AccountState era)) (DState era))
-> Getting
     (Map (Credential Staking) (AccountState era))
     (CertState era)
     (Map (Credential Staking) (AccountState era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era
 -> Const
      (Map (Credential Staking) (AccountState era)) (Accounts era))
-> DState era
-> Const (Map (Credential Staking) (AccountState era)) (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL ((Accounts era
  -> Const
       (Map (Credential Staking) (AccountState era)) (Accounts era))
 -> DState era
 -> Const
      (Map (Credential Staking) (AccountState era)) (DState era))
-> ((Map (Credential Staking) (AccountState era)
     -> Const
          (Map (Credential Staking) (AccountState era))
          (Map (Credential Staking) (AccountState era)))
    -> Accounts era
    -> Const
         (Map (Credential Staking) (AccountState era)) (Accounts era))
-> (Map (Credential Staking) (AccountState era)
    -> Const
         (Map (Credential Staking) (AccountState era))
         (Map (Credential Staking) (AccountState era)))
-> DState era
-> Const (Map (Credential Staking) (AccountState era)) (DState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Credential Staking) (AccountState era)
 -> Const
      (Map (Credential Staking) (AccountState era))
      (Map (Credential Staking) (AccountState era)))
-> Accounts era
-> Const
     (Map (Credential Staking) (AccountState era)) (Accounts era)
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
accountsMapL
    keyDeposit :: Coin
keyDeposit = 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 => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL
    accum :: (Map (Credential Staking) (AccountState era),
 Set (Credential Staking), Coin)
-> TxCert era
-> (Map (Credential Staking) (AccountState era),
    Set (Credential Staking), Coin)
accum acc :: (Map (Credential Staking) (AccountState era),
 Set (Credential Staking), Coin)
acc@(!Map (Credential Staking) (AccountState era)
accountsMap, !Set (Credential Staking)
newlyRegistered, !Coin
ans) = \case
      RegTxCert Credential Staking
cred
        | Credential Staking
-> Map (Credential Staking) (AccountState era) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Credential Staking
cred Map (Credential Staking) (AccountState era)
accountsMap Bool -> Bool -> Bool
|| Credential Staking -> Set (Credential Staking) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Credential Staking
cred Set (Credential Staking)
newlyRegistered -> (Map (Credential Staking) (AccountState era),
 Set (Credential Staking), Coin)
acc
        | Bool
otherwise -> (Map (Credential Staking) (AccountState era)
accountsMap, Credential Staking
-> Set (Credential Staking) -> Set (Credential Staking)
forall a. Ord a => a -> Set a -> Set a
Set.insert Credential Staking
cred Set (Credential Staking)
newlyRegistered, Coin
ans)
      UnRegTxCert Credential Staking
cred ->
        case Credential Staking
-> Map (Credential Staking) (AccountState era)
-> (Maybe (AccountState era),
    Map (Credential Staking) (AccountState era))
forall k b. Ord k => k -> Map k b -> (Maybe b, Map k b)
Map.extract Credential Staking
cred Map (Credential Staking) (AccountState era)
accountsMap of
          (Just AccountState era
accountState, Map (Credential Staking) (AccountState era)
newAccountsMap) ->
            (Map (Credential Staking) (AccountState era)
newAccountsMap, Set (Credential Staking)
newlyRegistered, Coin
ans Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (AccountState era
accountState AccountState era
-> Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
forall era.
EraAccounts era =>
Lens' (AccountState era) (CompactForm Coin)
Lens' (AccountState era) (CompactForm Coin)
depositAccountStateL))
          (Maybe (AccountState era)
Nothing, Map (Credential Staking) (AccountState era)
newAccountsMap)
            | Credential Staking -> Set (Credential Staking) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Credential Staking
cred Set (Credential Staking)
newlyRegistered ->
                (Map (Credential Staking) (AccountState era)
newAccountsMap, Credential Staking
-> Set (Credential Staking) -> Set (Credential Staking)
forall a. Ord a => a -> Set a -> Set a
Set.delete Credential Staking
cred Set (Credential Staking)
newlyRegistered, Coin
ans Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
keyDeposit)
            | Bool
otherwise -> (Map (Credential Staking) (AccountState era),
 Set (Credential Staking), Coin)
acc
      TxCert era
_ -> (Map (Credential Staking) (AccountState era),
 Set (Credential Staking), Coin)
acc

-- | This is the old implementation of `evalBodyTxBody`. We keep it around to ensure that
-- the produced result hasn't changed
evaluateTransactionBalance ::
  (MaryEraTxBody era, ShelleyEraTxCert era, EraCertState era) =>
  Network ->
  PParams era ->
  CertState era ->
  UTxO era ->
  TxBody TopTx era ->
  Value era
evaluateTransactionBalance :: forall era.
(MaryEraTxBody era, ShelleyEraTxCert era, EraCertState era) =>
Network
-> PParams era
-> CertState era
-> UTxO era
-> TxBody TopTx era
-> Value era
evaluateTransactionBalance Network
network PParams era
pp CertState era
dpstate UTxO era
utxo TxBody TopTx era
txBody =
  Network
-> PParams era
-> CertState era
-> UTxO era
-> TxBody TopTx era
-> Value era
forall era.
(EraTxBody era, ShelleyEraTxCert era, EraCertState era) =>
Network
-> PParams era
-> CertState era
-> UTxO era
-> TxBody TopTx era
-> Value era
evaluateTransactionBalanceShelley Network
network PParams era
pp CertState era
dpstate UTxO era
utxo TxBody TopTx era
txBody Value era -> Value era -> Value era
forall a. Semigroup a => a -> a -> a
<> (TxBody TopTx era
txBody TxBody TopTx era
-> Getting (Value era) (TxBody TopTx era) (Value era) -> Value era
forall s a. s -> Getting a s a -> a
^. Getting (Value era) (TxBody TopTx era) (Value era)
forall era (l :: TxLevel).
MaryEraTxBody era =>
SimpleGetter (TxBody l era) (Value era)
forall (l :: TxLevel). SimpleGetter (TxBody l era) (Value era)
mintValueTxBodyF)

evaluateTransactionBalanceShelley ::
  (EraTxBody era, ShelleyEraTxCert era, EraCertState era) =>
  Network ->
  PParams era ->
  CertState era ->
  UTxO era ->
  TxBody TopTx era ->
  Value era
evaluateTransactionBalanceShelley :: forall era.
(EraTxBody era, ShelleyEraTxCert era, EraCertState era) =>
Network
-> PParams era
-> CertState era
-> UTxO era
-> TxBody TopTx era
-> Value era
evaluateTransactionBalanceShelley Network
network PParams era
pp CertState era
dpstate UTxO era
utxo TxBody TopTx era
txBody = Value era
consumed Value era -> Value era -> Value era
forall t. Val t => t -> t -> t
<-> Value era
produced
  where
    produced :: Value era
produced =
      UTxO era -> Value era
forall era. EraTxOut era => UTxO era -> Value era
sumUTxO (TxBody TopTx era -> UTxO era
forall era (l :: TxLevel).
EraTxBody era =>
TxBody l era -> UTxO era
txouts TxBody TopTx era
txBody)
        Value era -> Value era -> Value era
forall t. Val t => t -> t -> t
<+> Coin -> Value era
forall t s. Inject t s => t -> s
inject (TxBody TopTx era
txBody TxBody TopTx era -> Getting Coin (TxBody TopTx era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxBody TopTx era) Coin
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx era) Coin
feeTxBodyL Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Network -> PParams era -> CertState era -> TxBody TopTx era -> Coin
forall era (l :: TxLevel).
(EraTxBody era, EraCertState era) =>
Network -> PParams era -> CertState era -> TxBody l era -> Coin
totalTxDeposits Network
network PParams era
pp CertState era
dpstate TxBody TopTx era
txBody)
    consumed :: Value era
consumed =
      UTxO era -> Value era
forall era. EraTxOut era => UTxO era -> Value era
sumUTxO (UTxO era -> Set TxIn -> UTxO era
forall era. UTxO era -> Set TxIn -> UTxO era
txInsFilter UTxO era
utxo (TxBody TopTx era
txBody TxBody TopTx era
-> Getting (Set TxIn) (TxBody TopTx era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody TopTx era) (Set TxIn)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL))
        Value era -> Value era -> Value era
forall a. Semigroup a => a -> a -> a
<> Coin -> Value era
forall t s. Inject t s => t -> s
inject (Coin
refunds Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
withdrawals)
    refunds :: Coin
refunds = PParams era -> CertState era -> TxBody TopTx era -> Coin
forall era (l :: TxLevel).
(EraTxBody era, ShelleyEraTxCert era, EraCertState era) =>
PParams era -> CertState era -> TxBody l era -> Coin
keyTxRefunds PParams era
pp CertState era
dpstate TxBody TopTx era
txBody
    withdrawals :: Coin
withdrawals = Map RewardAccount Coin -> Coin
forall m. Monoid m => Map RewardAccount m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Map RewardAccount Coin -> Coin)
-> (Withdrawals -> Map RewardAccount Coin) -> Withdrawals -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Withdrawals -> Map RewardAccount Coin
unWithdrawals (Withdrawals -> Coin) -> Withdrawals -> Coin
forall a b. (a -> b) -> a -> b
$ TxBody TopTx era
txBody TxBody TopTx era
-> Getting Withdrawals (TxBody TopTx era) Withdrawals
-> Withdrawals
forall s a. s -> Getting a s a -> a
^. Getting Withdrawals (TxBody TopTx era) Withdrawals
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) Withdrawals
forall (l :: TxLevel). Lens' (TxBody l era) Withdrawals
withdrawalsTxBodyL

-- | Randomly lookup pool params and staking credentials to add them as unregistration and
-- undelegation certificates respectively.
genTxBodyFrom ::
  (EraTxBody era, ShelleyEraTxCert era, Arbitrary (TxBody l era), EraCertState era) =>
  CertState era ->
  UTxO era ->
  Gen (TxBody l era)
genTxBodyFrom :: forall era (l :: TxLevel).
(EraTxBody era, ShelleyEraTxCert era, Arbitrary (TxBody l era),
 EraCertState era) =>
CertState era -> UTxO era -> Gen (TxBody l era)
genTxBodyFrom CertState era
certState (UTxO Map TxIn (TxOut era)
u) = do
  txBody <- Gen (TxBody l era)
forall a. Arbitrary a => Gen a
arbitrary
  inputs <- sublistOf (Map.keys u)
  unDelegCreds <- sublistOf (Map.keys (certState ^. certDStateL . accountsL . accountsMapL))
  deRegKeys <- sublistOf (Map.keys (certState ^. certPStateL . psStakePoolsL))
  network <- arbitrary
  let deReg =
        Map (KeyHash StakePool) StakePoolParams -> [StakePoolParams]
forall k a. Map k a -> [a]
Map.elems (Map (KeyHash StakePool) StakePoolParams -> [StakePoolParams])
-> Map (KeyHash StakePool) StakePoolParams -> [StakePoolParams]
forall a b. (a -> b) -> a -> b
$
          (KeyHash StakePool -> StakePoolState -> StakePoolParams)
-> Map (KeyHash StakePool) StakePoolState
-> Map (KeyHash StakePool) StakePoolParams
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (KeyHash StakePool -> Network -> StakePoolState -> StakePoolParams
`stakePoolStateToStakePoolParams` Network
network) (Map (KeyHash StakePool) StakePoolState
 -> Map (KeyHash StakePool) StakePoolParams)
-> Map (KeyHash StakePool) StakePoolState
-> Map (KeyHash StakePool) StakePoolParams
forall a b. (a -> b) -> a -> b
$
            Map (KeyHash StakePool) StakePoolState
-> Set (KeyHash StakePool)
-> Map (KeyHash StakePool) StakePoolState
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys (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) ([KeyHash StakePool] -> Set (KeyHash StakePool)
forall a. Ord a => [a] -> Set a
Set.fromList [KeyHash StakePool]
deRegKeys)
  certs <-
    shuffle $
      toList (txBody ^. certsTxBodyL)
        <> (UnRegTxCert <$> unDelegCreds)
        <> (RegPoolTxCert <$> deReg)
  pure
    ( txBody
        & inputsTxBodyL .~ Set.fromList inputs
        & certsTxBodyL .~ SSeq.fromList certs
    )

propEvalBalanceTxBody ::
  ( EraUTxO era
  , MaryEraTxBody era
  , ShelleyEraTxCert era
  , Arbitrary (TxBody TopTx era)
  , EraCertState era
  ) =>
  PParams era ->
  CertState era ->
  UTxO era ->
  Property
propEvalBalanceTxBody :: forall era.
(EraUTxO era, MaryEraTxBody era, ShelleyEraTxCert era,
 Arbitrary (TxBody TopTx era), EraCertState era) =>
PParams era -> CertState era -> UTxO era -> Property
propEvalBalanceTxBody PParams era
pp CertState era
certState UTxO era
utxo = do
  Property -> Property
forall prop. Testable prop => prop -> Property
property (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    Gen (TxBody TopTx era)
-> (TxBody TopTx era -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (forall era (l :: TxLevel).
(EraTxBody era, ShelleyEraTxCert era, Arbitrary (TxBody l era),
 EraCertState era) =>
CertState era -> UTxO era -> Gen (TxBody l era)
genTxBodyFrom @_ @TopTx CertState era
certState UTxO era
utxo) ((TxBody TopTx era -> Property) -> Property)
-> (TxBody TopTx era -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \TxBody TopTx era
txBody ->
      Gen Network -> (Network -> Expectation) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen Network
forall a. Arbitrary a => Gen a
arbitrary ((Network -> Expectation) -> Property)
-> (Network -> Expectation) -> Property
forall a b. (a -> b) -> a -> b
$ \Network
network ->
        PParams era
-> (Credential Staking -> Maybe Coin)
-> (Credential DRepRole -> Maybe Coin)
-> (KeyHash StakePool -> Bool)
-> UTxO era
-> TxBody TopTx era
-> Value era
forall era (l :: TxLevel).
EraUTxO era =>
PParams era
-> (Credential Staking -> Maybe Coin)
-> (Credential DRepRole -> Maybe Coin)
-> (KeyHash StakePool -> Bool)
-> UTxO era
-> TxBody l era
-> Value era
evalBalanceTxBody PParams era
pp Credential Staking -> Maybe Coin
lookupKeyDeposit (Maybe Coin -> Credential DRepRole -> Maybe Coin
forall a b. a -> b -> a
const Maybe Coin
forall a. Maybe a
Nothing) KeyHash StakePool -> Bool
isRegPoolId UTxO era
utxo TxBody TopTx era
txBody
          Value era -> Value era -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` Network
-> PParams era
-> CertState era
-> UTxO era
-> TxBody TopTx era
-> Value era
forall era.
(MaryEraTxBody era, ShelleyEraTxCert era, EraCertState era) =>
Network
-> PParams era
-> CertState era
-> UTxO era
-> TxBody TopTx era
-> Value era
evaluateTransactionBalance Network
network PParams era
pp CertState era
certState UTxO era
utxo TxBody TopTx era
txBody
  where
    lookupKeyDeposit :: Credential Staking -> Maybe Coin
lookupKeyDeposit = DState era -> Credential Staking -> Maybe Coin
forall era.
EraAccounts era =>
DState era -> Credential Staking -> Maybe Coin
lookupDepositDState (CertState era
certState CertState era
-> Getting (DState era) (CertState era) (DState era) -> DState era
forall s a. s -> Getting a s a -> a
^. Getting (DState era) (CertState era) (DState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL)
    isRegPoolId :: KeyHash StakePool -> Bool
isRegPoolId = (KeyHash StakePool -> Map (KeyHash StakePool) StakePoolState -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` PState era -> Map (KeyHash StakePool) StakePoolState
forall era. PState era -> Map (KeyHash StakePool) StakePoolState
psStakePools (CertState era
certState CertState era
-> Getting (PState era) (CertState era) (PState era) -> PState era
forall s a. s -> Getting a s a -> a
^. Getting (PState era) (CertState era) (PState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL))

propEvalBalanceShelleyTxBody ::
  (EraUTxO era, ShelleyEraTxCert era, Arbitrary (TxBody TopTx era), EraCertState era) =>
  Network ->
  PParams era ->
  CertState era ->
  UTxO era ->
  Property
propEvalBalanceShelleyTxBody :: forall era.
(EraUTxO era, ShelleyEraTxCert era, Arbitrary (TxBody TopTx era),
 EraCertState era) =>
Network -> PParams era -> CertState era -> UTxO era -> Property
propEvalBalanceShelleyTxBody Network
network PParams era
pp CertState era
certState UTxO era
utxo =
  Property -> Property
forall prop. Testable prop => prop -> Property
property (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    Gen (TxBody TopTx era)
-> (TxBody TopTx era -> Expectation) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (forall era (l :: TxLevel).
(EraTxBody era, ShelleyEraTxCert era, Arbitrary (TxBody l era),
 EraCertState era) =>
CertState era -> UTxO era -> Gen (TxBody l era)
genTxBodyFrom @_ @TopTx CertState era
certState UTxO era
utxo) ((TxBody TopTx era -> Expectation) -> Property)
-> (TxBody TopTx era -> Expectation) -> Property
forall a b. (a -> b) -> a -> b
$ \TxBody TopTx era
txBody ->
      PParams era
-> (Credential Staking -> Maybe Coin)
-> (Credential DRepRole -> Maybe Coin)
-> (KeyHash StakePool -> Bool)
-> UTxO era
-> TxBody TopTx era
-> Value era
forall era (l :: TxLevel).
EraUTxO era =>
PParams era
-> (Credential Staking -> Maybe Coin)
-> (Credential DRepRole -> Maybe Coin)
-> (KeyHash StakePool -> Bool)
-> UTxO era
-> TxBody l era
-> Value era
evalBalanceTxBody PParams era
pp Credential Staking -> Maybe Coin
lookupKeyDeposit (Maybe Coin -> Credential DRepRole -> Maybe Coin
forall a b. a -> b -> a
const Maybe Coin
forall a. Maybe a
Nothing) KeyHash StakePool -> Bool
isRegPoolId UTxO era
utxo TxBody TopTx era
txBody
        Value era -> Value era -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` Network
-> PParams era
-> CertState era
-> UTxO era
-> TxBody TopTx era
-> Value era
forall era.
(EraTxBody era, ShelleyEraTxCert era, EraCertState era) =>
Network
-> PParams era
-> CertState era
-> UTxO era
-> TxBody TopTx era
-> Value era
evaluateTransactionBalanceShelley Network
network PParams era
pp CertState era
certState UTxO era
utxo TxBody TopTx era
txBody
  where
    lookupKeyDeposit :: Credential Staking -> Maybe Coin
lookupKeyDeposit = DState era -> Credential Staking -> Maybe Coin
forall era.
EraAccounts era =>
DState era -> Credential Staking -> Maybe Coin
lookupDepositDState (CertState era
certState CertState era
-> Getting (DState era) (CertState era) (DState era) -> DState era
forall s a. s -> Getting a s a -> a
^. Getting (DState era) (CertState era) (DState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL)
    isRegPoolId :: KeyHash StakePool -> Bool
isRegPoolId = (KeyHash StakePool -> Map (KeyHash StakePool) StakePoolState -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` PState era -> Map (KeyHash StakePool) StakePoolState
forall era. PState era -> Map (KeyHash StakePool) StakePoolState
psStakePools (CertState era
certState CertState era
-> Getting (PState era) (CertState era) (PState era) -> PState era
forall s a. s -> Getting a s a -> a
^. Getting (PState era) (CertState era) (PState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL))

-- | NOTE: We cannot have this property pass for Conway and beyond because Conway changes this calculation.
-- This property test only exists to confirm that the old and new implementations for the evalBalanceTxBody` API matched,
-- and this can be ascertained only until Babbage.
spec :: Spec
spec :: Spec
spec =
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"TxBody" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"ShelleyEra" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String
-> (Network
    -> PParams ShelleyEra
    -> CertState ShelleyEra
    -> UTxO ShelleyEra
    -> Property)
-> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"evalBalanceTxBody" ((Network
  -> PParams ShelleyEra
  -> CertState ShelleyEra
  -> UTxO ShelleyEra
  -> Property)
 -> Spec)
-> (Network
    -> PParams ShelleyEra
    -> CertState ShelleyEra
    -> UTxO ShelleyEra
    -> Property)
-> Spec
forall a b. (a -> b) -> a -> b
$ forall era.
(EraUTxO era, ShelleyEraTxCert era, Arbitrary (TxBody TopTx era),
 EraCertState era) =>
Network -> PParams era -> CertState era -> UTxO era -> Property
propEvalBalanceShelleyTxBody @ShelleyEra
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"AllegraEra" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String
-> (Network
    -> PParams AllegraEra
    -> CertState AllegraEra
    -> UTxO AllegraEra
    -> Property)
-> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"evalBalanceTxBody" ((Network
  -> PParams AllegraEra
  -> CertState AllegraEra
  -> UTxO AllegraEra
  -> Property)
 -> Spec)
-> (Network
    -> PParams AllegraEra
    -> CertState AllegraEra
    -> UTxO AllegraEra
    -> Property)
-> Spec
forall a b. (a -> b) -> a -> b
$ forall era.
(EraUTxO era, ShelleyEraTxCert era, Arbitrary (TxBody TopTx era),
 EraCertState era) =>
Network -> PParams era -> CertState era -> UTxO era -> Property
propEvalBalanceShelleyTxBody @AllegraEra
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"MaryEra" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String
-> (PParams MaryEra
    -> CertState MaryEra -> UTxO MaryEra -> Property)
-> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"evalBalanceTxBody" ((PParams MaryEra -> CertState MaryEra -> UTxO MaryEra -> Property)
 -> Spec)
-> (PParams MaryEra
    -> CertState MaryEra -> UTxO MaryEra -> Property)
-> Spec
forall a b. (a -> b) -> a -> b
$ forall era.
(EraUTxO era, MaryEraTxBody era, ShelleyEraTxCert era,
 Arbitrary (TxBody TopTx era), EraCertState era) =>
PParams era -> CertState era -> UTxO era -> Property
propEvalBalanceTxBody @MaryEra
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"AlonzoEra" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String
-> (PParams AlonzoEra
    -> CertState AlonzoEra -> UTxO AlonzoEra -> Property)
-> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"evalBalanceTxBody" ((PParams AlonzoEra
  -> CertState AlonzoEra -> UTxO AlonzoEra -> Property)
 -> Spec)
-> (PParams AlonzoEra
    -> CertState AlonzoEra -> UTxO AlonzoEra -> Property)
-> Spec
forall a b. (a -> b) -> a -> b
$ forall era.
(EraUTxO era, MaryEraTxBody era, ShelleyEraTxCert era,
 Arbitrary (TxBody TopTx era), EraCertState era) =>
PParams era -> CertState era -> UTxO era -> Property
propEvalBalanceTxBody @AlonzoEra
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"BabbageEra" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String
-> (PParams BabbageEra
    -> CertState BabbageEra -> UTxO BabbageEra -> Property)
-> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"evalBalanceTxBody" ((PParams BabbageEra
  -> CertState BabbageEra -> UTxO BabbageEra -> Property)
 -> Spec)
-> (PParams BabbageEra
    -> CertState BabbageEra -> UTxO BabbageEra -> Property)
-> Spec
forall a b. (a -> b) -> a -> b
$ forall era.
(EraUTxO era, MaryEraTxBody era, ShelleyEraTxCert era,
 Arbitrary (TxBody TopTx era), EraCertState era) =>
PParams era -> CertState era -> UTxO era -> Property
propEvalBalanceTxBody @BabbageEra