generated from coulomb/repo-seed
Bernd Worsch
ce42607fca
Convert all remaining `<- paramOrNothing / param / paramOrDefault /
currentUserOrNothing` monadic binds to `let` — these functions are pure
(ImplicitParams-based) in IHP v1.5, so `<-` is a type error in an IO
do-block.
Controllers fixed:
AgentDelegations, AiGovernancePolicies, Annotations, ApiConsumers,
CollectiveProposals, DecisionRecords, DeploymentRecords,
HubCapabilityManifests, HubRoutingRules, InstitutionalKnowledge,
OutcomeCorrelations, RequirementCandidates, TypeRegistries,
WebhookSubscriptions, Widgets,
Api/V2/{Annotations,InteractionEvents,Token}
WebhookSubscriptions: remove orphaned `Right () ->` case arm that was
left inside a bare `unless` block (structural parse error).
Also carries forward all in-progress fixes from the working tree:
helpers (AgentBridge, ApiRateLimit, BottleneckDetector,
CrossHubPropagation, FrictionScore),
views (CanSelect instances, HSX lambda extraction, formFor wrappers),
env/build (envrc GHCi perms, flake.nix Tailwind + GHC resource limits,
static/app.css additional Tailwind output).
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 = 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 :: [(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
|