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

module Application.Helper.FrictionScore where

import IHP.Prelude
import IHP.ModelSupport
import IHP.QueryBuilder
import IHP.Fetch
import Generated.Types
import Web.Routes ()
import Database.PostgreSQL.Simple (Only(..))
import Data.Time.Clock (addUTCTime, getCurrentTime)
import qualified Data.Aeson as A
import qualified Data.Aeson.KeyMap as KM
import qualified Data.Aeson.Key as AK

-- | Friction score formula (documented):
--
--   score = min 100 $
--       annotationCount      * 5
--     + errorEventCount      * 10
--     + (if regressionFlag then 20 else 0)
--     + staleCandidateCount  * 8
--
-- Inputs are computed from the widget's related records.
computeFrictionScore
    :: (?modelContext :: ModelContext)
    => Id Widget
    -> [Annotation]           -- all annotations for this widget
    -> [InteractionEvent]     -- all events for this widget
    -> Bool                   -- True if widget is in regression
    -> [RequirementCandidate] -- all candidates for this widget
    -> IO FrictionScore
computeFrictionScore wid annotations events isRegressed candidates = do
    now <- getCurrentTime
    let thirtyDaysAgo      = addUTCTime (negate $ 30 * 86400) now
        annCount           = length annotations
        errCount           = length (filter (\e -> e.eventType == "errored") events)
        staleCount         = length (filter (\c -> c.status == "open" && c.createdAt < thirtyDaysAgo) candidates)
        rawScore           = annCount * 5 + errCount * 10 + (if isRegressed then 20 else 0) + staleCount * 8
        finalScore         = min 100 rawScore
    -- Upsert: update if row exists, insert otherwise
    existingRows <- sqlQuery
        "SELECT * FROM friction_scores WHERE widget_id = ? LIMIT 1"
        (Only wid)
    case (existingRows :: [FrictionScore]) of
        (existing : _) -> do
            existing
                |> set #score              finalScore
                |> set #annotationCount    annCount
                |> set #errorEventCount    errCount
                |> set #regressionFlag     isRegressed
                |> set #staleCandidateCount staleCount
                |> set #lastComputedAt     now
                |> updateRecord
        [] -> do
            newRecord @FrictionScore
                |> set #widgetId           wid
                |> set #score              finalScore
                |> set #annotationCount    annCount
                |> set #errorEventCount    errCount
                |> set #regressionFlag     isRegressed
                |> set #staleCandidateCount staleCount
                |> set #lastComputedAt     now
                |> createRecord

-- | Score band for Tailwind colour coding.
scoreBand :: Int -> Text
scoreBand s
    | s < 20    = "bg-green-100 text-green-800"
    | s < 40    = "bg-yellow-100 text-yellow-800"
    | s < 60    = "bg-orange-100 text-orange-800"
    | otherwise = "bg-red-100 text-red-800"

-- | Read per-hub AdaptiveThresholdConfig and apply weight_overrides
-- to friction component scores before summing. Falls back to global
-- defaults when no config exists for the hub.
-- weight_overrides keys: "annotation", "error", "regression", "stale"
applyAdaptiveWeights ::
    (?modelContext :: ModelContext) =>
    Id Hub ->
    Int ->  -- annotationCount
    Int ->  -- errorEventCount
    Bool -> -- regressionFlag
    Int ->  -- staleCandidateCount
    IO Int
applyAdaptiveWeights hubId annCount errCount isRegressed staleCount = do
    mConfig <- query @AdaptiveThresholdConfig
        |> filterWhere (#hubId, hubId)
        |> fetchOneOrNothing
    let overrides = maybe (A.object []) (.weightOverrides) mConfig
        w k def   = case overrides of
            A.Object o -> case KM.lookup (AK.fromText k) o of
                Just (A.Number n) -> round (n * fromIntegral def) :: Int
                _                 -> def
            _ -> def
        annW      = w "annotation" 5
        errW      = w "error"      10
        regW      = w "regression" 20
        staleW    = w "stale"      8
        raw       = annCount * annW
                  + errCount * errW
                  + (if isRegressed then regW else 0)
                  + staleCount * staleW
    pure (min 100 raw)