Unverified Commit 79649a5f authored by Oleg Grenrus's avatar Oleg Grenrus Committed by GitHub

Merge pull request #6684 from phadej/issue-6610

6610 Add pijul to known repository type
parents 4d1dcd2d e7e60f17
......@@ -1922,6 +1922,7 @@ repoTypeDirname Mercurial = [".hg"]
repoTypeDirname GnuArch = [".arch-params"]
repoTypeDirname Bazaar = [".bzr"]
repoTypeDirname Monotone = ["_MTN"]
repoTypeDirname Pijul = [".pijul"]
-- ------------------------------------------------------------
-- * Checks involving files in the package
......
......@@ -126,7 +126,7 @@ instance NFData RepoKind where rnf = genericRnf
-- obtain and track the repo depend on the repo type.
--
data KnownRepoType = Darcs | Git | SVN | CVS
| Mercurial | GnuArch | Bazaar | Monotone
| Mercurial | GnuArch | Bazaar | Monotone | Pijul
deriving (Eq, Generic, Ord, Read, Show, Typeable, Data, Enum, Bounded)
instance Binary KnownRepoType
......
......@@ -23,6 +23,6 @@ tests = testGroup "Distribution.Utils.Structured"
, testCase "SPDX.License" $ structureHash (Proxy :: Proxy License) @?= Fingerprint 0xd3d4a09f517f9f75 0xbc3d16370d5a853a
-- The difference is in encoding of newtypes
#if MIN_VERSION_base(4,7,0)
, testCase "LocalBuildInfo" $ structureHash (Proxy :: Proxy LocalBuildInfo) @?= Fingerprint 0xe426ef7c5c6e25e8 0x79b156f0f3c58f79
, testCase "LocalBuildInfo" $ structureHash (Proxy :: Proxy LocalBuildInfo) @?= Fingerprint 0x27de6f0a3d133e71 0x81c8d35b9e4b8bf0
#endif
]
......@@ -28,6 +28,7 @@ module Distribution.Client.VCS (
vcsGit,
vcsHg,
vcsSvn,
vcsPijul,
) where
import Prelude ()
......@@ -498,3 +499,147 @@ svnProgram = (simpleProgram "svn") {
_ -> ""
}
-- | VCS driver for Pijul.
-- Documentation for Pijul can be found at <https://pijul.org/manual/introduction.html>
--
-- 2020-04-09 Oleg:
--
-- As far as I understand pijul, there are branches and "tags" in pijul,
-- but there aren't a "commit hash" identifying an arbitrary state.
--
-- One can create `a pijul tag`, which will make a patch hash,
-- which depends on everything currently in the repository.
-- I guess if you try to apply that patch, you'll be forced to apply
-- all the dependencies too. In other words, there are no named tags.
--
-- It's not clear to me whether there is an option to
-- "apply this patch *and* all of its dependencies".
-- And relatedly, whether how to make sure that there are no other
-- patches applied.
--
-- With branches it's easier, as you can `pull` and `checkout` them,
-- and they seem to be similar enough. Yet, pijul documentations says
--
-- > Note that the purpose of branches in Pijul is quite different from Git,
-- since Git's "feature branches" can usually be implemented by just
-- patches.
--
-- I guess it means that indeed instead of creating a branch and making PR
-- in "GitHub" workflow, you'd just create a patch and offer it.
-- You can do that with `git` too. Push (a branch with) commit to remote
-- and ask other to cherry-pick that commit. Yet, in git identity of commit
-- changes when it applied to other trees, where patches in pijul have
-- will continue to have the same hash.
--
-- Unfortunately pijul doesn't talk about conflict resolution.
-- It seems that you get something like:
--
-- % pijul status
-- On branch merge
--
-- Unresolved conflicts:
-- (fix conflicts and record the resolution with "pijul record ...")
--
-- foo
--
-- % cat foo
-- first line
-- >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
-- branch BBB
-- ================================
-- branch AAA
-- <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-- last line
--
-- And then the `pijul dependencies` would draw you a graph like
--
--
-- -----> foo on branch B ----->
-- resolve confict Initial patch
-- -----> foo on branch A ----->
--
-- Which is seems reasonable.
--
-- So currently, pijul support is very experimental, and most likely
-- won't work, even the basics are in place. Tests are also written
-- but disabled, as the branching model differs from `git` one,
-- for which tests are written.
--
vcsPijul :: VCS Program
vcsPijul =
VCS {
vcsRepoType = KnownRepoType Pijul,
vcsProgram = pijulProgram,
vcsCloneRepo,
vcsSyncRepos
}
where
vcsCloneRepo :: Verbosity -- ^ it seems that pijul does not have verbose flag
-> ConfiguredProgram
-> SourceRepositoryPackage f
-> FilePath
-> FilePath
-> [ProgramInvocation]
vcsCloneRepo _verbosity prog repo srcuri destdir =
[ programInvocation prog cloneArgs ]
-- And if there's a tag, we have to do that in a second step:
++ [ (programInvocation prog (checkoutArgs tag)) {
progInvokeCwd = Just destdir
}
| tag <- maybeToList (srpTag repo) ]
where
cloneArgs = ["clone", srcuri, destdir]
++ branchArgs
branchArgs = case srpBranch repo of
Just b -> ["--from-branch", b]
Nothing -> []
checkoutArgs tag = "checkout" : [tag] -- TODO: this probably doesn't work either
vcsSyncRepos :: Verbosity
-> ConfiguredProgram
-> [(SourceRepositoryPackage f, FilePath)]
-> IO [MonitorFilePath]
vcsSyncRepos _ _ [] = return []
vcsSyncRepos verbosity pijulProg
((primaryRepo, primaryLocalDir) : secondaryRepos) = do
vcsSyncRepo verbosity pijulProg primaryRepo primaryLocalDir Nothing
sequence_
[ vcsSyncRepo verbosity pijulProg repo localDir (Just primaryLocalDir)
| (repo, localDir) <- secondaryRepos ]
return [ monitorDirectoryExistence dir
| dir <- (primaryLocalDir : map snd secondaryRepos) ]
vcsSyncRepo verbosity pijulProg SourceRepositoryPackage{..} localDir peer = do
exists <- doesDirectoryExist localDir
if exists
then pijul localDir ["pull"] -- TODO: this probably doesn't work.
else pijul (takeDirectory localDir) cloneArgs
pijul localDir checkoutArgs
where
pijul :: FilePath -> [String] -> IO ()
pijul cwd args = runProgramInvocation verbosity $
(programInvocation pijulProg args) {
progInvokeCwd = Just cwd
}
cloneArgs = ["clone", loc, localDir]
++ case peer of
Nothing -> []
Just peerLocalDir -> [peerLocalDir]
where loc = srpLocation
checkoutArgs = "checkout" : ["--force", checkoutTarget, "--" ]
checkoutTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag) -- TODO: this is definitely wrong.
pijulProgram :: Program
pijulProgram = (simpleProgram "pijul") {
programFindVersion = findProgramVersion "--version" $ \str ->
case words str of
-- "pijul 0.12.2
(_:ver:_) | all isTypical ver -> ver
_ -> ""
}
where
isNum c = c >= '0' && c <= '9'
isTypical c = isNum c || c == '.'
......@@ -47,29 +47,26 @@ import UnitTests.TempTestDir (withTestDir, removeDirectoryRecursiveHack)
--
tests :: MTimeChange -> [TestTree]
tests mtimeChange =
[ testGroup "check VCS test framework" $
[ testProperty "git" prop_framework_git
] ++
[ testProperty "darcs" (prop_framework_darcs mtimeChange)
| enableDarcsTests
[ testGroup "git"
[ testProperty "check VCS test framework" prop_framework_git
, testProperty "cloneSourceRepo" prop_cloneRepo_git
, testProperty "syncSourceRepos" prop_syncRepos_git
]
, testGroup "cloneSourceRepo" $
[ testProperty "git" prop_cloneRepo_git
] ++
[ testProperty "darcs" (prop_cloneRepo_darcs mtimeChange)
| enableDarcsTests
-- for the moment they're not yet working
, testGroup "darcs" $ const []
[ testProperty "check VCS test framework" $ prop_framework_darcs mtimeChange
, testProperty "cloneSourceRepo" $ prop_cloneRepo_darcs mtimeChange
, testProperty "syncSourceRepos" $ prop_syncRepos_darcs mtimeChange
]
, testGroup "syncSourceRepos" $
[ testProperty "git" prop_syncRepos_git
] ++
[ testProperty "darcs" (prop_syncRepos_darcs mtimeChange)
| enableDarcsTests
, testGroup "pijul" $ const []
[ testProperty "check VCS test framework" prop_framework_pijul
, testProperty "cloneSourceRepo" prop_cloneRepo_pijul
, testProperty "syncSourceRepos" prop_syncRepos_pijul
]
]
where
-- for the moment they're not yet working
enableDarcsTests = False
]
prop_framework_git :: BranchingRepoRecipe -> Property
prop_framework_git =
......@@ -83,6 +80,12 @@ prop_framework_darcs mtimeChange =
. prop_framework vcsDarcs (vcsTestDriverDarcs mtimeChange)
. WithoutBranchingSupport
prop_framework_pijul :: BranchingRepoRecipe -> Property
prop_framework_pijul =
ioProperty
. prop_framework vcsPijul vcsTestDriverPijul
. WithBranchingSupport
prop_cloneRepo_git :: BranchingRepoRecipe -> Property
prop_cloneRepo_git =
ioProperty
......@@ -96,6 +99,12 @@ prop_cloneRepo_darcs mtimeChange =
. prop_cloneRepo vcsDarcs (vcsTestDriverDarcs mtimeChange)
. WithoutBranchingSupport
prop_cloneRepo_pijul :: BranchingRepoRecipe -> Property
prop_cloneRepo_pijul =
ioProperty
. prop_cloneRepo vcsPijul vcsTestDriverPijul
. WithBranchingSupport
prop_syncRepos_git :: RepoDirSet -> SyncTargetIterations -> PrngSeed
-> BranchingRepoRecipe -> Property
prop_syncRepos_git destRepoDirs syncTargetSetIterations seed =
......@@ -113,6 +122,13 @@ prop_syncRepos_darcs mtimeChange destRepoDirs syncTargetSetIterations seed =
destRepoDirs syncTargetSetIterations seed
. WithoutBranchingSupport
prop_syncRepos_pijul :: RepoDirSet -> SyncTargetIterations -> PrngSeed
-> BranchingRepoRecipe -> Property
prop_syncRepos_pijul destRepoDirs syncTargetSetIterations seed =
ioProperty
. prop_syncRepos vcsPijul vcsTestDriverPijul
destRepoDirs syncTargetSetIterations seed
. WithBranchingSupport
-- ------------------------------------------------------------
-- * General test setup
......@@ -693,3 +709,47 @@ vcsTestDriverDarcs mtimeChange verbosity vcs repoRoot =
}
darcs = runProgramInvocation verbosity . darcsInvocation
vcsTestDriverPijul :: Verbosity -> VCS ConfiguredProgram
-> FilePath -> VCSTestDriver
vcsTestDriverPijul verbosity vcs repoRoot =
VCSTestDriver {
vcsVCS = vcs
, vcsRepoRoot = repoRoot
, vcsIgnoreFiles = Set.empty
, vcsInit =
pijul $ ["init"]
, vcsAddFile = \_ filename ->
pijul ["add", filename]
, vcsCommitChanges = \_state -> do
pijul $ ["record", "-a", "-m 'a patch'"
, "-A 'A <a@example.com>'"
]
commit <- pijul' ["log"]
let commit' = takeWhile (not . isSpace) commit
return (Just commit')
-- tags work differently in pijul...
-- so this is wrong
, vcsTagState = \_ tagname ->
pijul ["tag", tagname]
, vcsSwitchBranch = \_ branchname -> do
-- unless (branchname `Map.member` allBranches) $
-- pijul ["from-branch", branchname]
pijul $ ["checkout", branchname]
, vcsCheckoutTag = Left $ \tagname ->
pijul $ ["checkout", tagname]
}
where
gitInvocation args = (programInvocation (vcsProgram vcs) args) {
progInvokeCwd = Just repoRoot
}
pijul = runProgramInvocation verbosity . gitInvocation
pijul' = getProgramInvocationOutput verbosity . gitInvocation
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment