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

fix(WP-0014/A2): close remaining pure-param and structural compilation errors

Browse Source 
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>
This commit is contained in:
Bernd Worsch
2026-04-10 01:14:08 +00:00
parent 5510ae22da
commit ce42607fca
85 changed files with 584 additions and 397 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
Web/Controller/AgentDelegations.hs
View File

@@ -31,9 +31,9 @@ instance Controller AgentDelegationsController where
action DelegateSubtaskAction { agentProposalId } = do
proposal <- fetch agentProposalId
receivingAgentId <- param @(Id AgentRegistration) "receivingAgentId"
scope <- param @Text "scope"
tokenBudget <- paramOrDefault @Int 1000 "tokenBudget"
let receivingAgentId = param @(Id AgentRegistration) "receivingAgentId"
scope = param @Text "scope"
tokenBudget = paramOrDefault @Int 1000 "tokenBudget"
delegatingAgentId <- case proposal.agentRegistrationId of
Just aid -> pure aid
Nothing -> respondAndExit =<< renderNotFound

26
Web/Controller/AgentProposals.hs
View File

@@ -16,8 +16,8 @@ instance Controller AgentProposalsController where
beforeAction = ensureIsUser
action AgentProposalsAction = do
mTypeFilter <- paramOrNothing @Text "proposal_type"
mStatusFilter <- paramOrNothing @Text "status"
let mTypeFilter = paramOrNothing @Text "proposal_type"
mStatusFilter = paramOrNothing @Text "status"
proposals <- case (mTypeFilter, mStatusFilter) of
(Nothing, Nothing) ->
query @AgentProposal |> orderByDesc #createdAt |> fetch
@@ -70,15 +70,15 @@ instance Controller AgentProposalsController where
setSuccessMessage "Already reviewed"
redirectTo ShowAgentProposalAction { agentProposalId }
Nothing -> do
mUser <- currentUserOrNothing
let mUser = currentUserOrNothing
let reviewerId = fmap (.id) mUser
proposal
|> set #status "accepted"
|> updateRecord
notes <- paramOrNothing @Text "notes"
let notes = paramOrNothing @Text "notes"
newRecord @AgentReviewRecord
|> set #proposalId agentProposalId
|> set #reviewerId (fmap (Id . unId) reviewerId)
|> set #reviewerId (reviewerId)
|> set #decision "accepted"
|> set #notes notes
|> createRecord
@@ -86,20 +86,20 @@ instance Controller AgentProposalsController where
when (proposal.proposalType == "requirement_draft") do
let mParsed = decode (fromStrict (encodeUtf8 proposal.content))
:: Maybe (HashMap Text Text)
case mParsed of
Just m -> do
case (mParsed, proposal.sourceWidgetId) of
(Just m, Just srcWid) -> do
let title = fromMaybe "AI Draft" (HashMap.lookup "title" m)
desc = fromMaybe "" (HashMap.lookup "description" m)
newRecord @RequirementCandidate
|> set #title title
|> set #description desc
|> set #sourceWidgetId proposal.sourceWidgetId
|> set #sourceWidgetId srcWid
|> set #category "friction"
|> set #status "open"
|> createRecord
setSuccessMessage "Requirement candidate created from AI draft"
Nothing ->
setSuccessMessage "Proposal accepted (could not parse JSON for candidate)"
_ ->
setSuccessMessage "Proposal accepted (could not create candidate)"
redirectTo ShowAgentProposalAction { agentProposalId }
action RejectProposalAction { agentProposalId } = do
@@ -112,15 +112,15 @@ instance Controller AgentProposalsController where
setSuccessMessage "Already reviewed"
redirectTo ShowAgentProposalAction { agentProposalId }
Nothing -> do
mUser <- currentUserOrNothing
let mUser = currentUserOrNothing
let reviewerId = fmap (.id) mUser
proposal
|> set #status "rejected"
|> updateRecord
notes <- paramOrNothing @Text "notes"
let notes = paramOrNothing @Text "notes"
newRecord @AgentReviewRecord
|> set #proposalId agentProposalId
|> set #reviewerId (fmap (Id . unId) reviewerId)
|> set #reviewerId (reviewerId)
|> set #decision "rejected"
|> set #notes notes
|> createRecord

2
Web/Controller/AiGovernancePolicies.hs
View File

@@ -40,7 +40,7 @@ instance Controller AiGovernancePoliciesController where
action CreateAiGovernancePolicyAction = do
-- Collect allowed_actions from checkbox params
selectedActions <- paramList @Text "allowedActions"
let selectedActions = paramList @Text "allowedActions"
let actionsJson = A.toJSON selectedActions
let policy = newRecord @AiGovernancePolicy
|> set #allowedActions actionsJson

6
Web/Controller/AnnotationThreads.hs
View File

