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