139 lines
4.9 KiB
Haskell
139 lines
4.9 KiB
Haskell
module TestHelper (
|
|
withTempGitRepo,
|
|
withTempGitRepoWithRemote,
|
|
rawGit,
|
|
runGitIn,
|
|
testLogger,
|
|
commitCount,
|
|
gitDir,
|
|
createMergeHead,
|
|
createRevertHead,
|
|
createCherryPickHead,
|
|
createBisectLog,
|
|
createRebaseApply,
|
|
createRebaseMerge,
|
|
createSequencer,
|
|
) where
|
|
|
|
import Control.Concurrent.MVar (newMVar)
|
|
import Converge (LogLevel (..), Logger (..))
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import System.Directory (createDirectory)
|
|
import System.Exit (ExitCode)
|
|
import System.FilePath ((</>))
|
|
import System.IO (stderr)
|
|
import System.IO.Temp (withSystemTempDirectory)
|
|
import System.Process (readProcessWithExitCode)
|
|
|
|
-- | Run a git command in the given repository directory.
|
|
runGitIn :: FilePath -> [String] -> IO (ExitCode, Text, Text)
|
|
runGitIn repoPath args = do
|
|
(code, out, err) <- readProcessWithExitCode "git" ("-C" : repoPath : args) ""
|
|
pure (code, T.pack out, T.pack err)
|
|
|
|
-- | Run a git command directly (no -C prefix) -- useful for git clone, etc.
|
|
rawGit :: [String] -> IO (ExitCode, Text, Text)
|
|
rawGit args = do
|
|
(code, out, err) <- readProcessWithExitCode "git" args ""
|
|
pure (code, T.pack out, T.pack err)
|
|
|
|
-- | Create a test logger (serialized writes to stderr, Debug level).
|
|
testLogger :: IO Logger
|
|
testLogger = Logger <$> newMVar () <*> pure Debug <*> pure stderr
|
|
|
|
{- | Create a temporary git repository, configure a user, make an initial
|
|
commit on branch "main", run the action with the repo path, then clean up.
|
|
-}
|
|
withTempGitRepo :: (FilePath -> IO a) -> IO a
|
|
withTempGitRepo action = withSystemTempDirectory "converge-test" $ \tmp -> do
|
|
let repo = tmp </> "repo"
|
|
createDirectory repo
|
|
_ <- runGitIn repo ["init", "-b", "main"]
|
|
_ <- runGitIn repo ["config", "user.name", "converge-test"]
|
|
_ <- runGitIn repo ["config", "user.email", "test@converge.local"]
|
|
-- Create an initial commit so the repo has a HEAD and git log works.
|
|
writeFile (repo </> "initial.txt") "initial"
|
|
_ <- runGitIn repo ["add", "initial.txt"]
|
|
_ <- runGitIn repo ["commit", "-m", "initial commit"]
|
|
action repo
|
|
|
|
{- | Create a temporary git repo with a bare remote, run the action with the
|
|
local repo path, then clean up. The local repo is pushed to the remote
|
|
so origin/main is reachable via fetch/pull.
|
|
-}
|
|
withTempGitRepoWithRemote :: (FilePath -> IO a) -> IO a
|
|
withTempGitRepoWithRemote action = withSystemTempDirectory "converge-test-remote" $ \tmp -> do
|
|
let remoteDir = tmp </> "remote.git"
|
|
let localDir = tmp </> "local"
|
|
-- Create bare remote
|
|
createDirectory remoteDir
|
|
_ <- runGitIn remoteDir ["init", "--bare", "-b", "main"]
|
|
-- Create local repo pointing at the remote
|
|
createDirectory localDir
|
|
_ <- runGitIn localDir ["init", "-b", "main"]
|
|
_ <- runGitIn localDir ["config", "user.name", "converge-test"]
|
|
_ <- runGitIn localDir ["config", "user.email", "test@converge.local"]
|
|
_ <- runGitIn localDir ["remote", "add", "origin", remoteDir]
|
|
-- Initial commit + push so origin/main is established
|
|
writeFile (localDir </> "initial.txt") "initial"
|
|
_ <- runGitIn localDir ["add", "initial.txt"]
|
|
_ <- runGitIn localDir ["commit", "-m", "initial commit"]
|
|
_ <- runGitIn localDir ["push", "-u", "origin", "main"]
|
|
action localDir
|
|
|
|
-- | Count commits reachable from HEAD.
|
|
commitCount :: FilePath -> IO Int
|
|
commitCount repo = do
|
|
(_, out, _) <- runGitIn repo ["rev-list", "--count", "HEAD"]
|
|
let stripped = T.unpack (T.strip out)
|
|
case reads stripped of
|
|
[(n, "")] -> pure n
|
|
_ -> pure 0
|
|
|
|
-- | Get the .git directory path inside the repository.
|
|
gitDir :: FilePath -> IO FilePath
|
|
gitDir repo = do
|
|
(_, out, _) <- runGitIn repo ["rev-parse", "--git-dir"]
|
|
pure (repo </> T.unpack (T.strip out))
|
|
|
|
----------------------------------------------------------------------
|
|
-- Sentinel helpers: create well-known git files/directories inside
|
|
-- .git that indicate an in-progress operation.
|
|
----------------------------------------------------------------------
|
|
|
|
createMergeHead :: FilePath -> IO ()
|
|
createMergeHead repo = do
|
|
dir <- gitDir repo
|
|
writeFile (dir </> "MERGE_HEAD") ""
|
|
|
|
createRevertHead :: FilePath -> IO ()
|
|
createRevertHead repo = do
|
|
dir <- gitDir repo
|
|
writeFile (dir </> "REVERT_HEAD") ""
|
|
|
|
createCherryPickHead :: FilePath -> IO ()
|
|
createCherryPickHead repo = do
|
|
dir <- gitDir repo
|
|
writeFile (dir </> "CHERRY_PICK_HEAD") ""
|
|
|
|
createBisectLog :: FilePath -> IO ()
|
|
createBisectLog repo = do
|
|
dir <- gitDir repo
|
|
writeFile (dir </> "BISECT_LOG") ""
|
|
|
|
createRebaseApply :: FilePath -> IO ()
|
|
createRebaseApply repo = do
|
|
dir <- gitDir repo
|
|
createDirectory (dir </> "rebase-apply")
|
|
|
|
createRebaseMerge :: FilePath -> IO ()
|
|
createRebaseMerge repo = do
|
|
dir <- gitDir repo
|
|
createDirectory (dir </> "rebase-merge")
|
|
|
|
createSequencer :: FilePath -> IO ()
|
|
createSequencer repo = do
|
|
dir <- gitDir repo
|
|
createDirectory (dir </> "sequencer")
|