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>
74 lines
3.0 KiB
Haskell
74 lines
3.0 KiB
Haskell
module Application.Helper.Controller where
|
|
|
|
import IHP.ControllerPrelude
|
|
import Generated.Types
|
|
import Web.Routes ()
|
|
import Data.Time.Clock (addUTCTime)
|
|
import Data.List (sortBy)
|
|
|
|
-- Here you can add functions which are available in all your controllers
|
|
|
|
-- | Returns the set of widget IDs that are currently in regression.
|
|
--
|
|
-- A regression is defined as: a widget that has an OutcomeSignal(improved)
|
|
-- for any deployment, followed by a new Annotation(severity IN high/critical)
|
|
-- created more than 1 day after the signal's observed_at (grace period).
|
|
regressedWidgetIds :: [OutcomeSignal] -> [Annotation] -> [Id Widget]
|
|
regressedWidgetIds signals annotations =
|
|
[ wid
|
|
| wid <- nub (map (.widgetId) signals)
|
|
, isInRegression signals annotations wid
|
|
]
|
|
|
|
isInRegression :: [OutcomeSignal] -> [Annotation] -> Id Widget -> Bool
|
|
isInRegression signals annotations wid =
|
|
let improvedSignals = filter (\s -> s.widgetId == wid && s.signalType == "improved") signals
|
|
highAnns = filter (\a -> a.widgetId == wid
|
|
&& a.severity `elem` ["high", "critical"]
|
|
&& isNothing a.retractedAt) annotations
|
|
graceEnd sig = addUTCTime (24 * 3600) sig.observedAt
|
|
in any (\sig -> any (\ann -> ann.createdAt > graceEnd sig) highAnns) improvedSignals
|
|
|
|
-- | Computes the number of completed improvement cycles per widget.
|
|
--
|
|
-- A cycle is counted when:
|
|
-- 1. A RequirementCandidate for the widget was accepted
|
|
-- 2. A DecisionRecord exists for that requirement/candidate
|
|
-- 3. A DeploymentRecord exists for that decision
|
|
-- 4. A new RequirementCandidate was subsequently created for the same widget
|
|
--
|
|
-- Returns a list of (widgetId, cycleCount) for widgets with cycleCount >= 1,
|
|
-- sorted descending by cycleCount.
|
|
widgetCycleCounts
|
|
:: [RequirementCandidate]
|
|
-> [Requirement]
|
|
-> [DecisionRecord]
|
|
-> [DeploymentRecord]
|
|
-> [(Id Widget, Int)]
|
|
widgetCycleCounts candidates requirements decisions deployments =
|
|
sortBy (\(_, a) (_, b) -> compare b a)
|
|
[ (wid, cycleCount wid)
|
|
| wid <- nub (map (.sourceWidgetId) candidates)
|
|
, cycleCount wid >= 1
|
|
]
|
|
where
|
|
-- A completed cycle: accepted candidate → requirement → decision → deployment
|
|
completedCycleDeploymentTimes wid =
|
|
[ dr.deployedAt
|
|
| c <- filter (\x -> x.sourceWidgetId == wid && x.status == "accepted") candidates
|
|
, req <- filter (\x -> x.sourceCandidateId == c.id) requirements
|
|
, dec <- filter (\x -> x.requirementId == Just req.id) decisions
|
|
, dr <- filter (\x -> x.decisionId == dec.id) deployments
|
|
]
|
|
|
|
cycleCount wid =
|
|
let deplTimes = completedCycleDeploymentTimes wid
|
|
-- For each completed cycle, check if a subsequent candidate was created
|
|
widCandidates = filter (\x -> x.sourceWidgetId == wid) candidates
|
|
in length
|
|
[ ()
|
|
| deplTime <- deplTimes
|
|
, any (\c -> c.createdAt > deplTime) widCandidates
|
|
]
|
|
|