generated from coulomb/repo-seed
Bernd Worsch
3737845e02
Fixes 46 compile errors across 18 controllers and views: - BridgeResponse missing from explicit import lists (Widgets, RequirementCandidates, DecisionRecords, AgentDelegations) — dot-notation HasField resolution fails without the type in scope under DuplicateRecordFields - unId not in IHP v1.5 — replaced all fmap (Id . unId) with fmap coerce - respondWith not in IHP — replaced with plain redirectTo in 5 controllers - [hubId] list param to sqlQuery — replaced with (Only hubId) tuple - deleteWhere not in IHP — replaced with query/filterWhere/fetch/deleteRecords - fill @'["label"] mismatch — field is label_ in generated types, not label - PersistUUID/toUUID (persistent-style) — replaced with (Only id) - intercalate + jsonArrayTexts ambiguity in GovernanceTemplates — hid Index import, removed local duplicates, added Data.Text (intercalate) - Int16 not in scope in AntifragilityDashboard — changed to Int (score :: Int) - typeArraySection type mismatch in HubCapabilityManifests/Edit — unified to [Text] - renderForm arity mismatch — added action param to DecisionRecords/New.renderForm - Missing qualified Data.Aeson import in AdaptiveThresholds - Missing ?request::Request constraint in Api/V2/WidgetPatterns.renderJsonWithStatus Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
237 lines
12 KiB
Haskell
237 lines
12 KiB
Haskell
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.Aeson as A
|
|
import qualified Data.ByteString.Lazy as LBS
|
|
|
|
instance Controller WidgetPatternsController where
|
|
beforeAction = ensureIsUser
|
|
|
|
-- List all published patterns with adopter count
|
|
action WidgetPatternsAction = autoRefresh do
|
|
basePatterns <- query @WidgetPattern
|
|
|> filterWhere (#isPublished, True)
|
|
|> orderByAsc #name
|
|
|> fetch
|
|
patterns <- mapM (\p -> do
|
|
adopterCount <- sqlQueryScalar
|
|
"SELECT COUNT(*) FROM pattern_adoptions WHERE widget_pattern_id = ?"
|
|
(Only p.id)
|
|
latestVersion <- sqlQueryScalar
|
|
"SELECT MAX(version_number) FROM widget_pattern_versions WHERE widget_pattern_id = ?"
|
|
(Only p.id)
|
|
pure (p, fromMaybe 0 adopterCount, latestVersion)) basePatterns
|
|
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 :: [Only (Maybe (Id Hub))]) of
|
|
[Only (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 = A.toJSON newTypes
|
|
draft <- newRecord @HubCapabilityManifest
|
|
|> set #hubId hubId
|
|
|> set #status "draft"
|
|
|> set #declaredWidgetTypes newTypesJson
|
|
|> set #declaredEventTypes
|
|
(maybe (A.toJSON ([] :: [Text])) (.declaredEventTypes) mManifest)
|
|
|> set #declaredAnnotationCategories
|
|
(maybe (A.toJSON ([] :: [Text])) (.declaredAnnotationCategories) mManifest)
|
|
|> set #declaredPolicyScopes
|
|
(maybe (A.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 -> []
|
|
|