coulomb/inter-hub
2
0
Fork 0
generated from coulomb/repo-seed
Code Issues Pull Requests Actions 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

17
.envrc
View File

@@ -32,3 +32,20 @@ fi
export SMTP_HOST="127.0.0.1" # On some computers may need `127.0.1.1` instead.
export SMTP_PORT="1025"
export SMTP_ENCRYPTION="Unencrypted"
# GHCi security: prevent "WARNING: . is writable by someone else, IGNORING!"
# which causes .ghci (and applicationGhciConfig) to be skipped, breaking
# the IHP source-path setup (-ibuild, -iConfig, etc.).
chmod go-w .
# IHP_LIB: path to the IHP lib/IHP directory containing applicationGhciConfig.
# Required for manual GHCi invocation (devenv up / RunDevServer sets this
# internally). Derived from the devenv profile's RunDevServer binary.
if [ -f "$PWD/.devenv/profile/bin/RunDevServer" ]; then
_ihp_base=$(strings "$PWD/.devenv/profile/bin/RunDevServer" 2>/dev/null \
| grep -m1 'ihp-ide.*data.*/lib$')
if [ -n "$_ihp_base" ]; then
export IHP_LIB="$_ihp_base/IHP"
fi
unset _ihp_base
fi

3
.ghci
View File

@@ -1,4 +1,7 @@
:set -XNoImplicitPrelude
:def loadFromIHP \file -> (System.Environment.getEnv "IHP_LIB") >>= (\ihpLib -> readFile (ihpLib <> "/" <> file))
:loadFromIHP applicationGhciConfig
-- Resource limit: override IHP's default -j (unlimited parallel) with -j1
-- on this constrained host (2 CPU / 3.8 GiB RAM).
:set -j1
import IHP.Prelude

5
Application/Helper/AgentBridge.hs
View File

@@ -10,6 +10,7 @@ import Data.Aeson (object, (.=), encode, decode, Value, FromJSON(..), (.:), (.:?
import qualified Data.Aeson as A
import qualified Data.Aeson.KeyMap as KM
import qualified Data.Aeson.Key as AK
import qualified Data.Vector as V
import qualified Data.ByteString.Lazy as LBS
import System.Process (readProcessWithExitCode)
import System.Exit (ExitCode(..))
@@ -171,7 +172,7 @@ callBridgeBatch reqs = do
let outBytes = LBS.fromStrict (cs stdout)
case A.decode @A.Value outBytes of
Just (A.Object o) | Just (A.Array arr) <- KM.lookup (AK.fromString "results") o ->
pure $ map parseResult (toList arr)
pure $ map parseResult (V.toList arr)
_ ->
pure $ replicate (length reqs) (Left (BridgeError "Unparseable batch output" "ParseError"))
where
@@ -217,5 +218,5 @@ checkGovernancePolicy hubId agentId artifactType = do
-- | Extract Text values from a JSONB array.
jsonArrayTexts :: Value -> [Text]
jsonArrayTexts (A.Array vs) =
[ t | A.String t <- toList vs ]
[ t | A.String t <- V.toList vs ]
jsonArrayTexts _ = []

5
Application/Helper/ApiRateLimit.hs
View File

@@ -21,11 +21,10 @@ checkRateLimitAndLog ::
, ?request :: Request
) =>
ApiConsumer ->
Text -> -- endpoint path
Text -> -- HTTP method
Int -> -- response status code (0 if not yet known; log after)
Text -> -- endpoint path
IO ()
checkRateLimitAndLog consumer endpoint method _statusCode = do
checkRateLimitAndLog consumer endpoint method = do
-- Check rate limit: requests in last 60 seconds
rows1 <- sqlQuery
"SELECT COUNT(*) FROM api_request_log \

10
Application/Helper/BottleneckDetector.hs
View File

@@ -90,15 +90,15 @@ detectBottlenecks hubId hubWidgets candidates requirements decisions deployments
|> set #hubId hubId
|> set #stage stage
|> set #subjectType subjType
|> set #subjectId (coerce subjId)
|> set #subjectId subjId
|> set #stalledSince stalledSince
|> set #severity severity
|> createRecord
r1 <- mapM (\(c, t) -> mkBottleneck "candidate" "RequirementCandidate" c.id t candidateThreshold) staleCandidates
r2 <- mapM (\(r, t) -> mkBottleneck "requirement" "Requirement" r.id t requirementThreshold) stalRequirements
r3 <- mapM (\(d, t) -> mkBottleneck "decision" "DecisionRecord" d.id t decisionThreshold) staleDecisions
r4 <- mapM (\(d, t) -> mkBottleneck "observation" "DeploymentRecord" d.id t observationThreshold) staleDeployments
r1 <- mapM (\(c, t) -> mkBottleneck "candidate" "RequirementCandidate" (coerce c.id :: UUID) t candidateThreshold) staleCandidates
r2 <- mapM (\(r, t) -> mkBottleneck "requirement" "Requirement" (coerce r.id :: UUID) t requirementThreshold) stalRequirements
r3 <- mapM (\(d, t) -> mkBottleneck "decision" "DecisionRecord" (coerce d.id :: UUID) t decisionThreshold) staleDecisions
r4 <- mapM (\(d, t) -> mkBottleneck "observation" "DeploymentRecord" (coerce d.id :: UUID) t observationThreshold) staleDeployments
pure (r1 <> r2 <> r3 <> r4)

22
Application/Helper/CrossHubPropagation.hs
View File

@@ -69,14 +69,16 @@ detectPropagations hubs annotations widgets frictionScores = do
guard (not (any (\p -> p.patternType == "widget_type_friction" && p.summary == summary) existing))
pure (srcHub, hubsWithHighFriction, "widget_type_friction", summary)
let allPatterns = clusterPropagations <> frictionPropagations
let allPatterns :: [(Id' "hubs", [Id' "hubs"], Text, Text)]
allPatterns = clusterPropagations <> frictionPropagations
mapM (\(srcHubId, affectedHubIds, ptype, summary) ->
newRecord @CrossHubPropagation
|> set #patternType ptype
|> set #sourceHubId (Just srcHubId)
|> set #affectedHubIds (toJSON (map show affectedHubIds))
|> set #summary summary
|> set #status "open"
|> createRecord
) allPatterns
let insertPropagation (rawSrcId, affectedHubIds, ptype, summary) = do
let srcId = rawSrcId :: Id' "hubs"
newRecord @CrossHubPropagation
|> set #patternType ptype
|> set #sourceHubId (Just srcId)
|> set #affectedHubIds (toJSON (map show affectedHubIds))
|> set #summary summary
|> set #status "open"
|> createRecord
mapM insertPropagation allPatterns

