generated from coulomb/repo-seed
feat(P4): IHF Phase 4 complete — Outcome Observation and Antifragility Loop
Some checks failed
Test / test (push) Has been cancelled
Some checks failed
Test / test (push) Has been cancelled
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:
@@ -7,6 +7,10 @@ import IHP.Log.Types
|
||||
import IHP.ControllerPrelude hiding (query)
|
||||
import System.Environment (lookupEnv)
|
||||
import Generated.Types
|
||||
import Data.Time.Clock (addUTCTime, getCurrentTime)
|
||||
import Application.Helper.Controller (regressedWidgetIds, widgetCycleCounts)
|
||||
import Control.Exception (try, SomeException)
|
||||
import Data.Either (isLeft)
|
||||
|
||||
-- Integration tests run with a temporary PostgreSQL database.
|
||||
-- Run: nix flake check (or `test` inside devenv)
|
||||
@@ -657,3 +661,284 @@ main = do
|
||||
let accepted = filter (\d -> d.outcome == "accepted") decisions
|
||||
length accepted `shouldBe` 1
|
||||
deleteRecord hub
|
||||
|
||||
-- ----------------------------------------------------------------
|
||||
-- Phase 4: DeploymentRecord create + link to decision
|
||||
-- ----------------------------------------------------------------
|
||||
describe "DeploymentRecord" do
|
||||
it "creates a deployment linked to a decision" do
|
||||
hub <- newRecord @Hub
|
||||
|> set #slug "p4-dr-hub" |> set #name "P4 DR" |> set #domain "d"
|
||||
|> createRecord
|
||||
widget <- newRecord @Widget
|
||||
|> set #hubId hub.id |> set #name "DR Widget" |> set #widgetType "form"
|
||||
|> createRecord
|
||||
candidate <- newRecord @RequirementCandidate
|
||||
|> set #title "DR candidate" |> set #description "d"
|
||||
|> set #sourceWidgetId widget.id |> set #category "friction"
|
||||
|> set #status "accepted" |> createRecord
|
||||
dr <- newRecord @DecisionRecord
|
||||
|> set #title "DR decision" |> set #rationale "r"
|
||||
|> set #outcome "accepted" |> set #candidateId (Just candidate.id)
|
||||
|> createRecord
|
||||
deployment <- newRecord @DeploymentRecord
|
||||
|> set #decisionId dr.id
|
||||
|> set #versionRef "v1.0.0"
|
||||
|> createRecord
|
||||
deployment.versionRef `shouldBe` "v1.0.0"
|
||||
deployment.decisionId `shouldBe` dr.id
|
||||
fetched <- fetch deployment.id
|
||||
fetched.versionRef `shouldBe` "v1.0.0"
|
||||
deleteRecord hub
|
||||
|
||||
-- ----------------------------------------------------------------
|
||||
-- Phase 4: OutcomeSignal append-only (DB trigger)
|
||||
-- ----------------------------------------------------------------
|
||||
describe "OutcomeSignal append-only" do
|
||||
it "inserts signal successfully" do
|
||||
hub <- newRecord @Hub
|
||||
|> set #slug "p4-sig-hub" |> set #name "P4 Sig" |> set #domain "d"
|
||||
|> createRecord
|
||||
widget <- newRecord @Widget
|
||||
|> set #hubId hub.id |> set #name "Sig Widget" |> set #widgetType "form"
|
||||
|> createRecord
|
||||
candidate <- newRecord @RequirementCandidate
|
||||
|> set #title "Sig candidate" |> set #description "d"
|
||||
|> set #sourceWidgetId widget.id |> set #category "friction"
|
||||
|> set #status "accepted" |> createRecord
|
||||
decision <- newRecord @DecisionRecord
|
||||
|> set #title "Sig decision" |> set #rationale "r"
|
||||
|> set #outcome "accepted" |> set #candidateId (Just candidate.id)
|
||||
|> createRecord
|
||||
deployment <- newRecord @DeploymentRecord
|
||||
|> set #decisionId decision.id |> set #versionRef "v1.0.0"
|
||||
|> createRecord
|
||||
sig <- newRecord @OutcomeSignal
|
||||
|> set #deploymentId deployment.id
|
||||
|> set #widgetId widget.id
|
||||
|> set #signalType "improved"
|
||||
|> createRecord
|
||||
sig.signalType `shouldBe` "improved"
|
||||
-- DB trigger prevents UPDATE — exception is caught, connection continues
|
||||
result <- try (updateRecord (sig |> set #signalType "regressed") :: IO OutcomeSignal)
|
||||
:: IO (Either SomeException OutcomeSignal)
|
||||
isLeft result `shouldBe` True
|
||||
deleteRecord hub
|
||||
|
||||
it "DB trigger prevents DELETE on outcome_signals" do
|
||||
hub <- newRecord @Hub
|
||||
|> set #slug "p4-sigdel-hub" |> set #name "P4 SigDel" |> set #domain "d"
|
||||
|> createRecord
|
||||
widget <- newRecord @Widget
|
||||
|> set #hubId hub.id |> set #name "SigDel Widget" |> set #widgetType "form"
|
||||
|> createRecord
|
||||
candidate <- newRecord @RequirementCandidate
|
||||
|> set #title "SigDel cand" |> set #description "d"
|
||||
|> set #sourceWidgetId widget.id |> set #category "friction"
|
||||
|> set #status "accepted" |> createRecord
|
||||
decision <- newRecord @DecisionRecord
|
||||
|> set #title "SigDel dec" |> set #rationale "r"
|
||||
|> set #outcome "accepted" |> set #candidateId (Just candidate.id)
|
||||
|> createRecord
|
||||
deployment <- newRecord @DeploymentRecord
|
||||
|> set #decisionId decision.id |> set #versionRef "v1.0.0"
|
||||
|> createRecord
|
||||
sig <- newRecord @OutcomeSignal
|
||||
|> set #deploymentId deployment.id
|
||||
|> set #widgetId widget.id
|
||||
|> set #signalType "neutral"
|
||||
|> createRecord
|
||||
result <- try (deleteRecord sig) :: IO (Either SomeException ())
|
||||
isLeft result `shouldBe` True
|
||||
deleteRecord hub
|
||||
|
||||
-- ----------------------------------------------------------------
|
||||
-- Phase 4: Regression detection
|
||||
-- ----------------------------------------------------------------
|
||||
describe "Regression detection" do
|
||||
it "detects widget in regression (improved signal then high annotation)" do
|
||||
hub <- newRecord @Hub
|
||||
|> set #slug "p4-reg-hub" |> set #name "P4 Reg" |> set #domain "d"
|
||||
|> createRecord
|
||||
widget <- newRecord @Widget
|
||||
|> set #hubId hub.id |> set #name "Reg Widget" |> set #widgetType "form"
|
||||
|> createRecord
|
||||
candidate <- newRecord @RequirementCandidate
|
||||
|> set #title "Reg cand" |> set #description "d"
|
||||
|> set #sourceWidgetId widget.id |> set #category "friction"
|
||||
|> set #status "accepted" |> createRecord
|
||||
decision <- newRecord @DecisionRecord
|
||||
|> set #title "Reg dec" |> set #rationale "r"
|
||||
|> set #outcome "accepted" |> set #candidateId (Just candidate.id)
|
||||
|> createRecord
|
||||
deployment <- newRecord @DeploymentRecord
|
||||
|> set #decisionId decision.id |> set #versionRef "v1.0.0"
|
||||
|> createRecord
|
||||
-- Record an improved signal with observedAt 10 days ago
|
||||
now <- getCurrentTime
|
||||
let tenDaysAgo = addUTCTime (negate $ 10 * 24 * 3600) now
|
||||
sig <- newRecord @OutcomeSignal
|
||||
|> set #deploymentId deployment.id
|
||||
|> set #widgetId widget.id
|
||||
|> set #signalType "improved"
|
||||
|> set #observedAt tenDaysAgo
|
||||
|> createRecord
|
||||
-- Annotation created now — which is 10 days after signal (> 1 day grace)
|
||||
ann <- newRecord @Annotation
|
||||
|> set #widgetId widget.id
|
||||
|> set #body "High severity friction recurred"
|
||||
|> set #category "friction"
|
||||
|> set #severity "high"
|
||||
|> set #actorType "user"
|
||||
|> createRecord
|
||||
-- Run regression detection
|
||||
allSignals <- query @OutcomeSignal |> filterWhere (#widgetId, widget.id) |> fetch
|
||||
allAnns <- query @Annotation |> filterWhere (#widgetId, widget.id) |> fetch
|
||||
let regressed = regressedWidgetIds allSignals allAnns
|
||||
regressed `shouldContain` [widget.id]
|
||||
deleteRecord hub
|
||||
|
||||
it "does not flag widget without improved signal" do
|
||||
hub <- newRecord @Hub
|
||||
|> set #slug "p4-noreg-hub" |> set #name "P4 NoReg" |> set #domain "d"
|
||||
|> createRecord
|
||||
widget <- newRecord @Widget
|
||||
|> set #hubId hub.id |> set #name "NoReg Widget" |> set #widgetType "form"
|
||||
|> createRecord
|
||||
ann <- newRecord @Annotation
|
||||
|> set #widgetId widget.id |> set #body "high ann"
|
||||
|> set #category "friction" |> set #severity "high"
|
||||
|> set #actorType "user" |> createRecord
|
||||
let regressed = regressedWidgetIds [] [ann]
|
||||
regressed `shouldBe` []
|
||||
deleteRecord hub
|
||||
|
||||
-- ----------------------------------------------------------------
|
||||
-- Phase 4: ChangeEvaluation create + idempotent
|
||||
-- ----------------------------------------------------------------
|
||||
describe "ChangeEvaluation" do
|
||||
it "creates one evaluation per deployment and rejects duplicates" do
|
||||
hub <- newRecord @Hub
|
||||
|> set #slug "p4-eval-hub" |> set #name "P4 Eval" |> set #domain "d"
|
||||
|> createRecord
|
||||
widget <- newRecord @Widget
|
||||
|> set #hubId hub.id |> set #name "Eval Widget" |> set #widgetType "form"
|
||||
|> createRecord
|
||||
candidate <- newRecord @RequirementCandidate
|
||||
|> set #title "Eval cand" |> set #description "d"
|
||||
|> set #sourceWidgetId widget.id |> set #category "friction"
|
||||
|> set #status "accepted" |> createRecord
|
||||
decision <- newRecord @DecisionRecord
|
||||
|> set #title "Eval dec" |> set #rationale "r"
|
||||
|> set #outcome "accepted" |> set #candidateId (Just candidate.id)
|
||||
|> createRecord
|
||||
deployment <- newRecord @DeploymentRecord
|
||||
|> set #decisionId decision.id |> set #versionRef "v1.0.0"
|
||||
|> createRecord
|
||||
eval1 <- newRecord @ChangeEvaluation
|
||||
|> set #deploymentId deployment.id
|
||||
|> set #score 4
|
||||
|> set #rationale "Good improvement"
|
||||
|> createRecord
|
||||
eval1.score `shouldBe` 4
|
||||
-- Second evaluation for same deployment → UNIQUE constraint violation
|
||||
result <- try (newRecord @ChangeEvaluation
|
||||
|> set #deploymentId deployment.id
|
||||
|> set #score 3
|
||||
|> set #rationale "Duplicate"
|
||||
|> createRecord :: IO ChangeEvaluation)
|
||||
:: IO (Either SomeException ChangeEvaluation)
|
||||
isLeft result `shouldBe` True
|
||||
deleteRecord hub
|
||||
|
||||
-- ----------------------------------------------------------------
|
||||
-- Phase 4: Recurrence tracking
|
||||
-- ----------------------------------------------------------------
|
||||
describe "Recurrence tracking" do
|
||||
it "counts cycles for a widget with 2 completed cycles" do
|
||||
hub <- newRecord @Hub
|
||||
|> set #slug "p4-rec-hub" |> set #name "P4 Rec" |> set #domain "d"
|
||||
|> createRecord
|
||||
widget <- newRecord @Widget
|
||||
|> set #hubId hub.id |> set #name "Rec Widget" |> set #widgetType "form"
|
||||
|> createRecord
|
||||
-- Cycle 1: candidate → req → decision → deployment
|
||||
c1 <- newRecord @RequirementCandidate
|
||||
|> set #title "Rec cand 1" |> set #description "d"
|
||||
|> set #sourceWidgetId widget.id |> set #category "friction"
|
||||
|> set #status "accepted" |> createRecord
|
||||
req1 <- newRecord @Requirement
|
||||
|> set #title c1.title |> set #description "d"
|
||||
|> set #sourceCandidateId c1.id |> set #status "active"
|
||||
|> createRecord
|
||||
dec1 <- newRecord @DecisionRecord
|
||||
|> set #title "Rec dec 1" |> set #rationale "r"
|
||||
|> set #outcome "accepted" |> set #requirementId (Just req1.id)
|
||||
|> createRecord
|
||||
now <- getCurrentTime
|
||||
let pastTime = addUTCTime (negate $ 2 * 24 * 3600) now
|
||||
futureTime = addUTCTime (24 * 3600) now
|
||||
dep1 <- newRecord @DeploymentRecord
|
||||
|> set #decisionId dec1.id |> set #versionRef "v1.0"
|
||||
|> set #deployedAt pastTime
|
||||
|> createRecord
|
||||
-- Cycle 2: new candidate after dep1 deployment (created in the future relative to dep1)
|
||||
c2 <- newRecord @RequirementCandidate
|
||||
|> set #title "Rec cand 2" |> set #description "d"
|
||||
|> set #sourceWidgetId widget.id |> set #category "friction"
|
||||
|> set #status "accepted"
|
||||
|> set #createdAt futureTime
|
||||
|> createRecord
|
||||
-- Compute cycle count
|
||||
allCandidates <- query @RequirementCandidate |> filterWhere (#sourceWidgetId, widget.id) |> fetch
|
||||
allRequirements <- query @Requirement |> fetch
|
||||
allDecisions <- query @DecisionRecord |> fetch
|
||||
allDeployments <- query @DeploymentRecord |> fetch
|
||||
let cycles = widgetCycleCounts allCandidates allRequirements allDecisions allDeployments
|
||||
let mCount = lookup widget.id cycles
|
||||
mCount `shouldBe` Just 1
|
||||
deleteRecord hub
|
||||
|
||||
-- ----------------------------------------------------------------
|
||||
-- Phase 4: Antifragility dashboard data fetch
|
||||
-- ----------------------------------------------------------------
|
||||
describe "Antifragility dashboard data fetch" do
|
||||
it "returns correct deployment and signal counts" do
|
||||
hub <- newRecord @Hub
|
||||
|> set #slug "p4-afd-hub" |> set #name "P4 AFD" |> set #domain "d"
|
||||
|> createRecord
|
||||
widget <- newRecord @Widget
|
||||
|> set #hubId hub.id |> set #name "AFD Widget" |> set #widgetType "panel"
|
||||
|> createRecord
|
||||
candidate <- newRecord @RequirementCandidate
|
||||
|> set #title "AFD cand" |> set #description "d"
|
||||
|> set #sourceWidgetId widget.id |> set #category "friction"
|
||||
|> set #status "accepted" |> createRecord
|
||||
req <- newRecord @Requirement
|
||||
|> set #title candidate.title |> set #description "d"
|
||||
|> set #sourceCandidateId candidate.id |> set #status "active"
|
||||
|> createRecord
|
||||
decision <- newRecord @DecisionRecord
|
||||
|> set #title "AFD decision" |> set #rationale "r"
|
||||
|> set #outcome "accepted" |> set #requirementId (Just req.id)
|
||||
|> createRecord
|
||||
dep <- newRecord @DeploymentRecord
|
||||
|> set #decisionId decision.id |> set #versionRef "v1.0.0"
|
||||
|> createRecord
|
||||
_s1 <- newRecord @OutcomeSignal
|
||||
|> set #deploymentId dep.id |> set #widgetId widget.id
|
||||
|> set #signalType "improved" |> createRecord
|
||||
_s2 <- newRecord @OutcomeSignal
|
||||
|> set #deploymentId dep.id |> set #widgetId widget.id
|
||||
|> set #signalType "neutral" |> createRecord
|
||||
-- Verify query path used by antifragility dashboard
|
||||
let widgetIds = [widget.id]
|
||||
deployments <- query @DeploymentRecord
|
||||
|> filterWhereIn (#decisionId, [decision.id]) |> fetch
|
||||
signals <- query @OutcomeSignal
|
||||
|> filterWhereIn (#widgetId, widgetIds) |> fetch
|
||||
length deployments `shouldBe` 1
|
||||
length signals `shouldBe` 2
|
||||
let improvedCount = length (filter (\s -> s.signalType == "improved") signals)
|
||||
improvedCount `shouldBe` 1
|
||||
deleteRecord hub
|
||||
|
||||
Reference in New Issue
Block a user