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>
2026-03-27 01:42:43 +00:00
parent ff11913d5c
commit c560e541c7
26 changed files with 1591 additions and 12 deletions
--- a/Web/Controller/Widgets.hs
+++ b/Web/Controller/Widgets.hs
@@ -0,0 +1,106 @@
+module Web.Controller.Widgets where
+
+import Web.Types
+import Web.View.Widgets.Index
+import Web.View.Widgets.Show
+import Web.View.Widgets.New
+import Web.View.Widgets.Edit
+import Generated.Types
+import IHP.Prelude
+import IHP.ControllerPrelude
+import Data.Aeson (toJSON, object, (.=))
+
+instance Controller WidgetsController where
+    beforeAction = ensureIsUser
+
+    action WidgetsAction = do
+        widgets <- query @Widget |> orderByAsc #name |> fetch
+        hubs    <- query @Hub    |> fetch
+        render IndexView { widgets, hubs }
+
+    action NewWidgetAction = do
+        let widget = newRecord @Widget
+        hubs <- query @Hub |> fetch
+        render NewView { widget, hubs }
+
+    action ShowWidgetAction { widgetId } = do
+        widget   <- fetch widgetId
+        hub      <- fetch widget.hubId
+        versions <- query @WidgetVersion
+            |> filterWhere (#widgetId, widgetId)
+            |> orderByDesc #version
+            |> fetch
+        events   <- query @InteractionEvent
+            |> filterWhere (#widgetId, widgetId)
+            |> orderByDesc #occurredAt
+            |> limit 20
+            |> fetch
+        annotations <- query @Annotation
+            |> filterWhere (#widgetId, widgetId)
+            |> orderByAsc #createdAt
+            |> fetch
+        render ShowView { widget, hub, versions, events, annotations }
+
+    action CreateWidgetAction = do
+        let widget = newRecord @Widget
+        hubs <- query @Hub |> fetch
+        widget
+            |> fill @'["name", "widgetType", "hubId", "capabilityRef", "viewContext", "policyScope", "status"]
+            |> validateField #name nonEmpty
+            |> validateField #widgetType nonEmpty
+            |> ifValid \case
+                Left widget -> render NewView { widget, hubs }
+                Right widget -> do
+                    widget <- createRecord widget
+                    let snapshot = object
+                            [ "name"         .= widget.name
+                            , "widget_type"  .= widget.widgetType
+                            , "hub_id"       .= widget.hubId
+                            , "capability_ref" .= widget.capabilityRef
+                            , "view_context" .= widget.viewContext
+                            , "policy_scope" .= widget.policyScope
+                            , "status"       .= widget.status
+                            , "version"      .= widget.version
+                            ]
+                    newRecord @WidgetVersion
+                        |> set #widgetId widget.id
+                        |> set #version  1
+                        |> set #schemaSnapshot snapshot
+                        |> createRecord
+                    setSuccessMessage "Widget registered"
+                    redirectTo ShowWidgetAction { widgetId = widget.id }
+
+    action EditWidgetAction { widgetId } = do
+        widget <- fetch widgetId
+        hubs   <- query @Hub |> fetch
+        render EditView { widget, hubs }
+
+    action UpdateWidgetAction { widgetId } = do
+        widget <- fetch widgetId
+        hubs   <- query @Hub |> fetch
+        widget
+            |> fill @'["name", "widgetType", "hubId", "capabilityRef", "viewContext", "policyScope", "status"]
+            |> validateField #name nonEmpty
+            |> validateField #widgetType nonEmpty
+            |> ifValid \case
+                Left widget -> render EditView { widget, hubs }
+                Right widget -> do
+                    let newVersion = widget.version + 1
+                    widget <- widget |> set #version newVersion |> updateRecord
+                    let snapshot = object
+                            [ "name"           .= widget.name
+                            , "widget_type"    .= widget.widgetType
+                            , "hub_id"         .= widget.hubId
+                            , "capability_ref" .= widget.capabilityRef
+                            , "view_context"   .= widget.viewContext
+                            , "policy_scope"   .= widget.policyScope
+                            , "status"         .= widget.status
+                            , "version"        .= newVersion
+                            ]
+                    newRecord @WidgetVersion
+                        |> set #widgetId widget.id
+                        |> set #version  newVersion
+                        |> set #schemaSnapshot snapshot
+                        |> createRecord
+                    setSuccessMessage "Widget updated"
+                    redirectTo ShowWidgetAction { widgetId = widget.id }