inter-hub/Application/Helper/Controller.hs

module Application.Helper.Controller where

import IHP.ControllerPrelude
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.
--
-- A regression is defined as: a widget that has an OutcomeSignal(improved)
-- for any deployment, followed by a new Annotation(severity IN high/critical)
-- created more than 1 day after the signal's observed_at (grace period).
regressedWidgetIds :: [OutcomeSignal] -> [Annotation] -> [Id Widget]
regressedWidgetIds signals annotations =
    [ wid
    | wid <- nub (map (.widgetId) signals)
    , isInRegression signals annotations wid
    ]

isInRegression :: [OutcomeSignal] -> [Annotation] -> Id Widget -> Bool
isInRegression signals annotations wid =
    let improvedSignals = filter (\s -> s.widgetId == wid && s.signalType == "improved") signals
        highAnns        = filter (\a -> a.widgetId == wid
                                    && a.severity `elem` ["high", "critical"]
                                    && isNothing a.retractedAt) annotations
        graceEnd sig    = addUTCTime (24 * 3600) sig.observedAt
    in any (\sig -> any (\ann -> ann.createdAt > graceEnd sig) highAnns) improvedSignals

-- | Computes the number of completed improvement cycles per widget.
--
-- A cycle is counted when:
--   1. A RequirementCandidate for the widget was accepted
--   2. A DecisionRecord exists for that requirement/candidate
--   3. A DeploymentRecord exists for that decision
--   4. A new RequirementCandidate was subsequently created for the same widget
--
-- Returns a list of (widgetId, cycleCount) for widgets with cycleCount >= 1,
-- sorted descending by cycleCount.
widgetCycleCounts
    :: [RequirementCandidate]
    -> [Requirement]
    -> [DecisionRecord]
    -> [DeploymentRecord]
    -> [(Id Widget, Int)]
widgetCycleCounts candidates requirements decisions deployments =
    sortBy (\(_, a) (_, b) -> compare b a)
    [ (wid, cycleCount wid)
    | wid <- nub (map (.sourceWidgetId) candidates)
    , cycleCount wid >= 1
    ]
  where
    -- A completed cycle: accepted candidate → requirement → decision → deployment
    completedCycleDeploymentTimes wid =
        [ dr.deployedAt
        | c   <- filter (\x -> x.sourceWidgetId == wid && x.status == "accepted") candidates
        , req <- filter (\x -> x.sourceCandidateId == c.id) requirements
        , dec <- filter (\x -> x.requirementId == Just req.id) decisions
        , dr  <- filter (\x -> x.decisionId == dec.id) deployments
        ]

    cycleCount wid =
        let deplTimes = completedCycleDeploymentTimes wid
            -- For each completed cycle, check if a subsequent candidate was created
            widCandidates = filter (\x -> x.sourceWidgetId == wid) candidates
        in length
            [ ()
            | deplTime <- deplTimes
            , 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")