module Web.Controller.Widgets where import Web.Types import Web.View.Widgets.Index import Web.View.Widgets.Show import Web.View.Widgets.New import Web.View.Widgets.Edit import Generated.Types import IHP.Prelude import IHP.ControllerPrelude import Data.Aeson (toJSON, object, (.=)) import Application.Helper.Controller (isInRegression, widgetCycleCounts) import Application.Helper.TypeRegistry (validateWidgetType, validatePolicyScope, activeWidgetTypes, activePolicyScopes) import Application.Helper.AgentBridge (callAgent, checkGovernancePolicy) import Application.Helper.ModelRouter (resolveAgent) import Data.List (intercalate) instance Controller WidgetsController where beforeAction = ensureIsUser action WidgetsAction = do widgets <- query @Widget |> orderByAsc #name |> fetch hubs <- query @Hub |> fetch render IndexView { widgets, hubs } action NewWidgetAction = do let widget = newRecord @Widget hubs <- query @Hub |> fetch adapterSpecs <- query @WidgetAdapterSpec |> filterWhere (#status, "active") |> orderByAsc #name |> fetch (fwTypes, ownedTypes) <- activeWidgetTypes policyScopes <- activePolicyScopes render NewView { widget, hubs, adapterSpecs, widgetTypes = fwTypes <> ownedTypes, policyScopes } action ShowWidgetAction { widgetId } = do widget <- fetch widgetId hub <- fetch widget.hubId versions <- query @WidgetVersion |> filterWhere (#widgetId, widgetId) |> orderByDesc #version |> fetch events <- query @InteractionEvent |> filterWhere (#widgetId, widgetId) |> orderByDesc #occurredAt |> limit 20 |> fetch annotations <- query @Annotation |> filterWhere (#widgetId, widgetId) |> orderByAsc #createdAt |> fetch recentSignals <- query @OutcomeSignal |> filterWhere (#widgetId, widgetId) |> orderByDesc #observedAt |> limit 10 |> fetch allSignals <- query @OutcomeSignal |> filterWhere (#widgetId, widgetId) |> fetch let isRegressed = isInRegression allSignals annotations widgetId -- Recurrence cycle count for this widget allCandidates <- query @RequirementCandidate |> filterWhere (#sourceWidgetId, widgetId) |> fetch allRequirements <- query @Requirement |> fetch allDecisions <- query @DecisionRecord |> fetch allDeployments <- query @DeploymentRecord |> fetch let cycleCounts = widgetCycleCounts allCandidates allRequirements allDecisions allDeployments cycleCount = fromMaybe 0 (lookup widgetId cycleCounts) mAdapterSpec <- case widget.adapterSpecId of Nothing -> pure Nothing Just sid -> fetchOneOrNothing sid render ShowView { widget, hub, versions, events, annotations, recentSignals, isRegressed, cycleCount, mAdapterSpec } action CreateWidgetAction = do let widget = newRecord @Widget hubs <- query @Hub |> fetch adapterSpecs <- query @WidgetAdapterSpec |> filterWhere (#status, "active") |> orderByAsc #name |> fetch (fwTypes, ownedTypes) <- activeWidgetTypes policyScopes <- activePolicyScopes let widgetTypes = fwTypes <> ownedTypes widgetTypeVal <- paramOrDefault @Text "" "widgetType" >>= \t -> liftIO (validateWidgetType t) mPolicyScope <- paramOrNothing @Text "policyScope" policyScopeVal <- case mPolicyScope of Nothing -> pure (Right ()) Just "" -> pure (Right ()) Just ps -> liftIO (validatePolicyScope ps) widget |> fill @'["name", "widgetType", "hubId", "capabilityRef", "viewContext", "policyScope", "status", "adapterSpecId"] |> validateField #name nonEmpty |> validateField #widgetType nonEmpty |> (case widgetTypeVal of Left msg -> attachFailure #widgetType msg Right () -> id) |> (case policyScopeVal of Left msg -> attachFailure #policyScope msg Right () -> id) |> ifValid \case Left widget -> render NewView { widget, hubs, adapterSpecs, widgetTypes, policyScopes } Right widget -> do widget <- createRecord widget let snapshot = object [ "name" .= widget.name , "widget_type" .= widget.widgetType , "hub_id" .= widget.hubId , "capability_ref" .= widget.capabilityRef , "view_context" .= widget.viewContext , "policy_scope" .= widget.policyScope , "status" .= widget.status , "version" .= widget.version ] newRecord @WidgetVersion |> set #widgetId widget.id |> set #version 1 |> set #schemaSnapshot snapshot |> createRecord setSuccessMessage "Widget registered" redirectTo ShowWidgetAction { widgetId = widget.id } action EditWidgetAction { widgetId } = do widget <- fetch widgetId hubs <- query @Hub |> fetch adapterSpecs <- query @WidgetAdapterSpec |> filterWhere (#status, "active") |> orderByAsc #name |> fetch (fwTypes, ownedTypes) <- activeWidgetTypes policyScopes <- activePolicyScopes render EditView { widget, hubs, adapterSpecs, widgetTypes = fwTypes <> ownedTypes, policyScopes } action UpdateWidgetAction { widgetId } = do widget <- fetch widgetId hubs <- query @Hub |> fetch adapterSpecs <- query @WidgetAdapterSpec |> filterWhere (#status, "active") |> orderByAsc #name |> fetch (fwTypes, ownedTypes) <- activeWidgetTypes policyScopes <- activePolicyScopes let widgetTypes = fwTypes <> ownedTypes widgetTypeVal <- paramOrDefault @Text "" "widgetType" >>= \t -> liftIO (validateWidgetType t) mPolicyScope <- paramOrNothing @Text "policyScope" policyScopeVal <- case mPolicyScope of Nothing -> pure (Right ()) Just "" -> pure (Right ()) Just ps -> liftIO (validatePolicyScope ps) widget |> fill @'["name", "widgetType", "hubId", "capabilityRef", "viewContext", "policyScope", "status", "adapterSpecId"] |> validateField #name nonEmpty |> validateField #widgetType nonEmpty |> (case widgetTypeVal of Left msg -> attachFailure #widgetType msg Right () -> id) |> (case policyScopeVal of Left msg -> attachFailure #policyScope msg Right () -> id) |> ifValid \case Left widget -> render EditView { widget, hubs, adapterSpecs, widgetTypes, policyScopes } Right widget -> do let newVersion = widget.version + 1 widget <- widget |> set #version newVersion |> updateRecord let snapshot = object [ "name" .= widget.name , "widget_type" .= widget.widgetType , "hub_id" .= widget.hubId , "capability_ref" .= widget.capabilityRef , "view_context" .= widget.viewContext , "policy_scope" .= widget.policyScope , "status" .= widget.status , "version" .= newVersion ] newRecord @WidgetVersion |> set #widgetId widget.id |> set #version newVersion |> set #schemaSnapshot snapshot |> createRecord setSuccessMessage "Widget updated" redirectTo ShowWidgetAction { widgetId = widget.id } -- T03 / Phase 11: Summarize feedback cluster via routed agent action SummarizeClusterAction { widgetId } = do widget <- fetch widgetId annotations <- query @Annotation |> filterWhere (#widgetId, widgetId) |> orderByDesc #createdAt |> limit 20 |> fetch threads <- query @AnnotationThread |> filterWhere (#widgetId, widgetId) |> orderByDesc #createdAt |> limit 20 |> fetch let annLines = map (\a -> "[" <> a.category <> "/" <> a.severity <> "] " <> a.body) annotations threadLines = map (\t -> "[thread] " <> t.title <> ": " <> fromMaybe "" t.description) threads userMsg = intercalate "\n" (annLines <> threadLines) mAgent <- resolveAgent widget.hubId "synthesis" case mAgent of Nothing -> do setErrorMessage "No routing policy for 'synthesis' task type — configure one in Model Routing Policies" redirectTo ShowWidgetAction { widgetId } Just agent -> do allowed <- checkGovernancePolicy widget.hubId agent.id "annotation" if not allowed then do newRecord @AgentProposal |> set #proposalType "summary" |> set #sourceWidgetId (Just widgetId) |> set #content "Blocked by AI governance policy" |> set #modelRef agent.modelName |> set #status "blocked_by_policy" |> set #agentRegistrationId (Just agent.id) |> createRecord setErrorMessage "Blocked by AI governance policy" redirectTo ShowWidgetAction { widgetId } else do result <- liftIO $ callAgent agent userMsg case result of Left err -> do setErrorMessage ("AI summarization failed: " <> err.errorMessage) redirectTo ShowWidgetAction { widgetId } Right resp -> do newRecord @AgentProposal |> set #proposalType "summary" |> set #sourceWidgetId (Just widgetId) |> set #content resp.content |> set #modelRef resp.modelUsed |> set #status "pending" |> set #agentRegistrationId (Just agent.id) |> set #tokensIn (Just resp.tokensIn) |> set #tokensOut (Just resp.tokensOut) |> createRecord setSuccessMessage "Summary proposal created" redirectTo ShowWidgetAction { widgetId } -- T04 / Phase 11: Draft a requirement candidate via routed agent action DraftRequirementAction { widgetId } = do widget <- fetch widgetId annotations <- query @Annotation |> filterWhere (#widgetId, widgetId) |> orderByDesc #createdAt |> limit 20 |> fetch let annLines = map (\a -> "[" <> a.category <> "/" <> a.severity <> "] " <> a.body) annotations userMsg = intercalate "\n" annLines mAgent <- resolveAgent widget.hubId "requirement_draft" case mAgent of Nothing -> do setErrorMessage "No routing policy for 'requirement_draft' task type" redirectTo ShowWidgetAction { widgetId } Just agent -> do allowed <- checkGovernancePolicy widget.hubId agent.id "requirement_candidate" if not allowed then do newRecord @AgentProposal |> set #proposalType "requirement_draft" |> set #sourceWidgetId (Just widgetId) |> set #content "Blocked by AI governance policy" |> set #modelRef agent.modelName |> set #status "blocked_by_policy" |> set #agentRegistrationId (Just agent.id) |> createRecord setErrorMessage "Blocked by AI governance policy" redirectTo ShowWidgetAction { widgetId } else do result <- liftIO $ callAgent agent userMsg case result of Left err -> do setErrorMessage ("AI draft failed: " <> err.errorMessage) redirectTo ShowWidgetAction { widgetId } Right resp -> do newRecord @AgentProposal |> set #proposalType "requirement_draft" |> set #sourceWidgetId (Just widgetId) |> set #content resp.content |> set #modelRef resp.modelUsed |> set #status "pending" |> set #agentRegistrationId (Just agent.id) |> set #tokensIn (Just resp.tokensIn) |> set #tokensOut (Just resp.tokensOut) |> createRecord setSuccessMessage "Requirement draft proposal created" redirectTo ShowWidgetAction { widgetId }