generated from coulomb/repo-seed
feat(T02-T11): IHF Phase 1 schema, controllers, views, and helpers
- 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>
This commit is contained in:
@@ -4,20 +4,159 @@ 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.
|
||||
-- The DATABASE_URL env var is set automatically by `nix flake check`.
|
||||
-- See: https://ihp.digitallyinduced.com/Guide/testing.html
|
||||
-- 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`."
|
||||
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
|
||||
describe "Database" do
|
||||
it "can execute a query" do
|
||||
sqlExecDiscardResult "SELECT 1" ()
|
||||
|
||||
-- ----------------------------------------------------------------
|
||||
-- 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
|
||||
|
||||
Reference in New Issue
Block a user