Upgrade.hs

module Seihou.CLI.Upgrade
  ( handleUpgrade,
  )
where

import Control.Applicative ((<|>))
import Control.Exception (SomeException, try)
import Control.Monad (when)
import Data.Aeson (ToJSON (..), object, (.=))
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.ByteString.Lazy qualified as LBS
import Data.Generics.Labels ()
import Data.Map.Strict qualified as Map
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import Seihou.CLI.Commands (UpgradeOpts (..))
import Seihou.CLI.Install (installModuleDir)
import Seihou.CLI.InstallShared (InstallOutcome (..), OriginInfo (..), summarizeInstallRefusal)
import Seihou.CLI.Migrate
  ( MigrateError (..),
    MigrateOpts (..),
    MigrateResult (..),
    pendingChainFor,
    runMigrate,
  )
import Seihou.CLI.Outdated (moduleNameFromDm, readOriginWithModule)
import Seihou.CLI.RemoteVersion (fetchTrueModuleVersion)
import Seihou.CLI.Shared (resolveAppliedArtifactDir)
import Seihou.CLI.Style (dim, green, red, useColor, yellow)
import Seihou.CLI.VersionCompare (OutdatedStatus (..), compareVersions)
import Seihou.Core.Install (parseModuleName)
import Seihou.Core.Migration (MigrationPlan (..))
import Seihou.Core.Module (DiscoveredModule (..), ModuleSource (..), defaultSearchPaths, discoverAllModules, validateModule)
import Seihou.Core.Registry (Registry (..), RegistryEntry (..), RepoContents (..), discoverRepoContents)
import Seihou.Core.Types (AppliedModule (..), Manifest (..), Module (..), ModuleName (..))
import Seihou.Core.Version (renderVersion)
import Seihou.Dhall.Eval (evalModuleFromFile, evalRegistryFromFile)
import Seihou.Effect.FilesystemInterp (runFilesystem)
import Seihou.Effect.ManifestStore (readManifest)
import Seihou.Effect.ManifestStoreInterp (runManifestStore)
import Seihou.Prelude
import System.Exit (ExitCode (..), exitFailure)
import System.IO.Temp (withSystemTempDirectory)
import System.Process (readProcessWithExitCode)

data UpgradeStatus
  = Upgraded
  | AlreadyUpToDate
  | Skipped
  | UpgradeFailed Text
  | SourceUnreachable
  deriving stock (Eq, Show)

data UpgradeEntry = UpgradeEntry
  { moduleName :: !Text,
    oldVersion :: !(Maybe Text),
    newVersion :: !(Maybe Text),
    upgradeStatus :: !UpgradeStatus
  }
  deriving stock (Eq, Generic, Show)

