generated from coulomb/repo-seed
Bernd Worsch
133dae3d23
Some checks failed
Test / test (push) Has been cancelled
- Schema: AgentRegistration, ModelRoutingPolicy, AgentDelegation, CollectiveProposal, CollectiveProposalContribution, AiGovernancePolicy, AgentPerformanceRecord + ALTER TABLE agent_proposals (migration 1744156800; CHECK constraints on trust_level, status, consensus_status — GAAF compliant) - Bridge: scripts/llm_bridge.py (llm-connect subprocess seam) + Application/Helper/AgentBridge.hs (callBridge, callAgent, checkGovernancePolicy, jsonArrayTexts) - Routing: Application/Helper/ModelRouter.hs (resolveAgent, resolveAllAgents) + ModelRoutingPolicies CRUD - Registry: AgentRegistrations CRUD (Index/Show/New/Edit/Performance), DeactivateAgentAction, ComputeAgentPerformanceAction - Delegation: AgentDelegations controller + views, DelegateSubtaskAction with token budget enforcement at bridge call time - Collective: CollectiveProposals controller + views, CreateCollectiveProposalAction (fan-out → synthesis → consensus detection) - Governance: AiGovernancePolicies CRUD + ToggleAiGovernancePolicyAction; checkGovernancePolicy enforced at all 4 Phase 5 invocation points - Phase 5 wiring: replaced callClaudeApi in Widgets, DecisionRecords, RequirementCandidates with resolveAgent + callAgent + token tracking - llm-connect feature requests: ~/llm-connect/FEATURE_REQUESTS.md (FR-1 HTTP serve, FR-2 RoutingPolicy, FR-3 async, FR-4 BudgetTracker) - GAAF scorecard: 3.61 (up from 3.56); Functional 3.4→3.6, Extensions 3.8→3.9 Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
276 lines
14 KiB
Haskell
276 lines
14 KiB
Haskell
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 }
|