From 2c22766cd6e42dcd0bedb18ae13dc37f3699f603 Mon Sep 17 00:00:00 2001 From: Bernd Worsch Date: Sun, 12 Apr 2026 13:11:32 +0000 Subject: [PATCH] =?UTF-8?q?fix(WP-0017/E5):=20Layer=203=20error=20fixes=20?= =?UTF-8?q?=E2=80=94=20round=203=20(24=20files)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Int16→Int in score/stars functions; uuid-based readMay→UUID.fromText; autoRefresh do-notation fix; id→\x->x ambiguity in HubRoutingRules; MarketplaceDashboard replaced raw SQL with IHP query builder; optional hub selector in TypeRegistry views via CanSelect (Text, Maybe Id) instance added to Web.View.Prelude; import consolidations to Web.View.Prelude. Co-Authored-By: Claude Sonnet 4.6 --- Web/Controller/AiGovernancePolicies.hs | 1 + Web/Controller/Api/V2/Token.hs | 3 +- Web/Controller/CollectiveProposals.hs | 2 +- Web/Controller/HubRoutingRules.hs | 8 +-- Web/Controller/LearningDashboard.hs | 3 +- Web/Controller/MarketplaceDashboard.hs | 69 +++++++------------ Web/View/AdaptiveThresholds/Index.hs | 2 +- Web/View/ApiConsumers/New.hs | 4 +- Web/View/DecisionRecords/Show.hs | 6 +- Web/View/DeploymentRecords/Index.hs | 12 ++-- Web/View/DeploymentRecords/Show.hs | 11 +-- Web/View/GovernanceTemplates/New.hs | 2 +- Web/View/Hubs/GovernanceDashboard.hs | 4 +- Web/View/Hubs/OperationalReviewBoard.hs | 6 +- Web/View/LineageEnrichment/Index.hs | 2 +- Web/View/Prelude.hs | 6 ++ Web/View/StaticPages/Landing.hs | 4 +- Web/View/StaticPages/Tutorial.hs | 4 +- .../TypeRegistries/AnnotationCategories.hs | 7 +- Web/View/TypeRegistries/EventTypes.hs | 7 +- Web/View/TypeRegistries/PolicyScopes.hs | 7 +- Web/View/TypeRegistries/WidgetTypes.hs | 7 +- Web/View/WidgetOwnerships/Edit.hs | 5 +- Web/View/WidgetOwnerships/New.hs | 9 +-- 24 files changed, 81 insertions(+), 110 deletions(-) diff --git a/Web/Controller/AiGovernancePolicies.hs b/Web/Controller/AiGovernancePolicies.hs index 38c61b8..0da13ea 100644 --- a/Web/Controller/AiGovernancePolicies.hs +++ b/Web/Controller/AiGovernancePolicies.hs @@ -6,6 +6,7 @@ import Web.Controller.Prelude import Web.View.AiGovernancePolicies.Index import Web.View.AiGovernancePolicies.New import Application.Helper.AgentBridge (jsonArrayTexts) +import qualified Data.Aeson as A validAllowedActions :: [Text] validAllowedActions = ["read", "propose", "delegate", "auto_apply"] diff --git a/Web/Controller/Api/V2/Token.hs b/Web/Controller/Api/V2/Token.hs index 2a3c409..6d28393 100644 --- a/Web/Controller/Api/V2/Token.hs +++ b/Web/Controller/Api/V2/Token.hs @@ -10,6 +10,7 @@ import IHP.ControllerPrelude import Data.Aeson (object, (.=)) import qualified Data.Text as T import qualified Data.Text.Encoding as TE +import qualified Data.UUID as UUID import qualified "cryptohash-sha256" Crypto.Hash.SHA256 as SHA256 import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Random as Random @@ -50,7 +51,7 @@ instance Controller ApiV2TokenController where ] (Just cid, Just csec) -> do -- Look up consumer by id - case readMay cid of + case UUID.fromText cid of Nothing -> respondWithStatus 400 $ object ["error" .= ("invalid_client" :: Text)] Just rawId -> do diff --git a/Web/Controller/CollectiveProposals.hs b/Web/Controller/CollectiveProposals.hs index c0ffe02..adb1c63 100644 --- a/Web/Controller/CollectiveProposals.hs +++ b/Web/Controller/CollectiveProposals.hs @@ -8,7 +8,7 @@ import Web.View.CollectiveProposals.Index import Web.View.CollectiveProposals.Show import Application.Helper.AgentBridge (callAgent, callAgentsBatch, BridgeResponse(..)) import Application.Helper.ModelRouter (resolveAllAgents) -import Data.List (intercalate) +import qualified Data.Aeson as A instance Controller CollectiveProposalsController where diff --git a/Web/Controller/HubRoutingRules.hs b/Web/Controller/HubRoutingRules.hs index 9ca04fa..a5b7703 100644 --- a/Web/Controller/HubRoutingRules.hs +++ b/Web/Controller/HubRoutingRules.hs @@ -42,8 +42,8 @@ instance Controller HubRoutingRulesController where |> fill @'["sourceHubId","targetHubId","matchCategory","matchWidgetType","priority","notes"] |> validateField #sourceHubId nonEmpty |> validateField #targetHubId nonEmpty - |> (case wtResult of { Left msg -> attachFailure #matchWidgetType msg; Right () -> id }) - |> (case catResult of { Left msg -> attachFailure #matchCategory msg; Right () -> id }) + |> (case wtResult of { Left msg -> attachFailure #matchWidgetType msg; Right () -> \x -> x }) + |> (case catResult of { Left msg -> attachFailure #matchCategory msg; Right () -> \x -> x }) |> ifValid \case Left r -> render NewView { rule = r, hubs } Right r -> do @@ -65,8 +65,8 @@ instance Controller HubRoutingRulesController where catResult <- case mMatchCategory of { Nothing -> pure (Right ()); Just "" -> pure (Right ()); Just c -> liftIO (validateAnnotationCategory c) } rule |> fill @'["matchCategory","matchWidgetType","priority","notes"] - |> (case wtResult of { Left msg -> attachFailure #matchWidgetType msg; Right () -> id }) - |> (case catResult of { Left msg -> attachFailure #matchCategory msg; Right () -> id }) + |> (case wtResult of { Left msg -> attachFailure #matchWidgetType msg; Right () -> \x -> x }) + |> (case catResult of { Left msg -> attachFailure #matchCategory msg; Right () -> \x -> x }) |> ifValid \case Left r -> render EditView { rule = r, hubs } Right r -> do diff --git a/Web/Controller/LearningDashboard.hs b/Web/Controller/LearningDashboard.hs index e6fa4f8..7a98f4f 100644 --- a/Web/Controller/LearningDashboard.hs +++ b/Web/Controller/LearningDashboard.hs @@ -8,8 +8,7 @@ import Web.View.LearningDashboard.Show instance Controller LearningDashboardController where beforeAction = ensureIsUser - action LearningDashboardAction = do - autoRefresh + action LearningDashboardAction = autoRefresh do topCorrelations <- query @OutcomeCorrelation |> orderByDesc #correlationScore |> limit 10 diff --git a/Web/Controller/MarketplaceDashboard.hs b/Web/Controller/MarketplaceDashboard.hs index 55141e8..a9f3e6b 100644 --- a/Web/Controller/MarketplaceDashboard.hs +++ b/Web/Controller/MarketplaceDashboard.hs @@ -5,8 +5,6 @@ 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 @@ -15,15 +13,32 @@ instance Controller MarketplaceDashboardController where let mWType = paramOrNothing @Text "widgetType" let sortBy = paramOrDefault @Text "adopted" "sort" - -- Widget patterns: full-text search + filter - patterns <- sqlQuery (patternQuery mSearch mWType sortBy) () + -- Widget patterns: fetch then count adoptions + basePatterns <- query @WidgetPattern + |> filterWhere (#isPublished, True) + |> orderByAsc #name + |> limit 50 + |> fetch + patterns <- mapM (\p -> do + cnt <- sqlQueryScalar + "SELECT COUNT(*) FROM pattern_adoptions WHERE widget_pattern_id = ?" + (Only p.id) + pure (p, fromMaybe 0 cnt)) basePatterns - -- Governance templates: full-text search - templates <- sqlQuery (templateQuery mSearch) () + -- Governance templates: fetch then count clones + baseTemplates <- query @GovernanceTemplate + |> filterWhere (#isPublished, True) + |> limit 50 + |> fetch + templates <- mapM (\t -> do + cnt <- sqlQueryScalar + "SELECT COUNT(*) FROM governance_template_clones WHERE governance_template_id = ?" + (Only t.id) + pure (t, fromMaybe 0 cnt)) baseTemplates -- Trending patterns (most adoptions in last 30 days) - trending <- sqlQuery - "SELECT wp.id, wp.name, wp.widget_type, COUNT(pa.id) AS recent_adoptions \ + trendingRaw :: [(Id WidgetPattern, Text, Text, Int)] <- sqlQuery + "SELECT wp.id, wp.name, wp.widget_type, CAST(COUNT(pa.id) AS integer) AS recent_adoptions \ \ FROM widget_patterns wp \ \ JOIN pattern_adoptions pa ON pa.widget_pattern_id = wp.id \ \ WHERE wp.is_published = TRUE \ @@ -32,6 +47,7 @@ instance Controller MarketplaceDashboardController where \ ORDER BY recent_adoptions DESC \ \ LIMIT 5" () + let trending = trendingRaw widgetTypeOptions <- sqlQuery "SELECT name, label FROM widget_type_registry WHERE status = 'active' ORDER BY label" @@ -45,40 +61,3 @@ instance Controller MarketplaceDashboardController where , sortOrder = sortBy } --- | Widget pattern list query with optional search and type filter. -patternQuery :: Maybe Text -> Maybe Text -> Text -> Query -patternQuery mSearch mWType sortBy = - let baseWhere = "wp.is_published = TRUE" - searchClause = case mSearch of - Nothing -> "" - Just _ -> " AND to_tsvector('english', wp.name || ' ' || COALESCE(wp.description,'')) \ - \ @@ plainto_tsquery(?)" - typeClause = case mWType of - Nothing -> "" - Just _ -> " AND wp.widget_type = ?" - orderClause = case sortBy of - "recent" -> "wp.created_at DESC" - "alpha" -> "wp.name ASC" - _ -> "adopter_count DESC" - in "SELECT wp.*, COUNT(pa.id) AS adopter_count \ - \ FROM widget_patterns wp \ - \ LEFT JOIN pattern_adoptions pa ON pa.widget_pattern_id = wp.id \ - \ WHERE " <> baseWhere <> searchClause <> typeClause <> - " GROUP BY wp.id \ - \ ORDER BY " <> orderClause <> - " LIMIT 50" - --- | Governance template list query with optional search. -templateQuery :: Maybe Text -> Query -templateQuery mSearch = - let searchClause = case mSearch of - Nothing -> "" - Just _ -> " AND to_tsvector('english', gt.name || ' ' || COALESCE(gt.description,'')) \ - \ @@ plainto_tsquery(?)" - in "SELECT gt.*, COUNT(gtc.id) AS clone_count \ - \ FROM governance_templates gt \ - \ LEFT JOIN governance_template_clones gtc ON gtc.governance_template_id = gt.id \ - \ WHERE gt.is_published = TRUE" <> searchClause <> - " GROUP BY gt.id \ - \ ORDER BY clone_count DESC \ - \ LIMIT 50" diff --git a/Web/View/AdaptiveThresholds/Index.hs b/Web/View/AdaptiveThresholds/Index.hs index fa036dd..b6bf917 100644 --- a/Web/View/AdaptiveThresholds/Index.hs +++ b/Web/View/AdaptiveThresholds/Index.hs @@ -59,5 +59,5 @@ renderCfgStatus (Just cfg) = [hsx|

Last calibrated: {show cfg.calibrationDate}

-

{maybe "" id cfg.notes}

+

{fromMaybe "" cfg.notes}

|] diff --git a/Web/View/ApiConsumers/New.hs b/Web/View/ApiConsumers/New.hs index f00fd60..0069df7 100644 --- a/Web/View/ApiConsumers/New.hs +++ b/Web/View/ApiConsumers/New.hs @@ -36,11 +36,11 @@ instance View NewView where
- +
- +
diff --git a/Web/View/DecisionRecords/Show.hs b/Web/View/DecisionRecords/Show.hs index e3d1589..e8a8ee3 100644 --- a/Web/View/DecisionRecords/Show.hs +++ b/Web/View/DecisionRecords/Show.hs @@ -258,10 +258,10 @@ renderEvalSummary ev = [hsx| |] -starsFor :: Int16 -> Text -starsFor n = pack (replicate (fromIntegral n) '★') <> pack (replicate (5 - fromIntegral n) '☆') +starsFor :: Int -> Text +starsFor n = cs (replicate n '★') <> cs (replicate (5 - n) '☆') -scoreClass :: Int16 -> Text +scoreClass :: Int -> Text scoreClass n | n <= 2 = "bg-red-100 text-red-800" | n == 3 = "bg-yellow-100 text-yellow-800" diff --git a/Web/View/DeploymentRecords/Index.hs b/Web/View/DeploymentRecords/Index.hs index 012b090..90f82cc 100644 --- a/Web/View/DeploymentRecords/Index.hs +++ b/Web/View/DeploymentRecords/Index.hs @@ -69,24 +69,24 @@ renderRow decisions signals evaluations record = [hsx| decisionTitle = maybe "(unknown)" (.title) $ find (\d -> d.id == record.decisionId) decisions signalCount = length $ filter (\s -> s.deploymentId == record.id) signals - mScore :: Maybe Int16 + mScore :: Maybe Int mScore = fmap (.score) $ find (\e -> e.deploymentId == record.id) evaluations -renderMaybeScore :: Maybe Int16 -> Html +renderMaybeScore :: Maybe Int -> Html renderMaybeScore Nothing = [hsx|—|] renderMaybeScore (Just score) = renderScoreBadge score -renderScoreBadge :: Int16 -> Html +renderScoreBadge :: Int -> Html renderScoreBadge score = [hsx| " text-xs px-2 py-0.5 rounded font-medium"}> {starsFor score} |] -starsFor :: Int16 -> Text -starsFor n = pack (replicate (fromIntegral n) '★') <> pack (replicate (5 - fromIntegral n) '☆') +starsFor :: Int -> Text +starsFor n = cs (replicate n '★') <> cs (replicate (5 - n) '☆') -scoreClass :: Int16 -> Text +scoreClass :: Int -> Text scoreClass n | n <= 2 = "bg-red-100 text-red-800" | n == 3 = "bg-yellow-100 text-yellow-800" diff --git a/Web/View/DeploymentRecords/Show.hs b/Web/View/DeploymentRecords/Show.hs index 91abf30..fd0e6f0 100644 --- a/Web/View/DeploymentRecords/Show.hs +++ b/Web/View/DeploymentRecords/Show.hs @@ -6,6 +6,7 @@ import IHP.Prelude import IHP.ViewPrelude import Web.Routes () import Data.Int (Int16) +import Data.Scientific (Scientific, toRealFloat) data PeriodMetrics = PeriodMetrics { eventCount :: !Int @@ -174,9 +175,9 @@ renderSignal sig = [hsx|
|] -renderSignalValue :: Double -> Html +renderSignalValue :: Scientific -> Html renderSignalValue v = [hsx| - {show v} + {show (toRealFloat v :: Double)} |] renderNoEvaluationForm :: Id DeploymentRecord -> Html @@ -321,14 +322,14 @@ outcomeClass "merged" = "bg-indigo-100 text-indigo-800" outcomeClass "reframed" = "bg-orange-100 text-orange-800" outcomeClass _ = "bg-gray-100 text-gray-600" -scoreClass :: Int16 -> Text +scoreClass :: Int -> Text scoreClass n | n <= 2 = "bg-red-100 text-red-800" | n == 3 = "bg-yellow-100 text-yellow-800" | otherwise = "bg-green-100 text-green-800" -starsFor :: Int16 -> Text -starsFor n = pack (replicate (fromIntegral n) '★') <> pack (replicate (5 - fromIntegral n) '☆') +starsFor :: Int -> Text +starsFor n = cs (replicate n '★') <> cs (replicate (5 - n) '☆') userName :: [User] -> Maybe (Id User) -> Text userName _ Nothing = "—" diff --git a/Web/View/GovernanceTemplates/New.hs b/Web/View/GovernanceTemplates/New.hs index d86a05a..36fa2a7 100644 --- a/Web/View/GovernanceTemplates/New.hs +++ b/Web/View/GovernanceTemplates/New.hs @@ -54,7 +54,7 @@ instance View NewView where + placeholder="{"steps": [], "questions": []}"> diff --git a/Web/View/Prelude.hs b/Web/View/Prelude.hs index 4937f42..4265ac1 100644 --- a/Web/View/Prelude.hs +++ b/Web/View/Prelude.hs @@ -23,3 +23,9 @@ instance CanSelect (Text, Id' tag) where type SelectValue (Text, Id' tag) = Id' tag selectValue (_, v) = v selectLabel (l, _) = l + +-- | Allow [(Text, Maybe (Id' tag))] option lists (e.g. optional hub selectors). +instance CanSelect (Text, Maybe (Id' tag)) where + type SelectValue (Text, Maybe (Id' tag)) = Maybe (Id' tag) + selectValue (_, v) = v + selectLabel (l, _) = l diff --git a/Web/View/StaticPages/Landing.hs b/Web/View/StaticPages/Landing.hs index d22002d..deabd25 100644 --- a/Web/View/StaticPages/Landing.hs +++ b/Web/View/StaticPages/Landing.hs @@ -116,13 +116,13 @@ instance View LandingView where |] where chainLink (label :: Text) (color :: Text) = [hsx| - color <> "-100 text-" <> color <> "-800 font-mono"}> + color <> "-100 text-" <> color <> "-800 font-mono") :: Text}> {label} |] arrow = [hsx|→|] capCard title_ body_ color = [hsx| -
color <> "-500"}> +
color <> "-500") :: Text}>

