Install.hs

module Seihou.CLI.Install
  ( handleInstall,
    installModuleDir,
    cloneRepo,
    copyDirectoryRecursive,
  )
where

import Control.Applicative ((<|>))
import Control.Monad (when)
import Data.Generics.Labels ()
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import Seihou.CLI.BrowseFormat (kindLabel)
import Seihou.CLI.Commands (InstallOpts (..))
import Seihou.CLI.InstallHistory (HistoryEntry (..), InstallHistory (..), readHistory, recordUrl)
import Seihou.CLI.InstallShared
  ( InstallOutcome (..),
    cloneRepo,
    copyDirectoryRecursive,
    formatInstallRefusal,
    installModuleDir,
  )
import Seihou.CLI.Registry.Sync (checkRegistryVersionDrift)
import Seihou.CLI.Shared (logIO)
import Seihou.Core.AgentPrompt (validateAgentPrompt)
import Seihou.Core.Blueprint (validateBlueprint)
import Seihou.Core.Install (parseModuleName)
import Seihou.Core.Module (validateModule)
import Seihou.Core.Registry (EntryKind (..), Registry (..), RegistryEntry (..), RepoContents (..), discoverRepoContents, validateRegistry)
import Seihou.Core.Types
import Seihou.Dhall.Eval (evalAgentPromptFromFile, evalBlueprintFromFile, evalModuleFromFile, evalRegistryFromFile)
import Seihou.Effect.Fzf (selectOne)
import Seihou.Effect.FzfInterp (runFzfIO)
import Seihou.Effect.Logger (logError, logWarn)
import Seihou.Fzf (Candidate (..), FzfConfig, FzfResult (..), detectFzfConfig, isFzfUsable, withAnsi, withHeader, withHeight, withNoSort, withPrompt)
import Seihou.Fzf qualified
import Seihou.Prelude
import System.Directory (doesFileExist)
import System.Exit (exitFailure)
import System.IO (hFlush, stdout)
import System.IO.Temp (withSystemTempDirectory)

