-- SPDX-FileCopyrightText: 2026 Alexandra de Wit
--
-- SPDX-License-Identifier: MIT

{- | The request capacity a maintenance store runs under: the pool a backend declares, what one
cycle spent against it, and the gate each request passes through.
"Ecluse.Core.Registry.Sweep.Pacing" decides the rate. Nothing here decides one.
-}
module Ecluse.Core.Registry.Maintenance.Budget (
    -- * What a backend declares
    QuotaScope,
    mkQuotaScope,
    renderQuotaScope,
    QuotaDimension (..),
    parseQuotaDimension,
    QuotaOrigin (..),
    StoreBudget (..),
    undeclaredBudget,
    budgetDeclared,
    narrowestBudget,
    smallestQuota,
    renderStoreBudget,
    renderRates,
    toHundredths,

    -- * What a cycle spends
    RequestKind (..),
    requestKinds,
    parseRequestKind,
    RequestTally,
    oneRequest,
    tallyCounts,
    renderRequestTally,

    -- * The rate one scope runs at
    CyclePace,
    paceOf,

    -- * The gate and the meter behind it
    RequestGate (..),
    CycleCost (..),
    BudgetPort (..),
    newBudgetMeter,
) where

import Data.Map.Strict qualified as Map
import Data.Text qualified as T
import Data.Time (NominalDiffTime)

import Ecluse.Core.Clock (MonoTime, monoSecondsBetween, monotonicNow)
import Ecluse.Core.Registry.Maintenance.Budget.Internal (
    CyclePace,
    QuotaDimension (..),
    RequestKind (..),
    freePace,
    paceOf,
    paceSeconds,
    quotaDimensionName,
    quotaDimensions,
    requestKindName,
    requestKinds,
 )

-- | The capacity pool a store's requests debit, which several stores can share.
newtype QuotaScope = QuotaScope Text
    deriving stock (QuotaScope -> QuotaScope -> Bool
(QuotaScope -> QuotaScope -> Bool)
-> (QuotaScope -> QuotaScope -> Bool) -> Eq QuotaScope
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: QuotaScope -> QuotaScope -> Bool
== :: QuotaScope -> QuotaScope -> Bool
$c/= :: QuotaScope -> QuotaScope -> Bool
/= :: QuotaScope -> QuotaScope -> Bool
Eq, Eq QuotaScope
Eq QuotaScope =>
(QuotaScope -> QuotaScope -> Ordering)
-> (QuotaScope -> QuotaScope -> Bool)
-> (QuotaScope -> QuotaScope -> Bool)
-> (QuotaScope -> QuotaScope -> Bool)
-> (QuotaScope -> QuotaScope -> Bool)
-> (QuotaScope -> QuotaScope -> QuotaScope)
-> (QuotaScope -> QuotaScope -> QuotaScope)
-> Ord QuotaScope
QuotaScope -> QuotaScope -> Bool
QuotaScope -> QuotaScope -> Ordering
QuotaScope -> QuotaScope -> QuotaScope
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
$ccompare :: QuotaScope -> QuotaScope -> Ordering
compare :: QuotaScope -> QuotaScope -> Ordering
$c< :: QuotaScope -> QuotaScope -> Bool
< :: QuotaScope -> QuotaScope -> Bool
$c<= :: QuotaScope -> QuotaScope -> Bool
<= :: QuotaScope -> QuotaScope -> Bool
$c> :: QuotaScope -> QuotaScope -> Bool
> :: QuotaScope -> QuotaScope -> Bool
$c>= :: QuotaScope -> QuotaScope -> Bool
>= :: QuotaScope -> QuotaScope -> Bool
$cmax :: QuotaScope -> QuotaScope -> QuotaScope
max :: QuotaScope -> QuotaScope -> QuotaScope
$cmin :: QuotaScope -> QuotaScope -> QuotaScope
min :: QuotaScope -> QuotaScope -> QuotaScope
Ord, Int -> QuotaScope -> ShowS
[QuotaScope] -> ShowS
QuotaScope -> String
(Int -> QuotaScope -> ShowS)
-> (QuotaScope -> String)
-> ([QuotaScope] -> ShowS)
-> Show QuotaScope
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QuotaScope -> ShowS
showsPrec :: Int -> QuotaScope -> ShowS
$cshow :: QuotaScope -> String
show :: QuotaScope -> String
$cshowList :: [QuotaScope] -> ShowS
showList :: [QuotaScope] -> ShowS
Show)

