feat(P4): IHF Phase 4 complete — Outcome Observation and Antifragility Loop
Some checks failed
Test / test (push) Has been cancelled

Closes the IHF improvement loop. Full antifragility chain now traversable:
Widget → Annotation → Candidate → Requirement → Decision → Deployment → OutcomeSignal

New artifacts:
- DeploymentRecord (immutable, links DecisionRecord to a deployed version)
- OutcomeSignal (append-only; DB trigger prevents UPDATE/DELETE)
- ChangeEvaluation (one-per-deployment; UNIQUE constraint; 1–5 score)

New capabilities:
- DeploymentRecordsController (index, show, new, create)
- RecordOutcomeSignalAction — capture improved/regressed/neutral/inconclusive signals
- Pre/post comparison panel on deployment show (±30-day event/annotation counts)
- Regression detection — improved signal followed by high/critical annotation
- ChangeEvaluation — idempotent score+rationale per deployment
- Recurrence tracking — cycle count per widget, leaderboard
- AntifragilityDashboardAction (autoRefresh, 5 panels) per hub
- Phase 4 integration tests (T01–T08 logic coverage)
- docs/phase4-summary.md; SCOPE.md updated to Phase 4 complete

State Hub: workstream 07e9c860 → completed

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
2026-03-29 12:27:30 +00:00
parent bc57852473
commit 878d2577ae
22 changed files with 1782 additions and 44 deletions

View File

