generated from coulomb/repo-seed
feat(WP-0011): IHF Phase 10 — Hub Registry and Widget Marketplace
Some checks failed
Test / test (push) Has been cancelled
Some checks failed
Test / test (push) Has been cancelled
Delivers the hub registry discovery UI, widget pattern library, governance template library, and marketplace dashboard. Key changes: - Schema: widget_patterns (widget_type FK to registry), widget_pattern_versions, pattern_adoptions, governance_templates (categories JSONB, validated at controller), governance_template_clones — all GAAF-compliant, no bare TEXT type discriminators - Migration: 1743897600-ihf-phase10-hub-registry.sql - HubRegistry controller + views: browsable view over hub_capability_manifests, hub_health_snapshots, hubs with per-hub GAAF compliance indicator - WidgetPatterns controller + views: publish, version, adopt; adoption triggers manifest amendment draft when new types are introduced - GovernanceTemplates controller + views: CRUD, clone with category validation against annotation_category_registry - MarketplaceDashboard controller + view: full-text search, widget-type filter, sort, trending panel, autoRefresh - API v2: /api/v2/hub-registry, /api/v2/widget-patterns (+ adopt endpoint) - OpenAPI spec updated with Phase 10 paths - GAAF scorecard: Customization 2.5 → 3.2; overall 3.41 → 3.56 (Strong) - CLAUDE.md: Phase 10 complete; active workplan → Phase 11 Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
154
Web/Controller/GovernanceTemplates.hs
Normal file
154
Web/Controller/GovernanceTemplates.hs
Normal file
@@ -0,0 +1,154 @@
|
||||
module Web.Controller.GovernanceTemplates where
|
||||
|
||||
import Web.Types
|
||||
import Web.View.GovernanceTemplates.Index
|
||||
import Web.View.GovernanceTemplates.Show
|
||||
import Web.View.GovernanceTemplates.New
|
||||
import Generated.Types
|
||||
import IHP.Prelude
|
||||
import IHP.ControllerPrelude
|
||||
import Data.Aeson (Value(..), decode, encode, toJSON)
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
|
||||
instance Controller GovernanceTemplatesController where
|
||||
beforeAction = ensureIsUser
|
||||
|
||||
-- List published templates with clone count
|
||||
action GovernanceTemplatesAction = autoRefresh do
|
||||
templates <- sqlQuery
|
||||
"SELECT gt.*, COUNT(gtc.id) AS clone_count \
|
||||
\ FROM governance_templates gt \
|
||||
\ LEFT JOIN governance_template_clones gtc ON gtc.governance_template_id = gt.id \
|
||||
\ WHERE gt.is_published = TRUE \
|
||||
\ GROUP BY gt.id \
|
||||
\ ORDER BY clone_count DESC, gt.name ASC"
|
||||
()
|
||||
render IndexView { templates }
|
||||
|
||||
-- Template detail with clone count
|
||||
action ShowGovernanceTemplateAction { governanceTemplateId } = do
|
||||
template <- fetch governanceTemplateId
|
||||
hub <- fetch template.hubId
|
||||
cloneCount <- sqlQueryScalar
|
||||
"SELECT COUNT(*) FROM governance_template_clones WHERE governance_template_id = ?"
|
||||
(Only governanceTemplateId)
|
||||
render ShowView { template, hub, cloneCount = fromMaybe 0 cloneCount }
|
||||
|
||||
action NewGovernanceTemplateAction = do
|
||||
hubs <- query @Hub |> orderByAsc #name |> fetch
|
||||
categories <- sqlQuery
|
||||
"SELECT name, label FROM annotation_category_registry WHERE status = 'active' ORDER BY label"
|
||||
()
|
||||
let template = newRecord @GovernanceTemplate
|
||||
render NewView { template, hubs, categories }
|
||||
|
||||
action CreateGovernanceTemplateAction = do
|
||||
hubs <- query @Hub |> orderByAsc #name |> fetch
|
||||
categories <- sqlQuery
|
||||
"SELECT name, label FROM annotation_category_registry WHERE status = 'active' ORDER BY label"
|
||||
()
|
||||
let template = newRecord @GovernanceTemplate
|
||||
let selectedCats = paramList @Text "categories"
|
||||
let templateBodyRaw = param @Text "templateBody"
|
||||
let mBody = decode (LBS.fromStrict (cs templateBodyRaw)) :: Maybe Value
|
||||
case mBody of
|
||||
Nothing -> do
|
||||
setErrorMessage "Template body must be valid JSON."
|
||||
render NewView { template, hubs, categories }
|
||||
Just bodyVal -> do
|
||||
-- Validate each selected category is in the registry
|
||||
mErrors <- validateCategories selectedCats
|
||||
case mErrors of
|
||||
Left unknown -> do
|
||||
setErrorMessage ("Unknown categories: " <> intercalate ", " unknown)
|
||||
render NewView { template, hubs, categories }
|
||||
Right () -> do
|
||||
template
|
||||
|> fill @'["hubId", "name", "description"]
|
||||
|> set #categories (toJSON selectedCats)
|
||||
|> set #templateBody bodyVal
|
||||
|> set #isPublished False
|
||||
|> validateField #name nonEmpty
|
||||
|> validateField #hubId nonEmpty
|
||||
|> ifValid \case
|
||||
Left template -> render NewView { template, hubs, categories }
|
||||
Right template -> do
|
||||
t <- createRecord template
|
||||
setSuccessMessage "Governance template created"
|
||||
redirectTo ShowGovernanceTemplateAction { governanceTemplateId = t.id }
|
||||
|
||||
-- Clone template + manifest amendment if needed
|
||||
action CloneGovernanceTemplateAction { governanceTemplateId } = do
|
||||
template <- fetch governanceTemplateId
|
||||
hubId <- getUserHubId
|
||||
existing <- query @GovernanceTemplateClone
|
||||
|> filterWhere (#governanceTemplateId, governanceTemplateId)
|
||||
|> filterWhere (#cloningHubId, hubId)
|
||||
|> fetchOneOrNothing
|
||||
case existing of
|
||||
Just _ -> do
|
||||
setSuccessMessage "Your hub has already cloned this template."
|
||||
redirectTo ShowGovernanceTemplateAction { governanceTemplateId }
|
||||
Nothing -> do
|
||||
newRecord @GovernanceTemplateClone
|
||||
|> set #governanceTemplateId governanceTemplateId
|
||||
|> set #cloningHubId hubId
|
||||
|> createRecord
|
||||
-- Check if template categories are in hub's manifest
|
||||
mManifest <- query @HubCapabilityManifest
|
||||
|> filterWhere (#hubId, hubId)
|
||||
|> filterWhere (#status, "active")
|
||||
|> fetchOneOrNothing
|
||||
let templateCats = jsonArrayTexts template.categories
|
||||
let existingCats = maybe [] (jsonArrayTexts . (.declaredAnnotationCategories)) mManifest
|
||||
let missingCats = filter (`notElem` existingCats) templateCats
|
||||
if not (null missingCats)
|
||||
then do
|
||||
let newCats = existingCats ++ missingCats
|
||||
draft <- newRecord @HubCapabilityManifest
|
||||
|> set #hubId hubId
|
||||
|> set #status "draft"
|
||||
|> set #declaredWidgetTypes
|
||||
(maybe (toJSON ([] :: [Text])) (.declaredWidgetTypes) mManifest)
|
||||
|> set #declaredEventTypes
|
||||
(maybe (toJSON ([] :: [Text])) (.declaredEventTypes) mManifest)
|
||||
|> set #declaredAnnotationCategories (toJSON newCats)
|
||||
|> set #declaredPolicyScopes
|
||||
(maybe (toJSON ([] :: [Text])) (.declaredPolicyScopes) mManifest)
|
||||
|> createRecord
|
||||
setSuccessMessage "Template cloned. A manifest amendment draft has been created for the new categories."
|
||||
redirectTo ShowHubCapabilityManifestAction { hubCapabilityManifestId = draft.id }
|
||||
else do
|
||||
setSuccessMessage "Template cloned."
|
||||
redirectTo ShowGovernanceTemplateAction { governanceTemplateId }
|
||||
|
||||
-- | Validate that all category names exist in the active annotation_category_registry.
|
||||
validateCategories ::
|
||||
(?modelContext :: ModelContext) =>
|
||||
[Text] -> IO (Either [Text] ())
|
||||
validateCategories cats = do
|
||||
registered <- sqlQuery
|
||||
"SELECT name FROM annotation_category_registry WHERE status = 'active'"
|
||||
()
|
||||
let known = map (\(Only n) -> n) (registered :: [Only Text])
|
||||
let unknown = filter (`notElem` known) cats
|
||||
pure $ if null unknown then Right () else Left unknown
|
||||
|
||||
-- | Resolve the hub for the current session (first hub fallback).
|
||||
getUserHubId :: (?modelContext :: ModelContext, ?context :: ControllerContext) => IO (Id Hub)
|
||||
getUserHubId = do
|
||||
hubs <- query @Hub |> limit 1 |> fetch
|
||||
case hubs of
|
||||
(h:_) -> pure h.id
|
||||
[] -> error "No hubs found"
|
||||
|
||||
-- | Extract text values from a JSONB array.
|
||||
jsonArrayTexts :: Value -> [Text]
|
||||
jsonArrayTexts val = case decode (encode val) of
|
||||
Just (arr :: [Text]) -> arr
|
||||
Nothing -> []
|
||||
|
||||
intercalate :: Text -> [Text] -> Text
|
||||
intercalate _ [] = ""
|
||||
intercalate _ [x] = x
|
||||
intercalate sep (x:xs) = x <> sep <> intercalate sep xs
|
||||
Reference in New Issue
Block a user