generated from coulomb/repo-seed
Bernd Worsch
c560e541c7
- Schema: hubs, widgets, widget_versions, interaction_events (append-only trigger), annotations, users — single migration file - Web layer: Types, Routes, FrontController with auth + AutoRefresh layout - Controllers: Hubs (CRUD), Widgets (CRUD + versioning), InteractionEvents (JSON capture, canonical event_type validation), Annotations (threaded, append-only) - Sessions controller for IHP auth - Views: Hubs (index/show/new/edit), Widgets (index/show/new/edit), Annotations (index/new), Sessions (login) - widgetEnvelope helper with full data-* governance attributes - Integration tests: Hub CRUD, Widget versioning, event capture, append-only guard, annotation threading, validation Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
163 lines
7.9 KiB
Haskell
163 lines
7.9 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
|
|
|
|
-- 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
|