{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NumDecimals #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Chain.Common.TxFeePolicy (
  TxFeePolicy (..),
)
where

import Cardano.Chain.Common.CBOR (
  decodeKnownCborDataItem,
  encodeKnownCborDataItem,
 )
import Cardano.Chain.Common.Lovelace (
  Lovelace,
  LovelaceError,
  lovelaceToInteger,
  mkLovelace,
 )
import Cardano.Chain.Common.TxSizeLinear (TxSizeLinear (..))
import Cardano.Ledger.Binary (
  DecCBOR (..),
  DecoderError (DecoderErrorUnknownTag),
  EncCBOR (..),
  FromCBOR (..),
  ToCBOR (..),
  cborError,
  encodeListLen,
  enforceSize,
  fromByronCBOR,
  toByronCBOR,
 )
import Cardano.Prelude hiding (cborError)
import qualified Data.Aeson as Aeson
import Formatting (bprint, build, formatToString)
import qualified Formatting.Buildable as B
import NoThunks.Class (NoThunks (..))
import Text.JSON.Canonical (
  FromJSON (..),
  ToJSON (..),
  expected,
  fromJSField,
  mkObject,
 )

-- | Transaction fee policy represents a formula to compute the minimal allowed
--   Fee for a transaction. Transactions with lesser fees won't be accepted. The
--   Minimal fee may depend on the properties of a transaction (for example, its
--   Size in bytes), so the policy can't be represented simply as a number.
--
--   Recall that a transaction fee is the difference between the sum of its
--   Inputs and the sum of its outputs. The transaction is accepted when
--   @minimal_fee(tx) <= fee(tx)@, where @minimal_fee@ is the function defined
--   By the policy.
--
--   The policy can change during the lifetime of the blockchain (using the
--   Update mechanism). At the moment we have just one policy type (a linear
--   Equation on the transaction size), but in the future other policies may Be
--   added. To make this future-proof, we also have an "unknown" policy used By
--   older node versions (the ones that haven't updated yet).
data TxFeePolicy
  = TxFeePolicyTxSizeLinear !TxSizeLinear
  deriving (TxFeePolicy -> TxFeePolicy -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TxFeePolicy -> TxFeePolicy -> Bool
$c/= :: TxFeePolicy -> TxFeePolicy -> Bool
== :: TxFeePolicy -> TxFeePolicy -> Bool
$c== :: TxFeePolicy -> TxFeePolicy -> Bool
Eq, Eq TxFeePolicy
TxFeePolicy -> TxFeePolicy -> Bool
TxFeePolicy -> TxFeePolicy -> Ordering
TxFeePolicy -> TxFeePolicy -> TxFeePolicy
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TxFeePolicy -> TxFeePolicy -> TxFeePolicy
$cmin :: TxFeePolicy -> TxFeePolicy -> TxFeePolicy
max :: TxFeePolicy -> TxFeePolicy -> TxFeePolicy
$cmax :: TxFeePolicy -> TxFeePolicy -> TxFeePolicy
>= :: TxFeePolicy -> TxFeePolicy -> Bool
$c>= :: TxFeePolicy -> TxFeePolicy -> Bool
> :: TxFeePolicy -> TxFeePolicy -> Bool
$c> :: TxFeePolicy -> TxFeePolicy -> Bool
<= :: TxFeePolicy -> TxFeePolicy -> Bool
$c<= :: TxFeePolicy -> TxFeePolicy -> Bool
< :: TxFeePolicy -> TxFeePolicy -> Bool
$c< :: TxFeePolicy -> TxFeePolicy -> Bool
compare :: TxFeePolicy -> TxFeePolicy -> Ordering
$ccompare :: TxFeePolicy -> TxFeePolicy -> Ordering
Ord, Int -> TxFeePolicy -> ShowS
[TxFeePolicy] -> ShowS
TxFeePolicy -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TxFeePolicy] -> ShowS
$cshowList :: [TxFeePolicy] -> ShowS
show :: TxFeePolicy -> String
$cshow :: TxFeePolicy -> String
showsPrec :: Int -> TxFeePolicy -> ShowS
$cshowsPrec :: Int -> TxFeePolicy -> ShowS
Show, forall x. Rep TxFeePolicy x -> TxFeePolicy
forall x. TxFeePolicy -> Rep TxFeePolicy x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TxFeePolicy x -> TxFeePolicy
$cfrom :: forall x. TxFeePolicy -> Rep TxFeePolicy x
Generic)
  deriving anyclass (TxFeePolicy -> ()
forall a. (a -> ()) -> NFData a
rnf :: TxFeePolicy -> ()
$crnf :: TxFeePolicy -> ()
NFData, Context -> TxFeePolicy -> IO (Maybe ThunkInfo)
Proxy TxFeePolicy -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy TxFeePolicy -> String
$cshowTypeOf :: Proxy TxFeePolicy -> String
wNoThunks :: Context -> TxFeePolicy -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> TxFeePolicy -> IO (Maybe ThunkInfo)
noThunks :: Context -> TxFeePolicy -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> TxFeePolicy -> IO (Maybe ThunkInfo)
NoThunks)

