inter-hub-haskell/Application/Helper/HubHealth.hs

module Application.Helper.HubHealth where

import IHP.Prelude
import IHP.ModelSupport
import Generated.Types
import Web.Routes ()
import Data.Time.Clock (addUTCTime, getCurrentTime)

-- | Health score deduction table (documented):
--
--   -5  per open RequirementCandidate
--   -10 per regressed widget
--   -8  per stale DecisionRecord (decided > 30 days, no deployment)
--   -12 per active critical BottleneckRecord
--   -6  per active high BottleneckRecord
--   floor at 0, ceiling at 100
--
computeHubHealth
    :: (?modelContext :: ModelContext)
    => Id Hub
    -> [Widget]
    -> [RequirementCandidate]
    -> [DecisionRecord]
    -> [DeploymentRecord]
    -> [OutcomeSignal]
    -> [Annotation]
    -> [BottleneckRecord]
    -> IO HubHealthSnapshot
computeHubHealth hubId widgets candidates decisions deployments signals annotations bottlenecks = do
    now <- getCurrentTime
    let thirtyDaysAgo = addUTCTime (negate $ 30 * 86400) now

        openCandidates   = filter (\c -> c.status == "open") candidates
        regressedWids    = regressedWidgetIds signals annotations
        linkedDecIds     = map (.decisionId) deployments
        staleDecisions'  = filter (\d -> d.decidedAt < thirtyDaysAgo && d.id `notElem` linkedDecIds) decisions
        activeBN         = filter (\b -> isNothing b.resolvedAt) bottlenecks
        criticalBN       = filter (\b -> b.severity == "critical") activeBN
        highBN           = filter (\b -> b.severity == "high") activeBN

        openCount    = length openCandidates
        regCount     = length regressedWids
        staleDecCount = length staleDecisions'
        activeBNCount = length activeBN

        deductions = openCount * 5
                   + regCount * 10
                   + staleDecCount * 8
                   + length criticalBN * 12
                   + length highBN * 6
        score = max 0 (100 - deductions)

    newRecord @HubHealthSnapshot
        |> set #hubId           hubId
        |> set #healthScore     score
        |> set #openCandidates  openCount
        |> set #regressedWidgets regCount
        |> set #staleDecisions  staleDecCount
        |> set #activeBottlenecks activeBNCount
        |> createRecord

-- | Re-export from Application.Helper.Controller to avoid circular imports.
regressedWidgetIds :: [OutcomeSignal] -> [Annotation] -> [Id Widget]
regressedWidgetIds signals annotations =
    let negSignalWids = [ s.widgetId | s <- signals, s.signalType == "negative" ]
        negAnnotWids  = [ a.widgetId | a <- annotations, a.category == "regression" ]
    in nub (negSignalWids <> negAnnotWids)

-- | Colour class for health score badge.
healthScoreBadge :: Int -> Text
healthScoreBadge s
    | s >= 80   = "bg-green-100 text-green-800"
    | s >= 60   = "bg-yellow-100 text-yellow-800"
    | s >= 40   = "bg-orange-100 text-orange-800"
    | otherwise = "bg-red-100 text-red-800"