{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# 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.CertState
import Cardano.Ledger.Coin
import Cardano.Ledger.Compactible
import Cardano.Ledger.PoolParams
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.UTxO hiding (consumed, produced)
import qualified Cardano.Ledger.UMap as UM
import Cardano.Ledger.Val
import Data.Foldable
import qualified Data.Map.Strict as Map
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Lens.Micro
import Test.Cardano.Ledger.Babbage.Arbitrary ()
import Test.Cardano.Ledger.Common

totalTxDeposits ::
  EraTxBody era =>
  PParams era ->
  CertState era ->
  TxBody era ->
  Coin
totalTxDeposits :: forall era.
EraTxBody era =>
PParams era -> CertState era -> TxBody era -> Coin
totalTxDeposits PParams era
pp CertState era
dpstate TxBody era
txb =
  Int
numKeys forall t i. (Val t, Integral i) => i -> t -> t
<×> PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL forall t. Val t => t -> t -> t
<+> forall a b. (a, b) -> b
snd (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {era}.
EraTxCert era =>
(Map (KeyHash 'StakePool) PoolParams, Coin)
-> TxCert era -> (Map (KeyHash 'StakePool) PoolParams, Coin)
accum (Map (KeyHash 'StakePool) PoolParams
regpools, Integer -> Coin
Coin Integer
0) [TxCert era]
certs)
  where
    certs :: [TxCert era]
certs = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (TxBody era
txb forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL)
    numKeys :: Int
numKeys = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter forall era. EraTxCert era => TxCert era -> Bool
isRegStakeTxCert [TxCert era]
certs
    regpools :: Map (KeyHash 'StakePool) PoolParams
regpools = forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psStakePoolParams (forall era. CertState era -> PState era
certPState CertState era
dpstate)
    accum :: (Map (KeyHash 'StakePool) PoolParams, Coin)
-> TxCert era -> (Map (KeyHash 'StakePool) PoolParams, Coin)
accum (!Map (KeyHash 'StakePool) PoolParams
pools, !Coin
ans) (RegPoolTxCert PoolParams
poolparam) =
      -- We don't pay a deposit on a pool that is already registered
      if forall k a. Ord k => k -> Map k a -> Bool
Map.member (PoolParams -> KeyHash 'StakePool
ppId PoolParams
poolparam) Map (KeyHash 'StakePool) PoolParams
pools
        then (Map (KeyHash 'StakePool) PoolParams
pools, Coin
ans)
        else (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (PoolParams -> KeyHash 'StakePool
ppId PoolParams
poolparam) PoolParams
poolparam Map (KeyHash 'StakePool) PoolParams
pools, Coin
ans forall t. Val t => t -> t -> t
<+> PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppPoolDepositL)
    accum (Map (KeyHash 'StakePool) PoolParams, Coin)
ans TxCert era
_ = (Map (KeyHash 'StakePool) PoolParams, Coin)
ans

keyTxRefunds ::
  (EraTxBody era, ShelleyEraTxCert era) =>
  PParams era ->
  CertState era ->
  TxBody era ->
  Coin
keyTxRefunds :: forall era.
(EraTxBody era, ShelleyEraTxCert era) =>
PParams era -> CertState era -> TxBody era -> Coin
keyTxRefunds PParams era
pp CertState era
dpstate TxBody era
tx = forall a b. (a, b) -> b
snd (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {era}.
ShelleyEraTxCert era =>
(UView StakeCredential RDPair, Coin)
-> TxCert era -> (UView StakeCredential RDPair, Coin)
accum (UView StakeCredential RDPair
initialKeys, Integer -> Coin
Coin Integer
0) StrictSeq (TxCert era)
certs)
  where
    certs :: StrictSeq (TxCert era)
certs = TxBody era
tx forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
    initialKeys :: UView StakeCredential RDPair
initialKeys = UMap -> UView StakeCredential RDPair
UM.RewDepUView forall a b. (a -> b) -> a -> b
$ forall era. DState era -> UMap
dsUnified forall a b. (a -> b) -> a -> b
$ forall era. CertState era -> DState era
certDState CertState era
dpstate
    keyDeposit :: CompactForm Coin
keyDeposit = HasCallStack => Coin -> CompactForm Coin
UM.compactCoinOrError (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL)
    accum :: (UView StakeCredential RDPair, Coin)
-> TxCert era -> (UView StakeCredential RDPair, Coin)
accum (!UView StakeCredential RDPair
keys, !Coin
ans) (RegTxCert StakeCredential
k) =
      -- Deposit is added locally to the growing 'keys'
      (UMap -> UView StakeCredential RDPair
UM.RewDepUView forall a b. (a -> b) -> a -> b
$ forall k v. k -> v -> UView k v -> UMap
UM.insert StakeCredential
k (CompactForm Coin -> CompactForm Coin -> RDPair
UM.RDPair forall a. Monoid a => a
mempty CompactForm Coin
keyDeposit) UView StakeCredential RDPair
keys, Coin
ans)
    accum (!UView StakeCredential RDPair
keys, !Coin
ans) (UnRegTxCert StakeCredential
k) =
      -- If the key is registered, lookup the deposit in the locally growing 'keys'
      -- if it is not registered, then just return ans
      case forall k v. k -> UView k v -> Maybe v
UM.lookup StakeCredential
k UView StakeCredential RDPair
keys of
        Just (UM.RDPair CompactForm Coin
_ CompactForm Coin
deposit) -> (UView StakeCredential RDPair
keys, Coin
ans forall t. Val t => t -> t -> t
<+> forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm Coin
deposit)
        Maybe RDPair
Nothing -> (UView StakeCredential RDPair
keys, Coin
ans)
    accum (UView StakeCredential RDPair, Coin)
ans TxCert era
_ = (UView StakeCredential RDPair, Coin)
ans

-- | 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) =>
  PParams era ->
  CertState era ->
  UTxO era ->
  TxBody era ->
  Value era
evaluateTransactionBalance :: forall era.
(MaryEraTxBody era, ShelleyEraTxCert era) =>
PParams era -> CertState era -> UTxO era -> TxBody era -> Value era
evaluateTransactionBalance PParams era
pp CertState era
dpstate UTxO era
utxo TxBody era
txBody =
  forall era.
(EraTxBody era, ShelleyEraTxCert era) =>
PParams era -> CertState era -> UTxO era -> TxBody era -> Value era
evaluateTransactionBalanceShelley PParams era
pp CertState era
dpstate UTxO era
utxo TxBody era
txBody forall a. Semigroup a => a -> a -> a
<> (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
MaryEraTxBody era =>
SimpleGetter (TxBody era) (Value era)
mintValueTxBodyF)

evaluateTransactionBalanceShelley ::
  (EraTxBody era, ShelleyEraTxCert era) =>
  PParams era ->
  CertState era ->
  UTxO era ->
  TxBody era ->
  Value era
evaluateTransactionBalanceShelley :: forall era.
(EraTxBody era, ShelleyEraTxCert era) =>
PParams era -> CertState era -> UTxO era -> TxBody era -> Value era
evaluateTransactionBalanceShelley PParams era
pp CertState era
dpstate UTxO era
utxo TxBody era
txBody = Value era
consumed forall t. Val t => t -> t -> t
<-> Value era
produced
  where
    produced :: Value era
produced =
      forall era. EraTxOut era => UTxO era -> Value era
balance (forall era. EraTxBody era => TxBody era -> UTxO era
txouts TxBody era
txBody)
        forall t. Val t => t -> t -> t
<+> forall t s. Inject t s => t -> s
inject (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. EraTxBody era => Lens' (TxBody era) Coin
feeTxBodyL forall t. Val t => t -> t -> t
<+> forall era.
EraTxBody era =>
PParams era -> CertState era -> TxBody era -> Coin
totalTxDeposits PParams era
pp CertState era
dpstate TxBody era
txBody)
    consumed :: Value era
consumed =
      forall era. EraTxOut era => UTxO era -> Value era
balance (forall era. UTxO era -> Set TxIn -> UTxO era
txInsFilter UTxO era
utxo (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL))
        forall a. Semigroup a => a -> a -> a
<> forall t s. Inject t s => t -> s
inject (Coin
refunds forall a. Semigroup a => a -> a -> a
<> Coin
withdrawals)
    refunds :: Coin
refunds = forall era.
(EraTxBody era, ShelleyEraTxCert era) =>
PParams era -> CertState era -> TxBody era -> Coin
keyTxRefunds PParams era
pp CertState era
dpstate TxBody era
txBody
    withdrawals :: Coin
withdrawals = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall b c a. (b -> c) -> (a -> b) -> a -> c
. Withdrawals -> Map RewardAccount Coin
unWithdrawals forall a b. (a -> b) -> a -> b
$ TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. EraTxBody era => Lens' (TxBody 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 era)) =>
  CertState era ->
  UTxO era ->
  Gen (TxBody era)
genTxBodyFrom :: forall era.
(EraTxBody era, ShelleyEraTxCert era, Arbitrary (TxBody era)) =>
CertState era -> UTxO era -> Gen (TxBody era)
genTxBodyFrom CertState {DState era
certDState :: DState era
certDState :: forall era. CertState era -> DState era
certDState, PState era
certPState :: PState era
certPState :: forall era. CertState era -> PState era
certPState} (UTxO Map TxIn (TxOut era)
u) = do
  TxBody era
txBody <- forall a. Arbitrary a => Gen a
arbitrary
  [TxIn]
inputs <- forall a. [a] -> Gen [a]
sublistOf (forall k a. Map k a -> [k]
Map.keys Map TxIn (TxOut era)
u)
  [StakeCredential]
unDelegCreds <- forall a. [a] -> Gen [a]
sublistOf (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (forall k v. UView k v -> Set k
UM.domain (UMap -> UView StakeCredential RDPair
UM.RewDepUView forall a b. (a -> b) -> a -> b
$ forall era. DState era -> UMap
dsUnified DState era
certDState)))
  [PoolParams]
deRegKeys <- forall a. [a] -> Gen [a]
sublistOf (forall k a. Map k a -> [a]
Map.elems (forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psStakePoolParams PState era
certPState))
  [TxCert era]
certs <-
    forall a. [a] -> Gen [a]
shuffle forall a b. (a -> b) -> a -> b
$
      forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL)
        forall a. Semigroup a => a -> a -> a
<> (forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
UnRegTxCert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [StakeCredential]
unDelegCreds)
        forall a. Semigroup a => a -> a -> a
<> (forall era. EraTxCert era => PoolParams -> TxCert era
RegPoolTxCert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PoolParams]
deRegKeys)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( TxBody era
txBody
        forall a b. a -> (a -> b) -> b
& forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Ord a => [a] -> Set a
Set.fromList [TxIn]
inputs
        forall a b. a -> (a -> b) -> b
& forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. [a] -> StrictSeq a
SSeq.fromList [TxCert era]
certs
    )

propEvalBalanceTxBody ::
  (EraUTxO era, MaryEraTxBody era, ShelleyEraTxCert era, Arbitrary (TxBody era)) =>
  PParams era ->
  CertState era ->
  UTxO era ->
  Property
propEvalBalanceTxBody :: forall era.
(EraUTxO era, MaryEraTxBody era, ShelleyEraTxCert era,
 Arbitrary (TxBody era)) =>
PParams era -> CertState era -> UTxO era -> Property
propEvalBalanceTxBody PParams era
pp CertState era
certState UTxO era
utxo =
  forall prop. Testable prop => prop -> Property
property forall a b. (a -> b) -> a -> b
$
    forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (forall era.
(EraTxBody era, ShelleyEraTxCert era, Arbitrary (TxBody era)) =>
CertState era -> UTxO era -> Gen (TxBody era)
genTxBodyFrom CertState era
certState UTxO era
utxo) forall a b. (a -> b) -> a -> b
$ \TxBody era
txBody ->
      forall era.
EraUTxO era =>
PParams era
-> (StakeCredential -> Maybe Coin)
-> (Credential 'DRepRole -> Maybe Coin)
-> (KeyHash 'StakePool -> Bool)
-> UTxO era
-> TxBody era
-> Value era
evalBalanceTxBody PParams era
pp StakeCredential -> Maybe Coin
lookupKeyDeposit Credential 'DRepRole -> Maybe Coin
lookupDRepDeposit KeyHash 'StakePool -> Bool
isRegPoolId UTxO era
utxo TxBody era
txBody
        forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` forall era.
(MaryEraTxBody era, ShelleyEraTxCert era) =>
PParams era -> CertState era -> UTxO era -> TxBody era -> Value era
evaluateTransactionBalance PParams era
pp CertState era
certState UTxO era
utxo TxBody era
txBody
  where
    lookupKeyDeposit :: StakeCredential -> Maybe Coin
lookupKeyDeposit = forall era. DState era -> StakeCredential -> Maybe Coin
lookupDepositDState (forall era. CertState era -> DState era
certDState CertState era
certState)
    lookupDRepDeposit :: Credential 'DRepRole -> Maybe Coin
lookupDRepDeposit = forall era. VState era -> Credential 'DRepRole -> Maybe Coin
lookupDepositVState (forall era. CertState era -> VState era
certVState CertState era
certState)
    isRegPoolId :: KeyHash 'StakePool -> Bool
isRegPoolId = (forall k a. Ord k => k -> Map k a -> Bool
`Map.member` forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psStakePoolParams (forall era. CertState era -> PState era
certPState CertState era
certState))

propEvalBalanceShelleyTxBody ::
  (EraUTxO era, ShelleyEraTxCert era, Arbitrary (TxBody era)) =>
  PParams era ->
  CertState era ->
  UTxO era ->
  Property
propEvalBalanceShelleyTxBody :: forall era.
(EraUTxO era, ShelleyEraTxCert era, Arbitrary (TxBody era)) =>
PParams era -> CertState era -> UTxO era -> Property
propEvalBalanceShelleyTxBody PParams era
pp CertState era
certState UTxO era
utxo =
  forall prop. Testable prop => prop -> Property
property forall a b. (a -> b) -> a -> b
$
    forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (forall era.
(EraTxBody era, ShelleyEraTxCert era, Arbitrary (TxBody era)) =>
CertState era -> UTxO era -> Gen (TxBody era)
genTxBodyFrom CertState era
certState UTxO era
utxo) forall a b. (a -> b) -> a -> b
$ \TxBody era
txBody ->
      forall era.
EraUTxO era =>
PParams era
-> (StakeCredential -> Maybe Coin)
-> (Credential 'DRepRole -> Maybe Coin)
-> (KeyHash 'StakePool -> Bool)
-> UTxO era
-> TxBody era
-> Value era
evalBalanceTxBody PParams era
pp StakeCredential -> Maybe Coin
lookupKeyDeposit Credential 'DRepRole -> Maybe Coin
lookupDRepDeposit KeyHash 'StakePool -> Bool
isRegPoolId UTxO era
utxo TxBody era
txBody
        forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` forall era.
(EraTxBody era, ShelleyEraTxCert era) =>
PParams era -> CertState era -> UTxO era -> TxBody era -> Value era
evaluateTransactionBalanceShelley PParams era
pp CertState era
certState UTxO era
utxo TxBody era
txBody
  where
    lookupKeyDeposit :: StakeCredential -> Maybe Coin
lookupKeyDeposit = forall era. DState era -> StakeCredential -> Maybe Coin
lookupDepositDState (forall era. CertState era -> DState era
certDState CertState era
certState)
    lookupDRepDeposit :: Credential 'DRepRole -> Maybe Coin
lookupDRepDeposit = forall era. VState era -> Credential 'DRepRole -> Maybe Coin
lookupDepositVState (forall era. CertState era -> VState era
certVState CertState era
certState)
    isRegPoolId :: KeyHash 'StakePool -> Bool
isRegPoolId = (forall k a. Ord k => k -> Map k a -> Bool
`Map.member` forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psStakePoolParams (forall era. CertState era -> PState era
certPState CertState era
certState))

-- | 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 =
  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"TxBody" forall a b. (a -> b) -> a -> b
$ do
    forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"ShelleyEra" forall a b. (a -> b) -> a -> b
$ do
      forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"evalBalanceTxBody" forall a b. (a -> b) -> a -> b
$ forall era.
(EraUTxO era, ShelleyEraTxCert era, Arbitrary (TxBody era)) =>
PParams era -> CertState era -> UTxO era -> Property
propEvalBalanceShelleyTxBody @ShelleyEra
    forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"AllegraEra" forall a b. (a -> b) -> a -> b
$ do
      forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"evalBalanceTxBody" forall a b. (a -> b) -> a -> b
$ forall era.
(EraUTxO era, ShelleyEraTxCert era, Arbitrary (TxBody era)) =>
PParams era -> CertState era -> UTxO era -> Property
propEvalBalanceShelleyTxBody @AllegraEra
    forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"MaryEra" forall a b. (a -> b) -> a -> b
$ do
      forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"evalBalanceTxBody" forall a b. (a -> b) -> a -> b
$ forall era.
(EraUTxO era, MaryEraTxBody era, ShelleyEraTxCert era,
 Arbitrary (TxBody era)) =>
PParams era -> CertState era -> UTxO era -> Property
propEvalBalanceTxBody @MaryEra
    forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"AlonzoEra" forall a b. (a -> b) -> a -> b
$ do
      forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"evalBalanceTxBody" forall a b. (a -> b) -> a -> b
$ forall era.
(EraUTxO era, MaryEraTxBody era, ShelleyEraTxCert era,
 Arbitrary (TxBody era)) =>
PParams era -> CertState era -> UTxO era -> Property
propEvalBalanceTxBody @AlonzoEra
    forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"BabbageEra" forall a b. (a -> b) -> a -> b
$ do
      forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"evalBalanceTxBody" forall a b. (a -> b) -> a -> b
$ forall era.
(EraUTxO era, MaryEraTxBody era, ShelleyEraTxCert era,
 Arbitrary (TxBody era)) =>
PParams era -> CertState era -> UTxO era -> Property
propEvalBalanceTxBody @BabbageEra