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

fix: resolve all GHC 9.10.3 / IHP 1.5 compile errors (all 616 modules load)
Some checks failed
Test / test (push) Has been cancelled
Details

Browse Source 
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>
This commit is contained in:
Bernd Worsch
2026-04-29 10:46:50 +02:00
parent 209c77dd31
commit 2106000cc7
13 changed files with 71 additions and 130 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
Web/Controller/AdaptiveThresholds.hs
View File

@@ -27,7 +27,7 @@ instance Controller AdaptiveThresholdsController where
weakCats <- sqlQuery
"SELECT annotation_category FROM outcome_correlations \
\ WHERE hub_id = ? AND correlation_score < 0.3"
[hubId]
(Only hubId)
:: IO [Only Text]
-- Step 2: compute bottleneck threshold override = mean friction score
@@ -46,7 +46,7 @@ instance Controller AdaptiveThresholdsController where
\ WHERE rc.source_widget_id = w.id \
\ AND os.signal_type NOT IN ('success','adoption','satisfaction') \
\ )"
[hubId]
(Only hubId)
:: IO [Only (Maybe Double)]
now <- getCurrentTime

4
Web/Controller/AgentDelegations.hs
View File

@@ -10,7 +10,7 @@ import qualified Data.Aeson as A
import Application.Helper.AgentBridge
( callAgentWithBudget
, BridgeError(..)
, BridgeResponse
, BridgeResponse(..)
, bridgeErrorMessage
)
@@ -38,7 +38,7 @@ instance Controller AgentDelegationsController where
tokenBudget = paramOrDefault @Int 1000 "tokenBudget"
delegatingAgentId <- case (proposal.agentRegistrationId :: Maybe (Id AgentRegistration)) of
Just aid -> pure aid
Nothing -> respondAndExit =<< renderNotFound
Nothing -> renderNotFound >> error "unreachable"
receivingAgent <- fetch receivingAgentId

1
Web/Controller/AgentRegistrations.hs
View File

@@ -107,6 +107,7 @@ instance Controller AgentRegistrationsController where
\ WHERE ap.agent_registration_id = ? \
\ AND ap.created_at >= NOW() - INTERVAL '30 days'"
(Only agentRegistrationId)
:: IO [(Int, Int, Int, Int, Maybe Double)]
case rows of
[(accepted, rejected, _other, total, mConf)] -> do
now <- getCurrentTime

2
Web/Controller/Annotations.hs
View File

@@ -56,7 +56,7 @@ instance Controller AnnotationsController where
|> set #actorId (fmap coerce actorId)
|> set #actorType actorType
|> validateField #body nonEmpty
|> validateField #severity (`elem` validSeverities)
|> validateField #severity (isInList validSeverities)
|> (case categoryResult of
Left msg -> attachFailure #category msg
Right () -> \x -> x)

71
Web/Controller/DecisionRecords.hs
View File

