Upgrade.hs

module Seihou.CLI.Upgrade
  ( handleUpgrade,
  )
where

import Control.Applicative ((<|>))
import Control.Exception (SomeException, try)
import Control.Monad (forM, forM_, 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.Maybe (fromMaybe)
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import Data.Time (getCurrentTime)
import Seihou.CLI.Commands (UpgradeOpts (..))
import Seihou.CLI.Install (installModuleDir)
import Seihou.CLI.InstallClosure (ClosureArtifact (..), publishStagedClosure)
import Seihou.CLI.InstallShared (InstallOutcome (..), OriginInfo (..), installedRoot, readOriginInfo, 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.Update.Render (errorOutput, renderUpdateHuman)
import Seihou.CLI.Update.Source (hashArtifactDirectory, stageCandidateSources)
import Seihou.CLI.Update.Types (CandidateArtifact (..), CandidateCatalog (..))
import Seihou.CLI.VersionCompare (OutdatedStatus (..), compareVersions)
import Seihou.Core.Application (buildAppliedComposition)
import Seihou.Core.Install (parseModuleName)
import Seihou.Core.Migration (MigrationPlan (..))
import Seihou.Core.Module (DiscoveredModule (..), DiscoveredRunnable (..), ModuleSource (..), RunnableKind (..), defaultSearchPaths, discoverAllModules, discoverAllRunnables, validateModule)
import Seihou.Core.Registry (Registry (..), RegistryEntry (..), RepoContents (..), discoverRepoContents)
import Seihou.Core.Types (AppliedModule (..), AppliedTarget (..), ArtifactOrigin (..), Manifest (..), Module (..), ModuleName (..), RecipeName (..))
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.Directory qualified as Directory
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
  runnables <- discoverAllRunnables searchPaths
  let installed = filter (\dm -> dm ^. #source == SourceInstalled) modules
      recipes = [recipe | recipe <- runnables, recipe ^. #source == SourceInstalled, recipe ^. #kind == KindRecipe]
      requested = uopts ^. #modules
      selectedRecipes = [recipe | recipe <- recipes, null requested || recipe ^. #name `elem` requested]
  originsWithModules <- mapM readOriginWithModule installed
  let withOrigins = [(dm, origin) | (dm, Just origin) <- originsWithModules]
      found = map (moduleNameFromDm . fst) withOrigins <> map (^. #name) recipes
      missing = filter (`notElem` found) requested
  when (not (null missing)) $ TIO.putStrLn ("Module(s) or recipe(s) not found: " <> T.intercalate ", " missing) >> exitFailure
  recipeResult <- upgradeRecipes uopts selectedRecipes
  case recipeResult of
    Left message -> do
      if uopts ^. #json
        then LBS.putStr (encodePretty [UpgradeEntry (recipe ^. #name) Nothing Nothing (UpgradeFailed message) | recipe <- selectedRecipes])
        else TIO.putStrLn ("Recipe upgrade failed: " <> message)
      exitFailure
    Right (recipeEntries, covered) -> do
      let filtered = [(dm, origin) | (dm, origin) <- withOrigins, null requested || moduleNameFromDm dm `elem` requested, moduleNameFromDm dm `notElem` covered]
          grouped = Map.toList $ Map.fromListWith (++) [(origin ^. #sourceUrl, [(dm, origin)]) | (dm, origin) <- filtered]
      moduleEntries <- concat <$> mapM (upgradeSource uopts) grouped
      let entries = recipeEntries <> moduleEntries
      if null entries
        then TIO.putStrLn "No installed modules or recipes with origin metadata found."
        else do
          if uopts ^. #json then LBS.putStr (encodePretty entries) else renderUpgradeTable (uopts ^. #dryRun) entries
          unless (uopts ^. #dryRun) $ do
            handlePostUpgradeMigrations uopts entries
            when (not (uopts ^. #json)) $ forM_ selectedRecipes $ \recipe -> TIO.putStrLn $ "Run 'seihou update " <> recipe ^. #name <> "' to reconcile the recorded project application."

-- Refresh each selected recipe's complete candidate closure, including an
-- unchanged child whose base has changed. Publication uses staged bytes only.
upgradeRecipes :: UpgradeOpts -> [DiscoveredRunnable] -> IO (Either Text ([UpgradeEntry], [Text]))
upgradeRecipes _ [] = pure (Right ([], []))
upgradeRecipes opts recipes = withSystemTempDirectory "seihou-recipe-upgrade" $ \session -> do
  now <- getCurrentTime
  root <- Directory.getCurrentDirectory
  cache <- installedRoot
  roots <- forM recipes $ \recipe -> do
    origin <- readOriginInfo (recipe ^. #dir)
    pure $ case origin of
      Nothing -> Left ("Recipe '" <> recipe ^. #name <> "' has no origin metadata; reinstall it from its registry.")
      Just info -> Right (buildAppliedComposition (AppliedRecipeTarget (RecipeName (recipe ^. #name))) (RemoteOrigin (info ^. #sourceUrl) (recipe ^. #name) (info ^. #repoName)) (info ^. #version) [] Nothing Nothing [] Map.empty now)
  case sequence roots of
    Left message -> pure (Left message)
    Right applications -> do
      staged <- stageCandidateSources session root cache applications
      case staged of
        Left err -> pure (Left (renderUpdateHuman False (errorOutput err)))
        Right (catalog, _) -> do
          compared <- forM (Map.elems (catalog ^. #artifacts)) $ \artifact -> do
            let path = cache </> T.unpack (artifact ^. #name)
            old <- readOriginInfo path
            present <- Directory.doesDirectoryExist path
            oldHash <- if present then Just <$> hashArtifactDirectory path else pure Nothing
            let changed = oldHash /= Just (artifact ^. #contentHash)
                skipped = opts ^. #skipUnversioned && (artifact ^. #version == Nothing || maybe False ((== Nothing) . (^. #version)) old)
                status
                  | changed && skipped = Skipped
                  | changed = Upgraded
                  | otherwise = AlreadyUpToDate
                entry = UpgradeEntry (artifact ^. #name) (old >>= (^. #version)) (artifact ^. #version) status
                prepared = ClosureArtifact (artifact ^. #name) (fromMaybe "" (artifact ^. #sourceUrl)) (artifact ^. #repoName) (artifact ^. #version) (artifact ^. #tags) (artifact ^. #sourceRevision) (artifact ^. #sourceDirectory)
            pure (entry, prepared)
          let blocked = any ((== Skipped) . (^. #upgradeStatus) . fst) compared
              entries = [if blocked && entry ^. #upgradeStatus == Upgraded then entry & #upgradeStatus .~ Skipped else entry | (entry, _) <- compared]
              changes = [artifact | (entry, artifact) <- compared, entry ^. #upgradeStatus == Upgraded]
          published <- if opts ^. #dryRun || blocked || null changes then pure (Right ()) else publishStagedClosure cache changes
          pure $ do
            published
            Right (entries, map (^. #name) (Map.elems (catalog ^. #artifacts)))

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 :: Bool -> [UpgradeEntry] -> IO ()
renderUpgradeTable dryRun entries = do
  colorEnabled <- useColor
  let upgradedLabel = if dryRun then "would upgrade" else "upgraded"
      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 "Artifact"
          <> 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 upgradedLabel else upgradedLabel
              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))
      <> " artifact(s) checked, "
      <> T.pack (show upgraded)
      <> " "
      <> upgradedLabel
      <> (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