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>
107 lines
4.4 KiB
Haskell
107 lines
4.4 KiB
Haskell
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 }
|