@@ -34,26 +34,36 @@ instance Controller DecisionRecordsController where
render IndexView { records, requirements, users, mOutcomeFilter }
action ShowDecisionRecordAction { decisionRecordId } = do
record <- fetch decisionRecordId
policyRefs <- query @PolicyReference
record <- fetch decisionRecordId
policyRefs <- query @PolicyReference
|> filterWhere (#decisionId, decisionRecordId)
|> orderByAsc #createdAt
|> fetch
implRefs <- query @ImplementationChangeReference
implRefs <- query @ImplementationChangeReference
|> filterWhere (#decisionId, decisionRecordId)
|> orderByAsc #linkedAt
|> fetch
mRequirement <- case record.requirementId of
deploymentRecords <- query @DeploymentRecord
|> filterWhere (#decisionId, decisionRecordId)
|> orderByDesc #deployedAt
|> fetch
let deploymentIds = map (.id) deploymentRecords
evaluations <- query @ChangeEvaluation
|> filterWhereIn (#deploymentId, deploymentIds)
|> fetch
mRequirement <- case record.requirementId of
Nothing -> pure Nothing
Just rid -> fetchOneOrNothing rid
mCandidate <- case record.candidateId of
mCandidate <- case record.candidateId of
Nothing -> pure Nothing
Just cid -> fetchOneOrNothing cid
users <- query @User |> fetch
users <- query @User |> fetch
render ShowView
{ record
, policyRefs
, implRefs
, deploymentRecords
, evaluations
, mRequirement
, mCandidate
, users

View File

@@ -0,0 +1,180 @@
module Web.Controller.DeploymentRecords where
import Web.Types
import Web.View.DeploymentRecords.Index
import Web.View.DeploymentRecords.Show
import Web.View.DeploymentRecords.New
import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
import Data.Time.Clock (addUTCTime, NominalDiffTime)
import Text.Read (readMaybe)
import Data.String.Conversions (cs)
instance Controller DeploymentRecordsController where
beforeAction = ensureIsUser
action DeploymentRecordsAction = do
records <- query @DeploymentRecord |> orderByDesc #deployedAt |> fetch
decisions <- query @DecisionRecord |> fetch
signals <- query @OutcomeSignal |> fetch
evaluations <- query @ChangeEvaluation |> fetch
render IndexView { records, decisions, signals, evaluations }
action ShowDeploymentRecordAction { deploymentRecordId } = do
record <- fetch deploymentRecordId
decision <- fetch record.decisionId
mImplRef <- case record.implRefId of
Nothing -> pure Nothing
Just rid -> fetchOneOrNothing rid
mRequirement <- case decision.requirementId of
Nothing -> pure Nothing
Just rid -> fetchOneOrNothing rid
mCandidate <- case decision.candidateId of
Nothing -> pure Nothing
Just cid -> fetchOneOrNothing cid
mWidget <- case mCandidate of
Nothing -> pure Nothing
Just c -> fetchOneOrNothing c.sourceWidgetId
signals <- query @OutcomeSignal
|> filterWhere (#deploymentId, deploymentRecordId)
|> orderByDesc #observedAt
|> fetch
mEvaluation <- query @ChangeEvaluation
|> filterWhere (#deploymentId, deploymentRecordId)
|> fetchOneOrNothing
users <- query @User |> fetch
comparison <- computeComparison record.deployedAt mWidget
render ShowView
{ record
, decision
, mImplRef
, mRequirement
, mCandidate
, mWidget
, signals
, mEvaluation
, users
, comparison
}
action NewDeploymentRecordAction = do
decisions <- query @DecisionRecord |> fetch
implRefs <- query @ImplementationChangeReference |> fetch
users <- query @User |> fetch
mDecisionId <- paramOrNothing @(Id DecisionRecord) "decisionId"
let record = newRecord @DeploymentRecord
render NewView { record, decisions, implRefs, users, mDecisionId }
action CreateDeploymentRecordAction = do
decisions <- query @DecisionRecord |> fetch
implRefs <- query @ImplementationChangeReference |> fetch
users <- query @User |> fetch
mUser <- currentUserOrNothing
let deployedBy = fmap (.id) mUser
let record = newRecord @DeploymentRecord
record
|> fill @'["decisionId", "implRefId", "versionRef", "notes"]
|> set #deployedBy (fmap (Id . unId) deployedBy)
|> validateField #versionRef nonEmpty
|> ifValid \case
Left r -> render NewView { record = r, decisions, implRefs, users, mDecisionId = Just r.decisionId }
Right r -> do
created <- createRecord r
setSuccessMessage "Deployment record created"
redirectTo ShowDeploymentRecordAction { deploymentRecordId = created.id }
action RecordOutcomeSignalAction { deploymentRecordId } = do
signalType <- param @Text "signalType"
mValue <- paramOrNothing @Double "value"
mUser <- currentUserOrNothing
let validTypes = ["improved", "regressed", "neutral", "inconclusive"] :: [Text]
unless (signalType `elem` validTypes) do
setErrorMessage ("Invalid signal type: " <> signalType)
redirectTo ShowDeploymentRecordAction { deploymentRecordId }
-- Fetch the deployment to get the widget_id from its decision → candidate chain
deployment <- fetch deploymentRecordId
decision <- fetch deployment.decisionId
mCandidate <- case decision.candidateId of
Nothing -> pure Nothing
Just cid -> fetchOneOrNothing cid
case mCandidate of
Nothing -> do
setErrorMessage "Cannot record signal: no widget linked to this deployment's decision"
redirectTo ShowDeploymentRecordAction { deploymentRecordId }
Just candidate -> do
newRecord @OutcomeSignal
|> set #deploymentId deploymentRecordId
|> set #widgetId candidate.sourceWidgetId
|> set #signalType signalType
|> set #value mValue
|> createRecord
setSuccessMessage ("Outcome signal recorded: " <> signalType)
redirectTo ShowDeploymentRecordAction { deploymentRecordId }
action EvaluateChangeAction { deploymentRecordId } = do
-- Idempotent: if already evaluated, redirect with message
existing <- query @ChangeEvaluation
|> filterWhere (#deploymentId, deploymentRecordId)
|> fetchOneOrNothing
case existing of
Just _ -> do
setErrorMessage "Already evaluated — one evaluation per deployment."
redirectTo ShowDeploymentRecordAction { deploymentRecordId }
Nothing -> do
mUser <- currentUserOrNothing
let evaluatedBy = fmap (.id) mUser
scoreText <- param @Text "score"
rationale <- param @Text "rationale"
let mScore = readMaybe (cs scoreText) :: Maybe Int
case mScore of
Nothing -> do
setErrorMessage "Score must be a number between 1 and 5"
redirectTo ShowDeploymentRecordAction { deploymentRecordId }
Just s | s < 1 || s > 5 -> do
setErrorMessage "Score must be between 1 and 5"
redirectTo ShowDeploymentRecordAction { deploymentRecordId }
Just s -> do
when (rationale == "") do
setErrorMessage "Rationale cannot be empty"
redirectTo ShowDeploymentRecordAction { deploymentRecordId }
deployment <- fetch deploymentRecordId
newRecord @ChangeEvaluation
|> set #deploymentId deploymentRecordId
|> set #decisionId (Just deployment.decisionId)
|> set #score (fromIntegral s)
|> set #rationale rationale
|> set #evaluatedBy (fmap (Id . unId) evaluatedBy)
|> createRecord
setSuccessMessage "Change evaluated"
redirectTo ShowDeploymentRecordAction { deploymentRecordId }
thirtyDays :: NominalDiffTime
thirtyDays = 30 * 24 * 3600
computeComparison :: (?modelContext :: ModelContext) => UTCTime -> Maybe Widget -> IO (Maybe (PeriodMetrics, PeriodMetrics))
computeComparison _ Nothing = pure Nothing
computeComparison deployedAt (Just w) = do
let beforeStart = addUTCTime (negate thirtyDays) deployedAt
afterEnd = addUTCTime thirtyDays deployedAt
allEvents <- query @InteractionEvent |> filterWhere (#widgetId, w.id) |> fetch
allAnnotations <- query @Annotation |> filterWhere (#widgetId, w.id) |> fetch
let inWindow s e t = t >= s && t < e
evBefore = filter (\x -> inWindow beforeStart deployedAt x.occurredAt) allEvents
evAfter = filter (\x -> inWindow deployedAt afterEnd x.occurredAt) allEvents
annBefore = filter (\x -> inWindow beforeStart deployedAt x.createdAt && isNothing x.retractedAt) allAnnotations
annAfter = filter (\x -> inWindow deployedAt afterEnd x.createdAt && isNothing x.retractedAt) allAnnotations
pure $ Just (buildMetrics evBefore annBefore, buildMetrics evAfter annAfter)
buildMetrics :: [InteractionEvent] -> [Annotation] -> PeriodMetrics
buildMetrics events anns = PeriodMetrics
{ eventCount = length events
, annotationCount = length anns
, lowCount = count "low"
, mediumCount = count "medium"
, highCount = count "high"
, criticalCount = count "critical"
}
where
count sev = length (filter (\a -> a.severity == sev) anns)

View File

@@ -7,9 +7,11 @@ import Web.View.Hubs.New
import Web.View.Hubs.Edit
import Web.View.Hubs.TriageDashboard
import Web.View.Hubs.GovernanceDashboard
import Web.View.Hubs.AntifragilityDashboard
import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
import Application.Helper.Controller (regressedWidgetIds, widgetCycleCounts)
instance Controller HubsController where
beforeAction = ensureIsUser
@@ -147,6 +149,13 @@ instance Controller HubsController where
|> filterWhereIn (#widgetId, widgetIds)
|> fetch
-- Outcome signals for regression detection
allSignals <- query @OutcomeSignal
|> filterWhereIn (#widgetId, widgetIds)
|> fetch
let regressionWidgetIds = regressedWidgetIds allSignals allAnnotations
render GovernanceDashboardView
{ hub
, widgets
@@ -155,4 +164,58 @@ instance Controller HubsController where
, recentDecisions
, allDecisions
, allAnnotations
, regressionWidgetIds
}
action AntifragilityDashboardAction { hubId } = autoRefresh do
hub <- fetch hubId
widgets <- query @Widget
|> filterWhere (#hubId, hubId)
|> fetch
let widgetIds = map (.id) widgets
-- Deployments for this hub's decisions
allCandidates <- query @RequirementCandidate
|> filterWhereIn (#sourceWidgetId, widgetIds)
|> fetch
let acceptedCandidateIds = map (.id) (filter (\c -> c.status == "accepted") allCandidates)
allRequirements <- query @Requirement
|> filterWhereIn (#sourceCandidateId, acceptedCandidateIds)
|> fetch
let requirementIds = map (.id) allRequirements
allDecisions <- query @DecisionRecord
|> filterWhereIn (#requirementId, map Just requirementIds)
|> fetch
let decisionIds = map (.id) allDecisions
allDeployments <- query @DeploymentRecord
|> filterWhereIn (#decisionId, decisionIds)
|> orderByDesc #deployedAt
|> fetch
let deploymentIds = map (.id) allDeployments
allSignals <- query @OutcomeSignal
|> filterWhereIn (#widgetId, widgetIds)
|> fetch
allEvaluations <- query @ChangeEvaluation
|> filterWhereIn (#deploymentId, deploymentIds)
|> fetch
allImplRefs <- query @ImplementationChangeReference
|> filterWhereIn (#decisionId, decisionIds)
|> fetch
allAnnotations <- query @Annotation
|> filterWhereIn (#widgetId, widgetIds)
|> fetch
let regressionWidgetIds = regressedWidgetIds allSignals allAnnotations
recurrenceLeaderboard = take 10 (widgetCycleCounts allCandidates allRequirements allDecisions allDeployments)
render AntifragilityDashboardView
{ hub
, widgets
, allDeployments
, allDecisions
, allSignals
, allEvaluations
, allImplRefs
, regressionWidgetIds
, recurrenceLeaderboard
}

View File

@@ -9,6 +9,7 @@ import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
import Data.Aeson (toJSON, object, (.=))
import Application.Helper.Controller (isInRegression, widgetCycleCounts)
instance Controller WidgetsController where
beforeAction = ensureIsUser
@@ -39,7 +40,23 @@ instance Controller WidgetsController where
|> filterWhere (#widgetId, widgetId)
|> orderByAsc #createdAt
|> fetch
render ShowView { widget, hub, versions, events, annotations }
recentSignals <- query @OutcomeSignal
|> filterWhere (#widgetId, widgetId)
|> orderByDesc #observedAt
|> limit 10
|> fetch
allSignals <- query @OutcomeSignal
|> filterWhere (#widgetId, widgetId)
|> fetch
let isRegressed = isInRegression allSignals annotations widgetId
-- Recurrence cycle count for this widget
allCandidates <- query @RequirementCandidate |> filterWhere (#sourceWidgetId, widgetId) |> fetch
allRequirements <- query @Requirement |> fetch
allDecisions <- query @DecisionRecord |> fetch
allDeployments <- query @DeploymentRecord |> fetch
let cycleCounts = widgetCycleCounts allCandidates allRequirements allDecisions allDeployments
cycleCount = fromMaybe 0 (lookup widgetId cycleCounts)
render ShowView { widget, hub, versions, events, annotations, recentSignals, isRegressed, cycleCount }
action CreateWidgetAction = do
let widget = newRecord @Widget

View File

@@ -15,6 +15,7 @@ import Web.Controller.AnnotationThreads ()
import Web.Controller.RequirementCandidates ()
import Web.Controller.Requirements ()
import Web.Controller.DecisionRecords ()
import Web.Controller.DeploymentRecords ()
import Web.Controller.Sessions ()
instance FrontController WebApplication where
@@ -28,6 +29,7 @@ instance FrontController WebApplication where
, parseRoute @RequirementCandidatesController
, parseRoute @RequirementsController
, parseRoute @DecisionRecordsController
, parseRoute @DeploymentRecordsController
]
instance InitControllerContext WebApplication where
@@ -56,6 +58,7 @@ defaultLayout inner = [hsx|
<a href={RequirementCandidatesAction} class="text-sm text-gray-600 hover:text-gray-900">Candidates</a>
<a href={RequirementsAction} class="text-sm text-gray-600 hover:text-gray-900">Requirements</a>
<a href={DecisionRecordsAction} class="text-sm text-gray-600 hover:text-gray-900">Decisions</a>
<a href={DeploymentRecordsAction} class="text-sm text-gray-600 hover:text-gray-900">Deployments</a>
<div class="ml-auto">
<a href={DeleteSessionAction} class="text-sm text-gray-500 hover:text-gray-700">Sign out</a>
</div>

View File

@@ -28,5 +28,8 @@ instance AutoRoute RequirementsController
-- Decision Records (Phase 3)
instance AutoRoute DecisionRecordsController
-- Deployment Records (Phase 4)
instance AutoRoute DeploymentRecordsController
-- Sessions
instance AutoRoute SessionsController

View File

@@ -23,8 +23,9 @@ data HubsController
| EditHubAction { hubId :: !(Id Hub) }
| UpdateHubAction { hubId :: !(Id Hub) }
| DeleteHubAction { hubId :: !(Id Hub) }
| TriageDashboardAction { hubId :: !(Id Hub) }
| GovernanceDashboardAction { hubId :: !(Id Hub) }
| TriageDashboardAction { hubId :: !(Id Hub) }
| GovernanceDashboardAction { hubId :: !(Id Hub) }
| AntifragilityDashboardAction { hubId :: !(Id Hub) }
deriving (Eq, Show, Data)
data WidgetsController
@@ -88,6 +89,15 @@ data DecisionRecordsController
| DeleteImplementationRefAction { implementationChangeReferenceId :: !(Id ImplementationChangeReference) }
deriving (Eq, Show, Data)
data DeploymentRecordsController
= DeploymentRecordsAction
| ShowDeploymentRecordAction { deploymentRecordId :: !(Id DeploymentRecord) }
| NewDeploymentRecordAction
| CreateDeploymentRecordAction
| RecordOutcomeSignalAction { deploymentRecordId :: !(Id DeploymentRecord) }
| EvaluateChangeAction { deploymentRecordId :: !(Id DeploymentRecord) }
deriving (Eq, Show, Data)
data SessionsController
= NewSessionAction
| CreateSessionAction

View File

@@ -6,12 +6,14 @@ import IHP.Prelude
import IHP.ViewPrelude
data ShowView = ShowView
{ record :: !DecisionRecord
, policyRefs :: ![PolicyReference]
, implRefs :: ![ImplementationChangeReference]
, mRequirement :: !(Maybe Requirement)
, mCandidate :: !(Maybe RequirementCandidate)
, users :: ![User]
{ record :: !DecisionRecord
, policyRefs :: ![PolicyReference]
, implRefs :: ![ImplementationChangeReference]
, deploymentRecords :: ![DeploymentRecord]
, evaluations :: ![ChangeEvaluation]
, mRequirement :: !(Maybe Requirement)
, mCandidate :: !(Maybe RequirementCandidate)
, users :: ![User]
}
instance View ShowView where
@@ -92,6 +94,24 @@ instance View ShowView where
</form>
</div>
<!-- Deployments -->
<div class="bg-white rounded-lg border border-gray-200 px-6 py-4">
<div class="flex items-center justify-between mb-3">
<h2 class="text-sm font-semibold text-gray-700">Deployments</h2>
{if null implRefs
then mempty
else [hsx|
<a href={(pathTo NewDeploymentRecordAction) <> "?decisionId=" <> show record.id}
class="text-xs border border-indigo-300 text-indigo-600 px-3 py-1 rounded hover:bg-indigo-50">
New Deployment
</a>
|]}
</div>
{if null deploymentRecords
then [hsx|<p class="text-sm text-gray-400">No deployments recorded yet.</p>|]
else [hsx|{forEach deploymentRecords (renderDeploymentRow evaluations)}|]}
</div>
<!-- Implementation references -->
<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">Implementation References</h2>
@@ -201,6 +221,36 @@ systemBadgeClass "linear" = "bg-violet-100 text-violet-800"
systemBadgeClass "jira" = "bg-blue-100 text-blue-800"
systemBadgeClass _ = "bg-gray-100 text-gray-600"
renderDeploymentRow :: [ChangeEvaluation] -> DeploymentRecord -> Html
renderDeploymentRow evals dr = [hsx|
<div class="flex items-center justify-between py-2 border-b border-gray-100 last:border-0">
<div class="flex items-center gap-2 text-sm">
<a href={ShowDeploymentRecordAction { deploymentRecordId = dr.id }}
class="font-mono text-indigo-600 hover:text-indigo-800">{dr.versionRef}</a>
<span class="text-xs text-gray-400">{show dr.deployedAt}</span>
</div>
{maybe mempty renderEvalSummary mEval}
</div>
|]
where
mEval = find (\e -> e.deploymentId == dr.id) evals
renderEvalSummary :: ChangeEvaluation -> Html
renderEvalSummary ev = [hsx|
<span class={scoreClass ev.score <> " text-xs px-2 py-0.5 rounded font-medium"}>
{starsFor ev.score}
</span>
|]
starsFor :: Int16 -> Text
starsFor n = pack (Prelude.replicate (fromIntegral n) '★') <> pack (Prelude.replicate (5 - fromIntegral n) '☆')
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"
userName :: [User] -> Maybe (Id User) -> Text
userName _ Nothing = ""
userName users (Just uid) = maybe "(unknown)" (.name) (find (\u -> u.id == uid) users)

View File

@@ -0,0 +1,86 @@
module Web.View.DeploymentRecords.Index where
import Web.Types
import Generated.Types
import IHP.Prelude
import IHP.ViewPrelude
data IndexView = IndexView
{ records :: ![DeploymentRecord]
, decisions :: ![DecisionRecord]
, signals :: ![OutcomeSignal]
, evaluations :: ![ChangeEvaluation]
}
instance View IndexView where
html IndexView { .. } = [hsx|
<div class="flex items-center justify-between mb-6">
<h1 class="text-2xl font-semibold">Deployments</h1>
<a href={NewDeploymentRecordAction}
class="text-sm bg-indigo-600 text-white px-4 py-2 rounded hover:bg-indigo-700">
New Deployment
</a>
</div>
{if null records
then [hsx|<p class="text-gray-500 text-sm">No deployment records yet.</p>|]
else renderTable records decisions signals evaluations}
|]
renderTable :: [DeploymentRecord] -> [DecisionRecord] -> [OutcomeSignal] -> [ChangeEvaluation] -> Html
renderTable records decisions signals evaluations = [hsx|
<div class="bg-white rounded-lg border border-gray-200 overflow-hidden">
<table class="w-full text-sm">
<thead class="bg-gray-50 border-b border-gray-200">
<tr>
<th class="text-left px-4 py-3 font-semibold text-gray-600">Decision</th>
<th class="text-left px-4 py-3 font-semibold text-gray-600">Version</th>
<th class="text-left px-4 py-3 font-semibold text-gray-600">Deployed At</th>
<th class="text-right px-4 py-3 font-semibold text-gray-600">Signals</th>
<th class="text-right px-4 py-3 font-semibold text-gray-600">Evaluation</th>
</tr>
</thead>
<tbody>
{forEach records (renderRow decisions signals evaluations)}
</tbody>
</table>
</div>
|]
renderRow :: [DecisionRecord] -> [OutcomeSignal] -> [ChangeEvaluation] -> DeploymentRecord -> Html
renderRow decisions signals evaluations record = [hsx|
<tr class="border-b border-gray-100 hover:bg-gray-50 last:border-0">
<td class="px-4 py-3">
<a href={ShowDeploymentRecordAction { deploymentRecordId = record.id }}
class="text-indigo-600 hover:text-indigo-800">{decisionTitle}</a>
</td>
<td class="px-4 py-3 font-mono text-gray-700">{record.versionRef}</td>
<td class="px-4 py-3 text-gray-500">{show record.deployedAt}</td>
<td class="px-4 py-3 text-right text-gray-600">{show signalCount}</td>
<td class="px-4 py-3 text-right">
{maybe [hsx|<span class="text-gray-400"></span>|] renderScoreBadge mScore}
</td>
</tr>
|]
where
decisionTitle = maybe "(unknown)" (.title) $
find (\d -> d.id == record.decisionId) decisions
signalCount = length $ filter (\s -> s.deploymentId == record.id) signals
mScore :: Maybe Int16
mScore = fmap (.score) $ find (\e -> e.deploymentId == record.id) evaluations
renderScoreBadge :: Int16 -> Html
renderScoreBadge score = [hsx|
<span class={scoreClass score <> " text-xs px-2 py-0.5 rounded font-medium"}>
{starsFor score}
</span>
|]
starsFor :: Int16 -> Text
starsFor n = pack (Prelude.replicate (fromIntegral n) '★') <> pack (Prelude.replicate (5 - fromIntegral n) '☆')
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"

View File

@@ -0,0 +1,99 @@
module Web.View.DeploymentRecords.New where
import Web.Types
import Generated.Types
import IHP.Prelude
import IHP.ViewPrelude
data NewView = NewView
{ record :: !DeploymentRecord
, decisions :: ![DecisionRecord]
, implRefs :: ![ImplementationChangeReference]
, users :: ![User]
, mDecisionId :: !(Maybe (Id DecisionRecord))
}
instance View NewView where
html NewView { .. } = [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>New</span>
</div>
<div class="max-w-xl">
<h1 class="text-2xl font-semibold mb-6">Record Deployment</h1>
<form method="POST" action={CreateDeploymentRecordAction}
class="bg-white rounded-lg border border-gray-200 px-6 py-5 space-y-4">
{hiddenField "authenticity_token"}
<div>
<label class="block text-sm font-medium text-gray-700 mb-1">
Decision <span class="text-red-500">*</span>
</label>
<select name="decisionId"
class="w-full text-sm border border-gray-300 rounded px-3 py-2">
{forEach decisions (renderDecisionOption mDecisionId)}
</select>
</div>
<div>
<label class="block text-sm font-medium text-gray-700 mb-1">
Implementation Reference <span class="text-gray-400">(optional)</span>
</label>
<select name="implRefId"
class="w-full text-sm border border-gray-300 rounded px-3 py-2">
<option value=""> none </option>
{forEach implRefs renderImplRefOption}
</select>
</div>
<div>
<label class="block text-sm font-medium text-gray-700 mb-1">
Version Reference <span class="text-red-500">*</span>
</label>
<input type="text" name="versionRef"
value={record.versionRef}
placeholder="e.g. v1.2.3, git:abc1234, deploy/2026-03-29"
class="w-full text-sm border border-gray-300 rounded px-3 py-2" />
{validationErrorsFor record #versionRef}
</div>
<div>
<label class="block text-sm font-medium text-gray-700 mb-1">
Notes <span class="text-gray-400">(optional)</span>
</label>
<textarea name="notes" rows="3"
class="w-full text-sm border border-gray-300 rounded px-3 py-2">{fromMaybe "" record.notes}</textarea>
</div>
<div class="flex gap-3 pt-2">
<button type="submit"
class="text-sm bg-indigo-600 text-white px-4 py-2 rounded hover:bg-indigo-700">
Record Deployment
</button>
<a href={DeploymentRecordsAction}
class="text-sm border border-gray-300 px-4 py-2 rounded hover:bg-gray-50">
Cancel
</a>
</div>
</form>
</div>
|]
renderDecisionOption :: Maybe (Id DecisionRecord) -> DecisionRecord -> Html
renderDecisionOption mSelected d = [hsx|
<option value={show d.id} selected={isSelected}>
{d.title} ({d.outcome})
</option>
|]
where
isSelected = case mSelected of
Just sid -> sid == d.id
Nothing -> False
renderImplRefOption :: ImplementationChangeReference -> Html
renderImplRefOption ref = [hsx|
<option value={show ref.id}>{ref.workItemRef} ({ref.system})</option>
|]

View File

@@ -0,0 +1,332 @@
module Web.View.DeploymentRecords.Show where
import Web.Types
import Generated.Types
import IHP.Prelude
import IHP.ViewPrelude
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 { decisionRecordId = 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>
{if null signals
then [hsx|<p class="text-sm text-gray-400 mb-3">No signals recorded yet.</p>|]
else [hsx|<div class="mb-4">{forEach signals renderSignal}</div>|]}
<form method="POST" action={RecordOutcomeSignalAction { deploymentRecordId = record.id }}
class="flex items-end gap-2 mt-2">
{hiddenField "authenticity_token"}
<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 { requirementId = 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 { requirementCandidateId = 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 { widgetId = w.id }}
class="text-indigo-600 hover:text-indigo-800">{w.name}</a>
</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)

View File

@@ -0,0 +1,259 @@
module Web.View.Hubs.AntifragilityDashboard where
import Web.Types
import Generated.Types
import IHP.Prelude
import IHP.ViewPrelude
data AntifragilityDashboardView = AntifragilityDashboardView
{ hub :: !Hub
, widgets :: ![Widget]
, allDeployments :: ![DeploymentRecord]
, allDecisions :: ![DecisionRecord]
, allSignals :: ![OutcomeSignal]
, allEvaluations :: ![ChangeEvaluation]
, allImplRefs :: ![ImplementationChangeReference]
, regressionWidgetIds :: ![Id Widget]
, recurrenceLeaderboard :: ![(Id Widget, Int)]
}
instance View AntifragilityDashboardView where
html AntifragilityDashboardView { .. } = [hsx|
<div class="mb-6 flex items-center justify-between">
<div>
<div class="flex items-center gap-2 text-sm text-gray-500 mb-1">
<a href={HubsAction} class="hover:text-gray-700">Hubs</a>
<span>/</span>
<a href={ShowHubAction { hubId = hub.id }} class="hover:text-gray-700">{hub.name}</a>
<span>/</span>
<span>Antifragility</span>
</div>
<h1 class="text-2xl font-semibold">Antifragility Dashboard {hub.name}</h1>
</div>
<div class="flex gap-2">
<a href={TriageDashboardAction { hubId = hub.id }}
class="text-sm border border-gray-300 px-3 py-1.5 rounded hover:bg-gray-50">
Triage
</a>
<a href={GovernanceDashboardAction { hubId = hub.id }}
class="text-sm border border-gray-300 px-3 py-1.5 rounded hover:bg-gray-50">
Governance
</a>
<a href={ShowHubAction { hubId = hub.id }}
class="text-sm border border-gray-300 px-3 py-1.5 rounded hover:bg-gray-50">
Hub
</a>
</div>
</div>
<!-- KPI row -->
<div class="grid grid-cols-4 gap-4 mb-6">
<div class="bg-white rounded-lg border border-gray-200 px-4 py-3 text-center">
<div class="text-2xl font-bold">{show (length allDeployments)}</div>
<div class="text-xs text-gray-500 mt-0.5">deployments</div>
</div>
<div class="bg-white rounded-lg border border-gray-200 px-4 py-3 text-center">
<div class="text-2xl font-bold">{avgScoreText}</div>
<div class="text-xs text-gray-500 mt-0.5">avg evaluation</div>
</div>
<div class="bg-white rounded-lg border border-gray-200 px-4 py-3 text-center">
<div class="text-2xl font-bold">{improvedPctText}</div>
<div class="text-xs text-gray-500 mt-0.5">improved signals</div>
</div>
<div class="bg-red-50 rounded-lg border border-red-200 px-4 py-3 text-center">
<div class="text-2xl font-bold text-red-700">{show (length regressionWidgetIds)}</div>
<div class="text-xs text-red-500 mt-0.5">regressions</div>
</div>
</div>
<!-- Regression alerts -->
{if null regressionWidgetIds then mempty else [hsx|
<div class="bg-red-50 border border-red-200 rounded-lg px-6 py-4 mb-6">
<h2 class="text-sm font-semibold text-red-700 mb-3"> Regression Alerts</h2>
<div class="flex flex-wrap gap-2">
{forEach regressedWidgets renderRegressedBadge}
</div>
</div>
|]}
<!-- Open gaps: decisions with impl refs but no deployment -->
<div class="bg-white rounded-lg border border-gray-200 px-6 py-5 mb-6">
<h2 class="text-sm font-semibold text-gray-700 mb-3">
Open Gaps
<span class="text-xs font-normal text-gray-400 ml-2">
(decisions with impl refs but no deployment recorded)
</span>
</h2>
{if null openGaps
then [hsx|<p class="text-sm text-gray-400">All decisions with impl refs have deployments.</p>|]
else [hsx|
<div class="space-y-1">
{forEach openGaps renderGapRow}
</div>
|]}
</div>
<!-- Recent deployments -->
<div class="bg-white rounded-lg border border-gray-200 px-6 py-5 mb-6">
<h2 class="text-sm font-semibold text-gray-700 mb-3">Recent Deployments</h2>
{if null recentDeploys
then [hsx|<p class="text-sm text-gray-400">No deployments yet.</p>|]
else [hsx|
<table class="w-full text-sm">
<thead class="border-b border-gray-100">
<tr>
<th class="text-left py-2 text-xs font-medium text-gray-500">Version</th>
<th class="text-left py-2 text-xs font-medium text-gray-500">Decision</th>
<th class="text-right py-2 text-xs font-medium text-gray-500">Signals</th>
<th class="text-right py-2 text-xs font-medium text-gray-500">Eval</th>
<th class="text-right py-2 text-xs font-medium text-gray-500">Deployed</th>
</tr>
</thead>
<tbody class="divide-y divide-gray-50">
{forEach recentDeploys (renderDeployRow allDecisions allSignals allEvaluations)}
</tbody>
</table>
|]}
</div>
<!-- Recurrence leaderboard -->
<div class="bg-white rounded-lg border border-gray-200 px-6 py-5">
<h2 class="text-sm font-semibold text-gray-700 mb-3">Recurrence Leaderboard</h2>
{if null recurrenceLeaderboard
then [hsx|<p class="text-sm text-gray-400">No recurring widgets detected.</p>|]
else [hsx|
<table class="w-full text-sm">
<thead class="border-b border-gray-100">
<tr>
<th class="text-left py-2 text-xs font-medium text-gray-500">Widget</th>
<th class="text-right py-2 text-xs font-medium text-gray-500">Cycles</th>
</tr>
</thead>
<tbody class="divide-y divide-gray-50">
{forEach recurrenceLeaderboard (renderRecurrenceRow widgets)}
</tbody>
</table>
|]}
</div>
|]
where
deployedIds = map (.id) allDeployments
openGaps = filter (\d -> any (\r -> r.decisionId == d.id) allImplRefs
&& not (any (\dp -> dp.decisionId == d.id) allDeployments))
allDecisions
recentDeploys = take 20 (sortByDesc (.deployedAt) allDeployments)
regressedWidgets = filter (\w -> w.id `elem` regressionWidgetIds) widgets
avgScoreText
| null allEvaluations = ""
| otherwise =
let avg = fromIntegral (sum (map (.score) allEvaluations)) / fromIntegral (length allEvaluations) :: Double
in show (round avg :: Int) <> "/5"
improvedPctText
| null allSignals = ""
| otherwise =
let improved = length (filter (\s -> s.signalType == "improved") allSignals)
pct = (fromIntegral improved * 100 `div` length allSignals) :: Int
in show pct <> "%"
sortByDesc :: Ord b => (a -> b) -> [a] -> [a]
sortByDesc f = sortBy (\a b -> compare (f b) (f a))
renderRegressedBadge :: Widget -> Html
renderRegressedBadge w = [hsx|
<a href={ShowWidgetAction { widgetId = w.id }}
class="text-xs bg-red-100 text-red-800 border border-red-300 rounded px-2 py-1 hover:bg-red-200">
{w.name}
</a>
|]
renderGapRow :: DecisionRecord -> Html
renderGapRow d = [hsx|
<div class="flex items-center justify-between py-1.5 text-sm">
<a href={ShowDecisionRecordAction { decisionRecordId = d.id }}
class="text-indigo-600 hover:text-indigo-800">{d.title}</a>
<span class={outcomeClass d.outcome <> " text-xs px-2 py-0.5 rounded font-medium"}>
{d.outcome}
</span>
</div>
|]
renderDeployRow :: [DecisionRecord] -> [OutcomeSignal] -> [ChangeEvaluation] -> DeploymentRecord -> Html
renderDeployRow decisions signals evals dr = [hsx|
<tr>
<td class="py-2 pr-4">
<a href={ShowDeploymentRecordAction { deploymentRecordId = dr.id }}
class="font-mono text-indigo-600 hover:text-indigo-800">{dr.versionRef}</a>
</td>
<td class="py-2 pr-4 text-gray-600">{decisionTitle}</td>
<td class="py-2 pr-4 text-right">
{renderSignalSummary drSignals}
</td>
<td class="py-2 pr-4 text-right">
{maybe [hsx|<span class="text-gray-400 text-xs"></span>|] renderEvalBadge mScore}
</td>
<td class="py-2 text-right text-xs text-gray-400">{show dr.deployedAt}</td>
</tr>
|]
where
decisionTitle = maybe "" (.title) (find (\d -> d.id == dr.decisionId) decisions)
drSignals = filter (\s -> s.deploymentId == dr.id) signals
mScore = fmap (.score) (find (\e -> e.deploymentId == dr.id) evals)
renderSignalSummary :: [OutcomeSignal] -> Html
renderSignalSummary [] = [hsx|<span class="text-gray-400 text-xs"></span>|]
renderSignalSummary signals = [hsx|
<div class="flex gap-1 justify-end">
{forEach (take 3 signals) (\s -> [hsx|
<span class={signalDot s.signalType}></span>
|])}
</div>
|]
signalDot :: Text -> Text
signalDot "improved" = "inline-block w-2 h-2 rounded-full bg-green-500"
signalDot "regressed" = "inline-block w-2 h-2 rounded-full bg-red-500"
signalDot "neutral" = "inline-block w-2 h-2 rounded-full bg-gray-400"
signalDot "inconclusive" = "inline-block w-2 h-2 rounded-full bg-yellow-400"
signalDot _ = "inline-block w-2 h-2 rounded-full bg-gray-300"
renderEvalBadge :: Int16 -> Html
renderEvalBadge score = [hsx|
<span class={scoreClass score <> " text-xs px-2 py-0.5 rounded font-medium"}>
{show score}/5
</span>
|]
renderRecurrenceRow :: [Widget] -> (Id Widget, Int) -> Html
renderRecurrenceRow widgets (wid, count) = [hsx|
<tr>
<td class="py-2">
{maybe [hsx|<span class="text-gray-500"></span>|] renderWidgetLink mWidget}
</td>
<td class="py-2 text-right">
<span class="text-sm font-semibold text-yellow-700"> {show count}</span>
</td>
</tr>
|]
where
mWidget = find (\w -> w.id == wid) widgets
renderWidgetLink :: Widget -> Html
renderWidgetLink w = [hsx|
<a href={ShowWidgetAction { widgetId = w.id }}
class="text-indigo-600 hover:text-indigo-800">{w.name}</a>
|]
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"

View File

@@ -6,13 +6,14 @@ import IHP.Prelude
import IHP.ViewPrelude
data GovernanceDashboardView = GovernanceDashboardView
{ hub :: !Hub
, widgets :: ![Widget]
, allCandidates :: ![RequirementCandidate]
, allRequirements :: ![Requirement]
, recentDecisions :: ![DecisionRecord]
, allDecisions :: ![DecisionRecord]
, allAnnotations :: ![Annotation]
{ hub :: !Hub
, widgets :: ![Widget]
, allCandidates :: ![RequirementCandidate]
, allRequirements :: ![Requirement]
, recentDecisions :: ![DecisionRecord]
, allDecisions :: ![DecisionRecord]
, allAnnotations :: ![Annotation]
, regressionWidgetIds :: ![Id Widget]
}
instance View GovernanceDashboardView where
@@ -33,6 +34,10 @@ instance View GovernanceDashboardView where
class="text-sm border border-gray-300 px-3 py-1.5 rounded hover:bg-gray-50">
Triage Dashboard
</a>
<a href={AntifragilityDashboardAction { hubId = hub.id }}
class="text-sm border border-green-300 text-green-700 px-3 py-1.5 rounded hover:bg-green-50">
Antifragility
</a>
<a href={ShowHubAction { hubId = hub.id }}
class="text-sm border border-gray-300 px-3 py-1.5 rounded hover:bg-gray-50">
Hub Overview
@@ -40,11 +45,24 @@ instance View GovernanceDashboardView where
</div>
</div>
<!-- KPI row: decision outcomes -->
<div class="grid grid-cols-3 gap-4 mb-6 sm:grid-cols-6">
<!-- KPI row: decision outcomes + regression -->
<div class="grid grid-cols-3 gap-4 mb-4 sm:grid-cols-7">
{forEach outcomeList (\o -> renderKpiCard o (countOutcome allDecisions o))}
<div class="bg-red-50 text-red-800 rounded-lg px-4 py-3 text-center">
<div class="text-2xl font-bold">{show (length regressionWidgetIds)}</div>
<div class="text-xs mt-0.5 opacity-75">regressions</div>
</div>
</div>
{if null regressionWidgetIds then mempty else [hsx|
<div class="bg-red-50 border border-red-200 rounded-lg px-6 py-4 mb-6">
<h2 class="text-sm font-semibold text-red-700 mb-2"> Regressed Widgets</h2>
<div class="flex flex-wrap gap-2">
{forEach regressedWidgets renderRegressedBadge}
</div>
</div>
|]}
<!-- Open requirements awaiting decision -->
<div class="bg-white rounded-lg border border-gray-200 px-6 py-5 mb-6">
<h2 class="text-sm font-semibold text-gray-700 mb-3">
@@ -99,7 +117,8 @@ instance View GovernanceDashboardView where
</div>
|]
where
awaitingDecision = filter (isAwaitingDecision allDecisions) allRequirements
awaitingDecision = filter (isAwaitingDecision allDecisions) allRequirements
regressedWidgets = filter (\w -> w.id `elem` regressionWidgetIds) widgets
outcomeList :: [Text]
outcomeList = ["accepted", "rejected", "deferred", "split", "merged", "reframed"]
@@ -192,6 +211,14 @@ renderCoverageRow annotations candidates requirements decisions w = [hsx|
widgetReqIds = map (.id) (filter (\r -> r.sourceCandidateId `elem` candidateIds) requirements)
hasDecision = any (\d -> d.requirementId `elem` map Just widgetReqIds) decisions
renderRegressedBadge :: Widget -> Html
renderRegressedBadge w = [hsx|
<a href={ShowWidgetAction { widgetId = w.id }}
class="text-xs bg-red-100 text-red-800 border border-red-300 rounded px-2 py-1 hover:bg-red-200">
{w.name}
</a>
|]
coverageMark :: Bool -> Html
coverageMark True = [hsx|<span class="text-green-600 font-bold"></span>|]
coverageMark False = [hsx|<span class="text-gray-300"></span>|]

View File

@@ -37,6 +37,10 @@ instance View ShowView where
class="text-sm border border-purple-300 text-purple-700 px-3 py-1.5 rounded hover:bg-purple-50">
Governance Dashboard
</a>
<a href={AntifragilityDashboardAction { hubId = hub.id }}
class="text-sm border border-green-300 text-green-700 px-3 py-1.5 rounded hover:bg-green-50">
Antifragility
</a>
<a href={EditHubAction { hubId = hub.id }}
class="text-sm border border-gray-300 px-3 py-1.5 rounded hover:bg-gray-50">
Edit

View File

@@ -7,11 +7,14 @@ import IHP.ViewPrelude
import Application.Helper.View (widgetEnvelope)
data ShowView = ShowView
{ widget :: !Widget
, hub :: !Hub
, versions :: ![WidgetVersion]
, events :: ![InteractionEvent]
, annotations :: ![Annotation]
{ widget :: !Widget
, hub :: !Hub
, versions :: ![WidgetVersion]
, events :: ![InteractionEvent]
, annotations :: ![Annotation]
, recentSignals :: ![OutcomeSignal]
, isRegressed :: !Bool
, cycleCount :: !Int
}
instance View ShowView where
@@ -24,6 +27,24 @@ instance View ShowView where
<span>{widget.name}</span>
</div>
{if cycleCount >= 2 then [hsx|
<div class="mb-2 flex items-center gap-2 bg-yellow-50 border border-yellow-200 rounded-lg px-4 py-2">
<span class="text-yellow-700 font-semibold text-sm"> {show cycleCount} cycles</span>
<span class="text-yellow-600 text-xs">
Recurring friction this widget has been through {show cycleCount} improvement cycles.
</span>
</div>
|] else mempty}
{if isRegressed then [hsx|
<div class="mb-4 flex items-center gap-2 bg-red-50 border border-red-200 rounded-lg px-4 py-3">
<span class="text-red-600 font-semibold text-sm"> Regression detected</span>
<span class="text-red-500 text-xs">
This widget had an improved signal but has since received high/critical annotations.
</span>
</div>
|] else mempty}
{widgetEnvelope widget [hsx|
<div class="flex items-center justify-between mb-4">
<div>
@@ -95,6 +116,15 @@ instance View ShowView where
</div>
</section>
{if null recentSignals then mempty else [hsx|
<section class="mb-8">
<h2 class="text-lg font-medium mb-3">Recent Outcome Signals</h2>
<div class="bg-white rounded-lg border border-gray-200 divide-y divide-gray-100">
{forEach recentSignals renderSignalRow}
</div>
</section>
|]}
<section>
<h2 class="text-lg font-medium mb-3">Version History</h2>
<div class="bg-white rounded-lg border border-gray-200 overflow-hidden">
@@ -160,3 +190,21 @@ renderCategoryRow (cat, count) = [hsx|
<span class="font-semibold">{show count}</span>
</div>
|]
renderSignalRow :: OutcomeSignal -> Html
renderSignalRow sig = [hsx|
<div class="flex items-center gap-3 px-4 py-3 text-sm">
<span class={signalTypeClass sig.signalType <> " text-xs px-2 py-0.5 rounded font-medium"}>
{sig.signalType}
</span>
{maybe mempty (\v -> [hsx|<span class="font-mono text-gray-700">{show v}</span>|]) sig.value}
<span class="text-xs text-gray-400 ml-auto">{show sig.observedAt}</span>
</div>
|]
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"