TwoDeveloperFixture.hs

-- | One project shared by two simulated developers, each with their own
-- seihou configuration root.
--
-- Both developers work in the same @projectRoot@ — that is the point, since it
-- models a git checkout they both have. What differs is @homeA@ and @homeB@,
-- each of which becomes @XDG_CONFIG_HOME@ for that developer's invocations, so
-- each has an independent @\<home\>\/seihou\/installed\/@ and
-- @\<home\>\/seihou\/modules\/@. That single variable is the whole difference
-- between two developers as far as seihou is concerned.
module Seihou.CLI.TwoDeveloperFixture
  ( TwoDeveloperFixture (..),
    prepareTwoDeveloperFixture,
    installModuleVersion,
    moduleSourceUrl,
    seihouBinary,
    runSeihouAs,
    gitStatus,
    gitCommitAll,
    resetWorkingTree,
  )
where

import Control.Lens ((^.))
import Data.Generics.Labels ()
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import GHC.Generics (Generic)
import Seihou.CLI.SeihouBinary (seihouBinary)
import System.Directory (createDirectoryIfMissing)
import System.Environment (getEnvironment)
import System.Exit (ExitCode (..))
import System.FilePath ((</>))
import System.Process (CreateProcess (..), callProcess, proc, readCreateProcessWithExitCode, readProcess)

data TwoDeveloperFixture = TwoDeveloperFixture
  { projectRoot :: !FilePath,
    manifestPath :: !FilePath,
    projectFile :: !FilePath,
    homeA :: !FilePath,
    homeB :: !FilePath,
    moduleName :: !Text
  }
  deriving stock (Eq, Show, Generic)

-- | The URL both developers' installed copies record as their upstream.
--
-- Nothing is ever fetched from it. It exists so the two copies are recognisably
-- the *same* artifact — which is what lets the guard compare their versions
-- rather than reporting an origin mismatch.
moduleSourceUrl :: Text
moduleSourceUrl = "https://example.com/demo-modules.git"

