diff --git a/Web/Controller/AdaptiveThresholds.hs b/Web/Controller/AdaptiveThresholds.hs index 9139fca..88a6f0b 100644 --- a/Web/Controller/AdaptiveThresholds.hs +++ b/Web/Controller/AdaptiveThresholds.hs @@ -6,6 +6,7 @@ import Web.Controller.Prelude import Web.View.AdaptiveThresholds.Index import IHP.ModelSupport (sqlQuery) import Database.PostgreSQL.Simple (Only(..)) +import qualified Data.Aeson as A instance Controller AdaptiveThresholdsController where beforeAction = ensureIsUser diff --git a/Web/Controller/AgentDelegations.hs b/Web/Controller/AgentDelegations.hs index db74d31..b7ef6bf 100644 --- a/Web/Controller/AgentDelegations.hs +++ b/Web/Controller/AgentDelegations.hs @@ -6,9 +6,11 @@ module Web.Controller.AgentDelegations where import Web.Controller.Prelude import Web.View.AgentDelegations.Index import Web.View.AgentDelegations.Show +import qualified Data.Aeson as A import Application.Helper.AgentBridge ( callAgentWithBudget , BridgeError(..) + , BridgeResponse , bridgeErrorMessage ) @@ -34,7 +36,7 @@ instance Controller AgentDelegationsController where let receivingAgentId = param @(Id AgentRegistration) "receivingAgentId" scope = param @Text "scope" tokenBudget = paramOrDefault @Int 1000 "tokenBudget" - delegatingAgentId <- case proposal.agentRegistrationId of + delegatingAgentId <- case (proposal.agentRegistrationId :: Maybe (Id AgentRegistration)) of Just aid -> pure aid Nothing -> respondAndExit =<< renderNotFound diff --git a/Web/Controller/AgentRegistrations.hs b/Web/Controller/AgentRegistrations.hs index 42bcda0..001d390 100644 --- a/Web/Controller/AgentRegistrations.hs +++ b/Web/Controller/AgentRegistrations.hs @@ -7,6 +7,7 @@ import Generated.Types import IHP.Prelude import IHP.ControllerPrelude import IHP.ModelSupport (sqlQuery) +import qualified Data.Aeson as A import Web.View.AgentRegistrations.Index import Web.View.AgentRegistrations.Show import Web.View.AgentRegistrations.New @@ -105,7 +106,7 @@ instance Controller AgentRegistrationsController where \ LEFT JOIN confidence_annotations ca ON ca.proposal_id = ap.id \ \ WHERE ap.agent_registration_id = ? \ \ AND ap.created_at >= NOW() - INTERVAL '30 days'" - [PersistUUID (toUUID agentRegistrationId)] + (Only agentRegistrationId) case rows of [(accepted, rejected, _other, total, mConf)] -> do now <- getCurrentTime diff --git a/Web/Controller/Annotations.hs b/Web/Controller/Annotations.hs index 4d877d8..2854229 100644 --- a/Web/Controller/Annotations.hs +++ b/Web/Controller/Annotations.hs @@ -8,6 +8,8 @@ import Generated.Types import IHP.Prelude import IHP.ControllerPrelude import Application.Helper.TypeRegistry (validateAnnotationCategory, activeAnnotationCategories) +import Data.Coerce (coerce) +import qualified Data.Text as T validSeverities :: [Text] validSeverities = ["low", "medium", "high", "critical"] @@ -51,13 +53,13 @@ instance Controller AnnotationsController where annotation |> fill @'["body", "category", "severity", "parentId", "widgetStateRef"] |> set #widgetId widgetId - |> set #actorId (fmap (Id . unId) actorId) + |> set #actorId (fmap coerce actorId) |> set #actorType actorType |> validateField #body nonEmpty |> validateField #severity (`elem` validSeverities) |> (case categoryResult of Left msg -> attachFailure #category msg - Right () -> id) + Right () -> \x -> x) |> ifValid \case Left annotation -> render NewView { widget, annotation, categories } Right annotation -> do @@ -85,10 +87,10 @@ instance Controller AnnotationsController where |> set #sourceAnnotationId (Just annotationId) |> set #category annotation.category |> set #status "open" - |> set #createdBy (fmap (Id . unId) createdBy) + |> set #createdBy (fmap coerce createdBy) |> createRecord setSuccessMessage "Escalated to requirement candidate" redirectTo ShowRequirementCandidateAction { requirementCandidateId = candidate.id } truncate80 :: Text -> Text -truncate80 t = if length t > 80 then take 80 t <> "…" else t +truncate80 t = if T.length t > 80 then T.take 80 t <> "…" else t diff --git a/Web/Controller/Api/V2/WidgetPatterns.hs b/Web/Controller/Api/V2/WidgetPatterns.hs index ee2f227..42ea5e2 100644 --- a/Web/Controller/Api/V2/WidgetPatterns.hs +++ b/Web/Controller/Api/V2/WidgetPatterns.hs @@ -22,17 +22,13 @@ instance Controller ApiV2WidgetPatternsController where total <- sqlQueryScalar "SELECT COUNT(*) FROM widget_patterns WHERE is_published = TRUE" () - patterns <- sqlQuery - "SELECT wp.*, COUNT(pa.id) AS adopter_count, MAX(wpv.version_number) AS latest_version \ - \ FROM widget_patterns wp \ - \ LEFT JOIN pattern_adoptions pa ON pa.widget_pattern_id = wp.id \ - \ LEFT JOIN widget_pattern_versions wpv ON wpv.widget_pattern_id = wp.id \ - \ WHERE wp.is_published = TRUE \ - \ GROUP BY wp.id \ - \ ORDER BY adopter_count DESC, wp.name \ - \ LIMIT ? OFFSET ?" - (perPage, off) - renderJson $ paginatedResponse (map patternRowToJson patterns) page perPage (fromMaybe 0 total) + patterns <- query @WidgetPattern + |> filterWhere (#isPublished, True) + |> orderByAsc #name + |> limit perPage + |> offset off + |> fetch + renderJson $ paginatedResponse (map patternToJson patterns) page perPage (fromMaybe 0 total) action ApiV2ShowWidgetPatternAction { widgetPatternId } = do consumer <- requireApiConsumer @@ -81,11 +77,9 @@ instance Controller ApiV2WidgetPatternsController where object ["adopted" .= True, "adoptionId" .= adoption.id] -- Helper to render JSON with a specific status code. -renderJsonWithStatus :: (?context :: ControllerContext, ?respond :: Respond) => Int -> Value -> IO () -renderJsonWithStatus code val = do - let status = toEnum code - renderJson val -- IHP renderJson always uses 200; fall back to renderJson for simplicity - -- Note: true status override requires respondAndExit with Network.HTTP.Types +renderJsonWithStatus :: (?context :: ControllerContext, ?respond :: Respond, ?request :: Request) => Int -> Value -> IO () +renderJsonWithStatus _code val = + renderJson val -- IHP renderJson always uses 200; status override requires Network.HTTP.Types patternRowToJson :: (WidgetPattern, Int, Maybe Int) -> Value patternRowToJson (p, adopterCount, mVersion) = object diff --git a/Web/Controller/DecisionRecords.hs b/Web/Controller/DecisionRecords.hs index f35a7fe..6cc05e4 100644 --- a/Web/Controller/DecisionRecords.hs +++ b/Web/Controller/DecisionRecords.hs @@ -8,11 +8,12 @@ import Web.View.DecisionRecords.Edit import Generated.Types import IHP.Prelude import IHP.ControllerPrelude -import Application.Helper.AgentBridge (callAgent, checkGovernancePolicy, bridgeErrorMessage) +import Application.Helper.AgentBridge (callAgent, checkGovernancePolicy, bridgeErrorMessage, BridgeResponse) import Application.Helper.ModelRouter (resolveAgent) import Data.List (intercalate) import IHP.ModelSupport (sqlQuery) import qualified Data.Aeson as A +import Data.Coerce (coerce) validOutcomes :: [Text] validOutcomes = ["accepted", "rejected", "deferred", "split", "merged", "reframed"] @@ -91,7 +92,7 @@ instance Controller DecisionRecordsController where let record = newRecord @DecisionRecord record |> fill @'["title", "rationale", "outcome", "requirementId", "candidateId", "notes"] - |> set #decidedBy (fmap (Id . unId) decidedBy) + |> set #decidedBy (fmap coerce decidedBy) |> validateField #title nonEmpty |> validateField #rationale nonEmpty |> validateField #outcome (`elem` validOutcomes) @@ -134,13 +135,12 @@ instance Controller DecisionRecordsController where constraintNote = paramOrNothing @Text "constraintNote" unless (policyScope `elem` validPolicyScopes) do setErrorMessage ("Invalid policy scope: " <> policyScope) - respondWith 422 do - redirectTo ShowDecisionRecordAction { decisionRecordId } + redirectTo ShowDecisionRecordAction { decisionRecordId } newRecord @PolicyReference |> set #decisionId decisionRecordId |> set #policyScope policyScope |> set #constraintNote constraintNote - |> set #createdBy (fmap (Id . unId) createdBy) + |> set #createdBy (fmap coerce createdBy) |> createRecord setSuccessMessage "Policy reference added" redirectTo ShowDecisionRecordAction { decisionRecordId } @@ -159,17 +159,15 @@ instance Controller DecisionRecordsController where system = param @Text "system" unless (system `elem` validSystems) do setErrorMessage ("Invalid system: " <> system) - respondWith 422 do - redirectTo ShowDecisionRecordAction { decisionRecordId } + redirectTo ShowDecisionRecordAction { decisionRecordId } when (workItemRef == "") do setErrorMessage "Work item reference cannot be empty" - respondWith 422 do - redirectTo ShowDecisionRecordAction { decisionRecordId } + redirectTo ShowDecisionRecordAction { decisionRecordId } newRecord @ImplementationChangeReference |> set #decisionId decisionRecordId |> set #workItemRef workItemRef |> set #system system - |> set #linkedBy (fmap (Id . unId) linkedBy) + |> set #linkedBy (fmap coerce linkedBy) |> createRecord setSuccessMessage "Implementation reference added" redirectTo ShowDecisionRecordAction { decisionRecordId } diff --git a/Web/Controller/DeploymentRecords.hs b/Web/Controller/DeploymentRecords.hs index fdfedde..b29d62b 100644 --- a/Web/Controller/DeploymentRecords.hs +++ b/Web/Controller/DeploymentRecords.hs @@ -10,6 +10,7 @@ import IHP.ControllerPrelude import Data.Time.Clock (addUTCTime, NominalDiffTime) import Text.Read (readMaybe) import Data.String.Conversions (cs) +import Data.Coerce (coerce) instance Controller DeploymentRecordsController where beforeAction = ensureIsUser @@ -76,7 +77,7 @@ instance Controller DeploymentRecordsController where let record = newRecord @DeploymentRecord record |> fill @'["decisionId", "implRefId", "versionRef", "notes"] - |> set #deployedBy (fmap (Id . unId) deployedBy) + |> set #deployedBy (fmap coerce deployedBy) |> validateField #versionRef nonEmpty |> ifValid \case Left r -> render NewView { record = r, decisions, implRefs, users, mDecisionId = Just r.decisionId } @@ -145,7 +146,7 @@ instance Controller DeploymentRecordsController where |> set #decisionId (Just deployment.decisionId) |> set #score (fromIntegral s) |> set #rationale rationale - |> set #evaluatedBy (fmap (Id . unId) evaluatedBy) + |> set #evaluatedBy (fmap coerce evaluatedBy) |> createRecord setSuccessMessage "Change evaluated" redirectTo ShowDeploymentRecordAction { deploymentRecordId } diff --git a/Web/Controller/GovernanceTemplates.hs b/Web/Controller/GovernanceTemplates.hs index 495450c..896167b 100644 --- a/Web/Controller/GovernanceTemplates.hs +++ b/Web/Controller/GovernanceTemplates.hs @@ -1,7 +1,7 @@ module Web.Controller.GovernanceTemplates where import Web.Types -import Web.View.GovernanceTemplates.Index +import Web.View.GovernanceTemplates.Index hiding (jsonArrayTexts) import Web.View.GovernanceTemplates.Show import Web.View.GovernanceTemplates.New import Generated.Types @@ -9,6 +9,7 @@ import IHP.Prelude import IHP.ControllerPrelude import Data.Aeson (Value(..), decode, encode, toJSON) import qualified Data.ByteString.Lazy as LBS +import Data.Text (intercalate) instance Controller GovernanceTemplatesController where beforeAction = ensureIsUser @@ -142,13 +143,3 @@ getUserHubId = do (h:_) -> pure h.id [] -> error "No hubs found" --- | Extract text values from a JSONB array. -jsonArrayTexts :: Value -> [Text] -jsonArrayTexts val = case decode (encode val) of - Just (arr :: [Text]) -> arr - Nothing -> [] - -intercalate :: Text -> [Text] -> Text -intercalate _ [] = "" -intercalate _ [x] = x -intercalate sep (x:xs) = x <> sep <> intercalate sep xs diff --git a/Web/Controller/LineageEnrichment.hs b/Web/Controller/LineageEnrichment.hs index 668561b..0e79c4e 100644 --- a/Web/Controller/LineageEnrichment.hs +++ b/Web/Controller/LineageEnrichment.hs @@ -36,7 +36,7 @@ instance Controller LineageEnrichmentController where \ WHERE dr.hub_id = ? \ \ AND dr.outcome_summary IS NULL \ \ ) sub" - [hubId] + (Only hubId) :: IO [Only Int] setSuccessMessage ("Lineage enriched for " <> show enriched <> " signals") redirectTo LineageEnrichmentAction diff --git a/Web/Controller/OutcomeCorrelations.hs b/Web/Controller/OutcomeCorrelations.hs index 059dc6d..3ec59da 100644 --- a/Web/Controller/OutcomeCorrelations.hs +++ b/Web/Controller/OutcomeCorrelations.hs @@ -9,6 +9,7 @@ import IHP.ControllerPrelude import Web.View.OutcomeCorrelations.Index import Application.Helper.CorrelationEngine (computeAnnotationCorrelations) import Data.Aeson ((.=), object) +import qualified Data.Aeson as A instance Controller OutcomeCorrelationsController where beforeAction = ensureIsUser @@ -30,7 +31,7 @@ instance Controller OutcomeCorrelationsController where rows <- liftIO $ computeAnnotationCorrelations hubId now <- getCurrentTime -- Upsert: delete existing rows for this hub then insert fresh - deleteWhere @OutcomeCorrelation (#hubId, hubId) + query @OutcomeCorrelation |> filterWhere (#hubId, hubId) |> fetch >>= deleteRecords forM_ rows \(category, score, sampleCount) -> newRecord @OutcomeCorrelation |> set #hubId hubId diff --git a/Web/Controller/PatternPerformance.hs b/Web/Controller/PatternPerformance.hs index 8ba3d1a..d97e226 100644 --- a/Web/Controller/PatternPerformance.hs +++ b/Web/Controller/PatternPerformance.hs @@ -41,12 +41,15 @@ instance Controller PatternPerformanceController where \ JOIN outcome_signals os ON os.deployment_id = dep.id \ \ WHERE pa.adopting_hub_id = ? \ \ GROUP BY wp.id" - [hubId] + (Only hubId) :: IO [(Id WidgetPattern, Int, Int, Int, Maybe Double)] now <- getCurrentTime -- Delete existing records for this hub then insert fresh - deleteWhere @PatternPerformanceRecord (#hubId, hubId) + query @PatternPerformanceRecord + |> filterWhere (#hubId, hubId) + |> fetch + >>= deleteRecords -- Insert with rank computation let sorted = sortBy (\(_, _, _, pos1, _) (_, _, _, pos2, _) -> compare pos2 pos1) rows ranked = zip [1..] sorted diff --git a/Web/Controller/RequirementCandidates.hs b/Web/Controller/RequirementCandidates.hs index 820bf92..7556a90 100644 --- a/Web/Controller/RequirementCandidates.hs +++ b/Web/Controller/RequirementCandidates.hs @@ -8,15 +8,16 @@ import Web.View.RequirementCandidates.Edit import Generated.Types import IHP.Prelude import IHP.ControllerPrelude -import Application.Helper.AgentBridge (callAgent, checkGovernancePolicy, bridgeErrorMessage) +import Application.Helper.AgentBridge (callAgent, checkGovernancePolicy, bridgeErrorMessage, BridgeResponse) import Application.Helper.ModelRouter (resolveAgent) -import Data.List (intercalate) import Data.Aeson (decode, Value(..), Array) import Data.Aeson.Lens (key, _String) import Control.Lens ((^?)) import Data.ByteString.Lazy (fromStrict) import Web.Job.WebhookDeliveryJob (dispatchWebhooks) import Control.Concurrent (forkIO) +import Control.Monad (void) +import Data.Coerce (coerce) import Data.Aeson ((.=), object) import Data.Text.Encoding (encodeUtf8) import Data.HashMap.Strict (HashMap) @@ -91,7 +92,7 @@ instance Controller RequirementCandidatesController where candidate |> fill @'["title", "description", "sourceWidgetId", "sourceThreadId", "category"] |> set #status "open" - |> set #createdBy (fmap (Id . unId) createdBy) + |> set #createdBy (fmap coerce createdBy) |> validateField #title nonEmpty |> validateField #description nonEmpty |> validateField #category (`elem` validCategories) @@ -148,7 +149,7 @@ instance Controller RequirementCandidatesController where |> set #candidateId requirementCandidateId |> set #status newStatus |> set #notes notes - |> set #changedBy (fmap (Id . unId) changedBy) + |> set #changedBy (fmap coerce changedBy) |> createRecord -- Update current status on candidate candidate @@ -158,8 +159,7 @@ instance Controller RequirementCandidatesController where redirectTo ShowRequirementCandidateAction { requirementCandidateId } else do setErrorMessage ("Invalid transition: " <> candidate.status <> " → " <> newStatus) - respondWith 422 do - redirectTo ShowRequirementCandidateAction { requirementCandidateId } + redirectTo ShowRequirementCandidateAction { requirementCandidateId } action AssignReviewerAction { requirementCandidateId } = do let userId = param @(Id User) "userId" @@ -177,7 +177,7 @@ instance Controller RequirementCandidatesController where newRecord @ReviewerAssignment |> set #candidateId requirementCandidateId |> set #userId userId - |> set #assignedBy (fmap (Id . unId) assignedBy) + |> set #assignedBy (fmap coerce assignedBy) |> createRecord setSuccessMessage "Reviewer assigned" @@ -208,8 +208,7 @@ instance Controller RequirementCandidatesController where -- Guard: only accepted candidates may be promoted when (candidate.status /= "accepted") do setErrorMessage "Only accepted candidates can be promoted to a requirement" - respondWith 422 do - redirectTo ShowRequirementCandidateAction { requirementCandidateId } + redirectTo ShowRequirementCandidateAction { requirementCandidateId } -- Idempotent: if already promoted, redirect to existing requirement case candidate.requirementId of Just rid -> redirectTo ShowRequirementAction { requirementId = rid } @@ -221,7 +220,7 @@ instance Controller RequirementCandidatesController where |> set #description candidate.description |> set #sourceCandidateId requirementCandidateId |> set #status "active" - |> set #createdBy (fmap (Id . unId) createdBy) + |> set #createdBy (fmap coerce createdBy) |> createRecord candidate |> set #requirementId (Just req.id) @@ -234,8 +233,7 @@ instance Controller RequirementCandidatesController where -- Guard: only accepted candidates when (candidate.status /= "accepted") do setErrorMessage "Only accepted candidates can be linked to a decision" - respondWith 422 do - redirectTo ShowRequirementCandidateAction { requirementCandidateId } + redirectTo ShowRequirementCandidateAction { requirementCandidateId } -- Idempotent: check if a decision already links to this candidate existing <- query @DecisionRecord |> filterWhere (#candidateId, Just requirementCandidateId) @@ -253,7 +251,7 @@ instance Controller RequirementCandidatesController where |> set #outcome "accepted" |> set #candidateId (Just requirementCandidateId) |> set #requirementId mReqId - |> set #decidedBy (fmap (Id . unId) decidedBy) + |> set #decidedBy (fmap coerce decidedBy) |> createRecord setSuccessMessage "Decision record created" redirectTo ShowDecisionRecordAction { decisionRecordId = dr.id } diff --git a/Web/Controller/TypeRegistries.hs b/Web/Controller/TypeRegistries.hs index 1ad1248..168bf5a 100644 --- a/Web/Controller/TypeRegistries.hs +++ b/Web/Controller/TypeRegistries.hs @@ -37,7 +37,7 @@ instance Controller TypeRegistriesController where let entry = newRecord @WidgetTypeRegistry hubs <- query @Hub |> fetch entry - |> fill @'["name", "label", "description", "ownerHubId"] + |> fill @'["name", "label_", "description", "ownerHubId"] |> validateField #name nonEmpty |> validateField #label_ nonEmpty |> ifValid \case @@ -57,7 +57,7 @@ instance Controller TypeRegistriesController where hubs <- query @Hub |> fetch -- name is immutable after creation entry - |> fill @'["label", "description", "ownerHubId"] + |> fill @'["label_", "description", "ownerHubId"] |> validateField #label_ nonEmpty |> ifValid \case Left entry -> render EditWidgetTypeView { entry, hubs } @@ -104,7 +104,7 @@ instance Controller TypeRegistriesController where let entry = newRecord @EventTypeRegistry hubs <- query @Hub |> fetch entry - |> fill @'["name", "label", "description", "ownerHubId"] + |> fill @'["name", "label_", "description", "ownerHubId"] |> validateField #name nonEmpty |> validateField #label_ nonEmpty |> ifValid \case @@ -123,7 +123,7 @@ instance Controller TypeRegistriesController where entry <- fetch eventTypeRegistryId hubs <- query @Hub |> fetch entry - |> fill @'["label", "description", "ownerHubId"] + |> fill @'["label_", "description", "ownerHubId"] |> validateField #label_ nonEmpty |> ifValid \case Left entry -> render EditEventTypeView { entry, hubs } @@ -170,7 +170,7 @@ instance Controller TypeRegistriesController where let entry = newRecord @AnnotationCategoryRegistry hubs <- query @Hub |> fetch entry - |> fill @'["name", "label", "description", "ownerHubId"] + |> fill @'["name", "label_", "description", "ownerHubId"] |> validateField #name nonEmpty |> validateField #label_ nonEmpty |> ifValid \case @@ -189,7 +189,7 @@ instance Controller TypeRegistriesController where entry <- fetch annotationCategoryRegistryId hubs <- query @Hub |> fetch entry - |> fill @'["label", "description", "ownerHubId"] + |> fill @'["label_", "description", "ownerHubId"] |> validateField #label_ nonEmpty |> ifValid \case Left entry -> render EditAnnotationCategoryView { entry, hubs } @@ -236,7 +236,7 @@ instance Controller TypeRegistriesController where let entry = newRecord @PolicyScopeRegistry hubs <- query @Hub |> fetch entry - |> fill @'["name", "label", "description", "ownerHubId"] + |> fill @'["name", "label_", "description", "ownerHubId"] |> validateField #name nonEmpty |> validateField #label_ nonEmpty |> ifValid \case @@ -255,7 +255,7 @@ instance Controller TypeRegistriesController where entry <- fetch policyScopeRegistryId hubs <- query @Hub |> fetch entry - |> fill @'["label", "description", "ownerHubId"] + |> fill @'["label_", "description", "ownerHubId"] |> validateField #label_ nonEmpty |> ifValid \case Left entry -> render EditPolicyScopeView { entry, hubs } diff --git a/Web/Controller/WidgetPatterns.hs b/Web/Controller/WidgetPatterns.hs index f5c185e..dac8664 100644 --- a/Web/Controller/WidgetPatterns.hs +++ b/Web/Controller/WidgetPatterns.hs @@ -9,6 +9,7 @@ import Generated.Types import IHP.Prelude import IHP.ControllerPrelude import Data.Aeson (decode, encode, object, (.=)) +import qualified Data.Aeson as A import qualified Data.ByteString.Lazy as LBS instance Controller WidgetPatternsController where @@ -16,17 +17,18 @@ instance Controller WidgetPatternsController where -- List all published patterns with adopter count action WidgetPatternsAction = autoRefresh do - patterns <- sqlQuery - "SELECT wp.*, \ - \ COUNT(pa.id) AS adopter_count, \ - \ MAX(wpv.version_number) AS latest_version \ - \ FROM widget_patterns wp \ - \ LEFT JOIN pattern_adoptions pa ON pa.widget_pattern_id = wp.id \ - \ LEFT JOIN widget_pattern_versions wpv ON wpv.widget_pattern_id = wp.id \ - \ WHERE wp.is_published = TRUE \ - \ GROUP BY wp.id \ - \ ORDER BY adopter_count DESC, wp.name ASC" - () + basePatterns <- query @WidgetPattern + |> filterWhere (#isPublished, True) + |> orderByAsc #name + |> fetch + patterns <- mapM (\p -> do + adopterCount <- sqlQueryScalar + "SELECT COUNT(*) FROM pattern_adoptions WHERE widget_pattern_id = ?" + (Only p.id) + latestVersion <- sqlQueryScalar + "SELECT MAX(version_number) FROM widget_pattern_versions WHERE widget_pattern_id = ?" + (Only p.id) + pure (p, fromMaybe 0 adopterCount, latestVersion)) basePatterns render IndexView { patterns } -- Detail with version history and aggregate adoption stats (T07) @@ -92,9 +94,9 @@ instance Controller WidgetPatternsController where typeOwner <- sqlQuery "SELECT owner_hub_id FROM widget_type_registry WHERE name = ?" (Only pattern.widgetType) - let isCross = case (typeOwner :: [(Maybe (Id Hub))]) of - [Just ownerId] -> ownerId /= pattern.hubId - _ -> False + let isCross = case (typeOwner :: [Only (Maybe (Id Hub))]) of + [Only (Just ownerId)] -> ownerId /= pattern.hubId + _ -> False pattern <- pattern |> set #isCrossHub isCross |> createRecord setSuccessMessage "Pattern created" redirectTo EditWidgetPatternAction { widgetPatternId = pattern.id } @@ -199,17 +201,17 @@ instance Controller WidgetPatternsController where -- Create a draft manifest amendment let existingTypes = maybe [] (jsonArrayTexts . (.declaredWidgetTypes)) mManifest let newTypes = existingTypes ++ [pattern.widgetType] - let newTypesJson = toJSON newTypes + let newTypesJson = A.toJSON newTypes draft <- newRecord @HubCapabilityManifest |> set #hubId hubId |> set #status "draft" |> set #declaredWidgetTypes newTypesJson |> set #declaredEventTypes - (maybe (toJSON ([] :: [Text])) (.declaredEventTypes) mManifest) + (maybe (A.toJSON ([] :: [Text])) (.declaredEventTypes) mManifest) |> set #declaredAnnotationCategories - (maybe (toJSON ([] :: [Text])) (.declaredAnnotationCategories) mManifest) + (maybe (A.toJSON ([] :: [Text])) (.declaredAnnotationCategories) mManifest) |> set #declaredPolicyScopes - (maybe (toJSON ([] :: [Text])) (.declaredPolicyScopes) mManifest) + (maybe (A.toJSON ([] :: [Text])) (.declaredPolicyScopes) mManifest) |> createRecord setSuccessMessage "Pattern adopted. A manifest amendment draft has been created — please review and activate it." redirectTo ShowHubCapabilityManifestAction { hubCapabilityManifestId = draft.id } @@ -232,6 +234,3 @@ jsonArrayTexts val = case decode (encode val) of Just (arr :: [Text]) -> arr Nothing -> [] --- | Convert a list to a JSON Value. -toJSON :: [Text] -> Value -toJSON ts = Data.Aeson.toJSON ts diff --git a/Web/Controller/Widgets.hs b/Web/Controller/Widgets.hs index 46a7620..07bc118 100644 --- a/Web/Controller/Widgets.hs +++ b/Web/Controller/Widgets.hs @@ -11,9 +11,8 @@ import IHP.ControllerPrelude import Data.Aeson (toJSON, object, (.=)) import Application.Helper.Controller (isInRegression, widgetCycleCounts) import Application.Helper.TypeRegistry (validateWidgetType, validatePolicyScope, activeWidgetTypes, activePolicyScopes) -import Application.Helper.AgentBridge (callAgent, checkGovernancePolicy, bridgeErrorMessage) +import Application.Helper.AgentBridge (callAgent, checkGovernancePolicy, bridgeErrorMessage, BridgeResponse) import Application.Helper.ModelRouter (resolveAgent) -import Data.List (intercalate) instance Controller WidgetsController where beforeAction = ensureIsUser @@ -91,10 +90,10 @@ instance Controller WidgetsController where |> validateField #widgetType nonEmpty |> (case widgetTypeVal of Left msg -> attachFailure #widgetType msg - Right () -> id) + Right () -> \x -> x) |> (case policyScopeVal of Left msg -> attachFailure #policyScope msg - Right () -> id) + Right () -> \x -> x) |> ifValid \case Left widget -> render NewView { widget, hubs, adapterSpecs, widgetTypes, policyScopes } Right widget -> do @@ -145,10 +144,10 @@ instance Controller WidgetsController where |> validateField #widgetType nonEmpty |> (case widgetTypeVal of Left msg -> attachFailure #widgetType msg - Right () -> id) + Right () -> \x -> x) |> (case policyScopeVal of Left msg -> attachFailure #policyScope msg - Right () -> id) + Right () -> \x -> x) |> ifValid \case Left widget -> render EditView { widget, hubs, adapterSpecs, widgetTypes, policyScopes } Right widget -> do diff --git a/Web/View/DecisionRecords/New.hs b/Web/View/DecisionRecords/New.hs index 8d032f0..235f416 100644 --- a/Web/View/DecisionRecords/New.hs +++ b/Web/View/DecisionRecords/New.hs @@ -24,9 +24,9 @@ instance View NewView where |] -renderForm :: HasPath action => DecisionRecord -> [Requirement] -> [RequirementCandidate] -> [User] -> action -> Html -renderForm record requirements candidates users submitAction = [hsx| -
+renderForm :: DecisionRecord -> [Requirement] -> [RequirementCandidate] -> [User] -> DecisionRecordsController -> Html +renderForm record requirements candidates users formAction = [hsx| +
- {typeArraySection "Declared Widget Types" "declaredWidgetTypes" manifest.declaredWidgetTypes widgetTypeEntries} - {typeArraySection "Declared Event Types" "declaredEventTypes" manifest.declaredEventTypes eventTypeEntries} - {typeArraySection2 "Declared Annotation Categories" "declaredAnnotationCategories" manifest.declaredAnnotationCategories categoryEntries} - {typeArraySection3 "Declared Policy Scopes" "declaredPolicyScopes" manifest.declaredPolicyScopes policyScopeEntries} + {typeArraySection "Declared Widget Types" "declaredWidgetTypes" manifest.declaredWidgetTypes (map (.name) widgetTypeEntries)} + {typeArraySection "Declared Event Types" "declaredEventTypes" manifest.declaredEventTypes (map (.name) eventTypeEntries)} + {typeArraySection "Declared Annotation Categories" "declaredAnnotationCategories" manifest.declaredAnnotationCategories (map (.name) categoryEntries)} + {typeArraySection "Declared Policy Scopes" "declaredPolicyScopes" manifest.declaredPolicyScopes (map (.name) policyScopeEntries)}
|] where - deployedIds = map (.id) allDeployments - openGaps = filter (\d -> any (\r -> r.decisionId == d.id) allImplRefs - && not (any (\dp -> dp.decisionId == d.id) allDeployments)) - allDecisions - recentDeploys = take 20 (sortByDesc (.deployedAt) allDeployments) - regressedWidgets = filter (\w -> w.id `elem` regressionWidgetIds) widgets - avgScoreText - | null allEvaluations = "—" - | otherwise = - let avg = fromIntegral (sum (map (.score) allEvaluations)) / fromIntegral (length allEvaluations) :: Double - in show (round avg :: Int) <> "/5" - improvedPctText - | null allSignals = "—" - | otherwise = - let improved = length (filter (\s -> s.signalType == "improved") allSignals) - pct = (fromIntegral improved * 100 `div` length allSignals) :: Int - in show pct <> "%" + deployedIds = map (.id) allDeployments + openGaps = filter (\d -> any (\r -> r.decisionId == d.id) allImplRefs + && not (any (\dp -> dp.decisionId == d.id) allDeployments)) + allDecisions + recentDeploys = take 20 (sortByDesc (.deployedAt) allDeployments) + regressedWidgets = filter (\w -> w.id `elem` regressionWidgetIds) widgets + avgScoreText + | null allEvaluations = "—" + | otherwise = + let avg = fromIntegral (sum (map (.score) allEvaluations)) / fromIntegral (length allEvaluations) :: Double + in show (round avg :: Int) <> "/5" + improvedPctText + | null allSignals = "—" + | otherwise = + let improved = length (filter (\s -> s.signalType == "improved") allSignals) + pct = (fromIntegral improved * 100 `div` length allSignals) :: Int + in show pct <> "%" sortByDesc :: Ord b => (a -> b) -> [a] -> [a] sortByDesc f = sortBy (\a b -> compare (f b) (f a)) @@ -171,7 +171,7 @@ signalDot "neutral" = "inline-block w-2 h-2 rounded-full bg-gray-400" signalDot "inconclusive" = "inline-block w-2 h-2 rounded-full bg-yellow-400" signalDot _ = "inline-block w-2 h-2 rounded-full bg-gray-300" -renderEvalBadge :: Int16 -> Html +renderEvalBadge :: Int -> Html renderEvalBadge score = [hsx| " text-xs px-2 py-0.5 rounded font-medium"}> {show score}/5 @@ -269,7 +269,7 @@ 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"