generated from coulomb/repo-seed
Bernd Worsch
f1978c3888
A2 — Compilation fixes: - Remove inline FK constraints from Schema.sql; IHP schema compiler cannot parse them. Add 1744329600-restore-fk-constraints.sql migration to restore referential integrity at the DB level. - Rename `#label` → `#label_` throughout to avoid clash with Haskell built-in. - Fix `hub.id == hid` UUID comparisons to use `toUUID hub.id`. - Replace non-existent `setStatus`/`respondJson` calls with `renderJsonWithStatusCode` throughout Api controllers. - Fix qualified package import for `cryptohash-sha256` in Auth.hs. - Add `CanSelect (Text, Text)` instance in Helper.View. - Refactor HSX inline lambdas to named helper functions in 100+ views (GHC cannot infer types for anonymous functions inside quasi-quoted HSX). - Fix missing imports (IHP.QueryBuilder, IHP.Fetch, Web.Routes, Only, etc.) across helpers and controllers. - Remove duplicate `diffUTCTime` definition in BottleneckDetector. - Change `createEventForHub` return type from `IO ResponseReceived` to `IO ()`. - Seed type-registry vocabulary via 1744502400-seed-type-registries.sql (moved from Schema.sql where IHP does not execute INSERT statements). A3 — Tailwind build pipeline: - Add `tailwindcss` to flake.nix native packages. - Uncomment `tailwind.exec` process in devenv shell config. - Add tailwind/tailwind.config.js (scans Web/View/**/*.hs). - Add tailwind/app.css with @tailwind directives. A4 — Admin user seed: - Add 1744416000-seed-admin-user.sql: inserts admin@inter-hub.local with bcrypt-hashed password admin1234! (cost 10). - Add .env.example documenting all required environment variables and default admin credentials. Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
82 lines
3.7 KiB
Haskell
82 lines
3.7 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
|
|
|
|
-- | 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
|