coulomb/inter-hub
2
0
Fork 0
generated from coulomb/repo-seed
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(P4): IHF Phase 4 complete — Outcome Observation and Antifragility Loop
Some checks failed
Test / test (push) Has been cancelled
Details

Browse Source 
Closes the IHF improvement loop. Full antifragility chain now traversable:
Widget → Annotation → Candidate → Requirement → Decision → Deployment → OutcomeSignal

New artifacts:
- DeploymentRecord (immutable, links DecisionRecord to a deployed version)
- OutcomeSignal (append-only; DB trigger prevents UPDATE/DELETE)
- ChangeEvaluation (one-per-deployment; UNIQUE constraint; 1–5 score)

New capabilities:
- DeploymentRecordsController (index, show, new, create)
- RecordOutcomeSignalAction — capture improved/regressed/neutral/inconclusive signals
- Pre/post comparison panel on deployment show (±30-day event/annotation counts)
- Regression detection — improved signal followed by high/critical annotation
- ChangeEvaluation — idempotent score+rationale per deployment
- Recurrence tracking — cycle count per widget, leaderboard
- AntifragilityDashboardAction (autoRefresh, 5 panels) per hub
- Phase 4 integration tests (T01–T08 logic coverage)
- docs/phase4-summary.md; SCOPE.md updated to Phase 4 complete

State Hub: workstream 07e9c860 → completed

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
Bernd Worsch
2026-03-29 12:27:30 +00:00
parent bc57852473
commit 878d2577ae
22 changed files with 1782 additions and 44 deletions
Download Patch File Download Diff File Expand all files Collapse all files

22
Web/Controller/DecisionRecords.hs
View File