-- | Build a scope, folding case and surrounding space so two spellings of one pool are one pool.
mkQuotaScope :: Text -> QuotaScope
mkQuotaScope :: Text -> QuotaScope
mkQuotaScope = Text -> QuotaScope
QuotaScope (Text -> QuotaScope) -> (Text -> Text) -> Text -> QuotaScope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip

-- | The scope as an audit line names it.
renderQuotaScope :: QuotaScope -> Text
renderQuotaScope :: QuotaScope -> Text
renderQuotaScope (QuotaScope Text
raw) = Text
raw

-- | Read a configured dimension, refusing a spelling this build meters nothing under.
parseQuotaDimension :: Text -> Maybe QuotaDimension
parseQuotaDimension :: Text -> Maybe QuotaDimension
parseQuotaDimension Text
raw = (QuotaDimension -> Bool)
-> [QuotaDimension] -> Maybe QuotaDimension
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
raw) (Text -> Bool)
-> (QuotaDimension -> Text) -> QuotaDimension -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QuotaDimension -> Text
quotaDimensionName) [QuotaDimension]
quotaDimensions

-- | Where a scope's quota numbers came from, which the boot line reports.
data QuotaOrigin
    = -- | The backend's published defaults, which no call discovered.
      QuotaDocumented
    | -- | The operator declared them, for a backend that publishes none.
      QuotaDeclared
    | -- | Derived from the sweep's own package pace, for a backend that publishes none.
      QuotaDerived
    | -- | Neither, as the backend leaf hands the budget over before the boot resolves it.
      QuotaUndeclared
    deriving stock (QuotaOrigin -> QuotaOrigin -> Bool
(QuotaOrigin -> QuotaOrigin -> Bool)
-> (QuotaOrigin -> QuotaOrigin -> Bool) -> Eq QuotaOrigin
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: QuotaOrigin -> QuotaOrigin -> Bool
== :: QuotaOrigin -> QuotaOrigin -> Bool
$c/= :: QuotaOrigin -> QuotaOrigin -> Bool
/= :: QuotaOrigin -> QuotaOrigin -> Bool
Eq, Int -> QuotaOrigin -> ShowS
[QuotaOrigin] -> ShowS
QuotaOrigin -> String
(Int -> QuotaOrigin -> ShowS)
-> (QuotaOrigin -> String)
-> ([QuotaOrigin] -> ShowS)
-> Show QuotaOrigin
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QuotaOrigin -> ShowS
showsPrec :: Int -> QuotaOrigin -> ShowS
$cshow :: QuotaOrigin -> String
show :: QuotaOrigin -> String
$cshowList :: [QuotaOrigin] -> ShowS
showList :: [QuotaOrigin] -> ShowS
Show)

-- | One store's capacity: the pool it shares, its per-second quotas, and what each request costs.
data StoreBudget = StoreBudget
    { StoreBudget -> QuotaScope
bgScope :: QuotaScope
    , StoreBudget -> Map QuotaDimension Rational
bgQuotas :: Map QuotaDimension Rational
    -- ^ Requests per second the pool admits, per dimension. Empty where none is declared.
    , StoreBudget -> QuotaOrigin
bgOrigin :: QuotaOrigin
    , StoreBudget -> Map RequestKind (Map QuotaDimension Rational)
bgCosts :: Map RequestKind (Map QuotaDimension Rational)
    -- ^ What one request of each kind debits. A kind absent here debits nothing.
    }
    deriving stock (StoreBudget -> StoreBudget -> Bool
(StoreBudget -> StoreBudget -> Bool)
-> (StoreBudget -> StoreBudget -> Bool) -> Eq StoreBudget
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StoreBudget -> StoreBudget -> Bool
== :: StoreBudget -> StoreBudget -> Bool
$c/= :: StoreBudget -> StoreBudget -> Bool
/= :: StoreBudget -> StoreBudget -> Bool
Eq, Int -> StoreBudget -> ShowS
[StoreBudget] -> ShowS
StoreBudget -> String
(Int -> StoreBudget -> ShowS)
-> (StoreBudget -> String)
-> ([StoreBudget] -> ShowS)
-> Show StoreBudget
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StoreBudget -> ShowS
showsPrec :: Int -> StoreBudget -> ShowS
$cshow :: StoreBudget -> String
show :: StoreBudget -> String
$cshowList :: [StoreBudget] -> ShowS
showList :: [StoreBudget] -> ShowS
Show)

