{-# 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 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 = TxBody ConwayEra -> Tx ConwayEra
TxBody ConwayEra -> AlonzoTx ConwayEra
forall era. Monoid (TxWits era) => TxBody era -> AlonzoTx era
mkBasicAlonzoTx

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

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

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

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

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

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

  getMinFeeTx :: PParams ConwayEra -> Tx ConwayEra -> Int -> Coin
getMinFeeTx = PParams ConwayEra -> Tx ConwayEra -> Int -> Coin
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) =
    TxBody ConwayEra
-> TxWits ConwayEra
-> IsValid
-> StrictMaybe (TxAuxData ConwayEra)
-> AlonzoTx ConwayEra
TxBody ConwayEra
-> AlonzoTxWits ConwayEra
-> IsValid
-> StrictMaybe (AlonzoTxAuxData ConwayEra)
-> AlonzoTx ConwayEra
forall era.
TxBody era
-> TxWits era
-> IsValid
-> StrictMaybe (TxAuxData era)
-> AlonzoTx era
AlonzoTx
      (TxBody ConwayEra
 -> AlonzoTxWits ConwayEra
 -> IsValid
 -> StrictMaybe (AlonzoTxAuxData ConwayEra)
 -> AlonzoTx ConwayEra)
-> Either ConwayTxBodyUpgradeError (TxBody ConwayEra)
-> Either
     ConwayTxBodyUpgradeError
     (AlonzoTxWits ConwayEra
      -> IsValid
      -> StrictMaybe (AlonzoTxAuxData ConwayEra)
      -> AlonzoTx ConwayEra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxBody (PreviousEra ConwayEra)
-> Either (TxBodyUpgradeError ConwayEra) (TxBody ConwayEra)
forall era.
(EraTxBody era, EraTxBody (PreviousEra era)) =>
TxBody (PreviousEra era)
-> Either (TxBodyUpgradeError era) (TxBody era)
upgradeTxBody TxBody (PreviousEra ConwayEra)
TxBody BabbageEra
b
      Either
  ConwayTxBodyUpgradeError
  (AlonzoTxWits ConwayEra
   -> IsValid
   -> StrictMaybe (AlonzoTxAuxData ConwayEra)
   -> AlonzoTx ConwayEra)
-> Either ConwayTxBodyUpgradeError (AlonzoTxWits ConwayEra)
-> Either
     ConwayTxBodyUpgradeError
     (IsValid
      -> StrictMaybe (AlonzoTxAuxData ConwayEra) -> AlonzoTx ConwayEra)
forall a b.
Either ConwayTxBodyUpgradeError (a -> b)
-> Either ConwayTxBodyUpgradeError a
-> Either ConwayTxBodyUpgradeError b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AlonzoTxWits ConwayEra
-> Either ConwayTxBodyUpgradeError (AlonzoTxWits ConwayEra)
forall a. a -> Either ConwayTxBodyUpgradeError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxWits (PreviousEra ConwayEra) -> TxWits ConwayEra
forall era.
(EraTxWits era, EraTxWits (PreviousEra era)) =>
TxWits (PreviousEra era) -> TxWits era
upgradeTxWits TxWits (PreviousEra ConwayEra)
TxWits BabbageEra
w)
      Either
  ConwayTxBodyUpgradeError
  (IsValid
   -> StrictMaybe (AlonzoTxAuxData ConwayEra) -> AlonzoTx ConwayEra)
-> Either ConwayTxBodyUpgradeError IsValid
-> Either
     ConwayTxBodyUpgradeError
     (StrictMaybe (AlonzoTxAuxData ConwayEra) -> AlonzoTx ConwayEra)
forall a b.
Either ConwayTxBodyUpgradeError (a -> b)
-> Either ConwayTxBodyUpgradeError a
-> Either ConwayTxBodyUpgradeError b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IsValid -> Either ConwayTxBodyUpgradeError IsValid
forall a. a -> Either ConwayTxBodyUpgradeError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IsValid
valid
      Either
  ConwayTxBodyUpgradeError
  (StrictMaybe (AlonzoTxAuxData ConwayEra) -> AlonzoTx ConwayEra)
