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

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

import qualified Cardano.Chain.Common as Byron
import Cardano.Crypto.DSIGN.Ed25519 (Ed25519DSIGN)
import qualified Cardano.Crypto.Hash as Hash
import Cardano.Ledger.Api.Era
import Cardano.Ledger.Api.PParams
import Cardano.Ledger.Api.Tx
import Cardano.Ledger.Binary
import Cardano.Ledger.Core (EraIndependentTxBody)
import Cardano.Ledger.Keys (DSignable, hashKey, makeBootstrapWitness)
import Cardano.Ledger.SafeHash (extractHash, hashAnnotated)
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)
  , DSIGN (EraCrypto era) ~ Ed25519DSIGN
  , DSignable (EraCrypto era) (Hash.Hash (HASH (EraCrypto era)) EraIndependentTxBody)
  ) =>
  Spec
txSpec :: forall era.
(EraTx era, Arbitrary (Tx era), Arbitrary (PParams era),
 DSIGN (EraCrypto era) ~ Ed25519DSIGN,
 DSignable
   (EraCrypto era)
   (Hash (HASH (EraCrypto era)) EraIndependentTxBody)) =>
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 (EraCrypto era)]
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 (EraCrypto era) EraIndependentTxBody
txBodyHash = forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated TxBody era
txBody

        keyPairs :: Map (KeyHash Any (EraCrypto era)) (KeyPair Any (EraCrypto era))
keyPairs = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey KeyPair Any (EraCrypto era)
kp, KeyPair Any (EraCrypto era)
kp) | KeyPair Any (EraCrypto era)
kp <- [KeyPair Any (EraCrypto era)]
keyPairsList]
        wits :: Set (WitVKey 'Witness (EraCrypto era))
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 c (kr :: KeyRole).
(Crypto c, DSignable c (Hash (HASH c) EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> KeyPair kr c -> WitVKey 'Witness c
mkWitnessVKey SafeHash (EraCrypto era) EraIndependentTxBody
txBodyHash) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map (KeyHash Any (EraCrypto era)) (KeyPair Any (EraCrypto era))
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 (EraCrypto era)))
addrTxWitsL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Set (WitVKey 'Witness (EraCrypto era))
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 (EraCrypto era)) (KeyPair Any (EraCrypto era))
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 (EraCrypto era)]
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 (EraCrypto era) EraIndependentTxBody
txBodyHash = forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated TxBody era
txBody

        keyPairs :: Map (KeyHash Any (EraCrypto era)) (KeyPair Any (EraCrypto era))
keyPairs = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey KeyPair Any (EraCrypto era)
kp, KeyPair Any (EraCrypto era)
kp) | KeyPair Any (EraCrypto era)
kp <- [KeyPair Any (EraCrypto era)]
keyPairsList]
        wits :: Set (WitVKey 'Witness (EraCrypto era))
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 c (kr :: KeyRole).
(Crypto c, DSignable c (Hash (HASH c) EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> KeyPair kr c -> WitVKey 'Witness c
mkWitnessVKey SafeHash (EraCrypto era) EraIndependentTxBody
txBodyHash) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map (KeyHash Any (EraCrypto era)) (KeyPair Any (EraCrypto era))
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 (EraCrypto era))
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 (forall c.
(DSIGN c ~ Ed25519DSIGN, Crypto c) =>
Hash c EraIndependentTxBody
-> SigningKey -> Attributes AddrAttributes -> BootstrapWitness c
makeBootstrapWitness (forall c i. SafeHash c i -> Hash (HASH c) i
extractHash SafeHash (EraCrypto era) 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 (EraCrypto era)))
addrTxWitsL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Set (WitVKey 'Witness (EraCrypto era))
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 (EraCrypto era)))
bootAddrTxWitsL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Set (BootstrapWitness (EraCrypto era))
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 (EraCrypto era)) (KeyPair Any (EraCrypto era))
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),
 DSIGN (EraCrypto era) ~ Ed25519DSIGN,
 DSignable
   (EraCrypto era)
   (Hash (HASH (EraCrypto era)) EraIndependentTxBody)) =>
Spec
txSpec @Shelley
  forall era.
(EraTx era, Arbitrary (Tx era), Arbitrary (PParams era),
 DSIGN (EraCrypto era) ~ Ed25519DSIGN,
 DSignable
   (EraCrypto era)
   (Hash (HASH (EraCrypto era)) EraIndependentTxBody)) =>
Spec
txSpec @Allegra
  forall era.
(EraTx era, Arbitrary (Tx era), Arbitrary (PParams era),
 DSIGN (EraCrypto era) ~ Ed25519DSIGN,
 DSignable
   (EraCrypto era)
   (Hash (HASH (EraCrypto era)) EraIndependentTxBody)) =>
Spec
txSpec @Mary
  forall era.
(EraTx era, Arbitrary (Tx era), Arbitrary (PParams era),
 DSIGN (EraCrypto era) ~ Ed25519DSIGN,
 DSignable
   (EraCrypto era)
   (Hash (HASH (EraCrypto era)) EraIndependentTxBody)) =>
Spec
txSpec @Alonzo
  forall era.
(EraTx era, Arbitrary (Tx era), Arbitrary (PParams era),
 DSIGN (EraCrypto era) ~ Ed25519DSIGN,
 DSignable
   (EraCrypto era)
   (Hash (HASH (EraCrypto era)) EraIndependentTxBody)) =>
Spec
txSpec @Babbage
  forall era.
(EraTx era, Arbitrary (Tx era), Arbitrary (PParams era),
 DSIGN (EraCrypto era) ~ Ed25519DSIGN,
 DSignable
   (EraCrypto era)
   (Hash (HASH (EraCrypto era)) EraIndependentTxBody)) =>
Spec
txSpec @Conway