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

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

import Cardano.Binary
  ( DecoderError (DecoderErrorUnknownTag),
    FromCBOR (..),
    ToCBOR (..),
    encodeListLen,
    enforceSize,
  )
import Cardano.Chain.Common.CBOR
  ( decodeKnownCborDataItem,
    encodeKnownCborDataItem,
  )
import Cardano.Chain.Common.Lovelace
  ( Lovelace,
    LovelaceError,
    lovelaceToInteger,
    mkLovelace,
  )
import Cardano.Chain.Common.TxSizeLinear (TxSizeLinear (..))
import Cardano.Prelude
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
(TxFeePolicy -> TxFeePolicy -> Bool)
-> (TxFeePolicy -> TxFeePolicy -> Bool) -> Eq TxFeePolicy
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
Eq TxFeePolicy
-> (TxFeePolicy -> TxFeePolicy -> Ordering)
-> (TxFeePolicy -> TxFeePolicy -> Bool)
-> (TxFeePolicy -> TxFeePolicy -> Bool)
-> (TxFeePolicy -> TxFeePolicy -> Bool)
-> (TxFeePolicy -> TxFeePolicy -> Bool)
-> (TxFeePolicy -> TxFeePolicy -> TxFeePolicy)
-> (TxFeePolicy -> TxFeePolicy -> TxFeePolicy)
-> Ord 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
$cp1Ord :: Eq TxFeePolicy
Ord, Int -> TxFeePolicy -> ShowS
[TxFeePolicy] -> ShowS
TxFeePolicy -> String
(Int -> TxFeePolicy -> ShowS)
-> (TxFeePolicy -> String)
-> ([TxFeePolicy] -> ShowS)
-> Show TxFeePolicy
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. TxFeePolicy -> Rep TxFeePolicy x)
-> (forall x. Rep TxFeePolicy x -> TxFeePolicy)
-> Generic TxFeePolicy
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 -> ()
(TxFeePolicy -> ()) -> NFData TxFeePolicy
forall a. (a -> ()) -> NFData a
rnf :: TxFeePolicy -> ()
$crnf :: TxFeePolicy -> ()
NFData, Context -> TxFeePolicy -> IO (Maybe ThunkInfo)
Proxy TxFeePolicy -> String
(Context -> TxFeePolicy -> IO (Maybe ThunkInfo))
-> (Context -> TxFeePolicy -> IO (Maybe ThunkInfo))
-> (Proxy TxFeePolicy -> String)
-> NoThunks TxFeePolicy
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) =
    Format Builder (TxSizeLinear -> Builder) -> TxSizeLinear -> Builder
forall a. Format Builder a -> a
bprint (Format (TxSizeLinear -> Builder) (TxSizeLinear -> Builder)
"policy(tx-size-linear): " Format (TxSizeLinear -> Builder) (TxSizeLinear -> Builder)
-> Format Builder (TxSizeLinear -> Builder)
-> Format Builder (TxSizeLinear -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder (TxSizeLinear -> Builder)
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 TxFeePolicy
policy = case TxFeePolicy
policy of
    TxFeePolicyTxSizeLinear TxSizeLinear
txSizeLinear ->
      Word -> Encoding
encodeListLen Word
2
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
0 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> TxSizeLinear -> Encoding
forall a. ToCBOR a => a -> Encoding
encodeKnownCborDataItem TxSizeLinear
txSizeLinear

instance FromCBOR TxFeePolicy where
  fromCBOR :: Decoder s TxFeePolicy
fromCBOR = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"TxFeePolicy" Int
2
    Word8
tag <- forall s. FromCBOR Word8 => Decoder s Word8
forall a s. FromCBOR a => Decoder s a
fromCBOR @Word8
    case Word8
tag of
      Word8
0 -> TxSizeLinear -> TxFeePolicy
TxFeePolicyTxSizeLinear (TxSizeLinear -> TxFeePolicy)
-> Decoder s TxSizeLinear -> Decoder s TxFeePolicy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s TxSizeLinear
forall a s. FromCBOR a => Decoder s a
decodeKnownCborDataItem
      Word8
_ -> DecoderError -> Decoder s TxFeePolicy
forall e s a. Buildable e => e -> Decoder s a
cborError (DecoderError -> Decoder s TxFeePolicy)
-> DecoderError -> Decoder s TxFeePolicy
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)) =
    [(JSString, m JSValue)] -> m JSValue
forall (m :: * -> *).
Monad m =>
[(JSString, m JSValue)] -> m JSValue
mkObject
      [ (JSString
"summand", Integer -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON (Integer -> m JSValue) -> Integer -> m JSValue
forall a b. (a -> b) -> a -> b
$ Integer
1e9 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Lovelace -> Integer
lovelaceToInteger Lovelace
summand),
        (JSString
"multiplier", Integer -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON (Rational -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational -> Integer) -> Rational -> Integer
forall a b. (a -> b) -> a -> b
$ Rational
1e9 Rational -> Rational -> Rational
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 (Either LovelaceError Lovelace -> m Lovelace)
-> (Word64 -> Either LovelaceError Lovelace)
-> Word64
-> m Lovelace
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 (Word64 -> Either LovelaceError Lovelace)
-> (Word64 -> Word64) -> Word64 -> Either LovelaceError Lovelace
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
1e9)
        (Word64 -> m Lovelace) -> m Word64 -> m Lovelace
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSValue -> JSString -> m Word64
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> JSString -> m a
fromJSField
          JSValue
obj
          JSString
"summand"
    Rational
multiplier <-
      (Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
1e9)
        (Integer -> Rational) -> m Integer -> m Rational
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue -> JSString -> m Integer
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> JSString -> m a
fromJSField
          JSValue
obj
          JSString
"multiplier"
    TxFeePolicy -> m TxFeePolicy
forall (m :: * -> *) a. Monad m => a -> m a
return (TxFeePolicy -> m TxFeePolicy) -> TxFeePolicy -> m TxFeePolicy
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 =
        (LovelaceError -> m Lovelace)
-> (Lovelace -> m Lovelace)
-> Either LovelaceError Lovelace
-> m Lovelace
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Maybe String -> m Lovelace
forall (m :: * -> *) a.
ReportSchemaErrors m =>
String -> Maybe String -> m a
expected String
"Lovelace" (Maybe String -> m Lovelace)
-> (LovelaceError -> Maybe String) -> LovelaceError -> m Lovelace
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> (LovelaceError -> String) -> LovelaceError -> Maybe String
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format String (LovelaceError -> String) -> LovelaceError -> String
forall a. Format String a -> a
formatToString Format String (LovelaceError -> String)
forall a r. Buildable a => Format r (a -> r)
build) Lovelace -> m Lovelace
forall (f :: * -> *) a. Applicative f => a -> f a
pure