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

module Application.Helper.BottleneckDetector where

import IHP.Prelude
import IHP.ModelSupport
import IHP.QueryBuilder
import IHP.Fetch
import Generated.Types
import Web.Routes ()
import Data.Time.Clock (addUTCTime, getCurrentTime, NominalDiffTime)
import Database.PostgreSQL.Simple (Only(..))

-- | Severity based on how much older than the threshold the record is.
staleSeverity :: NominalDiffTime -> NominalDiffTime -> Text
staleSeverity age threshold
    | age > threshold * 2   = "critical"
    | age > threshold * 1.5 = "high"
    | otherwise             = "medium"

-- | Detect pipeline bottlenecks for a hub and upsert BottleneckRecord rows.
-- Idempotent: skips subjects that already have an unresolved record.
detectBottlenecks
    :: (?modelContext :: ModelContext)
    => Id Hub
    -> [Widget]
    -> [RequirementCandidate]
    -> [Requirement]
    -> [DecisionRecord]
    -> [DeploymentRecord]
    -> IO [BottleneckRecord]
detectBottlenecks hubId hubWidgets candidates requirements decisions deployments = do
    now <- getCurrentTime
    existing <- query @BottleneckRecord
        |> filterWhere (#hubId, hubId)
        |> filterWhereSql (#resolvedAt, "IS NULL")
        |> fetch
    let existingSubjects = map (.subjectId) existing

    let candidateThreshold = 30 * 86400  :: NominalDiffTime
        requirementThreshold = 60 * 86400 :: NominalDiffTime
        decisionThreshold  = 30 * 86400  :: NominalDiffTime
        observationThreshold = 14 * 86400 :: NominalDiffTime

    -- Stage 1: open candidates older than 30 days
    let staleCandidates =
            [ (c, addUTCTime (negate candidateThreshold) now)
            | c <- candidates
            , c.status == "open"
            , c.createdAt < addUTCTime (negate candidateThreshold) now
            , unpackId c.id `notElem` existingSubjects
            ]

    -- Stage 2: requirements with no decision older than 60 days
    let linkedReqIds = mapMaybe (.requirementId) decisions
        stalRequirements =
            [ (r, addUTCTime (negate requirementThreshold) now)
            | r <- requirements
            , r.createdAt < addUTCTime (negate requirementThreshold) now
            , r.id `notElem` linkedReqIds
            , unpackId r.id `notElem` existingSubjects
            ]

    -- Stage 3: decisions with no deployment older than 30 days
    let linkedDecisionIds = map (.decisionId) deployments
        staleDecisions =
            [ (d, addUTCTime (negate decisionThreshold) now)
            | d <- decisions
            , d.decidedAt < addUTCTime (negate decisionThreshold) now
            , d.id `notElem` linkedDecisionIds
            , unpackId d.id `notElem` existingSubjects
            ]

    -- Stage 4: deployments with no outcome signal older than 14 days
    signalWidgetIds <- sqlQuery
        "SELECT DISTINCT widget_id FROM outcome_signals" ()
    let signalWids = map (\(Only wid) -> wid) (signalWidgetIds :: [Only (Id Widget)])
    let widgetIdSet = map (.id) hubWidgets
    let staleDeployments =
            [ (dep, addUTCTime (negate observationThreshold) now)
            | dep <- deployments
            , dep.deployedAt < addUTCTime (negate observationThreshold) now
            , not (any (\wid -> wid `elem` signalWids) widgetIdSet)
            , unpackId dep.id `notElem` existingSubjects
            ]

    let mkBottleneck stage subjType subjId stalledSince threshold = do
            let age      = now `diffUTCTime` stalledSince
                severity = staleSeverity age threshold
            newRecord @BottleneckRecord
                |> set #hubId       hubId
                |> set #stage       stage
                |> set #subjectType subjType
                |> set #subjectId   subjId
                |> set #stalledSince stalledSince
                |> set #severity    severity
                |> createRecord

    r1 <- mapM (\(c, t) -> mkBottleneck "candidate"   "RequirementCandidate" (unpackId c.id) t candidateThreshold)   staleCandidates
    r2 <- mapM (\(r, t) -> mkBottleneck "requirement" "Requirement"          (unpackId r.id) t requirementThreshold)  stalRequirements
    r3 <- mapM (\(d, t) -> mkBottleneck "decision"    "DecisionRecord"       (unpackId d.id) t decisionThreshold)     staleDecisions
    r4 <- mapM (\(d, t) -> mkBottleneck "observation" "DeploymentRecord"     (unpackId d.id) t observationThreshold)  staleDeployments

    pure (r1 <> r2 <> r3 <> r4)