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

{- | The one refusal: an explicit override that breaks the plan. A pinned bound never sheds,
so it answers for its own bytes. The plan re-derives the override-free minimum, with every
pin substituted out and every computed tenant at the floor the shed ladder reaches, and
refuses just when that minimum fits the ceiling while the pinned plan does not. It names the
pins whose individual removal would fit, or all of them when only their combination
overshoots. A pod too small even without the pins degrades through
"Ecluse.Composition.MemoryPlan.Shed" like any other.
-}
module Ecluse.Composition.MemoryPlan.Override (
    -- * The pin set
    noOverridePins,
    configuredPins,

    -- * The substitution arithmetic
    overrideMinShedSum,
    overrideSubstitutions,
    overrideFreeOvershoot,

    -- * The refusal
    overrideViolationsFor,
    attributeOverrideViolations,
) where

import Data.Text qualified as T

import Ecluse.Composition.MemoryPlan.Bounds (mirrorArtifactEnvelopeMultiplier, queueDepthFloor)
import Ecluse.Composition.MemoryPlan.Internal (
    OverridePins (..),
    PlanInputs (piCache, piExplicitAdmission, piLimits, piQueue),
    ShedOutcomes (soResidualOvershoot),
    TenantDemands (..),
 )
import Ecluse.Config (CacheSettings (csMaxBytes), LimitsSettings (limMaxArtifactBytes, limMaxRequestBytes, limMaxResponseBytes), QueueSettings (qsMaxMemoryDepth))
import Ecluse.Core.Server.MemoryModel (mirrorJobEstimatedBytes)

-- | Every override substituted out: the pin set the override-free minimum resolves from.
noOverridePins :: OverridePins
noOverridePins :: OverridePins
noOverridePins =
    OverridePins
        { opCache :: Maybe Int
opCache = Maybe Int
forall a. Maybe a
Nothing
        , opAdmission :: Maybe Int
opAdmission = Maybe Int
forall a. Maybe a
Nothing
        , opResponse :: Maybe Int
opResponse = Maybe Int
forall a. Maybe a
Nothing
        , opRequest :: Maybe Int
opRequest = Maybe Int
forall a. Maybe a
Nothing
        , opDepth :: Maybe Int
opDepth = Maybe Int
forall a. Maybe a
Nothing
        , opArtifact :: Maybe Int
opArtifact = Maybe Int
forall a. Maybe a
Nothing
        }

-- | The pin set the operator's configuration actually carries.
configuredPins :: PlanInputs -> OverridePins
configuredPins :: PlanInputs -> OverridePins
configuredPins PlanInputs
inputs =
    OverridePins
        { opCache :: Maybe Int
opCache = CacheSettings -> Maybe Int
csMaxBytes (PlanInputs -> CacheSettings
piCache PlanInputs
inputs)
        , opAdmission :: Maybe Int
opAdmission = PlanInputs -> Maybe Int
piExplicitAdmission PlanInputs
inputs
        , opResponse :: Maybe Int
opResponse = LimitsSettings -> Maybe Int
limMaxResponseBytes LimitsSettings
limits
        , opRequest :: Maybe Int
opRequest = LimitsSettings -> Maybe Int
limMaxRequestBytes LimitsSettings
limits
        , opDepth :: Maybe Int
opDepth = QueueSettings -> Maybe Int
qsMaxMemoryDepth (PlanInputs -> QueueSettings
piQueue PlanInputs
inputs)
        , opArtifact :: Maybe Int
opArtifact = LimitsSettings -> Maybe Int
limMaxArtifactBytes LimitsSettings
limits
        }
  where
    limits :: LimitsSettings
limits = PlanInputs -> LimitsSettings
piLimits PlanInputs
inputs

{- | The fully-shed minimum tenant sum for a pin set. Each unpinned tenant contributes
the floor the shed ladder reaches. Comparing pin sets attributes an overshoot to its pins.
-}
overrideMinShedSum :: TenantDemands -> OverridePins -> Int
overrideMinShedSum :: TenantDemands -> OverridePins -> Int
overrideMinShedSum TenantDemands
d OverridePins
pins =
    TenantDemands -> Int
tdReserve TenantDemands
d
        Int -> Int -> Int
forall a. Num a => a -> a -> a
+ TenantDemands -> Int
tdFixedBuffers TenantDemands
d
        Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (OverridePins -> Maybe Int
opCache OverridePins
pins)
        Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (if TenantDemands -> Bool
tdPublishConfigured TenantDemands
d then Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (TenantDemands -> Int
tdRequestComputed TenantDemands
d) (OverridePins -> Maybe Int
opRequest OverridePins
pins) else Int
0)
        Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (if TenantDemands -> Bool
tdMemoryBacked TenantDemands
d then Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
queueDepthFloor (OverridePins -> Maybe Int
opDepth OverridePins
pins) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
mirrorJobEstimatedBytes else Int
0)
        Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (if TenantDemands -> Bool
tdMirrors TenantDemands
d then Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
mirrorArtifactEnvelopeMultiplier) (OverridePins -> Maybe Int
opArtifact OverridePins
pins) else Int
0)