7
Application/Helper/FrictionScore.hs
View File

@@ -9,7 +9,8 @@ import Web.Routes ()
import Database.PostgreSQL.Simple (Only(..))
import Data.Time.Clock (addUTCTime, getCurrentTime)
import qualified Data.Aeson as A
import qualified Data.HashMap.Strict as H
import qualified Data.Aeson.KeyMap as KM
import qualified Data.Aeson.Key as AK
-- | Friction score formula (documented):
--
@@ -85,9 +86,9 @@ applyAdaptiveWeights hubId annCount errCount isRegressed staleCount = do
mConfig <- query @AdaptiveThresholdConfig
|> filterWhere (#hubId, hubId)
|> fetchOneOrNothing
let overrides = maybe mempty (.weightOverrides) mConfig
let overrides = maybe (A.object []) (.weightOverrides) mConfig
w k def = case overrides of
A.Object o -> case H.lookup k o of
A.Object o -> case KM.lookup (AK.fromText k) o of
Just (A.Number n) -> round (n * fromIntegral def) :: Int
_ -> def
_ -> def

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 ())

4
Web/Job/WebhookDeliveryJob.hs
View File

@@ -65,7 +65,7 @@ attempt sub payload attemptNo = do
attempt sub payload (attemptNo + 1)
Left ex -> do
recordDelivery sub payload 0 latencyMs "failed"
(Just (T.pack (show ex)))
(Just (show ex))
when (attemptNo < 3) $
attempt sub payload (attemptNo + 1)
@@ -85,7 +85,7 @@ recordDelivery sub payload responseCode latencyMs status mError = do
\VALUES (uuid_generate_v4(), ?, ?::jsonb, NOW(), ?, \
\ NULLIF(?, 0), ?, ?)"
( sub.id
, encode payload
, LBS.toStrict (encode payload)
, status
, responseCode
, Just latencyMs

4
Web/Types.hs
View File

@@ -5,8 +5,8 @@ import IHP.ModelSupport
import IHP.LoginSupport.Types
import Generated.Types
-- | Authentication type alias
type CurrentUserRecord = User
-- | Authentication type family instance (required by IHP.LoginSupport)
type instance CurrentUserRecord = User
instance HasNewSessionUrl User where
newSessionUrl _ = "/NewSession"

2
Web/View/AdaptiveThresholds/Index.hs
View File

@@ -1,6 +1,6 @@
module Web.View.AdaptiveThresholds.Index where
import IHP.ViewPrelude
import Web.View.Prelude
import Data.Time (diffUTCTime)
data IndexView = IndexView

2
Web/View/AgentDelegations/Index.hs
View File

@@ -1,6 +1,6 @@
module Web.View.AgentDelegations.Index where
import IHP.ViewPrelude
import Web.View.Prelude
data IndexView = IndexView
{ delegations :: ![AgentDelegation] }

2
Web/View/AgentDelegations/Show.hs
View File

@@ -1,6 +1,6 @@
module Web.View.AgentDelegations.Show where
import IHP.ViewPrelude
import Web.View.Prelude
import Web.View.AgentDelegations.Index (statusBadge)
import Data.Aeson (Value)

2
Web/View/AgentRegistrations/Edit.hs
View File

@@ -1,6 +1,6 @@
module Web.View.AgentRegistrations.Edit where
import IHP.ViewPrelude
import Web.View.Prelude
import Web.View.AgentRegistrations.New (renderForm)
data EditView = EditView

2
Web/View/AgentRegistrations/Index.hs
View File

@@ -1,6 +1,6 @@
module Web.View.AgentRegistrations.Index where
import IHP.ViewPrelude
import Web.View.Prelude
data IndexView = IndexView
{ agents :: ![AgentRegistration]

2
Web/View/AgentRegistrations/New.hs
View File

@@ -1,6 +1,6 @@
module Web.View.AgentRegistrations.New where
import IHP.ViewPrelude
import Web.View.Prelude
data NewView = NewView
{ agent :: !AgentRegistration

2
Web/View/AgentRegistrations/Performance.hs
View File

@@ -3,5 +3,5 @@ module Web.View.AgentRegistrations.Performance where
-- Performance view is rendered inline in Show.hs via performancePanel helper.
-- This module re-exports it for use if needed as a standalone view.
import IHP.ViewPrelude
import Web.View.Prelude
import Web.View.AgentRegistrations.Show (performancePanel)

2
Web/View/AgentRegistrations/Show.hs
View File

@@ -1,6 +1,6 @@
module Web.View.AgentRegistrations.Show where
import IHP.ViewPrelude
import Web.View.Prelude
import Web.View.AgentRegistrations.Index (trustBadge, statusBadge)
import Text.Printf (printf)

2
Web/View/AiGovernancePolicies/Index.hs
View File

@@ -1,6 +1,6 @@
module Web.View.AiGovernancePolicies.Index where
import IHP.ViewPrelude
import Web.View.Prelude
data IndexView = IndexView
{ policies :: ![AiGovernancePolicy]

61
Web/View/AiGovernancePolicies/New.hs
View File

@@ -1,6 +1,6 @@
module Web.View.AiGovernancePolicies.New where
import IHP.ViewPrelude
import Web.View.Prelude
data NewView = NewView
{ policy :: !AiGovernancePolicy
@@ -34,33 +34,36 @@ instance View NewView where
html NewView { .. } = [hsx|
<div class="p-6 max-w-xl">
<h1 class="text-2xl font-bold text-gray-900 mb-6">Add AI Governance Policy</h1>
{formFor policy [hsx|
<div class="space-y-4">
<div>
<label class="block text-sm font-medium text-gray-700 mb-1">Hub</label>
<select name="hubId" class="block w-full border-gray-300 rounded-md shadow-sm text-sm">
{forEach hubs renderHubOption}
</select>
</div>
<div>
<label class="block text-sm font-medium text-gray-700 mb-1">Agent</label>
<select name="agentRegistrationId" class="block w-full border-gray-300 rounded-md shadow-sm text-sm">
{forEach agents renderAgentOption}
</select>
</div>
<div>{(textField #artifactType) { fieldLabel = "Artifact Type", placeholder = "e.g. requirement_candidate, annotation, decision_record" }}</div>
<div>
<label class="block text-sm font-medium text-gray-700 mb-2">Allowed Actions</label>
<div class="space-y-2">
{forEach allowedActionOptions renderActionOption}
</div>
</div>
<div class="flex gap-3 pt-2">
{submitButton { label = "Create Policy" }}
<a href={AiGovernancePoliciesAction}
class="px-4 py-2 bg-gray-100 hover:bg-gray-200 rounded-md text-sm">Cancel</a>
</div>
</div>
|]}
{renderForm policy hubs agents}
</div>
|]
renderForm :: AiGovernancePolicy -> [Hub] -> [AgentRegistration] -> Html
renderForm policy hubs agents = formFor policy [hsx|
<div class="space-y-4">
<div>
<label class="block text-sm font-medium text-gray-700 mb-1">Hub</label>
<select name="hubId" class="block w-full border-gray-300 rounded-md shadow-sm text-sm">
{forEach hubs renderHubOption}
</select>
</div>
<div>
<label class="block text-sm font-medium text-gray-700 mb-1">Agent</label>
<select name="agentRegistrationId" class="block w-full border-gray-300 rounded-md shadow-sm text-sm">
{forEach agents renderAgentOption}
</select>
</div>
<div>{(textField #artifactType) { fieldLabel = "Artifact Type", placeholder = "e.g. requirement_candidate, annotation, decision_record" }}</div>
<div>
<label class="block text-sm font-medium text-gray-700 mb-2">Allowed Actions</label>
<div class="space-y-2">
{forEach allowedActionOptions renderActionOption}
</div>
</div>
<div class="flex gap-3 pt-2">
{submitButton { label = "Create Policy" }}
<a href={AiGovernancePoliciesAction}
class="px-4 py-2 bg-gray-100 hover:bg-gray-200 rounded-md text-sm">Cancel</a>
</div>
</div>
|]

3
Web/View/Annotations/Index.hs
View File

@@ -5,6 +5,7 @@ import Generated.Types
import IHP.Prelude
import IHP.ViewPrelude
import Web.Routes ()
import Data.Coerce (coerce)
data IndexView = IndexView
{ widget :: !Widget
@@ -14,7 +15,7 @@ data IndexView = IndexView
instance View IndexView where
html IndexView { .. } =
let rootAnnotations = filter (\a -> isNothing a.parentId) annotations
childrenOf parent = filter (\a -> a.parentId == Just parent.id) annotations
childrenOf parent = filter (\a -> a.parentId == Just (coerce parent.id :: UUID)) annotations
in [hsx|
<div class="mb-6 flex items-center gap-2 text-sm text-gray-500">
<a href={WidgetsAction} class="hover:text-gray-700">Widgets</a>

2
Web/View/ApiConsumers/Edit.hs
View File

@@ -24,7 +24,7 @@ instance View EditView where
</div>
<div>
<label class="block text-sm font-medium text-gray-700 mb-1">Description</label>
<textarea name="description" class="border rounded px-3 py-2 text-sm w-full" rows="3">{maybe "" id consumer.description}</textarea>
<textarea name="description" class="border rounded px-3 py-2 text-sm w-full" rows="3">{fromMaybe "" consumer.description}</textarea>
</div>
<div>
<label class="block text-sm font-medium text-gray-700 mb-1">Linked Hub Manifest (optional)</label>

2
Web/View/ApiConsumers/New.hs
View File

@@ -23,7 +23,7 @@ instance View NewView where
</div>
<div>
<label class="block text-sm font-medium text-gray-700 mb-1">Description</label>
<textarea name="description" class="border rounded px-3 py-2 text-sm w-full" rows="3">{maybe "" id consumer.description}</textarea>
<textarea name="description" class="border rounded px-3 py-2 text-sm w-full" rows="3">{fromMaybe "" consumer.description}</textarea>
</div>
<div>
<label class="block text-sm font-medium text-gray-700 mb-1">Linked Hub Manifest (optional)</label>

1
Web/View/ArchiveRecords/Show.hs
View File

@@ -5,6 +5,7 @@ import Generated.Types
import IHP.Prelude
import IHP.ViewPrelude
import Web.Routes ()
import Data.Coerce (coerce)
data ShowView = ShowView
{ record :: !ArchiveRecord

2
Web/View/CollectiveProposals/Index.hs
View File

@@ -1,6 +1,6 @@
module Web.View.CollectiveProposals.Index where
import IHP.ViewPrelude
import Web.View.Prelude
data IndexView = IndexView
{ proposals :: ![CollectiveProposal] }

2
Web/View/CollectiveProposals/Show.hs
View File

@@ -1,6 +1,6 @@
module Web.View.CollectiveProposals.Show where
import IHP.ViewPrelude
import Web.View.Prelude
import Web.View.CollectiveProposals.Index (consensusBadge)
import Data.Aeson (Value)

2
Web/View/DecisionRecords/New.hs
View File

@@ -27,7 +27,7 @@ instance View NewView where
</div>
|]
renderForm :: DecisionRecord -> [Requirement] -> [RequirementCandidate] -> [User] -> action -> Html
renderForm :: HasPath action => DecisionRecord -> [Requirement] -> [RequirementCandidate] -> [User] -> action -> Html
renderForm record requirements candidates users submitAction = [hsx|
<form method="POST" action={submitAction} class="bg-white rounded-lg border border-gray-200 px-6 py-5 space-y-4">
<div>

2
Web/View/DecisionRecords/Show.hs
View File

@@ -259,7 +259,7 @@ renderEvalSummary ev = [hsx|
|]
starsFor :: Int16 -> Text
starsFor n = pack (Prelude.replicate (fromIntegral n) '★') <> pack (Prelude.replicate (5 - fromIntegral n) '☆')
starsFor n = pack (replicate (fromIntegral n) '★') <> pack (replicate (5 - fromIntegral n) '☆')
scoreClass :: Int16 -> Text
scoreClass n

2
Web/View/DeploymentRecords/Index.hs
View File

@@ -84,7 +84,7 @@ renderScoreBadge score = [hsx|
|]
starsFor :: Int16 -> Text
starsFor n = pack (Prelude.replicate (fromIntegral n) '★') <> pack (Prelude.replicate (5 - fromIntegral n) '☆')
starsFor n = pack (replicate (fromIntegral n) '★') <> pack (replicate (5 - fromIntegral n) '☆')
scoreClass :: Int16 -> Text
scoreClass n

2
Web/View/DeploymentRecords/Show.hs
View File

@@ -329,7 +329,7 @@ scoreClass n
| otherwise = "bg-green-100 text-green-800"
starsFor :: Int16 -> Text
starsFor n = pack (Prelude.replicate (fromIntegral n) '★') <> pack (Prelude.replicate (5 - fromIntegral n) '☆')
starsFor n = pack (replicate (fromIntegral n) '★') <> pack (replicate (5 - fromIntegral n) '☆')
userName :: [User] -> Maybe (Id User) -> Text
userName _ Nothing = "—"

2
Web/View/FederatedGovernance/Dashboard.hs
View File

@@ -184,7 +184,7 @@ instance View FederatedGovernanceDashboardView where
-- ── Panel 5: Archive activity ─────────────────────────────────────
archiveByType = List.sortBy (\a b -> compare (fst a) (fst b))
$ map (\grp -> ((head grp).subjectType, length grp))
$ map (\grp -> (maybe "" (.subjectType) (head grp), length grp))
$ List.groupBy (\a b -> a.subjectType == b.subjectType)
$ List.sortBy (\a b -> compare a.subjectType b.subjectType) recentArchives

2
Web/View/InstitutionalKnowledge/Index.hs
View File

@@ -1,6 +1,6 @@
module Web.View.InstitutionalKnowledge.Index where
import IHP.ViewPrelude
import Web.View.Prelude
data IndexView = IndexView
{ entries :: ![InstitutionalKnowledgeEntry]

2
Web/View/InstitutionalKnowledge/Show.hs
View File

@@ -1,6 +1,6 @@
module Web.View.InstitutionalKnowledge.Show where
import IHP.ViewPrelude
import Web.View.Prelude
data ShowView = ShowView
{ entry :: !InstitutionalKnowledgeEntry

2
Web/View/LearningDashboard/Show.hs
View File

@@ -1,6 +1,6 @@
module Web.View.LearningDashboard.Show where
import IHP.ViewPrelude
import Web.View.Prelude
import Data.Time (diffUTCTime, getCurrentTime, nominalDay)
data ShowView = ShowView

2
Web/View/LineageEnrichment/Index.hs
View File

@@ -1,6 +1,6 @@
module Web.View.LineageEnrichment.Index where
import IHP.ViewPrelude
import Web.View.Prelude
data IndexView = IndexView
{ hubs :: ![Hub]

2
Web/View/ModelRoutingPolicies/Index.hs
View File

@@ -1,6 +1,6 @@
module Web.View.ModelRoutingPolicies.Index where
import IHP.ViewPrelude
import Web.View.Prelude
data IndexView = IndexView
{ policies :: ![ModelRoutingPolicy]

61
Web/View/ModelRoutingPolicies/New.hs
View File

@@ -1,6 +1,6 @@
module Web.View.ModelRoutingPolicies.New where
import IHP.ViewPrelude
import Web.View.Prelude
data NewView = NewView
{ policy :: !ModelRoutingPolicy
@@ -21,37 +21,40 @@ instance View NewView where
html NewView { .. } = [hsx|
<div class="p-6 max-w-xl">
<h1 class="text-2xl font-bold text-gray-900 mb-6">Add Routing Policy</h1>
{formFor policy [hsx|
<div class="space-y-4">
<div>
<label class="block text-sm font-medium text-gray-700 mb-1">Hub</label>
<select name="hubId" class="block w-full border-gray-300 rounded-md shadow-sm text-sm">
{forEach hubs renderHubOption}
</select>
</div>
<div>
<label class="block text-sm font-medium text-gray-700 mb-1">Task Type</label>
<select name="taskType" class="block w-full border-gray-300 rounded-md shadow-sm text-sm">
{forEach taskTypeOptions renderTaskTypeOption}
</select>
</div>
<div>
<label class="block text-sm font-medium text-gray-700 mb-1">Agent</label>
<select name="agentRegistrationId" class="block w-full border-gray-300 rounded-md shadow-sm text-sm">
{forEach agents renderAgentOption}
</select>
</div>
<div>{(numberField #priority) { fieldLabel = "Priority (higher wins)", placeholder = "0" }}</div>
<div class="flex gap-3 pt-2">
{submitButton { label = "Create Policy" }}
<a href={ModelRoutingPoliciesAction}
class="px-4 py-2 bg-gray-100 hover:bg-gray-200 rounded-md text-sm">Cancel</a>
</div>
</div>
|]}
{renderForm policy hubs agents}
</div>
|]
renderForm :: ModelRoutingPolicy -> [Hub] -> [AgentRegistration] -> Html
renderForm policy hubs agents = formFor policy [hsx|
<div class="space-y-4">
<div>
<label class="block text-sm font-medium text-gray-700 mb-1">Hub</label>
<select name="hubId" class="block w-full border-gray-300 rounded-md shadow-sm text-sm">
{forEach hubs renderHubOption}
</select>
</div>
<div>
<label class="block text-sm font-medium text-gray-700 mb-1">Task Type</label>
<select name="taskType" class="block w-full border-gray-300 rounded-md shadow-sm text-sm">
{forEach taskTypeOptions renderTaskTypeOption}
</select>
</div>
<div>
<label class="block text-sm font-medium text-gray-700 mb-1">Agent</label>
<select name="agentRegistrationId" class="block w-full border-gray-300 rounded-md shadow-sm text-sm">
{forEach agents renderAgentOption}
</select>
</div>
<div>{(numberField #priority) { fieldLabel = "Priority (higher wins)", placeholder = "0" }}</div>
<div class="flex gap-3 pt-2">
{submitButton { label = "Create Policy" }}
<a href={ModelRoutingPoliciesAction}
class="px-4 py-2 bg-gray-100 hover:bg-gray-200 rounded-md text-sm">Cancel</a>
</div>
</div>
|]
renderHubOption :: Hub -> Html
renderHubOption h = [hsx|<option value={show h.id}>{h.name}</option>|]

2
Web/View/OutcomeCorrelations/Index.hs
View File

@@ -1,6 +1,6 @@
module Web.View.OutcomeCorrelations.Index where
import IHP.ViewPrelude
import Web.View.Prelude
data IndexView = IndexView
{ correlations :: ![OutcomeCorrelation]

2
Web/View/PatternPerformance/Index.hs
View File

@@ -1,6 +1,6 @@
module Web.View.PatternPerformance.Index where
import IHP.ViewPrelude
import Web.View.Prelude
data IndexView = IndexView
{ records :: ![PatternPerformanceRecord]

13
Web/View/Prelude.hs
View File

@@ -10,3 +10,16 @@ import Generated.Types
import IHP.Prelude
import IHP.ViewPrelude
import Web.Routes ()
-- | Allow [(Text, Text)] option lists in selectField/radioField.
-- The first element is the display label; the second is the stored value.
instance CanSelect (Text, Text) where
type SelectValue (Text, Text) = Text
selectValue (_, v) = v
selectLabel (l, _) = l
-- | Allow [(Text, Id' tag)] option lists (e.g. hub selectors) in selectField.
instance CanSelect (Text, Id' tag) where
type SelectValue (Text, Id' tag) = Id' tag
selectValue (_, v) = v
selectLabel (l, _) = l

44
Web/View/TypeRegistries/AnnotationCategories.hs
View File

@@ -93,7 +93,25 @@ instance View ShowAnnotationCategoryView where
</div>
|]
typeForm :: AnnotationCategoryRegistry -> [Hub] -> Bool -> Html
instance View NewAnnotationCategoryView where
html NewAnnotationCategoryView { .. } = [hsx|
<div class="mb-4">
<a href={AnnotationCategoryRegistryAction} class="text-sm text-gray-500 hover:text-gray-700">← Annotation Categories</a>
</div>
<h1 class="text-xl font-semibold mb-6">Register Annotation Category</h1>
{formFor entry (typeForm entry hubs True)}
|]
instance View EditAnnotationCategoryView where
html EditAnnotationCategoryView { .. } = [hsx|
<div class="mb-4">
<a href={AnnotationCategoryRegistryAction} class="text-sm text-gray-500 hover:text-gray-700">← Annotation Categories</a>
</div>
<h1 class="text-xl font-semibold mb-6">Edit Annotation Category</h1>
{formFor entry (typeForm entry hubs False)}
|]
typeForm :: (?context :: ControllerContext, ?formContext :: FormContext AnnotationCategoryRegistry) => AnnotationCategoryRegistry -> [Hub] -> Bool -> Html
typeForm entry hubs isNew = [hsx|
<div class="bg-white rounded-lg border border-gray-200 p-6 max-w-lg">
<div class="space-y-4">
@@ -119,29 +137,7 @@ typeForm entry hubs isNew = [hsx|
</div>
|]
instance View NewAnnotationCategoryView where
html NewAnnotationCategoryView { .. } = [hsx|
<div class="mb-4">
<a href={AnnotationCategoryRegistryAction} class="text-sm text-gray-500 hover:text-gray-700">← Annotation Categories</a>
</div>
<h1 class="text-xl font-semibold mb-6">Register Annotation Category</h1>
<form method="POST" action={CreateAnnotationCategoryAction}>
{typeForm entry hubs True}
</form>
|]
instance View EditAnnotationCategoryView where
html EditAnnotationCategoryView { .. } = [hsx|
<div class="mb-4">
<a href={AnnotationCategoryRegistryAction} class="text-sm text-gray-500 hover:text-gray-700">← Annotation Categories</a>
</div>
<h1 class="text-xl font-semibold mb-6">Edit Annotation Category</h1>
<form method="POST" action={UpdateAnnotationCategoryAction (entry.id)}>
{typeForm entry hubs False}
</form>
|]
renderNameField :: Bool -> Text -> Html
renderNameField :: (?context :: ControllerContext, ?formContext :: FormContext AnnotationCategoryRegistry) => Bool -> Text -> Html
renderNameField True _ = [hsx|
<div>
<label class="block text-sm font-medium text-gray-700 mb-1">Name <span class="text-gray-400 text-xs">(permanent, lowercase-underscored)</span></label>

44
Web/View/TypeRegistries/EventTypes.hs
View File

@@ -93,7 +93,25 @@ instance View ShowEventTypeView where
</div>
|]
typeForm :: EventTypeRegistry -> [Hub] -> Bool -> Html
instance View NewEventTypeView where
html NewEventTypeView { .. } = [hsx|
<div class="mb-4">
<a href={EventTypeRegistryAction} class="text-sm text-gray-500 hover:text-gray-700">← Event Types</a>
</div>
<h1 class="text-xl font-semibold mb-6">Register Event Type</h1>
{formFor entry (typeForm entry hubs True)}
|]
instance View EditEventTypeView where
html EditEventTypeView { .. } = [hsx|
<div class="mb-4">
<a href={EventTypeRegistryAction} class="text-sm text-gray-500 hover:text-gray-700">← Event Types</a>
</div>
<h1 class="text-xl font-semibold mb-6">Edit Event Type</h1>
{formFor entry (typeForm entry hubs False)}
|]
typeForm :: (?context :: ControllerContext, ?formContext :: FormContext EventTypeRegistry) => EventTypeRegistry -> [Hub] -> Bool -> Html
typeForm entry hubs isNew = [hsx|
<div class="bg-white rounded-lg border border-gray-200 p-6 max-w-lg">
<div class="space-y-4">
@@ -119,29 +137,7 @@ typeForm entry hubs isNew = [hsx|
</div>
|]
instance View NewEventTypeView where
html NewEventTypeView { .. } = [hsx|
<div class="mb-4">
<a href={EventTypeRegistryAction} class="text-sm text-gray-500 hover:text-gray-700">← Event Types</a>
</div>
<h1 class="text-xl font-semibold mb-6">Register Event Type</h1>
<form method="POST" action={CreateEventTypeAction}>
{typeForm entry hubs True}
</form>
|]
instance View EditEventTypeView where
html EditEventTypeView { .. } = [hsx|
<div class="mb-4">
<a href={EventTypeRegistryAction} class="text-sm text-gray-500 hover:text-gray-700">← Event Types</a>
</div>
<h1 class="text-xl font-semibold mb-6">Edit Event Type</h1>
<form method="POST" action={UpdateEventTypeAction (entry.id)}>
{typeForm entry hubs False}
</form>
|]
renderNameField :: Bool -> Text -> Html
renderNameField :: (?context :: ControllerContext, ?formContext :: FormContext EventTypeRegistry) => Bool -> Text -> Html
renderNameField True _ = [hsx|
<div>
<label class="block text-sm font-medium text-gray-700 mb-1">Name <span class="text-gray-400 text-xs">(permanent, lowercase-underscored)</span></label>

44
Web/View/TypeRegistries/PolicyScopes.hs
View File

@@ -93,7 +93,25 @@ instance View ShowPolicyScopeView where
</div>
|]
typeForm :: PolicyScopeRegistry -> [Hub] -> Bool -> Html
instance View NewPolicyScopeView where
html NewPolicyScopeView { .. } = [hsx|
<div class="mb-4">
<a href={PolicyScopeRegistryAction} class="text-sm text-gray-500 hover:text-gray-700">← Policy Scopes</a>
</div>
<h1 class="text-xl font-semibold mb-6">Register Policy Scope</h1>
{formFor entry (typeForm entry hubs True)}
|]
instance View EditPolicyScopeView where
html EditPolicyScopeView { .. } = [hsx|
<div class="mb-4">
<a href={PolicyScopeRegistryAction} class="text-sm text-gray-500 hover:text-gray-700">← Policy Scopes</a>
</div>
<h1 class="text-xl font-semibold mb-6">Edit Policy Scope</h1>
{formFor entry (typeForm entry hubs False)}
|]
typeForm :: (?context :: ControllerContext, ?formContext :: FormContext PolicyScopeRegistry) => PolicyScopeRegistry -> [Hub] -> Bool -> Html
typeForm entry hubs isNew = [hsx|
<div class="bg-white rounded-lg border border-gray-200 p-6 max-w-lg">
<div class="space-y-4">
@@ -119,29 +137,7 @@ typeForm entry hubs isNew = [hsx|
</div>
|]
instance View NewPolicyScopeView where
html NewPolicyScopeView { .. } = [hsx|
<div class="mb-4">
<a href={PolicyScopeRegistryAction} class="text-sm text-gray-500 hover:text-gray-700">← Policy Scopes</a>
</div>
<h1 class="text-xl font-semibold mb-6">Register Policy Scope</h1>
<form method="POST" action={CreatePolicyScopeAction}>
{typeForm entry hubs True}
</form>
|]
instance View EditPolicyScopeView where
html EditPolicyScopeView { .. } = [hsx|
<div class="mb-4">
<a href={PolicyScopeRegistryAction} class="text-sm text-gray-500 hover:text-gray-700">← Policy Scopes</a>
</div>
<h1 class="text-xl font-semibold mb-6">Edit Policy Scope</h1>
<form method="POST" action={UpdatePolicyScopeAction (entry.id)}>
{typeForm entry hubs False}
</form>
|]
renderNameField :: Bool -> Text -> Html
renderNameField :: (?context :: ControllerContext, ?formContext :: FormContext PolicyScopeRegistry) => Bool -> Text -> Html
renderNameField True _ = [hsx|
<div>
<label class="block text-sm font-medium text-gray-700 mb-1">Name <span class="text-gray-400 text-xs">(permanent, lowercase-hyphenated)</span></label>

44
Web/View/TypeRegistries/WidgetTypes.hs
View File

@@ -94,7 +94,25 @@ instance View ShowWidgetTypeView where
</div>
|]
typeForm :: WidgetTypeRegistry -> [Hub] -> Bool -> Html
instance View NewWidgetTypeView where
html NewWidgetTypeView { .. } = [hsx|
<div class="mb-4">
<a href={WidgetTypeRegistryAction} class="text-sm text-gray-500 hover:text-gray-700">← Widget Types</a>
</div>
<h1 class="text-xl font-semibold mb-6">Register Widget Type</h1>
{formFor entry (typeForm entry hubs True)}
|]
instance View EditWidgetTypeView where
html EditWidgetTypeView { .. } = [hsx|
<div class="mb-4">
<a href={WidgetTypeRegistryAction} class="text-sm text-gray-500 hover:text-gray-700">← Widget Types</a>
</div>
<h1 class="text-xl font-semibold mb-6">Edit Widget Type</h1>
{formFor entry (typeForm entry hubs False)}
|]
typeForm :: (?context :: ControllerContext, ?formContext :: FormContext WidgetTypeRegistry) => WidgetTypeRegistry -> [Hub] -> Bool -> Html
typeForm entry hubs isNew = [hsx|
<div class="bg-white rounded-lg border border-gray-200 p-6 max-w-lg">
<div class="space-y-4">
@@ -120,29 +138,7 @@ typeForm entry hubs isNew = [hsx|
</div>
|]
instance View NewWidgetTypeView where
html NewWidgetTypeView { .. } = [hsx|
<div class="mb-4">
<a href={WidgetTypeRegistryAction} class="text-sm text-gray-500 hover:text-gray-700">← Widget Types</a>
</div>
<h1 class="text-xl font-semibold mb-6">Register Widget Type</h1>
<form method="POST" action={CreateWidgetTypeAction}>
{typeForm entry hubs True}
</form>
|]
instance View EditWidgetTypeView where
html EditWidgetTypeView { .. } = [hsx|
<div class="mb-4">
<a href={WidgetTypeRegistryAction} class="text-sm text-gray-500 hover:text-gray-700">← Widget Types</a>
</div>
<h1 class="text-xl font-semibold mb-6">Edit Widget Type</h1>
<form method="POST" action={UpdateWidgetTypeAction (entry.id)}>
{typeForm entry hubs False}
</form>
|]
renderNameField :: Bool -> Text -> Html
renderNameField :: (?context :: ControllerContext, ?formContext :: FormContext WidgetTypeRegistry) => Bool -> Text -> Html
renderNameField True _ = [hsx|
<div>
<label class="block text-sm font-medium text-gray-700 mb-1">Name <span class="text-gray-400 text-xs">(permanent identifier, lowercase-hyphenated)</span></label>

5
Web/View/WebhookSubscriptions/New.hs
View File

@@ -27,7 +27,7 @@ instance View NewView where
<h1 class="text-2xl font-semibold mb-2">New Webhook Subscription</h1>
<p class="text-sm text-gray-500 mb-6">Consumer: <strong>{consumer.name}</strong></p>
<form method="POST" action={CreateWebhookSubscriptionAction} class="space-y-4">
{hiddenField #id}
<input type="hidden" name="id" value={show subscription.id} />
<input type="hidden" name="apiConsumerId" value={show consumer.id} />
<div>
<label class="block text-sm font-medium text-gray-700 mb-1">Event Topic *</label>
@@ -37,7 +37,8 @@ instance View NewView where
</div>
<div>
<label class="block text-sm font-medium text-gray-700 mb-1">Target URL *</label>
{textField #targetUrl}
<input type="text" name="targetUrl" value={subscription.targetUrl}
class="border rounded px-3 py-2 text-sm w-full" required />
<p class="text-xs text-gray-400 mt-1">Must be HTTPS. IHF will POST JSON payloads with X-IHF-Signature header.</p>
</div>
<div class="pt-2 flex gap-3">

4
Web/View/WidgetAdapterSpecs/New.hs
View File

@@ -85,8 +85,8 @@ renderForm spec envelopes reportings = formFor spec [hsx|
</div>
|]
renderEnvelopeOption :: WidgetEnvelopeContract -> Html
renderEnvelopeOption :: EnvelopeEmissionContract -> Html
renderEnvelopeOption e = [hsx|<option value={tshow e.id}>v{e.contractVersion}</option>|]
renderReportingOption :: WidgetReportingContract -> Html
renderReportingOption :: InteractionReportingContract -> Html
renderReportingOption r = [hsx|<option value={tshow r.id}>v{r.contractVersion}</option>|]

11
Web/View/WidgetOwnerships/Edit.hs
View File

@@ -22,7 +22,13 @@ instance View EditView where
renderForm :: WidgetOwnership -> [Hub] -> Html
renderForm ownership hubs = formFor ownership [hsx|
{(selectField #stewardHubId hubs){ fieldLabel = "Steward Hub (optional)" }}
<div>
<label class="ihp-form-label">Steward Hub (optional)</label>
<select name="stewardHubId" class="ihp-form-field">
<option value="">— None —</option>
{forEach hubs renderHubOption}
</select>
</div>
{(selectField #ownershipType ownershipTypes){ fieldLabel = "Ownership Type" }}
{dateTimeField #effectiveUntil}
{textareaField #notes}
@@ -31,3 +37,6 @@ renderForm ownership hubs = formFor ownership [hsx|
where
ownershipTypes :: [(Text, Text)]
ownershipTypes = [("local","local"), ("delegated","delegated"), ("global","global")]
renderHubOption :: Hub -> Html
renderHubOption h = [hsx|<option value={tshow h.id}>{h.name}</option>|]

11
Web/View/WidgetOwnerships/New.hs
View File

@@ -24,7 +24,13 @@ renderForm :: WidgetOwnership -> [Widget] -> [Hub] -> Html
renderForm ownership widgets hubs = formFor ownership [hsx|
{(selectField #widgetId widgets) { fieldLabel = "Widget" }}
{(selectField #ownerHubId hubs) { fieldLabel = "Owner Hub" }}
{(selectField #stewardHubId hubs){ fieldLabel = "Steward Hub (optional)" }}
<div>
<label class="ihp-form-label">Steward Hub (optional)</label>
<select name="stewardHubId" class="ihp-form-field">
<option value="">— None —</option>
{forEach hubs renderHubOption}
</select>
</div>
{(selectField #ownershipType ownershipTypes){ fieldLabel = "Ownership Type" }}
{dateTimeField #effectiveFrom}
{dateTimeField #effectiveUntil}
@@ -34,3 +40,6 @@ renderForm ownership widgets hubs = formFor ownership [hsx|
where
ownershipTypes :: [(Text, Text)]
ownershipTypes = [("local","local"), ("delegated","delegated"), ("global","global")]
renderHubOption :: Hub -> Html
renderHubOption h = [hsx|<option value={tshow h.id}>{h.name}</option>|]

1
Web/View/WidgetPatterns/Edit.hs
View File

@@ -23,7 +23,6 @@ instance View EditView where
<h1 class="text-2xl font-semibold mb-6">Edit Pattern</h1>
<form method="POST" action={UpdateWidgetPatternAction (pattern.id)}>
{csrfTokenFormField}
<div class="space-y-4 max-w-lg">
<div>
<label class="block text-sm font-medium text-gray-700 mb-1">Name</label>

1
Web/View/WidgetPatterns/New.hs
View File

@@ -27,7 +27,6 @@ instance View NewView where
renderForm :: WidgetPattern -> [Hub] -> [(Text, Text)] -> Html
renderForm pattern hubs widgetTypes = [hsx|
<form method="POST" action={CreateWidgetPatternAction}>
{csrfTokenFormField}
<div class="space-y-4 max-w-lg">
<div>
<label class="block text-sm font-medium text-gray-700 mb-1">Name</label>

3
Web/View/WidgetPatterns/Show.hs
View File

@@ -139,14 +139,13 @@ renderPublishNewVersionForm True pid = [hsx|
<div class="border-t border-gray-200 pt-4">
<h2 class="text-base font-semibold mb-3">Publish New Version</h2>
<form method="POST" action={PublishNewVersionAction (pid)}>
{csrfTokenFormField}
<div class="mb-3">
<label class="block text-sm font-medium text-gray-700 mb-1">
Definition (JSON)
</label>
<textarea name="definition" rows="4"
class="w-full border border-gray-300 rounded px-3 py-2 text-sm font-mono"
placeholder='{"key": "value"}'></textarea>
placeholder="JSON definition"></textarea>
</div>
<div class="mb-3">
<label class="block text-sm font-medium text-gray-700 mb-1">Changelog</label>

53
Web/View/Widgets/Show.hs
View File

@@ -33,24 +33,7 @@ instance View ShowView where
{if isRegressed then renderRegressionBanner else mempty}
{widgetEnvelope widget [hsx|
<div class="flex items-center justify-between mb-4">
<div>
<h1 class="text-2xl font-semibold">{widget.name}</h1>
<p class="text-sm text-gray-500 mt-0.5">
{widget.widgetType}
<span class="ml-2 text-xs bg-gray-100 px-1.5 py-0.5 rounded">{widget.policyScope}</span>
<span class="ml-2 text-xs bg-green-100 text-green-700 px-1.5 py-0.5 rounded">{widget.status}</span>
<span class="ml-2 text-xs text-gray-400">v{show widget.version}</span>
{renderAdapterBadge mAdapterSpec}
</p>
</div>
<a href={EditWidgetAction (widget.id)}
class="text-sm border border-gray-300 px-3 py-1.5 rounded hover:bg-gray-50">
Edit
</a>
</div>
|]}
{widgetEnvelope widget widgetHeader}
<div class="grid grid-cols-3 gap-4 mb-8 mt-6">
<div class="bg-white rounded-lg border border-gray-200 p-4">
@@ -132,14 +115,32 @@ instance View ShowView where
</div>
</section>
|]
where
rootAnnotations = filter (\a -> isNothing a.parentId) annotations
childrenOf parent = filter (\a -> a.parentId == Just parent.id) annotations
categoryBreakdown =
[ (cat, length (filter (\a -> a.category == cat) annotations))
| cat <- ["friction","defect","wish","policy_concern","doc_gap","trust","other"]
, any (\a -> a.category == cat) annotations
]
where
widgetHeader = [hsx|
<div class="flex items-center justify-between mb-4">
<div>
<h1 class="text-2xl font-semibold">{widget.name}</h1>
<p class="text-sm text-gray-500 mt-0.5">
{widget.widgetType}
<span class="ml-2 text-xs bg-gray-100 px-1.5 py-0.5 rounded">{widget.policyScope}</span>
<span class="ml-2 text-xs bg-green-100 text-green-700 px-1.5 py-0.5 rounded">{widget.status}</span>
<span class="ml-2 text-xs text-gray-400">v{show widget.version}</span>
{renderAdapterBadge mAdapterSpec}
</p>
</div>
<a href={EditWidgetAction (widget.id)}
class="text-sm border border-gray-300 px-3 py-1.5 rounded hover:bg-gray-50">
Edit
</a>
</div>
|]
rootAnnotations = filter (\a -> isNothing a.parentId) annotations
childrenOf parent = filter (\a -> a.parentId == Just parent.id) annotations
categoryBreakdown =
[ (cat, length (filter (\a -> a.category == cat) annotations))
| cat <- ["friction","defect","wish","policy_concern","doc_gap","trust","other"]
, any (\a -> a.category == cat) annotations
]
renderAnnotation :: (Annotation -> [Annotation]) -> Annotation -> Html
renderAnnotation childrenOf a = [hsx|

12
flake.nix
View File

@@ -55,8 +55,8 @@
ihp-hspec
];
# Hoogle documentation server (enabled by default on port 8002)
# withHoogle = false; # Disable to save memory
# Hoogle documentation server — disabled to save ~400 MB on constrained host
withHoogle = false;
# Disable relation type machinery for faster compilation
# relationSupport = false;
@@ -85,6 +85,14 @@
# PostgreSQL extensions
# services.postgres.extensions = extensions: [ extensions.postgis ];
# Resource limits for constrained host (2 CPU, ~3.8 GiB RAM).
# -A32m: smaller minor heap (reduces GC pressure).
# -M2g: hard heap ceiling (prevents OOM on large compiles).
# Note: -N1 is intentionally omitted — it requires -threaded and
# would break build-generated-code and similar tools.
# GHC parallel module compilation is capped via -j1 in .ghci.
env.GHCRTS = "-A32m -M2g";
# Custom processes that don't appear in https://devenv.sh/reference/options/
processes = {
tailwind.exec = "tailwindcss -c tailwind/tailwind.config.js -i ./tailwind/app.css -o static/app.css --watch=always";

118
static/app.css
View File

@@ -667,6 +667,22 @@ video {
margin-top: 2rem;
}
.mb-16 {
margin-bottom: 4rem;
}
.mt-10 {
margin-top: 2.5rem;
}
.mb-12 {
margin-bottom: 3rem;
}
.mb-10 {
margin-bottom: 2.5rem;
}
.block {
display: block;
}
@@ -683,6 +699,10 @@ video {
display: flex;
}
.inline-flex {
display: inline-flex;
}
.table {
display: table;
}
@@ -715,6 +735,14 @@ video {
height: 2rem;
}
.h-7 {
height: 1.75rem;
}
.h-6 {
height: 1.5rem;
}
.w-16 {
width: 4rem;
}
@@ -747,6 +775,14 @@ video {
width: 100%;
}
.w-7 {
width: 1.75rem;
}
.w-6 {
width: 1.5rem;
}
.min-w-full {
min-width: 100%;
}
@@ -799,6 +835,14 @@ video {
cursor: pointer;
}
.list-inside {
list-style-position: inside;
}
.list-disc {
list-style-type: disc;
}
.grid-cols-1 {
grid-template-columns: repeat(1, minmax(0, 1fr));
}
@@ -992,6 +1036,10 @@ video {
border-radius: 0.125rem;
}
.rounded-xl {
border-radius: 0.75rem;
}
.border {
border-width: 1px;
}
@@ -1127,6 +1175,11 @@ video {
border-color: rgb(253 224 71 / var(--tw-border-opacity, 1));
}
.border-emerald-200 {
--tw-border-opacity: 1;
border-color: rgb(167 243 208 / var(--tw-border-opacity, 1));
}
.bg-amber-100 {
--tw-bg-opacity: 1;
background-color: rgb(254 243 199 / var(--tw-bg-opacity, 1));
@@ -1342,6 +1395,11 @@ video {
background-color: rgb(234 179 8 / var(--tw-bg-opacity, 1));
}
.bg-emerald-50 {
--tw-bg-opacity: 1;
background-color: rgb(236 253 245 / var(--tw-bg-opacity, 1));
}
.p-3 {
padding: 0.75rem;
}
@@ -1437,6 +1495,16 @@ video {
padding-bottom: 2rem;
}
.py-12 {
padding-top: 3rem;
padding-bottom: 3rem;
}
.py-10 {
padding-top: 2.5rem;
padding-bottom: 2.5rem;
}
.pb-1 {
padding-bottom: 0.25rem;
}
@@ -1461,6 +1529,10 @@ video {
padding-top: 1rem;
}
.pb-2 {
padding-bottom: 0.5rem;
}
.text-left {
text-align: left;
}
@@ -1512,6 +1584,11 @@ video {
line-height: 1rem;
}
.text-4xl {
font-size: 2.25rem;
line-height: 2.5rem;
}
.font-bold {
font-weight: 700;
}
@@ -1743,6 +1820,26 @@ video {
color: rgb(133 77 14 / var(--tw-text-opacity, 1));
}
.text-emerald-600 {
--tw-text-opacity: 1;
color: rgb(5 150 105 / var(--tw-text-opacity, 1));
}
.text-emerald-700 {
--tw-text-opacity: 1;
color: rgb(4 120 87 / var(--tw-text-opacity, 1));
}
.text-green-400 {
--tw-text-opacity: 1;
color: rgb(74 222 128 / var(--tw-text-opacity, 1));
}
.text-gray-200 {
--tw-text-opacity: 1;
color: rgb(229 231 235 / var(--tw-text-opacity, 1));
}
.underline {
text-decoration-line: underline;
}
@@ -1771,6 +1868,12 @@ video {
filter: var(--tw-blur) var(--tw-brightness) var(--tw-contrast) var(--tw-grayscale) var(--tw-hue-rotate) var(--tw-invert) var(--tw-saturate) var(--tw-sepia) var(--tw-drop-shadow);
}
.transition-colors {
transition-property: color, background-color, border-color, text-decoration-color, fill, stroke;
transition-timing-function: cubic-bezier(0.4, 0, 0.2, 1);
transition-duration: 150ms;
}
.last\:border-0:last-child {
border-width: 0px;
}
@@ -1965,6 +2068,11 @@ video {
color: rgb(153 27 27 / var(--tw-text-opacity, 1));
}
.hover\:text-indigo-600:hover {
--tw-text-opacity: 1;
color: rgb(79 70 229 / var(--tw-text-opacity, 1));
}
.hover\:underline:hover {
text-decoration-line: underline;
}
@@ -1996,6 +2104,16 @@ video {
}
}
@media (min-width: 768px) {
.md\:grid-cols-3 {
grid-template-columns: repeat(3, minmax(0, 1fr));
}
.md\:grid-cols-4 {
grid-template-columns: repeat(4, minmax(0, 1fr));
}
}
@media (min-width: 1024px) {
.lg\:col-span-2 {
grid-column: span 2 / span 2;