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:
48
Web/Controller/Annotations.hs
Normal file
48
Web/Controller/Annotations.hs
Normal file
@@ -0,0 +1,48 @@
|
||||
module Web.Controller.Annotations where
|
||||
|
||||
import Web.Types
|
||||
import Web.View.Annotations.Index
|
||||
import Web.View.Annotations.New
|
||||
import Generated.Types
|
||||
import IHP.Prelude
|
||||
import IHP.ControllerPrelude
|
||||
|
||||
validCategories :: [Text]
|
||||
validCategories = ["friction", "defect", "wish", "policy_concern", "doc_gap", "trust", "other"]
|
||||
|
||||
instance Controller AnnotationsController where
|
||||
beforeAction = ensureIsUser
|
||||
|
||||
action WidgetAnnotationsAction { widgetId } = do
|
||||
widget <- fetch widgetId
|
||||
annotations <- query @Annotation
|
||||
|> filterWhere (#widgetId, widgetId)
|
||||
|> orderByAsc #createdAt
|
||||
|> fetch
|
||||
render IndexView { widget, annotations }
|
||||
|
||||
action NewAnnotationAction { widgetId } = do
|
||||
widget <- fetch widgetId
|
||||
let annotation = newRecord @Annotation
|
||||
render NewView { widget, annotation }
|
||||
|
||||
action CreateAnnotationAction { widgetId } = do
|
||||
widget <- fetch widgetId
|
||||
mUser <- currentUserOrNothing
|
||||
let actorId = fmap (.id) mUser
|
||||
actorType = maybe "anonymous" (const "user") mUser
|
||||
|
||||
let annotation = newRecord @Annotation
|
||||
annotation
|
||||
|> fill @'["body", "category", "parentId", "widgetStateRef"]
|
||||
|> set #widgetId widgetId
|
||||
|> set #actorId (fmap (Id . unId) actorId)
|
||||
|> set #actorType actorType
|
||||
|> validateField #body nonEmpty
|
||||
|> validateField #category (`elem` validCategories)
|
||||
|> ifValid \case
|
||||
Left annotation -> render NewView { widget, annotation }
|
||||
Right annotation -> do
|
||||
createRecord annotation
|
||||
setSuccessMessage "Annotation added"
|
||||
redirectTo WidgetAnnotationsAction { widgetId }
|
||||
74
Web/Controller/Hubs.hs
Normal file
74
Web/Controller/Hubs.hs
Normal file
@@ -0,0 +1,74 @@
|
||||
module Web.Controller.Hubs where
|
||||
|
||||
import Web.Types
|
||||
import Web.View.Hubs.Index
|
||||
import Web.View.Hubs.Show
|
||||
import Web.View.Hubs.New
|
||||
import Web.View.Hubs.Edit
|
||||
import Generated.Types
|
||||
import IHP.Prelude
|
||||
import IHP.ControllerPrelude
|
||||
|
||||
instance Controller HubsController where
|
||||
beforeAction = ensureIsUser
|
||||
|
||||
action HubsAction = do
|
||||
hubs <- query @Hub |> orderByAsc #createdAt |> fetch
|
||||
render IndexView { hubs }
|
||||
|
||||
action NewHubAction = do
|
||||
let hub = newRecord @Hub
|
||||
render NewView { hub }
|
||||
|
||||
action ShowHubAction { hubId } = autoRefresh do
|
||||
hub <- fetch hubId
|
||||
widgets <- query @Widget
|
||||
|> filterWhere (#hubId, hubId)
|
||||
|> orderByAsc #name
|
||||
|> fetch
|
||||
widgetIds <- pure (map (.id) widgets)
|
||||
recentEvents <- sqlQuery
|
||||
"SELECT * FROM interaction_events WHERE widget_id = ANY(?) ORDER BY occurred_at DESC LIMIT 50"
|
||||
(Only (PGArray widgetIds))
|
||||
recentAnnotations <- sqlQuery
|
||||
"SELECT * FROM annotations WHERE widget_id = ANY(?) ORDER BY created_at DESC LIMIT 20"
|
||||
(Only (PGArray widgetIds))
|
||||
render ShowView { hub, widgets, recentEvents, recentAnnotations }
|
||||
|
||||
action CreateHubAction = do
|
||||
let hub = newRecord @Hub
|
||||
hub
|
||||
|> fill @'["slug", "name", "domain"]
|
||||
|> validateField #slug nonEmpty
|
||||
|> validateField #name nonEmpty
|
||||
|> validateField #domain nonEmpty
|
||||
|> ifValid \case
|
||||
Left hub -> render NewView { hub }
|
||||
Right hub -> do
|
||||
hub <- createRecord hub
|
||||
setSuccessMessage "Hub created"
|
||||
redirectTo ShowHubAction { hubId = hub.id }
|
||||
|
||||
action EditHubAction { hubId } = do
|
||||
hub <- fetch hubId
|
||||
render EditView { hub }
|
||||
|
||||
action UpdateHubAction { hubId } = do
|
||||
hub <- fetch hubId
|
||||
hub
|
||||
|> fill @'["slug", "name", "domain"]
|
||||
|> validateField #slug nonEmpty
|
||||
|> validateField #name nonEmpty
|
||||
|> validateField #domain nonEmpty
|
||||
|> ifValid \case
|
||||
Left hub -> render EditView { hub }
|
||||
Right hub -> do
|
||||
updateRecord hub
|
||||
setSuccessMessage "Hub updated"
|
||||
redirectTo ShowHubAction { hubId = hub.id }
|
||||
|
||||
action DeleteHubAction { hubId } = do
|
||||
hub <- fetch hubId
|
||||
deleteRecord hub
|
||||
setSuccessMessage "Hub deleted"
|
||||
redirectTo HubsAction
|
||||
55
Web/Controller/InteractionEvents.hs
Normal file
55
Web/Controller/InteractionEvents.hs
Normal file
@@ -0,0 +1,55 @@
|
||||
module Web.Controller.InteractionEvents where
|
||||
|
||||
import Web.Types
|
||||
import Generated.Types
|
||||
import IHP.Prelude
|
||||
import IHP.ControllerPrelude
|
||||
import Data.Aeson (object, (.=))
|
||||
import qualified Data.Text as T
|
||||
|
||||
-- Valid canonical event types
|
||||
validEventTypes :: [Text]
|
||||
validEventTypes =
|
||||
[ "viewed", "clicked", "submitted", "abandoned", "retried", "failed"
|
||||
, "commented", "flagged_confusing", "flagged_helpful"
|
||||
, "blocked_by_policy", "escalated"
|
||||
, "accepted_recommendation", "rejected_recommendation"
|
||||
]
|
||||
|
||||
instance Controller InteractionEventsController where
|
||||
action CreateInteractionEventAction { widgetId } = do
|
||||
eventType <- param @Text "event_type"
|
||||
unless (eventType `elem` validEventTypes) do
|
||||
respondJson (object ["error" .= ("unknown event_type" :: Text), "valid" .= validEventTypes])
|
||||
-- IHP stops here; the above respondJson sends 200 but we need 422
|
||||
-- Use renderWithStatus for proper 422:
|
||||
setStatus 422
|
||||
respondJson (object ["error" .= ("unknown event_type" :: Text)])
|
||||
|
||||
mUser <- currentUserOrNothing
|
||||
let actorId = fmap (.id) mUser
|
||||
actorType = maybe "anonymous" (const "user") mUser
|
||||
|
||||
actorTypeParam <- paramOrDefault @Text actorType "actor_type"
|
||||
viewContextRef <- paramOrNothing @Text "view_context_ref"
|
||||
metadataRaw <- paramOrDefault @Text "{}" "metadata"
|
||||
|
||||
let metadata = case readMay @Value (cs metadataRaw) of
|
||||
Just v -> v
|
||||
Nothing -> object []
|
||||
|
||||
event <- newRecord @InteractionEvent
|
||||
|> set #widgetId widgetId
|
||||
|> set #eventType eventType
|
||||
|> set #actorId (fmap (Id . unId) actorId)
|
||||
|> set #actorType actorTypeParam
|
||||
|> set #viewContextRef viewContextRef
|
||||
|> set #metadata metadata
|
||||
|> createRecord
|
||||
|
||||
respondJson (object
|
||||
[ "id" .= event.id
|
||||
, "widget_id" .= event.widgetId
|
||||
, "event_type" .= event.eventType
|
||||
, "occurred_at".= event.occurredAt
|
||||
])
|
||||
29
Web/Controller/Sessions.hs
Normal file
29
Web/Controller/Sessions.hs
Normal file
@@ -0,0 +1,29 @@
|
||||
module Web.Controller.Sessions where
|
||||
|
||||
import Web.Types
|
||||
import Web.View.Sessions.New
|
||||
import Generated.Types
|
||||
import IHP.LoginSupport.Helper.Controller
|
||||
import IHP.Prelude
|
||||
import IHP.ControllerPrelude
|
||||
|
||||
instance Controller SessionsController where
|
||||
action NewSessionAction = do
|
||||
let user = newRecord @User
|
||||
render NewView { user }
|
||||
|
||||
action CreateSessionAction = do
|
||||
(user, token) <- authenticate @User
|
||||
case user of
|
||||
Just user -> do
|
||||
setSession "userId" (show user.id)
|
||||
redirectTo HubsAction
|
||||
Nothing -> do
|
||||
setErrorMessage "Invalid email or password"
|
||||
redirectTo NewSessionAction
|
||||
|
||||
action DeleteSessionAction = do
|
||||
unsetSession "userId"
|
||||
redirectTo NewSessionAction
|
||||
|
||||
instance SessionsControllerConfig User
|
||||
106
Web/Controller/Widgets.hs
Normal file
106
Web/Controller/Widgets.hs
Normal file
@@ -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 }
|
||||
Reference in New Issue
Block a user