feat(WP-0009): IHF GAAF Compliance Foundation — type registries, extension manifests, architectural contracts

Implements IHUB-WP-0009: closes four GAAF-2026 gaps before domain hub work begins.
- TypeRegistry helper + controllers/views (hub_kind, hub_capability_manifest)
- HubCapabilityManifest entity with validation and registry linkage
- ARCHITECTURE-LAYERS.md + CI-enforced boundary contracts
- Alembic migration 1743724800, fitness tests (Test/Architecture/)
- GAAF spec, Operational Architecture spec, domain hub extension guide
- Updates to CLAUDE.md, SCOPE.md, Schema.sql, Routes, FrontController, Types

state_hub_sync: pending (tunnel was STALE at completion time; run fix-consistency)

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>

Web/Controller/Annotations.hs

@@ -7,9 +7,7 @@ import Web.View.Annotations.Show
 import Generated.Types
 import IHP.Prelude
 import IHP.ControllerPrelude
-
-validCategories :: [Text]
-validCategories = ["friction", "defect", "wish", "policy_concern", "doc_gap", "trust", "other"]
+import Application.Helper.TypeRegistry (validateAnnotationCategory, activeAnnotationCategories)
 
 validSeverities :: [Text]
 validSeverities = ["low", "medium", "high", "critical"]
@@ -35,16 +33,21 @@ instance Controller AnnotationsController where
         render ShowView { widget, annotation, mCandidate }
 
     action NewAnnotationAction { widgetId } = do
-        widget <- fetch widgetId
+        widget     <- fetch widgetId
+        categories <- activeAnnotationCategories
         let annotation = newRecord @Annotation
-        render NewView { widget, annotation }
+        render NewView { widget, annotation, categories }
 
     action CreateAnnotationAction { widgetId } = do
-        widget  <- fetch widgetId
-        mUser   <- currentUserOrNothing
+        widget     <- fetch widgetId
+        categories <- activeAnnotationCategories
+        mUser      <- currentUserOrNothing
         let actorId   = fmap (.id) mUser
             actorType = maybe "anonymous" (const "user") mUser
 
+        category <- paramOrDefault @Text "" "category"
+        categoryResult <- validateAnnotationCategory category
+
         let annotation = newRecord @Annotation
         annotation
             |> fill @'["body", "category", "severity", "parentId", "widgetStateRef"]
@@ -52,10 +55,12 @@ instance Controller AnnotationsController where
             |> set #actorId   (fmap (Id . unId) actorId)
             |> set #actorType actorType
             |> validateField #body nonEmpty
-            |> validateField #category (`elem` validCategories)
             |> validateField #severity (`elem` validSeverities)
+            |> (case categoryResult of
+                    Left msg -> attachFailure #category msg
+                    Right () -> id)
             |> ifValid \case
-                Left annotation -> render NewView { widget, annotation }
+                Left annotation -> render NewView { widget, annotation, categories }
                 Right annotation -> do
                     createRecord annotation
                     setSuccessMessage "Annotation added"

Web/Controller/ApiInteractionEvents.hs

@@ -7,10 +7,7 @@ import IHP.ControllerPrelude
 import Data.Aeson (object, (.=))
 import qualified Data.Text as T
 import Network.Wai (requestMethod, requestHeaders)
-
--- | Accepted event types per InteractionReportingContract v1.0
-apiAcceptedEventTypes :: [Text]
-apiAcceptedEventTypes = ["clicked", "viewed", "submitted", "dismissed", "errored"]
+import Application.Helper.TypeRegistry (validateEventType)
 
 instance Controller ApiInteractionEventsController where
 
@@ -65,12 +62,15 @@ createEventForHub hub = do
     let Just wIdText = widgetIdText
         Just evType  = eventType
 
-    unless (evType `elem` apiAcceptedEventTypes) do
-        setStatus 422
-        respondJson (object
-            [ "error"    .= ("Unacceptable event_type" :: Text)
-            , "accepted" .= apiAcceptedEventTypes
-            ])
+    evTypeResult <- liftIO $ validateEventType evType
+    case evTypeResult of
+        Left _ -> do
+            setStatus 422
+            respondJson (object
+                [ "error"    .= ("Unacceptable event_type" :: Text)
+                , "hint"     .= ("Register the event type in the Type Registry before submitting" :: Text)
+                ])
+        Right () -> pure ()
 
     -- Resolve widget — must belong to this hub.
     case readMay wIdText of