@@ -39,14 +39,14 @@ instance Controller AnnotationThreadsController where
action CreateAnnotationThreadAction { widgetId } = do
widget <- fetch widgetId
mUser <- currentUserOrNothing
let mUser = currentUserOrNothing
let createdBy = fmap (.id) mUser
let thread = newRecord @AnnotationThread
thread
|> fill @'["title", "description"]
|> set #widgetId widgetId
|> set #createdBy (fmap (Id . unId) createdBy)
|> set #createdBy createdBy
|> validateField #title nonEmpty
|> ifValid \case
Left thread -> render NewView { widget, thread }
@@ -57,7 +57,7 @@ instance Controller AnnotationThreadsController where
action AssignAnnotationToThreadAction { annotationId } = do
annotation <- fetch annotationId
threadId <- param @(Id AnnotationThread) "threadId"
let threadId = param @(Id AnnotationThread) "threadId"
annotation
|> set #threadId (Just threadId)
|> updateRecord

11
Web/Controller/Annotations.hs
View File

@@ -41,11 +41,10 @@ instance Controller AnnotationsController where
action CreateAnnotationAction { widgetId } = do
widget <- fetch widgetId
categories <- activeAnnotationCategories
mUser <- currentUserOrNothing
let actorId = fmap (.id) mUser
let mUser = currentUserOrNothing
actorId = fmap (.id) mUser
actorType = maybe "anonymous" (const "user") mUser
category <- paramOrDefault @Text "" "category"
category = paramOrDefault @Text "" "category"
categoryResult <- validateAnnotationCategory category
let annotation = newRecord @Annotation
@@ -68,8 +67,8 @@ instance Controller AnnotationsController where
action EscalateAnnotationAction { annotationId } = do
annotation <- fetch annotationId
mUser <- currentUserOrNothing
let createdBy = fmap (.id) mUser
let mUser = currentUserOrNothing
createdBy = fmap (.id) mUser
-- Idempotent: check if already escalated
existing <- query @RequirementCandidate
|> filterWhere (#sourceAnnotationId, Just annotationId)

14
Web/Controller/Api/V2/Annotations.hs
View File

@@ -9,14 +9,15 @@ import Web.Controller.Api.V2.Auth
( requireApiConsumer, paginatedResponse, getPageParams
, respondWithStatus )
import Application.Helper.TypeRegistry (validateAnnotationCategory)
import qualified Data.UUID as UUID
instance Controller ApiV2AnnotationsController where
action ApiV2IndexAnnotationsAction = do
_consumer <- requireApiConsumer
(page, perPage) <- getPageParams
mWidgetId <- paramOrNothing @(Id Widget) "widgetId"
mCategory <- paramOrNothing @Text "category"
let mWidgetId = paramOrNothing @(Id Widget) "widgetId"
mCategory = paramOrNothing @Text "category"
let off = (page - 1) * perPage
let baseQ = query @Annotation |> orderByDesc #createdAt
let q1 = case mWidgetId of
@@ -37,9 +38,9 @@ instance Controller ApiV2AnnotationsController where
-- POST /api/v2/annotations
action ApiV2CreateAnnotationAction = do
_consumer <- requireApiConsumer
widgetIdText <- paramOrNothing @Text "widgetId"
category <- paramOrNothing @Text "category"
body <- paramOrNothing @Text "body"
let widgetIdText = paramOrNothing @Text "widgetId"
category = paramOrNothing @Text "category"
body = paramOrNothing @Text "body"
let missing = catMaybes
[ if isNothing widgetIdText then Just ("widgetId" :: Text) else Nothing
@@ -66,7 +67,7 @@ instance Controller ApiV2AnnotationsController where
]
Right () -> pure ()
case readMay wIdText of
case UUID.fromText wIdText of
Nothing -> respondWithStatus 422 $ object
["error" .= ("widgetId must be a valid UUID" :: Text)]
Just rawId -> do
@@ -82,7 +83,6 @@ instance Controller ApiV2AnnotationsController where
|> set #body bodyTxt
|> set #actorType "api"
|> createRecord
setStatus 201
renderJson (annotationToJson ann)
annotationToJson :: Annotation -> Value

7
Web/Controller/Api/V2/Auth.hs
View File

@@ -57,6 +57,7 @@ respondWithStatus status body = do
(toEnum status)
[("Content-Type", "application/json")]
(encode body)
error "respondAndExit: unreachable"
-- | SHA-256 hex hash of the key (same as stored in key_hash column)
hashApiKey :: Text -> Text
@@ -78,10 +79,10 @@ paginatedResponse items page perPage total =
]
-- | Parse page / per_page query params with sensible defaults
getPageParams :: (?context :: ControllerContext) => IO (Int, Int)
getPageParams :: (?context :: ControllerContext, ?request :: Request) => IO (Int, Int)
getPageParams = do
page <- fromMaybe 1 <$> paramOrNothing @Int "page"
perPage <- fromMaybe 50 <$> paramOrNothing @Int "per_page"
let page = fromMaybe 1 (paramOrNothing @Int "page")
perPage = fromMaybe 50 (paramOrNothing @Int "per_page")
let perPage' = min 200 (max 1 perPage)
let page' = max 1 page
pure (page', perPage')

3
Web/Controller/Api/V2/HubRegistry.hs
View File

@@ -8,7 +8,8 @@ import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
import Data.Aeson (object, (.=), Value)
import Web.Controller.Api.V2.Auth (requireApiConsumer, checkRateLimitAndLog)
import Web.Controller.Api.V2.Auth (requireApiConsumer)
import Application.Helper.ApiRateLimit (checkRateLimitAndLog)
instance Controller ApiV2HubRegistryController where

