From 7d4ce4787cb3d4fe30d08953ad64d19456a77690 Mon Sep 17 00:00:00 2001 From: Sumit Raja Date: Fri, 27 Aug 2021 06:41:21 +1000 Subject: [PATCH] Add support for hg version control system (#7133) * Add sync support for hg * Updated VCS tests to include hg. cabal.project requires tests enabled for cabal-install Co-authored-by: Emily Pillmore --- cabal-install/src/Distribution/Client/VCS.hs | 30 +++++++- .../UnitTests/Distribution/Client/VCS.hs | 69 +++++++++++++++++++ 2 files changed, 98 insertions(+), 1 deletion(-) diff --git a/cabal-install/src/Distribution/Client/VCS.hs b/cabal-install/src/Distribution/Client/VCS.hs index 0b79c965876..683fb1e7268 100644 --- a/cabal-install/src/Distribution/Client/VCS.hs +++ b/cabal-install/src/Distribution/Client/VCS.hs @@ -490,7 +490,35 @@ vcsHg = -> ConfiguredProgram -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] - vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for hg" + vcsSyncRepos _ _ [] = return [] + vcsSyncRepos verbosity hgProg + ((primaryRepo, primaryLocalDir) : secondaryRepos) = do + vcsSyncRepo verbosity hgProg primaryRepo primaryLocalDir + sequence_ + [ vcsSyncRepo verbosity hgProg repo localDir + | (repo, localDir) <- secondaryRepos ] + return [ monitorDirectoryExistence dir + | dir <- (primaryLocalDir : map snd secondaryRepos) ] + vcsSyncRepo verbosity hgProg repo localDir = do + exists <- doesDirectoryExist localDir + if exists + then hg localDir ["pull"] + else hg (takeDirectory localDir) cloneArgs + hg localDir checkoutArgs + where + hg :: FilePath -> [String] -> IO () + hg cwd args = runProgramInvocation verbosity $ + (programInvocation hgProg args) { + progInvokeCwd = Just cwd + } + cloneArgs = ["clone", "--noupdate", (srpLocation repo), localDir] + ++ verboseArg + verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + checkoutArgs = [ "checkout", "--clean" ] + ++ tagArgs + tagArgs = case srpTag repo of + Just t -> ["--rev", t] + Nothing -> [] hgProgram :: Program hgProgram = (simpleProgram "hg") { diff --git a/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs b/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs index e4d68b0f5ac..c3b8613b84d 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs @@ -66,6 +66,12 @@ tests mtimeChange = , testProperty "syncSourceRepos" prop_syncRepos_pijul ] + , testGroup "mercurial" $ const [] + [ testProperty "check VCS test framework" prop_framework_hg + , testProperty "cloneSourceRepo" prop_cloneRepo_hg + , testProperty "syncSourceRepos" prop_syncRepos_hg + ] + ] prop_framework_git :: BranchingRepoRecipe -> Property @@ -86,6 +92,12 @@ prop_framework_pijul = . prop_framework vcsPijul vcsTestDriverPijul . WithBranchingSupport +prop_framework_hg :: BranchingRepoRecipe -> Property +prop_framework_hg = + ioProperty + . prop_framework vcsHg vcsTestDriverHg + . WithBranchingSupport + prop_cloneRepo_git :: BranchingRepoRecipe -> Property prop_cloneRepo_git = ioProperty @@ -105,6 +117,12 @@ prop_cloneRepo_pijul = . prop_cloneRepo vcsPijul vcsTestDriverPijul . WithBranchingSupport +prop_cloneRepo_hg :: BranchingRepoRecipe -> Property +prop_cloneRepo_hg = + ioProperty + . prop_cloneRepo vcsHg vcsTestDriverHg + . WithBranchingSupport + prop_syncRepos_git :: RepoDirSet -> SyncTargetIterations -> PrngSeed -> BranchingRepoRecipe -> Property prop_syncRepos_git destRepoDirs syncTargetSetIterations seed = @@ -130,6 +148,14 @@ prop_syncRepos_pijul destRepoDirs syncTargetSetIterations seed = destRepoDirs syncTargetSetIterations seed . WithBranchingSupport +prop_syncRepos_hg :: RepoDirSet -> SyncTargetIterations -> PrngSeed + -> BranchingRepoRecipe -> Property +prop_syncRepos_hg destRepoDirs syncTargetSetIterations seed = + ioProperty + . prop_syncRepos vcsHg vcsTestDriverHg + destRepoDirs syncTargetSetIterations seed + . WithBranchingSupport + -- ------------------------------------------------------------ -- * General test setup -- ------------------------------------------------------------ @@ -755,3 +781,46 @@ vcsTestDriverPijul verbosity vcs repoRoot = } pijul = runProgramInvocation verbosity . gitInvocation pijul' = getProgramInvocationOutput verbosity . gitInvocation + +vcsTestDriverHg :: Verbosity -> VCS ConfiguredProgram + -> FilePath -> VCSTestDriver +vcsTestDriverHg verbosity vcs repoRoot = + VCSTestDriver { + vcsVCS = vcs + + , vcsRepoRoot = repoRoot + + , vcsIgnoreFiles = Set.empty + + , vcsInit = + hg $ ["init"] ++ verboseArg + + , vcsAddFile = \_ filename -> + hg ["add", filename] + + , vcsCommitChanges = \_state -> do + hg $ [ "--user='A '" + , "commit", "--message=a patch" + ] ++ verboseArg + commit <- hg' ["log", "--template='{node}\\n' -l1"] + let commit' = takeWhile (not . isSpace) commit + return (Just commit') + + , vcsTagState = \_ tagname -> + hg ["tag", "--force", tagname] + + , vcsSwitchBranch = \RepoState{allBranches} branchname -> do + unless (branchname `Map.member` allBranches) $ + hg ["branch", branchname] + hg $ ["checkout", branchname] ++ verboseArg + + , vcsCheckoutTag = Left $ \tagname -> + hg $ ["checkout", "--rev", tagname] ++ verboseArg + } + where + hgInvocation args = (programInvocation (vcsProgram vcs) args) { + progInvokeCwd = Just repoRoot + } + hg = runProgramInvocation verbosity . hgInvocation + hg' = getProgramInvocationOutput verbosity . hgInvocation + verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]