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 -- 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