inter-hub-haskell/Web/Controller/CollectiveProposals.hs

module Web.Controller.CollectiveProposals where

-- IHF Phase 11 — Advanced AI Federation (IHUB-WP-0012 T07)
-- Updated: agents invoked concurrently via callAgentsBatch (FR-3 async).

import Web.Controller.Prelude
import Web.View.CollectiveProposals.Index
import Web.View.CollectiveProposals.Show
import Application.Helper.AgentBridge (callAgent, callAgentsBatch, BridgeResponse(..))
import Application.Helper.ModelRouter (resolveAllAgents)
import qualified Data.Aeson as A

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
        let 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

        -- FR-3: invoke all agents concurrently in a single bridge subprocess call
        -- instead of sequential forM.  Latency now scales with the slowest agent,
        -- not the sum of all agents.
        results <- liftIO $ callAgentsBatch [(a, prompt) | a <- agents]

        successContribs <- fmap catMaybes $ forM (zip agents results) \(agent, result) ->
            case result of
                Left _     -> 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))

        consensusStatus <- if null successContribs
            then do
                proposal |> set #consensusStatus "divergent" |> updateRecord
                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
                -- Synthesis uses the highest-priority agent (head of the list)
                case agents of
                    [] -> do
                        proposal |> set #consensusStatus "divergent" |> updateRecord
                        pure "divergent"
                    (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: ≥2 successful contributions = consensus.
detectConsensus :: [CollectiveProposalContribution] -> Text
detectConsensus contribs
    | length contribs >= 2 = "consensus"
    | otherwise            = "pending"