diff --git a/Application/Helper/Controller.hs b/Application/Helper/Controller.hs index 062dd65..73555ed 100644 --- a/Application/Helper/Controller.hs +++ b/Application/Helper/Controller.hs @@ -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") diff --git a/Web/Controller/RequirementCandidates.hs b/Web/Controller/RequirementCandidates.hs index 59199a3..bf42a2f 100644 --- a/Web/Controller/RequirementCandidates.hs +++ b/Web/Controller/RequirementCandidates.hs @@ -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