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:
237
Web/Controller/WidgetPatterns.hs
Normal file
237
Web/Controller/WidgetPatterns.hs
Normal file
@@ -0,0 +1,237 @@
|
||||
module Web.Controller.WidgetPatterns where
|
||||
|
||||
import Web.Types
|
||||
import Web.View.WidgetPatterns.Index
|
||||
import Web.View.WidgetPatterns.Show
|
||||
import Web.View.WidgetPatterns.New
|
||||
import Web.View.WidgetPatterns.Edit
|
||||
import Generated.Types
|
||||
import IHP.Prelude
|
||||
import IHP.ControllerPrelude
|
||||
import Data.Aeson (decode, encode, object, (.=))
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
|
||||
instance Controller WidgetPatternsController where
|
||||
beforeAction = ensureIsUser
|
||||
|
||||
-- List all published patterns with adopter count
|
||||
action WidgetPatternsAction = autoRefresh do
|
||||
patterns <- sqlQuery
|
||||
"SELECT wp.*, \
|
||||
\ COUNT(pa.id) AS adopter_count, \
|
||||
\ MAX(wpv.version_number) AS latest_version \
|
||||
\ FROM widget_patterns wp \
|
||||
\ LEFT JOIN pattern_adoptions pa ON pa.widget_pattern_id = wp.id \
|
||||
\ LEFT JOIN widget_pattern_versions wpv ON wpv.widget_pattern_id = wp.id \
|
||||
\ WHERE wp.is_published = TRUE \
|
||||
\ GROUP BY wp.id \
|
||||
\ ORDER BY adopter_count DESC, wp.name ASC"
|
||||
()
|
||||
render IndexView { patterns }
|
||||
|
||||
-- Detail with version history and aggregate adoption stats (T07)
|
||||
action ShowWidgetPatternAction { widgetPatternId } = do
|
||||
pattern <- fetch widgetPatternId
|
||||
hub <- fetch pattern.hubId
|
||||
versions <- query @WidgetPatternVersion
|
||||
|> filterWhere (#widgetPatternId, widgetPatternId)
|
||||
|> orderByDesc #versionNumber
|
||||
|> fetch
|
||||
adopterCount <- sqlQueryScalar
|
||||
"SELECT COUNT(*) FROM pattern_adoptions WHERE widget_pattern_id = ?"
|
||||
(Only widgetPatternId)
|
||||
anonCount <- sqlQueryScalar
|
||||
"SELECT COUNT(*) FROM pattern_adoptions WHERE widget_pattern_id = ? AND is_anonymous = TRUE"
|
||||
(Only widgetPatternId)
|
||||
-- Aggregate friction/outcome from non-anonymous adopter hubs
|
||||
aggStats <- sqlQuery
|
||||
"SELECT \
|
||||
\ AVG(fs.score) AS mean_friction_score, \
|
||||
\ COUNT(DISTINCT os.id) AS outcome_signal_count \
|
||||
\ FROM pattern_adoptions pa \
|
||||
\ JOIN widgets w \
|
||||
\ ON w.hub_id = pa.adopting_hub_id \
|
||||
\ AND w.widget_type = ? \
|
||||
\ LEFT JOIN friction_scores fs ON fs.widget_id = w.id \
|
||||
\ LEFT JOIN outcome_signals os ON os.widget_id = w.id \
|
||||
\ WHERE pa.widget_pattern_id = ? \
|
||||
\ AND pa.is_anonymous = FALSE"
|
||||
(pattern.widgetType, widgetPatternId)
|
||||
let (mFriction, outcomeCount) = case (aggStats :: [(Maybe Double, Int)]) of
|
||||
[(f, o)] -> (f, o)
|
||||
_ -> (Nothing, 0)
|
||||
render ShowView
|
||||
{ pattern, hub, versions
|
||||
, adopterCount = fromMaybe 0 adopterCount
|
||||
, anonCount = fromMaybe 0 anonCount
|
||||
, meanFriction = mFriction
|
||||
, outcomeCount
|
||||
}
|
||||
|
||||
action NewWidgetPatternAction = do
|
||||
hubs <- query @Hub |> orderByAsc #name |> fetch
|
||||
widgetTypes <- sqlQuery "SELECT name, label FROM widget_type_registry WHERE status = 'active' ORDER BY label" ()
|
||||
let pattern = newRecord @WidgetPattern
|
||||
render NewView { pattern, hubs, widgetTypes }
|
||||
|
||||
action CreateWidgetPatternAction = do
|
||||
hubs <- query @Hub |> orderByAsc #name |> fetch
|
||||
widgetTypes <- sqlQuery "SELECT name, label FROM widget_type_registry WHERE status = 'active' ORDER BY label" ()
|
||||
let pattern = newRecord @WidgetPattern
|
||||
pattern
|
||||
|> fill @'["hubId", "name", "description", "widgetType"]
|
||||
|> set #isPublished False
|
||||
|> set #isCrossHub False
|
||||
|> validateField #name nonEmpty
|
||||
|> validateField #hubId nonEmpty
|
||||
|> validateField #widgetType nonEmpty
|
||||
|> ifValid \case
|
||||
Left pattern -> render NewView { pattern, hubs, widgetTypes }
|
||||
Right pattern -> do
|
||||
-- Determine cross-hub: is widget_type owned by a different hub?
|
||||
typeOwner <- sqlQuery
|
||||
"SELECT owner_hub_id FROM widget_type_registry WHERE name = ?"
|
||||
(Only pattern.widgetType)
|
||||
let isCross = case (typeOwner :: [(Maybe (Id Hub))]) of
|
||||
[Just ownerId] -> ownerId /= pattern.hubId
|
||||
_ -> False
|
||||
pattern <- pattern |> set #isCrossHub isCross |> createRecord
|
||||
setSuccessMessage "Pattern created"
|
||||
redirectTo EditWidgetPatternAction { widgetPatternId = pattern.id }
|
||||
|
||||
action EditWidgetPatternAction { widgetPatternId } = do
|
||||
pattern <- fetch widgetPatternId
|
||||
hubs <- query @Hub |> orderByAsc #name |> fetch
|
||||
widgetTypes <- sqlQuery "SELECT name, label FROM widget_type_registry WHERE status = 'active' ORDER BY label" ()
|
||||
render EditView { pattern, hubs, widgetTypes }
|
||||
|
||||
action UpdateWidgetPatternAction { widgetPatternId } = do
|
||||
pattern <- fetch widgetPatternId
|
||||
hubs <- query @Hub |> orderByAsc #name |> fetch
|
||||
widgetTypes <- sqlQuery "SELECT name, label FROM widget_type_registry WHERE status = 'active' ORDER BY label" ()
|
||||
when pattern.isPublished do
|
||||
setErrorMessage "Published patterns are read-only. Version it instead."
|
||||
redirectTo ShowWidgetPatternAction { widgetPatternId }
|
||||
pattern
|
||||
|> fill @'["name", "description"]
|
||||
|> validateField #name nonEmpty
|
||||
|> ifValid \case
|
||||
Left pattern -> render EditView { pattern, hubs, widgetTypes }
|
||||
Right pattern -> do
|
||||
updateRecord pattern
|
||||
setSuccessMessage "Pattern updated"
|
||||
redirectTo ShowWidgetPatternAction { widgetPatternId }
|
||||
|
||||
-- Publish: set is_published = True, create version 1
|
||||
action PublishWidgetPatternAction { widgetPatternId } = do
|
||||
pattern <- fetch widgetPatternId
|
||||
when pattern.isPublished do
|
||||
setErrorMessage "Pattern is already published."
|
||||
redirectTo ShowWidgetPatternAction { widgetPatternId }
|
||||
now <- getCurrentTime
|
||||
pattern |> set #isPublished True |> updateRecord
|
||||
let definition = object [ "name" .= pattern.name
|
||||
, "widgetType" .= pattern.widgetType
|
||||
, "description" .= pattern.description
|
||||
]
|
||||
newRecord @WidgetPatternVersion
|
||||
|> set #widgetPatternId widgetPatternId
|
||||
|> set #versionNumber 1
|
||||
|> set #definition definition
|
||||
|> set #changelog (Just "Initial publication")
|
||||
|> createRecord
|
||||
setSuccessMessage "Pattern published (v1)"
|
||||
redirectTo ShowWidgetPatternAction { widgetPatternId }
|
||||
|
||||
-- Publish a new version (T04)
|
||||
action PublishNewVersionAction { widgetPatternId } = do
|
||||
pattern <- fetch widgetPatternId
|
||||
unless pattern.isPublished do
|
||||
setErrorMessage "Publish the pattern first before versioning."
|
||||
redirectTo ShowWidgetPatternAction { widgetPatternId }
|
||||
latestVersion <- query @WidgetPatternVersion
|
||||
|> filterWhere (#widgetPatternId, widgetPatternId)
|
||||
|> orderByDesc #versionNumber
|
||||
|> limit 1
|
||||
|> fetchOneOrNothing
|
||||
let nextNum = maybe 1 (\v -> v.versionNumber + 1) latestVersion
|
||||
let definitionJson = case param @Text "definition" of
|
||||
raw -> fromMaybe (object []) (decode (LBS.fromStrict (cs raw)))
|
||||
let changelog = paramOrNothing @Text "changelog"
|
||||
newRecord @WidgetPatternVersion
|
||||
|> set #widgetPatternId widgetPatternId
|
||||
|> set #versionNumber nextNum
|
||||
|> set #definition definitionJson
|
||||
|> set #changelog changelog
|
||||
|> createRecord
|
||||
setSuccessMessage ("Published version " <> tshow nextNum)
|
||||
redirectTo ShowWidgetPatternAction { widgetPatternId }
|
||||
|
||||
-- Adopt pattern — creates PatternAdoption (see T05 for amendment logic)
|
||||
action AdoptPatternAction { widgetPatternId } = do
|
||||
pattern <- fetch widgetPatternId
|
||||
hubId <- getUserHubId
|
||||
existing <- query @PatternAdoption
|
||||
|> filterWhere (#widgetPatternId, widgetPatternId)
|
||||
|> filterWhere (#adoptingHubId, hubId)
|
||||
|> fetchOneOrNothing
|
||||
case existing of
|
||||
Just _ -> do
|
||||
setSuccessMessage "Your hub has already adopted this pattern."
|
||||
redirectTo ShowWidgetPatternAction { widgetPatternId }
|
||||
Nothing -> do
|
||||
let isAnon = paramOrDefault @Bool False "isAnonymous"
|
||||
adoption <- newRecord @PatternAdoption
|
||||
|> set #widgetPatternId widgetPatternId
|
||||
|> set #adoptingHubId hubId
|
||||
|> set #isAnonymous isAnon
|
||||
|> createRecord
|
||||
-- Check if pattern's widget_type is in the hub's active manifest
|
||||
mManifest <- query @HubCapabilityManifest
|
||||
|> filterWhere (#hubId, hubId)
|
||||
|> filterWhere (#status, "active")
|
||||
|> fetchOneOrNothing
|
||||
let needsAmendment = case mManifest of
|
||||
Nothing -> True
|
||||
Just m -> not (pattern.widgetType `elem` jsonArrayTexts m.declaredWidgetTypes)
|
||||
if needsAmendment
|
||||
then do
|
||||
-- Create a draft manifest amendment
|
||||
let existingTypes = maybe [] (jsonArrayTexts . (.declaredWidgetTypes)) mManifest
|
||||
let newTypes = existingTypes ++ [pattern.widgetType]
|
||||
let newTypesJson = toJSON newTypes
|
||||
draft <- newRecord @HubCapabilityManifest
|
||||
|> set #hubId hubId
|
||||
|> set #status "draft"
|
||||
|> set #declaredWidgetTypes newTypesJson
|
||||
|> set #declaredEventTypes
|
||||
(maybe (toJSON ([] :: [Text])) (.declaredEventTypes) mManifest)
|
||||
|> set #declaredAnnotationCategories
|
||||
(maybe (toJSON ([] :: [Text])) (.declaredAnnotationCategories) mManifest)
|
||||
|> set #declaredPolicyScopes
|
||||
(maybe (toJSON ([] :: [Text])) (.declaredPolicyScopes) mManifest)
|
||||
|> createRecord
|
||||
setSuccessMessage "Pattern adopted. A manifest amendment draft has been created — please review and activate it."
|
||||
redirectTo ShowHubCapabilityManifestAction { hubCapabilityManifestId = draft.id }
|
||||
else do
|
||||
setSuccessMessage "Pattern adopted."
|
||||
redirectTo ShowWidgetPatternAction { widgetPatternId }
|
||||
|
||||
-- | Get the hub ID associated with the logged-in user.
|
||||
-- Falls back to the first hub if no per-user association exists.
|
||||
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 — cannot determine adopting hub"
|
||||
|
||||
-- | Extract text values from a JSONB array.
|
||||
jsonArrayTexts :: Value -> [Text]
|
||||
jsonArrayTexts val = case decode (encode val) of
|
||||
Just (arr :: [Text]) -> arr
|
||||
Nothing -> []
|
||||
|
||||
-- | Convert a list to a JSON Value.
|
||||
toJSON :: [Text] -> Value
|
||||
toJSON ts = Data.Aeson.toJSON ts
|
||||
Reference in New Issue
Block a user