generated from coulomb/repo-seed
Bernd Worsch
878d2577ae
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>
945 lines
53 KiB
Haskell
945 lines
53 KiB
Haskell
module Main where
|
|
|
|
import Test.Hspec
|
|
import IHP.Prelude
|
|
import IHP.ModelSupport
|
|
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)
|
|
main :: IO ()
|
|
main = do
|
|
databaseUrl <- lookupEnv "DATABASE_URL" >>= \case
|
|
Just url -> pure (cs url)
|
|
Nothing -> error "DATABASE_URL not set. Run `devenv up` first or use `nix flake check`."
|
|
logger <- newLogger def { level = Warn }
|
|
withModelContext databaseUrl logger \modelContext -> do
|
|
let ?modelContext = modelContext
|
|
hspec do
|
|
|
|
-- ----------------------------------------------------------------
|
|
-- Hub CRUD
|
|
-- ----------------------------------------------------------------
|
|
describe "Hub CRUD" do
|
|
it "can create and fetch a hub" do
|
|
hub <- newRecord @Hub
|
|
|> set #slug "test-hub"
|
|
|> set #name "Test Hub"
|
|
|> set #domain "test"
|
|
|> createRecord
|
|
hub.name `shouldBe` "Test Hub"
|
|
fetched <- fetch hub.id
|
|
fetched.slug `shouldBe` "test-hub"
|
|
deleteRecord hub
|
|
|
|
-- ----------------------------------------------------------------
|
|
-- Widget CRUD + versioning
|
|
-- ----------------------------------------------------------------
|
|
describe "Widget CRUD" do
|
|
it "creates widget and records version 1" do
|
|
hub <- newRecord @Hub
|
|
|> set #slug "w-hub" |> set #name "W Hub" |> set #domain "d"
|
|
|> createRecord
|
|
widget <- newRecord @Widget
|
|
|> set #hubId hub.id
|
|
|> set #name "Test Widget"
|
|
|> set #widgetType "chart"
|
|
|> createRecord
|
|
widget.version `shouldBe` 1
|
|
let snapshot = object ["name" .= widget.name]
|
|
_ver <- newRecord @WidgetVersion
|
|
|> set #widgetId widget.id
|
|
|> set #version 1
|
|
|> set #schemaSnapshot snapshot
|
|
|> createRecord
|
|
versions <- query @WidgetVersion |> filterWhere (#widgetId, widget.id) |> fetch
|
|
length versions `shouldBe` 1
|
|
deleteRecord hub
|
|
|
|
-- ----------------------------------------------------------------
|
|
-- Interaction event capture
|
|
-- ----------------------------------------------------------------
|
|
describe "InteractionEvent capture" do
|
|
it "records event with anonymous actor" do
|
|
hub <- newRecord @Hub
|
|
|> set #slug "ev-hub" |> set #name "Ev Hub" |> set #domain "d"
|
|
|> createRecord
|
|
widget <- newRecord @Widget
|
|
|> set #hubId hub.id |> set #name "Ev Widget" |> set #widgetType "form"
|
|
|> createRecord
|
|
event <- newRecord @InteractionEvent
|
|
|> set #widgetId widget.id
|
|
|> set #eventType "clicked"
|
|
|> set #actorType "anonymous"
|
|
|> createRecord
|
|
event.eventType `shouldBe` "clicked"
|
|
event.actorType `shouldBe` "anonymous"
|
|
deleteRecord hub
|
|
|
|
it "append-only: UPDATE raises exception" do
|
|
hub <- newRecord @Hub
|
|
|> set #slug "ao-hub" |> set #name "AO Hub" |> set #domain "d"
|
|
|> createRecord
|
|
widget <- newRecord @Widget
|
|
|> set #hubId hub.id |> set #name "AO Widget" |> set #widgetType "table"
|
|
|> createRecord
|
|
event <- newRecord @InteractionEvent
|
|
|> set #widgetId widget.id
|
|
|> set #eventType "viewed"
|
|
|> set #actorType "user"
|
|
|> createRecord
|
|
let attemptUpdate = sqlExec
|
|
"UPDATE interaction_events SET event_type = 'tampered' WHERE id = ?"
|
|
(Only event.id)
|
|
attemptUpdate `shouldThrow` anyException
|
|
deleteRecord hub
|
|
|
|
-- ----------------------------------------------------------------
|
|
-- Annotation CRUD + threading
|
|
-- ----------------------------------------------------------------
|
|
describe "Annotation CRUD" do
|
|
it "creates annotation and lists it" do
|
|
hub <- newRecord @Hub
|
|
|> set #slug "ann-hub" |> set #name "Ann Hub" |> set #domain "d"
|
|
|> createRecord
|
|
widget <- newRecord @Widget
|
|
|> set #hubId hub.id |> set #name "Ann Widget" |> set #widgetType "panel"
|
|
|> createRecord
|
|
ann <- newRecord @Annotation
|
|
|> set #widgetId widget.id
|
|
|> set #body "This is confusing"
|
|
|> set #category "friction"
|
|
|> set #actorType "user"
|
|
|> createRecord
|
|
anns <- query @Annotation |> filterWhere (#widgetId, widget.id) |> fetch
|
|
length anns `shouldBe` 1
|
|
(head anns).body `shouldBe` "This is confusing"
|
|
deleteRecord hub
|
|
|
|
it "supports threaded replies via parent_id" do
|
|
hub <- newRecord @Hub
|
|
|> set #slug "thread-hub" |> set #name "Thread Hub" |> set #domain "d"
|
|
|> createRecord
|
|
widget <- newRecord @Widget
|
|
|> set #hubId hub.id |> set #name "Thread Widget" |> set #widgetType "form"
|
|
|> createRecord
|
|
root <- newRecord @Annotation
|
|
|> set #widgetId widget.id
|
|
|> set #body "Root comment"
|
|
|> set #category "friction"
|
|
|> set #actorType "user"
|
|
|> createRecord
|
|
reply <- newRecord @Annotation
|
|
|> set #widgetId widget.id
|
|
|> set #parentId (Just root.id)
|
|
|> set #body "Reply to root"
|
|
|> set #category "other"
|
|
|> set #actorType "user"
|
|
|> createRecord
|
|
reply.parentId `shouldBe` Just root.id
|
|
deleteRecord hub
|
|
|
|
-- ----------------------------------------------------------------
|
|
-- Validation: empty body rejected
|
|
-- ----------------------------------------------------------------
|
|
describe "Annotation validation" do
|
|
it "empty body fails validation" do
|
|
hub <- newRecord @Hub
|
|
|> set #slug "val-hub" |> set #name "Val Hub" |> set #domain "d"
|
|
|> createRecord
|
|
widget <- newRecord @Widget
|
|
|> set #hubId hub.id |> set #name "Val Widget" |> set #widgetType "form"
|
|
|> createRecord
|
|
let ann = newRecord @Annotation
|
|
|> set #widgetId widget.id
|
|
|> set #body ""
|
|
|> set #category "friction"
|
|
|> validateField #body nonEmpty
|
|
isValid ann `shouldBe` False
|
|
deleteRecord hub
|
|
|
|
-- ----------------------------------------------------------------
|
|
-- Phase 2: Annotation severity
|
|
-- ----------------------------------------------------------------
|
|
describe "Annotation severity" do
|
|
it "defaults to medium severity" do
|
|
hub <- newRecord @Hub
|
|
|> set #slug "sev-hub" |> set #name "Sev Hub" |> set #domain "d"
|
|
|> createRecord
|
|
widget <- newRecord @Widget
|
|
|> set #hubId hub.id |> set #name "Sev Widget" |> set #widgetType "form"
|
|
|> createRecord
|
|
ann <- newRecord @Annotation
|
|
|> set #widgetId widget.id
|
|
|> set #body "Default severity test"
|
|
|> set #category "friction"
|
|
|> set #actorType "user"
|
|
|> createRecord
|
|
ann.severity `shouldBe` "medium"
|
|
deleteRecord hub
|
|
|
|
it "stores explicit severity" do
|
|
hub <- newRecord @Hub
|
|
|> set #slug "sev2-hub" |> set #name "Sev2 Hub" |> set #domain "d"
|
|
|> createRecord
|
|
widget <- newRecord @Widget
|
|
|> set #hubId hub.id |> set #name "Sev2 Widget" |> set #widgetType "form"
|
|
|> createRecord
|
|
ann <- newRecord @Annotation
|
|
|> set #widgetId widget.id
|
|
|> set #body "Critical issue"
|
|
|> set #category "defect"
|
|
|> set #severity "critical"
|
|
|> set #actorType "user"
|
|
|> createRecord
|
|
ann.severity `shouldBe` "critical"
|
|
deleteRecord hub
|
|
|
|
-- ----------------------------------------------------------------
|
|
-- Phase 2: AnnotationThread create + assign annotation
|
|
-- ----------------------------------------------------------------
|
|
describe "AnnotationThread" do
|
|
it "creates thread and assigns annotation" do
|
|
hub <- newRecord @Hub
|
|
|> set #slug "th-hub" |> set #name "Th Hub" |> set #domain "d"
|
|
|> createRecord
|
|
widget <- newRecord @Widget
|
|
|> set #hubId hub.id |> set #name "Th Widget" |> set #widgetType "panel"
|
|
|> createRecord
|
|
thread <- newRecord @AnnotationThread
|
|
|> set #widgetId widget.id
|
|
|> set #title "Login flow friction cluster"
|
|
|> set #description (Just "All friction annotations about login")
|
|
|> createRecord
|
|
ann <- newRecord @Annotation
|
|
|> set #widgetId widget.id
|
|
|> set #body "Login button is confusing"
|
|
|> set #category "friction"
|
|
|> set #actorType "user"
|
|
|> createRecord
|
|
-- Assign annotation to thread
|
|
ann |> set #threadId (Just thread.id) |> updateRecord
|
|
fetched <- fetch ann.id
|
|
fetched.threadId `shouldBe` Just thread.id
|
|
deleteRecord hub
|
|
|
|
-- ----------------------------------------------------------------
|
|
-- Phase 2: Escalation annotation → RequirementCandidate
|
|
-- ----------------------------------------------------------------
|
|
describe "Escalation: annotation → RequirementCandidate" do
|
|
it "creates candidate from annotation" do
|
|
hub <- newRecord @Hub
|
|
|> set #slug "esc-hub" |> set #name "Esc Hub" |> set #domain "d"
|
|
|> createRecord
|
|
widget <- newRecord @Widget
|
|
|> set #hubId hub.id |> set #name "Esc Widget" |> set #widgetType "form"
|
|
|> createRecord
|
|
ann <- newRecord @Annotation
|
|
|> set #widgetId widget.id
|
|
|> set #body "The submit button is invisible"
|
|
|> set #category "defect"
|
|
|> set #actorType "user"
|
|
|> createRecord
|
|
candidate <- newRecord @RequirementCandidate
|
|
|> set #title "The submit button is invisible"
|
|
|> set #description ann.body
|
|
|> set #sourceWidgetId widget.id
|
|
|> set #sourceAnnotationId (Just ann.id)
|
|
|> set #category ann.category
|
|
|> set #status "open"
|
|
|> createRecord
|
|
candidate.status `shouldBe` "open"
|
|
candidate.sourceAnnotationId `shouldBe` Just ann.id
|
|
deleteRecord hub
|
|
|
|
it "duplicate escalation: candidate already linked to annotation" do
|
|
hub <- newRecord @Hub
|
|
|> set #slug "dup-hub" |> set #name "Dup Hub" |> set #domain "d"
|
|
|> createRecord
|
|
widget <- newRecord @Widget
|
|
|> set #hubId hub.id |> set #name "Dup Widget" |> set #widgetType "form"
|
|
|> createRecord
|
|
ann <- newRecord @Annotation
|
|
|> set #widgetId widget.id
|
|
|> set #body "Duplicate escalation test"
|
|
|> set #category "friction"
|
|
|> set #actorType "user"
|
|
|> createRecord
|
|
_c1 <- newRecord @RequirementCandidate
|
|
|> set #title "First escalation"
|
|
|> set #description ann.body
|
|
|> set #sourceWidgetId widget.id
|
|
|> set #sourceAnnotationId (Just ann.id)
|
|
|> set #category ann.category
|
|
|> set #status "open"
|
|
|> createRecord
|
|
-- Second escalation attempt: query returns existing
|
|
existing <- query @RequirementCandidate
|
|
|> filterWhere (#sourceAnnotationId, Just ann.id)
|
|
|> fetchOneOrNothing
|
|
isJust existing `shouldBe` True
|
|
deleteRecord hub
|
|
|
|
-- ----------------------------------------------------------------
|
|
-- Phase 2: Triage lifecycle
|
|
-- ----------------------------------------------------------------
|
|
describe "Triage lifecycle" do
|
|
it "valid path: open → in_review → accepted" do
|
|
hub <- newRecord @Hub
|
|
|> set #slug "tri-hub" |> set #name "Tri Hub" |> set #domain "d"
|
|
|> createRecord
|
|
widget <- newRecord @Widget
|
|
|> set #hubId hub.id |> set #name "Tri Widget" |> set #widgetType "form"
|
|
|> createRecord
|
|
candidate <- newRecord @RequirementCandidate
|
|
|> set #title "Triage test candidate"
|
|
|> set #description "Testing triage lifecycle"
|
|
|> set #sourceWidgetId widget.id
|
|
|> set #category "friction"
|
|
|> set #status "open"
|
|
|> createRecord
|
|
|
|
-- Transition: open → in_review
|
|
newRecord @TriageState
|
|
|> set #candidateId candidate.id
|
|
|> set #status "in_review"
|
|
|> createRecord
|
|
candidate |> set #status "in_review" |> updateRecord
|
|
|
|
inReview <- fetch candidate.id
|
|
inReview.status `shouldBe` "in_review"
|
|
|
|
-- Transition: in_review → accepted
|
|
newRecord @TriageState
|
|
|> set #candidateId inReview.id
|
|
|> set #status "accepted"
|
|
|> createRecord
|
|
inReview |> set #status "accepted" |> updateRecord
|
|
|
|
accepted <- fetch candidate.id
|
|
accepted.status `shouldBe` "accepted"
|
|
|
|
-- Audit trail: 2 triage state rows
|
|
rows <- query @TriageState |> filterWhere (#candidateId, candidate.id) |> fetch
|
|
length rows `shouldBe` 2
|
|
deleteRecord hub
|
|
|
|
it "invalid transition is not allowed by controller logic" do
|
|
let allowedTransition from to = case (from, to) of
|
|
("open", "in_review") -> True
|
|
("in_review", "accepted") -> True
|
|
("in_review", "rejected") -> True
|
|
("in_review", "deferred") -> True
|
|
("deferred", "in_review") -> True
|
|
_ -> False
|
|
allowedTransition "open" "accepted" `shouldBe` False
|
|
allowedTransition "open" "rejected" `shouldBe` False
|
|
allowedTransition "accepted" "open" `shouldBe` False
|
|
|
|
-- ----------------------------------------------------------------
|
|
-- Phase 2: ReviewerAssignment
|
|
-- ----------------------------------------------------------------
|
|
describe "ReviewerAssignment" do
|
|
it "assigns and reassigns reviewer" do
|
|
hub <- newRecord @Hub
|
|
|> set #slug "rev-hub" |> set #name "Rev Hub" |> set #domain "d"
|
|
|> createRecord
|
|
widget <- newRecord @Widget
|
|
|> set #hubId hub.id |> set #name "Rev Widget" |> set #widgetType "form"
|
|
|> createRecord
|
|
candidate <- newRecord @RequirementCandidate
|
|
|> set #title "Reviewer test"
|
|
|> set #description "Testing reviewer assignment"
|
|
|> set #sourceWidgetId widget.id
|
|
|> set #category "friction"
|
|
|> set #status "open"
|
|
|> createRecord
|
|
user1 <- newRecord @User
|
|
|> set #email "reviewer1@example.com"
|
|
|> set #name "Reviewer One"
|
|
|> set #passwordHash "hash1"
|
|
|> createRecord
|
|
user2 <- newRecord @User
|
|
|> set #email "reviewer2@example.com"
|
|
|> set #name "Reviewer Two"
|
|
|> set #passwordHash "hash2"
|
|
|> createRecord
|
|
|
|
-- First assignment
|
|
ra <- newRecord @ReviewerAssignment
|
|
|> set #candidateId candidate.id
|
|
|> set #userId user1.id
|
|
|> createRecord
|
|
ra.userId `shouldBe` user1.id
|
|
|
|
-- Reassign (upsert: delete old, insert new)
|
|
deleteRecord ra
|
|
ra2 <- newRecord @ReviewerAssignment
|
|
|> set #candidateId candidate.id
|
|
|> set #userId user2.id
|
|
|> createRecord
|
|
ra2.userId `shouldBe` user2.id
|
|
|
|
-- Only one assignment remains
|
|
assignments <- query @ReviewerAssignment
|
|
|> filterWhere (#candidateId, candidate.id)
|
|
|> fetch
|
|
length assignments `shouldBe` 1
|
|
|
|
deleteRecord hub
|
|
deleteRecord user1
|
|
deleteRecord user2
|
|
|
|
it "my-queue filter: only returns assigned open/in_review candidates" do
|
|
hub <- newRecord @Hub
|
|
|> set #slug "q-hub" |> set #name "Q Hub" |> set #domain "d"
|
|
|> createRecord
|
|
widget <- newRecord @Widget
|
|
|> set #hubId hub.id |> set #name "Q Widget" |> set #widgetType "form"
|
|
|> createRecord
|
|
user <- newRecord @User
|
|
|> set #email "queue@example.com"
|
|
|> set #name "Queue User"
|
|
|> set #passwordHash "hash"
|
|
|> createRecord
|
|
c1 <- newRecord @RequirementCandidate
|
|
|> set #title "Assigned open" |> set #description "d"
|
|
|> set #sourceWidgetId widget.id |> set #category "friction"
|
|
|> set #status "open" |> createRecord
|
|
c2 <- newRecord @RequirementCandidate
|
|
|> set #title "Unassigned" |> set #description "d"
|
|
|> set #sourceWidgetId widget.id |> set #category "friction"
|
|
|> set #status "open" |> createRecord
|
|
newRecord @ReviewerAssignment
|
|
|> set #candidateId c1.id
|
|
|> set #userId user.id
|
|
|> createRecord
|
|
assignments <- query @ReviewerAssignment |> filterWhere (#userId, user.id) |> fetch
|
|
let assignedIds = map (.candidateId) assignments
|
|
assignedIds `shouldContain` [c1.id]
|
|
assignedIds `shouldNotContain` [c2.id]
|
|
deleteRecord hub
|
|
deleteRecord user
|
|
|
|
-- ----------------------------------------------------------------
|
|
-- Phase 2: Triage dashboard autoRefresh wrapper check
|
|
-- ----------------------------------------------------------------
|
|
describe "Triage dashboard" do
|
|
it "autoRefresh wrapper: TriageDashboardAction fetches hub + widgets + candidates" do
|
|
-- Structural test: verify the data fetching logic compiles and is accessible
|
|
-- (runtime autoRefresh test requires WebSocket — verified manually)
|
|
hub <- newRecord @Hub
|
|
|> set #slug "dash-hub" |> set #name "Dash Hub" |> set #domain "d"
|
|
|> createRecord
|
|
widget <- newRecord @Widget
|
|
|> set #hubId hub.id |> set #name "Dash Widget" |> set #widgetType "panel"
|
|
|> createRecord
|
|
candidate <- newRecord @RequirementCandidate
|
|
|> set #title "Dashboard candidate" |> set #description "d"
|
|
|> set #sourceWidgetId widget.id |> set #category "friction"
|
|
|> set #status "open" |> createRecord
|
|
-- Verify fetch path used by dashboard action
|
|
widgets <- query @Widget |> filterWhere (#hubId, hub.id) |> fetch
|
|
candidates <- query @RequirementCandidate
|
|
|> filterWhereIn (#sourceWidgetId, map (.id) widgets)
|
|
|> fetch
|
|
length widgets `shouldBe` 1
|
|
length candidates `shouldBe` 1
|
|
deleteRecord hub
|
|
|
|
-- ----------------------------------------------------------------
|
|
-- Phase 3: Requirement promotion
|
|
-- ----------------------------------------------------------------
|
|
describe "Requirement promotion" do
|
|
it "promotes an accepted candidate to a requirement" do
|
|
hub <- newRecord @Hub
|
|
|> set #slug "p3-promo-hub" |> set #name "P3 Promo" |> set #domain "d"
|
|
|> createRecord
|
|
widget <- newRecord @Widget
|
|
|> set #hubId hub.id |> set #name "P3 Widget" |> set #widgetType "form"
|
|
|> createRecord
|
|
candidate <- newRecord @RequirementCandidate
|
|
|> set #title "Accepted candidate" |> set #description "desc"
|
|
|> set #sourceWidgetId widget.id |> set #category "friction"
|
|
|> set #status "accepted" |> createRecord
|
|
req <- newRecord @Requirement
|
|
|> set #title candidate.title
|
|
|> set #description candidate.description
|
|
|> set #sourceCandidateId candidate.id
|
|
|> set #status "active"
|
|
|> createRecord
|
|
candidate2 <- candidate |> set #requirementId (Just req.id) |> updateRecord
|
|
req.status `shouldBe` "active"
|
|
candidate2.requirementId `shouldBe` Just req.id
|
|
deleteRecord hub
|
|
|
|
it "idempotent: second promotion reuses existing requirement" do
|
|
hub <- newRecord @Hub
|
|
|> set #slug "p3-idem-hub" |> set #name "P3 Idem" |> set #domain "d"
|
|
|> createRecord
|
|
widget <- newRecord @Widget
|
|
|> set #hubId hub.id |> set #name "Idem Widget" |> set #widgetType "table"
|
|
|> createRecord
|
|
candidate <- newRecord @RequirementCandidate
|
|
|> set #title "Idempotent promo" |> set #description "d"
|
|
|> set #sourceWidgetId widget.id |> set #category "friction"
|
|
|> set #status "accepted" |> createRecord
|
|
req <- newRecord @Requirement
|
|
|> set #title candidate.title |> set #description candidate.description
|
|
|> set #sourceCandidateId candidate.id |> set #status "active"
|
|
|> createRecord
|
|
candidate2 <- candidate |> set #requirementId (Just req.id) |> updateRecord
|
|
-- Fetch back and verify requirement_id is set
|
|
fetched <- fetch candidate2.id
|
|
fetched.requirementId `shouldBe` Just req.id
|
|
deleteRecord hub
|
|
|
|
-- ----------------------------------------------------------------
|
|
-- Phase 3: DecisionRecord create and link
|
|
-- ----------------------------------------------------------------
|
|
describe "DecisionRecord" do
|
|
it "creates a decision record linked to a candidate" do
|
|
hub <- newRecord @Hub
|
|
|> set #slug "p3-dr-hub" |> set #name "P3 DR" |> set #domain "d"
|
|
|> createRecord
|
|
widget <- newRecord @Widget
|
|
|> set #hubId hub.id |> set #name "DR Widget" |> set #widgetType "chart"
|
|
|> createRecord
|
|
candidate <- newRecord @RequirementCandidate
|
|
|> set #title "DR candidate" |> set #description "desc"
|
|
|> set #sourceWidgetId widget.id |> set #category "friction"
|
|
|> set #status "accepted" |> createRecord
|
|
req <- newRecord @Requirement
|
|
|> set #title candidate.title |> set #description candidate.description
|
|
|> set #sourceCandidateId candidate.id |> set #status "active"
|
|
|> createRecord
|
|
dr <- newRecord @DecisionRecord
|
|
|> set #title "Approve DR widget redesign"
|
|
|> set #rationale "Users reported high friction"
|
|
|> set #outcome "accepted"
|
|
|> set #candidateId (Just candidate.id)
|
|
|> set #requirementId (Just req.id)
|
|
|> createRecord
|
|
dr.outcome `shouldBe` "accepted"
|
|
dr.candidateId `shouldBe` Just candidate.id
|
|
dr.requirementId `shouldBe` Just req.id
|
|
deleteRecord hub
|
|
|
|
it "outcome is immutable: direct SQL update changes value (enforcement is at controller)" do
|
|
-- The controller's UpdateDecisionRecordAction uses fill without outcome field.
|
|
-- This test verifies the DB row can be read back correctly after creation.
|
|
hub <- newRecord @Hub
|
|
|> set #slug "p3-imm-hub" |> set #name "P3 Imm" |> set #domain "d"
|
|
|> createRecord
|
|
widget <- newRecord @Widget
|
|
|> set #hubId hub.id |> set #name "Imm Widget" |> set #widgetType "panel"
|
|
|> createRecord
|
|
candidate <- newRecord @RequirementCandidate
|
|
|> set #title "Immutable outcome" |> set #description "d"
|
|
|> set #sourceWidgetId widget.id |> set #category "friction"
|
|
|> set #status "accepted" |> createRecord
|
|
dr <- newRecord @DecisionRecord
|
|
|> set #title "Immutability test" |> set #rationale "r"
|
|
|> set #outcome "accepted" |> set #candidateId (Just candidate.id)
|
|
|> createRecord
|
|
fetched <- fetch dr.id
|
|
fetched.outcome `shouldBe` "accepted"
|
|
deleteRecord hub
|
|
|
|
-- ----------------------------------------------------------------
|
|
-- Phase 3: PolicyReference add and delete
|
|
-- ----------------------------------------------------------------
|
|
describe "PolicyReference" do
|
|
it "can add multiple policy references to a decision" do
|
|
hub <- newRecord @Hub
|
|
|> set #slug "p3-pr-hub" |> set #name "P3 PR" |> set #domain "d"
|
|
|> createRecord
|
|
widget <- newRecord @Widget
|
|
|> set #hubId hub.id |> set #name "PR Widget" |> set #widgetType "form"
|
|
|> createRecord
|
|
candidate <- newRecord @RequirementCandidate
|
|
|> set #title "PR candidate" |> set #description "d"
|
|
|> set #sourceWidgetId widget.id |> set #category "friction"
|
|
|> set #status "accepted" |> createRecord
|
|
dr <- newRecord @DecisionRecord
|
|
|> set #title "PR decision" |> set #rationale "r"
|
|
|> set #outcome "accepted" |> set #candidateId (Just candidate.id)
|
|
|> createRecord
|
|
pr1 <- newRecord @PolicyReference
|
|
|> set #decisionId dr.id |> set #policyScope "regulatory"
|
|
|> set #constraintNote (Just "GDPR Art 5")
|
|
|> createRecord
|
|
pr2 <- newRecord @PolicyReference
|
|
|> set #decisionId dr.id |> set #policyScope "architectural"
|
|
|> createRecord
|
|
refs <- query @PolicyReference |> filterWhere (#decisionId, dr.id) |> fetch
|
|
length refs `shouldBe` 2
|
|
deleteRecord pr1
|
|
refs2 <- query @PolicyReference |> filterWhere (#decisionId, dr.id) |> fetch
|
|
length refs2 `shouldBe` 1
|
|
deleteRecord hub
|
|
|
|
-- ----------------------------------------------------------------
|
|
-- Phase 3: ImplementationChangeReference add and delete
|
|
-- ----------------------------------------------------------------
|
|
describe "ImplementationChangeReference" do
|
|
it "can add multiple impl refs and delete individually" do
|
|
hub <- newRecord @Hub
|
|
|> set #slug "p3-ir-hub" |> set #name "P3 IR" |> set #domain "d"
|
|
|> createRecord
|
|
widget <- newRecord @Widget
|
|
|> set #hubId hub.id |> set #name "IR Widget" |> set #widgetType "table"
|
|
|> createRecord
|
|
candidate <- newRecord @RequirementCandidate
|
|
|> set #title "IR candidate" |> set #description "d"
|
|
|> set #sourceWidgetId widget.id |> set #category "friction"
|
|
|> set #status "accepted" |> createRecord
|
|
dr <- newRecord @DecisionRecord
|
|
|> set #title "IR decision" |> set #rationale "r"
|
|
|> set #outcome "accepted" |> set #candidateId (Just candidate.id)
|
|
|> createRecord
|
|
ir1 <- newRecord @ImplementationChangeReference
|
|
|> set #decisionId dr.id |> set #workItemRef "#42" |> set #system "github"
|
|
|> createRecord
|
|
ir2 <- newRecord @ImplementationChangeReference
|
|
|> set #decisionId dr.id |> set #workItemRef "PROJ-100" |> set #system "linear"
|
|
|> createRecord
|
|
refs <- query @ImplementationChangeReference
|
|
|> filterWhere (#decisionId, dr.id) |> fetch
|
|
length refs `shouldBe` 2
|
|
deleteRecord ir1
|
|
refs2 <- query @ImplementationChangeReference
|
|
|> filterWhere (#decisionId, dr.id) |> fetch
|
|
length refs2 `shouldBe` 1
|
|
deleteRecord hub
|
|
|
|
-- ----------------------------------------------------------------
|
|
-- Phase 3: Governance dashboard data fetch
|
|
-- ----------------------------------------------------------------
|
|
describe "Governance dashboard data fetch" do
|
|
it "returns correct decision counts for a hub" do
|
|
hub <- newRecord @Hub
|
|
|> set #slug "p3-gd-hub" |> set #name "P3 GD" |> set #domain "d"
|
|
|> createRecord
|
|
widget <- newRecord @Widget
|
|
|> set #hubId hub.id |> set #name "GD Widget" |> set #widgetType "panel"
|
|
|> createRecord
|
|
candidate <- newRecord @RequirementCandidate
|
|
|> set #title "GD candidate" |> set #description "d"
|
|
|> set #sourceWidgetId widget.id |> set #category "friction"
|
|
|> set #status "accepted" |> createRecord
|
|
req <- newRecord @Requirement
|
|
|> set #title candidate.title |> set #description candidate.description
|
|
|> set #sourceCandidateId candidate.id |> set #status "active"
|
|
|> createRecord
|
|
dr1 <- newRecord @DecisionRecord
|
|
|> set #title "GD decision 1" |> set #rationale "r"
|
|
|> set #outcome "accepted" |> set #requirementId (Just req.id)
|
|
|> createRecord
|
|
dr2 <- newRecord @DecisionRecord
|
|
|> set #title "GD decision 2" |> set #rationale "r"
|
|
|> set #outcome "rejected" |> set #requirementId (Just req.id)
|
|
|> createRecord
|
|
-- Verify fetch path used by governance dashboard action
|
|
widgets <- query @Widget |> filterWhere (#hubId, hub.id) |> fetch
|
|
candidates <- query @RequirementCandidate
|
|
|> filterWhereIn (#sourceWidgetId, map (.id) widgets) |> fetch
|
|
let acceptedCandidateIds = map (.id) (filter (\c -> c.status == "accepted") candidates)
|
|
reqs <- query @Requirement
|
|
|> filterWhereIn (#sourceCandidateId, acceptedCandidateIds) |> fetch
|
|
let reqIds = map (.id) reqs
|
|
decisions <- query @DecisionRecord
|
|
|> filterWhereIn (#requirementId, map Just reqIds) |> fetch
|
|
length decisions `shouldBe` 2
|
|
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
|