@@ -8,9 +8,8 @@ import Web.View.DecisionRecords.Edit
import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
import Application.Helper.AgentBridge (callAgent, checkGovernancePolicy, bridgeErrorMessage, BridgeResponse)
import Application.Helper.AgentBridge (callAgent, checkGovernancePolicy, bridgeErrorMessage, BridgeResponse(..))
import Application.Helper.ModelRouter (resolveAgent)
import Data.List (intercalate)
import IHP.ModelSupport (sqlQuery)
import qualified Data.Aeson as A
import Data.Coerce (coerce)
@@ -95,7 +94,7 @@ instance Controller DecisionRecordsController where
|> set #decidedBy (fmap coerce decidedBy)
|> validateField #title nonEmpty
|> validateField #rationale nonEmpty
|> validateField #outcome (`elem` validOutcomes)
|> validateField #outcome (isInList validOutcomes)
|> ifValid \case
Left record -> render NewView { record, requirements, candidates, users }
Right record -> do
@@ -188,10 +187,14 @@ instance Controller DecisionRecordsController where
mRequirement <- case record.requirementId of
Nothing -> pure Nothing
Just rid -> fetchOneOrNothing rid
-- Resolve hub from the source widget via requirement candidate
mHubId <- case mRequirement >>= (.sourceWidgetId) of
-- Resolve hub via the decision's linked candidate → source widget
mHubId <- case record.candidateId of
Nothing -> pure Nothing
Just wid -> fmap (.hubId) <$> fetchOneOrNothing @Widget wid
Just cid -> do
mCand <- fetchOneOrNothing cid
case mCand of
Nothing -> pure Nothing
Just cand -> fmap (.hubId) <$> fetchOneOrNothing cand.sourceWidgetId
let implLines = map (\r -> r.system <> ": " <> r.workItemRef) implRefs
reqDesc = maybe "" (.description) mRequirement
userMsg = "Decision: " <> record.title
@@ -243,59 +246,3 @@ instance Controller DecisionRecordsController where
setSuccessMessage "Implementation proposal created"
redirectTo ShowDecisionRecordAction { decisionRecordId }
-- T05 / Phase 12: Distil decision into institutional knowledge entry
action DistilDecisionAction { decisionRecordId } = do
record <- fetch decisionRecordId
outcomes <- sqlQuery
"SELECT os.signal_type, os.value FROM outcome_signals os \
\ JOIN deployment_records dep ON dep.id = os.deployment_id \
\ WHERE dep.decision_id = ?"
[decisionRecordId]
:: IO [(Text, Maybe Double)]
let signalText = intercalate ", " $
map (\(st, mv) -> st <> maybe "" (\v -> "=" <> show v) mv) outcomes
prompt = "Distil this decision into a 2-3 sentence institutional knowledge entry. "
<> "Include the outcome data.\n\nDecision: " <> record.title
<> "\nRationale: " <> record.rationale
<> "\nOutcome: " <> record.outcome
<> "\nSignals: " <> signalText
-- Resolve hub from requirement chain
mHubId <- case record.requirementId of
Nothing -> pure Nothing
Just rid -> do
mReq <- fetchOneOrNothing rid
pure $ case mReq >>= (.sourceWidgetId) of
Nothing -> Nothing
Just _ -> Nothing -- hub resolution via widget lookup below
mHubIdResolved <- case record.requirementId of
Nothing -> pure Nothing
Just rid -> do
mReq <- fetchOneOrNothing rid
case mReq >>= (.sourceWidgetId) of
Nothing -> pure Nothing
Just wid -> fmap (.hubId) <$> fetchOneOrNothing @Widget wid
case mHubIdResolved of
Nothing -> do
setErrorMessage "Cannot resolve hub — ensure decision has a linked requirement with a source widget"
redirectTo ShowDecisionRecordAction { decisionRecordId }
Just hubId -> do
mAgent <- resolveAgent hubId "synthesis"
case mAgent of
Nothing -> do
setErrorMessage "No routing policy for 'synthesis' task type"
redirectTo ShowDecisionRecordAction { decisionRecordId }
Just agent -> do
result <- liftIO $ callAgent agent prompt
case result of
Left err -> do
setErrorMessage ("Distillation failed: " <> bridgeErrorMessage err)
redirectTo ShowDecisionRecordAction { decisionRecordId }
Right resp -> do
newRecord @InstitutionalKnowledgeEntry
|> set #hubId hubId
|> set #decisionRecordId (Just decisionRecordId)
|> set #summary resp.content
|> set #tags (A.toJSON ["decision" :: Text])
|> createRecord
setSuccessMessage "Knowledge entry created"
redirectTo ShowDecisionRecordAction { decisionRecordId }

3
Web/Controller/DeploymentRecords.hs
View File