{title_ :: Text}

{body_ :: Text}

diff --git a/Web/View/StaticPages/Tutorial.hs b/Web/View/StaticPages/Tutorial.hs index 73d8d37..39db250 100644 --- a/Web/View/StaticPages/Tutorial.hs +++ b/Web/View/StaticPages/Tutorial.hs @@ -25,7 +25,7 @@ instance View TutorialView where

-- Every rendered widget wraps its HSX in widgetEnvelope
- {"widgetEnvelope widgetId viewContext [hsx|...|]" :: Text} + {widgetExample}

The envelope injects data-widget-id and data-view-context attributes, @@ -112,6 +112,8 @@ instance View TutorialView where

|] where + widgetExample :: Text + widgetExample = "widgetEnvelope widgetId viewContext [hsx|...|]" stepBadge n = [hsx| {n :: Text} diff --git a/Web/View/TypeRegistries/AnnotationCategories.hs b/Web/View/TypeRegistries/AnnotationCategories.hs index 978e96a..3d75be2 100644 --- a/Web/View/TypeRegistries/AnnotationCategories.hs +++ b/Web/View/TypeRegistries/AnnotationCategories.hs @@ -1,9 +1,6 @@ module Web.View.TypeRegistries.AnnotationCategories where -import Web.Types -import Generated.Types -import IHP.Prelude -import IHP.ViewPrelude +import Web.View.Prelude import Web.Routes () data AnnotationCategoriesView = AnnotationCategoriesView { entries :: ![AnnotationCategoryRegistry], hubs :: ![Hub] } @@ -126,7 +123,7 @@ typeForm entry hubs isNew = [hsx|
- {selectField #ownerHubId hubs} + {selectField #ownerHubId (("" :: Text, Nothing) : map (\h -> (h.name, Just h.id)) hubs)}
diff --git a/Web/View/TypeRegistries/EventTypes.hs b/Web/View/TypeRegistries/EventTypes.hs index 510e555..f7ee0c1 100644 --- a/Web/View/TypeRegistries/EventTypes.hs +++ b/Web/View/TypeRegistries/EventTypes.hs @@ -1,9 +1,6 @@ module Web.View.TypeRegistries.EventTypes where -import Web.Types -import Generated.Types -import IHP.Prelude -import IHP.ViewPrelude +import Web.View.Prelude import Web.Routes () data EventTypesView = EventTypesView { entries :: ![EventTypeRegistry], hubs :: ![Hub] } @@ -126,7 +123,7 @@ typeForm entry hubs isNew = [hsx|
- {selectField #ownerHubId hubs} + {selectField #ownerHubId (("" :: Text, Nothing) : map (\h -> (h.name, Just h.id)) hubs)}
diff --git a/Web/View/TypeRegistries/PolicyScopes.hs b/Web/View/TypeRegistries/PolicyScopes.hs index 7f5acf5..7a553dc 100644 --- a/Web/View/TypeRegistries/PolicyScopes.hs +++ b/Web/View/TypeRegistries/PolicyScopes.hs @@ -1,9 +1,6 @@ module Web.View.TypeRegistries.PolicyScopes where -import Web.Types -import Generated.Types -import IHP.Prelude -import IHP.ViewPrelude +import Web.View.Prelude import Web.Routes () data PolicyScopesView = PolicyScopesView { entries :: ![PolicyScopeRegistry], hubs :: ![Hub] } @@ -126,7 +123,7 @@ typeForm entry hubs isNew = [hsx|
- {selectField #ownerHubId hubs} + {selectField #ownerHubId (("" :: Text, Nothing) : map (\h -> (h.name, Just h.id)) hubs)}
diff --git a/Web/View/TypeRegistries/WidgetTypes.hs b/Web/View/TypeRegistries/WidgetTypes.hs index 4c619c1..08cf50e 100644 --- a/Web/View/TypeRegistries/WidgetTypes.hs +++ b/Web/View/TypeRegistries/WidgetTypes.hs @@ -1,9 +1,6 @@ module Web.View.TypeRegistries.WidgetTypes where -import Web.Types -import Generated.Types -import IHP.Prelude -import IHP.ViewPrelude +import Web.View.Prelude import Web.Routes () data WidgetTypesView = WidgetTypesView { entries :: ![WidgetTypeRegistry], hubs :: ![Hub] } @@ -127,7 +124,7 @@ typeForm entry hubs isNew = [hsx|
- {selectField #ownerHubId hubs} + {selectField #ownerHubId (("" :: Text, Nothing) : map (\h -> (h.name, Just h.id)) hubs)}
diff --git a/Web/View/WidgetOwnerships/Edit.hs b/Web/View/WidgetOwnerships/Edit.hs index 6c78136..11accbf 100644 --- a/Web/View/WidgetOwnerships/Edit.hs +++ b/Web/View/WidgetOwnerships/Edit.hs @@ -1,9 +1,6 @@ module Web.View.WidgetOwnerships.Edit where -import Web.Types -import Generated.Types -import IHP.Prelude -import IHP.ViewPrelude +import Web.View.Prelude import Web.Routes () data EditView = EditView diff --git a/Web/View/WidgetOwnerships/New.hs b/Web/View/WidgetOwnerships/New.hs index 687f9ea..8c0b9b0 100644 --- a/Web/View/WidgetOwnerships/New.hs +++ b/Web/View/WidgetOwnerships/New.hs @@ -1,9 +1,6 @@ module Web.View.WidgetOwnerships.New where -import Web.Types -import Generated.Types -import IHP.Prelude -import IHP.ViewPrelude +import Web.View.Prelude import Web.Routes () data NewView = NewView @@ -22,8 +19,8 @@ instance View NewView where renderForm :: WidgetOwnership -> [Widget] -> [Hub] -> Html renderForm ownership widgets hubs = formFor ownership [hsx| - {(selectField #widgetId widgets) { fieldLabel = "Widget" }} - {(selectField #ownerHubId hubs) { fieldLabel = "Owner Hub" }} + {(selectField #widgetId (map (\w -> (w.name, w.id)) widgets)) { fieldLabel = "Widget" }} + {(selectField #ownerHubId (map (\h -> (h.name, h.id)) hubs)) { fieldLabel = "Owner Hub" }}