-- | Build the fixture under @root@.
--
-- Installs @demo@ at @versionA@ into developer A's configuration root and at
-- @versionB@ into developer B's, both carrying the same
-- @.seihou-origin.json@ source URL, and initialises @projectRoot@ as a git
-- repository with an initial commit so working-tree assertions are meaningful.
prepareTwoDeveloperFixture :: FilePath -> Text -> Text -> IO TwoDeveloperFixture
prepareTwoDeveloperFixture root versionA versionB = do
  let projectRoot = root </> "project"
      fixture =
        TwoDeveloperFixture
          { projectRoot = projectRoot,
            manifestPath = projectRoot </> ".seihou" </> "manifest.json",
            projectFile = projectRoot </> "README.md",
            homeA = root </> "home-a",
            homeB = root </> "home-b",
            moduleName = "demo"
          }
  createDirectoryIfMissing True projectRoot
  TIO.writeFile (projectRoot </> "PROJECT.md") "a project two developers share\n"
  installModuleVersion (fixture ^. #homeA) (fixture ^. #moduleName) versionA
  installModuleVersion (fixture ^. #homeB) (fixture ^. #moduleName) versionB
  callProcess "git" ["-C", projectRoot, "init", "-q"]
  callProcess "git" ["-C", projectRoot, "config", "user.name", "Seihou Test"]
  callProcess "git" ["-C", projectRoot, "config", "user.email", "test@example.com"]
  gitCommitAll fixture "test: seed the shared project"
  pure fixture

-- | Install one version of a module into a developer's configuration root,
-- replacing whatever was there. Mirrors what @seihou install@ lays down:
-- the module directory, its template files, and the @.seihou-origin.json@
-- recording where it came from.
installModuleVersion :: FilePath -> Text -> Text -> IO ()
installModuleVersion home name version = do
  let installed = home </> "seihou" </> "installed" </> T.unpack name
  createDirectoryIfMissing True (installed </> "files")
  TIO.writeFile (installed </> "module.dhall") (moduleDhall name version)
  TIO.writeFile (installed </> "files" </> "README.tmpl") (readmeTemplate version)
  TIO.writeFile
    (installed </> ".seihou-origin.json")
    ( "{\"sourceUrl\":\""
        <> moduleSourceUrl
        <> "\",\"repoName\":\"demo-modules\",\"version\":\""
        <> version
        <> "\",\"installedAt\":\"2026-07-01T00:00:00Z\",\"tags\":[]}"
    )

-- | The generated file names its version, so a downgrade is visible on disk
-- and not only in the manifest.
readmeTemplate :: Text -> Text
readmeTemplate version = "# {{project.name}}\n\ngenerated by demo " <> version <> "\n"

-- | A module that declares one defaulted variable and generates one file.
--
-- Copied from @moduleDhallWithTemplate@ in
-- "Seihou.CLI.UpdateSpec" so the schema shape stays in step with the rest of
-- the suite. No prompts and no commands: this fixture drives the real binary
-- non-interactively.
moduleDhall :: Text -> Text -> Text
moduleDhall name version =
  T.unlines
    [ "{ name = \"" <> name <> "\"",
      ", version = Some \"" <> version <> "\"",
      ", description = None Text",
      ", vars = [{ name = \"project.name\", type = \"text\", default = Some \"shared\", description = None Text, required = False, validation = None Text }]",
      ", exports = [] : List { var : Text, alias : Optional Text }",
      ", prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }",
      ", steps = [{ strategy = \"template\", src = \"README.tmpl\", dest = \"README.md\", when = None Text, patch = None Text }]",
      ", commands = [] : List { run : Text, workDir : Optional Text, when : Optional Text }",
      ", dependencies = [] : List Text",
      ", removal = None { steps : List { action : Text, dest : Text, src : Optional Text }, commands : List { run : Text, workDir : Optional Text, when : Optional Text } }",
      "}"
    ]

-- | The @seihou@ executable Cabal built for this test run.
--
-- @build-tool-depends: seihou-cli:seihou@ in the test-suite stanza is what puts
-- it at a predictable place beside the test binary.
-- | Run the real binary in the shared project as one of the two developers.
--
-- @home@ becomes @XDG_CONFIG_HOME@, which is the only thing that distinguishes
-- them. The override is unconditional so a test can never reach the
-- developer's own @~\/.config\/seihou\/@.
runSeihouAs :: FilePath -> TwoDeveloperFixture -> FilePath -> [String] -> IO (ExitCode, Text, Text)
runSeihouAs binary fixture home args = do
  inherited <- getEnvironment
  let environment = ("XDG_CONFIG_HOME", home) : filter ((/= "XDG_CONFIG_HOME") . fst) inherited
      command = (proc binary args) {cwd = Just (fixture ^. #projectRoot), env = Just environment}
  (exitCode, stdoutText, stderrText) <- readCreateProcessWithExitCode command ""
  pure (exitCode, T.pack stdoutText, T.pack stderrText)

-- | @git status --porcelain@ in the shared project. Empty means nothing was
-- written.
gitStatus :: TwoDeveloperFixture -> IO Text
gitStatus fixture =
  T.strip . T.pack <$> readProcess "git" ["-C", fixture ^. #projectRoot, "status", "--porcelain"] ""

-- | Commit everything in the shared project, as a developer would before
-- pushing.
gitCommitAll :: TwoDeveloperFixture -> String -> IO ()
gitCommitAll fixture message = do
  callProcess "git" ["-C", fixture ^. #projectRoot, "add", "-A"]
  callProcess "git" ["-C", fixture ^. #projectRoot, "commit", "-qm", message]

-- | Throw away every uncommitted change, putting the shared project back to
-- the last commit.
resetWorkingTree :: TwoDeveloperFixture -> IO ()
resetWorkingTree fixture = do
  callProcess "git" ["-C", fixture ^. #projectRoot, "checkout", "-q", "--", "."]
  callProcess "git" ["-C", fixture ^. #projectRoot, "clean", "-qfd"]