tegwick
2106000cc7
Fix 13 modules that blocked compilation on Alpine: - FrontController: remove annotationLauncherScript helper (IHP Html is a constrained type synonym); add (?context, ?request) constraint to defaultLayout matching what setLayout expects - HubCapabilityManifests: switch JSONB fill to paramList+toJSON; fix dynamic SQL Text→Query via fromString/cs; void sqlExec; add Control.Monad.void - Hubs: replace raw Array sqlQuery with filterWhereIn query builder; fix isInList validators - DecisionRecords: remove unregistered DistilDecisionAction; fix hub resolution chain via candidateId→sourceWidgetId; BridgeResponse(..) - RequirementCandidates: BridgeResponse(..); remove @Widget type apps from fetchOneOrNothing; void ConfidenceAnnotation createRecord - AdaptiveThresholds: fix sqlQuery tuple param (Only hubId) - AgentDelegations, AgentRegistrations, Widgets: BridgeResponse(..) - Annotations, DeploymentRecords, GovernanceTemplates: minor type fixes - DecisionRecords/Edit view: extract formAction before HSX block 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 (isInList 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
|