{-# LANGUAGE DerivingVia                #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilies               #-}

-- | Limits on the ledger-specific _measure_ (eg size) of a sequence of
-- transactions
--
-- > import           Ouroboros.Consensus.Mempool.TxLimits (TxLimits)
-- > import qualified Ouroboros.Consensus.Mempool.TxLimits as TxLimits
module Ouroboros.Consensus.Mempool.TxLimits (
    ByteSize (..)
  , TxLimits (..)
  , (Ouroboros.Consensus.Mempool.TxLimits.<=)
    -- * Restricting more strongly than the ledger's limits
  , Overrides
  , applyOverrides
  , getOverrides
  , mkOverrides
  , noOverridesMeasure
  ) where

import           Data.Coerce (coerce)
import           Data.Word (Word32)

import           Data.Measure (BoundedMeasure, Measure)
import qualified Data.Measure as Measure

import           Ouroboros.Consensus.Ledger.Abstract (Validated)
import           Ouroboros.Consensus.Ledger.Basics (LedgerState)
import           Ouroboros.Consensus.Ledger.SupportsMempool (GenTx)
import           Ouroboros.Consensus.Ticked (Ticked (..))

-- | Each block has its limits of how many transactions it can hold.
-- That limit is compared against the sum of measurements
-- taken of each of the transactions in that block.
--
-- How we measure the transaction depends of the era that this
-- transaction belongs to (more specifically it depends on the block
-- type to which this transaction will be added). For initial eras
-- (like Byron and initial generations of Shelley based eras) this
-- measure was simply a ByteSize (block could not be bigger then
-- given size - in bytes - specified by the ledger state). In future
-- eras (starting with Alonzo) this measure was a bit more complex
-- as it had to take other factors into account (like execution units).
-- For details please see the individual instances for the TxLimits.
class BoundedMeasure (TxMeasure blk) => TxLimits blk where
  type TxMeasure blk

  -- | What is the measure an individual tx?
  txMeasure        :: Validated (GenTx blk)    -> TxMeasure blk

  -- | What is the allowed capacity for txs in an individual block?
  txsBlockCapacity :: Ticked (LedgerState blk) -> TxMeasure blk

-- | Is every component of the first value less-than-or-equal-to the
-- corresponding component of the second value?
(<=) :: Measure a => a -> a -> Bool
<= :: a -> a -> Bool
(<=) = a -> a -> Bool
forall a. Measure a => a -> a -> Bool
(Measure.<=)

{-------------------------------------------------------------------------------
  ByteSize
-------------------------------------------------------------------------------}

newtype ByteSize = ByteSize { ByteSize -> Word32
unByteSize :: Word32 }
  deriving stock (Int -> ByteSize -> ShowS
[ByteSize] -> ShowS
ByteSize -> String
(Int -> ByteSize -> ShowS)
-> (ByteSize -> String) -> ([ByteSize] -> ShowS) -> Show ByteSize
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ByteSize] -> ShowS
$cshowList :: [ByteSize] -> ShowS
show :: ByteSize -> String
$cshow :: ByteSize -> String
showsPrec :: Int -> ByteSize -> ShowS
$cshowsPrec :: Int -> ByteSize -> ShowS
Show)
  deriving newtype (ByteSize -> ByteSize -> Bool
(ByteSize -> ByteSize -> Bool)
-> (ByteSize -> ByteSize -> Bool) -> Eq ByteSize
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ByteSize -> ByteSize -> Bool
$c/= :: ByteSize -> ByteSize -> Bool
== :: ByteSize -> ByteSize -> Bool
$c== :: ByteSize -> ByteSize -> Bool
Eq, Eq ByteSize
Eq ByteSize
-> (ByteSize -> ByteSize -> Ordering)
-> (ByteSize -> ByteSize -> Bool)
-> (ByteSize -> ByteSize -> Bool)
-> (ByteSize -> ByteSize -> Bool)
-> (ByteSize -> ByteSize -> Bool)
-> (ByteSize -> ByteSize -> ByteSize)
-> (ByteSize -> ByteSize -> ByteSize)
-> Ord ByteSize
ByteSize -> ByteSize -> Bool
ByteSize -> ByteSize -> Ordering
ByteSize -> ByteSize -> ByteSize
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 :: ByteSize -> ByteSize -> ByteSize
$cmin :: ByteSize -> ByteSize -> ByteSize
max :: ByteSize -> ByteSize -> ByteSize
$cmax :: ByteSize -> ByteSize -> ByteSize
>= :: ByteSize -> ByteSize -> Bool
$c>= :: ByteSize -> ByteSize -> Bool
> :: ByteSize -> ByteSize -> Bool
$c> :: ByteSize -> ByteSize -> Bool
<= :: ByteSize -> ByteSize -> Bool
$c<= :: ByteSize -> ByteSize -> Bool
< :: ByteSize -> ByteSize -> Bool
$c< :: ByteSize -> ByteSize -> Bool
compare :: ByteSize -> ByteSize -> Ordering
$ccompare :: ByteSize -> ByteSize -> Ordering
$cp1Ord :: Eq ByteSize
Ord)
  deriving newtype (Measure ByteSize
ByteSize
Measure ByteSize -> ByteSize -> BoundedMeasure ByteSize
forall a. Measure a -> a -> BoundedMeasure a
maxBound :: ByteSize
$cmaxBound :: ByteSize
$cp1BoundedMeasure :: Measure ByteSize
BoundedMeasure, Eq ByteSize
ByteSize
Eq ByteSize
-> ByteSize
-> (ByteSize -> ByteSize -> ByteSize)
-> (ByteSize -> ByteSize -> ByteSize)
-> (ByteSize -> ByteSize -> ByteSize)
-> Measure ByteSize
ByteSize -> ByteSize -> ByteSize
forall a.
Eq a
-> a
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> Measure a
max :: ByteSize -> ByteSize -> ByteSize
$cmax :: ByteSize -> ByteSize -> ByteSize
min :: ByteSize -> ByteSize -> ByteSize
$cmin :: ByteSize -> ByteSize -> ByteSize
plus :: ByteSize -> ByteSize -> ByteSize
$cplus :: ByteSize -> ByteSize -> ByteSize
zero :: ByteSize
$czero :: ByteSize
$cp1Measure :: Eq ByteSize
Measure)