@@ -11,6 +11,7 @@ import Data.Time.Clock (addUTCTime, NominalDiffTime)
import Text.Read (readMaybe)
import Data.String.Conversions (cs)
import Data.Coerce (coerce)
import Data.Scientific (Scientific)
instance Controller DeploymentRecordsController where
beforeAction = ensureIsUser
@@ -88,7 +89,7 @@ instance Controller DeploymentRecordsController where
action RecordOutcomeSignalAction { deploymentRecordId } = do
let signalType = param @Text "signalType"
mValue = paramOrNothing @Double "value"
mValue = fmap realToFrac (paramOrNothing @Double "value") :: Maybe Scientific
mUser = currentUserOrNothing
let validTypes = ["improved", "regressed", "neutral", "inconclusive"] :: [Text]
unless (signalType `elem` validTypes) do

16
Web/Controller/GovernanceTemplates.hs
View File

@@ -10,20 +10,20 @@ import IHP.ControllerPrelude
import Data.Aeson (Value(..), decode, encode, toJSON)
import qualified Data.ByteString.Lazy as LBS
import Data.Text (intercalate)
import qualified Data.Map.Strict as Map
instance Controller GovernanceTemplatesController where
beforeAction = ensureIsUser
-- List published templates with clone count
action GovernanceTemplatesAction = autoRefresh do
templates <- sqlQuery
"SELECT gt.*, COUNT(gtc.id) AS clone_count \
\ FROM governance_templates gt \
\ LEFT JOIN governance_template_clones gtc ON gtc.governance_template_id = gt.id \
\ WHERE gt.is_published = TRUE \
\ GROUP BY gt.id \
\ ORDER BY clone_count DESC, gt.name ASC"
()
rawTemplates <- query @GovernanceTemplate
|> filterWhere (#isPublished, True)
|> orderByAsc #name
|> fetch
allClones <- query @GovernanceTemplateClone |> fetch
let countMap = foldr (\c m -> Map.insertWith (+) c.governanceTemplateId 1 m) Map.empty allClones
templates = map (\t -> (t, Map.findWithDefault 0 t.id countMap)) rawTemplates
render IndexView { templates }
-- Template detail with clone count

23
Web/Controller/HubCapabilityManifests.hs
View File

@@ -8,9 +8,10 @@ import Web.View.HubCapabilityManifests.Edit
import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
import Data.Aeson (Value, Array, decode, encode)
import Data.Aeson (Value, Array, decode, encode, toJSON)
import qualified Data.Vector as V
import Data.Maybe (mapMaybe)
import Control.Monad (void)
instance Controller HubCapabilityManifestsController where
beforeAction = ensureIsUser
@@ -76,9 +77,11 @@ instance Controller HubCapabilityManifestsController where
setErrorMessage "Active manifests are read-only. Retire the current manifest and create a new draft to amend."
redirectTo ShowHubCapabilityManifestAction { hubCapabilityManifestId }
manifest
|> fill @'["manifestVersion", "capabilityDescription", "contact",
"declaredWidgetTypes", "declaredEventTypes",
"declaredAnnotationCategories", "declaredPolicyScopes"]
|> fill @'["manifestVersion", "capabilityDescription", "contact"]
|> set #declaredWidgetTypes (toJSON (paramList @Text "declaredWidgetTypes"))
|> set #declaredEventTypes (toJSON (paramList @Text "declaredEventTypes"))
|> set #declaredAnnotationCategories (toJSON (paramList @Text "declaredAnnotationCategories"))
|> set #declaredPolicyScopes (toJSON (paramList @Text "declaredPolicyScopes"))
|> ifValid \case
Left manifest -> render EditView { manifest, hub, widgetTypeEntries, eventTypeEntries, categoryEntries, policyScopeEntries }
Right manifest -> do
@@ -142,7 +145,7 @@ checkConflict ::
Text -> Id Hub -> Text -> IO [Text]
checkConflict tableName hubId name = do
rows <- sqlQuery
("SELECT owner_hub_id FROM " <> tableName <> " WHERE name = ?")
(fromString $ cs ("SELECT owner_hub_id FROM " <> tableName <> " WHERE name = ?"))
(Only name)
case rows of
[] -> pure []
@@ -158,12 +161,8 @@ upsertType ::
(?modelContext :: ModelContext) =>
Text -> Id Hub -> Text -> IO ()
upsertType tableName hubId name =
sqlExec
("INSERT INTO " <> tableName <> " (name, label, owner_hub_id, status) "
<> "VALUES (?, ?, ?, 'active') ON CONFLICT (name) DO NOTHING")
void $ sqlExec
(fromString $ cs ("INSERT INTO " <> tableName <> " (name, label, owner_hub_id, status) "
<> "VALUES (?, ?, ?, 'active') ON CONFLICT (name) DO NOTHING"))
(name, name, hubId)
intercalate :: Text -> [Text] -> Text
intercalate _ [] = ""
intercalate _ [x] = x
intercalate sep (x:xs) = x <> sep <> intercalate sep xs

