Update.hs

module Seihou.CLI.Update
  ( handleUpdate,
  )
where

import Control.Monad (unless, when)
import Data.Aeson (encode, object, (.=))
import Data.ByteString.Lazy.Char8 qualified as LBS
import Data.Generics.Labels ()
import Data.Maybe (isJust)
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import Seihou.CLI.CommandExecution (CommandPolicy (..))
import Seihou.CLI.Commands (UpdateOpts (..))
import Seihou.CLI.CommitMessage (generateCommitMessage)
import Seihou.CLI.Git (gitAdd, gitCheckIgnore, gitCommit, gitDiffCached, isGitRepo)
import Seihou.CLI.Judgement.CommitGate (CommitBlocked (..), gatedCommit, renderBlocked)
import Seihou.CLI.Style (useColor)
import Seihou.CLI.Update.Interaction
  ( InteractionError (..),
    InteractionMode (..),
    forceResolveUpdatePlan,
    resolveInteractively,
  )
import Seihou.CLI.Update.Render
  ( encodeUpdateOutput,
    errorOutputFor,
    planOutput,
    renderUpdateHuman,
    resultOutput,
  )
import Seihou.Core.Types (ModuleName (..))
import Seihou.Effect.ProcessInterp (runProcessIO)
import Seihou.Prelude
import System.Directory (getCurrentDirectory)
import System.Exit (ExitCode (..), exitFailure, exitWith)
import System.FilePath (isAbsolute)
import System.IO (hFlush, hIsTerminalDevice, isEOF, stderr, stdin)
import "seihou-cli" Seihou.CLI.Update qualified as Service

handleUpdate :: UpdateOpts -> IO ()
handleUpdate opts = do
  validateOptions opts
  terminal <- hIsTerminalDevice stdin
  let request = requestFromOptions terminal opts
  Service.withProjectUpdate request (handlePlanned terminal opts)

validateOptions :: UpdateOpts -> IO ()
validateOptions opts
  | opts ^. #dryRun && (opts ^. #commit || isJust (opts ^. #commitMessage)) =
      failCli opts "invalid_options" "--commit and --commit-message cannot be used with --dry-run"
  | opts ^. #runAllCommands && (opts ^. #noCommands) =
      failCli opts "invalid_options" "--run-all-commands and --no-commands are mutually exclusive"
  | otherwise = pure ()