{- | A store whose backend publishes no capacity and whose operator declared none. Its cycles are
paced by the sweep's own pauses alone.
-}
undeclaredBudget :: StoreBudget
undeclaredBudget :: StoreBudget
undeclaredBudget =
    StoreBudget
        { bgScope :: QuotaScope
bgScope = Text -> QuotaScope
mkQuotaScope Text
""
        , bgQuotas :: Map QuotaDimension Rational
bgQuotas = Map QuotaDimension Rational
forall k a. Map k a
Map.empty
        , bgOrigin :: QuotaOrigin
bgOrigin = QuotaOrigin
QuotaUndeclared
        , bgCosts :: Map RequestKind (Map QuotaDimension Rational)
bgCosts = Map RequestKind (Map QuotaDimension Rational)
forall k a. Map k a
Map.empty
        }

-- | Whether anything bounds this store's request rate.
budgetDeclared :: StoreBudget -> Bool
budgetDeclared :: StoreBudget -> Bool
budgetDeclared = Bool -> Bool
not (Bool -> Bool) -> (StoreBudget -> Bool) -> StoreBudget -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map QuotaDimension Rational -> Bool
forall k a. Map k a -> Bool
Map.null (Map QuotaDimension Rational -> Bool)
-> (StoreBudget -> Map QuotaDimension Rational)
-> StoreBudget
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StoreBudget -> Map QuotaDimension Rational
bgQuotas

{- | Combine two descriptions of one pool: the tightest quota per dimension and the dearest cost
per request kind, so two stores sharing a pool are paced by the narrower of what each claims.
-}
narrowestBudget :: StoreBudget -> StoreBudget -> StoreBudget
narrowestBudget :: StoreBudget -> StoreBudget -> StoreBudget
narrowestBudget StoreBudget
left StoreBudget
right =
    StoreBudget
left
        { bgQuotas = Map.unionWith min (bgQuotas left) (bgQuotas right)
        , bgCosts = Map.unionWith (Map.unionWith max) (bgCosts left) (bgCosts right)
        , bgOrigin = if originRank (bgOrigin left) >= originRank (bgOrigin right) then bgOrigin left else bgOrigin right
        }

-- How well a description accounts for a pool, so the better-founded of two labels the line.
originRank :: QuotaOrigin -> Int
originRank :: QuotaOrigin -> Int
originRank = \case
    QuotaOrigin
QuotaDeclared -> Int
3
    QuotaOrigin
QuotaDocumented -> Int
2
    QuotaOrigin
QuotaDerived -> Int
1
    QuotaOrigin
QuotaUndeclared -> Int
0

-- | The tightest quota in the pool, which the default budget fraction is derived from.
smallestQuota :: StoreBudget -> Maybe Rational
smallestQuota :: StoreBudget -> Maybe Rational
smallestQuota = (Rational -> Maybe Rational -> Maybe Rational)
-> Maybe Rational -> [Rational] -> Maybe Rational
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Rational
rate Maybe Rational
held -> Rational -> Maybe Rational
forall a. a -> Maybe a
Just (Rational -> (Rational -> Rational) -> Maybe Rational -> Rational
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Rational
rate (Rational -> Rational -> Rational
forall a. Ord a => a -> a -> a
min Rational
rate) Maybe Rational
held)) Maybe Rational
forall a. Maybe a
Nothing ([Rational] -> Maybe Rational)
-> (StoreBudget -> [Rational]) -> StoreBudget -> Maybe Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map QuotaDimension Rational -> [Rational]
forall k a. Map k a -> [a]
Map.elems (Map QuotaDimension Rational -> [Rational])
-> (StoreBudget -> Map QuotaDimension Rational)
-> StoreBudget
-> [Rational]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StoreBudget -> Map QuotaDimension Rational
bgQuotas

