Files
inter-hub/Web/View/DeploymentRecords/Show.hs
Bernd Worsch f1978c3888 fix(WP-0014): pre-flight compilation fixes, Tailwind pipeline, and admin seed
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>
2026-04-04 09:55:12 +00:00

337 lines
14 KiB
Haskell
Raw Blame History

This file contains ambiguous Unicode characters
This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
module Web.View.DeploymentRecords.Show where
import Web.Types
import Generated.Types
import IHP.Prelude
import IHP.ViewPrelude
import Web.Routes ()
import Data.Int (Int16)
data PeriodMetrics = PeriodMetrics
{ eventCount :: !Int
, annotationCount :: !Int
, lowCount :: !Int
, mediumCount :: !Int
, highCount :: !Int
, criticalCount :: !Int
}
highCriticalRate :: PeriodMetrics -> Double
highCriticalRate m
| m.annotationCount == 0 = 0
| otherwise = fromIntegral (m.highCount + m.criticalCount) / fromIntegral m.annotationCount
data ShowView = ShowView
{ record :: !DeploymentRecord
, decision :: !DecisionRecord
, mImplRef :: !(Maybe ImplementationChangeReference)
, mRequirement :: !(Maybe Requirement)
, mCandidate :: !(Maybe RequirementCandidate)
, mWidget :: !(Maybe Widget)
, signals :: ![OutcomeSignal]
, mEvaluation :: !(Maybe ChangeEvaluation)
, users :: ![User]
, comparison :: !(Maybe (PeriodMetrics, PeriodMetrics))
}
instance View ShowView where
html ShowView { .. } = [hsx|
<div class="mb-6 flex items-center gap-2 text-sm text-gray-500">
<a href={DeploymentRecordsAction} class="hover:text-gray-700">Deployments</a>
<span>/</span>
<span>{record.versionRef}</span>
</div>
<div class="max-w-3xl space-y-6">
<!-- Header card -->
<div class="bg-white rounded-lg border border-gray-200 px-6 py-5">
<div class="flex items-start justify-between mb-3">
<h1 class="text-2xl font-semibold">{record.versionRef}</h1>
</div>
<div class="text-xs text-gray-400 mb-3">
Deployed at: {show record.deployedAt} ·
Deployed by: {userName users record.deployedBy}
</div>
{maybe mempty renderNotes record.notes}
</div>
<!-- Decision chain -->
<div class="bg-white rounded-lg border border-gray-200 px-6 py-4">
<h2 class="text-sm font-semibold text-gray-700 mb-3">Decision Chain</h2>
<div class="space-y-2 text-sm">
<div class="flex items-center gap-2">
<span class="text-xs font-semibold text-gray-400 uppercase w-24">Decision</span>
<a href={ShowDecisionRecordAction (decision.id)}
class="text-indigo-600 hover:text-indigo-800">{decision.title}</a>
<span class={outcomeClass decision.outcome <> " text-xs px-2 py-0.5 rounded font-medium"}>
{decision.outcome}
</span>
</div>
{maybe mempty renderImplRefRow mImplRef}
{maybe mempty renderRequirementRow mRequirement}
{maybe mempty renderCandidateRow mCandidate}
{maybe mempty renderWidgetRow mWidget}
</div>
</div>
<!-- Outcome signals -->
<div class="bg-white rounded-lg border border-gray-200 px-6 py-4">
<h2 class="text-sm font-semibold text-gray-700 mb-3">Outcome Signals</h2>
{renderSignalsSection signals}
<form method="POST" action={RecordOutcomeSignalAction (record.id)}
class="flex items-end gap-2 mt-2">
<div>
<label class="text-xs text-gray-500 block mb-1">Signal type</label>
<select name="signalType"
class="text-sm border border-gray-300 rounded px-2 py-1.5">
<option value="improved">improved</option>
<option value="regressed">regressed</option>
<option value="neutral">neutral</option>
<option value="inconclusive">inconclusive</option>
</select>
</div>
<div>
<label class="text-xs text-gray-500 block mb-1">Value (0100, optional)</label>
<input type="number" name="value" min="0" max="100" step="any"
class="w-24 text-sm border border-gray-300 rounded px-2 py-1.5"
placeholder="" />
</div>
<button type="submit"
class="text-sm bg-gray-100 border border-gray-300 px-3 py-1.5 rounded hover:bg-gray-200">
Record
</button>
</form>
</div>
<!-- Change evaluation -->
<div class="bg-white rounded-lg border border-gray-200 px-6 py-4">
<h2 class="text-sm font-semibold text-gray-700 mb-3">Change Evaluation</h2>
{maybe (renderNoEvaluationForm record.id) renderEvaluation mEvaluation}
</div>
<!-- Pre/post comparison -->
{maybe mempty renderComparison comparison}
</div>
|]
renderNotes :: Text -> Html
renderNotes notes = [hsx|
<div class="mt-2">
<p class="text-xs font-semibold text-gray-500 uppercase tracking-wide mb-1">Notes</p>
<p class="text-sm text-gray-600 italic">{notes}</p>
</div>
|]
renderImplRefRow :: ImplementationChangeReference -> Html
renderImplRefRow ref = [hsx|
<div class="flex items-center gap-2">
<span class="text-xs font-semibold text-gray-400 uppercase w-24">Impl Ref</span>
<span class="font-mono text-gray-700">{ref.workItemRef}</span>
<span class="text-xs text-gray-400">({ref.system})</span>
</div>
|]
renderRequirementRow :: Requirement -> Html
renderRequirementRow req = [hsx|
<div class="flex items-center gap-2">
<span class="text-xs font-semibold text-gray-400 uppercase w-24">Requirement</span>
<a href={ShowRequirementAction (req.id)}
class="text-indigo-600 hover:text-indigo-800">{req.title}</a>
</div>
|]
renderCandidateRow :: RequirementCandidate -> Html
renderCandidateRow c = [hsx|
<div class="flex items-center gap-2">
<span class="text-xs font-semibold text-gray-400 uppercase w-24">Candidate</span>
<a href={ShowRequirementCandidateAction (c.id)}
class="text-indigo-600 hover:text-indigo-800">{c.title}</a>
</div>
|]
renderWidgetRow :: Widget -> Html
renderWidgetRow w = [hsx|
<div class="flex items-center gap-2">
<span class="text-xs font-semibold text-gray-400 uppercase w-24">Widget</span>
<a href={ShowWidgetAction (w.id)}
class="text-indigo-600 hover:text-indigo-800">{w.name}</a>
</div>
|]
renderSignalsSection :: [OutcomeSignal] -> Html
renderSignalsSection [] = [hsx|<p class="text-sm text-gray-400 mb-3">No signals recorded yet.</p>|]
renderSignalsSection sigs = [hsx|<div class="mb-4">{forEach sigs renderSignal}</div>|]
renderSignal :: OutcomeSignal -> Html
renderSignal sig = [hsx|
<div class="flex items-center gap-3 py-2 border-b border-gray-100 last:border-0">
<span class={signalTypeClass sig.signalType <> " text-xs px-2 py-0.5 rounded font-medium"}>
{sig.signalType}
</span>
{maybe mempty renderSignalValue sig.value}
<span class="text-xs text-gray-400 ml-auto">{show sig.observedAt}</span>
</div>
|]
renderSignalValue :: Double -> Html
renderSignalValue v = [hsx|
<span class="text-sm text-gray-700 font-mono">{show v}</span>
|]
renderNoEvaluationForm :: Id DeploymentRecord -> Html
renderNoEvaluationForm deploymentRecordId = [hsx|
<form method="POST" action={EvaluateChangeAction deploymentRecordId}
class="space-y-3">
{hiddenField "authenticity_token"}
<div>
<label class="block text-xs font-medium text-gray-600 mb-1">
Score (15) <span class="text-red-500">*</span>
</label>
<select name="score"
class="text-sm border border-gray-300 rounded px-3 py-1.5">
<option value="1">1 very poor</option>
<option value="2">2 poor</option>
<option value="3">3 neutral</option>
<option value="4">4 good</option>
<option value="5">5 excellent</option>
</select>
</div>
<div>
<label class="block text-xs font-medium text-gray-600 mb-1">
Rationale <span class="text-red-500">*</span>
</label>
<textarea name="rationale" rows="2" required
class="w-full text-sm border border-gray-300 rounded px-3 py-1.5"
placeholder="Why this score?"></textarea>
</div>
<button type="submit"
class="text-sm bg-indigo-600 text-white px-4 py-1.5 rounded hover:bg-indigo-700">
Evaluate
</button>
</form>
|]
renderEvaluation :: ChangeEvaluation -> Html
renderEvaluation ev = [hsx|
<div class="space-y-2">
<div class="flex items-center gap-2">
<span class={scoreClass ev.score <> " text-base px-2 py-0.5 rounded font-medium"}>
{starsFor ev.score}
</span>
</div>
<p class="text-sm text-gray-700">{ev.rationale}</p>
<p class="text-xs text-gray-400">{show ev.evaluatedAt}</p>
</div>
|]
renderComparison :: (PeriodMetrics, PeriodMetrics) -> Html
renderComparison (before, after) = [hsx|
<div class="bg-white rounded-lg border border-gray-200 px-6 py-4">
<h2 class="text-sm font-semibold text-gray-700 mb-3">
Pre/Post Comparison (±30 days)
</h2>
<table class="w-full text-sm">
<thead class="border-b border-gray-200">
<tr>
<th class="text-left py-2 text-xs font-semibold text-gray-500 uppercase tracking-wide">Metric</th>
<th class="text-right py-2 text-xs font-semibold text-gray-500 uppercase tracking-wide">Before</th>
<th class="text-right py-2 text-xs font-semibold text-gray-500 uppercase tracking-wide">After</th>
<th class="text-right py-2 text-xs font-semibold text-gray-500 uppercase tracking-wide">Delta</th>
</tr>
</thead>
<tbody>
{renderMetricRow "Interaction events" before.eventCount after.eventCount False}
{renderMetricRow "Annotations (total)" before.annotationCount after.annotationCount True}
{renderMetricRow "— low severity" before.lowCount after.lowCount True}
{renderMetricRow "— medium severity" before.mediumCount after.mediumCount True}
{renderMetricRow "— high severity" before.highCount after.highCount True}
{renderMetricRow "— critical severity" before.criticalCount after.criticalCount True}
{renderRateRow before after}
</tbody>
</table>
</div>
|]
renderMetricRow :: Text -> Int -> Int -> Bool -> Html
renderMetricRow label b a lowerIsBetter = [hsx|
<tr class="border-b border-gray-50">
<td class="py-2 text-gray-600">{label}</td>
<td class="py-2 text-right text-gray-700">{showNA b}</td>
<td class="py-2 text-right text-gray-700">{showNA a}</td>
<td class="py-2 text-right">
<span class={deltaClass (a - b) lowerIsBetter}>{showDelta (a - b)}</span>
</td>
</tr>
|]
where
showNA n = if n == 0 then "" else show n
showDelta d
| d == 0 = ""
| d > 0 = "+" <> show d
| otherwise = show d
renderRateRow :: PeriodMetrics -> PeriodMetrics -> Html
renderRateRow before after = [hsx|
<tr>
<td class="py-2 text-gray-600 font-medium">High/critical rate</td>
<td class="py-2 text-right text-gray-700">{formatRate (highCriticalRate before)}</td>
<td class="py-2 text-right text-gray-700">{formatRate (highCriticalRate after)}</td>
<td class="py-2 text-right">
<span class={rateClass (highCriticalRate after) (highCriticalRate before)}>
{formatRateDelta (highCriticalRate after - highCriticalRate before)}
</span>
</td>
</tr>
|]
where
formatRate r = show (round (r * 100) :: Int) <> "%"
formatRateDelta d
| abs d < 0.001 = ""
| d > 0 = "+" <> show (round (d * 100) :: Int) <> "%"
| otherwise = show (round (d * 100) :: Int) <> "%"
deltaClass :: Int -> Bool -> Text
deltaClass 0 _ = "text-gray-400"
deltaClass d True
| d < 0 = "text-green-600 font-medium"
| otherwise = "text-red-600 font-medium"
deltaClass d False
| d > 0 = "text-green-600 font-medium"
| otherwise = "text-red-600 font-medium"
rateClass :: Double -> Double -> Text
rateClass after before
| abs (after - before) < 0.001 = "text-gray-400"
| after < before = "text-green-600 font-medium"
| otherwise = "text-red-600 font-medium"
signalTypeClass :: Text -> Text
signalTypeClass "improved" = "bg-green-100 text-green-800"
signalTypeClass "regressed" = "bg-red-100 text-red-800"
signalTypeClass "neutral" = "bg-gray-100 text-gray-600"
signalTypeClass "inconclusive" = "bg-yellow-100 text-yellow-800"
signalTypeClass _ = "bg-gray-100 text-gray-600"
outcomeClass :: Text -> Text
outcomeClass "accepted" = "bg-green-100 text-green-800"
outcomeClass "rejected" = "bg-red-100 text-red-800"
outcomeClass "deferred" = "bg-gray-100 text-gray-600"
outcomeClass "split" = "bg-purple-100 text-purple-800"
outcomeClass "merged" = "bg-indigo-100 text-indigo-800"
outcomeClass "reframed" = "bg-orange-100 text-orange-800"
outcomeClass _ = "bg-gray-100 text-gray-600"
scoreClass :: Int16 -> Text
scoreClass n
| n <= 2 = "bg-red-100 text-red-800"
| n == 3 = "bg-yellow-100 text-yellow-800"
| otherwise = "bg-green-100 text-green-800"
starsFor :: Int16 -> Text
starsFor n = pack (Prelude.replicate (fromIntegral n) '★') <> pack (Prelude.replicate (5 - fromIntegral n) '☆')
userName :: [User] -> Maybe (Id User) -> Text
userName _ Nothing = ""
userName users (Just uid) = maybe "(unknown)" (.name) (find (\u -> u.id == uid) users)