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

module Web.Controller.AdaptiveThresholds where

-- IHF Phase 12 — Platform Memory (IHUB-WP-0013 T04)

import Web.Controller.Prelude
import Web.View.AdaptiveThresholds.Index
import IHP.ModelSupport (sqlQuery)
import Database.PostgreSQL.Simple (Only(..))
import qualified Data.Aeson as A

instance Controller AdaptiveThresholdsController where
    beforeAction = ensureIsUser

    action AdaptiveThresholdsAction = do
        hubs    <- query @Hub |> orderByAsc #name |> fetch
        configs <- query @AdaptiveThresholdConfig |> fetch
        insights <- query @LearningInsight
            |> filterWhere (#insightType, "threshold_calibration")
            |> orderByDesc #computedAt
            |> limit 10
            |> fetch
        render IndexView { hubs, configs, insights }

    action CalibrateThresholdsAction { hubIdForThreshold } = do
        let hubId = hubIdForThreshold
        -- Step 1: find weak-predictor categories (score < 0.3)
        weakCats <- sqlQuery
            "SELECT annotation_category FROM outcome_correlations \
            \ WHERE hub_id = ? AND correlation_score < 0.3"
            (Only hubId)
            :: IO [Only Text]

        -- Step 2: compute bottleneck threshold override = mean friction score
        -- for widgets with at least one negative outcome signal
        [Only mBottleneckOverride] <- sqlQuery
            "SELECT AVG(fs.score) \
            \ FROM friction_scores fs \
            \ JOIN widgets w ON w.id = fs.widget_id \
            \ WHERE w.hub_id = ? \
            \   AND EXISTS ( \
            \       SELECT 1 FROM outcome_signals os \
            \       JOIN deployment_records dep ON dep.id = os.deployment_id \
            \       JOIN decision_records dr ON dr.id = dep.decision_id \
            \       JOIN requirements r ON r.id = dr.requirement_id \
            \       JOIN requirement_candidates rc ON rc.id = r.candidate_id \
            \       WHERE rc.source_widget_id = w.id \
            \         AND os.signal_type NOT IN ('success','adoption','satisfaction') \
            \   )"
            (Only hubId)
            :: IO [Only (Maybe Double)]

        now <- getCurrentTime
        let weakNote = "Weak predictor categories (score < 0.3): "
                    <> intercalate ", " (map fromOnly weakCats)

        -- Step 3: upsert AdaptiveThresholdConfig
        existing <- query @AdaptiveThresholdConfig
            |> filterWhere (#hubId, hubId)
            |> fetchOneOrNothing
        case existing of
            Just cfg ->
                cfg
                    |> set #bottleneckThresholdOverride mBottleneckOverride
                    |> set #calibrationDate now
                    |> set #notes (Just weakNote)
                    |> updateRecord
            Nothing ->
                newRecord @AdaptiveThresholdConfig
                    |> set #hubId hubId
                    |> set #weightOverrides (A.Object mempty)
                    |> set #bottleneckThresholdOverride mBottleneckOverride
                    |> set #calibrationDate now
                    |> set #notes (Just weakNote)
                    |> createRecord

        -- Step 4: write LearningInsight
        newRecord @LearningInsight
            |> set #hubId hubId
            |> set #insightType "threshold_calibration"
            |> set #title "Adaptive threshold calibration completed"
            |> set #body ("Calibrated friction thresholds. " <> weakNote
                <> maybe "" (\b -> " Bottleneck override: " <> show b) mBottleneckOverride)
            |> set #evidenceLinks (A.toJSON ([] :: [A.Value]))
            |> createRecord

        setSuccessMessage "Threshold calibration complete"
        redirectTo AdaptiveThresholdsAction