{-# 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 = forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe (forall era. Era era => String
eraName @era) forall a b. (a -> b) -> a -> b
$ do
  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"estimateMinFeeTx" forall a b. (a -> b) -> a -> b
$ do
    forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"no Bootstrap" 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 forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
        txBodyHash :: SafeHash EraIndependentTxBody
txBodyHash = forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody era
txBody

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

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

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

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

        txSigned :: Tx era
txSigned =
          Tx era
tx
            forall a b. a -> (a -> b) -> b
& (forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness))
addrTxWitsL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Set (WitVKey 'Witness)
wits)
            forall a b. a -> (a -> b) -> b
& (forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Set BootstrapWitness)
bootAddrTxWitsL 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int
BS.length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. EncCBOR a => Version -> a -> ByteString
serialize' Version
byronProtVer
        assumedAttrs :: AddrAttributes
assumedAttrs =
          Byron.AddrAttributes
            { aaVKDerivationPath :: Maybe HDAddressPayload
Byron.aaVKDerivationPath = forall a. Maybe a
Nothing
            , aaNetworkMagic :: NetworkMagic
Byron.aaNetworkMagic = Word32 -> NetworkMagic
Byron.NetworkTestnet forall a. Bounded a => a
maxBound
            }
        -- This is the minimum amount by which over estimation can happen.
        overestimations :: [Natural]
overestimations =
          [ Attributes AddrAttributes -> Natural
serializeByronAttrs (forall h. h -> Attributes h
Byron.mkAttributes AddrAttributes
assumedAttrs) forall a. Num a => a -> a -> a
- Attributes AddrAttributes -> Natural
serializeByronAttrs Attributes AddrAttributes
attrs
          | (SigningKey
_, Attributes AddrAttributes
attrs) <- 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 = forall a. Integral a => a -> Integer
toInteger (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Natural]
overestimations) 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
ppMinFeeAL
          estimation :: Coin
estimation = forall era.
EraTx era =>
PParams era -> Tx era -> Int -> Int -> Int -> Coin
estimateMinFeeTx PParams era
pp Tx era
tx (forall k a. Map k a -> Int
Map.size Map (KeyHash Any) (KeyPair Any)
keyPairs) (forall k a. Map k a -> Int
Map.size Map VerificationKey (SigningKey, Attributes AddrAttributes)
byronKeyPairs) Int
0
          actual :: Coin
actual = forall era. EraTx era => PParams era -> Tx era -> Int -> Tx era
setMinFeeTx PParams era
pp Tx era
txSigned Int
0 forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTxBody era => Lens' (TxBody era) Coin
feeTxBodyL
         in
          forall prop.
Testable prop =>
String -> [String] -> prop -> Property
tabulate String
"Attrs overestimation in bytes" (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Natural]
overestimations) forall a b. (a -> b) -> a -> b
$
            Coin
estimation forall a. Ord a => a -> a -> Bool
>= Coin
actual 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