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)
import Data.Coerce (coerce)
import Data.Scientific (Scientific)

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
        let 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
        let mUser      = currentUserOrNothing
            deployedBy = fmap (.id) mUser

        let record = newRecord @DeploymentRecord
        record
            |> fill @'["decisionId", "implRefId", "versionRef", "notes"]
            |> set #deployedBy (fmap coerce 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
        let signalType = param @Text "signalType"
            mValue     = fmap realToFrac (paramOrNothing @Double "value") :: Maybe Scientific
            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
                let mUser       = currentUserOrNothing
                    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 coerce 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)