generated from coulomb/repo-seed
Bernd Worsch
ce42607fca
Convert all remaining `<- paramOrNothing / param / paramOrDefault /
currentUserOrNothing` monadic binds to `let` — these functions are pure
(ImplicitParams-based) in IHP v1.5, so `<-` is a type error in an IO
do-block.
Controllers fixed:
AgentDelegations, AiGovernancePolicies, Annotations, ApiConsumers,
CollectiveProposals, DecisionRecords, DeploymentRecords,
HubCapabilityManifests, HubRoutingRules, InstitutionalKnowledge,
OutcomeCorrelations, RequirementCandidates, TypeRegistries,
WebhookSubscriptions, Widgets,
Api/V2/{Annotations,InteractionEvents,Token}
WebhookSubscriptions: remove orphaned `Right () ->` case arm that was
left inside a bare `unless` block (structural parse error).
Also carries forward all in-progress fixes from the working tree:
helpers (AgentBridge, ApiRateLimit, BottleneckDetector,
CrossHubPropagation, FrictionScore),
views (CanSelect instances, HSX lambda extraction, formFor wrappers),
env/build (envrc GHCi perms, flake.nix Tailwind + GHC resource limits,
static/app.css additional Tailwind output).
Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
95 lines
4.0 KiB
Haskell
95 lines
4.0 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)
|
|
|
|
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
|