-- | The resolved capacity as the boot line records it, naming where each number came from.
renderStoreBudget :: StoreBudget -> Text
renderStoreBudget :: StoreBudget -> Text
renderStoreBudget StoreBudget
budget = Text
origin Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
quotas Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
  where
    origin :: Text
origin = case StoreBudget -> QuotaOrigin
bgOrigin StoreBudget
budget of
        QuotaOrigin
QuotaDocumented -> Text
"the backend's documented quotas"
        QuotaOrigin
QuotaDeclared -> Text
"the capacity you declared"
        QuotaOrigin
QuotaDerived -> Text
"capacity derived from the sweep's own package pace"
        QuotaOrigin
QuotaUndeclared -> Text
"no capacity at all"
    quotas :: Text
quotas
        | Map QuotaDimension Rational -> Bool
forall k a. Map k a -> Bool
Map.null (StoreBudget -> Map QuotaDimension Rational
bgQuotas StoreBudget
budget) = Text
"none"
        | Bool
otherwise = Map QuotaDimension Rational -> Text
renderRates (StoreBudget -> Map QuotaDimension Rational
bgQuotas StoreBudget
budget)

-- | Read a configured request kind, refusing a spelling no cycle makes.
parseRequestKind :: Text -> Maybe RequestKind
parseRequestKind :: Text -> Maybe RequestKind
parseRequestKind Text
raw = (RequestKind -> Bool) -> [RequestKind] -> Maybe RequestKind
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
raw) (Text -> Bool) -> (RequestKind -> Text) -> RequestKind -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestKind -> Text
requestKindName) [RequestKind]
requestKinds

-- | What one cycle attempted, counted per request kind.
newtype RequestTally = RequestTally (Map RequestKind Int)
    deriving stock (RequestTally -> RequestTally -> Bool
(RequestTally -> RequestTally -> Bool)
-> (RequestTally -> RequestTally -> Bool) -> Eq RequestTally
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RequestTally -> RequestTally -> Bool
== :: RequestTally -> RequestTally -> Bool
$c/= :: RequestTally -> RequestTally -> Bool
/= :: RequestTally -> RequestTally -> Bool
Eq, Int -> RequestTally -> ShowS
[RequestTally] -> ShowS
RequestTally -> String
(Int -> RequestTally -> ShowS)
-> (RequestTally -> String)
-> ([RequestTally] -> ShowS)
-> Show RequestTally
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RequestTally -> ShowS
showsPrec :: Int -> RequestTally -> ShowS
$cshow :: RequestTally -> String
show :: RequestTally -> String
$cshowList :: [RequestTally] -> ShowS
showList :: [RequestTally] -> ShowS
Show)

instance Semigroup RequestTally where
    RequestTally Map RequestKind Int
left <> :: RequestTally -> RequestTally -> RequestTally
<> RequestTally Map RequestKind Int
right = Map RequestKind Int -> RequestTally
RequestTally ((Int -> Int -> Int)
-> Map RequestKind Int
-> Map RequestKind Int
-> Map RequestKind Int
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Map RequestKind Int
left Map RequestKind Int
right)

instance Monoid RequestTally where
    mempty :: RequestTally
mempty = Map RequestKind Int -> RequestTally
RequestTally Map RequestKind Int
forall k a. Map k a
Map.empty

-- | The tally of a single attempt.
oneRequest :: RequestKind -> RequestTally
oneRequest :: RequestKind -> RequestTally
oneRequest RequestKind
kind = Map RequestKind Int -> RequestTally
RequestTally (RequestKind -> Int -> Map RequestKind Int
forall k a. k -> a -> Map k a
Map.singleton RequestKind
kind Int
1)