{-------------------------------------------------------------------------------
  Overrides
-------------------------------------------------------------------------------}

-- | An override that lowers a capacity limit
--
-- Specifically, we use this override to let the node operator limit the total
-- 'TxMeasure' of transactions in blocks even more severely than would the
-- ledger state's 'txsBlockCapacity'. The forge logic will use the 'Measure.min'
-- (ie the lattice's @meet@ operator) to combine this override with the capacity
-- given by the ledger state. More concretely, that will typically be a
-- componentwise minimum operation, along each of the components\/dimensions of
-- @'TxMeasure' blk@.
--
-- This newtype wrapper distinguishes the intention of this particular
-- 'TxMeasure' as such an override. We use 'TxMeasure' in different ways in this
-- code base. The newtype also allows us to distinguish the one most appropriate
-- monoid among many offered by the 'TxLimits' superclass constraints: it is the
-- monoid induced by the bounded meet-semilattice (see 'BoundedMeasure') that is
-- relevant to the notion of /overriding/ the ledger's block capacity.
newtype Overrides blk =
  -- This constructor is not exported.
  Overrides {Overrides blk -> TxMeasure blk
getOverrides :: TxMeasure blk}

instance TxLimits blk => Monoid (Overrides blk) where
  mempty :: Overrides blk
mempty = TxMeasure blk -> Overrides blk
forall blk. TxMeasure blk -> Overrides blk
Overrides TxMeasure blk
forall a. BoundedMeasure a => a
noOverridesMeasure

instance TxLimits blk => Semigroup (Overrides blk) where
  <> :: Overrides blk -> Overrides blk -> Overrides blk
(<>) = (TxMeasure blk -> TxMeasure blk -> TxMeasure blk)
-> Overrides blk -> Overrides blk -> Overrides blk
coerce ((TxMeasure blk -> TxMeasure blk -> TxMeasure blk)
 -> Overrides blk -> Overrides blk -> Overrides blk)
-> (TxMeasure blk -> TxMeasure blk -> TxMeasure blk)
-> Overrides blk
-> Overrides blk
-> Overrides blk
forall a b. (a -> b) -> a -> b
$ Measure (TxMeasure blk) =>
TxMeasure blk -> TxMeasure blk -> TxMeasure blk
forall a. Measure a => a -> a -> a
Measure.min @(TxMeasure blk)

-- | @'applyOverrides' 'noOverrides' m = m@
noOverridesMeasure :: BoundedMeasure a => a
noOverridesMeasure :: a
noOverridesMeasure = a
forall a. BoundedMeasure a => a
Measure.maxBound

-- | Smart constructor for 'Overrides'.
mkOverrides :: TxMeasure blk -> Overrides blk
mkOverrides :: TxMeasure blk -> Overrides blk
mkOverrides = TxMeasure blk -> Overrides blk
forall blk. TxMeasure blk -> Overrides blk
Overrides

-- | Apply the override
applyOverrides ::
     TxLimits blk
  => Overrides blk
  -> TxMeasure blk
  -> TxMeasure blk
applyOverrides :: Overrides blk -> TxMeasure blk -> TxMeasure blk
applyOverrides (Overrides TxMeasure blk
m') TxMeasure blk
m = TxMeasure blk -> TxMeasure blk -> TxMeasure blk
forall a. Measure a => a -> a -> a
Measure.min TxMeasure blk
m' TxMeasure blk
m