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.Controller (callClaudeApi)
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
        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
        mUser   <- currentUserOrNothing
        let 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
        newStatus <- param @Text "status"
        notes     <- paramOrNothing @Text "notes"
        mUser     <- currentUserOrNothing
        let 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
        userId <- param @(Id User) "userId"
        mUser  <- currentUserOrNothing
        let 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
        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
                mUser <- currentUserOrNothing
                let 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
                mUser <- currentUserOrNothing
                let 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: Detect duplicate candidates via Claude API
    action DetectDuplicatesAction { requirementCandidateId } = do
        target <- fetch requirementCandidateId
        others <- query @RequirementCandidate
            |> fetch
        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
        result <- liftIO $ callClaudeApi
            "You are a deduplication assistant. Given a target candidate and a list of existing candidates, identify likely duplicates. Respond with JSON: {\"duplicates\": [{\"id\": \"uuid\", \"reason\": \"...\"}]}."
            userMsg
            500
        case result of
            Left err -> do
                setErrorMessage ("Duplicate detection failed: " <> err)
                redirectTo ShowRequirementCandidateAction { requirementCandidateId }
            Right content -> do
                newRecord @AgentProposal
                    |> set #proposalType "duplicate_flag"
                    |> set #sourceCandidateId (Just requirementCandidateId)
                    |> set #content content
                    |> set #modelRef "claude-sonnet-4-6"
                    |> set #status "pending"
                    |> createRecord
                setSuccessMessage "Duplicate detection proposal created"
                redirectTo ShowRequirementCandidateAction { requirementCandidateId }

    -- T06: Detect policy sensitivity via Claude API
    action DetectPolicySensitivityAction { requirementCandidateId } = do
        candidate <- fetch requirementCandidateId
        mWidget   <- case candidate.sourceWidgetId of
            Nothing  -> pure Nothing
            Just wid -> fetchOneOrNothing wid
        let policyCtx = maybe "unknown" (.policyScope) mWidget
            userMsg   = "Title: " <> candidate.title
                     <> "\nDescription: " <> candidate.description
                     <> "\nPolicy scope context: " <> policyCtx
        result <- liftIO $ callClaudeApi
            "You are a policy compliance assistant. Analyse this requirement candidate for potential policy concerns. Valid scopes: internal, external, regulatory, contractual, architectural. Respond with JSON: {\"concerns\": [{\"scope\": \"...\", \"note\": \"...\"}], \"severity\": \"low|medium|high\"}."
            userMsg
            500
        case result of
            Left err -> do
                setErrorMessage ("Policy check failed: " <> err)
                redirectTo ShowRequirementCandidateAction { requirementCandidateId }
            Right content -> do
                let confidenceScore = extractSeverityScore content
                proposal <- newRecord @AgentProposal
                    |> set #proposalType "policy_flag"
                    |> set #sourceCandidateId (Just requirementCandidateId)
                    |> set #content content
                    |> set #modelRef "claude-sonnet-4-6"
                    |> set #confidence (Just confidenceScore)
                    |> set #status "pending"
                    |> createRecord
                -- Create one ConfidenceAnnotation per concern scope
                let mParsed = decode (fromStrict (encodeUtf8 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