{- | Each explicit override present in the pin set, paired with the pin set that
substitutes only it out, and with the operator's config-key name.
-}
overrideSubstitutions :: OverridePins -> [(Text, OverridePins)]
overrideSubstitutions :: OverridePins -> [(Text, OverridePins)]
overrideSubstitutions OverridePins
pins =
    [Maybe (Text, OverridePins)] -> [(Text, OverridePins)]
forall a. [Maybe a] -> [a]
catMaybes
        [ (Text
"cache.maxBytes", OverridePins
pins{opCache = Nothing}) (Text, OverridePins) -> Maybe Int -> Maybe (Text, OverridePins)
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ OverridePins -> Maybe Int
opCache OverridePins
pins
        , (Text
"limits.maxRequestBytes", OverridePins
pins{opRequest = Nothing}) (Text, OverridePins) -> Maybe Int -> Maybe (Text, OverridePins)
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ OverridePins -> Maybe Int
opRequest OverridePins
pins
        , (Text
"queue.maxMemoryDepth", OverridePins
pins{opDepth = Nothing}) (Text, OverridePins) -> Maybe Int -> Maybe (Text, OverridePins)
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ OverridePins -> Maybe Int
opDepth OverridePins
pins
        , (Text
"limits.maxArtifactBytes", OverridePins
pins{opArtifact = Nothing}) (Text, OverridePins) -> Maybe Int -> Maybe (Text, OverridePins)
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ OverridePins -> Maybe Int
opArtifact OverridePins
pins
        ]

-- How far a pin set's fully-shed minimum overshoots the ceiling.
overshootFor :: TenantDemands -> OverridePins -> Int
overshootFor :: TenantDemands -> OverridePins -> Int
overshootFor TenantDemands
d OverridePins
pins = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (TenantDemands -> OverridePins -> Int
overrideMinShedSum TenantDemands
d OverridePins
pins Int -> Int -> Int
forall a. Num a => a -> a -> a
- TenantDemands -> Int
tdCeiling TenantDemands
d)

{- | The overshoot with every pin substituted out. Above zero, the pod is too small
whatever the operator configured, so no pin is to blame.
-}
overrideFreeOvershoot :: TenantDemands -> Int
overrideFreeOvershoot :: TenantDemands -> Int
overrideFreeOvershoot TenantDemands
d = TenantDemands -> OverridePins -> Int
overshootFor TenantDemands
d OverridePins
noOverridePins

-- | The plan's own refusal decision, over its resolved demands and shed outcomes.
overrideViolationsFor :: TenantDemands -> ShedOutcomes -> [Text]
overrideViolationsFor :: TenantDemands -> ShedOutcomes -> [Text]
overrideViolationsFor TenantDemands
d ShedOutcomes
o =
    Int -> Int -> Int -> [(Text, Int)] -> [Text]
attributeOverrideViolations
        (TenantDemands -> Int
tdCeiling TenantDemands
d)
        (ShedOutcomes -> Int
soResidualOvershoot ShedOutcomes
o)
        (TenantDemands -> Int
overrideFreeOvershoot TenantDemands
d)
        [(Text
name, TenantDemands -> OverridePins -> Int
overshootFor TenantDemands
d OverridePins
pins) | (Text
name, OverridePins
pins) <- OverridePins -> [(Text, OverridePins)]
overrideSubstitutions (TenantDemands -> OverridePins
tdPins TenantDemands
d)]

{- | Decide the override refusal and name the culprits. A pod too small even without the
pins degrades instead of refusing. When no single pin flips the verdict, name them all.
-}
attributeOverrideViolations :: Int -> Int -> Int -> [(Text, Int)] -> [Text]
attributeOverrideViolations :: Int -> Int -> Int -> [(Text, Int)] -> [Text]
attributeOverrideViolations Int
heapCeiling Int
overriddenOvershoot Int
freeOvershoot [(Text, Int)]
perOverrideOvershoot
    | Int
overriddenOvershoot Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
freeOvershoot Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 =
        [ Text
"explicit override(s) "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
culprits
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" push the combined memory plan "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
overriddenOvershoot
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" bytes past the effective heap ceiling "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
heapCeiling
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"; the override-free minimum fits within it, so lower them or raise the ceiling"
        ]
    | Bool
otherwise = []
  where
    culprits :: [Text]
culprits = case [Text
name | (Text
name, Int
o) <- [(Text, Int)]
perOverrideOvershoot, Int
o Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0] of
        [] -> ((Text, Int) -> Text) -> [(Text, Int)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Int) -> Text
forall a b. (a, b) -> a
fst [(Text, Int)]
perOverrideOvershoot
        [Text]
flips -> [Text]
flips