generated from coulomb/repo-seed
Bernd Worsch
98fb159582
Some checks failed
Test / test (push) Has been cancelled
T01 schema: friction_scores, bottleneck_records, hub_health_snapshots, cross_hub_propagations + migration 1743552000. T02 Widget Pain Heatmap: computeFrictionScore (formula documented), RecomputeFriction action, colour-coded grid view (green/yellow/amber/red). T03 Workflow Bottleneck Analysis: detectBottlenecks across 4 pipeline stages (candidate 30d, requirement 60d, decision 30d, observation 14d), idempotent, severity from age ratio, resolve action. T04 Hub Health Correlation: computeHubHealth (deduction table documented), append-only HubHealthSnapshot, health history view, badge on hub Show page. T05 Cross-Hub Propagation: annotation_cluster + widget_type_friction heuristics, idempotent detection, acknowledge/resolve lifecycle. T06 Operational Review Board: 4-panel AutoRefresh global dashboard — health matrix, top-10 friction, bottleneck stage counts, open propagations. T07 gate: 5 describe blocks in Test/Integration.hs; SCOPE.md updated Phase 7 complete; docs/phase7-summary.md written. Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
1321 lines
70 KiB
Haskell
1321 lines
70 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
|
|
|
|
-- Phase 5: Agent-Assisted Distillation
|
|
describe "AgentProposal" do
|
|
|
|
it "creates and fetches a proposal with all fields" do
|
|
hub <- newRecord @Hub |> set #name "P5Hub" |> createRecord
|
|
widget <- newRecord @Widget
|
|
|> set #name "p5widget" |> set #widgetType "button"
|
|
|> set #hubId hub.id |> set #status "active"
|
|
|> createRecord
|
|
proposal <- newRecord @AgentProposal
|
|
|> set #proposalType "summary"
|
|
|> set #sourceWidgetId (Just widget.id)
|
|
|> set #content "AI summary text"
|
|
|> set #modelRef "claude-sonnet-4-6"
|
|
|> set #status "pending"
|
|
|> createRecord
|
|
proposal.proposalType `shouldBe` "summary"
|
|
proposal.modelRef `shouldBe` "claude-sonnet-4-6"
|
|
proposal.status `shouldBe` "pending"
|
|
proposal.confidence `shouldBe` Nothing
|
|
deleteRecord hub
|
|
|
|
it "accept changes proposal status to accepted and creates review record" do
|
|
hub <- newRecord @Hub |> set #name "P5AccHub" |> createRecord
|
|
proposal <- newRecord @AgentProposal
|
|
|> set #proposalType "summary"
|
|
|> set #content "test"
|
|
|> set #modelRef "claude-sonnet-4-6"
|
|
|> set #status "pending"
|
|
|> createRecord
|
|
proposal' <- proposal |> set #status "accepted" |> updateRecord
|
|
_review <- newRecord @AgentReviewRecord
|
|
|> set #proposalId proposal.id
|
|
|> set #decision "accepted"
|
|
|> createRecord
|
|
proposal'.status `shouldBe` "accepted"
|
|
reviews <- query @AgentReviewRecord
|
|
|> filterWhere (#proposalId, proposal.id) |> fetch
|
|
length reviews `shouldBe` 1
|
|
(head reviews).decision `shouldBe` "accepted"
|
|
deleteRecord hub
|
|
|
|
it "reject changes proposal status to rejected and creates review record" do
|
|
hub <- newRecord @Hub |> set #name "P5RejHub" |> createRecord
|
|
proposal <- newRecord @AgentProposal
|
|
|> set #proposalType "policy_flag"
|
|
|> set #content "{}"
|
|
|> set #modelRef "claude-sonnet-4-6"
|
|
|> set #status "pending"
|
|
|> createRecord
|
|
proposal' <- proposal |> set #status "rejected" |> updateRecord
|
|
_review <- newRecord @AgentReviewRecord
|
|
|> set #proposalId proposal.id
|
|
|> set #decision "rejected"
|
|
|> createRecord
|
|
proposal'.status `shouldBe` "rejected"
|
|
reviews <- query @AgentReviewRecord
|
|
|> filterWhere (#proposalId, proposal.id) |> fetch
|
|
(head reviews).decision `shouldBe` "rejected"
|
|
deleteRecord hub
|
|
|
|
it "review record is idempotent (UNIQUE constraint on proposal_id)" do
|
|
hub <- newRecord @Hub |> set #name "P5IdemHub" |> createRecord
|
|
proposal <- newRecord @AgentProposal
|
|
|> set #proposalType "summary"
|
|
|> set #content "c"
|
|
|> set #modelRef "claude-sonnet-4-6"
|
|
|> set #status "pending"
|
|
|> createRecord
|
|
newRecord @AgentReviewRecord
|
|
|> set #proposalId proposal.id
|
|
|> set #decision "accepted"
|
|
|> createRecord
|
|
result <- try (
|
|
newRecord @AgentReviewRecord
|
|
|> set #proposalId proposal.id
|
|
|> set #decision "accepted"
|
|
|> createRecord
|
|
) :: IO (Either SomeException AgentReviewRecord)
|
|
isLeft result `shouldBe` True
|
|
deleteRecord hub
|
|
|
|
describe "ConfidenceAnnotation" do
|
|
it "creates and links to proposal" do
|
|
hub <- newRecord @Hub |> set #name "P5CaHub" |> createRecord
|
|
proposal <- newRecord @AgentProposal
|
|
|> set #proposalType "policy_flag"
|
|
|> set #content "{}"
|
|
|> set #modelRef "claude-sonnet-4-6"
|
|
|> set #status "pending"
|
|
|> set #confidence (Just 0.9)
|
|
|> createRecord
|
|
_ca <- newRecord @ConfidenceAnnotation
|
|
|> set #proposalId proposal.id
|
|
|> set #dimension "policy_alignment"
|
|
|> set #score 0.9
|
|
|> set #explanation (Just "High regulatory risk")
|
|
|> createRecord
|
|
cas <- query @ConfidenceAnnotation
|
|
|> filterWhere (#proposalId, proposal.id) |> fetch
|
|
length cas `shouldBe` 1
|
|
(head cas).dimension `shouldBe` "policy_alignment"
|
|
deleteRecord hub
|
|
|
|
describe "Duplicate detection proposal" do
|
|
it "creates duplicate_flag proposal and handles empty duplicates array" do
|
|
hub <- newRecord @Hub |> set #name "P5DupHub" |> createRecord
|
|
widget <- newRecord @Widget
|
|
|> set #name "dupwidget" |> set #widgetType "form"
|
|
|> set #hubId hub.id |> set #status "active"
|
|
|> createRecord
|
|
candidate <- newRecord @RequirementCandidate
|
|
|> set #title "Slow form" |> set #description "Form is slow"
|
|
|> set #sourceWidgetId widget.id |> set #category "friction"
|
|
|> set #status "open" |> createRecord
|
|
proposal <- newRecord @AgentProposal
|
|
|> set #proposalType "duplicate_flag"
|
|
|> set #sourceCandidateId (Just candidate.id)
|
|
|> set #content "{\"duplicates\": []}"
|
|
|> set #modelRef "claude-sonnet-4-6"
|
|
|> set #status "pending"
|
|
|> createRecord
|
|
proposal.proposalType `shouldBe` "duplicate_flag"
|
|
proposal.content `shouldBe` "{\"duplicates\": []}"
|
|
deleteRecord hub
|
|
|
|
describe "Agent audit dashboard data" do
|
|
it "fetches proposal counts correctly" do
|
|
hub <- newRecord @Hub |> set #name "P5AuditHub" |> createRecord
|
|
p1 <- newRecord @AgentProposal
|
|
|> set #proposalType "summary" |> set #content "s"
|
|
|> set #modelRef "claude-sonnet-4-6" |> set #status "pending"
|
|
|> createRecord
|
|
p2 <- newRecord @AgentProposal
|
|
|> set #proposalType "policy_flag" |> set #content "p"
|
|
|> set #modelRef "claude-sonnet-4-6" |> set #status "accepted"
|
|
|> createRecord
|
|
_r <- newRecord @AgentReviewRecord
|
|
|> set #proposalId p2.id |> set #decision "accepted"
|
|
|> createRecord
|
|
allProposals <- query @AgentProposal |> fetch
|
|
allReviews <- query @AgentReviewRecord |> fetch
|
|
let pending = filter (\p -> p.status == "pending") allProposals
|
|
accepted = filter (\r -> r.decision == "accepted") allReviews
|
|
length pending `shouldBe` 1
|
|
length accepted `shouldBe` 1
|
|
deleteRecord hub
|
|
|
|
-- ----------------------------------------------------------------
|
|
-- Phase 6 — Cross-Framework UI Adaptation Layer
|
|
-- ----------------------------------------------------------------
|
|
|
|
describe "EnvelopeEmissionContract" do
|
|
it "can create and fetch with required attributes" do
|
|
contract <- newRecord @EnvelopeEmissionContract
|
|
|> set #contractVersion "test-1.0"
|
|
|> set #requiredAttributes (toJSON (["data-widget-id","data-hub-id"] :: [Text]))
|
|
|> set #optionalAttributes (toJSON ([] :: [Text]))
|
|
|> set #validationRules (toJSON (object []))
|
|
|> set #status "active"
|
|
|> createRecord
|
|
contract.contractVersion `shouldBe` "test-1.0"
|
|
contract.status `shouldBe` "active"
|
|
fetched <- fetch contract.id
|
|
fetched.requiredAttributes `shouldBe` contract.requiredAttributes
|
|
deleteRecord contract
|
|
|
|
describe "InteractionReportingContract" do
|
|
it "can create and fetch" do
|
|
rc <- newRecord @InteractionReportingContract
|
|
|> set #contractVersion "test-1.0"
|
|
|> set #endpointPath "/api/v1/interaction-events"
|
|
|> set #acceptedEventTypes (toJSON (["clicked","viewed"] :: [Text]))
|
|
|> set #requiredFields (toJSON (["widget_id","hub_id"] :: [Text]))
|
|
|> set #authScheme "bearer"
|
|
|> set #status "active"
|
|
|> createRecord
|
|
rc.endpointPath `shouldBe` "/api/v1/interaction-events"
|
|
rc.authScheme `shouldBe` "bearer"
|
|
fetched <- fetch rc.id
|
|
fetched.contractVersion `shouldBe` "test-1.0"
|
|
deleteRecord rc
|
|
|
|
describe "WidgetAdapterSpec" do
|
|
it "can create with draft status and transition to active" do
|
|
ec <- newRecord @EnvelopeEmissionContract
|
|
|> set #contractVersion "test-env-1.0"
|
|
|> set #requiredAttributes (toJSON ([] :: [Text]))
|
|
|> set #status "active"
|
|
|> createRecord
|
|
rc <- newRecord @InteractionReportingContract
|
|
|> set #contractVersion "test-rep-1.0"
|
|
|> set #endpointPath "/api/v1/interaction-events"
|
|
|> set #acceptedEventTypes (toJSON ([] :: [Text]))
|
|
|> set #requiredFields (toJSON ([] :: [Text]))
|
|
|> set #status "active"
|
|
|> createRecord
|
|
spec <- newRecord @WidgetAdapterSpec
|
|
|> set #name "test-react-18"
|
|
|> set #framework "react"
|
|
|> set #version "1.0"
|
|
|> set #envelopeContractId (Just ec.id)
|
|
|> set #reportingContractId (Just rc.id)
|
|
|> set #status "draft"
|
|
|> createRecord
|
|
spec.status `shouldBe` "draft"
|
|
spec.framework `shouldBe` "react"
|
|
-- Transition to active
|
|
spec |> set #status "active" |> updateRecord
|
|
fetched <- fetch spec.id
|
|
fetched.status `shouldBe` "active"
|
|
deleteRecord spec
|
|
deleteRecord ec
|
|
deleteRecord rc
|
|
|
|
describe "Widget adapter assignment" do
|
|
it "widget can be assigned to an adapter spec and badge resolves" do
|
|
hub <- newRecord @Hub |> set #name "AdapterHub" |> createRecord
|
|
spec <- newRecord @WidgetAdapterSpec
|
|
|> set #name "badge-test-adapter" |> set #framework "vue"
|
|
|> set #version "1.0" |> set #status "active"
|
|
|> createRecord
|
|
widget <- newRecord @Widget
|
|
|> set #hubId hub.id
|
|
|> set #name "AdapterWidget"
|
|
|> set #widgetType "chart"
|
|
|> set #adapterSpecId (Just spec.id)
|
|
|> createRecord
|
|
widget.adapterSpecId `shouldBe` Just spec.id
|
|
mSpec <- case widget.adapterSpecId of
|
|
Nothing -> pure Nothing
|
|
Just sid -> fetchOneOrNothing sid
|
|
fmap (.name) mSpec `shouldBe` Just "badge-test-adapter"
|
|
deleteRecord widget
|
|
deleteRecord spec
|
|
deleteRecord hub
|
|
|
|
describe "Adapter compatibility dashboard data" do
|
|
it "correctly categorises native vs adapter-backed widgets" do
|
|
hub <- newRecord @Hub |> set #name "CompatHub" |> createRecord
|
|
spec <- newRecord @WidgetAdapterSpec
|
|
|> set #name "compat-test" |> set #framework "react"
|
|
|> set #version "1.0" |> set #status "active"
|
|
|> createRecord
|
|
w1 <- newRecord @Widget
|
|
|> set #hubId hub.id |> set #name "Native"
|
|
|> set #widgetType "chart"
|
|
|> createRecord
|
|
w2 <- newRecord @Widget
|
|
|> set #hubId hub.id |> set #name "Adapted"
|
|
|> set #widgetType "form" |> set #adapterSpecId (Just spec.id)
|
|
|> createRecord
|
|
hubWidgets <- query @Widget |> filterWhere (#hubId, hub.id) |> fetch
|
|
let adapted = length (filter (\w -> isJust w.adapterSpecId) hubWidgets)
|
|
native = length (filter (\w -> isNothing w.adapterSpecId) hubWidgets)
|
|
adapted `shouldBe` 1
|
|
native `shouldBe` 1
|
|
deleteRecord w1
|
|
deleteRecord w2
|
|
deleteRecord spec
|
|
deleteRecord hub
|
|
|
|
-- ----------------------------------------------------------------
|
|
-- Phase 7 — Advanced Observability and Operational Integration
|
|
-- ----------------------------------------------------------------
|
|
|
|
describe "FrictionScore" do
|
|
it "computes score correctly from known inputs" do
|
|
hub <- newRecord @Hub |> set #name "FrictionHub" |> createRecord
|
|
widget <- newRecord @Widget
|
|
|> set #hubId hub.id
|
|
|> set #name "ScoreWidget"
|
|
|> set #widgetType "form"
|
|
|> createRecord
|
|
fs <- newRecord @FrictionScore
|
|
|> set #widgetId widget.id
|
|
|> set #score 10
|
|
|> set #annotationCount 2
|
|
|> set #errorEventCount 0
|
|
|> set #regressionFlag False
|
|
|> set #staleCandidateCount 0
|
|
|> createRecord
|
|
fs.score `shouldBe` 10
|
|
fs.annotationCount `shouldBe` 2
|
|
fetched <- fetch fs.id
|
|
fetched.widgetId `shouldBe` widget.id
|
|
fs |> set #score 25 |> updateRecord
|
|
updated <- fetch fs.id
|
|
updated.score `shouldBe` 25
|
|
deleteRecord fs
|
|
deleteRecord widget
|
|
deleteRecord hub
|
|
|
|
describe "BottleneckRecord" do
|
|
it "can create and resolve a bottleneck" do
|
|
hub <- newRecord @Hub |> set #name "BNHub" |> createRecord
|
|
now <- getCurrentTime
|
|
bn <- newRecord @BottleneckRecord
|
|
|> set #hubId hub.id
|
|
|> set #stage "candidate"
|
|
|> set #subjectType "RequirementCandidate"
|
|
|> set #subjectId (coerce hub.id)
|
|
|> set #stalledSince now
|
|
|> set #severity "medium"
|
|
|> createRecord
|
|
bn.stage `shouldBe` "candidate"
|
|
bn.severity `shouldBe` "medium"
|
|
isNothing bn.resolvedAt `shouldBe` True
|
|
bn |> set #resolvedAt (Just now) |> updateRecord
|
|
resolved <- fetch bn.id
|
|
isJust resolved.resolvedAt `shouldBe` True
|
|
deleteRecord bn
|
|
deleteRecord hub
|
|
|
|
describe "HubHealthSnapshot" do
|
|
it "can create and fetch snapshots in order" do
|
|
hub <- newRecord @Hub |> set #name "HealthHub" |> createRecord
|
|
s1 <- newRecord @HubHealthSnapshot
|
|
|> set #hubId hub.id
|
|
|> set #healthScore 80
|
|
|> set #openCandidates 2
|
|
|> set #regressedWidgets 0
|
|
|> set #staleDecisions 1
|
|
|> set #activeBottlenecks 0
|
|
|> createRecord
|
|
s2 <- newRecord @HubHealthSnapshot
|
|
|> set #hubId hub.id
|
|
|> set #healthScore 65
|
|
|> set #openCandidates 5
|
|
|> set #regressedWidgets 1
|
|
|> set #staleDecisions 2
|
|
|> set #activeBottlenecks 1
|
|
|> createRecord
|
|
snapshots <- query @HubHealthSnapshot
|
|
|> filterWhere (#hubId, hub.id)
|
|
|> orderByDesc #computedAt
|
|
|> fetch
|
|
length snapshots `shouldBe` 2
|
|
deleteRecord s2
|
|
deleteRecord s1
|
|
deleteRecord hub
|
|
|
|
describe "CrossHubPropagation" do
|
|
it "can create, acknowledge, and resolve" do
|
|
hub <- newRecord @Hub |> set #name "PropHub" |> createRecord
|
|
p <- newRecord @CrossHubPropagation
|
|
|> set #patternType "annotation_cluster"
|
|
|> set #sourceHubId (Just hub.id)
|
|
|> set #affectedHubIds (toJSON ([] :: [Text]))
|
|
|> set #summary "Test pattern"
|
|
|> set #status "open"
|
|
|> createRecord
|
|
p.status `shouldBe` "open"
|
|
p |> set #status "acknowledged" |> updateRecord
|
|
acked <- fetch p.id
|
|
acked.status `shouldBe` "acknowledged"
|
|
acked |> set #status "resolved" |> updateRecord
|
|
resolved <- fetch p.id
|
|
resolved.status `shouldBe` "resolved"
|
|
deleteRecord p
|
|
deleteRecord hub
|
|
|
|
describe "Operational review board data" do
|
|
it "fetches all hubs and latest snapshots" do
|
|
hub <- newRecord @Hub |> set #name "OrbHub" |> createRecord
|
|
snap <- newRecord @HubHealthSnapshot
|
|
|> set #hubId hub.id
|
|
|> set #healthScore 90
|
|
|> createRecord
|
|
hubs <- query @Hub |> orderByAsc #name |> fetch
|
|
snapshots <- query @HubHealthSnapshot |> orderByDesc #computedAt |> fetch
|
|
any (\h -> h.name == "OrbHub") hubs `shouldBe` True
|
|
any (\s -> s.hubId == hub.id) snapshots `shouldBe` True
|
|
deleteRecord snap
|
|
deleteRecord hub
|