15
Web/Controller/Api/V2/InteractionEvents.hs
View File

@@ -12,6 +12,8 @@ import Web.Controller.Api.V2.Auth
import Application.Helper.TypeRegistry (validateEventType)
import Web.Job.WebhookDeliveryJob (dispatchWebhooks)
import Control.Concurrent (forkIO)
import Control.Monad (void)
import qualified Data.UUID as UUID
import qualified Data.Aeson as A
instance Controller ApiV2InteractionEventsController where
@@ -19,8 +21,8 @@ instance Controller ApiV2InteractionEventsController where
action ApiV2IndexInteractionEventsAction = do
_consumer <- requireApiConsumer
(page, perPage) <- getPageParams
mWidgetId <- paramOrNothing @(Id Widget) "widgetId"
mEventType <- paramOrNothing @Text "eventType"
let mWidgetId = paramOrNothing @(Id Widget) "widgetId"
mEventType = paramOrNothing @Text "eventType"
let off = (page - 1) * perPage
let baseQ = query @InteractionEvent
|> orderByDesc #occurredAt
@@ -42,9 +44,9 @@ instance Controller ApiV2InteractionEventsController where
-- POST /api/v2/interaction-events
action ApiV2CreateInteractionEventAction = do
consumer <- requireApiConsumer
widgetIdText <- paramOrNothing @Text "widgetId"
eventType <- paramOrNothing @Text "eventType"
viewContext <- paramOrNothing @Text "viewContext"
let widgetIdText = paramOrNothing @Text "widgetId"
eventType = paramOrNothing @Text "eventType"
viewContext = paramOrNothing @Text "viewContext"
let missing = catMaybes
[ if isNothing widgetIdText then Just ("widgetId" :: Text) else Nothing
@@ -83,7 +85,7 @@ instance Controller ApiV2InteractionEventsController where
, "value" .= evType
]
case readMay wIdText of
case UUID.fromText wIdText of
Nothing -> respondWithStatus 422 $ object
["error" .= ("widgetId must be a valid UUID" :: Text)]
Just rawId -> do
@@ -108,7 +110,6 @@ instance Controller ApiV2InteractionEventsController where
, "occurredAt" .= event.occurredAt
]
liftIO $ void $ forkIO $ dispatchWebhooks "clicked" webhookPayload
setStatus 201
renderJson (eventToJson event)
eventToJson :: InteractionEvent -> Value

6
Web/Controller/Api/V2/Learning.hs
View File

@@ -14,8 +14,8 @@ instance Controller ApiV2LearningController where
action ApiV2IndexOutcomeCorrelationsAction = do
_consumer <- requireApiConsumer
mHubId <- paramOrNothing @(Id Hub) "hub_id"
mCat <- paramOrNothing @Text "category"
let mHubId = paramOrNothing @(Id Hub) "hub_id"
mCat = paramOrNothing @Text "category"
(page, perPage) <- getPageParams
let off = (page - 1) * perPage
baseQuery <- pure $ query @OutcomeCorrelation
@@ -43,7 +43,7 @@ instance Controller ApiV2LearningController where
action ApiV2IndexKnowledgeBaseAction = do
_consumer <- requireApiConsumer
mQ <- paramOrNothing @Text "q"
let mQ = paramOrNothing @Text "q"
(page, perPage) <- getPageParams
let off = (page - 1) * perPage
rows <- case mQ of

10
Web/Controller/Api/V2/Token.hs
View File

@@ -10,7 +10,7 @@ import IHP.ControllerPrelude
import Data.Aeson (object, (.=))
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Crypto.Hash.SHA256 as SHA256
import qualified "cryptohash-sha256" Crypto.Hash.SHA256 as SHA256
import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Random as Random
import Data.Time (addUTCTime)
@@ -23,10 +23,10 @@ instance Controller ApiV2TokenController where
when (requestMethod ?request /= "POST") do
respondWithStatus 405 $ object ["error" .= ("Method not allowed" :: Text)]
grantType <- paramOrNothing @Text "grant_type"
clientId <- paramOrNothing @Text "client_id"
clientSecret <- paramOrNothing @Text "client_secret"
mScope <- paramOrNothing @Text "scope"
let grantType = paramOrNothing @Text "grant_type"
clientId = paramOrNothing @Text "client_id"
clientSecret = paramOrNothing @Text "client_secret"
mScope = paramOrNothing @Text "scope"
-- grant_type must be client_credentials
case grantType of

3
Web/Controller/Api/V2/WidgetPatterns.hs
View File

@@ -9,7 +9,8 @@ import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
import Data.Aeson (object, (.=), Value)
import Web.Controller.Api.V2.Auth (requireApiConsumer, checkRateLimitAndLog, paginatedResponse, getPageParams)
import Web.Controller.Api.V2.Auth (requireApiConsumer, paginatedResponse, getPageParams)
import Application.Helper.ApiRateLimit (checkRateLimitAndLog)
instance Controller ApiV2WidgetPatternsController where

4
Web/Controller/Api/V2/Widgets.hs
View File

