Bernd Worsch
3737845e02
Fixes 46 compile errors across 18 controllers and views: - BridgeResponse missing from explicit import lists (Widgets, RequirementCandidates, DecisionRecords, AgentDelegations) — dot-notation HasField resolution fails without the type in scope under DuplicateRecordFields - unId not in IHP v1.5 — replaced all fmap (Id . unId) with fmap coerce - respondWith not in IHP — replaced with plain redirectTo in 5 controllers - [hubId] list param to sqlQuery — replaced with (Only hubId) tuple - deleteWhere not in IHP — replaced with query/filterWhere/fetch/deleteRecords - fill @'["label"] mismatch — field is label_ in generated types, not label - PersistUUID/toUUID (persistent-style) — replaced with (Only id) - intercalate + jsonArrayTexts ambiguity in GovernanceTemplates — hid Index import, removed local duplicates, added Data.Text (intercalate) - Int16 not in scope in AntifragilityDashboard — changed to Int (score :: Int) - typeArraySection type mismatch in HubCapabilityManifests/Edit — unified to [Text] - renderForm arity mismatch — added action param to DecisionRecords/New.renderForm - Missing qualified Data.Aeson import in AdaptiveThresholds - Missing ?request::Request constraint in Api/V2/WidgetPatterns.renderJsonWithStatus Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
96 lines
4 KiB
Haskell
96 lines
4 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
|
|
import Application.Helper.TypeRegistry (validateAnnotationCategory, activeAnnotationCategories)
|
|
import Data.Coerce (coerce)
|
|
import qualified Data.Text as T
|
|
|
|
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 coerce actorId)
|
|
|> set #actorType actorType
|
|
|> validateField #body nonEmpty
|
|
|> validateField #severity (`elem` validSeverities)
|
|
|> (case categoryResult of
|
|
Left msg -> attachFailure #category msg
|
|
Right () -> \x -> x)
|
|
|> 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 coerce createdBy)
|
|
|> createRecord
|
|
setSuccessMessage "Escalated to requirement candidate"
|
|
redirectTo ShowRequirementCandidateAction { requirementCandidateId = candidate.id }
|
|
|
|
truncate80 :: Text -> Text
|
|
truncate80 t = if T.length t > 80 then T.take 80 t <> "…" else t
|