{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

-- | 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           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
  = NoMempoolCapacityBytesOverride
    -- ^ Use 2x the maximum transaction capacity of a block. This will change
    -- dynamically with the protocol parameters adopted in the current ledger.
  | MempoolCapacityBytesOverride !ByteSize32
    -- ^ Use the least multiple of the block capacity that is no less than this
    -- size.
  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
-- the current ledger's maximum transaction capacity of a block.
--
-- If an override is present, reinterpret it as a number of blocks (rounded
-- up), and then simply multiply the ledger's capacity by that number.
computeMempoolCapacity ::
     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
    oneBlock :: TxMeasure blk
oneBlock                 = 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
    ByteSize32 Word32
oneBlockBytes = TxMeasure blk -> ByteSize32
forall a. HasByteSize a => a -> ByteSize32
txMeasureByteSize TxMeasure blk
oneBlock

    blockCount :: Word32
blockCount = 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
oneBlockBytes 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
oneBlockBytes
                else (Word32
x Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
oneBlockBytes Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
1) Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`div` Word32
oneBlockBytes

    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
blockCount (TxMeasure blk -> SemigroupViaMeasure (TxMeasure blk)
forall a. a -> SemigroupViaMeasure a
SemigroupViaMeasure TxMeasure blk
oneBlock)

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
(<>)