generated from coulomb/repo-seed
feat(P3): IHF Phase 3 complete — Governance and Decision Linkage
Implements the full governance layer: - Schema: requirements, decision_records, policy_references, implementation_change_references; requirement_candidates gets requirement_id back-reference - RequirementsController (index/show; promotion-only create) - DecisionRecordsController (CRUD + policy/impl ref management) - GovernanceDashboardAction on HubsController (AutoRefresh) - PromoteToRequirementAction + LinkToDecisionAction on candidates - Outcome immutability enforced at controller level (fill excludes outcome) - Full six-outcome vocabulary with Tailwind color roles - Integration tests for all Phase 3 paths - FrontController: registers Phase 2 missing controllers + all Phase 3 - SCOPE.md + docs/phase3-summary.md updated Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
167
Web/Controller/DecisionRecords.hs
Normal file
167
Web/Controller/DecisionRecords.hs
Normal file
@@ -0,0 +1,167 @@
|
||||
module Web.Controller.DecisionRecords where
|
||||
|
||||
import Web.Types
|
||||
import Web.View.DecisionRecords.Index
|
||||
import Web.View.DecisionRecords.Show
|
||||
import Web.View.DecisionRecords.New
|
||||
import Web.View.DecisionRecords.Edit
|
||||
import Generated.Types
|
||||
import IHP.Prelude
|
||||
import IHP.ControllerPrelude
|
||||
|
||||
validOutcomes :: [Text]
|
||||
validOutcomes = ["accepted", "rejected", "deferred", "split", "merged", "reframed"]
|
||||
|
||||
validPolicyScopes :: [Text]
|
||||
validPolicyScopes = ["internal", "external", "regulatory", "contractual", "architectural"]
|
||||
|
||||
validSystems :: [Text]
|
||||
validSystems = ["github", "linear", "jira", "other"]
|
||||
|
||||
instance Controller DecisionRecordsController where
|
||||
beforeAction = ensureIsUser
|
||||
|
||||
action DecisionRecordsAction = do
|
||||
mOutcomeFilter <- paramOrNothing @Text "outcome"
|
||||
records <- case mOutcomeFilter of
|
||||
Nothing -> query @DecisionRecord |> orderByDesc #decidedAt |> fetch
|
||||
Just o -> query @DecisionRecord
|
||||
|> filterWhere (#outcome, o)
|
||||
|> orderByDesc #decidedAt
|
||||
|> fetch
|
||||
requirements <- query @Requirement |> fetch
|
||||
users <- query @User |> fetch
|
||||
render IndexView { records, requirements, users, mOutcomeFilter }
|
||||
|
||||
action ShowDecisionRecordAction { decisionRecordId } = do
|
||||
record <- fetch decisionRecordId
|
||||
policyRefs <- query @PolicyReference
|
||||
|> filterWhere (#decisionId, decisionRecordId)
|
||||
|> orderByAsc #createdAt
|
||||
|> fetch
|
||||
implRefs <- query @ImplementationChangeReference
|
||||
|> filterWhere (#decisionId, decisionRecordId)
|
||||
|> orderByAsc #linkedAt
|
||||
|> fetch
|
||||
mRequirement <- case record.requirementId of
|
||||
Nothing -> pure Nothing
|
||||
Just rid -> fetchOneOrNothing rid
|
||||
mCandidate <- case record.candidateId of
|
||||
Nothing -> pure Nothing
|
||||
Just cid -> fetchOneOrNothing cid
|
||||
users <- query @User |> fetch
|
||||
render ShowView
|
||||
{ record
|
||||
, policyRefs
|
||||
, implRefs
|
||||
, mRequirement
|
||||
, mCandidate
|
||||
, users
|
||||
}
|
||||
|
||||
action NewDecisionRecordAction = do
|
||||
requirements <- query @Requirement |> fetch
|
||||
candidates <- query @RequirementCandidate |> fetch
|
||||
users <- query @User |> fetch
|
||||
let record = newRecord @DecisionRecord
|
||||
render NewView { record, requirements, candidates, users }
|
||||
|
||||
action CreateDecisionRecordAction = do
|
||||
requirements <- query @Requirement |> fetch
|
||||
candidates <- query @RequirementCandidate |> fetch
|
||||
users <- query @User |> fetch
|
||||
mUser <- currentUserOrNothing
|
||||
let decidedBy = fmap (.id) mUser
|
||||
|
||||
let record = newRecord @DecisionRecord
|
||||
record
|
||||
|> fill @'["title", "rationale", "outcome", "requirementId", "candidateId", "notes"]
|
||||
|> set #decidedBy (fmap (Id . unId) decidedBy)
|
||||
|> validateField #title nonEmpty
|
||||
|> validateField #rationale nonEmpty
|
||||
|> validateField #outcome (`elem` validOutcomes)
|
||||
|> ifValid \case
|
||||
Left record -> render NewView { record, requirements, candidates, users }
|
||||
Right record -> do
|
||||
created <- createRecord record
|
||||
setSuccessMessage "Decision record created"
|
||||
redirectTo ShowDecisionRecordAction { decisionRecordId = created.id }
|
||||
|
||||
action EditDecisionRecordAction { decisionRecordId } = do
|
||||
record <- fetch decisionRecordId
|
||||
requirements <- query @Requirement |> fetch
|
||||
candidates <- query @RequirementCandidate |> fetch
|
||||
users <- query @User |> fetch
|
||||
render EditView { record, requirements, candidates, users }
|
||||
|
||||
action UpdateDecisionRecordAction { decisionRecordId } = do
|
||||
record <- fetch decisionRecordId
|
||||
requirements <- query @Requirement |> fetch
|
||||
candidates <- query @RequirementCandidate |> fetch
|
||||
users <- query @User |> fetch
|
||||
|
||||
-- Outcome is immutable: only update non-outcome fields
|
||||
record
|
||||
|> fill @'["title", "rationale", "requirementId", "candidateId", "notes"]
|
||||
|> validateField #title nonEmpty
|
||||
|> validateField #rationale nonEmpty
|
||||
|> ifValid \case
|
||||
Left record -> render EditView { record, requirements, candidates, users }
|
||||
Right record -> do
|
||||
updateRecord record
|
||||
setSuccessMessage "Decision record updated"
|
||||
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
||||
|
||||
action AddPolicyReferenceAction { decisionRecordId } = do
|
||||
mUser <- currentUserOrNothing
|
||||
let createdBy = fmap (.id) mUser
|
||||
policyScope <- param @Text "policyScope"
|
||||
constraintNote <- paramOrNothing @Text "constraintNote"
|
||||
unless (policyScope `elem` validPolicyScopes) do
|
||||
setErrorMessage ("Invalid policy scope: " <> policyScope)
|
||||
respondWith 422 do
|
||||
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
||||
newRecord @PolicyReference
|
||||
|> set #decisionId decisionRecordId
|
||||
|> set #policyScope policyScope
|
||||
|> set #constraintNote constraintNote
|
||||
|> set #createdBy (fmap (Id . unId) createdBy)
|
||||
|> createRecord
|
||||
setSuccessMessage "Policy reference added"
|
||||
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
||||
|
||||
action DeletePolicyReferenceAction { policyReferenceId } = do
|
||||
ref <- fetch policyReferenceId
|
||||
let decisionRecordId = ref.decisionId
|
||||
deleteRecord ref
|
||||
setSuccessMessage "Policy reference removed"
|
||||
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
||||
|
||||
action AddImplementationRefAction { decisionRecordId } = do
|
||||
mUser <- currentUserOrNothing
|
||||
let linkedBy = fmap (.id) mUser
|
||||
workItemRef <- param @Text "workItemRef"
|
||||
system <- param @Text "system"
|
||||
unless (system `elem` validSystems) do
|
||||
setErrorMessage ("Invalid system: " <> system)
|
||||
respondWith 422 do
|
||||
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
||||
when (workItemRef == "") do
|
||||
setErrorMessage "Work item reference cannot be empty"
|
||||
respondWith 422 do
|
||||
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
||||
newRecord @ImplementationChangeReference
|
||||
|> set #decisionId decisionRecordId
|
||||
|> set #workItemRef workItemRef
|
||||
|> set #system system
|
||||
|> set #linkedBy (fmap (Id . unId) linkedBy)
|
||||
|> createRecord
|
||||
setSuccessMessage "Implementation reference added"
|
||||
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
||||
|
||||
action DeleteImplementationRefAction { implementationChangeReferenceId } = do
|
||||
ref <- fetch implementationChangeReferenceId
|
||||
let decisionRecordId = ref.decisionId
|
||||
deleteRecord ref
|
||||
setSuccessMessage "Implementation reference removed"
|
||||
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
||||
@@ -6,6 +6,7 @@ import Web.View.Hubs.Show
|
||||
import Web.View.Hubs.New
|
||||
import Web.View.Hubs.Edit
|
||||
import Web.View.Hubs.TriageDashboard
|
||||
import Web.View.Hubs.GovernanceDashboard
|
||||
import Generated.Types
|
||||
import IHP.Prelude
|
||||
import IHP.ControllerPrelude
|
||||
@@ -110,3 +111,48 @@ instance Controller HubsController where
|
||||
, recentEscalations
|
||||
, allAnnotations
|
||||
}
|
||||
|
||||
action GovernanceDashboardAction { hubId } = autoRefresh do
|
||||
hub <- fetch hubId
|
||||
widgets <- query @Widget
|
||||
|> filterWhere (#hubId, hubId)
|
||||
|> fetch
|
||||
let widgetIds = map (.id) widgets
|
||||
|
||||
-- All requirements whose source candidate is in this hub's widgets
|
||||
allCandidates <- query @RequirementCandidate
|
||||
|> filterWhereIn (#sourceWidgetId, widgetIds)
|
||||
|> fetch
|
||||
let acceptedCandidateIds = map (.id) (filter (\c -> c.status == "accepted") allCandidates)
|
||||
|
||||
allRequirements <- query @Requirement
|
||||
|> filterWhereIn (#sourceCandidateId, acceptedCandidateIds)
|
||||
|> fetch
|
||||
|
||||
-- Recent decisions (last 20) — scoped to this hub's requirements
|
||||
let requirementIds = map (.id) allRequirements
|
||||
recentDecisions <- query @DecisionRecord
|
||||
|> filterWhereIn (#requirementId, map Just requirementIds)
|
||||
|> orderByDesc #decidedAt
|
||||
|> limit 20
|
||||
|> fetch
|
||||
|
||||
-- All hub decisions (for outcome counts)
|
||||
allDecisions <- query @DecisionRecord
|
||||
|> filterWhereIn (#requirementId, map Just requirementIds)
|
||||
|> fetch
|
||||
|
||||
-- All annotations for traceability coverage
|
||||
allAnnotations <- query @Annotation
|
||||
|> filterWhereIn (#widgetId, widgetIds)
|
||||
|> fetch
|
||||
|
||||
render GovernanceDashboardView
|
||||
{ hub
|
||||
, widgets
|
||||
, allCandidates
|
||||
, allRequirements
|
||||
, recentDecisions
|
||||
, allDecisions
|
||||
, allAnnotations
|
||||
}
|
||||
|
||||
@@ -178,3 +178,58 @@ instance Controller RequirementCandidatesController where
|
||||
, widgets
|
||||
, mStatusFilter = Just "my_queue"
|
||||
}
|
||||
|
||||
action PromoteToRequirementAction { requirementCandidateId } = do
|
||||
candidate <- fetch requirementCandidateId
|
||||
-- Guard: only accepted candidates may be promoted
|
||||
when (candidate.status /= "accepted") do
|
||||
setErrorMessage "Only accepted candidates can be promoted to a requirement"
|
||||
respondWith 422 do
|
||||
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
|
||||
-- Idempotent: if already promoted, redirect to existing requirement
|
||||
case candidate.requirementId of
|
||||
Just rid -> redirectTo ShowRequirementAction { requirementId = rid }
|
||||
Nothing -> do
|
||||
mUser <- currentUserOrNothing
|
||||
let createdBy = fmap (.id) mUser
|
||||
req <- newRecord @Requirement
|
||||
|> set #title candidate.title
|
||||
|> set #description candidate.description
|
||||
|> set #sourceCandidateId requirementCandidateId
|
||||
|> set #status "active"
|
||||
|> set #createdBy (fmap (Id . unId) createdBy)
|
||||
|> createRecord
|
||||
candidate
|
||||
|> set #requirementId (Just req.id)
|
||||
|> updateRecord
|
||||
setSuccessMessage "Promoted to requirement"
|
||||
redirectTo ShowRequirementAction { requirementId = req.id }
|
||||
|
||||
action LinkToDecisionAction { requirementCandidateId } = do
|
||||
candidate <- fetch requirementCandidateId
|
||||
-- Guard: only accepted candidates
|
||||
when (candidate.status /= "accepted") do
|
||||
setErrorMessage "Only accepted candidates can be linked to a decision"
|
||||
respondWith 422 do
|
||||
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
|
||||
-- Idempotent: check if a decision already links to this candidate
|
||||
existing <- query @DecisionRecord
|
||||
|> filterWhere (#candidateId, Just requirementCandidateId)
|
||||
|> fetchOneOrNothing
|
||||
case existing of
|
||||
Just dr -> redirectTo ShowDecisionRecordAction { decisionRecordId = dr.id }
|
||||
Nothing -> do
|
||||
mUser <- currentUserOrNothing
|
||||
let decidedBy = fmap (.id) mUser
|
||||
-- Use promoted requirement id if available
|
||||
let mReqId = candidate.requirementId
|
||||
dr <- newRecord @DecisionRecord
|
||||
|> set #title candidate.title
|
||||
|> set #rationale candidate.description
|
||||
|> set #outcome "accepted"
|
||||
|> set #candidateId (Just requirementCandidateId)
|
||||
|> set #requirementId mReqId
|
||||
|> set #decidedBy (fmap (Id . unId) decidedBy)
|
||||
|> createRecord
|
||||
setSuccessMessage "Decision record created"
|
||||
redirectTo ShowDecisionRecordAction { decisionRecordId = dr.id }
|
||||
|
||||
25
Web/Controller/Requirements.hs
Normal file
25
Web/Controller/Requirements.hs
Normal file
@@ -0,0 +1,25 @@
|
||||
module Web.Controller.Requirements where
|
||||
|
||||
import Web.Types
|
||||
import Web.View.Requirements.Index
|
||||
import Web.View.Requirements.Show
|
||||
import Generated.Types
|
||||
import IHP.Prelude
|
||||
import IHP.ControllerPrelude
|
||||
|
||||
instance Controller RequirementsController where
|
||||
beforeAction = ensureIsUser
|
||||
|
||||
action RequirementsAction = do
|
||||
requirements <- query @Requirement |> orderByDesc #createdAt |> fetch
|
||||
candidates <- query @RequirementCandidate |> fetch
|
||||
render IndexView { requirements, candidates }
|
||||
|
||||
action ShowRequirementAction { requirementId } = do
|
||||
requirement <- fetch requirementId
|
||||
candidate <- fetch requirement.sourceCandidateId
|
||||
widget <- fetch candidate.sourceWidgetId
|
||||
mDecision <- query @DecisionRecord
|
||||
|> filterWhere (#requirementId, Just requirementId)
|
||||
|> fetchOneOrNothing
|
||||
render ShowView { requirement, candidate, widget, mDecision }
|
||||
Reference in New Issue
Block a user