handleInstall :: InstallOpts -> IO ()
handleInstall iopts = do
  source <- resolveSource (iopts ^. #source)

  TIO.putStrLn $ "Installing from " <> source <> "..."

  -- Clone into a temporary directory
  withSystemTempDirectory "seihou-install" $ \tmpDir -> do
    let repoName = parseModuleName source
        cloneDir = tmpDir </> repoName
    cloneRes <- cloneRepo source cloneDir
    case cloneRes of
      Left err -> do
        logIO LogNormal $ do
          logError err
        exitFailure
      Right () -> TIO.putStrLn "  Cloned repository"

    -- Determine what the repo contains
    contents <- discoverRepoContents evalRegistryFromFile cloneDir
    case contents of
      EmptyRepo -> do
        logIO LogNormal (logError "repository contains neither seihou-registry.dhall nor a supported runnable Dhall file.")
        exitFailure
      SingleModule rootDir -> do
        when (not (null (iopts ^. #modules)) || iopts ^. #all) $
          logIO LogNormal (logWarn "--module and --all flags are ignored for single-module repositories.")
        installSingleModule iopts rootDir source Nothing
      SingleRecipe rootDir -> do
        when (not (null (iopts ^. #modules)) || iopts ^. #all) $
          logIO LogNormal (logWarn "--module and --all flags are ignored for single-recipe repositories.")
        installSingleRecipe iopts rootDir source
      SingleBlueprint rootDir -> do
        when (not (null (iopts ^. #modules)) || iopts ^. #all) $
          logIO LogNormal (logWarn "--module and --all flags are ignored for single-blueprint repositories.")
        installSingleBlueprint iopts rootDir source
      SinglePrompt rootDir -> do
        when (not (null (iopts ^. #modules)) || iopts ^. #all) $
          logIO LogNormal (logWarn "--module and --all flags are ignored for single-prompt repositories.")
        installSinglePrompt iopts rootDir source
      MultiModule registry -> do
        regErrors <- validateRegistry cloneDir registry
        if not (null regErrors)
          then do
            logIO LogNormal $ do
              logError "registry has validation errors:"
              mapM_ (\e -> logError $ "  - " <> e) regErrors
            exitFailure
          else do
            driftWarnings <- checkRegistryVersionDrift cloneDir registry
            logIO LogNormal (mapM_ logWarn driftWarnings)
            installFromRegistry iopts cloneDir registry source

  -- Record URL in history for future recall (only reached on success)
  recordUrl source

-- | Resolve the install source: use the explicit URL if given, otherwise pick from history.
resolveSource :: Maybe Text -> IO Text
resolveSource (Just url) = pure url
resolveSource Nothing = do
  history <- readHistory
  case history ^. #entries of
    [] -> do
      TIO.putStrLn "No URL specified and no install history found."
      TIO.putStrLn "Usage: seihou install <git-url>"
      exitFailure
    entries -> do
      fzfCfg <- detectFzfConfig
      if isFzfUsable fzfCfg
        then fzfUrlSelection fzfCfg entries
        else promptUrlSelection entries

-- | FZF selection of a URL from history.
fzfUrlSelection :: FzfConfig -> [HistoryEntry] -> IO Text
fzfUrlSelection fzfCfg entries = do
  let candidates =
        [ Candidate
            { display = entry ^. #url,
              value = entry ^. #url
            }
        | entry <- entries
        ]
      opts = withPrompt "install> " <> withHeader "Select a previously used source:" <> withHeight "40%" <> withAnsi <> withNoSort
  result <- runEff $ runFzfIO fzfCfg $ selectOne opts candidates
  case result of
    FzfSelected url -> pure url
    FzfCancelled -> do
      TIO.putStrLn "Cancelled."
      exitFailure
    FzfNoMatch -> do
      TIO.putStrLn "No match."
      exitFailure
    FzfError err -> do
      TIO.putStrLn $ "fzf error: " <> err <> ", falling back to prompt"
      promptUrlSelection entries

-- | Numbered prompt fallback for URL selection.
promptUrlSelection :: [HistoryEntry] -> IO Text
promptUrlSelection entries = do
  TIO.putStrLn ""
  TIO.putStrLn "Previously used sources:"
  let numbered = zip [1 :: Int ..] entries
  mapM_
    (\(i, entry) -> TIO.putStrLn $ "  " <> T.pack (show i) <> ") " <> entry ^. #url)
    numbered
  TIO.putStrLn ""
  TIO.putStr "Select a source (number): "
  hFlush stdout
  input <- TIO.getLine
  case readMaybe (T.unpack (T.strip input)) of
    Just n
      | n >= 1 && n <= length entries ->
          pure ((entries !! (n - 1)) ^. #url)
    _ -> do
      TIO.putStrLn "Invalid selection."
      exitFailure

-- | Install a single-module repo (legacy behavior).
installSingleModule :: InstallOpts -> FilePath -> Text -> Maybe Text -> IO ()
installSingleModule iopts rootDir source registryName = do
  let name = case iopts ^. #name of
        Just n -> T.unpack n
        Nothing -> parseModuleName source

  let dhallFile = rootDir </> "module.dhall"
  decoded <- evalModuleFromFile dhallFile
  modul <- case decoded of
    Left err -> do
      logIO LogNormal $ do
        logError "repository is not a valid seihou module."
        logError $ "  " <> T.pack (show err)
      exitFailure
    Right m -> pure m

  result <- validateModule rootDir modul
  case result of
    Left (ValidationError _ errors) -> do
      logIO LogNormal $ do
        logError "module has validation errors:"
        mapM_ (\e -> logError $ "  - " <> e) errors
      exitFailure
    Left err -> do
      logIO LogNormal (logError $ T.pack (show err))
      exitFailure
    Right _ -> pure ()
  TIO.putStrLn "  Validated module definition"

  outcome <- installModuleDir (iopts ^. #force) rootDir name source registryName (modul ^. #version) []
  reportSingleInstall name source outcome
  TIO.putStrLn ""
  TIO.putStrLn $ "Module available as: " <> T.pack name

-- | Install a single-recipe repo.
installSingleRecipe :: InstallOpts -> FilePath -> Text -> IO ()
installSingleRecipe iopts rootDir source = do
  let name = case iopts ^. #name of
        Just n -> T.unpack n
        Nothing -> parseModuleName source

  -- Validate recipe.dhall exists (discoverRepoContents already confirmed it)
  TIO.putStrLn "  Validated recipe definition"

  outcome <- installModuleDir (iopts ^. #force) rootDir name source Nothing Nothing []
  reportSingleInstall name source outcome
  TIO.putStrLn ""
  TIO.putStrLn $ "Recipe available as: " <> T.pack name

-- | Install a single-blueprint repo.
installSingleBlueprint :: InstallOpts -> FilePath -> Text -> IO ()
installSingleBlueprint iopts rootDir source = do
  let name = case iopts ^. #name of
        Just n -> T.unpack n
        Nothing -> parseModuleName source

  let dhallFile = rootDir </> "blueprint.dhall"
  decoded <- evalBlueprintFromFile dhallFile
  bp <- case decoded of
    Left err -> do
      logIO LogNormal $ do
        logError "repository is not a valid seihou blueprint."
        logError $ "  " <> T.pack (show err)
      exitFailure
    Right b -> pure b

  result <- validateBlueprint rootDir bp
  case result of
    Left (ValidationError _ errors) -> do
      logIO LogNormal $ do
        logError "blueprint has validation errors:"
        mapM_ (\e -> logError $ "  - " <> e) errors
      exitFailure
    Left err -> do
      logIO LogNormal (logError $ T.pack (show err))
      exitFailure
    Right _ -> pure ()
  TIO.putStrLn "  Validated blueprint definition"

  let bpVersion = (bp ^. #version)
  outcome <- installModuleDir (iopts ^. #force) rootDir name source Nothing bpVersion []
  reportSingleInstall name source outcome
  TIO.putStrLn ""
  TIO.putStrLn $ "Blueprint available as: " <> T.pack name

-- | Install a single-prompt repo.
installSinglePrompt :: InstallOpts -> FilePath -> Text -> IO ()
installSinglePrompt iopts rootDir source = do
  let name = case iopts ^. #name of
        Just n -> T.unpack n
        Nothing -> parseModuleName source

  let dhallFile = rootDir </> "prompt.dhall"
  decoded <- evalAgentPromptFromFile dhallFile
  prompt <- case decoded of
    Left err -> do
      logIO LogNormal $ do
        logError "repository is not a valid seihou prompt."
        logError $ "  " <> T.pack (show err)
      exitFailure
    Right p -> pure p

  result <- validateAgentPrompt rootDir prompt
  case result of
    Left (ValidationError _ errors) -> do
      logIO LogNormal $ do
        logError "prompt has validation errors:"
        mapM_ (\e -> logError $ "  - " <> e) errors
      exitFailure
    Left err -> do
      logIO LogNormal (logError $ T.pack (show err))
      exitFailure
    Right _ -> pure ()
  TIO.putStrLn "  Validated prompt definition"

  outcome <- installModuleDir (iopts ^. #force) rootDir name source Nothing (prompt ^. #version) []
  reportSingleInstall name source outcome
  TIO.putStrLn ""
  TIO.putStrLn $ "Prompt available as: " <> T.pack name

-- | Install from a multi-module registry.
installFromRegistry :: InstallOpts -> FilePath -> Registry -> Text -> IO ()
installFromRegistry iopts cloneDir registry source = do
  selected <- selectModules iopts registry
  if null selected
    then TIO.putStrLn "No entries selected."
    else do
      results <- mapM (installRegistryEntry (iopts ^. #force) cloneDir source (registry ^. #repoName)) selected
      let succeeded = length (filter id results)
          failed = length results - succeeded
      TIO.putStrLn ""
      TIO.putStrLn $
        T.pack (show succeeded)
          <> " "
          <> (if succeeded == 1 then "entry" else "entries")
          <> " installed"
          <> (if failed > 0 then ", " <> T.pack (show failed) <> " failed" else "")
          <> "."
      -- A batch runs to completion before it reports, so a user installing
      -- twenty entries sees every refusal and every load failure at once
      -- rather than stopping at the first. But a batch that did not fully
      -- succeed must not exit zero: a caller in a script would otherwise
      -- treat a half-applied install as done.
      when (failed > 0) exitFailure

-- | Report one single-artifact install. A refusal is fatal here: the command
-- was asked to install exactly one thing and did not.
reportSingleInstall :: String -> Text -> InstallOutcome -> IO ()
reportSingleInstall _ _ InstallPerformed = pure ()
reportSingleInstall name source (InstallRefused collision) = do
  TIO.putStrLn ""
  TIO.putStrLn (formatInstallRefusal name source collision)
  exitFailure

-- | Report one registry-batch install, returning whether it succeeded. A
-- refusal is not fatal here: the remaining entries are still attempted, and
-- 'installFromRegistry' exits nonzero once it has reported them all.
reportRegistryInstall :: String -> Text -> InstallOutcome -> Text -> IO Bool
reportRegistryInstall _ _ InstallPerformed successLine = do
  TIO.putStrLn successLine
  pure True
reportRegistryInstall name source (InstallRefused collision) _ = do
  TIO.putStrLn (formatInstallRefusal name source collision)
  pure False

-- | All registry entries (modules, recipes, blueprints, prompts) in display order.
-- Used wherever installation must treat all four kinds uniformly.
allEntries :: Registry -> [RegistryEntry]
allEntries registry = registry ^. #modules ++ registry ^. #recipes ++ registry ^. #blueprints ++ (registry ^. #prompts)

-- | Pair each registry entry with its 'EntryKind' tag, preserving the
-- module → recipe → blueprint → prompt display order. Used by the install picker
-- to render per-kind labels and by callers that need to discriminate
-- after selection.
labelledEntries :: Registry -> [(EntryKind, RegistryEntry)]
labelledEntries registry =
  map ((,) ModuleEntry) (registry ^. #modules)
    ++ map ((,) RecipeEntry) (registry ^. #recipes)
    ++ map ((,) BlueprintEntry) (registry ^. #blueprints)
    ++ map ((,) PromptEntry) (registry ^. #prompts)

-- | Select which modules to install from a registry.
selectModules :: InstallOpts -> Registry -> IO [RegistryEntry]
selectModules iopts registry
  | (iopts ^. #all) = pure (allEntries registry)
  | not (null (iopts ^. #modules)) = do
      let entries = allEntries registry
          findEntry name = filter (\e -> e ^. #name . #unModuleName == name) entries
          (found, missing) =
            foldr
              ( \name (f, m) -> case findEntry name of
                  (e : _) -> (e : f, m)
                  [] -> (f, name : m)
              )
              ([], [])
              (iopts ^. #modules)
      if not (null missing)
        then do
          logIO LogNormal $ do
            logError "the following entries were not found in the registry:"
            mapM_ (\n -> logError $ "  - " <> n) missing
          exitFailure
        else pure found
  | otherwise = do
      fzfCfg <- detectFzfConfig
      if isFzfUsable fzfCfg
        then fzfModuleSelection fzfCfg registry
        else promptModuleSelection registry

-- | Interactive module selection via fzf.
fzfModuleSelection :: Seihou.Fzf.FzfConfig -> Registry -> IO [RegistryEntry]
fzfModuleSelection fzfCfg registry = do
  let entries = labelledEntries registry
      candidates =
        [ Candidate
            { display =
                kindLabel kind
                  <> "  "
                  <> entry ^. #name . #unModuleName
                  <> maybe "" (\d -> "  " <> d) (entry ^. #description)
                  <> if null (entry ^. #tags) then "" else "  [" <> T.intercalate ", " (entry ^. #tags) <> "]",
              value = entry
            }
        | (kind, entry) <- entries
        ]
      opts = withPrompt "entry> " <> withHeight "40%" <> withAnsi <> withNoSort
  result <- runEff $ runFzfIO fzfCfg $ selectOne opts candidates
  case result of
    FzfSelected entry -> pure [entry]
    FzfCancelled -> pure []
    FzfNoMatch -> pure []
    FzfError err -> do
      TIO.putStrLn $ "fzf error: " <> err
      promptModuleSelection registry

-- | Interactive module selection via numbered list.
promptModuleSelection :: Registry -> IO [RegistryEntry]
promptModuleSelection registry = do
  TIO.putStrLn ""
  TIO.putStrLn $ (registry ^. #repoName)
  case registry ^. #repoDescription of
    Just desc -> TIO.putStrLn $ "  " <> desc
    Nothing -> pure ()
  TIO.putStrLn ""
  TIO.putStrLn "Available modules, recipes, blueprints, and prompts:"
  let entries = zip [1 :: Int ..] (labelledEntries registry)
  mapM_
    ( \(i, (kind, entry)) ->
        TIO.putStrLn $
          "  "
            <> T.pack (show i)
            <> ") "
            <> kindLabel kind
            <> "  "
            <> entry ^. #name . #unModuleName
            <> maybe "" (\d -> " - " <> d) (entry ^. #description)
    )
    entries
  TIO.putStrLn ""
  TIO.putStr "Select entries (comma-separated numbers, or 'all'): "
  hFlush stdout
  input <- TIO.getLine
  let trimmed = T.strip input
  let entryList = allEntries registry
  if T.toLower trimmed == "all"
    then pure entryList
    else do
      let nums = map (readMaybe . T.unpack . T.strip) (T.splitOn "," trimmed)
      if any (== Nothing) nums
        then do
          TIO.putStrLn "Invalid input. Please enter numbers separated by commas."
          pure []
        else do
          let indices = map (\(Just n) -> n) nums
              maxIdx = length entryList
              valid = all (\n -> n >= 1 && n <= maxIdx) indices
          if not valid
            then do
              TIO.putStrLn $ "Invalid selection. Please enter numbers between 1 and " <> T.pack (show maxIdx) <> "."
              pure []
            else pure [entryList !! (n - 1) | n <- indices]

-- | Install a single registry entry (module, recipe, blueprint, or prompt).
installRegistryEntry :: Bool -> FilePath -> Text -> Text -> RegistryEntry -> IO Bool
installRegistryEntry force cloneDir source repoName entry = do
  let entryDir = cloneDir </> (entry ^. #path)
      name = T.unpack (entry ^. #name . #unModuleName)
      moduleDhall = entryDir </> "module.dhall"
      recipeDhall = entryDir </> "recipe.dhall"
      blueprintDhall = entryDir </> "blueprint.dhall"
      promptDhall = entryDir </> "prompt.dhall"
  TIO.putStrLn $ "  Installing " <> entry ^. #name . #unModuleName <> "..."

  hasModule <- doesFileExist moduleDhall
  if hasModule
    then do
      decoded <- evalModuleFromFile moduleDhall
      case decoded of
        Left err -> do
          logIO LogNormal $ do
            logError $ "  failed to load " <> entry ^. #name . #unModuleName <> ": " <> T.pack (show err)
          pure False
        Right modul -> do
          result <- validateModule entryDir modul
          case result of
            Left (ValidationError _ errors) -> do
              logIO LogNormal $ do
                logError $ "  " <> entry ^. #name . #unModuleName <> " has validation errors:"
                mapM_ (\e -> logError $ "    - " <> e) errors
              pure False
            Left err -> do
              logIO LogNormal (logError $ "  " <> T.pack (show err))
              pure False
            Right _ -> do
              let ver = entry ^. #version <|> (modul ^. #version)
              outcome <- installModuleDir force entryDir name source (Just repoName) ver (entry ^. #tags)
              reportRegistryInstall name source outcome ("    Installed as: " <> T.pack name)
    else do
      hasRecipe <- doesFileExist recipeDhall
      if hasRecipe
        then do
          outcome <- installModuleDir force entryDir name source (Just repoName) (entry ^. #version) (entry ^. #tags)
          reportRegistryInstall name source outcome ("    Installed recipe as: " <> T.pack name)
        else do
          hasBlueprint <- doesFileExist blueprintDhall
          if hasBlueprint
            then do
              decoded <- evalBlueprintFromFile blueprintDhall
              case decoded of
                Left err -> do
                  logIO LogNormal $ do
                    logError $ "  failed to load " <> entry ^. #name . #unModuleName <> ": " <> T.pack (show err)
                  pure False
                Right bp -> do
                  let bpVersion = (bp ^. #version)
                      ver = entry ^. #version <|> bpVersion
                  outcome <- installModuleDir force entryDir name source (Just repoName) ver (entry ^. #tags)
                  reportRegistryInstall name source outcome ("    Installed blueprint as: " <> T.pack name)
            else do
              hasPrompt <- doesFileExist promptDhall
              if hasPrompt
                then do
                  decoded <- evalAgentPromptFromFile promptDhall
                  case decoded of
                    Left err -> do
                      logIO LogNormal $ do
                        logError $ "  failed to load " <> entry ^. #name . #unModuleName <> ": " <> T.pack (show err)
                      pure False
                    Right prompt -> do
                      result <- validateAgentPrompt entryDir prompt
                      case result of
                        Left (ValidationError _ errors) -> do
                          logIO LogNormal $ do
                            logError $ "  " <> entry ^. #name . #unModuleName <> " has validation errors:"
                            mapM_ (\e -> logError $ "    - " <> e) errors
                          pure False
                        Left err -> do
                          logIO LogNormal (logError $ "  " <> T.pack (show err))
                          pure False
                        Right _ -> do
                          let ver = entry ^. #version <|> (prompt ^. #version)
                          outcome <- installModuleDir force entryDir name source (Just repoName) ver (entry ^. #tags)
                          reportRegistryInstall name source outcome ("    Installed prompt as: " <> T.pack name)
                else do
                  logIO LogNormal $ do
                    logError $ "  entry '" <> entry ^. #name . #unModuleName <> "' has no supported runnable Dhall file at " <> T.pack (entry ^. #path)
                  pure False

readMaybe :: String -> Maybe Int
readMaybe s = case reads s of
  [(n, "")] -> Just n
  _ -> Nothing