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 }
|
||||
Reference in New Issue
Block a user