Web/Controller/HubCapabilityManifests.hs

@@ -0,0 +1,169 @@
+module Web.Controller.HubCapabilityManifests where
+
+import Web.Types
+import Web.View.HubCapabilityManifests.Index
+import Web.View.HubCapabilityManifests.Show
+import Web.View.HubCapabilityManifests.New
+import Web.View.HubCapabilityManifests.Edit
+import Generated.Types
+import IHP.Prelude
+import IHP.ControllerPrelude
+import Data.Aeson (Value, Array, decode, encode)
+import qualified Data.Vector as V
+import Data.Maybe (mapMaybe)
+
+instance Controller HubCapabilityManifestsController where
+    beforeAction = ensureIsUser
+
+    action HubCapabilityManifestsAction = autoRefresh do
+        manifests <- query @HubCapabilityManifest
+            |> orderByDesc #createdAt
+            |> fetch
+        hubs <- query @Hub |> fetch
+        render IndexView { manifests, hubs }
+
+    action ShowHubCapabilityManifestAction { hubCapabilityManifestId } = do
+        manifest <- fetch hubCapabilityManifestId
+        hub      <- fetch manifest.hubId
+        render ShowView { manifest, hub }
+
+    action NewHubCapabilityManifestAction = do
+        mHubId <- paramOrNothing @(Id Hub) "hubId"
+        hubs   <- query @Hub |> orderByAsc #name |> fetch
+        let manifest = newRecord @HubCapabilityManifest
+        case mHubId of
+            Just hubId -> do
+                -- Check if a manifest already exists for this hub
+                existing <- query @HubCapabilityManifest
+                    |> filterWhere (#hubId, hubId)
+                    |> fetchOneOrNothing
+                case existing of
+                    Just m -> redirectTo EditHubCapabilityManifestAction { hubCapabilityManifestId = m.id }
+                    Nothing -> render NewView { manifest = manifest |> set #hubId hubId, hubs }
+            Nothing -> render NewView { manifest, hubs }
+
+    action CreateHubCapabilityManifestAction = do
+        hubs <- query @Hub |> orderByAsc #name |> fetch
+        let manifest = newRecord @HubCapabilityManifest
+        manifest
+            |> fill @'["hubId", "manifestVersion", "capabilityDescription", "contact"]
+            |> set #status "draft"
+            |> validateField #hubId nonEmpty
+            |> ifValid \case
+                Left manifest -> render NewView { manifest, hubs }
+                Right manifest -> do
+                    manifest <- createRecord manifest
+                    setSuccessMessage "Capability manifest created (draft)"
+                    redirectTo EditHubCapabilityManifestAction { hubCapabilityManifestId = manifest.id }
+
+    action EditHubCapabilityManifestAction { hubCapabilityManifestId } = do
+        manifest <- fetch hubCapabilityManifestId
+        hub      <- fetch manifest.hubId
+        widgetTypeEntries    <- sqlQuery "SELECT * FROM widget_type_registry WHERE status = 'active' ORDER BY label ASC" ()
+        eventTypeEntries     <- sqlQuery "SELECT * FROM event_type_registry WHERE status = 'active' ORDER BY label ASC" ()
+        categoryEntries      <- sqlQuery "SELECT * FROM annotation_category_registry WHERE status = 'active' ORDER BY label ASC" ()
+        policyScopeEntries   <- sqlQuery "SELECT * FROM policy_scope_registry WHERE status = 'active' ORDER BY label ASC" ()
+        render EditView { manifest, hub, widgetTypeEntries, eventTypeEntries, categoryEntries, policyScopeEntries }
+
+    action UpdateHubCapabilityManifestAction { hubCapabilityManifestId } = do
+        manifest <- fetch hubCapabilityManifestId
+        hub      <- fetch manifest.hubId
+        widgetTypeEntries    <- sqlQuery "SELECT * FROM widget_type_registry WHERE status = 'active' ORDER BY label ASC" ()
+        eventTypeEntries     <- sqlQuery "SELECT * FROM event_type_registry WHERE status = 'active' ORDER BY label ASC" ()
+        categoryEntries      <- sqlQuery "SELECT * FROM annotation_category_registry WHERE status = 'active' ORDER BY label ASC" ()
+        policyScopeEntries   <- sqlQuery "SELECT * FROM policy_scope_registry WHERE status = 'active' ORDER BY label ASC" ()
+        when (manifest.status == "active") do
+            setErrorMessage "Active manifests are read-only. Retire the current manifest and create a new draft to amend."
+            redirectTo ShowHubCapabilityManifestAction { hubCapabilityManifestId }
+        manifest
+            |> fill @'["manifestVersion", "capabilityDescription", "contact",
+                       "declaredWidgetTypes", "declaredEventTypes",
+                       "declaredAnnotationCategories", "declaredPolicyScopes"]
+            |> ifValid \case
+                Left manifest -> render EditView { manifest, hub, widgetTypeEntries, eventTypeEntries, categoryEntries, policyScopeEntries }
+                Right manifest -> do
+                    updateRecord manifest
+                    setSuccessMessage "Manifest updated"
+                    redirectTo EditHubCapabilityManifestAction { hubCapabilityManifestId }
+
+    action ActivateManifestAction { hubCapabilityManifestId } = do
+        manifest <- fetch hubCapabilityManifestId
+        hub      <- fetch manifest.hubId
+
+        -- Collect declared type names from JSONB arrays
+        let wTypes  = jsonArrayTexts manifest.declaredWidgetTypes
+            eTypes  = jsonArrayTexts manifest.declaredEventTypes
+            cats    = jsonArrayTexts manifest.declaredAnnotationCategories
+            scopes  = jsonArrayTexts manifest.declaredPolicyScopes
+
+        -- Conflict detection: check that each declared name is either
+        -- unregistered or already owned by this hub.
+        conflicts <- fmap concat $ mapM (checkConflict "widget_type_registry" hub.id) wTypes
+        eConflicts <- fmap concat $ mapM (checkConflict "event_type_registry" hub.id) eTypes
+        cConflicts <- fmap concat $ mapM (checkConflict "annotation_category_registry" hub.id) cats
+        pConflicts <- fmap concat $ mapM (checkConflict "policy_scope_registry" hub.id) scopes
+        let allConflicts = conflicts <> eConflicts <> cConflicts <> pConflicts
+
+        if not (null allConflicts)
+            then do
+                setErrorMessage ("Activation blocked — type name conflicts: " <> intercalate ", " allConflicts)
+                redirectTo ShowHubCapabilityManifestAction { hubCapabilityManifestId }
+            else do
+                -- Register declared types (idempotent — skip if already present)
+                mapM_ (upsertType "widget_type_registry" hub.id) wTypes
+                mapM_ (upsertType "event_type_registry" hub.id) eTypes
+                mapM_ (upsertType "annotation_category_registry" hub.id) cats
+                mapM_ (upsertType "policy_scope_registry" hub.id) scopes
+                now <- getCurrentTime
+                manifest |> set #status "active" |> set #activatedAt (Just now) |> updateRecord
+                setSuccessMessage "Manifest activated — all declared types are now registered"
+                redirectTo ShowHubCapabilityManifestAction { hubCapabilityManifestId }
+
+    action RetireManifestAction { hubCapabilityManifestId } = do
+        manifest <- fetch hubCapabilityManifestId
+        manifest |> set #status "retired" |> updateRecord
+        setSuccessMessage "Manifest retired. Types remain in registry but this manifest is no longer current."
+        redirectTo HubCapabilityManifestsAction
+
+-- | Extract text values from a JSONB array (e.g. '["foo","bar"]').
+jsonArrayTexts :: Value -> [Text]
+jsonArrayTexts val = case val of
+    _ -> case decode (encode val) of
+        Just (arr :: Array) -> mapMaybe extractText (V.toList arr)
+        Nothing -> []
+  where
+    extractText (String t) = Just t
+    extractText _          = Nothing
+
+-- | Check if 'name' in 'tableName' is owned by a different hub.
+--   Returns [] if no conflict, or [error message] if conflict.
+checkConflict ::
+    (?modelContext :: ModelContext) =>
+    Text -> Id Hub -> Text -> IO [Text]
+checkConflict tableName hubId name = do
+    rows <- sqlQuery
+        ("SELECT owner_hub_id FROM " <> tableName <> " WHERE name = ?")
+        (Only name)
+    case rows of
+        [] -> pure []
+        [Only Nothing] -> pure []  -- framework-level, no owner conflict
+        [Only (Just ownerId)] ->
+            if ownerId == hubId
+                then pure []
+                else pure ["Type '" <> name <> "' in " <> tableName <> " is already owned by another hub"]
+        _ -> pure []
+
+-- | Insert a type name into the registry table if it doesn't exist.
+upsertType ::
+    (?modelContext :: ModelContext) =>
+    Text -> Id Hub -> Text -> IO ()
+upsertType tableName hubId name =
+    sqlExec
+        ("INSERT INTO " <> tableName <> " (name, label, owner_hub_id, status) "
+         <> "VALUES (?, ?, ?, 'active') ON CONFLICT (name) DO NOTHING")
+        (name, name, hubId)
+
+intercalate :: Text -> [Text] -> Text
+intercalate _ []     = ""
+intercalate _ [x]    = x
+intercalate sep (x:xs) = x <> sep <> intercalate sep xs

Web/Controller/HubRoutingRules.hs

@@ -10,6 +10,7 @@ import Generated.Types
 import IHP.Prelude
 import IHP.ControllerPrelude
 import Application.Helper.RoutingEngine (applyRoutingRules)
+import Application.Helper.TypeRegistry (validateWidgetType, validateAnnotationCategory)
 
 instance Controller HubRoutingRulesController where
     beforeAction = ensureIsUser
@@ -33,10 +34,16 @@ instance Controller HubRoutingRulesController where
     action CreateHubRoutingRuleAction = do
         let rule = newRecord @HubRoutingRule
         hubs <- query @Hub |> orderByAsc #name |> fetch
+        mMatchWidgetType <- paramOrNothing @Text "matchWidgetType"
+        mMatchCategory   <- paramOrNothing @Text "matchCategory"
+        wtResult  <- case mMatchWidgetType of { Nothing -> pure (Right ()); Just "" -> pure (Right ()); Just t -> liftIO (validateWidgetType t) }
+        catResult <- case mMatchCategory   of { Nothing -> pure (Right ()); Just "" -> pure (Right ()); Just c -> liftIO (validateAnnotationCategory c) }
         rule
             |> fill @'["sourceHubId","targetHubId","matchCategory","matchWidgetType","priority","notes"]
             |> validateField #sourceHubId nonEmpty
             |> validateField #targetHubId nonEmpty
+            |> (case wtResult  of { Left msg -> attachFailure #matchWidgetType msg; Right () -> id })
+            |> (case catResult of { Left msg -> attachFailure #matchCategory msg;   Right () -> id })
             |> ifValid \case
                 Left r  -> render NewView { rule = r, hubs }
                 Right r -> do
@@ -52,8 +59,14 @@ instance Controller HubRoutingRulesController where
     action UpdateHubRoutingRuleAction { hubRoutingRuleId } = do
         rule <- fetch hubRoutingRuleId
         hubs <- query @Hub |> orderByAsc #name |> fetch
+        mMatchWidgetType <- paramOrNothing @Text "matchWidgetType"
+        mMatchCategory   <- paramOrNothing @Text "matchCategory"
+        wtResult  <- case mMatchWidgetType of { Nothing -> pure (Right ()); Just "" -> pure (Right ()); Just t -> liftIO (validateWidgetType t) }
+        catResult <- case mMatchCategory   of { Nothing -> pure (Right ()); Just "" -> pure (Right ()); Just c -> liftIO (validateAnnotationCategory c) }
         rule
             |> fill @'["matchCategory","matchWidgetType","priority","notes"]
+            |> (case wtResult  of { Left msg -> attachFailure #matchWidgetType msg; Right () -> id })
+            |> (case catResult of { Left msg -> attachFailure #matchCategory msg;   Right () -> id })
             |> ifValid \case
                 Left r  -> render EditView { rule = r, hubs }
                 Right r -> do

Web/Controller/Hubs.hs

@@ -46,15 +46,20 @@ instance Controller HubsController where
         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 }
+        mManifest <- query @HubCapabilityManifest
+            |> filterWhere (#hubId, hubId)
+            |> fetchOneOrNothing
+        render ShowView { hub, widgets, recentEvents, recentAnnotations, mManifest }
 
     action CreateHubAction = do
         let hub = newRecord @Hub
         hub
-            |> fill @'["slug", "name", "domain"]
+            |> fill @'["slug", "name", "domain", "hubKind"]
             |> validateField #slug nonEmpty
             |> validateField #name nonEmpty
             |> validateField #domain nonEmpty
+            |> validateField #hubKind (`elem` ["domain", "shared"])
+            -- 'framework' cannot be set via the UI
             |> ifValid \case
                 Left hub -> render NewView { hub }
                 Right hub -> do
@@ -69,10 +74,11 @@ instance Controller HubsController where
     action UpdateHubAction { hubId } = do
         hub <- fetch hubId
         hub
-            |> fill @'["slug", "name", "domain"]
+            |> fill @'["slug", "name", "domain", "hubKind"]
             |> validateField #slug nonEmpty
             |> validateField #name nonEmpty
             |> validateField #domain nonEmpty
+            |> validateField #hubKind (`elem` ["framework", "domain", "shared"])
             |> ifValid \case
                 Left hub -> render EditView { hub }
                 Right hub -> do

Web/Controller/TypeRegistries.hs

@@ -0,0 +1,278 @@
+module Web.Controller.TypeRegistries where
+
+import Web.Types
+import Web.View.TypeRegistries.WidgetTypes
+import Web.View.TypeRegistries.EventTypes
+import Web.View.TypeRegistries.AnnotationCategories
+import Web.View.TypeRegistries.PolicyScopes
+import Generated.Types
+import IHP.Prelude
+import IHP.ControllerPrelude
+
+instance Controller TypeRegistriesController where
+    beforeAction = ensureIsUser
+
+    -- ── Widget Types ─────────────────────────────────────────────────────────
+
+    action WidgetTypeRegistryAction = do
+        entries <- query @WidgetTypeRegistry
+            |> orderByAsc #label
+            |> fetch
+        hubs <- query @Hub |> fetch
+        render WidgetTypesView { entries, hubs }
+
+    action ShowWidgetTypeAction { widgetTypeRegistryId } = do
+        entry <- fetch widgetTypeRegistryId
+        mOwner <- case entry.ownerHubId of
+            Nothing  -> pure Nothing
+            Just hid -> fmap Just (fetch hid)
+        render ShowWidgetTypeView { entry, mOwner }
+
+    action NewWidgetTypeAction = do
+        let entry = newRecord @WidgetTypeRegistry
+        hubs <- query @Hub |> fetch
+        render NewWidgetTypeView { entry, hubs }
+
+    action CreateWidgetTypeAction = do
+        let entry = newRecord @WidgetTypeRegistry
+        hubs <- query @Hub |> fetch
+        entry
+            |> fill @'["name", "label", "description", "ownerHubId"]
+            |> validateField #name nonEmpty
+            |> validateField #label nonEmpty
+            |> ifValid \case
+                Left entry -> render NewWidgetTypeView { entry, hubs }
+                Right entry -> do
+                    createRecord entry
+                    setSuccessMessage ("Widget type '" <> entry.name <> "' registered")
+                    redirectTo WidgetTypeRegistryAction
+
+    action EditWidgetTypeAction { widgetTypeRegistryId } = do
+        entry <- fetch widgetTypeRegistryId
+        hubs <- query @Hub |> fetch
+        render EditWidgetTypeView { entry, hubs }
+
+    action UpdateWidgetTypeAction { widgetTypeRegistryId } = do
+        entry <- fetch widgetTypeRegistryId
+        hubs <- query @Hub |> fetch
+        -- name is immutable after creation
+        entry
+            |> fill @'["label", "description", "ownerHubId"]
+            |> validateField #label nonEmpty
+            |> ifValid \case
+                Left entry -> render EditWidgetTypeView { entry, hubs }
+                Right entry -> do
+                    updateRecord entry
+                    setSuccessMessage "Widget type updated"
+                    redirectTo WidgetTypeRegistryAction
+
+    action DeprecateWidgetTypeAction { widgetTypeRegistryId } = do
+        entry <- fetch widgetTypeRegistryId
+        replacedBy <- param @Text "deprecated_in_favour_of"
+        when (null replacedBy) do
+            setErrorMessage "You must specify the replacement type name"
+            redirectTo WidgetTypeRegistryAction
+        entry
+            |> set #status "deprecated"
+            |> set #deprecatedInFavourOf (Just replacedBy)
+            |> updateRecord
+        setSuccessMessage ("Widget type '" <> entry.name <> "' deprecated")
+        redirectTo WidgetTypeRegistryAction
+
+    -- ── Event Types ──────────────────────────────────────────────────────────
+
+    action EventTypeRegistryAction = do
+        entries <- query @EventTypeRegistry
+            |> orderByAsc #label
+            |> fetch
+        hubs <- query @Hub |> fetch
+        render EventTypesView { entries, hubs }
+
+    action ShowEventTypeAction { eventTypeRegistryId } = do
+        entry <- fetch eventTypeRegistryId
+        mOwner <- case entry.ownerHubId of
+            Nothing  -> pure Nothing
+            Just hid -> fmap Just (fetch hid)
+        render ShowEventTypeView { entry, mOwner }
+
+    action NewEventTypeAction = do
+        let entry = newRecord @EventTypeRegistry
+        hubs <- query @Hub |> fetch
+        render NewEventTypeView { entry, hubs }
+
+    action CreateEventTypeAction = do
+        let entry = newRecord @EventTypeRegistry
+        hubs <- query @Hub |> fetch
+        entry
+            |> fill @'["name", "label", "description", "ownerHubId"]
+            |> validateField #name nonEmpty
+            |> validateField #label nonEmpty
+            |> ifValid \case
+                Left entry -> render NewEventTypeView { entry, hubs }
+                Right entry -> do
+                    createRecord entry
+                    setSuccessMessage ("Event type '" <> entry.name <> "' registered")
+                    redirectTo EventTypeRegistryAction
+
+    action EditEventTypeAction { eventTypeRegistryId } = do
+        entry <- fetch eventTypeRegistryId
+        hubs <- query @Hub |> fetch
+        render EditEventTypeView { entry, hubs }
+
+    action UpdateEventTypeAction { eventTypeRegistryId } = do
+        entry <- fetch eventTypeRegistryId
+        hubs <- query @Hub |> fetch
+        entry
+            |> fill @'["label", "description", "ownerHubId"]
+            |> validateField #label nonEmpty
+            |> ifValid \case
+                Left entry -> render EditEventTypeView { entry, hubs }
+                Right entry -> do
+                    updateRecord entry
+                    setSuccessMessage "Event type updated"
+                    redirectTo EventTypeRegistryAction
+
+    action DeprecateEventTypeAction { eventTypeRegistryId } = do
+        entry <- fetch eventTypeRegistryId
+        replacedBy <- param @Text "deprecated_in_favour_of"
+        when (null replacedBy) do
+            setErrorMessage "You must specify the replacement type name"
+            redirectTo EventTypeRegistryAction
+        entry
+            |> set #status "deprecated"
+            |> set #deprecatedInFavourOf (Just replacedBy)
+            |> updateRecord
+        setSuccessMessage ("Event type '" <> entry.name <> "' deprecated")
+        redirectTo EventTypeRegistryAction
+
+    -- ── Annotation Categories ────────────────────────────────────────────────
+
+    action AnnotationCategoryRegistryAction = do
+        entries <- query @AnnotationCategoryRegistry
+            |> orderByAsc #label
+            |> fetch
+        hubs <- query @Hub |> fetch
+        render AnnotationCategoriesView { entries, hubs }
+
+    action ShowAnnotationCategoryAction { annotationCategoryRegistryId } = do
+        entry <- fetch annotationCategoryRegistryId
+        mOwner <- case entry.ownerHubId of
+            Nothing  -> pure Nothing
+            Just hid -> fmap Just (fetch hid)
+        render ShowAnnotationCategoryView { entry, mOwner }
+
+    action NewAnnotationCategoryAction = do
+        let entry = newRecord @AnnotationCategoryRegistry
+        hubs <- query @Hub |> fetch
+        render NewAnnotationCategoryView { entry, hubs }
+
+    action CreateAnnotationCategoryAction = do
+        let entry = newRecord @AnnotationCategoryRegistry
+        hubs <- query @Hub |> fetch
+        entry
+            |> fill @'["name", "label", "description", "ownerHubId"]
+            |> validateField #name nonEmpty
+            |> validateField #label nonEmpty
+            |> ifValid \case
+                Left entry -> render NewAnnotationCategoryView { entry, hubs }
+                Right entry -> do
+                    createRecord entry
+                    setSuccessMessage ("Annotation category '" <> entry.name <> "' registered")
+                    redirectTo AnnotationCategoryRegistryAction
+
+    action EditAnnotationCategoryAction { annotationCategoryRegistryId } = do
+        entry <- fetch annotationCategoryRegistryId
+        hubs <- query @Hub |> fetch
+        render EditAnnotationCategoryView { entry, hubs }
+
+    action UpdateAnnotationCategoryAction { annotationCategoryRegistryId } = do
+        entry <- fetch annotationCategoryRegistryId
+        hubs <- query @Hub |> fetch
+        entry
+            |> fill @'["label", "description", "ownerHubId"]
+            |> validateField #label nonEmpty
+            |> ifValid \case
+                Left entry -> render EditAnnotationCategoryView { entry, hubs }
+                Right entry -> do
+                    updateRecord entry
+                    setSuccessMessage "Annotation category updated"
+                    redirectTo AnnotationCategoryRegistryAction
+
+    action DeprecateAnnotationCategoryAction { annotationCategoryRegistryId } = do
+        entry <- fetch annotationCategoryRegistryId
+        replacedBy <- param @Text "deprecated_in_favour_of"
+        when (null replacedBy) do
+            setErrorMessage "You must specify the replacement category name"
+            redirectTo AnnotationCategoryRegistryAction
+        entry
+            |> set #status "deprecated"
+            |> set #deprecatedInFavourOf (Just replacedBy)
+            |> updateRecord
+        setSuccessMessage ("Annotation category '" <> entry.name <> "' deprecated")
+        redirectTo AnnotationCategoryRegistryAction
+
+    -- ── Policy Scopes ────────────────────────────────────────────────────────
+
+    action PolicyScopeRegistryAction = do
+        entries <- query @PolicyScopeRegistry
+            |> orderByAsc #label
+            |> fetch
+        hubs <- query @Hub |> fetch
+        render PolicyScopesView { entries, hubs }
+
+    action ShowPolicyScopeAction { policyScopeRegistryId } = do
+        entry <- fetch policyScopeRegistryId
+        mOwner <- case entry.ownerHubId of
+            Nothing  -> pure Nothing
+            Just hid -> fmap Just (fetch hid)
+        render ShowPolicyScopeView { entry, mOwner }
+
+    action NewPolicyScopeAction = do
+        let entry = newRecord @PolicyScopeRegistry
+        hubs <- query @Hub |> fetch
+        render NewPolicyScopeView { entry, hubs }
+
+    action CreatePolicyScopeAction = do
+        let entry = newRecord @PolicyScopeRegistry
+        hubs <- query @Hub |> fetch
+        entry
+            |> fill @'["name", "label", "description", "ownerHubId"]
+            |> validateField #name nonEmpty
+            |> validateField #label nonEmpty
+            |> ifValid \case
+                Left entry -> render NewPolicyScopeView { entry, hubs }
+                Right entry -> do
+                    createRecord entry
+                    setSuccessMessage ("Policy scope '" <> entry.name <> "' registered")
+                    redirectTo PolicyScopeRegistryAction
+
+    action EditPolicyScopeAction { policyScopeRegistryId } = do
+        entry <- fetch policyScopeRegistryId
+        hubs <- query @Hub |> fetch
+        render EditPolicyScopeView { entry, hubs }
+
+    action UpdatePolicyScopeAction { policyScopeRegistryId } = do
+        entry <- fetch policyScopeRegistryId
+        hubs <- query @Hub |> fetch
+        entry
+            |> fill @'["label", "description", "ownerHubId"]
+            |> validateField #label nonEmpty
+            |> ifValid \case
+                Left entry -> render EditPolicyScopeView { entry, hubs }
+                Right entry -> do
+                    updateRecord entry
+                    setSuccessMessage "Policy scope updated"
+                    redirectTo PolicyScopeRegistryAction
+
+    action DeprecatePolicyScopeAction { policyScopeRegistryId } = do
+        entry <- fetch policyScopeRegistryId
+        replacedBy <- param @Text "deprecated_in_favour_of"
+        when (null replacedBy) do
+            setErrorMessage "You must specify the replacement scope name"
+            redirectTo PolicyScopeRegistryAction
+        entry
+            |> set #status "deprecated"
+            |> set #deprecatedInFavourOf (Just replacedBy)
+            |> updateRecord
+        setSuccessMessage ("Policy scope '" <> entry.name <> "' deprecated")
+        redirectTo PolicyScopeRegistryAction

Web/Controller/Widgets.hs

@@ -10,6 +10,7 @@ import IHP.Prelude
 import IHP.ControllerPrelude
 import Data.Aeson (toJSON, object, (.=))
 import Application.Helper.Controller (isInRegression, widgetCycleCounts, callClaudeApi)
+import Application.Helper.TypeRegistry (validateWidgetType, validatePolicyScope, activeWidgetTypes, activePolicyScopes)
 import Data.List (intercalate)
 
 instance Controller WidgetsController where
@@ -27,7 +28,9 @@ instance Controller WidgetsController where
             |> filterWhere (#status, "active")
             |> orderByAsc #name
             |> fetch
-        render NewView { widget, hubs, adapterSpecs }
+        (fwTypes, ownedTypes) <- activeWidgetTypes
+        policyScopes <- activePolicyScopes
+        render NewView { widget, hubs, adapterSpecs, widgetTypes = fwTypes <> ownedTypes, policyScopes }
 
     action ShowWidgetAction { widgetId } = do
         widget   <- fetch widgetId
@@ -70,12 +73,27 @@ instance Controller WidgetsController where
         let widget = newRecord @Widget
         hubs         <- query @Hub |> fetch
         adapterSpecs <- query @WidgetAdapterSpec |> filterWhere (#status, "active") |> orderByAsc #name |> fetch
+        (fwTypes, ownedTypes) <- activeWidgetTypes
+        policyScopes <- activePolicyScopes
+        let widgetTypes = fwTypes <> ownedTypes
+        widgetTypeVal <- paramOrDefault @Text "" "widgetType" >>= \t -> liftIO (validateWidgetType t)
+        mPolicyScope  <- paramOrNothing @Text "policyScope"
+        policyScopeVal <- case mPolicyScope of
+            Nothing -> pure (Right ())
+            Just "" -> pure (Right ())
+            Just ps -> liftIO (validatePolicyScope ps)
         widget
             |> fill @'["name", "widgetType", "hubId", "capabilityRef", "viewContext", "policyScope", "status", "adapterSpecId"]
             |> validateField #name nonEmpty
             |> validateField #widgetType nonEmpty
+            |> (case widgetTypeVal of
+                    Left msg -> attachFailure #widgetType msg
+                    Right () -> id)
+            |> (case policyScopeVal of
+                    Left msg -> attachFailure #policyScope msg
+                    Right () -> id)
             |> ifValid \case
-                Left widget -> render NewView { widget, hubs, adapterSpecs }
+                Left widget -> render NewView { widget, hubs, adapterSpecs, widgetTypes, policyScopes }
                 Right widget -> do
                     widget <- createRecord widget
                     let snapshot = object
@@ -100,18 +118,35 @@ instance Controller WidgetsController where
         widget       <- fetch widgetId
         hubs         <- query @Hub |> fetch
         adapterSpecs <- query @WidgetAdapterSpec |> filterWhere (#status, "active") |> orderByAsc #name |> fetch
-        render EditView { widget, hubs, adapterSpecs }
+        (fwTypes, ownedTypes) <- activeWidgetTypes
+        policyScopes <- activePolicyScopes
+        render EditView { widget, hubs, adapterSpecs, widgetTypes = fwTypes <> ownedTypes, policyScopes }
 
     action UpdateWidgetAction { widgetId } = do
         widget       <- fetch widgetId
         hubs         <- query @Hub |> fetch
         adapterSpecs <- query @WidgetAdapterSpec |> filterWhere (#status, "active") |> orderByAsc #name |> fetch
+        (fwTypes, ownedTypes) <- activeWidgetTypes
+        policyScopes <- activePolicyScopes
+        let widgetTypes = fwTypes <> ownedTypes
+        widgetTypeVal <- paramOrDefault @Text "" "widgetType" >>= \t -> liftIO (validateWidgetType t)
+        mPolicyScope  <- paramOrNothing @Text "policyScope"
+        policyScopeVal <- case mPolicyScope of
+            Nothing -> pure (Right ())
+            Just "" -> pure (Right ())
+            Just ps -> liftIO (validatePolicyScope ps)
         widget
             |> fill @'["name", "widgetType", "hubId", "capabilityRef", "viewContext", "policyScope", "status", "adapterSpecId"]
             |> validateField #name nonEmpty
             |> validateField #widgetType nonEmpty
+            |> (case widgetTypeVal of
+                    Left msg -> attachFailure #widgetType msg
+                    Right () -> id)
+            |> (case policyScopeVal of
+                    Left msg -> attachFailure #policyScope msg
+                    Right () -> id)
             |> ifValid \case
-                Left widget -> render EditView { widget, hubs, adapterSpecs }
+                Left widget -> render EditView { widget, hubs, adapterSpecs, widgetTypes, policyScopes }
                 Right widget -> do
                     let newVersion = widget.version + 1
                     widget <- widget |> set #version newVersion |> updateRecord