inter-hub-haskell/Web/Controller/RequirementCandidates.hs

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, BridgeResponse(..))
import Application.Helper.ModelRouter (resolveAgent)
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 Control.Monad (void)
import Data.Coerce (coerce)
import Data.Scientific (Scientific)
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 coerce createdBy)
            |> validateField #title nonEmpty
            |> validateField #description nonEmpty
            |> validateField #category (isInList 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 (isInList 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 coerce 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)
                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 coerce 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"
            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 coerce 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"
            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 coerce 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 (sourceWidgetId is non-nullable)
        mHubId <- fmap (.hubId) <$> fetchOneOrNothing target.sourceWidgetId
        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
        -- sourceWidgetId is non-nullable; fetchOneOrNothing handles missing widget
        mWidget <- fetchOneOrNothing candidate.sourceWidgetId
        mHubId  <- fmap (.hubId) <$> fetchOneOrNothing candidate.sourceWidgetId
        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 = realToFrac (extractSeverityScore resp.content) :: Scientific
                                        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) ->
                                                            void $ newRecord @ConfidenceAnnotation
                                                                |> set #proposalId proposal.id
                                                                |> set #dimension scope
                                                                |> set #score (confidenceScore :: Scientific)
                                                                |> 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