@@ -12,12 +12,12 @@ instance Controller ApiV2WidgetsController where
action ApiV2IndexWidgetsAction = do
_consumer <- requireApiConsumer
(page, perPage) <- getPageParams
let offset = (page - 1) * perPage
let pageOffset = (page - 1) * perPage
total <- query @Widget |> fetchCount
widgets <- query @Widget
|> orderByDesc #createdAt
|> limit perPage
|> offset offset
|> offset pageOffset
|> fetch
renderJson $ paginatedResponse (map widgetToJson widgets) page perPage total

4
Web/Controller/ApiConsumers.hs
View File

@@ -52,7 +52,7 @@ instance Controller ApiConsumersController where
|> fetch
render NewView { consumer = consumerWithErrors, manifests }
Right validConsumer -> do
mManifestId <- paramOrNothing @(Id HubCapabilityManifest) "hubCapabilityManifestId"
let mManifestId = paramOrNothing @(Id HubCapabilityManifest) "hubCapabilityManifestId"
validConsumer
|> set #hubCapabilityManifestId mManifestId
|> createRecord
@@ -76,7 +76,7 @@ instance Controller ApiConsumersController where
|> fetch
render EditView { consumer = consumerWithErrors, manifests }
Right validConsumer -> do
mManifestId <- paramOrNothing @(Id HubCapabilityManifest) "hubCapabilityManifestId"
let mManifestId = paramOrNothing @(Id HubCapabilityManifest) "hubCapabilityManifestId"
validConsumer
|> set #hubCapabilityManifestId mManifestId
|> updateRecord

9
Web/Controller/ApiInteractionEvents.hs
View File