-- | Every kind the tally counted, beside its count.
tallyCounts :: RequestTally -> [(RequestKind, Int)]
tallyCounts :: RequestTally -> [(RequestKind, Int)]
tallyCounts (RequestTally Map RequestKind Int
counts) = Map RequestKind Int -> [(RequestKind, Int)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map RequestKind Int
counts

-- | The counts as an audit line reads them.
renderRequestTally :: RequestTally -> Text
renderRequestTally :: RequestTally -> Text
renderRequestTally RequestTally
tally
    | [(RequestKind, Int)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(RequestKind, Int)]
counted = Text
"no requests"
    | Bool
otherwise = Text -> [Text] -> Text
T.intercalate Text
", " [RequestKind -> Text
requestKindName RequestKind
kind Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
n | (RequestKind
kind, Int
n) <- [(RequestKind, Int)]
counted]
  where
    counted :: [(RequestKind, Int)]
counted = ((RequestKind, Int) -> Bool)
-> [(RequestKind, Int)] -> [(RequestKind, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Int -> Bool)
-> ((RequestKind, Int) -> Int) -> (RequestKind, Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RequestKind, Int) -> Int
forall a b. (a, b) -> b
snd) (RequestTally -> [(RequestKind, Int)]
tallyCounts RequestTally
tally)

-- | The gate one store's requests pass through: it counts each one and waits its scope's pace.
newtype RequestGate = RequestGate
    { RequestGate -> RequestKind -> IO ()
gateSpend :: RequestKind -> IO ()
    }

-- | What one cycle cost: each scope's own attempts, and the time it spent outside budget waits.
data CycleCost = CycleCost
    { CycleCost -> Map QuotaScope RequestTally
ccRequests :: Map QuotaScope RequestTally
    , CycleCost -> Rational
ccWorkSeconds :: Rational
    }
    deriving stock (CycleCost -> CycleCost -> Bool
(CycleCost -> CycleCost -> Bool)
-> (CycleCost -> CycleCost -> Bool) -> Eq CycleCost
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CycleCost -> CycleCost -> Bool
== :: CycleCost -> CycleCost -> Bool
$c/= :: CycleCost -> CycleCost -> Bool
/= :: CycleCost -> CycleCost -> Bool
Eq, Int -> CycleCost -> ShowS
[CycleCost] -> ShowS
CycleCost -> String
(Int -> CycleCost -> ShowS)
-> (CycleCost -> String)
-> ([CycleCost] -> ShowS)
-> Show CycleCost
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CycleCost -> ShowS
showsPrec :: Int -> CycleCost -> ShowS
$cshow :: CycleCost -> String
show :: CycleCost -> String
$cshowList :: [CycleCost] -> ShowS
showList :: [CycleCost] -> ShowS
Show)

{- | The cycle's own end of the budget: it opens a measurement, reads what the cycle cost, and
installs the rate the next cycle's requests wait at.
-}
data BudgetPort = BudgetPort
    { BudgetPort -> IO ()
budgetOpen :: IO ()
    , BudgetPort -> IO CycleCost
budgetClose :: IO CycleCost
    , BudgetPort -> Map QuotaScope CyclePace -> IO ()
budgetPaced :: Map QuotaScope CyclePace -> IO ()
    }

-- The cells one cycle's measurement runs over, shared by the port and every scope's gate.
data BudgetMeter = BudgetMeter
    { BudgetMeter -> IORef (Map QuotaScope RequestTally)
bmTallies :: IORef (Map QuotaScope RequestTally)
    , BudgetMeter -> IORef Rational
bmWaited :: IORef Rational
    , BudgetMeter -> IORef (Map QuotaScope CyclePace)
bmPaces :: IORef (Map QuotaScope CyclePace)
    , BudgetMeter -> IORef MonoTime
bmOpened :: IORef MonoTime
    }

{- | One meter shared by every store a cycle touches, beside the gate each scope's requests pass
through. The wait is injected, so a spec reads the pacing without serving it.
-}
newBudgetMeter :: (NominalDiffTime -> IO ()) -> IO (BudgetPort, QuotaScope -> RequestGate)
newBudgetMeter :: (NominalDiffTime -> IO ())
-> IO (BudgetPort, QuotaScope -> RequestGate)
newBudgetMeter NominalDiffTime -> IO ()
wait = do
    meter <-
        IORef (Map QuotaScope RequestTally)
-> IORef Rational
-> IORef (Map QuotaScope CyclePace)
-> IORef MonoTime
-> BudgetMeter
BudgetMeter
            (IORef (Map QuotaScope RequestTally)
 -> IORef Rational
 -> IORef (Map QuotaScope CyclePace)
 -> IORef MonoTime
 -> BudgetMeter)
-> IO (IORef (Map QuotaScope RequestTally))
-> IO
     (IORef Rational
      -> IORef (Map QuotaScope CyclePace)
      -> IORef MonoTime
      -> BudgetMeter)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map QuotaScope RequestTally
-> IO (IORef (Map QuotaScope RequestTally))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Map QuotaScope RequestTally
forall k a. Map k a
Map.empty
            IO
  (IORef Rational
   -> IORef (Map QuotaScope CyclePace)
   -> IORef MonoTime
   -> BudgetMeter)
-> IO (IORef Rational)
-> IO
     (IORef (Map QuotaScope CyclePace) -> IORef MonoTime -> BudgetMeter)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rational -> IO (IORef Rational)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Rational
0
            IO
  (IORef (Map QuotaScope CyclePace) -> IORef MonoTime -> BudgetMeter)
-> IO (IORef (Map QuotaScope CyclePace))
-> IO (IORef MonoTime -> BudgetMeter)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map QuotaScope CyclePace -> IO (IORef (Map QuotaScope CyclePace))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Map QuotaScope CyclePace
forall k a. Map k a
Map.empty
            IO (IORef MonoTime -> BudgetMeter)
-> IO (IORef MonoTime) -> IO BudgetMeter
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (MonoTime -> IO (IORef MonoTime)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef (MonoTime -> IO (IORef MonoTime))
-> IO MonoTime -> IO (IORef MonoTime)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO MonoTime
monotonicNow)
    pure (meterPort meter, meterGate wait meter)

meterPort :: BudgetMeter -> BudgetPort
meterPort :: BudgetMeter -> BudgetPort
meterPort BudgetMeter
meter =
    BudgetPort
        { budgetOpen :: IO ()
budgetOpen = do
            IORef (Map QuotaScope RequestTally)
-> Map QuotaScope RequestTally -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef (BudgetMeter -> IORef (Map QuotaScope RequestTally)
bmTallies BudgetMeter
meter) Map QuotaScope RequestTally
forall k a. Map k a
Map.empty
            IORef Rational -> Rational -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef (BudgetMeter -> IORef Rational
bmWaited BudgetMeter
meter) Rational
0
            IO MonoTime
monotonicNow IO MonoTime -> (MonoTime -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IORef MonoTime -> MonoTime -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef (BudgetMeter -> IORef MonoTime
bmOpened BudgetMeter
meter)
        , budgetClose :: IO CycleCost
budgetClose = do
            elapsed <- MonoTime -> MonoTime -> Double
monoSecondsBetween (MonoTime -> MonoTime -> Double)
-> IO MonoTime -> IO (MonoTime -> Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef MonoTime -> IO MonoTime
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef (BudgetMeter -> IORef MonoTime
bmOpened BudgetMeter
meter) IO (MonoTime -> Double) -> IO MonoTime -> IO Double
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO MonoTime
monotonicNow
            spent <- readIORef (bmWaited meter)
            counted <- readIORef (bmTallies meter)
            pure CycleCost{ccRequests = counted, ccWorkSeconds = max 0 (toRational elapsed - spent)}
        , budgetPaced :: Map QuotaScope CyclePace -> IO ()
budgetPaced = IORef (Map QuotaScope CyclePace)
-> Map QuotaScope CyclePace -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef (BudgetMeter -> IORef (Map QuotaScope CyclePace)
bmPaces BudgetMeter
meter)
        }

meterGate :: (NominalDiffTime -> IO ()) -> BudgetMeter -> QuotaScope -> RequestGate
meterGate :: (NominalDiffTime -> IO ())
-> BudgetMeter -> QuotaScope -> RequestGate
meterGate NominalDiffTime -> IO ()
wait BudgetMeter
meter QuotaScope
scope =
    RequestGate
        { gateSpend :: RequestKind -> IO ()
gateSpend = \RequestKind
kind -> do
            IORef (Map QuotaScope RequestTally)
-> (Map QuotaScope RequestTally
    -> (Map QuotaScope RequestTally, ()))
-> IO ()
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' (BudgetMeter -> IORef (Map QuotaScope RequestTally)
bmTallies BudgetMeter
meter) (\Map QuotaScope RequestTally
held -> ((RequestTally -> RequestTally -> RequestTally)
-> QuotaScope
-> RequestTally
-> Map QuotaScope RequestTally
-> Map QuotaScope RequestTally
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith RequestTally -> RequestTally -> RequestTally
forall a. Semigroup a => a -> a -> a
(<>) QuotaScope
scope (RequestKind -> RequestTally
oneRequest RequestKind
kind) Map QuotaScope RequestTally
held, ()))
            pace <- CyclePace -> QuotaScope -> Map QuotaScope CyclePace -> CyclePace
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault CyclePace
freePace QuotaScope
scope (Map QuotaScope CyclePace -> CyclePace)
-> IO (Map QuotaScope CyclePace) -> IO CyclePace
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map QuotaScope CyclePace) -> IO (Map QuotaScope CyclePace)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef (BudgetMeter -> IORef (Map QuotaScope CyclePace)
bmPaces BudgetMeter
meter)
            let seconds = CyclePace -> RequestKind -> NominalDiffTime
paceSeconds CyclePace
pace RequestKind
kind
            when (seconds > 0) (waitCharged wait meter seconds)
        }

-- The wait served, not the wait asked for, so the work time it comes out of stays right
-- however the injected wait behaves.
waitCharged :: (NominalDiffTime -> IO ()) -> BudgetMeter -> NominalDiffTime -> IO ()
waitCharged :: (NominalDiffTime -> IO ())
-> BudgetMeter -> NominalDiffTime -> IO ()
waitCharged NominalDiffTime -> IO ()
wait BudgetMeter
meter NominalDiffTime
seconds = do
    before <- IO MonoTime
monotonicNow
    wait seconds
    served <- monoSecondsBetween before <$> monotonicNow
    atomicModifyIORef' (bmWaited meter) (\Rational
held -> (Rational
held Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Double -> Rational
forall a. Real a => a -> Rational
toRational (Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
0 Double
served), ()))

