diff --git a/Application/Helper/Controller.hs b/Application/Helper/Controller.hs index 3aa7c2a..dd6cfca 100644 --- a/Application/Helper/Controller.hs +++ b/Application/Helper/Controller.hs @@ -1,5 +1,71 @@ module Application.Helper.Controller where import IHP.ControllerPrelude +import Generated.Types +import Data.Time.Clock (addUTCTime) +import Data.List (sortBy) --- Here you can add functions which are available in all your controllers \ No newline at end of file +-- Here you can add functions which are available in all your controllers + +-- | Returns the set of widget IDs that are currently in regression. +-- +-- A regression is defined as: a widget that has an OutcomeSignal(improved) +-- for any deployment, followed by a new Annotation(severity IN high/critical) +-- created more than 1 day after the signal's observed_at (grace period). +regressedWidgetIds :: [OutcomeSignal] -> [Annotation] -> [Id Widget] +regressedWidgetIds signals annotations = + [ wid + | wid <- nub (map (.widgetId) signals) + , isInRegression signals annotations wid + ] + +isInRegression :: [OutcomeSignal] -> [Annotation] -> Id Widget -> Bool +isInRegression signals annotations wid = + let improvedSignals = filter (\s -> s.widgetId == wid && s.signalType == "improved") signals + highAnns = filter (\a -> a.widgetId == wid + && a.severity `elem` ["high", "critical"] + && isNothing a.retractedAt) annotations + graceEnd sig = addUTCTime (24 * 3600) sig.observedAt + in any (\sig -> any (\ann -> ann.createdAt > graceEnd sig) highAnns) improvedSignals + +-- | Computes the number of completed improvement cycles per widget. +-- +-- A cycle is counted when: +-- 1. A RequirementCandidate for the widget was accepted +-- 2. A DecisionRecord exists for that requirement/candidate +-- 3. A DeploymentRecord exists for that decision +-- 4. A new RequirementCandidate was subsequently created for the same widget +-- +-- Returns a list of (widgetId, cycleCount) for widgets with cycleCount >= 1, +-- sorted descending by cycleCount. +widgetCycleCounts + :: [RequirementCandidate] + -> [Requirement] + -> [DecisionRecord] + -> [DeploymentRecord] + -> [(Id Widget, Int)] +widgetCycleCounts candidates requirements decisions deployments = + sortBy (\(_, a) (_, b) -> compare b a) + [ (wid, cycleCount wid) + | wid <- nub (map (.sourceWidgetId) candidates) + , cycleCount wid >= 1 + ] + where + -- A completed cycle: accepted candidate → requirement → decision → deployment + completedCycleDeploymentTimes wid = + [ dr.deployedAt + | c <- filter (\x -> x.sourceWidgetId == wid && x.status == "accepted") candidates + , req <- filter (\x -> x.sourceCandidateId == c.id) requirements + , dec <- filter (\x -> x.requirementId == Just req.id) decisions + , dr <- filter (\x -> x.decisionId == dec.id) deployments + ] + + cycleCount wid = + let deplTimes = completedCycleDeploymentTimes wid + -- For each completed cycle, check if a subsequent candidate was created + widCandidates = filter (\x -> x.sourceWidgetId == wid) candidates + in length + [ () + | deplTime <- deplTimes + , any (\c -> c.createdAt > deplTime) widCandidates + ] \ No newline at end of file diff --git a/Application/Migration/1743292800-ihf-phase4-outcome-observation.sql b/Application/Migration/1743292800-ihf-phase4-outcome-observation.sql new file mode 100644 index 0000000..c87f787 --- /dev/null +++ b/Application/Migration/1743292800-ihf-phase4-outcome-observation.sql @@ -0,0 +1,57 @@ +-- IHF Phase 4: Outcome Observation and Antifragility Loop +-- Adds: deployment_records, outcome_signals (append-only), change_evaluations + +CREATE TABLE deployment_records ( + id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL, + impl_ref_id UUID REFERENCES implementation_change_references(id) ON DELETE SET NULL, + decision_id UUID NOT NULL REFERENCES decision_records(id) ON DELETE RESTRICT, + version_ref TEXT NOT NULL, + deployed_at TIMESTAMP WITH TIME ZONE DEFAULT now() NOT NULL, + deployed_by UUID REFERENCES users(id), + notes TEXT, + created_at TIMESTAMP WITH TIME ZONE DEFAULT now() NOT NULL +); + +CREATE INDEX deployment_records_decision_id_idx ON deployment_records (decision_id); +CREATE INDEX deployment_records_deployed_at_idx ON deployment_records (deployed_at DESC); + +CREATE TABLE outcome_signals ( + id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL, + widget_id UUID NOT NULL REFERENCES widgets(id) ON DELETE CASCADE, + deployment_id UUID NOT NULL REFERENCES deployment_records(id) ON DELETE CASCADE, + signal_type TEXT NOT NULL, + value NUMERIC, + observed_at TIMESTAMP WITH TIME ZONE DEFAULT now() NOT NULL +); + +CREATE INDEX outcome_signals_widget_id_idx ON outcome_signals (widget_id); +CREATE INDEX outcome_signals_deployment_id_idx ON outcome_signals (deployment_id); +CREATE INDEX outcome_signals_observed_at_idx ON outcome_signals (observed_at DESC); + +CREATE OR REPLACE FUNCTION prevent_outcome_signal_mutation() +RETURNS TRIGGER AS $$ +BEGIN + RAISE EXCEPTION 'outcome_signals is append-only: UPDATE and DELETE are not permitted'; +END; +$$ LANGUAGE plpgsql; + +CREATE TRIGGER outcome_signals_no_update + BEFORE UPDATE ON outcome_signals + FOR EACH ROW EXECUTE FUNCTION prevent_outcome_signal_mutation(); + +CREATE TRIGGER outcome_signals_no_delete + BEFORE DELETE ON outcome_signals + FOR EACH ROW EXECUTE FUNCTION prevent_outcome_signal_mutation(); + +CREATE TABLE change_evaluations ( + id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL, + deployment_id UUID NOT NULL REFERENCES deployment_records(id) ON DELETE CASCADE, + decision_id UUID REFERENCES decision_records(id) ON DELETE SET NULL, + score SMALLINT NOT NULL CHECK (score BETWEEN 1 AND 5), + rationale TEXT NOT NULL, + evaluated_by UUID REFERENCES users(id), + evaluated_at TIMESTAMP WITH TIME ZONE DEFAULT now() NOT NULL, + UNIQUE (deployment_id) +); + +CREATE INDEX change_evaluations_deployment_id_idx ON change_evaluations (deployment_id); diff --git a/Application/Schema.sql b/Application/Schema.sql index 6ee82ad..eb5f286 100644 --- a/Application/Schema.sql +++ b/Application/Schema.sql @@ -205,3 +205,61 @@ CREATE INDEX impl_change_refs_decision_id_idx ON implementation_change_reference -- Back-reference: which candidate was promoted to a requirement (Phase 3) ALTER TABLE requirement_candidates ADD COLUMN requirement_id UUID REFERENCES requirements(id) ON DELETE SET NULL; + +-- Deployment records — connect decisions to deployed versions (Phase 4) +CREATE TABLE deployment_records ( + id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL, + impl_ref_id UUID REFERENCES implementation_change_references(id) ON DELETE SET NULL, + decision_id UUID NOT NULL REFERENCES decision_records(id) ON DELETE RESTRICT, + version_ref TEXT NOT NULL, + deployed_at TIMESTAMP WITH TIME ZONE DEFAULT now() NOT NULL, + deployed_by UUID REFERENCES users(id), + notes TEXT, + created_at TIMESTAMP WITH TIME ZONE DEFAULT now() NOT NULL +); + +CREATE INDEX deployment_records_decision_id_idx ON deployment_records (decision_id); +CREATE INDEX deployment_records_deployed_at_idx ON deployment_records (deployed_at DESC); + +-- Outcome signals — append-only observation of widget behaviour post-deployment (Phase 4) +CREATE TABLE outcome_signals ( + id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL, + widget_id UUID NOT NULL REFERENCES widgets(id) ON DELETE CASCADE, + deployment_id UUID NOT NULL REFERENCES deployment_records(id) ON DELETE CASCADE, + signal_type TEXT NOT NULL, + value NUMERIC, + observed_at TIMESTAMP WITH TIME ZONE DEFAULT now() NOT NULL +); + +CREATE INDEX outcome_signals_widget_id_idx ON outcome_signals (widget_id); +CREATE INDEX outcome_signals_deployment_id_idx ON outcome_signals (deployment_id); +CREATE INDEX outcome_signals_observed_at_idx ON outcome_signals (observed_at DESC); + +CREATE OR REPLACE FUNCTION prevent_outcome_signal_mutation() +RETURNS TRIGGER AS $$ +BEGIN + RAISE EXCEPTION 'outcome_signals is append-only: UPDATE and DELETE are not permitted'; +END; +$$ LANGUAGE plpgsql; + +CREATE TRIGGER outcome_signals_no_update + BEFORE UPDATE ON outcome_signals + FOR EACH ROW EXECUTE FUNCTION prevent_outcome_signal_mutation(); + +CREATE TRIGGER outcome_signals_no_delete + BEFORE DELETE ON outcome_signals + FOR EACH ROW EXECUTE FUNCTION prevent_outcome_signal_mutation(); + +-- Change evaluations — one score per deployment (Phase 4) +CREATE TABLE change_evaluations ( + id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL, + deployment_id UUID NOT NULL REFERENCES deployment_records(id) ON DELETE CASCADE, + decision_id UUID REFERENCES decision_records(id) ON DELETE SET NULL, + score SMALLINT NOT NULL CHECK (score BETWEEN 1 AND 5), + rationale TEXT NOT NULL, + evaluated_by UUID REFERENCES users(id), + evaluated_at TIMESTAMP WITH TIME ZONE DEFAULT now() NOT NULL, + UNIQUE (deployment_id) +); + +CREATE INDEX change_evaluations_deployment_id_idx ON change_evaluations (deployment_id); diff --git a/SCOPE.md b/SCOPE.md index de73719..d4b6d9a 100644 --- a/SCOPE.md +++ b/SCOPE.md @@ -65,9 +65,9 @@ IHF treats every meaningful UI element as a **governed interaction artifact** ra ## Current State -- Status: Phase 3 complete — governance and decision linkage implemented -- Implementation: Phase 0 complete (specification); Phase 1 complete (widget registry, event capture, annotations, hub dashboard, auth); Phase 2 complete (annotation severity, annotation threads, requirement candidates, triage lifecycle, reviewer assignment, triage dashboard); Phase 3 complete (requirement promotion, decision records, policy references, implementation change references, governance audit trail dashboard) -- Stability: core artifact model and schema are stable; Phase 3 data model (Requirement, DecisionRecord, PolicyReference, ImplementationChangeReference) is additive and stable +- Status: Phase 4 complete — outcome observation and antifragility loop implemented +- Implementation: Phase 0 complete (specification); Phase 1 complete (widget registry, event capture, annotations, hub dashboard, auth); Phase 2 complete (annotation severity, annotation threads, requirement candidates, triage lifecycle, reviewer assignment, triage dashboard); Phase 3 complete (requirement promotion, decision records, policy references, implementation change references, governance dashboard); Phase 4 complete (deployment records, outcome signals, pre/post comparison, regression detection, change evaluation, recurrence tracking, antifragility dashboard) +- Stability: core artifact model and schema are stable; Phase 4 data model (DeploymentRecord, OutcomeSignal, ChangeEvaluation) is additive and stable; outcome signals and interaction events are append-only (DB triggers) - Usage: reference implementation running on IHP v1.5 + PostgreSQL; `devenv up` to start --- diff --git a/Test/Integration.hs b/Test/Integration.hs index 5d6e3c5..b21b81c 100644 --- a/Test/Integration.hs +++ b/Test/Integration.hs @@ -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 diff --git a/Web/Controller/DecisionRecords.hs b/Web/Controller/DecisionRecords.hs index ded4851..911ea11 100644 --- a/Web/Controller/DecisionRecords.hs +++ b/Web/Controller/DecisionRecords.hs @@ -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 diff --git a/Web/Controller/DeploymentRecords.hs b/Web/Controller/DeploymentRecords.hs new file mode 100644 index 0000000..5849d89 --- /dev/null +++ b/Web/Controller/DeploymentRecords.hs @@ -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) diff --git a/Web/Controller/Hubs.hs b/Web/Controller/Hubs.hs index eacbf71..15ad0ba 100644 --- a/Web/Controller/Hubs.hs +++ b/Web/Controller/Hubs.hs @@ -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 } diff --git a/Web/Controller/Widgets.hs b/Web/Controller/Widgets.hs index d63aa08..6eafa54 100644 --- a/Web/Controller/Widgets.hs +++ b/Web/Controller/Widgets.hs @@ -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 diff --git a/Web/FrontController.hs b/Web/FrontController.hs index b074cc5..3cb1709 100644 --- a/Web/FrontController.hs +++ b/Web/FrontController.hs @@ -15,6 +15,7 @@ import Web.Controller.AnnotationThreads () import Web.Controller.RequirementCandidates () import Web.Controller.Requirements () import Web.Controller.DecisionRecords () +import Web.Controller.DeploymentRecords () import Web.Controller.Sessions () instance FrontController WebApplication where @@ -28,6 +29,7 @@ instance FrontController WebApplication where , parseRoute @RequirementCandidatesController , parseRoute @RequirementsController , parseRoute @DecisionRecordsController + , parseRoute @DeploymentRecordsController ] instance InitControllerContext WebApplication where @@ -56,6 +58,7 @@ defaultLayout inner = [hsx| Candidates Requirements Decisions + Deployments
diff --git a/Web/Routes.hs b/Web/Routes.hs index 8ede9d9..2b40237 100644 --- a/Web/Routes.hs +++ b/Web/Routes.hs @@ -28,5 +28,8 @@ instance AutoRoute RequirementsController -- Decision Records (Phase 3) instance AutoRoute DecisionRecordsController +-- Deployment Records (Phase 4) +instance AutoRoute DeploymentRecordsController + -- Sessions instance AutoRoute SessionsController diff --git a/Web/Types.hs b/Web/Types.hs index 5dd826f..0d3ec1c 100644 --- a/Web/Types.hs +++ b/Web/Types.hs @@ -23,8 +23,9 @@ data HubsController | EditHubAction { hubId :: !(Id Hub) } | UpdateHubAction { hubId :: !(Id Hub) } | DeleteHubAction { hubId :: !(Id Hub) } - | TriageDashboardAction { hubId :: !(Id Hub) } - | GovernanceDashboardAction { hubId :: !(Id Hub) } + | TriageDashboardAction { hubId :: !(Id Hub) } + | GovernanceDashboardAction { hubId :: !(Id Hub) } + | AntifragilityDashboardAction { hubId :: !(Id Hub) } deriving (Eq, Show, Data) data WidgetsController @@ -88,6 +89,15 @@ data DecisionRecordsController | DeleteImplementationRefAction { implementationChangeReferenceId :: !(Id ImplementationChangeReference) } deriving (Eq, Show, Data) +data DeploymentRecordsController + = DeploymentRecordsAction + | ShowDeploymentRecordAction { deploymentRecordId :: !(Id DeploymentRecord) } + | NewDeploymentRecordAction + | CreateDeploymentRecordAction + | RecordOutcomeSignalAction { deploymentRecordId :: !(Id DeploymentRecord) } + | EvaluateChangeAction { deploymentRecordId :: !(Id DeploymentRecord) } + deriving (Eq, Show, Data) + data SessionsController = NewSessionAction | CreateSessionAction diff --git a/Web/View/DecisionRecords/Show.hs b/Web/View/DecisionRecords/Show.hs index fd7d234..1a05042 100644 --- a/Web/View/DecisionRecords/Show.hs +++ b/Web/View/DecisionRecords/Show.hs @@ -6,12 +6,14 @@ import IHP.Prelude import IHP.ViewPrelude data ShowView = ShowView - { record :: !DecisionRecord - , policyRefs :: ![PolicyReference] - , implRefs :: ![ImplementationChangeReference] - , mRequirement :: !(Maybe Requirement) - , mCandidate :: !(Maybe RequirementCandidate) - , users :: ![User] + { record :: !DecisionRecord + , policyRefs :: ![PolicyReference] + , implRefs :: ![ImplementationChangeReference] + , deploymentRecords :: ![DeploymentRecord] + , evaluations :: ![ChangeEvaluation] + , mRequirement :: !(Maybe Requirement) + , mCandidate :: !(Maybe RequirementCandidate) + , users :: ![User] } instance View ShowView where @@ -92,6 +94,24 @@ instance View ShowView where + +No deployments recorded yet.
|] + else [hsx|{forEach deploymentRecords (renderDeploymentRow evaluations)}|]} +No deployment records yet.
|] + else renderTable records decisions signals evaluations} + |] + +renderTable :: [DeploymentRecord] -> [DecisionRecord] -> [OutcomeSignal] -> [ChangeEvaluation] -> Html +renderTable records decisions signals evaluations = [hsx| +| Decision | +Version | +Deployed At | +Signals | +Evaluation | +
|---|
No signals recorded yet.
|] + else [hsx|Notes
+{notes}
+{ev.rationale}
+{show ev.evaluatedAt}
+| Metric | +Before | +After | +Delta | +
|---|
All decisions with impl refs have deployments.
|] + else [hsx| +No deployments yet.
|] + else [hsx| +| Version | +Decision | +Signals | +Eval | +Deployed | +
|---|
No recurring widgets detected.
|] + else [hsx| +| Widget | +Cycles | +
|---|