inter-hub/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

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
                    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 }