feat(P7): IHF Phase 7 complete — advanced observability and operational integration

T01 schema: friction_scores, bottleneck_records, hub_health_snapshots, cross_hub_propagations + migration 1743552000. T02 Widget Pain Heatmap: computeFrictionScore (formula documented), RecomputeFriction action, colour-coded grid view (green/yellow/amber/red). T03 Workflow Bottleneck Analysis: detectBottlenecks across 4 pipeline stages (candidate 30d, requirement 60d, decision 30d, observation 14d), idempotent, severity from age ratio, resolve action. T04 Hub Health Correlation: computeHubHealth (deduction table documented), append-only HubHealthSnapshot, health history view, badge on hub Show page. T05 Cross-Hub Propagation: annotation_cluster + widget_type_friction heuristics, idempotent detection, acknowledge/resolve lifecycle. T06 Operational Review Board: 4-panel AutoRefresh global dashboard — health matrix, top-10 friction, bottleneck stage counts, open propagations. T07 gate: 5 describe blocks in Test/Integration.hs; SCOPE.md updated Phase 7 complete; docs/phase7-summary.md written. Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
2026-03-29 21:49:22 +00:00
parent c0b4b984b0
commit 98fb159582
22 changed files with 1638 additions and 262 deletions
--- a/Application/Helper/BottleneckDetector.hs
+++ b/Application/Helper/BottleneckDetector.hs
@@ -0,0 +1,101 @@
+module Application.Helper.BottleneckDetector where
+
+import IHP.Prelude
+import IHP.ModelSupport
+import Generated.Types
+import Data.Time.Clock (addUTCTime, getCurrentTime, NominalDiffTime)
+
+-- | 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
+            , c.id `notElem` map coerce 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
+            , r.id `notElem` map coerce 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
+            , d.id `notElem` map coerce 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)
+            , dep.id `notElem` map coerce 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   (coerce subjId)
+                |> set #stalledSince stalledSince
+                |> set #severity    severity
+                |> createRecord
+
+    r1 <- mapM (\(c, t) -> mkBottleneck "candidate"   "RequirementCandidate" c.id t candidateThreshold)   staleCandidates
+    r2 <- mapM (\(r, t) -> mkBottleneck "requirement" "Requirement"          r.id t requirementThreshold)  stalRequirements
+    r3 <- mapM (\(d, t) -> mkBottleneck "decision"    "DecisionRecord"       d.id t decisionThreshold)     staleDecisions
+    r4 <- mapM (\(d, t) -> mkBottleneck "observation" "DeploymentRecord"     d.id t observationThreshold)  staleDeployments
+
+    pure (r1 <> r2 <> r3 <> r4)
+
+diffUTCTime :: UTCTime -> UTCTime -> NominalDiffTime
+diffUTCTime a b = realToFrac (a `Data.Time.Clock.diffUTCTime` b)