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>
337 lines
14 KiB
Haskell
337 lines
14 KiB
Haskell
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 (0–100, 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 (1–5) <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 (replicate (fromIntegral n) '★') <> pack (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)
|