{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Conway.Tx (
  module BabbageTxReExport,
  tierRefScriptFee,
  refScriptCostStride,
  refScriptCostMultiplier,
)
where

import Cardano.Ledger.Allegra.Tx (validateTimelock)
import Cardano.Ledger.Alonzo.Core (AlonzoEraTxWits)
import Cardano.Ledger.Alonzo.Tx (
  alonzoMinFeeTx,
  auxDataAlonzoTxL,
  bodyAlonzoTxL,
  isValidAlonzoTxL,
  mkBasicAlonzoTx,
  sizeAlonzoTxF,
  wireSizeAlonzoTxF,
  witsAlonzoTxL,
 )
import Cardano.Ledger.Alonzo.TxSeq (
  AlonzoTxSeq (AlonzoTxSeq, txSeqTxns),
  hashAlonzoTxSeq,
 )
import Cardano.Ledger.Babbage.Tx as BabbageTxReExport (
  AlonzoEraTx (..),
  AlonzoTx (..),
 )
import Cardano.Ledger.BaseTypes (unboundRational)
import Cardano.Ledger.Coin (Coin (Coin))
import Cardano.Ledger.Conway.Era (ConwayEra)
import Cardano.Ledger.Conway.PParams (ConwayEraPParams, ppMinFeeRefScriptCostPerByteL)
import Cardano.Ledger.Conway.TxAuxData ()
import Cardano.Ledger.Conway.TxBody ()
import Cardano.Ledger.Conway.TxWits ()
import Cardano.Ledger.Core
import Cardano.Ledger.Crypto
import Cardano.Ledger.Val (Val (..))
import Data.Ratio ((%))
import GHC.Stack
import Lens.Micro ((^.))

instance Crypto c => EraTx (ConwayEra c) where
  {-# SPECIALIZE instance EraTx (ConwayEra StandardCrypto) #-}

  type Tx (ConwayEra c) = AlonzoTx (ConwayEra c)
  type TxUpgradeError (ConwayEra c) = TxBodyUpgradeError (ConwayEra c)

  mkBasicTx :: TxBody (ConwayEra c) -> Tx (ConwayEra c)
mkBasicTx = forall era. Monoid (TxWits era) => TxBody era -> AlonzoTx era
mkBasicAlonzoTx

  bodyTxL :: Lens' (Tx (ConwayEra c)) (TxBody (ConwayEra c))
bodyTxL = forall era. Lens' (AlonzoTx era) (TxBody era)
bodyAlonzoTxL
  {-# INLINE bodyTxL #-}

  witsTxL :: Lens' (Tx (ConwayEra c)) (TxWits (ConwayEra c))
witsTxL = forall era. Lens' (AlonzoTx era) (TxWits era)
witsAlonzoTxL
  {-# INLINE witsTxL #-}

  auxDataTxL :: Lens'
  (Tx (ConwayEra c)) (StrictMaybe (AuxiliaryData (ConwayEra c)))
auxDataTxL = forall era. Lens' (AlonzoTx era) (StrictMaybe (TxAuxData era))
auxDataAlonzoTxL
  {-# INLINE auxDataTxL #-}

  sizeTxF :: SimpleGetter (Tx (ConwayEra c)) Integer
sizeTxF = forall era. EraTx era => SimpleGetter (AlonzoTx era) Integer
sizeAlonzoTxF
  {-# INLINE sizeTxF #-}

  wireSizeTxF :: SimpleGetter (Tx (ConwayEra c)) Word32
wireSizeTxF = forall era. EraTx era => SimpleGetter (AlonzoTx era) Word32
wireSizeAlonzoTxF
  {-# INLINE wireSizeTxF #-}

  validateNativeScript :: Tx (ConwayEra c) -> NativeScript (ConwayEra c) -> Bool
validateNativeScript = forall era.
(EraTx era, AllegraEraTxBody era, AllegraEraScript era) =>
Tx era -> NativeScript era -> Bool
validateTimelock
  {-# INLINE validateNativeScript #-}

  getMinFeeTx :: PParams (ConwayEra c) -> Tx (ConwayEra c) -> Int -> Coin
getMinFeeTx = forall era.
(EraTx era, AlonzoEraTxWits era, ConwayEraPParams era) =>
PParams era -> Tx era -> Int -> Coin
getConwayMinFeeTx

  upgradeTx :: EraTx (PreviousEra (ConwayEra c)) =>
Tx (PreviousEra (ConwayEra c))
-> Either (TxUpgradeError (ConwayEra c)) (Tx (ConwayEra c))
upgradeTx (AlonzoTx TxBody (BabbageEra c)
b TxWits (BabbageEra c)
w IsValid
valid StrictMaybe (TxAuxData (BabbageEra c))
aux) =
    forall era.
TxBody era
-> TxWits era
-> IsValid
-> StrictMaybe (TxAuxData era)
-> AlonzoTx era
AlonzoTx
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
(EraTxBody era, EraTxBody (PreviousEra era)) =>
TxBody (PreviousEra era)
-> Either (TxBodyUpgradeError era) (TxBody era)
upgradeTxBody TxBody (BabbageEra c)
b
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall era.
(EraTxWits era, EraTxWits (PreviousEra era)) =>
TxWits (PreviousEra era) -> TxWits era
upgradeTxWits TxWits (BabbageEra c)
w)
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure IsValid
valid
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall era.
(EraTxAuxData era, EraTxAuxData (PreviousEra era)) =>
TxAuxData (PreviousEra era) -> TxAuxData era
upgradeTxAuxData StrictMaybe (TxAuxData (BabbageEra c))
aux)

-- | 25 KiB
refScriptCostStride :: Int
refScriptCostStride :: Int
refScriptCostStride = Int
25_600

refScriptCostMultiplier :: Rational
refScriptCostMultiplier :: Rational
refScriptCostMultiplier = Rational
1.2

getConwayMinFeeTx ::
  ( EraTx era
  , AlonzoEraTxWits era
  , ConwayEraPParams era
  ) =>
  PParams era ->
  Tx era ->
  Int ->
  Coin
getConwayMinFeeTx :: forall era.
(EraTx era, AlonzoEraTxWits era, ConwayEraPParams era) =>
PParams era -> Tx era -> Int -> Coin
getConwayMinFeeTx PParams era
pp Tx era
tx Int
refScriptsSize =
  forall era.
(EraTx era, AlonzoEraTxWits era, AlonzoEraPParams era) =>
PParams era -> Tx era -> Coin
alonzoMinFeeTx PParams era
pp Tx era
tx forall t. Val t => t -> t -> t
<+> Coin
refScriptsFee
  where
    refScriptCostPerByte :: Rational
refScriptCostPerByte = forall r. BoundedRational r => r -> Rational
unboundRational (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraPParams era =>
Lens' (PParams era) NonNegativeInterval
ppMinFeeRefScriptCostPerByteL)
    refScriptsFee :: Coin
refScriptsFee =
      HasCallStack => Rational -> Int -> Rational -> Int -> Coin
tierRefScriptFee
        Rational
refScriptCostMultiplier
        Int
refScriptCostStride
        Rational
refScriptCostPerByte
        Int
refScriptsSize

-- | Calculate the fee for reference scripts using an expoential growth of the price per
-- byte with linear increments
tierRefScriptFee ::
  HasCallStack =>
  -- | Growth factor or step multiplier
  Rational ->
  -- | Increment size in which price grows linearly according to the price
  Int ->
  -- | Base fee. Currently this is customizable by `ppMinFeeRefScriptCostPerByteL`
  Rational ->
  -- | Total RefScript size in bytes
  Int ->
  Coin
tierRefScriptFee :: HasCallStack => Rational -> Int -> Rational -> Int -> Coin
tierRefScriptFee Rational
multiplier Int
sizeIncrement
  | Rational
multiplier forall a. Ord a => a -> a -> Bool
<= Rational
0 Bool -> Bool -> Bool
|| Int
sizeIncrement forall a. Ord a => a -> a -> Bool
<= Int
0 = forall a. HasCallStack => [Char] -> a
error [Char]
"Size increment and multiplier must be positive"
  | Bool
otherwise = Rational -> Rational -> Int -> Coin
go Rational
0
  where
    go :: Rational -> Rational -> Int -> Coin
go !Rational
acc !Rational
curTierPrice !Int
n
      | Int
n forall a. Ord a => a -> a -> Bool
< Int
sizeIncrement =
          Integer -> Coin
Coin forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational
acc forall a. Num a => a -> a -> a
+ (forall a. Integral a => a -> Integer
toInteger Int
n forall a. Integral a => a -> a -> Ratio a
% Integer
1) forall a. Num a => a -> a -> a
* Rational
curTierPrice)
      | Bool
otherwise =
          Rational -> Rational -> Int -> Coin
go (Rational
acc forall a. Num a => a -> a -> a
+ Rational
sizeIncrementRational forall a. Num a => a -> a -> a
* Rational
curTierPrice) (Rational
multiplier forall a. Num a => a -> a -> a
* Rational
curTierPrice) (Int
n forall a. Num a => a -> a -> a
- Int
sizeIncrement)
    sizeIncrementRational :: Rational
sizeIncrementRational = forall a. Integral a => a -> Integer
toInteger Int
sizeIncrement forall a. Integral a => a -> a -> Ratio a
% Integer
1

instance Crypto c => AlonzoEraTx (ConwayEra c) where
  {-# SPECIALIZE instance AlonzoEraTx (ConwayEra StandardCrypto) #-}

  isValidTxL :: Lens' (Tx (ConwayEra c)) IsValid
isValidTxL = forall era. Lens' (AlonzoTx era) IsValid
isValidAlonzoTxL
  {-# INLINE isValidTxL #-}

instance Crypto c => EraSegWits (ConwayEra c) where
  type TxSeq (ConwayEra c) = AlonzoTxSeq (ConwayEra c)
  fromTxSeq :: TxSeq (ConwayEra c) -> StrictSeq (Tx (ConwayEra c))
fromTxSeq = forall era. AlonzoTxSeq era -> StrictSeq (Tx era)
txSeqTxns
  toTxSeq :: StrictSeq (Tx (ConwayEra c)) -> TxSeq (ConwayEra c)
toTxSeq = forall era.
(AlonzoEraTx era, SafeToHash (TxWits era)) =>
StrictSeq (Tx era) -> AlonzoTxSeq era
AlonzoTxSeq
  hashTxSeq :: TxSeq (ConwayEra c)
-> Hash (HASH (EraCrypto (ConwayEra c))) EraIndependentBlockBody
hashTxSeq = forall era.
Era era =>
AlonzoTxSeq era -> Hash (EraCrypto era) EraIndependentBlockBody
hashAlonzoTxSeq
  numSegComponents :: Word64
numSegComponents = Word64
4