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, callClaudeApi)
import Application.Helper.TypeRegistry (validateWidgetType, validatePolicyScope, activeWidgetTypes, activePolicyScopes)
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: Summarize feedback cluster via Claude API
    action SummarizeClusterAction { widgetId } = do
        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)
        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"
                redirectTo ShowWidgetAction { widgetId }

    -- T04: Draft a requirement candidate via Claude API
    action DraftRequirementAction { widgetId } = do
        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
        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"
                redirectTo ShowWidgetAction { widgetId }