coulomb/inter-hub
2
0
Fork 0
generated from coulomb/repo-seed
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix: migrate DetectPolicySensitivityAction to routed agent pattern
Some checks failed
Test / test (push) Has been cancelled
Details

Browse Source 
The last action still calling callClaudeApi directly. Now routes through
resolveAgent (task_type="policy_sensitivity") + checkGovernancePolicy +
callAgent, consistent with all other Phase 11 AI invocations. Adds
agentRegistrationId, tokensIn, tokensOut to the created AgentProposal and
handles blocked_by_policy the same way as the other 4 actions.

Remove callClaudeApi and its direct HTTP imports from
Application/Helper/Controller.hs — no longer referenced anywhere.

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
Bernd Worsch
2026-04-01 23:22:15 +00:00
parent 0f505feb2d
commit ffd5fbb900
2 changed files with 67 additions and 93 deletions
Download Patch File Download Diff File Expand all files Collapse all files

56
Application/Helper/Controller.hs
View File

@@ -5,14 +5,6 @@ import Generated.Types
import Data.Time.Clock (addUTCTime)
import Data.List (sortBy)
-- Phase 5: Anthropic API
import Network.HTTP.Conduit (newManager, tlsManagerSettings, parseRequest, httpLbs, responseBody, method, requestHeaders, requestBody, RequestBodyLBS(..))
import Data.Aeson (object, (.=), encode, eitherDecode, Value)
import Data.Aeson.Lens (key, _String, nth)
import Control.Lens ((^?))
import Data.String.Conversions (cs)
import System.Environment (lookupEnv)
-- Here you can add functions which are available in all your controllers
-- | Returns the set of widget IDs that are currently in regression.
@@ -78,51 +70,3 @@ widgetCycleCounts candidates requirements decisions deployments =
, any (\c -> c.createdAt > deplTime) widCandidates
]
-- | Call the Anthropic Messages API.
--
-- Returns the text content of the first content block, or an error message.
-- API key read from IHP_ANTHROPIC_API_KEY env var.
-- On any error (missing key, HTTP failure, unexpected JSON) returns Left with a description.
callClaudeApi
:: Text -- ^ system prompt
-> Text -- ^ user message
-> Int -- ^ max_tokens
-> IO (Either Text Text)
callClaudeApi systemPrompt userMessage maxTokens = do
mApiKey <- lookupEnv "IHP_ANTHROPIC_API_KEY"
case mApiKey of
Nothing -> pure (Left "IHP_ANTHROPIC_API_KEY is not set")
Just apiKey -> do
let url = "https://api.anthropic.com/v1/messages"
let body = object
[ "model" .= ("claude-sonnet-4-6" :: Text)
, "max_tokens" .= maxTokens
, "system" .= systemPrompt
, "messages" .= [ object
[ "role" .= ("user" :: Text)
, "content" .= userMessage
] ]
]
let reqBody = RequestBodyLBS (encode body)
manager <- newManager tlsManagerSettings
initReq <- parseRequest url
let req = initReq
{ method = "POST"
, requestHeaders =
[ ("content-type", "application/json")
, ("x-api-key", cs apiKey)
, ("anthropic-version", "2023-06-01")
]
, requestBody = reqBody
}
resp <- httpLbs req manager
let respBody = responseBody resp
case eitherDecode respBody of
Left err -> pure (Left ("JSON parse error: " <> cs err))
Right val ->
case val ^? key "content" . nth 0 . key "text" . _String of
Just txt -> pure (Right txt)
Nothing ->
case val ^? key "error" . key "message" . _String of
Just msg -> pure (Left ("API error: " <> msg))
Nothing -> pure (Left "Unexpected API response shape")

104
Web/Controller/RequirementCandidates.hs
View File

