{-# 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.Val (Val (..))
import Data.Ratio ((%))
import GHC.Stack
import Lens.Micro ((^.))

instance EraTx ConwayEra where
  type Tx ConwayEra = AlonzoTx ConwayEra
  type TxUpgradeError ConwayEra = TxBodyUpgradeError ConwayEra

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

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

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

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

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

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

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

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

  upgradeTx :: EraTx (PreviousEra ConwayEra) =>
Tx (PreviousEra ConwayEra)
-> Either (TxUpgradeError ConwayEra) (Tx ConwayEra)
upgradeTx (AlonzoTx TxBody BabbageEra
b TxWits BabbageEra
w IsValid
valid StrictMaybe (TxAuxData BabbageEra)
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
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
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)
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 AlonzoEraTx ConwayEra where
  isValidTxL :: Lens' (Tx ConwayEra) IsValid
isValidTxL = forall era. Lens' (AlonzoTx era) IsValid
isValidAlonzoTxL
  {-# INLINE isValidTxL #-}

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