{- | Every dimension's rate as a boot or audit line spells them, in dimension order. An empty map
renders as the empty string, so a caller with a "none" to say says it itself.
-}
renderRates :: Map QuotaDimension Rational -> Text
renderRates :: Map QuotaDimension Rational -> Text
renderRates Map QuotaDimension Rational
rates =
    Text -> [Text] -> Text
T.intercalate Text
", " [QuotaDimension -> Text
quotaDimensionName QuotaDimension
dimension Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Rational -> Text
renderRate Rational
rate | (QuotaDimension
dimension, Rational
rate) <- Map QuotaDimension Rational -> [(QuotaDimension, Rational)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map QuotaDimension Rational
rates]

-- A rate as a boot or audit line spells it.
renderRate :: Rational -> Text
renderRate :: Rational -> Text
renderRate Rational
rate = Double -> Text
forall b a. (Show a, IsString b) => a -> b
show (Rational -> Double
toHundredths Rational
rate) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/s"

{- | A rational as a line spells it, rounded to whole hundredths. A budget fraction and a rate are
both reported this way, so a line never carries an unbounded expansion.
-}
toHundredths :: Rational -> Double
toHundredths :: Rational -> Double
toHundredths Rational
value = Integer -> Double
forall a. Num a => Integer -> a
fromInteger (Rational -> Integer
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Rational
value Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
100)) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
100