generated from coulomb/repo-seed
Bernd Worsch
74bab5f6f2
- Schema.sql: add FK constraints for phases 6–12 so IHP generates Id X instead of UUID for FK columns (widget_adapter_specs, friction_scores, hub_routing_rules, agent_proposals, hub_capability_manifests, etc.) - HubHealth, ModelRouter, ApiInteractionEvents: remove toUUID() wrappers now that FK columns carry proper Id types - FederatedGovernance/Dashboard, HubRoutingRules/Index: same Id comparison fix - AgentProposals/Index, DecisionRecords/Index, ApiConsumers/Edit: Id type fixes - BottleneckDetector: add Data.Coerce import; CrossHubPropagation: add guard - ApiKeys: qualify cryptohash-sha256 import to resolve package ambiguity - WebhookDeliveryJob: use LBS.fromStrict; remove duplicate diffUTCTime - Sessions/New: use renderFlashMessages (IHP built-in) - ArchiveRecords/LineageInspector: simplify renderChainStep signature - static/app.css: Tailwind CSS output (2011 lines) — A3 confirmed - workplans/IHUB-WP-0015-local-deployment-intro-ui.md: add workplan Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
83 lines
3.8 KiB
Haskell
83 lines
3.8 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 = 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
|