requestFromOptions :: Bool -> UpdateOpts -> Service.UpdateRequest
requestFromOptions terminal opts =
  Service.UpdateRequest
    { selection =
        if null (opts ^. #targets)
          then Service.AllRecordedApplications
          else Service.NamedUpdateTargets (opts ^. #targets),
      varOverrides = opts ^. #vars,
      reconfigure = opts ^. #reconfigure,
      promptPolicy =
        if terminal && not (opts ^. #json)
          then Service.AllowPrompts
          else Service.ForbidPrompts,
      commandPolicy =
        if opts ^. #runAllCommands
          then RunAllCommands
          else if opts ^. #noCommands then DisableCommands else RunChangedCommands,
      dryRun = opts ^. #dryRun,
      allowDowngrade = opts ^. #allowDowngrade,
      includeSharedOwners = opts ^. #includeSharedOwners
    }

handlePlanned :: Bool -> UpdateOpts -> Either Service.UpdateError Service.UpdatePlan -> IO ()
handlePlanned _ opts (Left err) = do
  if opts ^. #json
    then LBS.putStrLn (encodeUpdateOutput (errorOutputFor (opts ^. #targets) err))
    else TIO.hPutStr stderr (renderUpdateHuman False (errorOutputFor (opts ^. #targets) err))
  exitFailure
handlePlanned terminal opts (Right originalPlan) = do
  forced <-
    if opts ^. #force
      then either (failInteraction opts) pure (forceResolveUpdatePlan originalPlan)
      else pure originalPlan
  resolved <-
    resolveInteractively
      (if terminal && not (opts ^. #json) then Interactive else NonInteractive)
      forced
      >>= either (failInteraction opts) pure
  color <- useColor
  if Service.isUpdateNoOp resolved
    then
      if opts ^. #json
        then LBS.putStrLn (encodeUpdateOutput (planOutput resolved))
        else TIO.putStrLn "Already up to date."
    else
      if opts ^. #dryRun
        then emitPlan color opts resolved
        else do
          unless (opts ^. #json) $ TIO.putStr (renderUpdateHuman color (planOutput resolved))
          accepted <- if opts ^. #json then pure True else confirmApply terminal
          if not accepted
            then TIO.hPutStrLn stderr "Update cancelled; no managed state was changed."
            else do
              applied <- Service.applyProjectUpdate resolved
              case applied of
                Left err -> handlePlanned terminal opts (Left err)
                Right result -> do
                  if opts ^. #json
                    then LBS.putStrLn (encodeUpdateOutput (resultOutput result))
                    else TIO.putStr (renderUpdateHuman color (resultOutput result))
                  when (opts ^. #commit || isJust (opts ^. #commitMessage)) $ do
                    committed <- commitUpdate opts result
                    case committed of
                      Left (Left err) -> do
                        TIO.hPutStrLn stderr ("Update succeeded, but git commit failed: " <> err)
                        exitFailure
                      Left (Right blocked@(CommitBlocked code _)) -> do
                        -- Same exit codes as seihou check, run and migrate;
                        -- with --json the report stays off stdout.
                        (if opts ^. #json then TIO.hPutStr stderr else TIO.putStr) (renderBlocked blocked)
                        exitWith (ExitFailure code)
                      Left (Right failed) -> do
                        TIO.hPutStrLn stderr ("Update succeeded, but " <> T.stripEnd (renderBlocked failed))
                        exitFailure
                      Right () -> pure ()

emitPlan :: Bool -> UpdateOpts -> Service.UpdatePlan -> IO ()
emitPlan color opts plan =
  if opts ^. #json
    then LBS.putStrLn (encodeUpdateOutput (planOutput plan))
    else TIO.putStr (renderUpdateHuman color (planOutput plan))

confirmApply :: Bool -> IO Bool
confirmApply False = pure False
confirmApply True = loop
  where
    loop = do
      TIO.hPutStr stderr "Apply? [Y/n] "
      hFlush stderr
      eof <- isEOF
      if eof
        then pure False
        else do
          answer <- T.toLower . T.strip <$> TIO.getLine
          case answer of
            "" -> pure True
            "y" -> pure True
            "yes" -> pure True
            "n" -> pure False
            "no" -> pure False
            _ -> do
              TIO.hPutStrLn stderr "Please answer yes or no."
              loop

-- | 'Left' 'Left' is a staging failure; 'Left' 'Right' is the gate's or the
-- commit's own outcome.
commitUpdate :: UpdateOpts -> Service.UpdateResult -> IO (Either (Either Text CommitBlocked) ())
commitUpdate opts result = do
  let candidates = filter (not . isAbsolute) (Set.toAscList (result ^. #touchedPaths))
  inRepo <- runEff $ runProcessIO isGitRepo
  if not inRepo
    then pure (Right ())
    else do
      ignored <- runEff $ runProcessIO $ gitCheckIgnore candidates
      let staged = filter (`notElem` ignored) candidates
      if null staged
        then pure (Right ())
        else do
          (addExit, _, addErr) <- runEff $ runProcessIO $ gitAdd staged
          case addExit of
            ExitFailure _ -> pure (Left (Left (T.strip addErr)))
            ExitSuccess -> do
              root <- getCurrentDirectory
              let mkMessage = case opts ^. #commitMessage of
                    Just custom -> pure custom
                    Nothing -> do
                      diff <- runEff $ runProcessIO gitDiffCached
                      let modules = map (ModuleName . (^. #name)) (result ^. #versions)
                      generateCommitMessage modules diff
                  commitWith message = do
                    (commitExit, _, commitErr) <- runEff $ runProcessIO $ gitCommit message
                    pure $ case commitExit of
                      ExitSuccess -> Right ()
                      ExitFailure _ -> Left (T.strip commitErr)
              first Right <$> gatedCommit root mkMessage commitWith

failInteraction :: UpdateOpts -> InteractionError -> IO a
failInteraction opts err = case err of
  SeedAdoptionRequiresInteraction paths -> failCli opts "seed_adoption_requires_interaction" ("Seed adoption requires explicit consent for: " <> T.intercalate ", " (map T.pack (Set.toAscList paths)) <> ". Run an interactive seihou update to choose keep or accept; --force does not consent to adoption.")
  InteractionRequired paths ->
    failCli
      opts
      "unresolved_conflicts"
      ( "Unresolved paths require an interactive terminal or an applicable --force choice: "
          <> T.intercalate ", " (map T.pack (Set.toAscList paths))
      )
  InteractionAborted path ->
    failCli opts "update_aborted" ("Resolution aborted for " <> T.pack path)
  InteractionResolutionFailed inner ->
    failCli opts "resolution_failed" (T.pack (show inner))
  InteractionInputFailed message ->
    failCli opts "input_failed" message

failCli :: UpdateOpts -> Text -> Text -> IO a
failCli opts code message = do
  if opts ^. #json
    then
      LBS.putStrLn $
        encode $
          object
            [ "schemaVersion" .= (1 :: Int),
              "outcome" .= ("error" :: Text),
              "error" .= object ["code" .= code, "message" .= message]
            ]
    else TIO.hPutStrLn stderr ("Update failed [" <> code <> "]: " <> message)
  exitFailure