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 let mUser = currentUserOrNothing 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 let mUser = currentUserOrNothing 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