generated from coulomb/repo-seed
Bernd Worsch
98fb159582
Some checks failed
Test / test (push) Has been cancelled
T01 schema: friction_scores, bottleneck_records, hub_health_snapshots, cross_hub_propagations + migration 1743552000. T02 Widget Pain Heatmap: computeFrictionScore (formula documented), RecomputeFriction action, colour-coded grid view (green/yellow/amber/red). T03 Workflow Bottleneck Analysis: detectBottlenecks across 4 pipeline stages (candidate 30d, requirement 60d, decision 30d, observation 14d), idempotent, severity from age ratio, resolve action. T04 Hub Health Correlation: computeHubHealth (deduction table documented), append-only HubHealthSnapshot, health history view, badge on hub Show page. T05 Cross-Hub Propagation: annotation_cluster + widget_type_friction heuristics, idempotent detection, acknowledge/resolve lifecycle. T06 Operational Review Board: 4-panel AutoRefresh global dashboard — health matrix, top-10 friction, bottleneck stage counts, open propagations. T07 gate: 5 describe blocks in Test/Integration.hs; SCOPE.md updated Phase 7 complete; docs/phase7-summary.md written. Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
79 lines
3.7 KiB
Haskell
79 lines
3.7 KiB
Haskell
module Application.Helper.CrossHubPropagation where
|
|
|
|
import IHP.Prelude
|
|
import IHP.ModelSupport
|
|
import Generated.Types
|
|
import Data.Time.Clock (addUTCTime, getCurrentTime)
|
|
import Data.Aeson (toJSON)
|
|
import qualified Data.List as List
|
|
|
|
-- | 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 = 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 = 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 = clusterPropagations <> frictionPropagations
|
|
|
|
mapM (\(srcHubId, affectedHubIds, ptype, summary) ->
|
|
newRecord @CrossHubPropagation
|
|
|> set #patternType ptype
|
|
|> set #sourceHubId (Just srcHubId)
|
|
|> set #affectedHubIds (toJSON (map show affectedHubIds))
|
|
|> set #summary summary
|
|
|> set #status "open"
|
|
|> createRecord
|
|
) allPatterns
|