@@ -34,26 +34,36 @@ instance Controller DecisionRecordsController where
render IndexView { records, requirements, users, mOutcomeFilter }
action ShowDecisionRecordAction { decisionRecordId } = do
record <- fetch decisionRecordId
policyRefs <- query @PolicyReference
record <- fetch decisionRecordId
policyRefs <- query @PolicyReference
|> filterWhere (#decisionId, decisionRecordId)
|> orderByAsc #createdAt
|> fetch
implRefs <- query @ImplementationChangeReference
implRefs <- query @ImplementationChangeReference
|> filterWhere (#decisionId, decisionRecordId)
|> orderByAsc #linkedAt
|> fetch
mRequirement <- case record.requirementId of
deploymentRecords <- query @DeploymentRecord
|> filterWhere (#decisionId, decisionRecordId)
|> orderByDesc #deployedAt
|> fetch
let deploymentIds = map (.id) deploymentRecords
evaluations <- query @ChangeEvaluation
|> filterWhereIn (#deploymentId, deploymentIds)
|> fetch
mRequirement <- case record.requirementId of
Nothing -> pure Nothing
Just rid -> fetchOneOrNothing rid
mCandidate <- case record.candidateId of
mCandidate <- case record.candidateId of
Nothing -> pure Nothing
Just cid -> fetchOneOrNothing cid
users <- query @User |> fetch
users <- query @User |> fetch
render ShowView
{ record
, policyRefs
, implRefs
, deploymentRecords
, evaluations
, mRequirement
, mCandidate
, users

180
Web/Controller/DeploymentRecords.hs Normal file
View File

@@ -0,0 +1,180 @@
module Web.Controller.DeploymentRecords where
import Web.Types
import Web.View.DeploymentRecords.Index
import Web.View.DeploymentRecords.Show
import Web.View.DeploymentRecords.New
import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
import Data.Time.Clock (addUTCTime, NominalDiffTime)
import Text.Read (readMaybe)
import Data.String.Conversions (cs)
instance Controller DeploymentRecordsController where
beforeAction = ensureIsUser
action DeploymentRecordsAction = do
records <- query @DeploymentRecord |> orderByDesc #deployedAt |> fetch
decisions <- query @DecisionRecord |> fetch
signals <- query @OutcomeSignal |> fetch
evaluations <- query @ChangeEvaluation |> fetch
render IndexView { records, decisions, signals, evaluations }
action ShowDeploymentRecordAction { deploymentRecordId } = do
record <- fetch deploymentRecordId
decision <- fetch record.decisionId
mImplRef <- case record.implRefId of
Nothing -> pure Nothing
Just rid -> fetchOneOrNothing rid
mRequirement <- case decision.requirementId of
Nothing -> pure Nothing
Just rid -> fetchOneOrNothing rid
mCandidate <- case decision.candidateId of
Nothing -> pure Nothing
Just cid -> fetchOneOrNothing cid
mWidget <- case mCandidate of
Nothing -> pure Nothing
Just c -> fetchOneOrNothing c.sourceWidgetId
signals <- query @OutcomeSignal
|> filterWhere (#deploymentId, deploymentRecordId)
|> orderByDesc #observedAt
|> fetch
mEvaluation <- query @ChangeEvaluation
|> filterWhere (#deploymentId, deploymentRecordId)
|> fetchOneOrNothing
users <- query @User |> fetch
comparison <- computeComparison record.deployedAt mWidget
render ShowView
{ record
, decision
, mImplRef
, mRequirement
, mCandidate
, mWidget
, signals
, mEvaluation
, users
, comparison
}
action NewDeploymentRecordAction = do
decisions <- query @DecisionRecord |> fetch
implRefs <- query @ImplementationChangeReference |> fetch
users <- query @User |> fetch
mDecisionId <- paramOrNothing @(Id DecisionRecord) "decisionId"
let record = newRecord @DeploymentRecord
render NewView { record, decisions, implRefs, users, mDecisionId }
action CreateDeploymentRecordAction = do
decisions <- query @DecisionRecord |> fetch
implRefs <- query @ImplementationChangeReference |> fetch
users <- query @User |> fetch
mUser <- currentUserOrNothing
let deployedBy = fmap (.id) mUser
let record = newRecord @DeploymentRecord
record
|> fill @'["decisionId", "implRefId", "versionRef", "notes"]
|> set #deployedBy (fmap (Id . unId) deployedBy)
|> validateField #versionRef nonEmpty
|> ifValid \case
Left r -> render NewView { record = r, decisions, implRefs, users, mDecisionId = Just r.decisionId }
Right r -> do
created <- createRecord r
setSuccessMessage "Deployment record created"
redirectTo ShowDeploymentRecordAction { deploymentRecordId = created.id }
action RecordOutcomeSignalAction { deploymentRecordId } = do
signalType <- param @Text "signalType"
mValue <- paramOrNothing @Double "value"
mUser <- currentUserOrNothing
let validTypes = ["improved", "regressed", "neutral", "inconclusive"] :: [Text]
unless (signalType `elem` validTypes) do
setErrorMessage ("Invalid signal type: " <> signalType)
redirectTo ShowDeploymentRecordAction { deploymentRecordId }
-- Fetch the deployment to get the widget_id from its decision → candidate chain
deployment <- fetch deploymentRecordId
decision <- fetch deployment.decisionId
mCandidate <- case decision.candidateId of
Nothing -> pure Nothing
Just cid -> fetchOneOrNothing cid
case mCandidate of
Nothing -> do
setErrorMessage "Cannot record signal: no widget linked to this deployment's decision"
redirectTo ShowDeploymentRecordAction { deploymentRecordId }
Just candidate -> do
newRecord @OutcomeSignal
|> set #deploymentId deploymentRecordId
|> set #widgetId candidate.sourceWidgetId
|> set #signalType signalType
|> set #value mValue
|> createRecord
setSuccessMessage ("Outcome signal recorded: " <> signalType)
redirectTo ShowDeploymentRecordAction { deploymentRecordId }
action EvaluateChangeAction { deploymentRecordId } = do
-- Idempotent: if already evaluated, redirect with message
existing <- query @ChangeEvaluation
|> filterWhere (#deploymentId, deploymentRecordId)
|> fetchOneOrNothing
case existing of
Just _ -> do
setErrorMessage "Already evaluated — one evaluation per deployment."
redirectTo ShowDeploymentRecordAction { deploymentRecordId }
Nothing -> do
mUser <- currentUserOrNothing
let evaluatedBy = fmap (.id) mUser
scoreText <- param @Text "score"
rationale <- param @Text "rationale"
let mScore = readMaybe (cs scoreText) :: Maybe Int
case mScore of
Nothing -> do
setErrorMessage "Score must be a number between 1 and 5"
redirectTo ShowDeploymentRecordAction { deploymentRecordId }
Just s | s < 1 || s > 5 -> do
setErrorMessage "Score must be between 1 and 5"
redirectTo ShowDeploymentRecordAction { deploymentRecordId }
Just s -> do
when (rationale == "") do
setErrorMessage "Rationale cannot be empty"
redirectTo ShowDeploymentRecordAction { deploymentRecordId }
deployment <- fetch deploymentRecordId
newRecord @ChangeEvaluation
|> set #deploymentId deploymentRecordId
|> set #decisionId (Just deployment.decisionId)
|> set #score (fromIntegral s)
|> set #rationale rationale
|> set #evaluatedBy (fmap (Id . unId) evaluatedBy)
|> createRecord
setSuccessMessage "Change evaluated"
redirectTo ShowDeploymentRecordAction { deploymentRecordId }
thirtyDays :: NominalDiffTime
thirtyDays = 30 * 24 * 3600
computeComparison :: (?modelContext :: ModelContext) => UTCTime -> Maybe Widget -> IO (Maybe (PeriodMetrics, PeriodMetrics))
computeComparison _ Nothing = pure Nothing
computeComparison deployedAt (Just w) = do
let beforeStart = addUTCTime (negate thirtyDays) deployedAt
afterEnd = addUTCTime thirtyDays deployedAt
allEvents <- query @InteractionEvent |> filterWhere (#widgetId, w.id) |> fetch
allAnnotations <- query @Annotation |> filterWhere (#widgetId, w.id) |> fetch
let inWindow s e t = t >= s && t < e
evBefore = filter (\x -> inWindow beforeStart deployedAt x.occurredAt) allEvents
evAfter = filter (\x -> inWindow deployedAt afterEnd x.occurredAt) allEvents
annBefore = filter (\x -> inWindow beforeStart deployedAt x.createdAt && isNothing x.retractedAt) allAnnotations
annAfter = filter (\x -> inWindow deployedAt afterEnd x.createdAt && isNothing x.retractedAt) allAnnotations
pure $ Just (buildMetrics evBefore annBefore, buildMetrics evAfter annAfter)
buildMetrics :: [InteractionEvent] -> [Annotation] -> PeriodMetrics
buildMetrics events anns = PeriodMetrics
{ eventCount = length events
, annotationCount = length anns
, lowCount = count "low"
, mediumCount = count "medium"
, highCount = count "high"
, criticalCount = count "critical"
}
where
count sev = length (filter (\a -> a.severity == sev) anns)

63
Web/Controller/Hubs.hs
View File

@@ -7,9 +7,11 @@ 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 Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
import Application.Helper.Controller (regressedWidgetIds, widgetCycleCounts)
instance Controller HubsController where
beforeAction = ensureIsUser
@@ -147,6 +149,13 @@ instance Controller HubsController where
|> 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
@@ -155,4 +164,58 @@ instance Controller HubsController where
, 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
}

19
Web/Controller/Widgets.hs
View File

@@ -9,6 +9,7 @@ import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
import Data.Aeson (toJSON, object, (.=))
import Application.Helper.Controller (isInRegression, widgetCycleCounts)
instance Controller WidgetsController where
beforeAction = ensureIsUser
@@ -39,7 +40,23 @@ instance Controller WidgetsController where
|> filterWhere (#widgetId, widgetId)
|> orderByAsc #createdAt
|> fetch
render ShowView { widget, hub, versions, events, annotations }
recentSignals <- query @OutcomeSignal
|> filterWhere (#widgetId, widgetId)
|> orderByDesc #observedAt
|> limit 10
|> fetch
allSignals <- query @OutcomeSignal
|> filterWhere (#widgetId, widgetId)
|> fetch
let isRegressed = isInRegression allSignals annotations widgetId
-- Recurrence cycle count for this widget
allCandidates <- query @RequirementCandidate |> filterWhere (#sourceWidgetId, widgetId) |> fetch
allRequirements <- query @Requirement |> fetch
allDecisions <- query @DecisionRecord |> fetch
allDeployments <- query @DeploymentRecord |> fetch
let cycleCounts = widgetCycleCounts allCandidates allRequirements allDecisions allDeployments
cycleCount = fromMaybe 0 (lookup widgetId cycleCounts)
render ShowView { widget, hub, versions, events, annotations, recentSignals, isRegressed, cycleCount }
action CreateWidgetAction = do
let widget = newRecord @Widget