coulomb/inter-hub
2
0
Fork 0
generated from coulomb/repo-seed
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(P2+P3): IHF Phase 2 complete; register Phase 3 workplan

Browse Source 
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>
This commit is contained in:
Bernd Worsch
2026-03-28 23:37:34 +00:00
parent cfcf4c81f7
commit 840b0e5c7b
25 changed files with 2136 additions and 29 deletions
Download Patch File Download Diff File Expand all files Collapse all files

65
Web/Controller/AnnotationThreads.hs Normal file
View File

@@ -0,0 +1,65 @@
module Web.Controller.AnnotationThreads where
import Web.Types
import Web.View.AnnotationThreads.Index
import Web.View.AnnotationThreads.New
import Web.View.AnnotationThreads.Show
import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
instance Controller AnnotationThreadsController where
beforeAction = ensureIsUser
action WidgetAnnotationThreadsAction { widgetId } = do
widget <- fetch widgetId
threads <- query @AnnotationThread
|> filterWhere (#widgetId, widgetId)
|> orderByDesc #createdAt
|> fetch
-- Fetch annotation counts per thread
allAnnotations <- query @Annotation
|> filterWhere (#widgetId, widgetId)
|> fetch
render IndexView { widget, threads, allAnnotations }
action ShowAnnotationThreadAction { annotationThreadId } = do
thread <- fetch annotationThreadId
widget <- fetch thread.widgetId
annotations <- query @Annotation
|> filterWhere (#threadId, Just annotationThreadId)
|> orderByAsc #createdAt
|> fetch
render ShowView { widget, thread, annotations }
action NewAnnotationThreadAction { widgetId } = do
widget <- fetch widgetId
let thread = newRecord @AnnotationThread
render NewView { widget, thread }
action CreateAnnotationThreadAction { widgetId } = do
widget <- fetch widgetId
mUser <- currentUserOrNothing
let createdBy = fmap (.id) mUser
let thread = newRecord @AnnotationThread
thread
|> fill @'["title", "description"]
|> set #widgetId widgetId
|> set #createdBy (fmap (Id . unId) createdBy)
|> validateField #title nonEmpty
|> ifValid \case
Left thread -> render NewView { widget, thread }
Right thread -> do
createRecord thread
setSuccessMessage "Thread created"
redirectTo WidgetAnnotationThreadsAction { widgetId }
action AssignAnnotationToThreadAction { annotationId } = do
annotation <- fetch annotationId
threadId <- param @(Id AnnotationThread) "threadId"
annotation
|> set #threadId (Just threadId)
|> updateRecord
setSuccessMessage "Annotation added to thread"
redirectTo ShowAnnotationThreadAction { annotationThreadId = threadId }

44
Web/Controller/Annotations.hs
View File

@@ -3,6 +3,7 @@ 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
@@ -10,6 +11,9 @@ 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
@@ -21,6 +25,15 @@ instance Controller AnnotationsController where
|> 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
@@ -34,15 +47,44 @@ instance Controller AnnotationsController where
let annotation = newRecord @Annotation
annotation
|> fill @'["body", "category", "parentId", "widgetStateRef"]
|> 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

38
Web/Controller/Hubs.hs
View File

@@ -5,6 +5,7 @@ import Web.View.Hubs.Index
import Web.View.Hubs.Show
import Web.View.Hubs.New
import Web.View.Hubs.Edit
import Web.View.Hubs.TriageDashboard
import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
@@ -72,3 +73,40 @@ instance Controller HubsController where
deleteRecord hub
setSuccessMessage "Hub deleted"
redirectTo HubsAction
action TriageDashboardAction { hubId } = autoRefresh do
hub <- fetch hubId
widgets <- query @Widget
|> filterWhere (#hubId, hubId)
|> fetch
let widgetIds = map (.id) widgets
-- All candidates for this hub's widgets
allCandidates <- query @RequirementCandidate
|> filterWhereIn (#sourceWidgetId, widgetIds)
|> orderByAsc #createdAt
|> fetch
-- Triage queue: open candidates, oldest first
let triageQueue = filter (\c -> c.status == "open") allCandidates
-- Recent escalations: last 20
recentEscalations <- query @RequirementCandidate
|> filterWhereIn (#sourceWidgetId, widgetIds)
|> orderByDesc #createdAt
|> limit 20
|> fetch
-- All annotations for category breakdown
allAnnotations <- query @Annotation
|> filterWhereIn (#widgetId, widgetIds)
|> fetch
render TriageDashboardView
{ hub
, widgets
, allCandidates
, triageQueue
, recentEscalations
, allAnnotations
}

180
Web/Controller/RequirementCandidates.hs Normal file
View File

@@ -0,0 +1,180 @@
module Web.Controller.RequirementCandidates where
import Web.Types
import Web.View.RequirementCandidates.Index
import Web.View.RequirementCandidates.Show
import Web.View.RequirementCandidates.New
import Web.View.RequirementCandidates.Edit
import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
validStatuses :: [Text]
validStatuses = ["open", "in_review", "accepted", "rejected", "deferred"]
validCategories :: [Text]
validCategories = ["friction", "defect", "wish", "policy_concern", "doc_gap", "trust", "other"]
-- Allowed triage transitions
allowedTransition :: Text -> Text -> Bool
allowedTransition "open" "in_review" = True
allowedTransition "in_review" "accepted" = True
allowedTransition "in_review" "rejected" = True
allowedTransition "in_review" "deferred" = True
allowedTransition "deferred" "in_review" = True
allowedTransition _ _ = False
instance Controller RequirementCandidatesController where
beforeAction = ensureIsUser
action RequirementCandidatesAction = do
mStatusFilter <- paramOrNothing @Text "status"
candidates <- case mStatusFilter of
Nothing -> query @RequirementCandidate |> orderByDesc #createdAt |> fetch
Just s -> query @RequirementCandidate
|> filterWhere (#status, s)
|> orderByDesc #createdAt
|> fetch
-- Fetch reviewer assignments for display
assignments <- query @ReviewerAssignment |> fetch
users <- query @User |> fetch
widgets <- query @Widget |> fetch
render IndexView { candidates, assignments, users, widgets, mStatusFilter }
action ShowRequirementCandidateAction { requirementCandidateId } = do
candidate <- fetch requirementCandidateId
widget <- fetch candidate.sourceWidgetId
triageStates <- query @TriageState
|> filterWhere (#candidateId, requirementCandidateId)
|> orderByAsc #changedAt
|> fetch
mAssignment <- query @ReviewerAssignment
|> filterWhere (#candidateId, requirementCandidateId)
|> fetchOneOrNothing
users <- query @User |> fetch
mSourceAnnotation <- case candidate.sourceAnnotationId of
Nothing -> pure Nothing
Just aid -> fetchOneOrNothing aid
mSourceThread <- case candidate.sourceThreadId of
Nothing -> pure Nothing
Just tid -> fetchOneOrNothing tid
render ShowView { candidate, widget, triageStates, mAssignment, users, mSourceAnnotation, mSourceThread }
action NewRequirementCandidateAction = do
widgets <- query @Widget |> fetch
threads <- query @AnnotationThread |> fetch
let candidate = newRecord @RequirementCandidate
render NewView { candidate, widgets, threads }
action CreateRequirementCandidateAction = do
widgets <- query @Widget |> fetch
threads <- query @AnnotationThread |> fetch
mUser <- currentUserOrNothing
let createdBy = fmap (.id) mUser
let candidate = newRecord @RequirementCandidate
candidate
|> fill @'["title", "description", "sourceWidgetId", "sourceThreadId", "category"]
|> set #status "open"
|> set #createdBy (fmap (Id . unId) createdBy)
|> validateField #title nonEmpty
|> validateField #description nonEmpty
|> validateField #category (`elem` validCategories)
|> ifValid \case
Left candidate -> render NewView { candidate, widgets, threads }
Right candidate -> do
created <- createRecord candidate
setSuccessMessage "Requirement candidate created"
redirectTo ShowRequirementCandidateAction { requirementCandidateId = created.id }
action EditRequirementCandidateAction { requirementCandidateId } = do
candidate <- fetch requirementCandidateId
widgets <- query @Widget |> fetch
threads <- query @AnnotationThread |> fetch
render EditView { candidate, widgets, threads }
action UpdateRequirementCandidateAction { requirementCandidateId } = do
candidate <- fetch requirementCandidateId
widgets <- query @Widget |> fetch
threads <- query @AnnotationThread |> fetch
candidate
|> fill @'["title", "description", "sourceWidgetId", "sourceThreadId", "category"]
|> validateField #title nonEmpty
|> validateField #description nonEmpty
|> validateField #category (`elem` validCategories)
|> ifValid \case
Left candidate -> render EditView { candidate, widgets, threads }
Right candidate -> do
updateRecord candidate
setSuccessMessage "Candidate updated"
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
action UpdateTriageStatusAction { requirementCandidateId } = do
candidate <- fetch requirementCandidateId
newStatus <- param @Text "status"
notes <- paramOrNothing @Text "notes"
mUser <- currentUserOrNothing
let changedBy = fmap (.id) mUser
if allowedTransition candidate.status newStatus
then do
-- Insert triage state row (append-only audit trail)
newRecord @TriageState
|> set #candidateId requirementCandidateId
|> set #status newStatus
|> set #notes notes
|> set #changedBy (fmap (Id . unId) changedBy)
|> createRecord
-- Update current status on candidate
candidate
|> set #status newStatus
|> updateRecord
setSuccessMessage ("Status updated to " <> newStatus)
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
else do
setErrorMessage ("Invalid transition: " <> candidate.status <> " → " <> newStatus)
respondWith 422 do
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
action AssignReviewerAction { requirementCandidateId } = do
userId <- param @(Id User) "userId"
mUser <- currentUserOrNothing
let assignedBy = fmap (.id) mUser
-- Upsert: delete existing assignment then insert
existing <- query @ReviewerAssignment
|> filterWhere (#candidateId, requirementCandidateId)
|> fetchOneOrNothing
case existing of
Just ra -> deleteRecord ra
Nothing -> pure ()
newRecord @ReviewerAssignment
|> set #candidateId requirementCandidateId
|> set #userId userId
|> set #assignedBy (fmap (Id . unId) assignedBy)
|> createRecord
setSuccessMessage "Reviewer assigned"
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
action MyQueueAction = do
mUser <- currentUserOrNothing
case mUser of
Nothing -> redirectTo RequirementCandidatesAction
Just user -> do
assignments <- query @ReviewerAssignment
|> filterWhere (#userId, user.id)
|> fetch
let candidateIds = map (.candidateId) assignments
candidates <- mapM fetch candidateIds
let active = filter (\c -> c.status `elem` ["open", "in_review"]) candidates
widgets <- query @Widget |> fetch
render IndexView
{ candidates = active
, assignments
, users = [user]
, widgets
, mStatusFilter = Just "my_queue"
}