generated from coulomb/repo-seed
Bernd Worsch
58cad31042
- CrossHubPropagation: IHP.Prelude.head returns Maybe a; use List.head (Data.List.head, already imported qualified) for non-empty-guarded lists - Sessions: currentUserOrNothing is pure Maybe, not IO; use case...of instead of >>= Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
85 lines
3.9 KiB
Haskell
85 lines
3.9 KiB
Haskell
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
|