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