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