generated from coulomb/repo-seed
Bernd Worsch
840b0e5c7b
Phase 2 — Structured Feedback and Triage (IHUB-WP-0002): - Schema: annotation_threads, requirement_candidates, triage_states, reviewer_assignments; annotations extended with severity + thread_id - AnnotationThreadsController: create threads, assign annotations - RequirementCandidatesController: CRUD, escalation, triage lifecycle, reviewer assignment, my-queue - Annotation severity (low/medium/high/critical) with Tailwind color cues - TriageDashboardAction on HubsController with autoRefresh - Integration tests (T01–T09), SCOPE.md updated, docs/phase2-summary.md Phase 3 — Governance and Decision Linkage (IHUB-WP-0003): - Workplan registered: 9 tasks, State Hub workstream 5f201ee3 Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
91 lines
3.7 KiB
Haskell
91 lines
3.7 KiB
Haskell
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
|
|
|
|
validCategories :: [Text]
|
|
validCategories = ["friction", "defect", "wish", "policy_concern", "doc_gap", "trust", "other"]
|
|
|
|
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
|
|
let annotation = newRecord @Annotation
|
|
render NewView { widget, annotation }
|
|
|
|
action CreateAnnotationAction { widgetId } = do
|
|
widget <- fetch widgetId
|
|
mUser <- currentUserOrNothing
|
|
let actorId = fmap (.id) mUser
|
|
actorType = maybe "anonymous" (const "user") mUser
|
|
|
|
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 #category (`elem` validCategories)
|
|
|> validateField #severity (`elem` validSeverities)
|
|
|> ifValid \case
|
|
Left annotation -> render NewView { widget, annotation }
|
|
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
|