{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | Mempool capacity, size and transaction size datatypes.
--
-- This module also defines how to manually override the mempool capacity.
--
-- > import           Ouroboros.Consensus.Mempool.Capacity (Capacity)
-- > import qualified Ouroboros.Consensus.Mempool.Capacity as Capacity
module Ouroboros.Consensus.Mempool.Capacity
  ( -- * Mempool capacity
    MempoolCapacityBytesOverride (..)
  , computeMempoolCapacity
  , mkCapacityBytesOverride

    -- * Mempool Size
  , MempoolSize (..)
  ) where

import Data.DerivingVia (InstantiatedAt (..))
import Data.Measure (Measure)
import qualified Data.Measure as Measure
import Data.Proxy (Proxy (..))
import Data.Semigroup (stimes)
import Data.Word (Word32)
import GHC.Generics
import NoThunks.Class
import Ouroboros.Consensus.Ledger.Basics
import Ouroboros.Consensus.Ledger.SupportsMempool

{-------------------------------------------------------------------------------
  Mempool capacity in bytes
-------------------------------------------------------------------------------}

-- | An override for the default 'MempoolCapacityBytes' which is 2x the
-- maximum transaction capacity
data MempoolCapacityBytesOverride
  = -- | Use 2x the maximum transaction capacity of a block plus, under Leios,
    -- of an endorser block. This will change dynamically with the protocol
    -- parameters adopted in the current ledger.
    NoMempoolCapacityBytesOverride
  | -- | Use the least multiple of the block (plus endorser-block) capacity
    -- that is no less than this size.
    MempoolCapacityBytesOverride !ByteSize32
  deriving (MempoolCapacityBytesOverride
-> MempoolCapacityBytesOverride -> Bool
(MempoolCapacityBytesOverride
 -> MempoolCapacityBytesOverride -> Bool)
-> (MempoolCapacityBytesOverride
    -> MempoolCapacityBytesOverride -> Bool)
-> Eq MempoolCapacityBytesOverride
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MempoolCapacityBytesOverride
-> MempoolCapacityBytesOverride -> Bool
== :: MempoolCapacityBytesOverride
-> MempoolCapacityBytesOverride -> Bool
$c/= :: MempoolCapacityBytesOverride
-> MempoolCapacityBytesOverride -> Bool
/= :: MempoolCapacityBytesOverride
-> MempoolCapacityBytesOverride -> Bool
Eq, Int -> MempoolCapacityBytesOverride -> ShowS
[MempoolCapacityBytesOverride] -> ShowS
MempoolCapacityBytesOverride -> String
(Int -> MempoolCapacityBytesOverride -> ShowS)
-> (MempoolCapacityBytesOverride -> String)
-> ([MempoolCapacityBytesOverride] -> ShowS)
-> Show MempoolCapacityBytesOverride
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MempoolCapacityBytesOverride -> ShowS
showsPrec :: Int -> MempoolCapacityBytesOverride -> ShowS
$cshow :: MempoolCapacityBytesOverride -> String
show :: MempoolCapacityBytesOverride -> String
$cshowList :: [MempoolCapacityBytesOverride] -> ShowS
showList :: [MempoolCapacityBytesOverride] -> ShowS
Show)

-- | Create an override for the mempool capacity using the provided number of
-- bytes.
mkCapacityBytesOverride :: ByteSize32 -> MempoolCapacityBytesOverride
mkCapacityBytesOverride :: ByteSize32 -> MempoolCapacityBytesOverride
mkCapacityBytesOverride = ByteSize32 -> MempoolCapacityBytesOverride
MempoolCapacityBytesOverride

-- | If no override is provided, calculate the default mempool capacity as 2x
-- what one forging opportunity can take from the mempool: the current
-- ledger's maximum transaction capacity of a block plus, under Leios, of an
-- endorser block ('mempoolEbReservation' of 'ebCapacityTxMeasure', zero
-- elsewhere).
--
-- If an override is present, reinterpret it as a number of such units
-- (rounded up), and then multiply the unit capacity by that number.
computeMempoolCapacity ::
  forall blk mk.
  LedgerSupportsMempool blk =>
  LedgerConfig blk ->
  TickedLedgerState blk mk ->
  MempoolCapacityBytesOverride ->
  TxMeasure blk
computeMempoolCapacity :: forall blk (mk :: MapKind).
LedgerSupportsMempool blk =>
LedgerConfig blk
-> TickedLedgerState blk mk
-> MempoolCapacityBytesOverride
-> TxMeasure blk
computeMempoolCapacity LedgerConfig blk
cfg TickedLedgerState blk mk
st MempoolCapacityBytesOverride
override =
  TxMeasure blk
capacity
 where
  oneUnit :: TxMeasure blk
oneUnit =
    LedgerConfig blk -> TickedLedgerState blk mk -> TxMeasure blk
forall blk (mk :: MapKind).
TxLimits blk =>
LedgerConfig blk -> TickedLedgerState blk mk -> TxMeasure blk
forall (mk :: MapKind).
LedgerConfig blk -> TickedLedgerState blk mk -> TxMeasure blk
blockCapacityTxMeasure LedgerConfig blk
cfg TickedLedgerState blk mk
st
      TxMeasure blk -> TxMeasure blk -> TxMeasure blk
forall a. Measure a => a -> a -> a
`Measure.plus` Proxy blk -> TxEbMeasure blk -> TxMeasure blk
forall blk (proxy :: * -> *).
TxLimits blk =>
proxy blk -> TxEbMeasure blk -> TxMeasure blk
forall (proxy :: * -> *).
proxy blk -> TxEbMeasure blk -> TxMeasure blk
mempoolEbReservation (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) (LedgerConfig blk -> TickedLedgerState blk mk -> TxEbMeasure blk
forall blk (mk :: MapKind).
TxLimits blk =>
LedgerConfig blk -> TickedLedgerState blk mk -> TxEbMeasure blk
forall (mk :: MapKind).
LedgerConfig blk -> TickedLedgerState blk mk -> TxEbMeasure blk
ebCapacityTxMeasure LedgerConfig blk
cfg TickedLedgerState blk mk
st)
  ByteSize32 Word32
oneUnitBytes = TxMeasure blk -> ByteSize32
forall a. HasByteSize a => a -> ByteSize32
txMeasureByteSize TxMeasure blk
oneUnit

  unitCount :: Word32
unitCount = case MempoolCapacityBytesOverride
override of
    MempoolCapacityBytesOverride
NoMempoolCapacityBytesOverride -> Word32
2
    MempoolCapacityBytesOverride (ByteSize32 Word32
x) ->
      -- This calculation is happening at Word32. If it was to overflow, it
      -- will round down instead.
      Word32 -> Word32 -> Word32
forall a. Ord a => a -> a -> a
max Word32
1 (Word32 -> Word32) -> Word32 -> Word32
forall a b. (a -> b) -> a -> b
$
        if Word32
x Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
oneUnitBytes Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< Word32
x
          then Word32
x Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`div` Word32
oneUnitBytes
          else (Word32
x Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
oneUnitBytes Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
1) Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`div` Word32
oneUnitBytes

  SemigroupViaMeasure TxMeasure blk
capacity =
    Word32
-> SemigroupViaMeasure (TxMeasure blk)
-> SemigroupViaMeasure (TxMeasure blk)
forall b.
Integral b =>
b
-> SemigroupViaMeasure (TxMeasure blk)
-> SemigroupViaMeasure (TxMeasure blk)
forall a b. (Semigroup a, Integral b) => b -> a -> a
stimes Word32
unitCount (TxMeasure blk -> SemigroupViaMeasure (TxMeasure blk)
forall a. a -> SemigroupViaMeasure a
SemigroupViaMeasure TxMeasure blk
oneUnit)

newtype SemigroupViaMeasure a = SemigroupViaMeasure a
  deriving newtype (SemigroupViaMeasure a -> SemigroupViaMeasure a -> Bool
(SemigroupViaMeasure a -> SemigroupViaMeasure a -> Bool)
-> (SemigroupViaMeasure a -> SemigroupViaMeasure a -> Bool)
-> Eq (SemigroupViaMeasure a)
forall a.
Eq a =>
SemigroupViaMeasure a -> SemigroupViaMeasure a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a.
Eq a =>
SemigroupViaMeasure a -> SemigroupViaMeasure a -> Bool
== :: SemigroupViaMeasure a -> SemigroupViaMeasure a -> Bool
$c/= :: forall a.
Eq a =>
SemigroupViaMeasure a -> SemigroupViaMeasure a -> Bool
/= :: SemigroupViaMeasure a -> SemigroupViaMeasure a -> Bool
Eq, Eq (SemigroupViaMeasure a)
SemigroupViaMeasure a
Eq (SemigroupViaMeasure a) =>
SemigroupViaMeasure a
-> (SemigroupViaMeasure a
    -> SemigroupViaMeasure a -> SemigroupViaMeasure a)
-> (SemigroupViaMeasure a
    -> SemigroupViaMeasure a -> SemigroupViaMeasure a)
-> (SemigroupViaMeasure a
    -> SemigroupViaMeasure a -> SemigroupViaMeasure a)
-> Measure (SemigroupViaMeasure a)
SemigroupViaMeasure a
-> SemigroupViaMeasure a -> SemigroupViaMeasure a
forall a.
Eq a =>
a -> (a -> a -> a) -> (a -> a -> a) -> (a -> a -> a) -> Measure a
forall a. Measure a => Eq (SemigroupViaMeasure a)
forall a. Measure a => SemigroupViaMeasure a
forall a.
Measure a =>
SemigroupViaMeasure a
-> SemigroupViaMeasure a -> SemigroupViaMeasure a
$czero :: forall a. Measure a => SemigroupViaMeasure a
zero :: SemigroupViaMeasure a
$cplus :: forall a.
Measure a =>
SemigroupViaMeasure a
-> SemigroupViaMeasure a -> SemigroupViaMeasure a
plus :: SemigroupViaMeasure a
-> SemigroupViaMeasure a -> SemigroupViaMeasure a
$cmin :: forall a.
Measure a =>
SemigroupViaMeasure a
-> SemigroupViaMeasure a -> SemigroupViaMeasure a
min :: SemigroupViaMeasure a
-> SemigroupViaMeasure a -> SemigroupViaMeasure a
$cmax :: forall a.
Measure a =>
SemigroupViaMeasure a
-> SemigroupViaMeasure a -> SemigroupViaMeasure a
max :: SemigroupViaMeasure a
-> SemigroupViaMeasure a -> SemigroupViaMeasure a
Measure)
  deriving NonEmpty (SemigroupViaMeasure a) -> SemigroupViaMeasure a
SemigroupViaMeasure a
-> SemigroupViaMeasure a -> SemigroupViaMeasure a
(SemigroupViaMeasure a
 -> SemigroupViaMeasure a -> SemigroupViaMeasure a)
-> (NonEmpty (SemigroupViaMeasure a) -> SemigroupViaMeasure a)
-> (forall b.
    Integral b =>
    b -> SemigroupViaMeasure a -> SemigroupViaMeasure a)
-> Semigroup (SemigroupViaMeasure a)
forall b.
Integral b =>
b -> SemigroupViaMeasure a -> SemigroupViaMeasure a
forall a.
Measure a =>
NonEmpty (SemigroupViaMeasure a) -> SemigroupViaMeasure a
forall a.
Measure a =>
SemigroupViaMeasure a
-> SemigroupViaMeasure a -> SemigroupViaMeasure a
forall a b.
(Measure a, Integral b) =>
b -> SemigroupViaMeasure a -> SemigroupViaMeasure a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: forall a.
Measure a =>
SemigroupViaMeasure a
-> SemigroupViaMeasure a -> SemigroupViaMeasure a
<> :: SemigroupViaMeasure a
-> SemigroupViaMeasure a -> SemigroupViaMeasure a
$csconcat :: forall a.
Measure a =>
NonEmpty (SemigroupViaMeasure a) -> SemigroupViaMeasure a
sconcat :: NonEmpty (SemigroupViaMeasure a) -> SemigroupViaMeasure a
$cstimes :: forall a b.
(Measure a, Integral b) =>
b -> SemigroupViaMeasure a -> SemigroupViaMeasure a
stimes :: forall b.
Integral b =>
b -> SemigroupViaMeasure a -> SemigroupViaMeasure a
Semigroup via (InstantiatedAt Measure (SemigroupViaMeasure a))

{-------------------------------------------------------------------------------
  Mempool size
-------------------------------------------------------------------------------}

-- | The size of a mempool.
data MempoolSize = MempoolSize
  { MempoolSize -> Word32
msNumTxs :: !Word32
  -- ^ The number of transactions in the mempool.
  , MempoolSize -> ByteSize32
msNumBytes :: !ByteSize32
  -- ^ The summed byte size of all the transactions in the mempool.
  }
  deriving (MempoolSize -> MempoolSize -> Bool
(MempoolSize -> MempoolSize -> Bool)
-> (MempoolSize -> MempoolSize -> Bool) -> Eq MempoolSize
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MempoolSize -> MempoolSize -> Bool
== :: MempoolSize -> MempoolSize -> Bool
$c/= :: MempoolSize -> MempoolSize -> Bool
/= :: MempoolSize -> MempoolSize -> Bool
Eq, Int -> MempoolSize -> ShowS
[MempoolSize] -> ShowS
MempoolSize -> String
(Int -> MempoolSize -> ShowS)
-> (MempoolSize -> String)
-> ([MempoolSize] -> ShowS)
-> Show MempoolSize
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MempoolSize -> ShowS
showsPrec :: Int -> MempoolSize -> ShowS
$cshow :: MempoolSize -> String
show :: MempoolSize -> String
$cshowList :: [MempoolSize] -> ShowS
showList :: [MempoolSize] -> ShowS
Show, (forall x. MempoolSize -> Rep MempoolSize x)
-> (forall x. Rep MempoolSize x -> MempoolSize)
-> Generic MempoolSize
forall x. Rep MempoolSize x -> MempoolSize
forall x. MempoolSize -> Rep MempoolSize x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. MempoolSize -> Rep MempoolSize x
from :: forall x. MempoolSize -> Rep MempoolSize x
$cto :: forall x. Rep MempoolSize x -> MempoolSize
to :: forall x. Rep MempoolSize x -> MempoolSize
Generic, Context -> MempoolSize -> IO (Maybe ThunkInfo)
Proxy MempoolSize -> String
(Context -> MempoolSize -> IO (Maybe ThunkInfo))
-> (Context -> MempoolSize -> IO (Maybe ThunkInfo))
-> (Proxy MempoolSize -> String)
-> NoThunks MempoolSize
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> MempoolSize -> IO (Maybe ThunkInfo)
noThunks :: Context -> MempoolSize -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> MempoolSize -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> MempoolSize -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy MempoolSize -> String
showTypeOf :: Proxy MempoolSize -> String
NoThunks)

instance Semigroup MempoolSize where
  MempoolSize Word32
xt ByteSize32
xb <> :: MempoolSize -> MempoolSize -> MempoolSize
<> MempoolSize Word32
yt ByteSize32
yb = Word32 -> ByteSize32 -> MempoolSize
MempoolSize (Word32
xt Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
yt) (ByteSize32
xb ByteSize32 -> ByteSize32 -> ByteSize32
forall a. Semigroup a => a -> a -> a
<> ByteSize32
yb)

instance Monoid MempoolSize where
  mempty :: MempoolSize
mempty = MempoolSize{msNumTxs :: Word32
msNumTxs = Word32
0, msNumBytes :: ByteSize32
msNumBytes = Word32 -> ByteSize32
ByteSize32 Word32
0}
  mappend :: MempoolSize -> MempoolSize -> MempoolSize
mappend = MempoolSize -> MempoolSize -> MempoolSize
forall a. Semigroup a => a -> a -> a
(<>)