inter-hub-haskell/Application/Helper/CrossHubPropagation.hs

module Application.Helper.CrossHubPropagation where

import IHP.Prelude
import IHP.ModelSupport
import IHP.QueryBuilder
import IHP.Fetch
import Generated.Types
import Web.Routes ()
import Data.Time.Clock (addUTCTime, getCurrentTime)
import Data.Aeson (toJSON)
import qualified Data.List as List
import Control.Monad (guard)

-- | Detect cross-hub propagation patterns and insert CrossHubPropagation rows.
-- Idempotent: skips patterns for which an open/acknowledged record already exists.
detectPropagations
    :: (?modelContext :: ModelContext)
    => [Hub]
    -> [Annotation]    -- all annotations across all hubs, widget already resolved
    -> [Widget]        -- all widgets (to map widgetId → hubId)
    -> [FrictionScore] -- all friction scores
    -> IO [CrossHubPropagation]
detectPropagations hubs annotations widgets frictionScores = do
    now <- getCurrentTime
    let fourteenDaysAgo = addUTCTime (negate $ 14 * 86400) now

    existing <- query @CrossHubPropagation
        |> filterWhereSql (#status, "IN ('open','acknowledged')")
        |> fetch

    -- Helper: find hub for a widget
    let widgetHub wid = (.hubId) <$> find (\w -> w.id == wid) widgets

    -- Heuristic 1: annotation category clustering
    -- For each category, count distinct hubs with ≥3 annotations in last 14 days
    let recentAnnotations = filter (\a -> a.createdAt >= fourteenDaysAgo) annotations
        categories = List.nub (map (.category) recentAnnotations)
        clusterPropagations = do
            cat <- categories
            let catAnnots = filter (\a -> a.category == cat) recentAnnotations
                hubCounts = map (\hid -> (hid, length (filter (\a -> widgetHub a.widgetId == Just hid) catAnnots)))
                            (List.nub (mapMaybe (\a -> widgetHub a.widgetId) catAnnots))
                qualHubs  = [ hid | (hid, cnt) <- hubCounts, cnt >= 3 ]
            guard (length qualHubs >= 2)
            let srcHub = List.head qualHubs
                summary = "Annotation category '" <> cat <> "' concentrated in "
                        <> show (length qualHubs) <> " hubs"
            -- Skip if open/acknowledged record already exists with same summary
            guard (not (any (\p -> p.patternType == "annotation_cluster" && p.summary == summary) existing))
            pure (srcHub, qualHubs, "annotation_cluster", summary)

    -- Heuristic 2: widget type friction across hubs
    let widgetTypes = List.nub (map (.widgetType) widgets)
        frictionThreshold = 40 :: Int
        frictionPropagations = do
            wtype <- widgetTypes
            let typeWidgets = filter (\w -> w.widgetType == wtype) widgets
                hubsWithHighFriction =
                    List.nub
                    [ w.hubId
                    | w <- typeWidgets
                    , Just fs <- [find (\f -> f.widgetId == w.id) frictionScores]
                    , fs.score >= frictionThreshold
                    ]
            guard (length hubsWithHighFriction >= 2)
            let srcHub  = List.head hubsWithHighFriction
                summary = "Widget type '" <> wtype <> "' has high friction in "
                        <> show (length hubsWithHighFriction) <> " hubs"
            guard (not (any (\p -> p.patternType == "widget_type_friction" && p.summary == summary) existing))
            pure (srcHub, hubsWithHighFriction, "widget_type_friction", summary)

    let allPatterns :: [(Id' "hubs", [Id' "hubs"], Text, Text)]
        allPatterns = clusterPropagations <> frictionPropagations

    let insertPropagation (rawSrcId, affectedHubIds, ptype, summary) = do
            let srcId = rawSrcId :: Id' "hubs"
            newRecord @CrossHubPropagation
                |> set #patternType    ptype
                |> set #sourceHubId   (Just srcId)
                |> set #affectedHubIds (toJSON (map show affectedHubIds))
                |> set #summary        summary
                |> set #status         "open"
                |> createRecord
    mapM insertPropagation allPatterns