inter-hub/Web/Controller/DeploymentRecords.hs

module Web.Controller.DeploymentRecords where

import Web.Types
import Web.View.DeploymentRecords.Index
import Web.View.DeploymentRecords.Show
import Web.View.DeploymentRecords.New
import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
import Data.Time.Clock (addUTCTime, NominalDiffTime)
import Text.Read (readMaybe)
import Data.String.Conversions (cs)

instance Controller DeploymentRecordsController where
    beforeAction = ensureIsUser

    action DeploymentRecordsAction = do
        records     <- query @DeploymentRecord |> orderByDesc #deployedAt |> fetch
        decisions   <- query @DecisionRecord |> fetch
        signals     <- query @OutcomeSignal |> fetch
        evaluations <- query @ChangeEvaluation |> fetch
        render IndexView { records, decisions, signals, evaluations }

    action ShowDeploymentRecordAction { deploymentRecordId } = do
        record      <- fetch deploymentRecordId
        decision    <- fetch record.decisionId
        mImplRef    <- case record.implRefId of
            Nothing  -> pure Nothing
            Just rid -> fetchOneOrNothing rid
        mRequirement <- case decision.requirementId of
            Nothing  -> pure Nothing
            Just rid -> fetchOneOrNothing rid
        mCandidate  <- case decision.candidateId of
            Nothing  -> pure Nothing
            Just cid -> fetchOneOrNothing cid
        mWidget     <- case mCandidate of
            Nothing -> pure Nothing
            Just c  -> fetchOneOrNothing c.sourceWidgetId
        signals     <- query @OutcomeSignal
            |> filterWhere (#deploymentId, deploymentRecordId)
            |> orderByDesc #observedAt
            |> fetch
        mEvaluation <- query @ChangeEvaluation
            |> filterWhere (#deploymentId, deploymentRecordId)
            |> fetchOneOrNothing
        users       <- query @User |> fetch
        comparison  <- computeComparison record.deployedAt mWidget
        render ShowView
            { record
            , decision
            , mImplRef
            , mRequirement
            , mCandidate
            , mWidget
            , signals
            , mEvaluation
            , users
            , comparison
            }

    action NewDeploymentRecordAction = do
        decisions <- query @DecisionRecord |> fetch
        implRefs  <- query @ImplementationChangeReference |> fetch
        users     <- query @User |> fetch
        mDecisionId <- paramOrNothing @(Id DecisionRecord) "decisionId"
        let record = newRecord @DeploymentRecord
        render NewView { record, decisions, implRefs, users, mDecisionId }

    action CreateDeploymentRecordAction = do
        decisions <- query @DecisionRecord |> fetch
        implRefs  <- query @ImplementationChangeReference |> fetch
        users     <- query @User |> fetch
        mUser     <- currentUserOrNothing
        let deployedBy = fmap (.id) mUser

        let record = newRecord @DeploymentRecord
        record
            |> fill @'["decisionId", "implRefId", "versionRef", "notes"]
            |> set #deployedBy (fmap (Id . unId) deployedBy)
            |> validateField #versionRef nonEmpty
            |> ifValid \case
                Left  r -> render NewView { record = r, decisions, implRefs, users, mDecisionId = Just r.decisionId }
                Right r -> do
                    created <- createRecord r
                    setSuccessMessage "Deployment record created"
                    redirectTo ShowDeploymentRecordAction { deploymentRecordId = created.id }

    action RecordOutcomeSignalAction { deploymentRecordId } = do
        signalType <- param @Text "signalType"
        mValue     <- paramOrNothing @Double "value"
        mUser      <- currentUserOrNothing
        let validTypes = ["improved", "regressed", "neutral", "inconclusive"] :: [Text]
        unless (signalType `elem` validTypes) do
            setErrorMessage ("Invalid signal type: " <> signalType)
            redirectTo ShowDeploymentRecordAction { deploymentRecordId }
        -- Fetch the deployment to get the widget_id from its decision → candidate chain
        deployment <- fetch deploymentRecordId
        decision   <- fetch deployment.decisionId
        mCandidate <- case decision.candidateId of
            Nothing  -> pure Nothing
            Just cid -> fetchOneOrNothing cid
        case mCandidate of
            Nothing -> do
                setErrorMessage "Cannot record signal: no widget linked to this deployment's decision"
                redirectTo ShowDeploymentRecordAction { deploymentRecordId }
            Just candidate -> do
                newRecord @OutcomeSignal
                    |> set #deploymentId deploymentRecordId
                    |> set #widgetId     candidate.sourceWidgetId
                    |> set #signalType   signalType
                    |> set #value        mValue
                    |> createRecord
                setSuccessMessage ("Outcome signal recorded: " <> signalType)
                redirectTo ShowDeploymentRecordAction { deploymentRecordId }

    action EvaluateChangeAction { deploymentRecordId } = do
        -- Idempotent: if already evaluated, redirect with message
        existing <- query @ChangeEvaluation
            |> filterWhere (#deploymentId, deploymentRecordId)
            |> fetchOneOrNothing
        case existing of
            Just _ -> do
                setErrorMessage "Already evaluated — one evaluation per deployment."
                redirectTo ShowDeploymentRecordAction { deploymentRecordId }
            Nothing -> do
                mUser <- currentUserOrNothing
                let evaluatedBy = fmap (.id) mUser
                scoreText <- param @Text "score"
                rationale <- param @Text "rationale"
                let mScore = readMaybe (cs scoreText) :: Maybe Int
                case mScore of
                    Nothing -> do
                        setErrorMessage "Score must be a number between 1 and 5"
                        redirectTo ShowDeploymentRecordAction { deploymentRecordId }
                    Just s | s < 1 || s > 5 -> do
                        setErrorMessage "Score must be between 1 and 5"
                        redirectTo ShowDeploymentRecordAction { deploymentRecordId }
                    Just s -> do
                        when (rationale == "") do
                            setErrorMessage "Rationale cannot be empty"
                            redirectTo ShowDeploymentRecordAction { deploymentRecordId }
                        deployment <- fetch deploymentRecordId
                        newRecord @ChangeEvaluation
                            |> set #deploymentId  deploymentRecordId
                            |> set #decisionId    (Just deployment.decisionId)
                            |> set #score         (fromIntegral s)
                            |> set #rationale     rationale
                            |> set #evaluatedBy   (fmap (Id . unId) evaluatedBy)
                            |> createRecord
                        setSuccessMessage "Change evaluated"
                        redirectTo ShowDeploymentRecordAction { deploymentRecordId }

thirtyDays :: NominalDiffTime
thirtyDays = 30 * 24 * 3600

computeComparison :: (?modelContext :: ModelContext) => UTCTime -> Maybe Widget -> IO (Maybe (PeriodMetrics, PeriodMetrics))
computeComparison _ Nothing = pure Nothing
computeComparison deployedAt (Just w) = do
    let beforeStart = addUTCTime (negate thirtyDays) deployedAt
        afterEnd    = addUTCTime thirtyDays deployedAt
    allEvents      <- query @InteractionEvent |> filterWhere (#widgetId, w.id) |> fetch
    allAnnotations <- query @Annotation       |> filterWhere (#widgetId, w.id) |> fetch
    let inWindow s e t = t >= s && t < e
        evBefore  = filter (\x -> inWindow beforeStart deployedAt x.occurredAt) allEvents
        evAfter   = filter (\x -> inWindow deployedAt afterEnd x.occurredAt)   allEvents
        annBefore = filter (\x -> inWindow beforeStart deployedAt x.createdAt && isNothing x.retractedAt) allAnnotations
        annAfter  = filter (\x -> inWindow deployedAt afterEnd x.createdAt && isNothing x.retractedAt)  allAnnotations
    pure $ Just (buildMetrics evBefore annBefore, buildMetrics evAfter annAfter)

buildMetrics :: [InteractionEvent] -> [Annotation] -> PeriodMetrics
buildMetrics events anns = PeriodMetrics
    { eventCount      = length events
    , annotationCount = length anns
    , lowCount        = count "low"
    , mediumCount     = count "medium"
    , highCount       = count "high"
    , criticalCount   = count "critical"
    }
  where
    count sev = length (filter (\a -> a.severity == sev) anns)