generated from coulomb/repo-seed
Bernd Worsch
ce42607fca
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>
107 lines
4.2 KiB
Haskell
107 lines
4.2 KiB
Haskell
module Web.Controller.Api.V2.Learning where
|
|
|
|
-- IHF Phase 12 — Platform Memory (IHUB-WP-0013 T08)
|
|
|
|
import Web.Types
|
|
import Generated.Types
|
|
import IHP.Prelude
|
|
import IHP.ControllerPrelude
|
|
import Data.Aeson (object, (.=))
|
|
import Web.Controller.Api.V2.Auth (requireApiConsumer, paginatedResponse, getPageParams)
|
|
import IHP.ModelSupport (sqlQuery)
|
|
|
|
instance Controller ApiV2LearningController where
|
|
|
|
action ApiV2IndexOutcomeCorrelationsAction = do
|
|
_consumer <- requireApiConsumer
|
|
let mHubId = paramOrNothing @(Id Hub) "hub_id"
|
|
mCat = paramOrNothing @Text "category"
|
|
(page, perPage) <- getPageParams
|
|
let off = (page - 1) * perPage
|
|
baseQuery <- pure $ query @OutcomeCorrelation
|
|
filtered <- pure $ case mHubId of
|
|
Nothing -> baseQuery
|
|
Just hid -> baseQuery |> filterWhere (#hubId, hid)
|
|
filteredCat <- pure $ case mCat of
|
|
Nothing -> filtered
|
|
Just cat -> filtered |> filterWhere (#annotationCategory, cat)
|
|
total <- filteredCat |> fetchCount
|
|
rows <- filteredCat |> orderByDesc #correlationScore |> limit perPage |> offset off |> fetch
|
|
renderJson $ paginatedResponse (map correlationToJson rows) page perPage total
|
|
|
|
action ApiV2IndexPatternPerformanceAction = do
|
|
_consumer <- requireApiConsumer
|
|
(page, perPage) <- getPageParams
|
|
let off = (page - 1) * perPage
|
|
total <- query @PatternPerformanceRecord |> fetchCount
|
|
rows <- query @PatternPerformanceRecord
|
|
|> orderByAsc #outcomeRank
|
|
|> limit perPage
|
|
|> offset off
|
|
|> fetch
|
|
renderJson $ paginatedResponse (map patternPerfToJson rows) page perPage total
|
|
|
|
action ApiV2IndexKnowledgeBaseAction = do
|
|
_consumer <- requireApiConsumer
|
|
let mQ = paramOrNothing @Text "q"
|
|
(page, perPage) <- getPageParams
|
|
let off = (page - 1) * perPage
|
|
rows <- case mQ of
|
|
Nothing -> query @InstitutionalKnowledgeEntry
|
|
|> orderByDesc #createdAt
|
|
|> limit perPage
|
|
|> offset off
|
|
|> fetch
|
|
Just q -> sqlQuery
|
|
"SELECT * FROM institutional_knowledge_entries \
|
|
\ WHERE summary_tsv @@ plainto_tsquery('english', ?) \
|
|
\ ORDER BY ts_rank(summary_tsv, plainto_tsquery('english', ?)) DESC \
|
|
\ LIMIT ? OFFSET ?"
|
|
(q, q, perPage, off)
|
|
renderJson (map knowledgeToJson rows)
|
|
|
|
action ApiV2ShowKnowledgeBaseAction { knowledgeEntryId } = do
|
|
_consumer <- requireApiConsumer
|
|
entry <- fetch knowledgeEntryId
|
|
renderJson (knowledgeToJson entry)
|
|
|
|
correlationToJson :: OutcomeCorrelation -> Value
|
|
correlationToJson c = object
|
|
[ "id" .= c.id
|
|
, "hubId" .= c.hubId
|
|
, "annotationCategory" .= c.annotationCategory
|
|
, "correlationType" .= c.correlationType
|
|
, "correlationScore" .= c.correlationScore
|
|
, "sampleCount" .= c.sampleCount
|
|
, "computedAt" .= c.computedAt
|
|
]
|
|
|
|
patternPerfToJson :: PatternPerformanceRecord -> Value
|
|
patternPerfToJson r =
|
|
let positiveRate = if r.totalOutcomeCount > 0
|
|
then fromIntegral r.positiveOutcomeCount / fromIntegral r.totalOutcomeCount :: Double
|
|
else 0.0
|
|
in object
|
|
[ "id" .= r.id
|
|
, "widgetPatternId" .= r.widgetPatternId
|
|
, "hubId" .= r.hubId
|
|
, "adoptionCount" .= r.adoptionCount
|
|
, "positiveOutcomeCount" .= r.positiveOutcomeCount
|
|
, "totalOutcomeCount" .= r.totalOutcomeCount
|
|
, "positiveOutcomeRate" .= positiveRate
|
|
, "meanOutcomeValue" .= r.meanOutcomeValue
|
|
, "outcomeRank" .= r.outcomeRank
|
|
, "calibratedAt" .= r.calibratedAt
|
|
]
|
|
|
|
knowledgeToJson :: InstitutionalKnowledgeEntry -> Value
|
|
knowledgeToJson e = object
|
|
[ "id" .= e.id
|
|
, "hubId" .= e.hubId
|
|
, "decisionRecordId" .= e.decisionRecordId
|
|
, "summary" .= e.summary
|
|
, "tags" .= e.tags
|
|
, "createdAt" .= e.createdAt
|
|
, "updatedAt" .= e.updatedAt
|
|
]
|