Files
inter-hub/Web/Controller/Hubs.hs
Bernd Worsch ae81dfd484 feat(P6/T07): adapter compatibility validation dashboard (AutoRefresh)
AdapterCompatibilityDashboardAction added to HubsController (AutoRefresh).
Five panels: adapter summary KPIs (active/draft/deprecated), widget coverage
bar (adapter-backed vs native IHP, breakdown per spec), active contracts in use,
unassigned widgets, active adapter spec table with widget counts. Linked from
hub Show page and global nav.

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
2026-03-29 21:21:21 +00:00

240 lines
8.8 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 Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
import Application.Helper.Controller (regressedWidgetIds, widgetCycleCounts)
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 }