-> Either
     ConwayTxBodyUpgradeError (StrictMaybe (AlonzoTxAuxData ConwayEra))
-> Either ConwayTxBodyUpgradeError (AlonzoTx ConwayEra)
forall a b.
Either ConwayTxBodyUpgradeError (a -> b)
-> Either ConwayTxBodyUpgradeError a
-> Either ConwayTxBodyUpgradeError b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StrictMaybe (AlonzoTxAuxData ConwayEra)
-> Either
     ConwayTxBodyUpgradeError (StrictMaybe (AlonzoTxAuxData ConwayEra))
forall a. a -> Either ConwayTxBodyUpgradeError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((TxAuxData (PreviousEra ConwayEra) -> AlonzoTxAuxData ConwayEra)
-> StrictMaybe (TxAuxData (PreviousEra ConwayEra))
-> StrictMaybe (AlonzoTxAuxData ConwayEra)
forall a b. (a -> b) -> StrictMaybe a -> StrictMaybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxAuxData (PreviousEra ConwayEra) -> TxAuxData ConwayEra
TxAuxData (PreviousEra ConwayEra) -> AlonzoTxAuxData ConwayEra
forall era.
(EraTxAuxData era, EraTxAuxData (PreviousEra era)) =>
TxAuxData (PreviousEra era) -> TxAuxData era
upgradeTxAuxData StrictMaybe (TxAuxData (PreviousEra ConwayEra))
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 =
  PParams era -> Tx era -> Coin
forall era.
(EraTx era, AlonzoEraTxWits era, AlonzoEraPParams era) =>
PParams era -> Tx era -> Coin
alonzoMinFeeTx PParams era
pp Tx era
tx Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
refScriptsFee
  where
    refScriptCostPerByte :: Rational
refScriptCostPerByte = NonNegativeInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational (PParams era
pp PParams era
-> Getting NonNegativeInterval (PParams era) NonNegativeInterval
-> NonNegativeInterval
forall s a. s -> Getting a s a -> a
^. Getting NonNegativeInterval (PParams era) NonNegativeInterval
forall era.
ConwayEraPParams era =>
Lens' (PParams era) NonNegativeInterval
Lens' (PParams era) NonNegativeInterval
ppMinFeeRefScriptCostPerByteL)
    refScriptsFee :: Coin
refScriptsFee =
      HasCallStack => Rational -> Int -> Rational -> Int -> Coin
Rational -> Int -> Rational -> Int -> Coin
tierRefScriptFee
        Rational
refScriptCostMultiplier
        Int
refScriptCostStride
        Rational
refScriptCostPerByte
        Int
refScriptsSize

-- | Calculate the fee for reference scripts using an exponential 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 Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
<= Rational
0 Bool -> Bool -> Bool
|| Int
sizeIncrement Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = [Char] -> Rational -> Int -> Coin
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
sizeIncrement =
          Integer -> Coin
Coin (Integer -> Coin) -> Integer -> Coin
forall a b. (a -> b) -> a -> b
$ Rational -> Integer
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational
acc Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Int -> Rational
forall a. Real a => a -> Rational
toRational Int
n Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
curTierPrice)
      | Bool
otherwise =
          Rational -> Rational -> Int -> Coin
go (Rational
acc Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
sizeIncrementRational Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
curTierPrice) (Rational
multiplier Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
curTierPrice) (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sizeIncrement)
    sizeIncrementRational :: Rational
sizeIncrementRational = Int -> Rational
forall a. Real a => a -> Rational
toRational Int
sizeIncrement

instance AlonzoEraTx ConwayEra where
  isValidTxL :: Lens' (Tx ConwayEra) IsValid
isValidTxL = (IsValid -> f IsValid) -> Tx ConwayEra -> f (Tx ConwayEra)
(IsValid -> f IsValid)
-> AlonzoTx ConwayEra -> f (AlonzoTx ConwayEra)
forall era (f :: * -> *).
Functor f =>
(IsValid -> f IsValid) -> AlonzoTx era -> f (AlonzoTx era)
isValidAlonzoTxL
  {-# INLINE isValidTxL #-}

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