@@ -10,6 +10,7 @@ import Network.Wai (requestMethod, requestHeaders, responseLBS, ResponseReceived
import Network.HTTP.Types (status201, status401, status403, status405, status422)
import IHP.Controller.Render (renderJson, renderJsonWithStatusCode)
import Application.Helper.TypeRegistry (validateEventType)
import qualified Data.UUID as UUID
instance Controller ApiInteractionEventsController where
@@ -41,9 +42,9 @@ instance Controller ApiInteractionEventsController where
createEventForHub :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Hub -> IO ()
createEventForHub hub = do
-- Validate required fields per contract v1.0
widgetIdText <- paramOrNothing @Text "widget_id"
eventType <- paramOrNothing @Text "event_type"
_occurredAt <- paramOrNothing @Text "occurred_at"
let widgetIdText = paramOrNothing @Text "widget_id"
eventType = paramOrNothing @Text "event_type"
_occurredAt = paramOrNothing @Text "occurred_at"
let missing = catMaybes
[ if isNothing widgetIdText then Just ("widget_id" :: Text) else Nothing
@@ -70,7 +71,7 @@ createEventForHub hub = do
Right () -> pure ()
-- Resolve widget — must belong to this hub.
case readMay wIdText of
case UUID.fromText wIdText of
Nothing -> do
renderJsonWithStatusCode status422 (object ["error" .= ("widget_id must be a valid UUID" :: Text)])
Just rawId -> do

5
Web/Controller/ApiKeys.hs
View File

@@ -6,6 +6,7 @@ import Web.View.ApiKeys.Created
import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified "cryptohash-sha256" Crypto.Hash.SHA256 as SHA256
import qualified Data.ByteString.Base16 as Base16
@@ -24,9 +25,9 @@ instance Controller ApiKeysController where
render NewView { apiKey, consumer }
action CreateApiKeyAction = do
apiConsumerId <- param @(Id ApiConsumer) "apiConsumerId"
let apiConsumerId = param @(Id ApiConsumer) "apiConsumerId"
consumer <- fetch apiConsumerId
scopes <- fromMaybe "" <$> paramOrNothing @Text "scopes"
let scopes = fromMaybe "" (paramOrNothing @Text "scopes")
-- Generate a random 32-byte key, encode as hex (64 chars)
rawBytes <- liftIO $ Random.random 32

1
Web/Controller/ArchiveRecords.hs
View File

@@ -7,6 +7,7 @@ import Web.View.ArchiveRecords.LineageInspector
import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
import Data.Coerce (coerce)
instance Controller ArchiveRecordsController where
beforeAction = ensureIsUser

12
Web/Controller/CollectiveProposals.hs
View File

@@ -30,12 +30,12 @@ instance Controller CollectiveProposalsController where
render ShowView { proposal, agentContributions = agentNames }
action CreateCollectiveProposalAction = do
hubId <- param @(Id Hub) "hubId"
title <- param @Text "title"
taskType <- param @Text "taskType"
prompt <- param @Text "prompt"
mWidgetId <- paramOrNothing @(Id Widget) "sourceWidgetId"
mCandId <- paramOrNothing @(Id RequirementCandidate) "sourceCandidateId"
let hubId = param @(Id Hub) "hubId"
title = param @Text "title"
taskType = param @Text "taskType"
prompt = param @Text "prompt"
mWidgetId = paramOrNothing @(Id Widget) "sourceWidgetId"
mCandId = paramOrNothing @(Id RequirementCandidate) "sourceCandidateId"
proposal <- newRecord @CollectiveProposal
|> set #title title

22
Web/Controller/DecisionRecords.hs
View File

@@ -27,7 +27,7 @@ instance Controller DecisionRecordsController where
beforeAction = ensureIsUser
action DecisionRecordsAction = do
mOutcomeFilter <- paramOrNothing @Text "outcome"
let mOutcomeFilter = paramOrNothing @Text "outcome"
records <- case mOutcomeFilter of
Nothing -> query @DecisionRecord |> orderByDesc #decidedAt |> fetch
Just o -> query @DecisionRecord
@@ -85,8 +85,8 @@ instance Controller DecisionRecordsController where
requirements <- query @Requirement |> fetch
candidates <- query @RequirementCandidate |> fetch
users <- query @User |> fetch
mUser <- currentUserOrNothing
let decidedBy = fmap (.id) mUser
let mUser = currentUserOrNothing
decidedBy = fmap (.id) mUser
let record = newRecord @DecisionRecord
record
@@ -128,10 +128,10 @@ instance Controller DecisionRecordsController where
redirectTo ShowDecisionRecordAction { decisionRecordId }
action AddPolicyReferenceAction { decisionRecordId } = do
mUser <- currentUserOrNothing
let createdBy = fmap (.id) mUser
policyScope <- param @Text "policyScope"
constraintNote <- paramOrNothing @Text "constraintNote"
let mUser = currentUserOrNothing
createdBy = fmap (.id) mUser
policyScope = param @Text "policyScope"
constraintNote = paramOrNothing @Text "constraintNote"
unless (policyScope `elem` validPolicyScopes) do
setErrorMessage ("Invalid policy scope: " <> policyScope)
respondWith 422 do
@@ -153,10 +153,10 @@ instance Controller DecisionRecordsController where
redirectTo ShowDecisionRecordAction { decisionRecordId }
action AddImplementationRefAction { decisionRecordId } = do
mUser <- currentUserOrNothing
let linkedBy = fmap (.id) mUser
workItemRef <- param @Text "workItemRef"
system <- param @Text "system"
let mUser = currentUserOrNothing
linkedBy = fmap (.id) mUser
workItemRef = param @Text "workItemRef"
system = param @Text "system"
unless (system `elem` validSystems) do
setErrorMessage ("Invalid system: " <> system)
respondWith 422 do

20
Web/Controller/DeploymentRecords.hs
View File

@@ -62,7 +62,7 @@ instance Controller DeploymentRecordsController where
decisions <- query @DecisionRecord |> fetch
implRefs <- query @ImplementationChangeReference |> fetch
users <- query @User |> fetch
mDecisionId <- paramOrNothing @(Id DecisionRecord) "decisionId"
let mDecisionId = paramOrNothing @(Id DecisionRecord) "decisionId"
let record = newRecord @DeploymentRecord
render NewView { record, decisions, implRefs, users, mDecisionId }
@@ -70,8 +70,8 @@ instance Controller DeploymentRecordsController where
decisions <- query @DecisionRecord |> fetch
implRefs <- query @ImplementationChangeReference |> fetch
users <- query @User |> fetch
mUser <- currentUserOrNothing
let deployedBy = fmap (.id) mUser
let mUser = currentUserOrNothing
deployedBy = fmap (.id) mUser
let record = newRecord @DeploymentRecord
record
@@ -86,9 +86,9 @@ instance Controller DeploymentRecordsController where
redirectTo ShowDeploymentRecordAction { deploymentRecordId = created.id }
action RecordOutcomeSignalAction { deploymentRecordId } = do
signalType <- param @Text "signalType"
mValue <- paramOrNothing @Double "value"
mUser <- currentUserOrNothing
let signalType = param @Text "signalType"
mValue = paramOrNothing @Double "value"
mUser = currentUserOrNothing
let validTypes = ["improved", "regressed", "neutral", "inconclusive"] :: [Text]
unless (signalType `elem` validTypes) do
setErrorMessage ("Invalid signal type: " <> signalType)
@@ -123,10 +123,10 @@ instance Controller DeploymentRecordsController where
setErrorMessage "Already evaluated — one evaluation per deployment."
redirectTo ShowDeploymentRecordAction { deploymentRecordId }
Nothing -> do
mUser <- currentUserOrNothing
let evaluatedBy = fmap (.id) mUser
scoreText <- param @Text "score"
rationale <- param @Text "rationale"
let mUser = currentUserOrNothing
evaluatedBy = fmap (.id) mUser
scoreText = param @Text "score"
rationale = param @Text "rationale"
let mScore = readMaybe (cs scoreText) :: Maybe Int
case mScore of
Nothing -> do

4
Web/Controller/FederatedPolicyOverlays.hs
View File

@@ -32,7 +32,7 @@ instance Controller FederatedPolicyOverlaysController where
let overlay = newRecord @FederatedPolicyOverlay
hubs <- query @Hub |> orderByAsc #name |> fetch
overlay
|> fill @'["title","policyText","appliesToHubs","notes"]
|> fill @'["title","policyText","notes"]
|> validateField #title nonEmpty
|> validateField #policyText nonEmpty
|> ifValid \case
@@ -57,7 +57,7 @@ instance Controller FederatedPolicyOverlaysController where
setErrorMessage "Activated overlays cannot be edited"
redirectTo ShowFederatedPolicyOverlayAction { federatedPolicyOverlayId }
overlay
|> fill @'["title","policyText","appliesToHubs","notes"]
|> fill @'["title","policyText","notes"]
|> validateField #title nonEmpty
|> validateField #policyText nonEmpty
|> ifValid \case

2
Web/Controller/HubCapabilityManifests.hs
View File

@@ -28,7 +28,7 @@ instance Controller HubCapabilityManifestsController where
render ShowView { manifest, hub }
action NewHubCapabilityManifestAction = do
mHubId <- paramOrNothing @(Id Hub) "hubId"
let mHubId = paramOrNothing @(Id Hub) "hubId"
hubs <- query @Hub |> orderByAsc #name |> fetch
let manifest = newRecord @HubCapabilityManifest
case mHubId of

8
Web/Controller/HubRoutingRules.hs
View File

@@ -34,8 +34,8 @@ instance Controller HubRoutingRulesController where
action CreateHubRoutingRuleAction = do
let rule = newRecord @HubRoutingRule
hubs <- query @Hub |> orderByAsc #name |> fetch
mMatchWidgetType <- paramOrNothing @Text "matchWidgetType"
mMatchCategory <- paramOrNothing @Text "matchCategory"
let mMatchWidgetType = paramOrNothing @Text "matchWidgetType"
mMatchCategory = paramOrNothing @Text "matchCategory"
wtResult <- case mMatchWidgetType of { Nothing -> pure (Right ()); Just "" -> pure (Right ()); Just t -> liftIO (validateWidgetType t) }
catResult <- case mMatchCategory of { Nothing -> pure (Right ()); Just "" -> pure (Right ()); Just c -> liftIO (validateAnnotationCategory c) }
rule
@@ -59,8 +59,8 @@ instance Controller HubRoutingRulesController where
action UpdateHubRoutingRuleAction { hubRoutingRuleId } = do
rule <- fetch hubRoutingRuleId
hubs <- query @Hub |> orderByAsc #name |> fetch
mMatchWidgetType <- paramOrNothing @Text "matchWidgetType"
mMatchCategory <- paramOrNothing @Text "matchCategory"
let mMatchWidgetType = paramOrNothing @Text "matchWidgetType"
mMatchCategory = paramOrNothing @Text "matchCategory"
wtResult <- case mMatchWidgetType of { Nothing -> pure (Right ()); Just "" -> pure (Right ()); Just t -> liftIO (validateWidgetType t) }
catResult <- case mMatchCategory of { Nothing -> pure (Right ()); Just "" -> pure (Right ()); Just c -> liftIO (validateAnnotationCategory c) }
rule

9
Web/Controller/InstitutionalKnowledge.hs
View File

@@ -2,7 +2,10 @@ module Web.Controller.InstitutionalKnowledge where
-- IHF Phase 12 — Platform Memory (IHUB-WP-0013 T05)
import Web.Controller.Prelude
import Web.Types
import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
import Web.View.InstitutionalKnowledge.Index
import Web.View.InstitutionalKnowledge.Show
import IHP.ModelSupport (sqlQuery)
@@ -27,8 +30,8 @@ instance Controller InstitutionalKnowledgeController where
render ShowView { entry, hub, mDecision }
action QueryKnowledgeBaseAction = do
q <- param @Text "q"
mHubStr <- paramOrNothing @Text "hubId"
let q = param @Text "q"
mHubStr = paramOrNothing @Text "hubId"
hubs <- query @Hub |> fetch
entries <- case mHubStr of
Nothing ->

18
Web/Controller/InteractionEvents.hs
View File

@@ -5,6 +5,7 @@ import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
import Data.Aeson (object, (.=), decode, Value)
import Data.Coerce (coerce)
import qualified Data.Aeson as A
import qualified Data.Text as T
import qualified Data.ByteString.Lazy.Char8 as LBSC
@@ -22,17 +23,16 @@ validEventTypes =
instance Controller InteractionEventsController where
action CreateInteractionEventAction { widgetId } = do
eventType <- param @Text "event_type"
let eventType = param @Text "event_type"
unless (eventType `elem` validEventTypes) do
renderJsonWithStatusCode status422 (object ["error" .= ("unknown event_type" :: Text), "valid" .= validEventTypes])
mUser <- currentUserOrNothing
let actorId = fmap (.id) mUser
actorType = maybe "anonymous" (const "user") mUser
actorTypeParam <- paramOrDefault @Text actorType "actor_type"
viewContextRef <- paramOrNothing @Text "view_context_ref"
metadataRaw <- paramOrDefault @Text "{}" "metadata"
let mUser = currentUserOrNothing
let actorId = fmap (.id) mUser
actorType = maybe "anonymous" (const "user") mUser
actorTypeParam = paramOrDefault @Text actorType "actor_type"
viewContextRef = paramOrNothing @Text "view_context_ref"
metadataRaw = paramOrDefault @Text "{}" "metadata"
let metadata = case decode (LBSC.pack (cs metadataRaw)) of
Just v -> v
@@ -41,7 +41,7 @@ instance Controller InteractionEventsController where
event <- newRecord @InteractionEvent
|> set #widgetId widgetId
|> set #eventType eventType
|> set #actorId (fmap toUUID actorId)
|> set #actorId (coerce actorId)
|> set #actorType actorTypeParam
|> set #viewContextRef viewContextRef
|> set #metadata metadata

1
Web/Controller/MarketplaceDashboard.hs
View File

@@ -5,6 +5,7 @@ import Web.View.MarketplaceDashboard.Show
import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
import Database.PostgreSQL.Simple (Query)
instance Controller MarketplaceDashboardController where
beforeAction = ensureIsUser

7
Web/Controller/OutcomeCorrelations.hs
View File

@@ -2,7 +2,10 @@ module Web.Controller.OutcomeCorrelations where
-- IHF Phase 12 — Platform Memory (IHUB-WP-0013 T02)
import Web.Controller.Prelude
import Web.Types
import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
import Web.View.OutcomeCorrelations.Index
import Application.Helper.CorrelationEngine (computeAnnotationCorrelations)
import Data.Aeson ((.=), object)
@@ -11,7 +14,7 @@ instance Controller OutcomeCorrelationsController where
beforeAction = ensureIsUser
action OutcomeCorrelationsAction = do
mHubFilter <- paramOrNothing @(Id Hub) "hubId"
let mHubFilter = paramOrNothing @(Id Hub) "hubId"
correlations <- case mHubFilter of
Nothing -> query @OutcomeCorrelation
|> orderByDesc #correlationScore

30
Web/Controller/RequirementCandidates.hs
View File

@@ -43,7 +43,7 @@ instance Controller RequirementCandidatesController where
beforeAction = ensureIsUser
action RequirementCandidatesAction = do
mStatusFilter <- paramOrNothing @Text "status"
let mStatusFilter = paramOrNothing @Text "status"
candidates <- case mStatusFilter of
Nothing -> query @RequirementCandidate |> orderByDesc #createdAt |> fetch
Just s -> query @RequirementCandidate
@@ -84,8 +84,8 @@ instance Controller RequirementCandidatesController where
action CreateRequirementCandidateAction = do
widgets <- query @Widget |> fetch
threads <- query @AnnotationThread |> fetch
mUser <- currentUserOrNothing
let createdBy = fmap (.id) mUser
let mUser = currentUserOrNothing
createdBy = fmap (.id) mUser
let candidate = newRecord @RequirementCandidate
candidate
@@ -136,10 +136,10 @@ instance Controller RequirementCandidatesController where
action UpdateTriageStatusAction { requirementCandidateId } = do
candidate <- fetch requirementCandidateId
newStatus <- param @Text "status"
notes <- paramOrNothing @Text "notes"
mUser <- currentUserOrNothing
let changedBy = fmap (.id) mUser
let newStatus = param @Text "status"
notes = paramOrNothing @Text "notes"
mUser = currentUserOrNothing
changedBy = fmap (.id) mUser
if allowedTransition candidate.status newStatus
then do
@@ -162,9 +162,9 @@ instance Controller RequirementCandidatesController where
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
action AssignReviewerAction { requirementCandidateId } = do
userId <- param @(Id User) "userId"
mUser <- currentUserOrNothing
let assignedBy = fmap (.id) mUser
let userId = param @(Id User) "userId"
mUser = currentUserOrNothing
assignedBy = fmap (.id) mUser
-- Upsert: delete existing assignment then insert
existing <- query @ReviewerAssignment
@@ -184,7 +184,7 @@ instance Controller RequirementCandidatesController where
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
action MyQueueAction = do
mUser <- currentUserOrNothing
let mUser = currentUserOrNothing
case mUser of
Nothing -> redirectTo RequirementCandidatesAction
Just user -> do
@@ -214,8 +214,8 @@ instance Controller RequirementCandidatesController where
case candidate.requirementId of
Just rid -> redirectTo ShowRequirementAction { requirementId = rid }
Nothing -> do
mUser <- currentUserOrNothing
let createdBy = fmap (.id) mUser
let mUser = currentUserOrNothing
createdBy = fmap (.id) mUser
req <- newRecord @Requirement
|> set #title candidate.title
|> set #description candidate.description
@@ -243,8 +243,8 @@ instance Controller RequirementCandidatesController where
case existing of
Just dr -> redirectTo ShowDecisionRecordAction { decisionRecordId = dr.id }
Nothing -> do
mUser <- currentUserOrNothing
let decidedBy = fmap (.id) mUser
let mUser = currentUserOrNothing
decidedBy = fmap (.id) mUser
-- Use promoted requirement id if available
let mReqId = candidate.requirementId
dr <- newRecord @DecisionRecord

1
Web/Controller/Sessions.hs
View File

@@ -4,6 +4,7 @@ import Web.Types
import Web.View.Sessions.New
import Generated.Types
import IHP.LoginSupport.Helper.Controller
import IHP.AuthSupport.Controller.Sessions (SessionsControllerConfig)
import IHP.Prelude
import IHP.ControllerPrelude

8
Web/Controller/TypeRegistries.hs
View File

@@ -68,7 +68,7 @@ instance Controller TypeRegistriesController where
action DeprecateWidgetTypeAction { widgetTypeRegistryId } = do
entry <- fetch widgetTypeRegistryId
replacedBy <- param @Text "deprecated_in_favour_of"
let replacedBy = param @Text "deprecated_in_favour_of"
when (null replacedBy) do
setErrorMessage "You must specify the replacement type name"
redirectTo WidgetTypeRegistryAction
@@ -134,7 +134,7 @@ instance Controller TypeRegistriesController where
action DeprecateEventTypeAction { eventTypeRegistryId } = do
entry <- fetch eventTypeRegistryId
replacedBy <- param @Text "deprecated_in_favour_of"
let replacedBy = param @Text "deprecated_in_favour_of"
when (null replacedBy) do
setErrorMessage "You must specify the replacement type name"
redirectTo EventTypeRegistryAction
@@ -200,7 +200,7 @@ instance Controller TypeRegistriesController where
action DeprecateAnnotationCategoryAction { annotationCategoryRegistryId } = do
entry <- fetch annotationCategoryRegistryId
replacedBy <- param @Text "deprecated_in_favour_of"
let replacedBy = param @Text "deprecated_in_favour_of"
when (null replacedBy) do
setErrorMessage "You must specify the replacement category name"
redirectTo AnnotationCategoryRegistryAction
@@ -266,7 +266,7 @@ instance Controller TypeRegistriesController where
action DeprecatePolicyScopeAction { policyScopeRegistryId } = do
entry <- fetch policyScopeRegistryId
replacedBy <- param @Text "deprecated_in_favour_of"
let replacedBy = param @Text "deprecated_in_favour_of"
when (null replacedBy) do
setErrorMessage "You must specify the replacement scope name"
redirectTo PolicyScopeRegistryAction

30
Web/Controller/WebhookSubscriptions.hs
View File

@@ -32,27 +32,27 @@ instance Controller WebhookSubscriptionsController where
render NewView { subscription, consumer }
action CreateWebhookSubscriptionAction = do
apiConsumerId <- param @(Id ApiConsumer) "apiConsumerId"
let apiConsumerId = param @(Id ApiConsumer) "apiConsumerId"
eventType = param @Text "eventType"
targetUrl = param @Text "targetUrl"
consumer <- fetch apiConsumerId
eventType <- param @Text "eventType"
targetUrl <- param @Text "targetUrl"
-- Validate against allowed webhook topics
unless (eventType `elem` allowedWebhookTopics) $ do
setErrorMessage ("Unknown webhook topic: " <> eventType)
redirectTo (NewWebhookSubscriptionAction apiConsumerId)
Right () -> do
-- Generate HMAC signing secret
secretBytes <- liftIO $ Random.random 32
let secret = TE.decodeUtf8 (Base16.encode secretBytes)
_sub <- newRecord @WebhookSubscription
|> set #apiConsumerId consumer.id
|> set #eventType eventType
|> set #targetUrl targetUrl
|> set #secret secret
|> set #isActive True
|> createRecord
redirectTo (ShowApiConsumerAction apiConsumerId)
-- Generate HMAC signing secret
secretBytes <- liftIO $ Random.random 32
let secret = TE.decodeUtf8 (Base16.encode secretBytes)
_sub <- newRecord @WebhookSubscription
|> set #apiConsumerId consumer.id
|> set #eventType eventType
|> set #targetUrl targetUrl
|> set #secret secret
|> set #isActive True
|> createRecord
redirectTo (ShowApiConsumerAction apiConsumerId)
action ToggleWebhookSubscriptionAction { webhookSubscriptionId } = do
sub <- fetch webhookSubscriptionId

14
Web/Controller/Widgets.hs
View File

@@ -77,9 +77,10 @@ instance Controller WidgetsController where
adapterSpecs <- query @WidgetAdapterSpec |> filterWhere (#status, "active") |> orderByAsc #name |> fetch
(fwTypes, ownedTypes) <- activeWidgetTypes
policyScopes <- activePolicyScopes
let widgetTypes = fwTypes <> ownedTypes
widgetTypeVal <- paramOrDefault @Text "" "widgetType" >>= \t -> liftIO (validateWidgetType t)
mPolicyScope <- paramOrNothing @Text "policyScope"
let widgetTypes = fwTypes <> ownedTypes
widgetTypeText = paramOrDefault @Text "" "widgetType"
mPolicyScope = paramOrNothing @Text "policyScope"
widgetTypeVal <- liftIO (validateWidgetType widgetTypeText)
policyScopeVal <- case mPolicyScope of
Nothing -> pure (Right ())
Just "" -> pure (Right ())
@@ -130,9 +131,10 @@ instance Controller WidgetsController where
adapterSpecs <- query @WidgetAdapterSpec |> filterWhere (#status, "active") |> orderByAsc #name |> fetch
(fwTypes, ownedTypes) <- activeWidgetTypes
policyScopes <- activePolicyScopes
let widgetTypes = fwTypes <> ownedTypes
widgetTypeVal <- paramOrDefault @Text "" "widgetType" >>= \t -> liftIO (validateWidgetType t)
mPolicyScope <- paramOrNothing @Text "policyScope"
let widgetTypes = fwTypes <> ownedTypes
widgetTypeText = paramOrDefault @Text "" "widgetType"
mPolicyScope = paramOrNothing @Text "policyScope"
widgetTypeVal <- liftIO (validateWidgetType widgetTypeText)
policyScopeVal <- case mPolicyScope of
Nothing -> pure (Right ())
Just "" -> pure (Right ())