{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

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

import qualified Cardano.Chain.Common as Byron
import Cardano.Ledger.Api.Era
import Cardano.Ledger.Api.PParams
import Cardano.Ledger.Api.Tx
import Cardano.Ledger.Binary
import Cardano.Ledger.Hashes (extractHash, hashAnnotated, hashKey)
import Cardano.Ledger.Keys (makeBootstrapWitness)
import Cardano.Ledger.Val (Val ((<×>)))
import qualified Data.ByteString as BS
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Lens.Micro
import Numeric.Natural
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Conway.Arbitrary ()
import Test.Cardano.Ledger.Core.KeyPair (ByronKeyPair (..), KeyPair (..), mkWitnessVKey)

txSpec ::
  forall era.
  ( EraTx era
  , Arbitrary (Tx era)
  , Arbitrary (PParams era)
  ) =>
  Spec
txSpec :: forall era.
(EraTx era, Arbitrary (Tx era), Arbitrary (PParams era)) =>
Spec
txSpec = String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe (forall era. Era era => String
eraName @era) (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
"estimateMinFeeTx" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String
-> (PParams era -> Tx era -> [KeyPair Any] -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"no Bootstrap" ((PParams era -> Tx era -> [KeyPair Any] -> Property) -> Spec)
-> (PParams era -> Tx era -> [KeyPair Any] -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \(PParams era
pp :: PParams era) (Tx era
tx :: Tx era) [KeyPair Any]
keyPairsList ->
      let
        txBody :: TxBody era
txBody = Tx era
tx Tx era -> Getting (TxBody era) (Tx era) (TxBody era) -> TxBody era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody era) (Tx era) (TxBody era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL
        txBodyHash :: SafeHash EraIndependentTxBody
txBodyHash = TxBody era -> SafeHash EraIndependentTxBody
forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody era
txBody

        keyPairs :: Map (KeyHash Any) (KeyPair Any)
keyPairs = [(KeyHash Any, KeyPair Any)] -> Map (KeyHash Any) (KeyPair Any)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(VKey Any -> KeyHash Any
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey Any -> KeyHash Any) -> VKey Any -> KeyHash Any
forall a b. (a -> b) -> a -> b
$ KeyPair Any -> VKey Any
forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey KeyPair Any
kp, KeyPair Any
kp) | KeyPair Any
kp <- [KeyPair Any]
keyPairsList]
        wits :: Set (WitVKey 'Witness)
wits = [WitVKey 'Witness] -> Set (WitVKey 'Witness)
forall a. Ord a => [a] -> Set a
Set.fromList ([WitVKey 'Witness] -> Set (WitVKey 'Witness))
-> [WitVKey 'Witness] -> Set (WitVKey 'Witness)
forall a b. (a -> b) -> a -> b
$ (KeyPair Any -> WitVKey 'Witness)
-> [KeyPair Any] -> [WitVKey 'Witness]
forall a b. (a -> b) -> [a] -> [b]
map (SafeHash EraIndependentTxBody -> KeyPair Any -> WitVKey 'Witness
forall (kr :: KeyRole).
SafeHash EraIndependentTxBody -> KeyPair kr -> WitVKey 'Witness
mkWitnessVKey SafeHash EraIndependentTxBody
txBodyHash) ([KeyPair Any] -> [WitVKey 'Witness])
-> [KeyPair Any] -> [WitVKey 'Witness]
forall a b. (a -> b) -> a -> b
$ Map (KeyHash Any) (KeyPair Any) -> [KeyPair Any]
forall k a. Map k a -> [a]
Map.elems Map (KeyHash Any) (KeyPair Any)
keyPairs

        txSigned :: Tx era
txSigned = Tx era
tx Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& ((TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx era -> Identity (Tx era))
-> ((Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
    -> TxWits era -> Identity (TxWits era))
-> (Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
-> TxWits era -> Identity (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness))
Lens' (TxWits era) (Set (WitVKey 'Witness))
addrTxWitsL ((Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
 -> Tx era -> Identity (Tx era))
-> Set (WitVKey 'Witness) -> Tx era -> Tx era
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Set (WitVKey 'Witness)
wits)
       in
        PParams era -> Tx era -> Int -> Int -> Int -> Coin
forall era.
EraTx era =>
PParams era -> Tx era -> Int -> Int -> Int -> Coin
estimateMinFeeTx PParams era
pp Tx era
tx (Map (KeyHash Any) (KeyPair Any) -> Int
forall k a. Map k a -> Int
Map.size Map (KeyHash Any) (KeyPair Any)
keyPairs) Int
0 Int
0
          Coin -> Coin -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== (PParams era -> Tx era -> Int -> Tx era
forall era. EraTx era => PParams era -> Tx era -> Int -> Tx era
setMinFeeTx PParams era
pp Tx era
txSigned Int
0 Tx era -> Getting Coin (Tx era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (TxBody era -> Const Coin (TxBody era))
-> Tx era -> Const Coin (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Const Coin (TxBody era))
 -> Tx era -> Const Coin (Tx era))
-> ((Coin -> Const Coin Coin)
    -> TxBody era -> Const Coin (TxBody era))
-> Getting Coin (Tx era) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin) -> TxBody era -> Const Coin (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
feeTxBodyL)
    String
-> (PParams era
    -> Tx era
    -> [KeyPair Any]
    -> [(ByronKeyPair, AddrAttributes)]
    -> Property)
-> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"with Bootstrap" ((PParams era
  -> Tx era
  -> [KeyPair Any]
  -> [(ByronKeyPair, AddrAttributes)]
  -> Property)
 -> Spec)
-> (PParams era
    -> Tx era
    -> [KeyPair Any]
    -> [(ByronKeyPair, AddrAttributes)]
    -> Property)
-> Spec
forall a b. (a -> b) -> a -> b
$ \(PParams era
pp :: PParams era) (Tx era
tx :: Tx era) [KeyPair Any]
keyPairsList [(ByronKeyPair, AddrAttributes)]
byronKeyPairsList ->
      let
        txBody :: TxBody era
txBody = Tx era
tx Tx era -> Getting (TxBody era) (Tx era) (TxBody era) -> TxBody era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody era) (Tx era) (TxBody era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL
        txBodyHash :: SafeHash EraIndependentTxBody
txBodyHash = TxBody era -> SafeHash EraIndependentTxBody
forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody era
txBody

        keyPairs :: Map (KeyHash Any) (KeyPair Any)
keyPairs = [(KeyHash Any, KeyPair Any)] -> Map (KeyHash Any) (KeyPair Any)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(VKey Any -> KeyHash Any
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey Any -> KeyHash Any) -> VKey Any -> KeyHash Any
forall a b. (a -> b) -> a -> b
$ KeyPair Any -> VKey Any
forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey KeyPair Any
kp, KeyPair Any
kp) | KeyPair Any
kp <- [KeyPair Any]
keyPairsList]
        wits :: Set (WitVKey 'Witness)
wits = [WitVKey 'Witness] -> Set (WitVKey 'Witness)
forall a. Ord a => [a] -> Set a
Set.fromList ([WitVKey 'Witness] -> Set (WitVKey 'Witness))
-> [WitVKey 'Witness] -> Set (WitVKey 'Witness)
forall a b. (a -> b) -> a -> b
$ (KeyPair Any -> WitVKey 'Witness)
-> [KeyPair Any] -> [WitVKey 'Witness]
forall a b. (a -> b) -> [a] -> [b]
map (SafeHash EraIndependentTxBody -> KeyPair Any -> WitVKey 'Witness
forall (kr :: KeyRole).
SafeHash EraIndependentTxBody -> KeyPair kr -> WitVKey 'Witness
mkWitnessVKey SafeHash EraIndependentTxBody
txBodyHash) ([KeyPair Any] -> [WitVKey 'Witness])
-> [KeyPair Any] -> [WitVKey 'Witness]
forall a b. (a -> b) -> a -> b
$ Map (KeyHash Any) (KeyPair Any) -> [KeyPair Any]
forall k a. Map k a -> [a]
Map.elems Map (KeyHash Any) (KeyPair Any)
keyPairs

        byronKeyPairs :: Map VerificationKey (SigningKey, Attributes AddrAttributes)
byronKeyPairs =
          [(VerificationKey, (SigningKey, Attributes AddrAttributes))]
-> Map VerificationKey (SigningKey, Attributes AddrAttributes)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
            [ ( ByronKeyPair -> VerificationKey
bkpVerificationKey ByronKeyPair
kp
              , (ByronKeyPair -> SigningKey
bkpSigningKey ByronKeyPair
kp, AddrAttributes -> Attributes AddrAttributes
forall h. h -> Attributes h
Byron.mkAttributes (AddrAttributes -> Attributes AddrAttributes)
-> AddrAttributes -> Attributes AddrAttributes
forall a b. (a -> b) -> a -> b
$ AddrAttributes
attrs {Byron.aaVKDerivationPath = Nothing})
              )
            | (ByronKeyPair
kp, AddrAttributes
attrs) <-
                [(ByronKeyPair, AddrAttributes)]
byronKeyPairsList
            ]
        byronWits :: Set BootstrapWitness
byronWits =
          [BootstrapWitness] -> Set BootstrapWitness
forall a. Ord a => [a] -> Set a
Set.fromList ([BootstrapWitness] -> Set BootstrapWitness)
-> [BootstrapWitness] -> Set BootstrapWitness
forall a b. (a -> b) -> a -> b
$
            ((SigningKey, Attributes AddrAttributes) -> BootstrapWitness)
-> [(SigningKey, Attributes AddrAttributes)] -> [BootstrapWitness]
forall a b. (a -> b) -> [a] -> [b]
map ((SigningKey -> Attributes AddrAttributes -> BootstrapWitness)
-> (SigningKey, Attributes AddrAttributes) -> BootstrapWitness
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Hash HASH EraIndependentTxBody
-> SigningKey -> Attributes AddrAttributes -> BootstrapWitness
makeBootstrapWitness (SafeHash EraIndependentTxBody -> Hash HASH EraIndependentTxBody
forall i. SafeHash i -> Hash HASH i
extractHash SafeHash EraIndependentTxBody
txBodyHash))) (Map VerificationKey (SigningKey, Attributes AddrAttributes)
-> [(SigningKey, Attributes AddrAttributes)]
forall k a. Map k a -> [a]
Map.elems Map VerificationKey (SigningKey, Attributes AddrAttributes)
byronKeyPairs)

        txSigned :: Tx era
txSigned =
          Tx era
tx
            Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& ((TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx era -> Identity (Tx era))
-> ((Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
    -> TxWits era -> Identity (TxWits era))
-> (Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
-> TxWits era -> Identity (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness))
Lens' (TxWits era) (Set (WitVKey 'Witness))
addrTxWitsL ((Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
 -> Tx era -> Identity (Tx era))
-> Set (WitVKey 'Witness) -> Tx era -> Tx era
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Set (WitVKey 'Witness)
wits)
            Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& ((TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx era -> Identity (Tx era))
-> ((Set BootstrapWitness -> Identity (Set BootstrapWitness))
    -> TxWits era -> Identity (TxWits era))
-> (Set BootstrapWitness -> Identity (Set BootstrapWitness))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set BootstrapWitness -> Identity (Set BootstrapWitness))
-> TxWits era -> Identity (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Set BootstrapWitness)
Lens' (TxWits era) (Set BootstrapWitness)
bootAddrTxWitsL ((Set BootstrapWitness -> Identity (Set BootstrapWitness))
 -> Tx era -> Identity (Tx era))
-> Set BootstrapWitness -> Tx era -> Tx era
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Set BootstrapWitness
byronWits)

        -- Conversion to Natural is necessary to guard against negative numbers thus
        -- checking overestimation:
        serializeByronAttrs :: Byron.Attributes Byron.AddrAttributes -> Natural
        serializeByronAttrs :: Attributes AddrAttributes -> Natural
serializeByronAttrs = Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Natural)
-> (Attributes AddrAttributes -> Int)
-> Attributes AddrAttributes
-> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int
BS.length (ByteString -> Int)
-> (Attributes AddrAttributes -> ByteString)
-> Attributes AddrAttributes
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> Attributes AddrAttributes -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize' Version
byronProtVer
        assumedAttrs :: AddrAttributes
assumedAttrs =
          Byron.AddrAttributes
            { aaVKDerivationPath :: Maybe HDAddressPayload
Byron.aaVKDerivationPath = Maybe HDAddressPayload
forall a. Maybe a
Nothing
            , aaNetworkMagic :: NetworkMagic
Byron.aaNetworkMagic = Word32 -> NetworkMagic
Byron.NetworkTestnet Word32
forall a. Bounded a => a
maxBound
            }
        -- This is the minimum amount by which over estimation can happen.
        overestimations :: [Natural]
overestimations =
          [ Attributes AddrAttributes -> Natural
serializeByronAttrs (AddrAttributes -> Attributes AddrAttributes
forall h. h -> Attributes h
Byron.mkAttributes AddrAttributes
assumedAttrs) Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Attributes AddrAttributes -> Natural
serializeByronAttrs Attributes AddrAttributes
attrs
          | (SigningKey
_, Attributes AddrAttributes
attrs) <- Map VerificationKey (SigningKey, Attributes AddrAttributes)
-> [(SigningKey, Attributes AddrAttributes)]
forall k a. Map k a -> [a]
Map.elems Map VerificationKey (SigningKey, Attributes AddrAttributes)
byronKeyPairs
          ]
       in
        -- Overestimating transaction size can lead to the overestimated fee affecting the
        -- size of the transaction, which in turn affects the overestimation. For this
        -- reason we can only check `>=`
        let
          overestimatedMinFeeA :: Coin
overestimatedMinFeeA = Natural -> Integer
forall a. Integral a => a -> Integer
toInteger ([Natural] -> Natural
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Natural]
overestimations) Integer -> 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
ppMinFeeAL
          estimation :: Coin
estimation = PParams era -> Tx era -> Int -> Int -> Int -> Coin
forall era.
EraTx era =>
PParams era -> Tx era -> Int -> Int -> Int -> Coin
estimateMinFeeTx PParams era
pp Tx era
tx (Map (KeyHash Any) (KeyPair Any) -> Int
forall k a. Map k a -> Int
Map.size Map (KeyHash Any) (KeyPair Any)
keyPairs) (Map VerificationKey (SigningKey, Attributes AddrAttributes) -> Int
forall k a. Map k a -> Int
Map.size Map VerificationKey (SigningKey, Attributes AddrAttributes)
byronKeyPairs) Int
0
          actual :: Coin
actual = PParams era -> Tx era -> Int -> Tx era
forall era. EraTx era => PParams era -> Tx era -> Int -> Tx era
setMinFeeTx PParams era
pp Tx era
txSigned Int
0 Tx era -> Getting Coin (Tx era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (TxBody era -> Const Coin (TxBody era))
-> Tx era -> Const Coin (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Const Coin (TxBody era))
 -> Tx era -> Const Coin (Tx era))
-> ((Coin -> Const Coin Coin)
    -> TxBody era -> Const Coin (TxBody era))
-> Getting Coin (Tx era) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin) -> TxBody era -> Const Coin (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
feeTxBodyL
         in
          String -> [String] -> Bool -> Property
forall prop.
Testable prop =>
String -> [String] -> prop -> Property
tabulate String
"Attrs overestimation in bytes" ((Natural -> String) -> [Natural] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Natural -> String
forall a. Show a => a -> String
show [Natural]
overestimations) (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
            Coin
estimation Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
>= Coin
actual Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
overestimatedMinFeeA

spec :: Spec
spec :: Spec
spec = do
  forall era.
(EraTx era, Arbitrary (Tx era), Arbitrary (PParams era)) =>
Spec
txSpec @ShelleyEra
  forall era.
(EraTx era, Arbitrary (Tx era), Arbitrary (PParams era)) =>
Spec
txSpec @AllegraEra
  forall era.
(EraTx era, Arbitrary (Tx era), Arbitrary (PParams era)) =>
Spec
txSpec @MaryEra
  forall era.
(EraTx era, Arbitrary (Tx era), Arbitrary (PParams era)) =>
Spec
txSpec @AlonzoEra
  forall era.
(EraTx era, Arbitrary (Tx era), Arbitrary (PParams era)) =>
Spec
txSpec @BabbageEra
  forall era.
(EraTx era, Arbitrary (Tx era), Arbitrary (PParams era)) =>
Spec
txSpec @ConwayEra