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

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, bridgeErrorMessage, BridgeResponse(..))
import Application.Helper.ModelRouter (resolveAgent)

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
            widgetTypeText = paramOrDefault @Text "" "widgetType"
            mPolicyScope   = paramOrNothing @Text "policyScope"
        widgetTypeVal  <- liftIO (validateWidgetType widgetTypeText)
        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 () -> \x -> x)
            |> (case policyScopeVal of
                    Left msg -> attachFailure #policyScope msg
                    Right () -> \x -> x)
            |> 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
            widgetTypeText = paramOrDefault @Text "" "widgetType"
            mPolicyScope   = paramOrNothing @Text "policyScope"
        widgetTypeVal  <- liftIO (validateWidgetType widgetTypeText)
        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 () -> \x -> x)
            |> (case policyScopeVal of
                    Left msg -> attachFailure #policyScope msg
                    Right () -> \x -> x)
            |> 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: " <> bridgeErrorMessage err)
                                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: " <> bridgeErrorMessage err)
                                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 }