instance ToJSON UpgradeEntry where
  toJSON e =
    object
      [ "module" .= (e ^. #moduleName),
        "oldVersion" .= (e ^. #oldVersion),
        "newVersion" .= (e ^. #newVersion),
        "status" .= statusText (e ^. #upgradeStatus)
      ]
    where
      statusText :: UpgradeStatus -> Text
      statusText Upgraded = "upgraded"
      statusText AlreadyUpToDate = "up to date"
      statusText Skipped = "skipped"
      statusText (UpgradeFailed reason) = "failed: " <> reason
      statusText SourceUnreachable = "unreachable"

handleUpgrade :: UpgradeOpts -> IO ()
handleUpgrade uopts = do
  searchPaths <- defaultSearchPaths
  modules <- discoverAllModules searchPaths
  let installed = filter (\dm -> dm ^. #source == SourceInstalled) modules

  if null installed
    then TIO.putStrLn "No installed modules found."
    else do
      originsWithModules <- mapM readOriginWithModule installed
      let withOrigins = [(dm, origin) | (dm, Just origin) <- originsWithModules]

      filtered <- case uopts ^. #modules of
        [] -> pure withOrigins
        names -> do
          let result = [(dm, origin) | (dm, origin) <- withOrigins, moduleNameFromDm dm `elem` names]
              found = map (moduleNameFromDm . fst) result
              missing = filter (`notElem` found) names
          when (not (null missing)) $ do
            TIO.putStrLn $ "Module(s) not found: " <> T.intercalate ", " missing
            exitFailure
          pure result

      if null filtered
        then TIO.putStrLn "No installed modules with origin metadata found."
        else do
          let grouped = Map.toList $ Map.fromListWith (++) [(origin ^. #sourceUrl, [(dm, origin)]) | (dm, origin) <- filtered]

          if uopts ^. #dryRun
            then TIO.putStrLn "Checking installed modules for updates (dry run)..."
            else TIO.putStrLn "Upgrading installed modules..."

          entries <- concat <$> mapM (upgradeSource uopts) grouped

          if uopts ^. #json
            then LBS.putStr (encodePretty entries)
            else renderUpgradeTable entries

          -- After all upgrades, see whether the *current project* has
          -- migrations pending for any module that was upgraded just
          -- now. Either run them (--with-migrations) or print a
          -- one-line advisory per module.
          unless (uopts ^. #dryRun) $
            handlePostUpgradeMigrations uopts entries

upgradeSource :: UpgradeOpts -> (Text, [(DiscoveredModule, OriginInfo)]) -> IO [UpgradeEntry]
upgradeSource uopts (sourceUrl, modulesWithOrigins) = do
  let repoName = parseModuleName sourceUrl
  TIO.putStrLn $ "  Cloning " <> T.pack repoName <> "..."

  result <- try $ withSystemTempDirectory "seihou-upgrade" $ \tmpDir -> do
    let cloneDir = tmpDir </> repoName
    (exitCode, _stdout, _stderr) <- readProcessWithExitCode "git" ["clone", "--depth", "1", T.unpack sourceUrl, cloneDir] ""
    case exitCode of
      ExitFailure _ -> pure Nothing
      ExitSuccess -> do
        contents <- discoverRepoContents evalRegistryFromFile cloneDir
        Just <$> mapM (upgradeModule uopts cloneDir contents sourceUrl) modulesWithOrigins

  case result of
    Left (_ :: SomeException) ->
      pure [mkUnreachableEntry dm origin | (dm, origin) <- modulesWithOrigins]
    Right Nothing ->
      pure [mkUnreachableEntry dm origin | (dm, origin) <- modulesWithOrigins]
    Right (Just entries) ->
      pure entries

mkUnreachableEntry :: DiscoveredModule -> OriginInfo -> UpgradeEntry
mkUnreachableEntry dm origin =
  UpgradeEntry
    { moduleName = moduleNameFromDm dm,
      oldVersion = origin ^. #version,
      newVersion = Nothing,
      upgradeStatus = SourceUnreachable
    }

upgradeModule :: UpgradeOpts -> FilePath -> RepoContents -> Text -> (DiscoveredModule, OriginInfo) -> IO UpgradeEntry
upgradeModule uopts cloneDir contents sourceUrl (dm, origin) = do
  let name = moduleNameFromDm dm
      installedVer = (origin ^. #version)
  availableVer <- fetchAvailable cloneDir (ModuleName name)
  let status = compareVersions installedVer availableVer

  case status of
    OutdatedSt
      | uopts ^. #dryRun ->
          pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = Upgraded}
      | otherwise ->
          doUpgrade cloneDir contents sourceUrl origin name installedVer availableVer
    UpToDate ->
      pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = AlreadyUpToDate}
    Unversioned
      | uopts ^. #skipUnversioned ->
          pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = Skipped}
      | uopts ^. #dryRun ->
          pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = Upgraded}
      | otherwise ->
          doUpgrade cloneDir contents sourceUrl origin name installedVer availableVer
    Unreachable ->
      pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = Nothing, upgradeStatus = SourceUnreachable}

doUpgrade :: FilePath -> RepoContents -> Text -> OriginInfo -> Text -> Maybe Text -> Maybe Text -> IO UpgradeEntry
doUpgrade cloneDir contents sourceUrl origin name installedVer availableVer = do
  let result = case contents of
        SingleModule rootDir -> Just (rootDir, origin ^. #repoName)
        MultiModule registry ->
          case filter (\e -> e ^. #name . #unModuleName == name) (registry ^. #modules) of
            (entry : _) -> Just (cloneDir </> entry ^. #path, Just (registry ^. #repoName))
            [] -> Nothing
        SingleRecipe _ -> Nothing
        SingleBlueprint _ -> Nothing
        SinglePrompt _ -> Nothing
        EmptyRepo -> Nothing

  case result of
    Nothing ->
      pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = UpgradeFailed "module not found in remote"}
    Just (moduleDir, registryName) -> do
      let dhallFile = moduleDir </> "module.dhall"
      decoded <- evalModuleFromFile dhallFile
      case decoded of
        Left err ->
          pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = UpgradeFailed (T.pack (show err))}
        Right modul -> do
          valResult <- validateModule moduleDir modul
          case valResult of
            Left err ->
              pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = UpgradeFailed (T.pack (show err))}
            Right _ -> do
              -- Trust the module.dhall version over the registry's static
              -- entry.version: the registry can be stale (the bug fixed in
              -- docs/plans/14-fix-outdated-version-detection.md). Tags are
              -- still sourced from the registry entry since module.dhall
              -- has no equivalent field.
              let (ver, tags) = case contents of
                    MultiModule registry -> case filter (\e -> e ^. #name . #unModuleName == name) (registry ^. #modules) of
                      (entry : _) -> (modul ^. #version <|> entry ^. #version, entry ^. #tags)
                      [] -> (modul ^. #version, [])
                    _ -> (modul ^. #version, [])
              -- Pass force = False deliberately. This reinstalls from the URL
              -- the installed copy already records, so it is structurally the
              -- same-source case and must never refuse. If it ever does, the
              -- cache and its own provenance file disagree — real news, and
              -- reported as an upgrade failure rather than overridden. Do not
              -- "fix" a refusal here by passing True.
              outcome <- installModuleDir False moduleDir (T.unpack name) sourceUrl registryName ver tags
              case outcome of
                InstallRefused collision ->
                  pure
                    UpgradeEntry
                      { moduleName = name,
                        oldVersion = installedVer,
                        newVersion = availableVer,
                        upgradeStatus = UpgradeFailed (summarizeInstallRefusal sourceUrl collision)
                      }
                InstallPerformed -> do
                  TIO.putStrLn $ "    Upgraded " <> name
                  pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = Upgraded}

renderUpgradeTable :: [UpgradeEntry] -> IO ()
renderUpgradeTable entries = do
  colorEnabled <- useColor
  let maxNameLen = max 6 (maximum (map (T.length . (^. #moduleName)) entries))
      maxOldLen = max 3 (maximum (map (T.length . maybe "(none)" id . (^. #oldVersion)) entries))
      maxNewLen = max 3 (maximum (map (T.length . maybe "(none)" id . (^. #newVersion)) entries))

      padR n t = t <> T.replicate (n - T.length t + 2) " "

      header =
        padR maxNameLen "Module"
          <> padR maxOldLen "Old"
          <> padR maxNewLen "New"
          <> "Status"

      formatRow e =
        let oldText = maybe "(none)" id (e ^. #oldVersion)
            newText = maybe "(none)" id (e ^. #newVersion)
            statusTxt = case e ^. #upgradeStatus of
              Upgraded -> if colorEnabled then green "upgraded" else "upgraded"
              AlreadyUpToDate -> if colorEnabled then dim "up to date" else "up to date"
              Skipped -> if colorEnabled then yellow "skipped (unversioned)" else "skipped (unversioned)"
              UpgradeFailed reason -> if colorEnabled then red ("failed: " <> reason) else "failed: " <> reason
              SourceUnreachable -> if colorEnabled then yellow "unreachable" else "unreachable"
         in padR maxNameLen (e ^. #moduleName)
              <> padR maxOldLen oldText
              <> padR maxNewLen newText
              <> statusTxt

  TIO.putStrLn ""
  TIO.putStrLn header
  mapM_ (TIO.putStrLn . formatRow) entries

  let upgraded = length (filter (\e -> e ^. #upgradeStatus == Upgraded) entries)
      failed = length (filter isFailedEntry entries)
      skipped = length (filter (\e -> e ^. #upgradeStatus == Skipped) entries)
  TIO.putStrLn ""
  TIO.putStrLn $
    T.pack (show (length entries))
      <> " module(s) checked, "
      <> T.pack (show upgraded)
      <> " upgraded"
      <> (if failed > 0 then ", " <> T.pack (show failed) <> " failed" else "")
      <> (if skipped > 0 then ", " <> T.pack (show skipped) <> " skipped" else "")
      <> "."

isFailedEntry :: UpgradeEntry -> Bool
isFailedEntry e = case e ^. #upgradeStatus of
  UpgradeFailed _ -> True
  SourceUnreachable -> True
  _ -> False

-- | After the upgrade table is printed, look at the project's local
-- manifest for each module that was just upgraded. If the upgrade
-- raised the installed-copy version above the manifest's recorded
-- version, there are migrations to run. With @--with-migrations@,
-- run them. Otherwise, print a single advisory line per module.
--
-- If there's no local manifest at all (the user is upgrading without
-- a project), this is a silent no-op.
handlePostUpgradeMigrations :: UpgradeOpts -> [UpgradeEntry] -> IO ()
handlePostUpgradeMigrations uopts entries = do
  let manifestPath = ".seihou" </> "manifest.json"
      upgraded =
        [ entry ^. #moduleName | entry <- entries, entry ^. #upgradeStatus == Upgraded
        ]
  if null upgraded
    then pure ()
    else do
      mfRes <- runEff $ runFilesystem $ runManifestStore manifestPath readManifest
      case mfRes of
        Left _ -> pure ()
        Right Nothing -> pure ()
        Right (Just manifest) ->
          mapM_ (handleOneModule uopts manifest) upgraded

handleOneModule :: UpgradeOpts -> Manifest -> Text -> IO ()
handleOneModule uopts manifest name =
  case findAppliedByName manifest name of
    Nothing -> pure ()
    Just am -> do
      -- The manifest records a portable origin, so the just-upgraded module
      -- has to be located on this machine before its migrations can be read.
      -- This is advisory reporting after a successful upgrade, so a module
      -- that does not resolve here is skipped rather than reported.
      resolved <- resolveAppliedArtifactDir "module.dhall" (am ^. #origin)
      case resolved of
        Left _ -> pure ()
        Right moduleDir -> do
          r <- evalModuleFromFile (moduleDir </> "module.dhall")
          case r of
            Left _ -> pure ()
            Right installed ->
              case pendingChainFor am installed of
                Nothing -> pure ()
                Just plan
                  | uopts ^. #withMigrations -> runOnePostUpgradeMigration moduleDir name
                  | otherwise -> printAdvisory name plan

findAppliedByName :: Manifest -> Text -> Maybe AppliedModule
findAppliedByName manifest name =
  case filter (\am -> am ^. #name . #unModuleName == name) (manifest ^. #modules) of
    (am : _) -> Just am
    [] -> Nothing

printAdvisory :: Text -> MigrationPlan -> IO ()
printAdvisory name plan = do
  colorEnabled <- useColor
  let msg =
        "note: "
          <> name
          <> " has "
          <> T.pack (show (length (plan ^. #steps)))
          <> " migration(s) pending ("
          <> renderVersion (plan ^. #from)
          <> " → "
          <> renderVersion (plan ^. #to)
          <> "); run 'seihou update' to reconcile the recorded project application"
  TIO.putStrLn $ if colorEnabled then yellow msg else msg

-- | Run a migration for a single module. Reads the manifest fresh so
-- chained migrations against multiple upgraded modules see each
-- other's effects.
runOnePostUpgradeMigration :: FilePath -> Text -> IO ()
runOnePostUpgradeMigration installedDir name = do
  let manifestPath = ".seihou" </> "manifest.json"
  mfRes <- runEff $ runFilesystem $ runManifestStore manifestPath readManifest
  case mfRes of
    Right (Just manifest) -> do
      let opts =
            MigrateOpts
              { module_ = ModuleName name,
                to = Nothing,
                dryRun = False,
                force = False,
                json = False,
                verbose = False,
                -- The post-upgrade hook has already refreshed the
                -- installed copy via 'seihou upgrade'; skip the
                -- redundant fetch in 'runMigrate'.
                noFetch = True,
                commit = False,
                commitMessage = Nothing,
                -- Only 'handleMigrate' consults this; 'runMigrate' is the
                -- guard-free core, and the upgrade that got us here has
                -- just refreshed the installed copy anyway.
                allowDowngrade = False
              }
      result <- runMigrate opts manifest installedDir
      case result of
        Right (MigrateApplied _ _ _ _) -> do
          colorEnabled <- useColor
          let msg = "    Migrated " <> name
          TIO.putStrLn $ if colorEnabled then green msg else msg
        Right (MigrateNoOp _) -> pure ()
        Right (MigrateDryRunOK {}) -> pure ()
        Left err -> do
          colorEnabled <- useColor
          let msg = "    Migration failed for " <> name <> ": " <> renderMigrateError err
          TIO.putStrLn $ if colorEnabled then red msg else msg
    _ -> pure ()

renderMigrateError :: MigrateError -> Text
renderMigrateError err = case err of
  MigrateModuleNotApplied n -> "module " <> n ^. #unModuleName <> " not applied"
  MigrateNoRecordedVersion n -> "no version recorded for " <> (n ^. #unModuleName)
  MigrateInstalledModuleEvalFailed _ msg -> msg
  MigrateInstalledModuleHasNoVersion n _ -> "no version on installed " <> (n ^. #unModuleName)
  MigrateUnparseableInstalledVersion v -> "bad version " <> v
  MigrateUnparseableTargetVersion v -> "bad target version " <> v
  MigrateUnparseableManifestVersion v -> "bad manifest version " <> v
  MigratePlanFailed _ -> "plan failed"
  MigrateExecFailed _ -> "execution failed (use --force or revert your edits)"
  MigrateNoManifest _ -> "no manifest in current dir"

-- | Local @unless@ to avoid pulling in another import.
unless :: Bool -> IO () -> IO ()
unless True _ = pure ()
unless False action = action

-- | Look up the available version of a module in a cloned repo by reading
-- its @module.dhall@. Fetch errors collapse to @Nothing@; downstream
-- 'compareVersions' treats that as "unversioned" and 'doUpgrade' will
-- still attempt the install (the registry's static @version@ is no longer
-- consulted for the comparison — see EP-1).
fetchAvailable :: FilePath -> ModuleName -> IO (Maybe Text)
fetchAvailable cloneDir name = do
  result <- fetchTrueModuleVersion cloneDir name
  case result of
    Right v -> pure v
    Left _ -> pure Nothing