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>
401 lines
21 KiB
Haskell
401 lines
21 KiB
Haskell
module Web.Controller.RequirementCandidates where
|
|
|
|
import Web.Types
|
|
import Web.View.RequirementCandidates.Index
|
|
import Web.View.RequirementCandidates.Show
|
|
import Web.View.RequirementCandidates.New
|
|
import Web.View.RequirementCandidates.Edit
|
|
import Generated.Types
|
|
import IHP.Prelude
|
|
import IHP.ControllerPrelude
|
|
import Application.Helper.AgentBridge (callAgent, checkGovernancePolicy, bridgeErrorMessage)
|
|
import Application.Helper.ModelRouter (resolveAgent)
|
|
import Data.List (intercalate)
|
|
import Data.Aeson (decode, Value(..), Array)
|
|
import Data.Aeson.Lens (key, _String)
|
|
import Control.Lens ((^?))
|
|
import Data.ByteString.Lazy (fromStrict)
|
|
import Web.Job.WebhookDeliveryJob (dispatchWebhooks)
|
|
import Control.Concurrent (forkIO)
|
|
import Data.Aeson ((.=), object)
|
|
import Data.Text.Encoding (encodeUtf8)
|
|
import Data.HashMap.Strict (HashMap)
|
|
import qualified Data.HashMap.Strict as HashMap
|
|
import qualified Data.Vector as Vector
|
|
import Control.Monad (forM_)
|
|
|
|
validStatuses :: [Text]
|
|
validStatuses = ["open", "in_review", "accepted", "rejected", "deferred"]
|
|
|
|
validCategories :: [Text]
|
|
validCategories = ["friction", "defect", "wish", "policy_concern", "doc_gap", "trust", "other"]
|
|
|
|
-- Allowed triage transitions
|
|
allowedTransition :: Text -> Text -> Bool
|
|
allowedTransition "open" "in_review" = True
|
|
allowedTransition "in_review" "accepted" = True
|
|
allowedTransition "in_review" "rejected" = True
|
|
allowedTransition "in_review" "deferred" = True
|
|
allowedTransition "deferred" "in_review" = True
|
|
allowedTransition _ _ = False
|
|
|
|
instance Controller RequirementCandidatesController where
|
|
beforeAction = ensureIsUser
|
|
|
|
action RequirementCandidatesAction = do
|
|
let mStatusFilter = paramOrNothing @Text "status"
|
|
candidates <- case mStatusFilter of
|
|
Nothing -> query @RequirementCandidate |> orderByDesc #createdAt |> fetch
|
|
Just s -> query @RequirementCandidate
|
|
|> filterWhere (#status, s)
|
|
|> orderByDesc #createdAt
|
|
|> fetch
|
|
-- Fetch reviewer assignments for display
|
|
assignments <- query @ReviewerAssignment |> fetch
|
|
users <- query @User |> fetch
|
|
widgets <- query @Widget |> fetch
|
|
render IndexView { candidates, assignments, users, widgets, mStatusFilter }
|
|
|
|
action ShowRequirementCandidateAction { requirementCandidateId } = do
|
|
candidate <- fetch requirementCandidateId
|
|
widget <- fetch candidate.sourceWidgetId
|
|
triageStates <- query @TriageState
|
|
|> filterWhere (#candidateId, requirementCandidateId)
|
|
|> orderByAsc #changedAt
|
|
|> fetch
|
|
mAssignment <- query @ReviewerAssignment
|
|
|> filterWhere (#candidateId, requirementCandidateId)
|
|
|> fetchOneOrNothing
|
|
users <- query @User |> fetch
|
|
mSourceAnnotation <- case candidate.sourceAnnotationId of
|
|
Nothing -> pure Nothing
|
|
Just aid -> fetchOneOrNothing aid
|
|
mSourceThread <- case candidate.sourceThreadId of
|
|
Nothing -> pure Nothing
|
|
Just tid -> fetchOneOrNothing tid
|
|
render ShowView { candidate, widget, triageStates, mAssignment, users, mSourceAnnotation, mSourceThread }
|
|
|
|
action NewRequirementCandidateAction = do
|
|
widgets <- query @Widget |> fetch
|
|
threads <- query @AnnotationThread |> fetch
|
|
let candidate = newRecord @RequirementCandidate
|
|
render NewView { candidate, widgets, threads }
|
|
|
|
action CreateRequirementCandidateAction = do
|
|
widgets <- query @Widget |> fetch
|
|
threads <- query @AnnotationThread |> fetch
|
|
let mUser = currentUserOrNothing
|
|
createdBy = fmap (.id) mUser
|
|
|
|
let candidate = newRecord @RequirementCandidate
|
|
candidate
|
|
|> fill @'["title", "description", "sourceWidgetId", "sourceThreadId", "category"]
|
|
|> set #status "open"
|
|
|> set #createdBy (fmap (Id . unId) createdBy)
|
|
|> validateField #title nonEmpty
|
|
|> validateField #description nonEmpty
|
|
|> validateField #category (`elem` validCategories)
|
|
|> ifValid \case
|
|
Left candidate -> render NewView { candidate, widgets, threads }
|
|
Right candidate -> do
|
|
created <- createRecord candidate
|
|
-- Dispatch webhooks fire-and-forget
|
|
let webhookPayload = object
|
|
[ "event" .= ("requirement_candidate.created" :: Text)
|
|
, "resourceId" .= created.id
|
|
, "title" .= created.title
|
|
, "category" .= created.category
|
|
]
|
|
liftIO $ void $ forkIO $
|
|
dispatchWebhooks "requirement_candidate.created" webhookPayload
|
|
setSuccessMessage "Requirement candidate created"
|
|
redirectTo ShowRequirementCandidateAction { requirementCandidateId = created.id }
|
|
|
|
action EditRequirementCandidateAction { requirementCandidateId } = do
|
|
candidate <- fetch requirementCandidateId
|
|
widgets <- query @Widget |> fetch
|
|
threads <- query @AnnotationThread |> fetch
|
|
render EditView { candidate, widgets, threads }
|
|
|
|
action UpdateRequirementCandidateAction { requirementCandidateId } = do
|
|
candidate <- fetch requirementCandidateId
|
|
widgets <- query @Widget |> fetch
|
|
threads <- query @AnnotationThread |> fetch
|
|
|
|
candidate
|
|
|> fill @'["title", "description", "sourceWidgetId", "sourceThreadId", "category"]
|
|
|> validateField #title nonEmpty
|
|
|> validateField #description nonEmpty
|
|
|> validateField #category (`elem` validCategories)
|
|
|> ifValid \case
|
|
Left candidate -> render EditView { candidate, widgets, threads }
|
|
Right candidate -> do
|
|
updateRecord candidate
|
|
setSuccessMessage "Candidate updated"
|
|
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
|
|
|
|
action UpdateTriageStatusAction { requirementCandidateId } = do
|
|
candidate <- fetch requirementCandidateId
|
|
let newStatus = param @Text "status"
|
|
notes = paramOrNothing @Text "notes"
|
|
mUser = currentUserOrNothing
|
|
changedBy = fmap (.id) mUser
|
|
|
|
if allowedTransition candidate.status newStatus
|
|
then do
|
|
-- Insert triage state row (append-only audit trail)
|
|
newRecord @TriageState
|
|
|> set #candidateId requirementCandidateId
|
|
|> set #status newStatus
|
|
|> set #notes notes
|
|
|> set #changedBy (fmap (Id . unId) changedBy)
|
|
|> createRecord
|
|
-- Update current status on candidate
|
|
candidate
|
|
|> set #status newStatus
|
|
|> updateRecord
|
|
setSuccessMessage ("Status updated to " <> newStatus)
|
|
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
|
|
else do
|
|
setErrorMessage ("Invalid transition: " <> candidate.status <> " → " <> newStatus)
|
|
respondWith 422 do
|
|
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
|
|
|
|
action AssignReviewerAction { requirementCandidateId } = do
|
|
let userId = param @(Id User) "userId"
|
|
mUser = currentUserOrNothing
|
|
assignedBy = fmap (.id) mUser
|
|
|
|
-- Upsert: delete existing assignment then insert
|
|
existing <- query @ReviewerAssignment
|
|
|> filterWhere (#candidateId, requirementCandidateId)
|
|
|> fetchOneOrNothing
|
|
case existing of
|
|
Just ra -> deleteRecord ra
|
|
Nothing -> pure ()
|
|
|
|
newRecord @ReviewerAssignment
|
|
|> set #candidateId requirementCandidateId
|
|
|> set #userId userId
|
|
|> set #assignedBy (fmap (Id . unId) assignedBy)
|
|
|> createRecord
|
|
|
|
setSuccessMessage "Reviewer assigned"
|
|
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
|
|
|
|
action MyQueueAction = do
|
|
let mUser = currentUserOrNothing
|
|
case mUser of
|
|
Nothing -> redirectTo RequirementCandidatesAction
|
|
Just user -> do
|
|
assignments <- query @ReviewerAssignment
|
|
|> filterWhere (#userId, user.id)
|
|
|> fetch
|
|
let candidateIds = map (.candidateId) assignments
|
|
candidates <- mapM fetch candidateIds
|
|
let active = filter (\c -> c.status `elem` ["open", "in_review"]) candidates
|
|
widgets <- query @Widget |> fetch
|
|
render IndexView
|
|
{ candidates = active
|
|
, assignments
|
|
, users = [user]
|
|
, 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
|
|
let mUser = currentUserOrNothing
|
|
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
|
|
let mUser = currentUserOrNothing
|
|
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 }
|
|
|
|
-- T05 / Phase 11: Detect duplicate candidates via routed agent
|
|
action DetectDuplicatesAction { requirementCandidateId } = do
|
|
target <- fetch requirementCandidateId
|
|
others <- query @RequirementCandidate |> fetch
|
|
-- Resolve hub from the source widget
|
|
mHubId <- case target.sourceWidgetId of
|
|
Nothing -> pure Nothing
|
|
Just wid -> fmap (.hubId) <$> fetchOneOrNothing @Widget wid
|
|
let otherLines = map (\c -> show c.id <> " | " <> c.title <> ": " <> c.description)
|
|
(filter (\c -> c.id /= requirementCandidateId) others)
|
|
targetLine = "TARGET: " <> target.title <> ": " <> target.description
|
|
userMsg = targetLine <> "\n\nEXISTING:\n" <> intercalate "\n" otherLines
|
|
case mHubId of
|
|
Nothing -> do
|
|
setErrorMessage "Cannot determine hub for routing — ensure the candidate has a source widget"
|
|
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
|
|
Just hubId -> do
|
|
mAgent <- resolveAgent hubId "triage"
|
|
case mAgent of
|
|
Nothing -> do
|
|
setErrorMessage "No routing policy for 'triage' task type"
|
|
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
|
|
Just agent -> do
|
|
allowed <- checkGovernancePolicy hubId agent.id "requirement_candidate"
|
|
if not allowed
|
|
then do
|
|
newRecord @AgentProposal
|
|
|> set #proposalType "duplicate_flag"
|
|
|> set #sourceCandidateId (Just requirementCandidateId)
|
|
|> 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 ShowRequirementCandidateAction { requirementCandidateId }
|
|
else do
|
|
result <- liftIO $ callAgent agent userMsg
|
|
case result of
|
|
Left err -> do
|
|
setErrorMessage ("Duplicate detection failed: " <> bridgeErrorMessage err)
|
|
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
|
|
Right resp -> do
|
|
newRecord @AgentProposal
|
|
|> set #proposalType "duplicate_flag"
|
|
|> set #sourceCandidateId (Just requirementCandidateId)
|
|
|> 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 "Duplicate detection proposal created"
|
|
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
|
|
|
|
-- T06: Detect policy sensitivity via routed agent
|
|
action DetectPolicySensitivityAction { requirementCandidateId } = do
|
|
candidate <- fetch requirementCandidateId
|
|
mWidget <- case candidate.sourceWidgetId of
|
|
Nothing -> pure Nothing
|
|
Just wid -> fetchOneOrNothing wid
|
|
-- Resolve hub for routing
|
|
mHubId <- case candidate.sourceWidgetId of
|
|
Nothing -> pure Nothing
|
|
Just wid -> fmap (.hubId) <$> fetchOneOrNothing @Widget wid
|
|
let policyCtx = maybe "unknown" (.policyScope) mWidget
|
|
userMsg = "Title: " <> candidate.title
|
|
<> "\nDescription: " <> candidate.description
|
|
<> "\nPolicy scope context: " <> policyCtx
|
|
<> "\nRespond with JSON: {\"concerns\": [{\"scope\": \"...\", \"note\": \"...\"}], \"severity\": \"low|medium|high\"}."
|
|
case mHubId of
|
|
Nothing -> do
|
|
setErrorMessage "Cannot determine hub for routing — ensure the candidate has a source widget"
|
|
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
|
|
Just hubId -> do
|
|
mAgent <- resolveAgent hubId "policy_sensitivity"
|
|
case mAgent of
|
|
Nothing -> do
|
|
setErrorMessage "No routing policy for 'policy_sensitivity' task type"
|
|
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
|
|
Just agent -> do
|
|
allowed <- checkGovernancePolicy hubId agent.id "requirement_candidate"
|
|
if not allowed
|
|
then do
|
|
newRecord @AgentProposal
|
|
|> set #proposalType "policy_flag"
|
|
|> set #sourceCandidateId (Just requirementCandidateId)
|
|
|> 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 ShowRequirementCandidateAction { requirementCandidateId }
|
|
else do
|
|
result <- liftIO $ callAgent agent userMsg
|
|
case result of
|
|
Left err -> do
|
|
setErrorMessage ("Policy check failed: " <> bridgeErrorMessage err)
|
|
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
|
|
Right resp -> do
|
|
let confidenceScore = extractSeverityScore resp.content
|
|
proposal <- newRecord @AgentProposal
|
|
|> set #proposalType "policy_flag"
|
|
|> set #sourceCandidateId (Just requirementCandidateId)
|
|
|> set #content resp.content
|
|
|> set #modelRef resp.modelUsed
|
|
|> set #confidence (Just confidenceScore)
|
|
|> set #status "pending"
|
|
|> set #agentRegistrationId (Just agent.id)
|
|
|> set #tokensIn (Just resp.tokensIn)
|
|
|> set #tokensOut (Just resp.tokensOut)
|
|
|> createRecord
|
|
-- Create one ConfidenceAnnotation per concern scope
|
|
let mParsed = decode (fromStrict (encodeUtf8 resp.content))
|
|
:: Maybe (HashMap Text Value)
|
|
case mParsed >>= HashMap.lookup "concerns" of
|
|
Just (Array concerns) ->
|
|
forM_ (Vector.toList concerns) \concern ->
|
|
case (concern ^? key "scope" . _String
|
|
,concern ^? key "note" . _String) of
|
|
(Just scope, noteM) ->
|
|
newRecord @ConfidenceAnnotation
|
|
|> set #proposalId proposal.id
|
|
|> set #dimension scope
|
|
|> set #score confidenceScore
|
|
|> set #explanation noteM
|
|
|> createRecord
|
|
_ -> pure ()
|
|
_ -> pure ()
|
|
setSuccessMessage "Policy check proposal created"
|
|
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
|
|
|
|
-- Map severity string to numeric confidence
|
|
extractSeverityScore :: Text -> Double
|
|
extractSeverityScore content
|
|
| "\"high\"" `isInfixOf` content = 0.9
|
|
| "\"medium\"" `isInfixOf` content = 0.6
|
|
| otherwise = 0.3
|