diff --git a/Web/Controller/AdaptiveThresholds.hs b/Web/Controller/AdaptiveThresholds.hs index 88a6f0b..7acf072 100644 --- a/Web/Controller/AdaptiveThresholds.hs +++ b/Web/Controller/AdaptiveThresholds.hs @@ -27,7 +27,7 @@ instance Controller AdaptiveThresholdsController where weakCats <- sqlQuery "SELECT annotation_category FROM outcome_correlations \ \ WHERE hub_id = ? AND correlation_score < 0.3" - [hubId] + (Only hubId) :: IO [Only Text] -- Step 2: compute bottleneck threshold override = mean friction score @@ -46,7 +46,7 @@ instance Controller AdaptiveThresholdsController where \ WHERE rc.source_widget_id = w.id \ \ AND os.signal_type NOT IN ('success','adoption','satisfaction') \ \ )" - [hubId] + (Only hubId) :: IO [Only (Maybe Double)] now <- getCurrentTime diff --git a/Web/Controller/AgentDelegations.hs b/Web/Controller/AgentDelegations.hs index b7ef6bf..0f85dc3 100644 --- a/Web/Controller/AgentDelegations.hs +++ b/Web/Controller/AgentDelegations.hs @@ -10,7 +10,7 @@ import qualified Data.Aeson as A import Application.Helper.AgentBridge ( callAgentWithBudget , BridgeError(..) - , BridgeResponse + , BridgeResponse(..) , bridgeErrorMessage ) @@ -38,7 +38,7 @@ instance Controller AgentDelegationsController where tokenBudget = paramOrDefault @Int 1000 "tokenBudget" delegatingAgentId <- case (proposal.agentRegistrationId :: Maybe (Id AgentRegistration)) of Just aid -> pure aid - Nothing -> respondAndExit =<< renderNotFound + Nothing -> renderNotFound >> error "unreachable" receivingAgent <- fetch receivingAgentId diff --git a/Web/Controller/AgentRegistrations.hs b/Web/Controller/AgentRegistrations.hs index 001d390..079ab23 100644 --- a/Web/Controller/AgentRegistrations.hs +++ b/Web/Controller/AgentRegistrations.hs @@ -107,6 +107,7 @@ instance Controller AgentRegistrationsController where \ WHERE ap.agent_registration_id = ? \ \ AND ap.created_at >= NOW() - INTERVAL '30 days'" (Only agentRegistrationId) + :: IO [(Int, Int, Int, Int, Maybe Double)] case rows of [(accepted, rejected, _other, total, mConf)] -> do now <- getCurrentTime diff --git a/Web/Controller/Annotations.hs b/Web/Controller/Annotations.hs index 2854229..a079a9c 100644 --- a/Web/Controller/Annotations.hs +++ b/Web/Controller/Annotations.hs @@ -56,7 +56,7 @@ instance Controller AnnotationsController where |> set #actorId (fmap coerce actorId) |> set #actorType actorType |> validateField #body nonEmpty - |> validateField #severity (`elem` validSeverities) + |> validateField #severity (isInList validSeverities) |> (case categoryResult of Left msg -> attachFailure #category msg Right () -> \x -> x) diff --git a/Web/Controller/DecisionRecords.hs b/Web/Controller/DecisionRecords.hs index 6cc05e4..9b4ff81 100644 --- a/Web/Controller/DecisionRecords.hs +++ b/Web/Controller/DecisionRecords.hs @@ -8,9 +8,8 @@ import Web.View.DecisionRecords.Edit import Generated.Types import IHP.Prelude import IHP.ControllerPrelude -import Application.Helper.AgentBridge (callAgent, checkGovernancePolicy, bridgeErrorMessage, BridgeResponse) +import Application.Helper.AgentBridge (callAgent, checkGovernancePolicy, bridgeErrorMessage, BridgeResponse(..)) import Application.Helper.ModelRouter (resolveAgent) -import Data.List (intercalate) import IHP.ModelSupport (sqlQuery) import qualified Data.Aeson as A import Data.Coerce (coerce) @@ -95,7 +94,7 @@ instance Controller DecisionRecordsController where |> set #decidedBy (fmap coerce decidedBy) |> validateField #title nonEmpty |> validateField #rationale nonEmpty - |> validateField #outcome (`elem` validOutcomes) + |> validateField #outcome (isInList validOutcomes) |> ifValid \case Left record -> render NewView { record, requirements, candidates, users } Right record -> do @@ -188,10 +187,14 @@ instance Controller DecisionRecordsController where mRequirement <- case record.requirementId of Nothing -> pure Nothing Just rid -> fetchOneOrNothing rid - -- Resolve hub from the source widget via requirement candidate - mHubId <- case mRequirement >>= (.sourceWidgetId) of + -- Resolve hub via the decision's linked candidate → source widget + mHubId <- case record.candidateId of Nothing -> pure Nothing - Just wid -> fmap (.hubId) <$> fetchOneOrNothing @Widget wid + Just cid -> do + mCand <- fetchOneOrNothing cid + case mCand of + Nothing -> pure Nothing + Just cand -> fmap (.hubId) <$> fetchOneOrNothing cand.sourceWidgetId let implLines = map (\r -> r.system <> ": " <> r.workItemRef) implRefs reqDesc = maybe "" (.description) mRequirement userMsg = "Decision: " <> record.title @@ -243,59 +246,3 @@ instance Controller DecisionRecordsController where setSuccessMessage "Implementation proposal created" redirectTo ShowDecisionRecordAction { decisionRecordId } - -- T05 / Phase 12: Distil decision into institutional knowledge entry - action DistilDecisionAction { decisionRecordId } = do - record <- fetch decisionRecordId - outcomes <- sqlQuery - "SELECT os.signal_type, os.value FROM outcome_signals os \ - \ JOIN deployment_records dep ON dep.id = os.deployment_id \ - \ WHERE dep.decision_id = ?" - [decisionRecordId] - :: IO [(Text, Maybe Double)] - let signalText = intercalate ", " $ - map (\(st, mv) -> st <> maybe "" (\v -> "=" <> show v) mv) outcomes - prompt = "Distil this decision into a 2-3 sentence institutional knowledge entry. " - <> "Include the outcome data.\n\nDecision: " <> record.title - <> "\nRationale: " <> record.rationale - <> "\nOutcome: " <> record.outcome - <> "\nSignals: " <> signalText - -- Resolve hub from requirement chain - mHubId <- case record.requirementId of - Nothing -> pure Nothing - Just rid -> do - mReq <- fetchOneOrNothing rid - pure $ case mReq >>= (.sourceWidgetId) of - Nothing -> Nothing - Just _ -> Nothing -- hub resolution via widget lookup below - mHubIdResolved <- case record.requirementId of - Nothing -> pure Nothing - Just rid -> do - mReq <- fetchOneOrNothing rid - case mReq >>= (.sourceWidgetId) of - Nothing -> pure Nothing - Just wid -> fmap (.hubId) <$> fetchOneOrNothing @Widget wid - case mHubIdResolved of - Nothing -> do - setErrorMessage "Cannot resolve hub — ensure decision has a linked requirement with a source widget" - redirectTo ShowDecisionRecordAction { decisionRecordId } - Just hubId -> do - mAgent <- resolveAgent hubId "synthesis" - case mAgent of - Nothing -> do - setErrorMessage "No routing policy for 'synthesis' task type" - redirectTo ShowDecisionRecordAction { decisionRecordId } - Just agent -> do - result <- liftIO $ callAgent agent prompt - case result of - Left err -> do - setErrorMessage ("Distillation failed: " <> bridgeErrorMessage err) - redirectTo ShowDecisionRecordAction { decisionRecordId } - Right resp -> do - newRecord @InstitutionalKnowledgeEntry - |> set #hubId hubId - |> set #decisionRecordId (Just decisionRecordId) - |> set #summary resp.content - |> set #tags (A.toJSON ["decision" :: Text]) - |> createRecord - setSuccessMessage "Knowledge entry created" - redirectTo ShowDecisionRecordAction { decisionRecordId } diff --git a/Web/Controller/DeploymentRecords.hs b/Web/Controller/DeploymentRecords.hs index b29d62b..0b538e6 100644 --- a/Web/Controller/DeploymentRecords.hs +++ b/Web/Controller/DeploymentRecords.hs @@ -11,6 +11,7 @@ import Data.Time.Clock (addUTCTime, NominalDiffTime) import Text.Read (readMaybe) import Data.String.Conversions (cs) import Data.Coerce (coerce) +import Data.Scientific (Scientific) instance Controller DeploymentRecordsController where beforeAction = ensureIsUser @@ -88,7 +89,7 @@ instance Controller DeploymentRecordsController where action RecordOutcomeSignalAction { deploymentRecordId } = do let signalType = param @Text "signalType" - mValue = paramOrNothing @Double "value" + mValue = fmap realToFrac (paramOrNothing @Double "value") :: Maybe Scientific mUser = currentUserOrNothing let validTypes = ["improved", "regressed", "neutral", "inconclusive"] :: [Text] unless (signalType `elem` validTypes) do diff --git a/Web/Controller/GovernanceTemplates.hs b/Web/Controller/GovernanceTemplates.hs index 896167b..c9bef3a 100644 --- a/Web/Controller/GovernanceTemplates.hs +++ b/Web/Controller/GovernanceTemplates.hs @@ -10,20 +10,20 @@ import IHP.ControllerPrelude import Data.Aeson (Value(..), decode, encode, toJSON) import qualified Data.ByteString.Lazy as LBS import Data.Text (intercalate) +import qualified Data.Map.Strict as Map instance Controller GovernanceTemplatesController where beforeAction = ensureIsUser -- List published templates with clone count action GovernanceTemplatesAction = autoRefresh do - templates <- sqlQuery - "SELECT gt.*, COUNT(gtc.id) AS clone_count \ - \ FROM governance_templates gt \ - \ LEFT JOIN governance_template_clones gtc ON gtc.governance_template_id = gt.id \ - \ WHERE gt.is_published = TRUE \ - \ GROUP BY gt.id \ - \ ORDER BY clone_count DESC, gt.name ASC" - () + rawTemplates <- query @GovernanceTemplate + |> filterWhere (#isPublished, True) + |> orderByAsc #name + |> fetch + allClones <- query @GovernanceTemplateClone |> fetch + let countMap = foldr (\c m -> Map.insertWith (+) c.governanceTemplateId 1 m) Map.empty allClones + templates = map (\t -> (t, Map.findWithDefault 0 t.id countMap)) rawTemplates render IndexView { templates } -- Template detail with clone count diff --git a/Web/Controller/HubCapabilityManifests.hs b/Web/Controller/HubCapabilityManifests.hs index 07cfe8a..4c162f3 100644 --- a/Web/Controller/HubCapabilityManifests.hs +++ b/Web/Controller/HubCapabilityManifests.hs @@ -8,9 +8,10 @@ import Web.View.HubCapabilityManifests.Edit import Generated.Types import IHP.Prelude import IHP.ControllerPrelude -import Data.Aeson (Value, Array, decode, encode) +import Data.Aeson (Value, Array, decode, encode, toJSON) import qualified Data.Vector as V import Data.Maybe (mapMaybe) +import Control.Monad (void) instance Controller HubCapabilityManifestsController where beforeAction = ensureIsUser @@ -76,9 +77,11 @@ instance Controller HubCapabilityManifestsController where setErrorMessage "Active manifests are read-only. Retire the current manifest and create a new draft to amend." redirectTo ShowHubCapabilityManifestAction { hubCapabilityManifestId } manifest - |> fill @'["manifestVersion", "capabilityDescription", "contact", - "declaredWidgetTypes", "declaredEventTypes", - "declaredAnnotationCategories", "declaredPolicyScopes"] + |> fill @'["manifestVersion", "capabilityDescription", "contact"] + |> set #declaredWidgetTypes (toJSON (paramList @Text "declaredWidgetTypes")) + |> set #declaredEventTypes (toJSON (paramList @Text "declaredEventTypes")) + |> set #declaredAnnotationCategories (toJSON (paramList @Text "declaredAnnotationCategories")) + |> set #declaredPolicyScopes (toJSON (paramList @Text "declaredPolicyScopes")) |> ifValid \case Left manifest -> render EditView { manifest, hub, widgetTypeEntries, eventTypeEntries, categoryEntries, policyScopeEntries } Right manifest -> do @@ -142,7 +145,7 @@ checkConflict :: Text -> Id Hub -> Text -> IO [Text] checkConflict tableName hubId name = do rows <- sqlQuery - ("SELECT owner_hub_id FROM " <> tableName <> " WHERE name = ?") + (fromString $ cs ("SELECT owner_hub_id FROM " <> tableName <> " WHERE name = ?")) (Only name) case rows of [] -> pure [] @@ -158,12 +161,8 @@ upsertType :: (?modelContext :: ModelContext) => Text -> Id Hub -> Text -> IO () upsertType tableName hubId name = - sqlExec - ("INSERT INTO " <> tableName <> " (name, label, owner_hub_id, status) " - <> "VALUES (?, ?, ?, 'active') ON CONFLICT (name) DO NOTHING") + void $ sqlExec + (fromString $ cs ("INSERT INTO " <> tableName <> " (name, label, owner_hub_id, status) " + <> "VALUES (?, ?, ?, 'active') ON CONFLICT (name) DO NOTHING")) (name, name, hubId) -intercalate :: Text -> [Text] -> Text -intercalate _ [] = "" -intercalate _ [x] = x -intercalate sep (x:xs) = x <> sep <> intercalate sep xs diff --git a/Web/Controller/Hubs.hs b/Web/Controller/Hubs.hs index c6bf733..249751b 100644 --- a/Web/Controller/Hubs.hs +++ b/Web/Controller/Hubs.hs @@ -39,13 +39,17 @@ instance Controller HubsController where |> filterWhere (#hubId, hubId) |> orderByAsc #name |> fetch - widgetIds <- pure (map (.id) widgets) - recentEvents <- sqlQuery - "SELECT * FROM interaction_events WHERE widget_id = ANY(?) ORDER BY occurred_at DESC LIMIT 50" - (Only (PGArray widgetIds)) - recentAnnotations <- sqlQuery - "SELECT * FROM annotations WHERE widget_id = ANY(?) ORDER BY created_at DESC LIMIT 20" - (Only (PGArray widgetIds)) + let widgetIds = map (.id) widgets + recentEvents <- query @InteractionEvent + |> filterWhereIn (#widgetId, widgetIds) + |> orderByDesc #occurredAt + |> limit 50 + |> fetch + recentAnnotations <- query @Annotation + |> filterWhereIn (#widgetId, widgetIds) + |> orderByDesc #createdAt + |> limit 20 + |> fetch mManifest <- query @HubCapabilityManifest |> filterWhere (#hubId, hubId) |> fetchOneOrNothing @@ -58,7 +62,7 @@ instance Controller HubsController where |> validateField #slug nonEmpty |> validateField #name nonEmpty |> validateField #domain nonEmpty - |> validateField #hubKind (`elem` ["domain", "shared"]) + |> validateField #hubKind (isInList ["domain", "shared"]) -- 'framework' cannot be set via the UI |> ifValid \case Left hub -> render NewView { hub } @@ -78,7 +82,7 @@ instance Controller HubsController where |> validateField #slug nonEmpty |> validateField #name nonEmpty |> validateField #domain nonEmpty - |> validateField #hubKind (`elem` ["framework", "domain", "shared"]) + |> validateField #hubKind (isInList ["framework", "domain", "shared"]) |> ifValid \case Left hub -> render EditView { hub } Right hub -> do @@ -265,8 +269,7 @@ instance Controller HubsController where widgets <- query @Widget |> filterWhere (#hubId, hubId) |> fetch let widgetIds = map (.id) widgets annotations <- query @Annotation |> filterWhereIn (#widgetId, widgetIds) |> fetch - events <- sqlQuery "SELECT * FROM interaction_events WHERE widget_id = ANY(?)" - (Only (PGArray widgetIds)) + events <- query @InteractionEvent |> filterWhereIn (#widgetId, widgetIds) |> fetch signals <- query @OutcomeSignal |> filterWhereIn (#widgetId, widgetIds) |> fetch candidates <- query @RequirementCandidate |> filterWhereIn (#sourceWidgetId, widgetIds) |> fetch let regressionWids = regressedWidgetIds signals annotations diff --git a/Web/Controller/RequirementCandidates.hs b/Web/Controller/RequirementCandidates.hs index 7556a90..0143705 100644 --- a/Web/Controller/RequirementCandidates.hs +++ b/Web/Controller/RequirementCandidates.hs @@ -8,7 +8,7 @@ import Web.View.RequirementCandidates.Edit import Generated.Types import IHP.Prelude import IHP.ControllerPrelude -import Application.Helper.AgentBridge (callAgent, checkGovernancePolicy, bridgeErrorMessage, BridgeResponse) +import Application.Helper.AgentBridge (callAgent, checkGovernancePolicy, bridgeErrorMessage, BridgeResponse(..)) import Application.Helper.ModelRouter (resolveAgent) import Data.Aeson (decode, Value(..), Array) import Data.Aeson.Lens (key, _String) @@ -18,6 +18,7 @@ import Web.Job.WebhookDeliveryJob (dispatchWebhooks) import Control.Concurrent (forkIO) import Control.Monad (void) import Data.Coerce (coerce) +import Data.Scientific (Scientific) import Data.Aeson ((.=), object) import Data.Text.Encoding (encodeUtf8) import Data.HashMap.Strict (HashMap) @@ -95,7 +96,7 @@ instance Controller RequirementCandidatesController where |> set #createdBy (fmap coerce createdBy) |> validateField #title nonEmpty |> validateField #description nonEmpty - |> validateField #category (`elem` validCategories) + |> validateField #category (isInList validCategories) |> ifValid \case Left candidate -> render NewView { candidate, widgets, threads } Right candidate -> do @@ -127,7 +128,7 @@ instance Controller RequirementCandidatesController where |> fill @'["title", "description", "sourceWidgetId", "sourceThreadId", "category"] |> validateField #title nonEmpty |> validateField #description nonEmpty - |> validateField #category (`elem` validCategories) + |> validateField #category (isInList validCategories) |> ifValid \case Left candidate -> render EditView { candidate, widgets, threads } Right candidate -> do @@ -260,10 +261,8 @@ instance Controller RequirementCandidatesController where action DetectDuplicatesAction { requirementCandidateId } = do target <- fetch requirementCandidateId others <- query @RequirementCandidate |> fetch - -- Resolve hub from the source widget - mHubId <- case target.sourceWidgetId of - Nothing -> pure Nothing - Just wid -> fmap (.hubId) <$> fetchOneOrNothing @Widget wid + -- Resolve hub from the source widget (sourceWidgetId is non-nullable) + mHubId <- fmap (.hubId) <$> fetchOneOrNothing target.sourceWidgetId let otherLines = map (\c -> show c.id <> " | " <> c.title <> ": " <> c.description) (filter (\c -> c.id /= requirementCandidateId) others) targetLine = "TARGET: " <> target.title <> ": " <> target.description @@ -315,13 +314,9 @@ instance Controller RequirementCandidatesController where -- T06: Detect policy sensitivity via routed agent action DetectPolicySensitivityAction { requirementCandidateId } = do candidate <- fetch requirementCandidateId - mWidget <- case candidate.sourceWidgetId of - Nothing -> pure Nothing - Just wid -> fetchOneOrNothing wid - -- Resolve hub for routing - mHubId <- case candidate.sourceWidgetId of - Nothing -> pure Nothing - Just wid -> fmap (.hubId) <$> fetchOneOrNothing @Widget wid + -- sourceWidgetId is non-nullable; fetchOneOrNothing handles missing widget + mWidget <- fetchOneOrNothing candidate.sourceWidgetId + mHubId <- fmap (.hubId) <$> fetchOneOrNothing candidate.sourceWidgetId let policyCtx = maybe "unknown" (.policyScope) mWidget userMsg = "Title: " <> candidate.title <> "\nDescription: " <> candidate.description @@ -358,7 +353,7 @@ instance Controller RequirementCandidatesController where setErrorMessage ("Policy check failed: " <> bridgeErrorMessage err) redirectTo ShowRequirementCandidateAction { requirementCandidateId } Right resp -> do - let confidenceScore = extractSeverityScore resp.content + let confidenceScore = realToFrac (extractSeverityScore resp.content) :: Scientific proposal <- newRecord @AgentProposal |> set #proposalType "policy_flag" |> set #sourceCandidateId (Just requirementCandidateId) @@ -379,10 +374,10 @@ instance Controller RequirementCandidatesController where case (concern ^? key "scope" . _String ,concern ^? key "note" . _String) of (Just scope, noteM) -> - newRecord @ConfidenceAnnotation + void $ newRecord @ConfidenceAnnotation |> set #proposalId proposal.id |> set #dimension scope - |> set #score confidenceScore + |> set #score (confidenceScore :: Scientific) |> set #explanation noteM |> createRecord _ -> pure () diff --git a/Web/Controller/Widgets.hs b/Web/Controller/Widgets.hs index 07bc118..3fd87d0 100644 --- a/Web/Controller/Widgets.hs +++ b/Web/Controller/Widgets.hs @@ -11,7 +11,7 @@ import IHP.ControllerPrelude import Data.Aeson (toJSON, object, (.=)) import Application.Helper.Controller (isInRegression, widgetCycleCounts) import Application.Helper.TypeRegistry (validateWidgetType, validatePolicyScope, activeWidgetTypes, activePolicyScopes) -import Application.Helper.AgentBridge (callAgent, checkGovernancePolicy, bridgeErrorMessage, BridgeResponse) +import Application.Helper.AgentBridge (callAgent, checkGovernancePolicy, bridgeErrorMessage, BridgeResponse(..)) import Application.Helper.ModelRouter (resolveAgent) instance Controller WidgetsController where diff --git a/Web/FrontController.hs b/Web/FrontController.hs index 0f03fee..6888739 100644 --- a/Web/FrontController.hs +++ b/Web/FrontController.hs @@ -2,11 +2,11 @@ module Web.FrontController where import IHP.RouterPrelude import IHP.LoginSupport.Middleware -import IHP.ControllerPrelude (getAppConfig) +import IHP.ControllerPrelude +import IHP.ViewPrelude (Html, hsx, Layout, autoRefreshMeta) import Generated.Types import Web.Types import Web.Routes () -import Config (AnnotationLauncherEnabled (..)) -- Controllers import Web.Controller.Hubs () @@ -146,14 +146,7 @@ instance InitControllerContext WebApplication where setLayout defaultLayout initAuthentication @User -annotationLauncherScript :: (?context :: ControllerContext) => Html -annotationLauncherScript = - let AnnotationLauncherEnabled enabled = getAppConfig @AnnotationLauncherEnabled - in if enabled - then [hsx||] - else mempty - -defaultLayout :: Layout +defaultLayout :: (?context :: ControllerContext, ?request :: Request) => Layout defaultLayout inner = [hsx| @@ -165,7 +158,7 @@ defaultLayout inner = [hsx| - {annotationLauncherScript} +