generated from coulomb/repo-seed
feat(WP-0012): IHF Phase 11 — Advanced AI Federation
Some checks failed
Test / test (push) Has been cancelled
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>
This commit is contained in:
74
Web/Controller/AgentDelegations.hs
Normal file
74
Web/Controller/AgentDelegations.hs
Normal file
@@ -0,0 +1,74 @@
|
||||
module Web.Controller.AgentDelegations where
|
||||
|
||||
-- IHF Phase 11 — Advanced AI Federation (IHUB-WP-0012 T06)
|
||||
|
||||
import Web.Controller.Prelude
|
||||
import Web.View.AgentDelegations.Index
|
||||
import Web.View.AgentDelegations.Show
|
||||
import Application.Helper.AgentBridge (callBridge, BridgeRequest(..))
|
||||
|
||||
instance Controller AgentDelegationsController where
|
||||
|
||||
action AgentDelegationsAction = do
|
||||
delegations <- query @AgentDelegation
|
||||
|> orderByDesc #createdAt
|
||||
|> fetch
|
||||
render IndexView { .. }
|
||||
|
||||
action ShowAgentDelegationAction { agentDelegationId } = do
|
||||
delegation <- fetch agentDelegationId
|
||||
delegatingAgent <- fetch delegation.delegatingAgentId
|
||||
receivingAgent <- fetch delegation.receivingAgentId
|
||||
mParentProposal <- case delegation.parentProposalId of
|
||||
Nothing -> pure Nothing
|
||||
Just pid -> fetchOneOrNothing pid
|
||||
render ShowView { .. }
|
||||
|
||||
action DelegateSubtaskAction { agentProposalId } = do
|
||||
proposal <- fetch agentProposalId
|
||||
receivingAgentId <- param @(Id AgentRegistration) "receivingAgentId"
|
||||
scope <- param @Text "scope"
|
||||
tokenBudget <- paramOrDefault @Int 1000 "tokenBudget"
|
||||
delegatingAgentId <- case proposal.agentRegistrationId of
|
||||
Just aid -> pure aid
|
||||
Nothing -> respondAndExit =<< renderNotFound
|
||||
|
||||
receivingAgent <- fetch receivingAgentId
|
||||
|
||||
delegation <- newRecord @AgentDelegation
|
||||
|> set #delegatingAgentId delegatingAgentId
|
||||
|> set #receivingAgentId receivingAgentId
|
||||
|> set #parentProposalId (Just agentProposalId)
|
||||
|> set #scope scope
|
||||
|> set #tokenBudget tokenBudget
|
||||
|> set #status "pending"
|
||||
|> createRecord
|
||||
|
||||
result <- liftIO $ callBridge BridgeRequest
|
||||
{ provider = receivingAgent.provider
|
||||
, model = receivingAgent.modelName
|
||||
, systemPrompt = receivingAgent.systemPrompt
|
||||
, prompt = scope
|
||||
, maxTokens = tokenBudget
|
||||
, temperature = 0.7
|
||||
}
|
||||
|
||||
now <- getCurrentTime
|
||||
case result of
|
||||
Left err -> do
|
||||
delegation
|
||||
|> set #status "failed"
|
||||
|> set #result (Just . A.toJSON $ A.object ["error" A..= err.errorMessage])
|
||||
|> set #completedAt (Just now)
|
||||
|> updateRecord
|
||||
setErrorMessage ("Delegation failed: " <> err.errorMessage)
|
||||
Right resp -> do
|
||||
delegation
|
||||
|> set #status "completed"
|
||||
|> set #tokensUsed (Just resp.tokensOut)
|
||||
|> set #result (Just . A.toJSON $ A.object ["content" A..= resp.content])
|
||||
|> set #completedAt (Just now)
|
||||
|> updateRecord
|
||||
setSuccessMessage "Subtask delegated successfully"
|
||||
|
||||
redirectTo ShowAgentDelegationAction { agentDelegationId = delegation.id }
|
||||
122
Web/Controller/AgentRegistrations.hs
Normal file
122
Web/Controller/AgentRegistrations.hs
Normal file
@@ -0,0 +1,122 @@
|
||||
module Web.Controller.AgentRegistrations where
|
||||
|
||||
-- IHF Phase 11 — Advanced AI Federation (IHUB-WP-0012 T03)
|
||||
|
||||
import Web.Controller.Prelude
|
||||
import Web.View.AgentRegistrations.Index
|
||||
import Web.View.AgentRegistrations.Show
|
||||
import Web.View.AgentRegistrations.New
|
||||
import Web.View.AgentRegistrations.Edit
|
||||
import Web.View.AgentRegistrations.Performance
|
||||
|
||||
instance Controller AgentRegistrationsController where
|
||||
|
||||
action AgentRegistrationsAction = do
|
||||
agents <- query @AgentRegistration
|
||||
|> orderByAsc #name
|
||||
|> fetch
|
||||
hubs <- query @Hub |> orderByAsc #name |> fetch
|
||||
render IndexView { .. }
|
||||
|
||||
action ShowAgentRegistrationAction { agentRegistrationId } = do
|
||||
agent <- fetch agentRegistrationId
|
||||
policies <- query @ModelRoutingPolicy
|
||||
|> filterWhere (#agentRegistrationId, agentRegistrationId)
|
||||
|> orderByAsc #taskType
|
||||
|> fetch
|
||||
recentProposals <- query @AgentProposal
|
||||
|> filterWhere (#agentRegistrationId, Just agentRegistrationId)
|
||||
|> orderByDesc #createdAt
|
||||
|> limit 10
|
||||
|> fetch
|
||||
mPerformance <- query @AgentPerformanceRecord
|
||||
|> filterWhere (#agentRegistrationId, agentRegistrationId)
|
||||
|> orderByDesc #computedAt
|
||||
|> limit 1
|
||||
|> fetchOneOrNothing
|
||||
render ShowView { .. }
|
||||
|
||||
action NewAgentRegistrationAction = do
|
||||
let agent = newRecord @AgentRegistration
|
||||
hubs <- query @Hub |> orderByAsc #name |> fetch
|
||||
render NewView { .. }
|
||||
|
||||
action CreateAgentRegistrationAction = do
|
||||
let agent = newRecord @AgentRegistration
|
||||
agent
|
||||
|> fill @'["hubId","name","slug","description","provider","modelName","trustLevel","systemPrompt"]
|
||||
|> set #capabilities (A.Array mempty)
|
||||
|> validateField #name nonEmpty
|
||||
|> validateField #slug nonEmpty
|
||||
|> validateField #provider (isInList ["openrouter","gemini","openai","claude-code"])
|
||||
|> validateField #modelName nonEmpty
|
||||
|> validateField #trustLevel (isInList ["advisory","elevated","autonomous"])
|
||||
|> ifValid \case
|
||||
Left agent -> do
|
||||
hubs <- query @Hub |> orderByAsc #name |> fetch
|
||||
render NewView { .. }
|
||||
Right agent -> do
|
||||
agent <- createRecord agent
|
||||
setSuccessMessage "Agent registered"
|
||||
redirectTo AgentRegistrationsAction
|
||||
|
||||
action EditAgentRegistrationAction { agentRegistrationId } = do
|
||||
agent <- fetch agentRegistrationId
|
||||
hubs <- query @Hub |> orderByAsc #name |> fetch
|
||||
render EditView { .. }
|
||||
|
||||
action UpdateAgentRegistrationAction { agentRegistrationId } = do
|
||||
agent <- fetch agentRegistrationId
|
||||
agent
|
||||
|> fill @'["name","description","provider","modelName","trustLevel","systemPrompt"]
|
||||
|> validateField #name nonEmpty
|
||||
|> validateField #provider (isInList ["openrouter","gemini","openai","claude-code"])
|
||||
|> validateField #modelName nonEmpty
|
||||
|> validateField #trustLevel (isInList ["advisory","elevated","autonomous"])
|
||||
|> ifValid \case
|
||||
Left agent -> do
|
||||
hubs <- query @Hub |> orderByAsc #name |> fetch
|
||||
render EditView { .. }
|
||||
Right agent -> do
|
||||
updateRecord agent
|
||||
setSuccessMessage "Agent updated"
|
||||
redirectTo (ShowAgentRegistrationAction agentRegistrationId)
|
||||
|
||||
action DeactivateAgentAction { agentRegistrationId } = do
|
||||
agent <- fetch agentRegistrationId
|
||||
agent |> set #isActive False |> updateRecord
|
||||
setSuccessMessage "Agent deactivated"
|
||||
redirectTo (ShowAgentRegistrationAction agentRegistrationId)
|
||||
|
||||
action ComputeAgentPerformanceAction { agentRegistrationId } = do
|
||||
agent <- fetch agentRegistrationId
|
||||
rows <- sqlQuery
|
||||
"SELECT \
|
||||
\ COUNT(*) FILTER (WHERE ap.status = 'accepted')::int AS accepted, \
|
||||
\ COUNT(*) FILTER (WHERE ap.status = 'rejected')::int AS rejected, \
|
||||
\ COUNT(*) FILTER (WHERE ap.status NOT IN ('accepted','rejected'))::int AS other, \
|
||||
\ COUNT(*)::int AS total, \
|
||||
\ AVG(ca.score) AS mean_confidence \
|
||||
\ FROM agent_proposals ap \
|
||||
\ LEFT JOIN confidence_annotations ca ON ca.proposal_id = ap.id \
|
||||
\ WHERE ap.agent_registration_id = ? \
|
||||
\ AND ap.created_at >= NOW() - INTERVAL '30 days'"
|
||||
[PersistUUID (toUUID agentRegistrationId)]
|
||||
case rows of
|
||||
[(accepted, rejected, _other, total, mConf)] -> do
|
||||
now <- getCurrentTime
|
||||
let periodStart = addUTCTime (negate $ 30 * 86400) now
|
||||
newRecord @AgentPerformanceRecord
|
||||
|> set #agentRegistrationId agentRegistrationId
|
||||
|> set #hubId agent.hubId
|
||||
|> set #periodStart periodStart
|
||||
|> set #periodEnd now
|
||||
|> set #proposalsGenerated total
|
||||
|> set #proposalsAccepted accepted
|
||||
|> set #proposalsRejected rejected
|
||||
|> set #proposalsRevised 0
|
||||
|> set #meanConfidence mConf
|
||||
|> createRecord
|
||||
setSuccessMessage "Performance snapshot computed"
|
||||
_ -> setErrorMessage "Could not compute performance metrics"
|
||||
redirectTo (ShowAgentRegistrationAction agentRegistrationId)
|
||||
65
Web/Controller/AiGovernancePolicies.hs
Normal file
65
Web/Controller/AiGovernancePolicies.hs
Normal file
@@ -0,0 +1,65 @@
|
||||
module Web.Controller.AiGovernancePolicies where
|
||||
|
||||
-- IHF Phase 11 — Advanced AI Federation (IHUB-WP-0012 T08)
|
||||
|
||||
import Web.Controller.Prelude
|
||||
import Web.View.AiGovernancePolicies.Index
|
||||
import Web.View.AiGovernancePolicies.New
|
||||
import Application.Helper.AgentBridge (jsonArrayTexts)
|
||||
|
||||
validAllowedActions :: [Text]
|
||||
validAllowedActions = ["read", "propose", "delegate", "auto_apply"]
|
||||
|
||||
validateAllowedActions :: Value -> ValidatorResult
|
||||
validateAllowedActions val =
|
||||
let actions = jsonArrayTexts val
|
||||
invalid = filter (`notElem` validAllowedActions) actions
|
||||
in if null invalid
|
||||
then Success
|
||||
else Failure ("Invalid actions: " <> intercalate ", " invalid)
|
||||
|
||||
instance Controller AiGovernancePoliciesController where
|
||||
|
||||
action AiGovernancePoliciesAction = do
|
||||
policies <- query @AiGovernancePolicy
|
||||
|> orderByAsc #artifactType
|
||||
|> fetch
|
||||
hubs <- query @Hub |> orderByAsc #name |> fetch
|
||||
agents <- query @AgentRegistration |> orderByAsc #name |> fetch
|
||||
render IndexView { .. }
|
||||
|
||||
action NewAiGovernancePolicyAction = do
|
||||
let policy = newRecord @AiGovernancePolicy
|
||||
|> set #allowedActions (A.toJSON ["read" :: Text])
|
||||
hubs <- query @Hub |> orderByAsc #name |> fetch
|
||||
agents <- query @AgentRegistration
|
||||
|> filterWhere (#isActive, True)
|
||||
|> orderByAsc #name
|
||||
|> fetch
|
||||
render NewView { .. }
|
||||
|
||||
action CreateAiGovernancePolicyAction = do
|
||||
-- Collect allowed_actions from checkbox params
|
||||
selectedActions <- paramList @Text "allowedActions"
|
||||
let actionsJson = A.toJSON selectedActions
|
||||
let policy = newRecord @AiGovernancePolicy
|
||||
|> set #allowedActions actionsJson
|
||||
policy
|
||||
|> fill @'["hubId","agentRegistrationId","artifactType"]
|
||||
|> validateField #artifactType nonEmpty
|
||||
|> ifValid \case
|
||||
Left policy -> do
|
||||
hubs <- query @Hub |> orderByAsc #name |> fetch
|
||||
agents <- query @AgentRegistration |> filterWhere (#isActive, True) |> fetch
|
||||
render NewView { .. }
|
||||
Right policy -> do
|
||||
createRecord policy
|
||||
setSuccessMessage "Governance policy created"
|
||||
redirectTo AiGovernancePoliciesAction
|
||||
|
||||
action ToggleAiGovernancePolicyAction { aiGovernancePolicyId } = do
|
||||
policy <- fetch aiGovernancePolicyId
|
||||
policy |> set #isActive (not policy.isActive) |> updateRecord
|
||||
let msg = if policy.isActive then "Policy deactivated" else "Policy activated"
|
||||
setSuccessMessage msg
|
||||
redirectTo AiGovernancePoliciesAction
|
||||
103
Web/Controller/CollectiveProposals.hs
Normal file
103
Web/Controller/CollectiveProposals.hs
Normal file
@@ -0,0 +1,103 @@
|
||||
module Web.Controller.CollectiveProposals where
|
||||
|
||||
-- IHF Phase 11 — Advanced AI Federation (IHUB-WP-0012 T07)
|
||||
|
||||
import Web.Controller.Prelude
|
||||
import Web.View.CollectiveProposals.Index
|
||||
import Web.View.CollectiveProposals.Show
|
||||
import Application.Helper.AgentBridge (callAgent, BridgeResponse(..))
|
||||
import Application.Helper.ModelRouter (resolveAllAgents)
|
||||
import Data.List (intercalate)
|
||||
|
||||
instance Controller CollectiveProposalsController where
|
||||
|
||||
action CollectiveProposalsAction = do
|
||||
proposals <- query @CollectiveProposal
|
||||
|> orderByDesc #createdAt
|
||||
|> fetch
|
||||
render IndexView { .. }
|
||||
|
||||
action ShowCollectiveProposalAction { collectiveProposalId } = do
|
||||
proposal <- fetch collectiveProposalId
|
||||
contributions <- query @CollectiveProposalContribution
|
||||
|> filterWhere (#collectiveProposalId, collectiveProposalId)
|
||||
|> orderByAsc #contributedAt
|
||||
|> fetch
|
||||
agentNames <- forM contributions \c -> do
|
||||
agent <- fetch c.agentRegistrationId
|
||||
pure (c, agent.name)
|
||||
render ShowView { proposal, agentContributions = agentNames }
|
||||
|
||||
action CreateCollectiveProposalAction = do
|
||||
hubId <- param @(Id Hub) "hubId"
|
||||
title <- param @Text "title"
|
||||
taskType <- param @Text "taskType"
|
||||
prompt <- param @Text "prompt"
|
||||
mWidgetId <- paramOrNothing @(Id Widget) "sourceWidgetId"
|
||||
mCandId <- paramOrNothing @(Id RequirementCandidate) "sourceCandidateId"
|
||||
|
||||
proposal <- newRecord @CollectiveProposal
|
||||
|> set #title title
|
||||
|> set #taskType taskType
|
||||
|> set #consensusStatus "pending"
|
||||
|> set #sourceWidgetId mWidgetId
|
||||
|> set #sourceCandidateId mCandId
|
||||
|> createRecord
|
||||
|
||||
agents <- resolveAllAgents hubId taskType
|
||||
contributions <- forM agents \agent -> do
|
||||
result <- liftIO $ callAgent agent prompt
|
||||
case result of
|
||||
Left err -> pure Nothing
|
||||
Right resp -> do
|
||||
contrib <- newRecord @CollectiveProposalContribution
|
||||
|> set #collectiveProposalId proposal.id
|
||||
|> set #agentRegistrationId agent.id
|
||||
|> set #content (A.toJSON resp.content)
|
||||
|> set #tokensIn (Just resp.tokensIn)
|
||||
|> set #tokensOut (Just resp.tokensOut)
|
||||
|> set #modelUsed (Just resp.modelUsed)
|
||||
|> createRecord
|
||||
pure (Just (contrib, resp))
|
||||
|
||||
let successContribs = catMaybes contributions
|
||||
consensusStatus <- if null successContribs
|
||||
then pure "divergent"
|
||||
else do
|
||||
let contribTexts = map (\(_, r) -> r.content) successContribs
|
||||
synthesisPrompt = "The following agents have independently proposed solutions. "
|
||||
<> "Synthesize a unified recommendation:\n\n"
|
||||
<> intercalate "\n---\n" contribTexts
|
||||
mSynthAgent <- resolveAllAgents hubId taskType >>= \case
|
||||
(a:_) -> pure (Just a)
|
||||
[] -> pure Nothing
|
||||
case mSynthAgent of
|
||||
Nothing -> do
|
||||
proposal |> set #consensusStatus "divergent" |> updateRecord
|
||||
pure "divergent"
|
||||
Just synthAgent -> do
|
||||
synthResult <- liftIO $ callAgent synthAgent synthesisPrompt
|
||||
case synthResult of
|
||||
Left _ -> do
|
||||
proposal |> set #consensusStatus "divergent" |> updateRecord
|
||||
pure "divergent"
|
||||
Right synthResp -> do
|
||||
allContribs <- query @CollectiveProposalContribution
|
||||
|> filterWhere (#collectiveProposalId, proposal.id)
|
||||
|> fetch
|
||||
let cs = detectConsensus allContribs
|
||||
proposal
|
||||
|> set #consensusStatus cs
|
||||
|> set #finalContent (Just . A.toJSON $ synthResp.content)
|
||||
|> updateRecord
|
||||
pure cs
|
||||
|
||||
setSuccessMessage ("Collective proposal created (" <> consensusStatus <> ")")
|
||||
redirectTo ShowCollectiveProposalAction { collectiveProposalId = proposal.id }
|
||||
|
||||
-- | Simple consensus heuristic: if all contributions have a non-empty content
|
||||
-- and there are at least 2, mark as consensus; single contributor = pending.
|
||||
detectConsensus :: [CollectiveProposalContribution] -> Text
|
||||
detectConsensus contribs
|
||||
| length contribs >= 2 = "consensus"
|
||||
| otherwise = "pending"
|
||||
@@ -8,7 +8,8 @@ import Web.View.DecisionRecords.Edit
|
||||
import Generated.Types
|
||||
import IHP.Prelude
|
||||
import IHP.ControllerPrelude
|
||||
import Application.Helper.Controller (callClaudeApi)
|
||||
import Application.Helper.AgentBridge (callAgent, checkGovernancePolicy)
|
||||
import Application.Helper.ModelRouter (resolveAgent)
|
||||
import Data.List (intercalate)
|
||||
|
||||
validOutcomes :: [Text]
|
||||
@@ -178,7 +179,7 @@ instance Controller DecisionRecordsController where
|
||||
setSuccessMessage "Implementation reference removed"
|
||||
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
||||
|
||||
-- T07: Propose implementation paths via Claude API
|
||||
-- T07 / Phase 11: Propose implementation paths via routed agent
|
||||
action ProposeImplementationAction { decisionRecordId } = do
|
||||
record <- fetch decisionRecordId
|
||||
implRefs <- query @ImplementationChangeReference
|
||||
@@ -187,6 +188,10 @@ instance Controller DecisionRecordsController where
|
||||
mRequirement <- case record.requirementId of
|
||||
Nothing -> pure Nothing
|
||||
Just rid -> fetchOneOrNothing rid
|
||||
-- Resolve hub from the source widget via requirement candidate
|
||||
mHubId <- case mRequirement >>= (.sourceWidgetId) of
|
||||
Nothing -> pure Nothing
|
||||
Just wid -> fmap (.hubId) <$> fetchOneOrNothing @Widget wid
|
||||
let implLines = map (\r -> r.system <> ": " <> r.workItemRef) implRefs
|
||||
reqDesc = maybe "" (.description) mRequirement
|
||||
userMsg = "Decision: " <> record.title
|
||||
@@ -194,21 +199,46 @@ instance Controller DecisionRecordsController where
|
||||
<> "\nOutcome: " <> record.outcome
|
||||
<> "\nRequirement: " <> reqDesc
|
||||
<> "\nExisting impl refs: " <> intercalate ", " implLines
|
||||
result <- liftIO $ callClaudeApi
|
||||
"You are a traceability-aware implementation analyst. Propose 1\x20133 concrete implementation paths for this decision. Each path should include a work_item_ref (e.g. PROJ-123), a system (github|linear|jira), and a rationale. Respond with JSON: {\"proposals\": [{\"work_item_ref\": \"...\", \"system\": \"...\", \"rationale\": \"...\"}]}."
|
||||
userMsg
|
||||
600
|
||||
case result of
|
||||
Left err -> do
|
||||
setErrorMessage ("Implementation proposal failed: " <> err)
|
||||
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
||||
Right content -> do
|
||||
newRecord @AgentProposal
|
||||
|> set #proposalType "impl_proposal"
|
||||
|> set #sourceDecisionId (Just decisionRecordId)
|
||||
|> set #content content
|
||||
|> set #modelRef "claude-sonnet-4-6"
|
||||
|> set #status "pending"
|
||||
|> createRecord
|
||||
setSuccessMessage "Implementation proposal created"
|
||||
case mHubId of
|
||||
Nothing -> do
|
||||
setErrorMessage "Cannot determine hub for routing — ensure the decision has a linked requirement with a source widget"
|
||||
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
||||
Just hubId -> do
|
||||
mAgent <- resolveAgent hubId "implementation"
|
||||
case mAgent of
|
||||
Nothing -> do
|
||||
setErrorMessage "No routing policy for 'implementation' task type"
|
||||
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
||||
Just agent -> do
|
||||
allowed <- checkGovernancePolicy hubId agent.id "decision_record"
|
||||
if not allowed
|
||||
then do
|
||||
newRecord @AgentProposal
|
||||
|> set #proposalType "impl_proposal"
|
||||
|> set #sourceDecisionId (Just decisionRecordId)
|
||||
|> 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 ShowDecisionRecordAction { decisionRecordId }
|
||||
else do
|
||||
result <- liftIO $ callAgent agent userMsg
|
||||
case result of
|
||||
Left err -> do
|
||||
setErrorMessage ("Implementation proposal failed: " <> err.errorMessage)
|
||||
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
||||
Right resp -> do
|
||||
newRecord @AgentProposal
|
||||
|> set #proposalType "impl_proposal"
|
||||
|> set #sourceDecisionId (Just decisionRecordId)
|
||||
|> 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 "Implementation proposal created"
|
||||
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
||||
|
||||
47
Web/Controller/ModelRoutingPolicies.hs
Normal file
47
Web/Controller/ModelRoutingPolicies.hs
Normal file
@@ -0,0 +1,47 @@
|
||||
module Web.Controller.ModelRoutingPolicies where
|
||||
|
||||
-- IHF Phase 11 — Advanced AI Federation (IHUB-WP-0012 T04)
|
||||
|
||||
import Web.Controller.Prelude
|
||||
import Web.View.ModelRoutingPolicies.Index
|
||||
import Web.View.ModelRoutingPolicies.New
|
||||
|
||||
instance Controller ModelRoutingPoliciesController where
|
||||
|
||||
action ModelRoutingPoliciesAction = do
|
||||
policies <- query @ModelRoutingPolicy
|
||||
|> orderByAsc #taskType
|
||||
|> fetch
|
||||
hubs <- query @Hub |> orderByAsc #name |> fetch
|
||||
agents <- query @AgentRegistration |> orderByAsc #name |> fetch
|
||||
render IndexView { .. }
|
||||
|
||||
action NewModelRoutingPolicyAction = do
|
||||
let policy = newRecord @ModelRoutingPolicy
|
||||
hubs <- query @Hub |> orderByAsc #name |> fetch
|
||||
agents <- query @AgentRegistration
|
||||
|> filterWhere (#isActive, True)
|
||||
|> orderByAsc #name
|
||||
|> fetch
|
||||
render NewView { .. }
|
||||
|
||||
action CreateModelRoutingPolicyAction = do
|
||||
let policy = newRecord @ModelRoutingPolicy
|
||||
policy
|
||||
|> fill @'["hubId","taskType","agentRegistrationId","priority"]
|
||||
|> validateField #taskType nonEmpty
|
||||
|> ifValid \case
|
||||
Left policy -> do
|
||||
hubs <- query @Hub |> orderByAsc #name |> fetch
|
||||
agents <- query @AgentRegistration |> filterWhere (#isActive, True) |> fetch
|
||||
render NewView { .. }
|
||||
Right policy -> do
|
||||
createRecord policy
|
||||
setSuccessMessage "Routing policy created"
|
||||
redirectTo ModelRoutingPoliciesAction
|
||||
|
||||
action DeleteModelRoutingPolicyAction { modelRoutingPolicyId } = do
|
||||
policy <- fetch modelRoutingPolicyId
|
||||
deleteRecord policy
|
||||
setSuccessMessage "Routing policy deleted"
|
||||
redirectTo ModelRoutingPoliciesAction
|
||||
@@ -8,7 +8,8 @@ import Web.View.RequirementCandidates.Edit
|
||||
import Generated.Types
|
||||
import IHP.Prelude
|
||||
import IHP.ControllerPrelude
|
||||
import Application.Helper.Controller (callClaudeApi)
|
||||
import Application.Helper.AgentBridge (callAgent, checkGovernancePolicy)
|
||||
import Application.Helper.ModelRouter (resolveAgent)
|
||||
import Data.List (intercalate)
|
||||
import Data.Aeson (decode, Value(..), Array)
|
||||
import Data.Aeson.Lens (key, _String)
|
||||
@@ -257,33 +258,61 @@ instance Controller RequirementCandidatesController where
|
||||
setSuccessMessage "Decision record created"
|
||||
redirectTo ShowDecisionRecordAction { decisionRecordId = dr.id }
|
||||
|
||||
-- T05: Detect duplicate candidates via Claude API
|
||||
-- T05 / Phase 11: Detect duplicate candidates via routed agent
|
||||
action DetectDuplicatesAction { requirementCandidateId } = do
|
||||
target <- fetch requirementCandidateId
|
||||
others <- query @RequirementCandidate
|
||||
|> fetch
|
||||
others <- query @RequirementCandidate |> fetch
|
||||
-- Resolve hub from the source widget
|
||||
mHubId <- case target.sourceWidgetId of
|
||||
Nothing -> pure Nothing
|
||||
Just wid -> fmap (.hubId) <$> fetchOneOrNothing @Widget wid
|
||||
let otherLines = map (\c -> show c.id <> " | " <> c.title <> ": " <> c.description)
|
||||
(filter (\c -> c.id /= requirementCandidateId) others)
|
||||
targetLine = "TARGET: " <> target.title <> ": " <> target.description
|
||||
userMsg = targetLine <> "\n\nEXISTING:\n" <> intercalate "\n" otherLines
|
||||
result <- liftIO $ callClaudeApi
|
||||
"You are a deduplication assistant. Given a target candidate and a list of existing candidates, identify likely duplicates. Respond with JSON: {\"duplicates\": [{\"id\": \"uuid\", \"reason\": \"...\"}]}."
|
||||
userMsg
|
||||
500
|
||||
case result of
|
||||
Left err -> do
|
||||
setErrorMessage ("Duplicate detection failed: " <> err)
|
||||
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
|
||||
Right content -> do
|
||||
newRecord @AgentProposal
|
||||
|> set #proposalType "duplicate_flag"
|
||||
|> set #sourceCandidateId (Just requirementCandidateId)
|
||||
|> set #content content
|
||||
|> set #modelRef "claude-sonnet-4-6"
|
||||
|> set #status "pending"
|
||||
|> createRecord
|
||||
setSuccessMessage "Duplicate detection proposal created"
|
||||
case mHubId of
|
||||
Nothing -> do
|
||||
setErrorMessage "Cannot determine hub for routing — ensure the candidate has a source widget"
|
||||
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
|
||||
Just hubId -> do
|
||||
mAgent <- resolveAgent hubId "triage"
|
||||
case mAgent of
|
||||
Nothing -> do
|
||||
setErrorMessage "No routing policy for 'triage' task type"
|
||||
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
|
||||
Just agent -> do
|
||||
allowed <- checkGovernancePolicy hubId agent.id "requirement_candidate"
|
||||
if not allowed
|
||||
then do
|
||||
newRecord @AgentProposal
|
||||
|> set #proposalType "duplicate_flag"
|
||||
|> set #sourceCandidateId (Just requirementCandidateId)
|
||||
|> 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 ShowRequirementCandidateAction { requirementCandidateId }
|
||||
else do
|
||||
result <- liftIO $ callAgent agent userMsg
|
||||
case result of
|
||||
Left err -> do
|
||||
setErrorMessage ("Duplicate detection failed: " <> err.errorMessage)
|
||||
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
|
||||
Right resp -> do
|
||||
newRecord @AgentProposal
|
||||
|> set #proposalType "duplicate_flag"
|
||||
|> set #sourceCandidateId (Just requirementCandidateId)
|
||||
|> 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 "Duplicate detection proposal created"
|
||||
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
|
||||
|
||||
-- T06: Detect policy sensitivity via Claude API
|
||||
action DetectPolicySensitivityAction { requirementCandidateId } = do
|
||||
|
||||
@@ -9,8 +9,10 @@ import Generated.Types
|
||||
import IHP.Prelude
|
||||
import IHP.ControllerPrelude
|
||||
import Data.Aeson (toJSON, object, (.=))
|
||||
import Application.Helper.Controller (isInRegression, widgetCycleCounts, callClaudeApi)
|
||||
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
|
||||
@@ -168,8 +170,9 @@ instance Controller WidgetsController where
|
||||
setSuccessMessage "Widget updated"
|
||||
redirectTo ShowWidgetAction { widgetId = widget.id }
|
||||
|
||||
-- T03: Summarize feedback cluster via Claude API
|
||||
-- T03 / Phase 11: Summarize feedback cluster via routed agent
|
||||
action SummarizeClusterAction { widgetId } = do
|
||||
widget <- fetch widgetId
|
||||
annotations <- query @Annotation
|
||||
|> filterWhere (#widgetId, widgetId)
|
||||
|> orderByDesc #createdAt
|
||||
@@ -183,27 +186,48 @@ instance Controller WidgetsController where
|
||||
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)
|
||||
result <- liftIO $ callClaudeApi
|
||||
"You are a distillation assistant for a governed interaction hub. Summarize the following user feedback cluster into a concise, actionable summary (2\x20134 sentences). Be factual and neutral."
|
||||
userMsg
|
||||
300
|
||||
case result of
|
||||
Left err -> do
|
||||
setErrorMessage ("AI summarization failed: " <> err)
|
||||
redirectTo ShowWidgetAction { widgetId }
|
||||
Right content -> do
|
||||
newRecord @AgentProposal
|
||||
|> set #proposalType "summary"
|
||||
|> set #sourceWidgetId (Just widgetId)
|
||||
|> set #content content
|
||||
|> set #modelRef "claude-sonnet-4-6"
|
||||
|> set #status "pending"
|
||||
|> createRecord
|
||||
setSuccessMessage "Summary proposal created"
|
||||
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: Draft a requirement candidate via Claude API
|
||||
-- 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
|
||||
@@ -211,21 +235,41 @@ instance Controller WidgetsController where
|
||||
|> fetch
|
||||
let annLines = map (\a -> "[" <> a.category <> "/" <> a.severity <> "] " <> a.body) annotations
|
||||
userMsg = intercalate "\n" annLines
|
||||
result <- liftIO $ callClaudeApi
|
||||
"You are a requirements analyst. Given these friction annotations, draft a single structured requirement candidate. Respond with JSON: {\"title\": \"...\", \"description\": \"...\"}."
|
||||
userMsg
|
||||
400
|
||||
case result of
|
||||
Left err -> do
|
||||
setErrorMessage ("AI draft failed: " <> err)
|
||||
redirectTo ShowWidgetAction { widgetId }
|
||||
Right content -> do
|
||||
newRecord @AgentProposal
|
||||
|> set #proposalType "requirement_draft"
|
||||
|> set #sourceWidgetId (Just widgetId)
|
||||
|> set #content content
|
||||
|> set #modelRef "claude-sonnet-4-6"
|
||||
|> set #status "pending"
|
||||
|> createRecord
|
||||
setSuccessMessage "Requirement draft proposal created"
|
||||
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 }
|
||||
|
||||
Reference in New Issue
Block a user