generated from coulomb/repo-seed
Bernd Worsch
98fb159582
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>
361 lines
15 KiB
Haskell
361 lines
15 KiB
Haskell
module Web.Controller.Hubs where
|
|
|
|
import Web.Types
|
|
import Web.View.Hubs.Index
|
|
import Web.View.Hubs.Show
|
|
import Web.View.Hubs.New
|
|
import Web.View.Hubs.Edit
|
|
import Web.View.Hubs.TriageDashboard
|
|
import Web.View.Hubs.GovernanceDashboard
|
|
import Web.View.Hubs.AntifragilityDashboard
|
|
import Web.View.Hubs.AgentAuditDashboard
|
|
import Web.View.Hubs.AdapterCompatibilityDashboard
|
|
import Web.View.Hubs.FrictionHeatmap
|
|
import Web.View.Hubs.BottleneckDashboard
|
|
import Web.View.Hubs.HubHealthHistory
|
|
import Web.View.Hubs.OperationalReviewBoard
|
|
import Generated.Types
|
|
import IHP.Prelude
|
|
import IHP.ControllerPrelude
|
|
import Application.Helper.Controller (regressedWidgetIds, widgetCycleCounts)
|
|
import Application.Helper.FrictionScore (computeFrictionScore)
|
|
import Application.Helper.BottleneckDetector (detectBottlenecks)
|
|
import Application.Helper.HubHealth (computeHubHealth)
|
|
|
|
instance Controller HubsController where
|
|
beforeAction = ensureIsUser
|
|
|
|
action HubsAction = do
|
|
hubs <- query @Hub |> orderByAsc #createdAt |> fetch
|
|
render IndexView { hubs }
|
|
|
|
action NewHubAction = do
|
|
let hub = newRecord @Hub
|
|
render NewView { hub }
|
|
|
|
action ShowHubAction { hubId } = autoRefresh do
|
|
hub <- fetch hubId
|
|
widgets <- query @Widget
|
|
|> filterWhere (#hubId, hubId)
|
|
|> orderByAsc #name
|
|
|> fetch
|
|
widgetIds <- pure (map (.id) widgets)
|
|
recentEvents <- sqlQuery
|
|
"SELECT * FROM interaction_events WHERE widget_id = ANY(?) ORDER BY occurred_at DESC LIMIT 50"
|
|
(Only (PGArray widgetIds))
|
|
recentAnnotations <- sqlQuery
|
|
"SELECT * FROM annotations WHERE widget_id = ANY(?) ORDER BY created_at DESC LIMIT 20"
|
|
(Only (PGArray widgetIds))
|
|
render ShowView { hub, widgets, recentEvents, recentAnnotations }
|
|
|
|
action CreateHubAction = do
|
|
let hub = newRecord @Hub
|
|
hub
|
|
|> fill @'["slug", "name", "domain"]
|
|
|> validateField #slug nonEmpty
|
|
|> validateField #name nonEmpty
|
|
|> validateField #domain nonEmpty
|
|
|> ifValid \case
|
|
Left hub -> render NewView { hub }
|
|
Right hub -> do
|
|
hub <- createRecord hub
|
|
setSuccessMessage "Hub created"
|
|
redirectTo ShowHubAction { hubId = hub.id }
|
|
|
|
action EditHubAction { hubId } = do
|
|
hub <- fetch hubId
|
|
render EditView { hub }
|
|
|
|
action UpdateHubAction { hubId } = do
|
|
hub <- fetch hubId
|
|
hub
|
|
|> fill @'["slug", "name", "domain"]
|
|
|> validateField #slug nonEmpty
|
|
|> validateField #name nonEmpty
|
|
|> validateField #domain nonEmpty
|
|
|> ifValid \case
|
|
Left hub -> render EditView { hub }
|
|
Right hub -> do
|
|
updateRecord hub
|
|
setSuccessMessage "Hub updated"
|
|
redirectTo ShowHubAction { hubId = hub.id }
|
|
|
|
action DeleteHubAction { hubId } = do
|
|
hub <- fetch hubId
|
|
deleteRecord hub
|
|
setSuccessMessage "Hub deleted"
|
|
redirectTo HubsAction
|
|
|
|
action TriageDashboardAction { hubId } = autoRefresh do
|
|
hub <- fetch hubId
|
|
widgets <- query @Widget
|
|
|> filterWhere (#hubId, hubId)
|
|
|> fetch
|
|
let widgetIds = map (.id) widgets
|
|
|
|
-- All candidates for this hub's widgets
|
|
allCandidates <- query @RequirementCandidate
|
|
|> filterWhereIn (#sourceWidgetId, widgetIds)
|
|
|> orderByAsc #createdAt
|
|
|> fetch
|
|
|
|
-- Triage queue: open candidates, oldest first
|
|
let triageQueue = filter (\c -> c.status == "open") allCandidates
|
|
|
|
-- Recent escalations: last 20
|
|
recentEscalations <- query @RequirementCandidate
|
|
|> filterWhereIn (#sourceWidgetId, widgetIds)
|
|
|> orderByDesc #createdAt
|
|
|> limit 20
|
|
|> fetch
|
|
|
|
-- All annotations for category breakdown
|
|
allAnnotations <- query @Annotation
|
|
|> filterWhereIn (#widgetId, widgetIds)
|
|
|> fetch
|
|
|
|
render TriageDashboardView
|
|
{ hub
|
|
, widgets
|
|
, allCandidates
|
|
, triageQueue
|
|
, recentEscalations
|
|
, allAnnotations
|
|
}
|
|
|
|
action GovernanceDashboardAction { hubId } = autoRefresh do
|
|
hub <- fetch hubId
|
|
widgets <- query @Widget
|
|
|> filterWhere (#hubId, hubId)
|
|
|> fetch
|
|
let widgetIds = map (.id) widgets
|
|
|
|
-- All requirements whose source candidate is in this hub's widgets
|
|
allCandidates <- query @RequirementCandidate
|
|
|> filterWhereIn (#sourceWidgetId, widgetIds)
|
|
|> fetch
|
|
let acceptedCandidateIds = map (.id) (filter (\c -> c.status == "accepted") allCandidates)
|
|
|
|
allRequirements <- query @Requirement
|
|
|> filterWhereIn (#sourceCandidateId, acceptedCandidateIds)
|
|
|> fetch
|
|
|
|
-- Recent decisions (last 20) — scoped to this hub's requirements
|
|
let requirementIds = map (.id) allRequirements
|
|
recentDecisions <- query @DecisionRecord
|
|
|> filterWhereIn (#requirementId, map Just requirementIds)
|
|
|> orderByDesc #decidedAt
|
|
|> limit 20
|
|
|> fetch
|
|
|
|
-- All hub decisions (for outcome counts)
|
|
allDecisions <- query @DecisionRecord
|
|
|> filterWhereIn (#requirementId, map Just requirementIds)
|
|
|> fetch
|
|
|
|
-- All annotations for traceability coverage
|
|
allAnnotations <- query @Annotation
|
|
|> filterWhereIn (#widgetId, widgetIds)
|
|
|> fetch
|
|
|
|
-- Outcome signals for regression detection
|
|
allSignals <- query @OutcomeSignal
|
|
|> filterWhereIn (#widgetId, widgetIds)
|
|
|> fetch
|
|
|
|
let regressionWidgetIds = regressedWidgetIds allSignals allAnnotations
|
|
|
|
render GovernanceDashboardView
|
|
{ hub
|
|
, widgets
|
|
, allCandidates
|
|
, allRequirements
|
|
, recentDecisions
|
|
, allDecisions
|
|
, allAnnotations
|
|
, regressionWidgetIds
|
|
}
|
|
|
|
action AntifragilityDashboardAction { hubId } = autoRefresh do
|
|
hub <- fetch hubId
|
|
widgets <- query @Widget
|
|
|> filterWhere (#hubId, hubId)
|
|
|> fetch
|
|
let widgetIds = map (.id) widgets
|
|
|
|
-- Deployments for this hub's decisions
|
|
allCandidates <- query @RequirementCandidate
|
|
|> filterWhereIn (#sourceWidgetId, widgetIds)
|
|
|> fetch
|
|
let acceptedCandidateIds = map (.id) (filter (\c -> c.status == "accepted") allCandidates)
|
|
allRequirements <- query @Requirement
|
|
|> filterWhereIn (#sourceCandidateId, acceptedCandidateIds)
|
|
|> fetch
|
|
let requirementIds = map (.id) allRequirements
|
|
allDecisions <- query @DecisionRecord
|
|
|> filterWhereIn (#requirementId, map Just requirementIds)
|
|
|> fetch
|
|
let decisionIds = map (.id) allDecisions
|
|
allDeployments <- query @DeploymentRecord
|
|
|> filterWhereIn (#decisionId, decisionIds)
|
|
|> orderByDesc #deployedAt
|
|
|> fetch
|
|
let deploymentIds = map (.id) allDeployments
|
|
allSignals <- query @OutcomeSignal
|
|
|> filterWhereIn (#widgetId, widgetIds)
|
|
|> fetch
|
|
allEvaluations <- query @ChangeEvaluation
|
|
|> filterWhereIn (#deploymentId, deploymentIds)
|
|
|> fetch
|
|
allImplRefs <- query @ImplementationChangeReference
|
|
|> filterWhereIn (#decisionId, decisionIds)
|
|
|> fetch
|
|
allAnnotations <- query @Annotation
|
|
|> filterWhereIn (#widgetId, widgetIds)
|
|
|> fetch
|
|
|
|
let regressionWidgetIds = regressedWidgetIds allSignals allAnnotations
|
|
recurrenceLeaderboard = take 10 (widgetCycleCounts allCandidates allRequirements allDecisions allDeployments)
|
|
|
|
render AntifragilityDashboardView
|
|
{ hub
|
|
, widgets
|
|
, allDeployments
|
|
, allDecisions
|
|
, allSignals
|
|
, allEvaluations
|
|
, allImplRefs
|
|
, regressionWidgetIds
|
|
, recurrenceLeaderboard
|
|
}
|
|
action AgentAuditDashboardAction { hubId } = autoRefresh do
|
|
hub <- fetch hubId
|
|
proposals <- query @AgentProposal
|
|
|> orderByDesc #createdAt
|
|
|> fetch
|
|
reviews <- query @AgentReviewRecord |> fetch
|
|
widgets <- query @Widget |> fetch
|
|
render AgentAuditDashboardView { hub, proposals, reviews, widgets }
|
|
|
|
action AdapterCompatibilityDashboardAction { hubId } = autoRefresh do
|
|
hub <- fetch hubId
|
|
specs <- query @WidgetAdapterSpec |> orderByAsc #name |> fetch
|
|
widgets <- query @Widget |> filterWhere (#hubId, hubId) |> fetch
|
|
envelopes <- query @EnvelopeEmissionContract |> filterWhere (#status, "active") |> fetch
|
|
reportings <- query @InteractionReportingContract |> filterWhere (#status, "active") |> fetch
|
|
render AdapterCompatibilityDashboardView { hub, specs, widgets, envelopes, reportings }
|
|
|
|
action FrictionHeatmapAction { hubId } = autoRefresh do
|
|
hub <- fetch hubId
|
|
widgets <- query @Widget |> filterWhere (#hubId, hubId) |> fetch
|
|
let widgetIds = map (.id) widgets
|
|
frictionScores <- query @FrictionScore
|
|
|> filterWhereIn (#widgetId, widgetIds)
|
|
|> fetch
|
|
render FrictionHeatmapView { hub, widgets, frictionScores }
|
|
|
|
action RecomputeFrictionAction { hubId } = do
|
|
hub <- fetch hubId
|
|
widgets <- query @Widget |> filterWhere (#hubId, hubId) |> fetch
|
|
let widgetIds = map (.id) widgets
|
|
annotations <- query @Annotation |> filterWhereIn (#widgetId, widgetIds) |> fetch
|
|
events <- sqlQuery "SELECT * FROM interaction_events WHERE widget_id = ANY(?)"
|
|
(Only (PGArray widgetIds))
|
|
signals <- query @OutcomeSignal |> filterWhereIn (#widgetId, widgetIds) |> fetch
|
|
candidates <- query @RequirementCandidate |> filterWhereIn (#sourceWidgetId, widgetIds) |> fetch
|
|
let regressionWids = regressedWidgetIds signals annotations
|
|
mapM_ (\w ->
|
|
let wAnnotations = filter (\a -> a.widgetId == w.id) annotations
|
|
wEvents = filter (\e -> e.widgetId == w.id) events
|
|
wCandidates = filter (\c -> c.sourceWidgetId == w.id) candidates
|
|
isRegressed = w.id `elem` regressionWids
|
|
in computeFrictionScore w.id wAnnotations wEvents isRegressed wCandidates
|
|
) widgets
|
|
setSuccessMessage "Friction scores recomputed"
|
|
redirectTo FrictionHeatmapAction { hubId }
|
|
|
|
action BottleneckDashboardAction { hubId } = autoRefresh do
|
|
hub <- fetch hubId
|
|
widgets <- query @Widget |> filterWhere (#hubId, hubId) |> fetch
|
|
bottlenecks <- query @BottleneckRecord
|
|
|> filterWhere (#hubId, hubId)
|
|
|> orderByAsc #stalledSince
|
|
|> fetch
|
|
render BottleneckDashboardView { hub, widgets, bottlenecks }
|
|
|
|
action DetectBottlenecksAction { hubId } = do
|
|
hub <- fetch hubId
|
|
widgets <- query @Widget |> filterWhere (#hubId, hubId) |> fetch
|
|
let widgetIds = map (.id) widgets
|
|
candidates <- query @RequirementCandidate |> filterWhereIn (#sourceWidgetId, widgetIds) |> fetch
|
|
let candidateIds = map (.id) candidates
|
|
acceptedIds = map (.id) (filter (\c -> c.status == "accepted") candidates)
|
|
requirements <- query @Requirement |> filterWhereIn (#sourceCandidateId, acceptedIds) |> fetch
|
|
let reqIds = map (.id) requirements
|
|
decisions <- query @DecisionRecord
|
|
|> filterWhereIn (#requirementId, map Just reqIds)
|
|
|> fetch
|
|
let decisionIds = map (.id) decisions
|
|
deployments <- query @DeploymentRecord |> filterWhereIn (#decisionId, decisionIds) |> fetch
|
|
_ <- detectBottlenecks hubId widgets candidates requirements decisions deployments
|
|
setSuccessMessage "Bottleneck detection complete"
|
|
redirectTo BottleneckDashboardAction { hubId }
|
|
|
|
action ResolveBottleneckAction { bottleneckRecordId } = do
|
|
bottleneck <- fetch bottleneckRecordId
|
|
now <- getCurrentTime
|
|
bottleneck |> set #resolvedAt (Just now) |> updateRecord
|
|
setSuccessMessage "Bottleneck resolved"
|
|
redirectTo BottleneckDashboardAction { hubId = bottleneck.hubId }
|
|
|
|
action SnapshotHubHealthAction { hubId } = do
|
|
hub <- fetch hubId
|
|
widgets <- query @Widget |> filterWhere (#hubId, hubId) |> fetch
|
|
let widgetIds = map (.id) widgets
|
|
candidates <- query @RequirementCandidate |> filterWhereIn (#sourceWidgetId, widgetIds) |> fetch
|
|
let acceptedIds = map (.id) (filter (\c -> c.status == "accepted") candidates)
|
|
requirements <- query @Requirement |> filterWhereIn (#sourceCandidateId, acceptedIds) |> fetch
|
|
let reqIds = map (.id) requirements
|
|
decisions <- query @DecisionRecord |> filterWhereIn (#requirementId, map Just reqIds) |> fetch
|
|
let decisionIds = map (.id) decisions
|
|
deployments <- query @DeploymentRecord |> filterWhereIn (#decisionId, decisionIds) |> fetch
|
|
signals <- query @OutcomeSignal |> filterWhereIn (#widgetId, widgetIds) |> fetch
|
|
annotations <- query @Annotation |> filterWhereIn (#widgetId, widgetIds) |> fetch
|
|
bottlenecks <- query @BottleneckRecord
|
|
|> filterWhere (#hubId, hubId)
|
|
|> filterWhereSql (#resolvedAt, "IS NULL")
|
|
|> fetch
|
|
_ <- computeHubHealth hubId widgets candidates decisions deployments signals annotations bottlenecks
|
|
setSuccessMessage "Hub health snapshot taken"
|
|
redirectTo HubHealthHistoryAction { hubId }
|
|
|
|
action HubHealthHistoryAction { hubId } = autoRefresh do
|
|
hub <- fetch hubId
|
|
snapshots <- query @HubHealthSnapshot
|
|
|> filterWhere (#hubId, hubId)
|
|
|> orderByDesc #computedAt
|
|
|> fetch
|
|
render HubHealthHistoryView { hub, snapshots }
|
|
|
|
action OperationalReviewBoardAction = autoRefresh do
|
|
hubs <- query @Hub |> orderByAsc #name |> fetch
|
|
allSnapshots <- query @HubHealthSnapshot |> orderByDesc #computedAt |> fetch
|
|
topFrictionScores <- query @FrictionScore |> orderByDesc #score |> limit 10 |> fetch
|
|
topWidgets <- mapM (\fs -> fetch fs.widgetId) topFrictionScores
|
|
bottlenecks <- query @BottleneckRecord
|
|
|> filterWhereSql (#resolvedAt, "IS NULL")
|
|
|> orderByAsc #stage
|
|
|> fetch
|
|
propagations <- query @CrossHubPropagation
|
|
|> orderByDesc #detectedAt
|
|
|> fetch
|
|
let openPropagations = filter (\p -> p.status `elem` ["open","acknowledged"]) propagations
|
|
render OperationalReviewBoardView
|
|
{ hubs
|
|
, allSnapshots
|
|
, topFrictionScores
|
|
, topWidgets
|
|
, bottlenecks
|
|
, openPropagations
|
|
}
|