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

module Web.Controller.PatternPerformance where

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

import Web.Controller.Prelude
import Web.View.PatternPerformance.Index
import IHP.ModelSupport (sqlQuery)

instance Controller PatternPerformanceController where
    beforeAction = ensureIsUser

    action PatternPerformanceAction = do
        records <- query @PatternPerformanceRecord
            |> orderByAsc #outcomeRank
            |> fetch
        hubs    <- query @Hub |> orderByAsc #name |> fetch
        render IndexView { records, hubs }

    action ComputePatternPerformanceAction { hubIdForPerformance } = do
        let hubId = hubIdForPerformance
        rows <- sqlQuery
            "SELECT \
            \    wp.id AS pattern_id, \
            \    COUNT(DISTINCT pa.id)::int AS adoption_count, \
            \    COUNT(os.id)::int AS total_outcome_count, \
            \    COUNT(os.id) FILTER ( \
            \        WHERE os.signal_type IN ('success','adoption','satisfaction') \
            \    )::int AS positive_outcome_count, \
            \    AVG(os.value) AS mean_outcome_value \
            \ FROM widget_patterns wp \
            \ JOIN pattern_adoptions pa ON pa.widget_pattern_id = wp.id \
            \ JOIN widgets w ON w.hub_id = pa.adopting_hub_id \
            \     AND w.widget_type = wp.widget_type \
            \ JOIN deployment_records dep ON dep.id IN ( \
            \     SELECT dep2.id FROM deployment_records dep2 \
            \     JOIN decision_records dr2 ON dr2.id = dep2.decision_id \
            \     JOIN requirements r2 ON r2.id = dr2.requirement_id \
            \     JOIN requirement_candidates rc2 ON rc2.id = r2.candidate_id \
            \     WHERE rc2.source_widget_id = w.id \
            \ ) \
            \ JOIN outcome_signals os ON os.deployment_id = dep.id \
            \ WHERE pa.adopting_hub_id = ? \
            \ GROUP BY wp.id"
            (Only hubId)
            :: IO [(Id WidgetPattern, Int, Int, Int, Maybe Double)]

        now <- getCurrentTime
        -- Delete existing records for this hub then insert fresh
        query @PatternPerformanceRecord
            |> filterWhere (#hubId, hubId)
            |> fetch
            >>= deleteRecords
        -- Insert with rank computation
        let sorted = sortBy (\(_, _, _, pos1, _) (_, _, _, pos2, _) -> compare pos2 pos1) rows
            ranked = zip [1..] sorted
        forM_ ranked \(rank, (patId, adoptions, total, positive, meanVal)) ->
            newRecord @PatternPerformanceRecord
                |> set #widgetPatternId patId
                |> set #hubId hubId
                |> set #adoptionCount adoptions
                |> set #positiveOutcomeCount positive
                |> set #totalOutcomeCount total
                |> set #meanOutcomeValue meanVal
                |> set #outcomeRank (Just rank)
                |> set #calibratedAt now
                |> createRecord

        setSuccessMessage ("Pattern performance computed: " <> show (length rows) <> " patterns")
        redirectTo PatternPerformanceAction