feat(P7): IHF Phase 7 complete — advanced observability and operational integration
Some checks failed
Test / test (push) Has been cancelled

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>
This commit is contained in:
2026-03-29 21:49:22 +00:00
parent c0b4b984b0
commit 98fb159582
22 changed files with 1638 additions and 262 deletions

View File

@@ -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)

View File

@@ -0,0 +1,78 @@
module Application.Helper.CrossHubPropagation where
import IHP.Prelude
import IHP.ModelSupport
import Generated.Types
import Data.Time.Clock (addUTCTime, getCurrentTime)
import Data.Aeson (toJSON)
import qualified Data.List as List
-- | Detect cross-hub propagation patterns and insert CrossHubPropagation rows.
-- Idempotent: skips patterns for which an open/acknowledged record already exists.
detectPropagations
:: (?modelContext :: ModelContext)
=> [Hub]
-> [Annotation] -- all annotations across all hubs, widget already resolved
-> [Widget] -- all widgets (to map widgetId → hubId)
-> [FrictionScore] -- all friction scores
-> IO [CrossHubPropagation]
detectPropagations hubs annotations widgets frictionScores = do
now <- getCurrentTime
let fourteenDaysAgo = addUTCTime (negate $ 14 * 86400) now
existing <- query @CrossHubPropagation
|> filterWhereSql (#status, "IN ('open','acknowledged')")
|> fetch
-- Helper: find hub for a widget
let widgetHub wid = (.hubId) <$> find (\w -> w.id == wid) widgets
-- Heuristic 1: annotation category clustering
-- For each category, count distinct hubs with ≥3 annotations in last 14 days
let recentAnnotations = filter (\a -> a.createdAt >= fourteenDaysAgo) annotations
categories = List.nub (map (.category) recentAnnotations)
clusterPropagations = do
cat <- categories
let catAnnots = filter (\a -> a.category == cat) recentAnnotations
hubCounts = map (\hid -> (hid, length (filter (\a -> widgetHub a.widgetId == Just hid) catAnnots)))
(List.nub (mapMaybe (\a -> widgetHub a.widgetId) catAnnots))
qualHubs = [ hid | (hid, cnt) <- hubCounts, cnt >= 3 ]
guard (length qualHubs >= 2)
let srcHub = head qualHubs
summary = "Annotation category '" <> cat <> "' concentrated in "
<> show (length qualHubs) <> " hubs"
-- Skip if open/acknowledged record already exists with same summary
guard (not (any (\p -> p.patternType == "annotation_cluster" && p.summary == summary) existing))
pure (srcHub, qualHubs, "annotation_cluster", summary)
-- Heuristic 2: widget type friction across hubs
let widgetTypes = List.nub (map (.widgetType) widgets)
frictionThreshold = 40 :: Int
frictionPropagations = do
wtype <- widgetTypes
let typeWidgets = filter (\w -> w.widgetType == wtype) widgets
hubsWithHighFriction =
List.nub
[ w.hubId
| w <- typeWidgets
, Just fs <- [find (\f -> f.widgetId == w.id) frictionScores]
, fs.score >= frictionThreshold
]
guard (length hubsWithHighFriction >= 2)
let srcHub = head hubsWithHighFriction
summary = "Widget type '" <> wtype <> "' has high friction in "
<> show (length hubsWithHighFriction) <> " hubs"
guard (not (any (\p -> p.patternType == "widget_type_friction" && p.summary == summary) existing))
pure (srcHub, hubsWithHighFriction, "widget_type_friction", summary)
let allPatterns = clusterPropagations <> frictionPropagations
mapM (\(srcHubId, affectedHubIds, ptype, summary) ->
newRecord @CrossHubPropagation
|> set #patternType ptype
|> set #sourceHubId (Just srcHubId)
|> set #affectedHubIds (toJSON (map show affectedHubIds))
|> set #summary summary
|> set #status "open"
|> createRecord
) allPatterns

View File

@@ -0,0 +1,64 @@
module Application.Helper.FrictionScore where
import IHP.Prelude
import IHP.ModelSupport
import Generated.Types
import Data.Time.Clock (addUTCTime, getCurrentTime)
-- | 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"

View File

@@ -0,0 +1,74 @@
module Application.Helper.HubHealth where
import IHP.Prelude
import IHP.ModelSupport
import Generated.Types
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"

View File

@@ -0,0 +1,64 @@
-- IHF Phase 7 — Advanced Observability and Operational Integration
-- Workplan: IHUB-WP-0007
CREATE TABLE friction_scores (
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
widget_id UUID NOT NULL REFERENCES widgets(id),
score INTEGER NOT NULL DEFAULT 0,
annotation_count INTEGER NOT NULL DEFAULT 0,
error_event_count INTEGER NOT NULL DEFAULT 0,
regression_flag BOOLEAN NOT NULL DEFAULT FALSE,
stale_candidate_count INTEGER NOT NULL DEFAULT 0,
last_computed_at TIMESTAMP WITH TIME ZONE DEFAULT now() NOT NULL,
UNIQUE (widget_id)
);
CREATE INDEX friction_scores_widget_id_idx ON friction_scores (widget_id);
CREATE INDEX friction_scores_score_idx ON friction_scores (score DESC);
CREATE TABLE bottleneck_records (
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
hub_id UUID NOT NULL REFERENCES hubs(id),
stage TEXT NOT NULL,
subject_type TEXT NOT NULL,
subject_id UUID NOT NULL,
stalled_since TIMESTAMP WITH TIME ZONE NOT NULL,
severity TEXT NOT NULL DEFAULT 'medium',
resolved_at TIMESTAMP WITH TIME ZONE,
notes TEXT,
created_at TIMESTAMP WITH TIME ZONE DEFAULT now() NOT NULL
);
CREATE INDEX bottleneck_records_hub_id_idx ON bottleneck_records (hub_id);
CREATE INDEX bottleneck_records_stage_idx ON bottleneck_records (stage);
CREATE INDEX bottleneck_records_resolved_idx ON bottleneck_records (resolved_at)
WHERE resolved_at IS NULL;
CREATE TABLE hub_health_snapshots (
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
hub_id UUID NOT NULL REFERENCES hubs(id),
health_score INTEGER NOT NULL,
open_candidates INTEGER NOT NULL DEFAULT 0,
regressed_widgets INTEGER NOT NULL DEFAULT 0,
stale_decisions INTEGER NOT NULL DEFAULT 0,
active_bottlenecks INTEGER NOT NULL DEFAULT 0,
computed_at TIMESTAMP WITH TIME ZONE DEFAULT now() NOT NULL
);
CREATE INDEX hub_health_snapshots_hub_id_idx ON hub_health_snapshots (hub_id);
CREATE INDEX hub_health_snapshots_computed_at_idx
ON hub_health_snapshots (hub_id, computed_at DESC);
CREATE TABLE cross_hub_propagations (
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
pattern_type TEXT NOT NULL,
source_hub_id UUID REFERENCES hubs(id),
affected_hub_ids JSONB NOT NULL DEFAULT '[]',
summary TEXT NOT NULL,
detected_at TIMESTAMP WITH TIME ZONE DEFAULT now() NOT NULL,
status TEXT NOT NULL DEFAULT 'open',
notes TEXT
);
CREATE INDEX cross_hub_propagations_status_idx ON cross_hub_propagations (status);
CREATE INDEX cross_hub_propagations_pattern_idx ON cross_hub_propagations (pattern_type);

View File

@@ -379,3 +379,71 @@ CREATE INDEX widgets_adapter_spec_id_idx ON widgets (adapter_spec_id);
-- Per-hub API key for bearer-token auth on the interaction reporting endpoint.
ALTER TABLE hubs
ADD COLUMN api_key TEXT;
-- Phase 7: Advanced Observability and Operational Integration
-- Aggregated pain score per widget, recomputed on demand or scheduled.
CREATE TABLE friction_scores (
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
widget_id UUID NOT NULL REFERENCES widgets(id),
score INTEGER NOT NULL DEFAULT 0,
annotation_count INTEGER NOT NULL DEFAULT 0,
error_event_count INTEGER NOT NULL DEFAULT 0,
regression_flag BOOLEAN NOT NULL DEFAULT FALSE,
stale_candidate_count INTEGER NOT NULL DEFAULT 0,
last_computed_at TIMESTAMP WITH TIME ZONE DEFAULT now() NOT NULL,
UNIQUE (widget_id)
);
CREATE INDEX friction_scores_widget_id_idx ON friction_scores (widget_id);
CREATE INDEX friction_scores_score_idx ON friction_scores (score DESC);
-- Detected stalls at specific pipeline stages.
CREATE TABLE bottleneck_records (
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
hub_id UUID NOT NULL REFERENCES hubs(id),
stage TEXT NOT NULL,
subject_type TEXT NOT NULL,
subject_id UUID NOT NULL,
stalled_since TIMESTAMP WITH TIME ZONE NOT NULL,
severity TEXT NOT NULL DEFAULT 'medium',
resolved_at TIMESTAMP WITH TIME ZONE,
notes TEXT,
created_at TIMESTAMP WITH TIME ZONE DEFAULT now() NOT NULL
);
CREATE INDEX bottleneck_records_hub_id_idx ON bottleneck_records (hub_id);
CREATE INDEX bottleneck_records_stage_idx ON bottleneck_records (stage);
CREATE INDEX bottleneck_records_resolved_idx ON bottleneck_records (resolved_at)
WHERE resolved_at IS NULL;
-- Periodic health snapshots for trend tracking.
CREATE TABLE hub_health_snapshots (
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
hub_id UUID NOT NULL REFERENCES hubs(id),
health_score INTEGER NOT NULL,
open_candidates INTEGER NOT NULL DEFAULT 0,
regressed_widgets INTEGER NOT NULL DEFAULT 0,
stale_decisions INTEGER NOT NULL DEFAULT 0,
active_bottlenecks INTEGER NOT NULL DEFAULT 0,
computed_at TIMESTAMP WITH TIME ZONE DEFAULT now() NOT NULL
);
CREATE INDEX hub_health_snapshots_hub_id_idx ON hub_health_snapshots (hub_id);
CREATE INDEX hub_health_snapshots_computed_at_idx
ON hub_health_snapshots (hub_id, computed_at DESC);
-- Patterns detected across multiple hubs.
CREATE TABLE cross_hub_propagations (
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
pattern_type TEXT NOT NULL,
source_hub_id UUID REFERENCES hubs(id),
affected_hub_ids JSONB NOT NULL DEFAULT '[]',
summary TEXT NOT NULL,
detected_at TIMESTAMP WITH TIME ZONE DEFAULT now() NOT NULL,
status TEXT NOT NULL DEFAULT 'open',
notes TEXT
);
CREATE INDEX cross_hub_propagations_status_idx ON cross_hub_propagations (status);
CREATE INDEX cross_hub_propagations_pattern_idx ON cross_hub_propagations (pattern_type);