inter-hub/Web/Controller/Annotations.hs

module Web.Controller.Annotations where

import Web.Types
import Web.View.Annotations.Index
import Web.View.Annotations.New
import Web.View.Annotations.Show
import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
import Application.Helper.TypeRegistry (validateAnnotationCategory, activeAnnotationCategories)

validSeverities :: [Text]
validSeverities = ["low", "medium", "high", "critical"]

instance Controller AnnotationsController where
    beforeAction = ensureIsUser

    action WidgetAnnotationsAction { widgetId } = do
        widget      <- fetch widgetId
        annotations <- query @Annotation
            |> filterWhere (#widgetId, widgetId)
            |> orderByAsc #createdAt
            |> fetch
        render IndexView { widget, annotations }

    action ShowAnnotationAction { annotationId } = do
        annotation <- fetch annotationId
        widget     <- fetch annotation.widgetId
        -- Check if already escalated to a candidate
        mCandidate <- query @RequirementCandidate
            |> filterWhere (#sourceAnnotationId, Just annotationId)
            |> fetchOneOrNothing
        render ShowView { widget, annotation, mCandidate }

    action NewAnnotationAction { widgetId } = do
        widget     <- fetch widgetId
        categories <- activeAnnotationCategories
        let annotation = newRecord @Annotation
        render NewView { widget, annotation, categories }

    action CreateAnnotationAction { widgetId } = do
        widget     <- fetch widgetId
        categories <- activeAnnotationCategories
        mUser      <- currentUserOrNothing
        let actorId   = fmap (.id) mUser
            actorType = maybe "anonymous" (const "user") mUser

        category <- paramOrDefault @Text "" "category"
        categoryResult <- validateAnnotationCategory category

        let annotation = newRecord @Annotation
        annotation
            |> fill @'["body", "category", "severity", "parentId", "widgetStateRef"]
            |> set #widgetId  widgetId
            |> set #actorId   (fmap (Id . unId) actorId)
            |> set #actorType actorType
            |> validateField #body nonEmpty
            |> validateField #severity (`elem` validSeverities)
            |> (case categoryResult of
                    Left msg -> attachFailure #category msg
                    Right () -> id)
            |> ifValid \case
                Left annotation -> render NewView { widget, annotation, categories }
                Right annotation -> do
                    createRecord annotation
                    setSuccessMessage "Annotation added"
                    redirectTo WidgetAnnotationsAction { widgetId }

    action EscalateAnnotationAction { annotationId } = do
        annotation <- fetch annotationId
        mUser      <- currentUserOrNothing
        let createdBy = fmap (.id) mUser
        -- Idempotent: check if already escalated
        existing <- query @RequirementCandidate
            |> filterWhere (#sourceAnnotationId, Just annotationId)
            |> fetchOneOrNothing
        case existing of
            Just candidate ->
                redirectTo ShowRequirementCandidateAction { requirementCandidateId = candidate.id }
            Nothing -> do
                let titleText = truncate80 annotation.body
                candidate <- newRecord @RequirementCandidate
                    |> set #title titleText
                    |> set #description annotation.body
                    |> set #sourceWidgetId annotation.widgetId
                    |> set #sourceAnnotationId (Just annotationId)
                    |> set #category annotation.category
                    |> set #status "open"
                    |> set #createdBy (fmap (Id . unId) createdBy)
                    |> createRecord
                setSuccessMessage "Escalated to requirement candidate"
                redirectTo ShowRequirementCandidateAction { requirementCandidateId = candidate.id }

truncate80 :: Text -> Text
truncate80 t = if length t > 80 then take 80 t <> "…" else t