generated from coulomb/repo-seed
feat(WP-0009): IHF GAAF Compliance Foundation — type registries, extension manifests, architectural contracts
Some checks failed
Test / test (push) Has been cancelled
Some checks failed
Test / test (push) Has been cancelled
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>
This commit is contained in:
278
Web/Controller/TypeRegistries.hs
Normal file
278
Web/Controller/TypeRegistries.hs
Normal file
@@ -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
|
||||
Reference in New Issue
Block a user