@@ -314,53 +314,83 @@ instance Controller RequirementCandidatesController where
setSuccessMessage "Duplicate detection proposal created"
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
-- T06: Detect policy sensitivity via Claude API
-- 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
let policyCtx = maybe "unknown" (.policyScope) mWidget
userMsg = "Title: " <> candidate.title
<> "\nDescription: " <> candidate.description
<> "\nPolicy scope context: " <> policyCtx
result <- liftIO $ callClaudeApi
"You are a policy compliance assistant. Analyse this requirement candidate for potential policy concerns. Valid scopes: internal, external, regulatory, contractual, architectural. Respond with JSON: {\"concerns\": [{\"scope\": \"...\", \"note\": \"...\"}], \"severity\": \"low|medium|high\"}."
userMsg
500
case result of
Left err -> do
setErrorMessage ("Policy check failed: " <> err)
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
Right content -> do
let confidenceScore = extractSeverityScore content
proposal <- newRecord @AgentProposal
|> set #proposalType "policy_flag"
|> set #sourceCandidateId (Just requirementCandidateId)
|> set #content content
|> set #modelRef "claude-sonnet-4-6"
|> set #confidence (Just confidenceScore)
|> set #status "pending"
|> createRecord
-- Create one ConfidenceAnnotation per concern scope
let mParsed = decode (fromStrict (encodeUtf8 content))
:: Maybe (HashMap Text Value)
case mParsed >>= HashMap.lookup "concerns" of
Just (Array concerns) ->
forM_ (Vector.toList concerns) \concern ->
case (concern ^? key "scope" . _String
,concern ^? key "note" . _String) of
(Just scope, noteM) ->
newRecord @ConfidenceAnnotation
|> set #proposalId proposal.id
|> set #dimension scope
|> set #score confidenceScore
|> set #explanation noteM
|> createRecord
_ -> pure ()
_ -> pure ()
setSuccessMessage "Policy check proposal created"
<> "\nRespond with JSON: {\"concerns\": [{\"scope\": \"...\", \"note\": \"...\"}], \"severity\": \"low|medium|high\"}."
case mHubId of
Nothing -> do
setErrorMessage "Cannot determine hub for routing — ensure the candidate has a source widget"
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
Just hubId -> do
mAgent <- resolveAgent hubId "policy_sensitivity"
case mAgent of
Nothing -> do
setErrorMessage "No routing policy for 'policy_sensitivity' task type"
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
Just agent -> do
allowed <- checkGovernancePolicy hubId agent.id "requirement_candidate"
if not allowed
then do
newRecord @AgentProposal
|> set #proposalType "policy_flag"
|> set #sourceCandidateId (Just requirementCandidateId)
|> set #content "Blocked by AI governance policy"
|> set #modelRef agent.modelName
|> set #status "blocked_by_policy"
|> set #agentRegistrationId (Just agent.id)
|> createRecord
setErrorMessage "Blocked by AI governance policy"
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
else do
result <- liftIO $ callAgent agent userMsg
case result of
Left err -> do
setErrorMessage ("Policy check failed: " <> bridgeErrorMessage err)
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
Right resp -> do
let confidenceScore = extractSeverityScore resp.content
proposal <- newRecord @AgentProposal
|> set #proposalType "policy_flag"
|> set #sourceCandidateId (Just requirementCandidateId)
|> set #content resp.content
|> set #modelRef resp.modelUsed
|> set #confidence (Just confidenceScore)
|> set #status "pending"
|> set #agentRegistrationId (Just agent.id)
|> set #tokensIn (Just resp.tokensIn)
|> set #tokensOut (Just resp.tokensOut)
|> createRecord
-- Create one ConfidenceAnnotation per concern scope
let mParsed = decode (fromStrict (encodeUtf8 resp.content))
:: Maybe (HashMap Text Value)
case mParsed >>= HashMap.lookup "concerns" of
Just (Array concerns) ->
forM_ (Vector.toList concerns) \concern ->
case (concern ^? key "scope" . _String
,concern ^? key "note" . _String) of
(Just scope, noteM) ->
newRecord @ConfidenceAnnotation
|> set #proposalId proposal.id
|> set #dimension scope
|> set #score confidenceScore
|> set #explanation noteM
|> createRecord
_ -> pure ()
_ -> pure ()
setSuccessMessage "Policy check proposal created"
redirectTo ShowRequirementCandidateAction { requirementCandidateId }
-- Map severity string to numeric confidence
extractSeverityScore :: Text -> Double