25
Web/Controller/Hubs.hs
View File

@@ -39,13 +39,17 @@ instance Controller HubsController where
|> filterWhere (#hubId, hubId)
|> orderByAsc #name
|> fetch
widgetIds <- pure (map (.id) widgets)
recentEvents <- sqlQuery
"SELECT * FROM interaction_events WHERE widget_id = ANY(?) ORDER BY occurred_at DESC LIMIT 50"
(Only (PGArray widgetIds))
recentAnnotations <- sqlQuery
"SELECT * FROM annotations WHERE widget_id = ANY(?) ORDER BY created_at DESC LIMIT 20"
(Only (PGArray widgetIds))
let widgetIds = map (.id) widgets
recentEvents <- query @InteractionEvent
|> filterWhereIn (#widgetId, widgetIds)
|> orderByDesc #occurredAt
|> limit 50
|> fetch
recentAnnotations <- query @Annotation
|> filterWhereIn (#widgetId, widgetIds)
|> orderByDesc #createdAt
|> limit 20
|> fetch
mManifest <- query @HubCapabilityManifest
|> filterWhere (#hubId, hubId)
|> fetchOneOrNothing
@@ -58,7 +62,7 @@ instance Controller HubsController where
|> validateField #slug nonEmpty
|> validateField #name nonEmpty
|> validateField #domain nonEmpty
|> validateField #hubKind (`elem` ["domain", "shared"])
|> validateField #hubKind (isInList ["domain", "shared"])
-- 'framework' cannot be set via the UI
|> ifValid \case
Left hub -> render NewView { hub }
@@ -78,7 +82,7 @@ instance Controller HubsController where
|> validateField #slug nonEmpty
|> validateField #name nonEmpty
|> validateField #domain nonEmpty
|> validateField #hubKind (`elem` ["framework", "domain", "shared"])
|> validateField #hubKind (isInList ["framework", "domain", "shared"])
|> ifValid \case
Left hub -> render EditView { hub }
Right hub -> do
@@ -265,8 +269,7 @@ instance Controller HubsController where
widgets <- query @Widget |> filterWhere (#hubId, hubId) |> fetch
let widgetIds = map (.id) widgets
annotations <- query @Annotation |> filterWhereIn (#widgetId, widgetIds) |> fetch
events <- sqlQuery "SELECT * FROM interaction_events WHERE widget_id = ANY(?)"
(Only (PGArray widgetIds))
events <- query @InteractionEvent |> filterWhereIn (#widgetId, widgetIds) |> fetch
signals <- query @OutcomeSignal |> filterWhereIn (#widgetId, widgetIds) |> fetch
candidates <- query @RequirementCandidate |> filterWhereIn (#sourceWidgetId, widgetIds) |> fetch
let regressionWids = regressedWidgetIds signals annotations

29
Web/Controller/RequirementCandidates.hs
View File

@@ -8,7 +8,7 @@ import Web.View.RequirementCandidates.Edit
import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
import Application.Helper.AgentBridge (callAgent, checkGovernancePolicy, bridgeErrorMessage, BridgeResponse)
import Application.Helper.AgentBridge (callAgent, checkGovernancePolicy, bridgeErrorMessage, BridgeResponse(..))
import Application.Helper.ModelRouter (resolveAgent)
import Data.Aeson (decode, Value(..), Array)
import Data.Aeson.Lens (key, _String)
@@ -18,6 +18,7 @@ import Web.Job.WebhookDeliveryJob (dispatchWebhooks)
import Control.Concurrent (forkIO)
import Control.Monad (void)
import Data.Coerce (coerce)
import Data.Scientific (Scientific)
import Data.Aeson ((.=), object)
import Data.Text.Encoding (encodeUtf8)
import Data.HashMap.Strict (HashMap)
@@ -95,7 +96,7 @@ instance Controller RequirementCandidatesController where
|> set #createdBy (fmap coerce createdBy)
|> validateField #title nonEmpty
|> validateField #description nonEmpty
|> validateField #category (`elem` validCategories)
|> validateField #category (isInList validCategories)
|> ifValid \case
Left candidate -> render NewView { candidate, widgets, threads }
Right candidate -> do
@@ -127,7 +128,7 @@ instance Controller RequirementCandidatesController where
|> fill @'["title", "description", "sourceWidgetId", "sourceThreadId", "category"]
|> validateField #title nonEmpty
|> validateField #description nonEmpty
|> validateField #category (`elem` validCategories)
|> validateField #category (isInList validCategories)
|> ifValid \case
Left candidate -> render EditView { candidate, widgets, threads }
Right candidate -> do
@@ -260,10 +261,8 @@ instance Controller RequirementCandidatesController where
action DetectDuplicatesAction { requirementCandidateId } = do
target <- fetch requirementCandidateId
others <- query @RequirementCandidate |> fetch
-- Resolve hub from the source widget
mHubId <- case target.sourceWidgetId of
Nothing -> pure Nothing
Just wid -> fmap (.hubId) <$> fetchOneOrNothing @Widget wid
-- Resolve hub from the source widget (sourceWidgetId is non-nullable)
mHubId <- fmap (.hubId) <$> fetchOneOrNothing target.sourceWidgetId
let otherLines = map (\c -> show c.id <> " | " <> c.title <> ": " <> c.description)
(filter (\c -> c.id /= requirementCandidateId) others)
targetLine = "TARGET: " <> target.title <> ": " <> target.description
@@ -315,13 +314,9 @@ instance Controller RequirementCandidatesController where
-- T06: Detect policy sensitivity via routed agent
action DetectPolicySensitivityAction { requirementCandidateId } = do
candidate <- fetch requirementCandidateId
mWidget <- case candidate.sourceWidgetId of
Nothing -> pure Nothing
Just wid -> fetchOneOrNothing wid
-- Resolve hub for routing
mHubId <- case candidate.sourceWidgetId of
Nothing -> pure Nothing
Just wid -> fmap (.hubId) <$> fetchOneOrNothing @Widget wid
-- sourceWidgetId is non-nullable; fetchOneOrNothing handles missing widget
mWidget <- fetchOneOrNothing candidate.sourceWidgetId
mHubId <- fmap (.hubId) <$> fetchOneOrNothing candidate.sourceWidgetId
let policyCtx = maybe "unknown" (.policyScope) mWidget
userMsg = "Title: " <> candidate.title
<> "\nDescription: " <> candidate.description
@@ -358,7 +353,7 @@ instance Controller RequirementCandidatesController where
setErrorMessage ("Policy check failed: " <> bridgeErrorMessage err)
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
Right resp -> do
let confidenceScore = extractSeverityScore resp.content
let confidenceScore = realToFrac (extractSeverityScore resp.content) :: Scientific
proposal <- newRecord @AgentProposal
|> set #proposalType "policy_flag"
|> set #sourceCandidateId (Just requirementCandidateId)
@@ -379,10 +374,10 @@ instance Controller RequirementCandidatesController where
case (concern ^? key "scope" . _String
,concern ^? key "note" . _String) of
(Just scope, noteM) ->
newRecord @ConfidenceAnnotation
void $ newRecord @ConfidenceAnnotation
|> set #proposalId proposal.id
|> set #dimension scope
|> set #score confidenceScore
|> set #score (confidenceScore :: Scientific)
|> set #explanation noteM
|> createRecord
_ -> pure ()

2
Web/Controller/Widgets.hs
View File

@@ -11,7 +11,7 @@ import IHP.ControllerPrelude
import Data.Aeson (toJSON, object, (.=))
import Application.Helper.Controller (isInRegression, widgetCycleCounts)
import Application.Helper.TypeRegistry (validateWidgetType, validatePolicyScope, activeWidgetTypes, activePolicyScopes)
import Application.Helper.AgentBridge (callAgent, checkGovernancePolicy, bridgeErrorMessage, BridgeResponse)
import Application.Helper.AgentBridge (callAgent, checkGovernancePolicy, bridgeErrorMessage, BridgeResponse(..))
import Application.Helper.ModelRouter (resolveAgent)
instance Controller WidgetsController where

15
Web/FrontController.hs
View File

@@ -2,11 +2,11 @@ module Web.FrontController where
import IHP.RouterPrelude
import IHP.LoginSupport.Middleware
import IHP.ControllerPrelude (getAppConfig)
import IHP.ControllerPrelude
import IHP.ViewPrelude (Html, hsx, Layout, autoRefreshMeta)
import Generated.Types
import Web.Types
import Web.Routes ()
import Config (AnnotationLauncherEnabled (..))
-- Controllers
import Web.Controller.Hubs ()
@@ -146,14 +146,7 @@ instance InitControllerContext WebApplication where
setLayout defaultLayout
initAuthentication @User
annotationLauncherScript :: (?context :: ControllerContext) => Html
annotationLauncherScript =
let AnnotationLauncherEnabled enabled = getAppConfig @AnnotationLauncherEnabled
in if enabled
then [hsx|<script src="/js/ihf-annotation-launcher.js"></script>|]
else mempty
defaultLayout :: Layout
defaultLayout :: (?context :: ControllerContext, ?request :: Request) => Layout
defaultLayout inner = [hsx|
<!DOCTYPE html>
<html lang="en">
@@ -165,7 +158,7 @@ defaultLayout inner = [hsx|
<link rel="stylesheet" href="/app.css" />
<script src="/vendor/morphdom.js"></script>
<script src="/vendor/ihp-auto-refresh.js"></script>
{annotationLauncherScript}
<script src="/js/ihf-annotation-launcher.js"></script>
</head>
<body class="bg-gray-50 text-gray-900">
<nav class="bg-white border-b border-gray-200 px-6 py-3 flex items-center gap-6">

6
Web/View/DecisionRecords/Edit.hs
View File

@@ -15,7 +15,9 @@ data EditView = EditView
}
instance View EditView where
html EditView { .. } = [hsx|
html EditView { .. } =
let formAction = UpdateDecisionRecordAction { decisionRecordId = record.id }
in [hsx|
<div class="mb-6 flex items-center gap-2 text-sm text-gray-500">
<a href={DecisionRecordsAction} class="hover:text-gray-700">Decisions</a>
<span>/</span>
@@ -30,6 +32,6 @@ instance View EditView where
<p class="text-sm text-amber-600 mb-6">
Note: outcome is immutable and cannot be changed here.
</p>
{renderForm record requirements candidates users (UpdateDecisionRecordAction { decisionRecordId = record.id })}
{renderForm record requirements candidates users formAction}
</div>
|]