generated from coulomb/repo-seed
Bernd Worsch
3737845e02
Fixes 46 compile errors across 18 controllers and views: - BridgeResponse missing from explicit import lists (Widgets, RequirementCandidates, DecisionRecords, AgentDelegations) — dot-notation HasField resolution fails without the type in scope under DuplicateRecordFields - unId not in IHP v1.5 — replaced all fmap (Id . unId) with fmap coerce - respondWith not in IHP — replaced with plain redirectTo in 5 controllers - [hubId] list param to sqlQuery — replaced with (Only hubId) tuple - deleteWhere not in IHP — replaced with query/filterWhere/fetch/deleteRecords - fill @'["label"] mismatch — field is label_ in generated types, not label - PersistUUID/toUUID (persistent-style) — replaced with (Only id) - intercalate + jsonArrayTexts ambiguity in GovernanceTemplates — hid Index import, removed local duplicates, added Data.Text (intercalate) - Int16 not in scope in AntifragilityDashboard — changed to Int (score :: Int) - typeArraySection type mismatch in HubCapabilityManifests/Edit — unified to [Text] - renderForm arity mismatch — added action param to DecisionRecords/New.renderForm - Missing qualified Data.Aeson import in AdaptiveThresholds - Missing ?request::Request constraint in Api/V2/WidgetPatterns.renderJsonWithStatus Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
302 lines
15 KiB
Haskell
302 lines
15 KiB
Haskell
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
|
|
import Application.Helper.AgentBridge (callAgent, checkGovernancePolicy, bridgeErrorMessage, BridgeResponse)
|
|
import Application.Helper.ModelRouter (resolveAgent)
|
|
import Data.List (intercalate)
|
|
import IHP.ModelSupport (sqlQuery)
|
|
import qualified Data.Aeson as A
|
|
import Data.Coerce (coerce)
|
|
|
|
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
|
|
let 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
|
|
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
|
|
Nothing -> pure Nothing
|
|
Just cid -> fetchOneOrNothing cid
|
|
users <- query @User |> fetch
|
|
render ShowView
|
|
{ record
|
|
, policyRefs
|
|
, implRefs
|
|
, deploymentRecords
|
|
, evaluations
|
|
, 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
|
|
let mUser = currentUserOrNothing
|
|
decidedBy = fmap (.id) mUser
|
|
|
|
let record = newRecord @DecisionRecord
|
|
record
|
|
|> fill @'["title", "rationale", "outcome", "requirementId", "candidateId", "notes"]
|
|
|> set #decidedBy (fmap coerce 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
|
|
let mUser = currentUserOrNothing
|
|
createdBy = fmap (.id) mUser
|
|
policyScope = param @Text "policyScope"
|
|
constraintNote = paramOrNothing @Text "constraintNote"
|
|
unless (policyScope `elem` validPolicyScopes) do
|
|
setErrorMessage ("Invalid policy scope: " <> policyScope)
|
|
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
|
newRecord @PolicyReference
|
|
|> set #decisionId decisionRecordId
|
|
|> set #policyScope policyScope
|
|
|> set #constraintNote constraintNote
|
|
|> set #createdBy (fmap coerce 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
|
|
let mUser = currentUserOrNothing
|
|
linkedBy = fmap (.id) mUser
|
|
workItemRef = param @Text "workItemRef"
|
|
system = param @Text "system"
|
|
unless (system `elem` validSystems) do
|
|
setErrorMessage ("Invalid system: " <> system)
|
|
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
|
when (workItemRef == "") do
|
|
setErrorMessage "Work item reference cannot be empty"
|
|
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
|
newRecord @ImplementationChangeReference
|
|
|> set #decisionId decisionRecordId
|
|
|> set #workItemRef workItemRef
|
|
|> set #system system
|
|
|> set #linkedBy (fmap coerce 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 }
|
|
|
|
-- T07 / Phase 11: Propose implementation paths via routed agent
|
|
action ProposeImplementationAction { decisionRecordId } = do
|
|
record <- fetch decisionRecordId
|
|
implRefs <- query @ImplementationChangeReference
|
|
|> filterWhere (#decisionId, decisionRecordId)
|
|
|> fetch
|
|
mRequirement <- case record.requirementId of
|
|
Nothing -> pure Nothing
|
|
Just rid -> fetchOneOrNothing rid
|
|
-- Resolve hub from the source widget via requirement candidate
|
|
mHubId <- case mRequirement >>= (.sourceWidgetId) of
|
|
Nothing -> pure Nothing
|
|
Just wid -> fmap (.hubId) <$> fetchOneOrNothing @Widget wid
|
|
let implLines = map (\r -> r.system <> ": " <> r.workItemRef) implRefs
|
|
reqDesc = maybe "" (.description) mRequirement
|
|
userMsg = "Decision: " <> record.title
|
|
<> "\nRationale: " <> record.rationale
|
|
<> "\nOutcome: " <> record.outcome
|
|
<> "\nRequirement: " <> reqDesc
|
|
<> "\nExisting impl refs: " <> intercalate ", " implLines
|
|
case mHubId of
|
|
Nothing -> do
|
|
setErrorMessage "Cannot determine hub for routing — ensure the decision has a linked requirement with a source widget"
|
|
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
|
Just hubId -> do
|
|
mAgent <- resolveAgent hubId "implementation"
|
|
case mAgent of
|
|
Nothing -> do
|
|
setErrorMessage "No routing policy for 'implementation' task type"
|
|
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
|
Just agent -> do
|
|
allowed <- checkGovernancePolicy hubId agent.id "decision_record"
|
|
if not allowed
|
|
then do
|
|
newRecord @AgentProposal
|
|
|> set #proposalType "impl_proposal"
|
|
|> set #sourceDecisionId (Just decisionRecordId)
|
|
|> set #content "Blocked by AI governance policy"
|
|
|> set #modelRef agent.modelName
|
|
|> set #status "blocked_by_policy"
|
|
|> set #agentRegistrationId (Just agent.id)
|
|
|> createRecord
|
|
setErrorMessage "Blocked by AI governance policy"
|
|
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
|
else do
|
|
result <- liftIO $ callAgent agent userMsg
|
|
case result of
|
|
Left err -> do
|
|
setErrorMessage ("Implementation proposal failed: " <> bridgeErrorMessage err)
|
|
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
|
Right resp -> do
|
|
newRecord @AgentProposal
|
|
|> set #proposalType "impl_proposal"
|
|
|> set #sourceDecisionId (Just decisionRecordId)
|
|
|> set #content resp.content
|
|
|> set #modelRef resp.modelUsed
|
|
|> set #status "pending"
|
|
|> set #agentRegistrationId (Just agent.id)
|
|
|> set #tokensIn (Just resp.tokensIn)
|
|
|> set #tokensOut (Just resp.tokensOut)
|
|
|> createRecord
|
|
setSuccessMessage "Implementation proposal created"
|
|
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
|
|
|
-- T05 / Phase 12: Distil decision into institutional knowledge entry
|
|
action DistilDecisionAction { decisionRecordId } = do
|
|
record <- fetch decisionRecordId
|
|
outcomes <- sqlQuery
|
|
"SELECT os.signal_type, os.value FROM outcome_signals os \
|
|
\ JOIN deployment_records dep ON dep.id = os.deployment_id \
|
|
\ WHERE dep.decision_id = ?"
|
|
[decisionRecordId]
|
|
:: IO [(Text, Maybe Double)]
|
|
let signalText = intercalate ", " $
|
|
map (\(st, mv) -> st <> maybe "" (\v -> "=" <> show v) mv) outcomes
|
|
prompt = "Distil this decision into a 2-3 sentence institutional knowledge entry. "
|
|
<> "Include the outcome data.\n\nDecision: " <> record.title
|
|
<> "\nRationale: " <> record.rationale
|
|
<> "\nOutcome: " <> record.outcome
|
|
<> "\nSignals: " <> signalText
|
|
-- Resolve hub from requirement chain
|
|
mHubId <- case record.requirementId of
|
|
Nothing -> pure Nothing
|
|
Just rid -> do
|
|
mReq <- fetchOneOrNothing rid
|
|
pure $ case mReq >>= (.sourceWidgetId) of
|
|
Nothing -> Nothing
|
|
Just _ -> Nothing -- hub resolution via widget lookup below
|
|
mHubIdResolved <- case record.requirementId of
|
|
Nothing -> pure Nothing
|
|
Just rid -> do
|
|
mReq <- fetchOneOrNothing rid
|
|
case mReq >>= (.sourceWidgetId) of
|
|
Nothing -> pure Nothing
|
|
Just wid -> fmap (.hubId) <$> fetchOneOrNothing @Widget wid
|
|
case mHubIdResolved of
|
|
Nothing -> do
|
|
setErrorMessage "Cannot resolve hub — ensure decision has a linked requirement with a source widget"
|
|
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
|
Just hubId -> do
|
|
mAgent <- resolveAgent hubId "synthesis"
|
|
case mAgent of
|
|
Nothing -> do
|
|
setErrorMessage "No routing policy for 'synthesis' task type"
|
|
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
|
Just agent -> do
|
|
result <- liftIO $ callAgent agent prompt
|
|
case result of
|
|
Left err -> do
|
|
setErrorMessage ("Distillation failed: " <> bridgeErrorMessage err)
|
|
redirectTo ShowDecisionRecordAction { decisionRecordId }
|
|
Right resp -> do
|
|
newRecord @InstitutionalKnowledgeEntry
|
|
|> set #hubId hubId
|
|
|> set #decisionRecordId (Just decisionRecordId)
|
|
|> set #summary resp.content
|
|
|> set #tags (A.toJSON ["decision" :: Text])
|
|
|> createRecord
|
|
setSuccessMessage "Knowledge entry created"
|
|
redirectTo ShowDecisionRecordAction { decisionRecordId }
|