inter-hub/Web/Controller/CollectiveProposals.hs

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"