instance B.Buildable TxFeePolicy where
  build :: TxFeePolicy -> Builder
build (TxFeePolicyTxSizeLinear TxSizeLinear
tsp) =
    forall a. Format Builder a -> a
bprint (Format (TxSizeLinear -> Builder) (TxSizeLinear -> Builder)
"policy(tx-size-linear): " forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a r. Buildable a => Format r (a -> r)
build) TxSizeLinear
tsp

-- Used for debugging purposes only
instance Aeson.ToJSON TxFeePolicy

instance ToCBOR TxFeePolicy where
  toCBOR :: TxFeePolicy -> Encoding
toCBOR = forall a. EncCBOR a => a -> Encoding
toByronCBOR

instance FromCBOR TxFeePolicy where
  fromCBOR :: forall s. Decoder s TxFeePolicy
fromCBOR = forall a s. DecCBOR a => Decoder s a
fromByronCBOR

instance EncCBOR TxFeePolicy where
  encCBOR :: TxFeePolicy -> Encoding
encCBOR TxFeePolicy
policy = case TxFeePolicy
policy of
    TxFeePolicyTxSizeLinear TxSizeLinear
txSizeLinear ->
      Word -> Encoding
encodeListLen Word
2
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
0 :: Word8)
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encodeKnownCborDataItem TxSizeLinear
txSizeLinear

instance DecCBOR TxFeePolicy where
  decCBOR :: forall s. Decoder s TxFeePolicy
decCBOR = do
    forall s. Text -> Int -> Decoder s ()
enforceSize Text
"TxFeePolicy" Int
2
    Word8
tag <- forall a s. DecCBOR a => Decoder s a
decCBOR @Word8
    case Word8
tag of
      Word8
0 -> TxSizeLinear -> TxFeePolicy
TxFeePolicyTxSizeLinear forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decodeKnownCborDataItem
      Word8
_ -> forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError forall a b. (a -> b) -> a -> b
$ Text -> Word8 -> DecoderError
DecoderErrorUnknownTag Text
"TxFeePolicy" Word8
tag

instance Monad m => ToJSON m TxFeePolicy where
  -- We multiply by 1e9 to keep compatibility with 'Nano' coefficients
  toJSON :: TxFeePolicy -> m JSValue
toJSON (TxFeePolicyTxSizeLinear (TxSizeLinear Lovelace
summand Rational
multiplier)) =
    forall (m :: * -> *).
Monad m =>
[(JSString, m JSValue)] -> m JSValue
mkObject
      [ (JSString
"summand", forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON forall a b. (a -> b) -> a -> b
$ Integer
1e9 forall a. Num a => a -> a -> a
* Lovelace -> Integer
lovelaceToInteger Lovelace
summand)
      , (JSString
"multiplier", forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON (forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ Rational
1e9 forall a. Num a => a -> a -> a
* Rational
multiplier :: Integer))
      ]

instance MonadError SchemaError m => FromJSON m TxFeePolicy where
  -- We div by 1e9 to keep compatibility with 'Nano' coefficients
  fromJSON :: JSValue -> m TxFeePolicy
fromJSON JSValue
obj = do
    Lovelace
summand <-
      Either LovelaceError Lovelace -> m Lovelace
wrapLovelaceError
        forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Word64 -> Either LovelaceError Lovelace
mkLovelace
        forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (forall a. Integral a => a -> a -> a
`div` Word64
1e9)
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> JSString -> m a
fromJSField
          JSValue
obj
          JSString
"summand"
    Rational
multiplier <-
      (forall a. Integral a => a -> a -> Ratio a
% Integer
1e9)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> JSString -> m a
fromJSField
          JSValue
obj
          JSString
"multiplier"
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TxSizeLinear -> TxFeePolicy
TxFeePolicyTxSizeLinear (Lovelace -> Rational -> TxSizeLinear
TxSizeLinear Lovelace
summand Rational
multiplier)
    where
      wrapLovelaceError :: Either LovelaceError Lovelace -> m Lovelace
      wrapLovelaceError :: Either LovelaceError Lovelace -> m Lovelace
wrapLovelaceError =
        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a.
ReportSchemaErrors m =>
String -> Maybe String -> m a
expected String
"Lovelace" forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. a -> Maybe a
Just forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Format String a -> a
formatToString forall a r. Buildable a => Format r (a -> r)
build) forall (f :: * -> *) a. Applicative f => a -> f a
pure