hackport-0.6.3: cabal/cabal-install/Distribution/Client/VCS.hs
{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}
module Distribution.Client.VCS (
-- * VCS driver type
VCS,
vcsRepoType,
vcsProgram,
-- ** Type re-exports
SourceRepo,
RepoType,
RepoKind,
Program,
ConfiguredProgram,
-- * Selecting amongst source repos
selectPackageSourceRepo,
-- * Validating 'SourceRepo's and configuring VCS drivers
validateSourceRepo,
validateSourceRepos,
SourceRepoProblem(..),
configureVCS,
configureVCSs,
-- * Running the VCS driver
cloneSourceRepo,
syncSourceRepos,
-- * The individual VCS drivers
knownVCSs,
vcsBzr,
vcsDarcs,
vcsGit,
vcsHg,
vcsSvn,
) where
import Prelude ()
import Distribution.Client.Compat.Prelude
import Distribution.Types.SourceRepo
( SourceRepo(..), RepoType(..), RepoKind(..) )
import Distribution.Client.RebuildMonad
( Rebuild, monitorFiles, MonitorFilePath, monitorDirectoryExistence )
import Distribution.Verbosity as Verbosity
( Verbosity, normal )
import Distribution.Simple.Program
( Program(programFindVersion)
, ConfiguredProgram(programVersion)
, simpleProgram, findProgramVersion
, ProgramInvocation(..), programInvocation, runProgramInvocation
, emptyProgramDb, requireProgram )
import Distribution.Version
( mkVersion )
import Control.Monad
( mapM_ )
import Control.Monad.Trans
( liftIO )
import qualified Data.Char as Char
import qualified Data.Map as Map
import Data.Ord
( comparing )
import Data.Either
( partitionEithers )
import System.FilePath
( takeDirectory )
import System.Directory
( doesDirectoryExist )
-- | A driver for a version control system, e.g. git, darcs etc.
--
data VCS program = VCS {
-- | The type of repository this driver is for.
vcsRepoType :: RepoType,
-- | The vcs program itself.
-- This is used at type 'Program' and 'ConfiguredProgram'.
vcsProgram :: program,
-- | The program invocation(s) to get\/clone a repository into a fresh
-- local directory.
vcsCloneRepo :: Verbosity
-> ConfiguredProgram
-> SourceRepo
-> FilePath -- Source URI
-> FilePath -- Destination directory
-> [ProgramInvocation],
-- | The program invocation(s) to synchronise a whole set of /related/
-- repositories with corresponding local directories. Also returns the
-- files that the command depends on, for change monitoring.
vcsSyncRepos :: Verbosity
-> ConfiguredProgram
-> [(SourceRepo, FilePath)]
-> IO [MonitorFilePath]
}
-- ------------------------------------------------------------
-- * Selecting repos and drivers
-- ------------------------------------------------------------
-- | Pick the 'SourceRepo' to use to get the package sources from.
--
-- Note that this does /not/ depend on what 'VCS' drivers we are able to
-- successfully configure. It is based only on the 'SourceRepo's declared
-- in the package, and optionally on a preferred 'RepoKind'.
--
selectPackageSourceRepo :: Maybe RepoKind
-> [SourceRepo]
-> Maybe SourceRepo
selectPackageSourceRepo preferredRepoKind =
listToMaybe
-- Sort repositories by kind, from This to Head to Unknown. Repositories
-- with equivalent kinds are selected based on the order they appear in
-- the Cabal description file.
. sortBy (comparing thisFirst)
-- If the user has specified the repo kind, filter out the repositories
-- they're not interested in.
. filter (\repo -> maybe True (repoKind repo ==) preferredRepoKind)
where
thisFirst :: SourceRepo -> Int
thisFirst r = case repoKind r of
RepoThis -> 0
RepoHead -> case repoTag r of
-- If the type is 'head' but the author specified a tag, they
-- probably meant to create a 'this' repository but screwed up.
Just _ -> 0
Nothing -> 1
RepoKindUnknown _ -> 2
data SourceRepoProblem = SourceRepoRepoTypeUnspecified
| SourceRepoRepoTypeUnsupported RepoType
| SourceRepoLocationUnspecified
deriving Show
-- | Validates that the 'SourceRepo' specifies a location URI and a repository
-- type that is supported by a VCS driver.
--
-- | It also returns the 'VCS' driver we should use to work with it.
--
validateSourceRepo :: SourceRepo
-> Either SourceRepoProblem
(SourceRepo, String, RepoType, VCS Program)
validateSourceRepo = \repo -> do
rtype <- repoType repo ?! SourceRepoRepoTypeUnspecified
vcs <- Map.lookup rtype knownVCSs ?! SourceRepoRepoTypeUnsupported rtype
uri <- repoLocation repo ?! SourceRepoLocationUnspecified
return (repo, uri, rtype, vcs)
where
a ?! e = maybe (Left e) Right a
-- | As 'validateSourceRepo' but for a bunch of 'SourceRepo's, and return
-- things in a convenient form to pass to 'configureVCSs', or to report
-- problems.
--
validateSourceRepos :: [SourceRepo]
-> Either [(SourceRepo, SourceRepoProblem)]
[(SourceRepo, String, RepoType, VCS Program)]
validateSourceRepos rs =
case partitionEithers (map validateSourceRepo' rs) of
(problems@(_:_), _) -> Left problems
([], vcss) -> Right vcss
where
validateSourceRepo' r = either (Left . (,) r) Right
(validateSourceRepo r)
configureVCS :: Verbosity
-> VCS Program
-> IO (VCS ConfiguredProgram)
configureVCS verbosity vcs@VCS{vcsProgram = prog} =
asVcsConfigured <$> requireProgram verbosity prog emptyProgramDb
where
asVcsConfigured (prog', _) = vcs { vcsProgram = prog' }
configureVCSs :: Verbosity
-> Map RepoType (VCS Program)
-> IO (Map RepoType (VCS ConfiguredProgram))
configureVCSs verbosity = traverse (configureVCS verbosity)
-- ------------------------------------------------------------
-- * Running the driver
-- ------------------------------------------------------------
-- | Clone a single source repo into a fresh directory, using a configured VCS.
--
-- This is for making a new copy, not synchronising an existing copy. It will
-- fail if the destination directory already exists.
--
-- Make sure to validate the 'SourceRepo' using 'validateSourceRepo' first.
--
cloneSourceRepo :: Verbosity
-> VCS ConfiguredProgram
-> SourceRepo -- ^ Must have 'repoLocation' filled.
-> FilePath -- ^ Destination directory
-> IO ()
cloneSourceRepo _ _ repo@SourceRepo{ repoLocation = Nothing } _ =
error $ "cloneSourceRepo: precondition violation, missing repoLocation: \""
++ show repo ++ "\". Validate using validateSourceRepo first."
cloneSourceRepo verbosity vcs
repo@SourceRepo{ repoLocation = Just srcuri } destdir =
mapM_ (runProgramInvocation verbosity) invocations
where
invocations = vcsCloneRepo vcs verbosity
(vcsProgram vcs) repo
srcuri destdir
-- | Syncronise a set of 'SourceRepo's referring to the same repository with
-- corresponding local directories. The local directories may or may not
-- already exist.
--
-- The 'SourceRepo' values used in a single invocation of 'syncSourceRepos',
-- or used across a series of invocations with any local directory must refer
-- to the /same/ repository. That means it must be the same location but they
-- can differ in the branch, or tag or subdir.
--
-- The reason to allow multiple related 'SourceRepo's is to allow for the
-- network or storage to be shared between different checkouts of the repo.
-- For example if a single repo contains multiple packages in different subdirs
-- and in some project it may make sense to use a different state of the repo
-- for one subdir compared to another.
--
syncSourceRepos :: Verbosity
-> VCS ConfiguredProgram
-> [(SourceRepo, FilePath)]
-> Rebuild ()
syncSourceRepos verbosity vcs repos = do
files <- liftIO $ vcsSyncRepos vcs verbosity (vcsProgram vcs) repos
monitorFiles files
-- ------------------------------------------------------------
-- * The various VCS drivers
-- ------------------------------------------------------------
-- | The set of all supported VCS drivers, organised by 'RepoType'.
--
knownVCSs :: Map RepoType (VCS Program)
knownVCSs = Map.fromList [ (vcsRepoType vcs, vcs) | vcs <- vcss ]
where
vcss = [ vcsBzr, vcsDarcs, vcsGit, vcsHg, vcsSvn ]
-- | VCS driver for Bazaar.
--
vcsBzr :: VCS Program
vcsBzr =
VCS {
vcsRepoType = Bazaar,
vcsProgram = bzrProgram,
vcsCloneRepo,
vcsSyncRepos
}
where
vcsCloneRepo :: Verbosity
-> ConfiguredProgram
-> SourceRepo
-> FilePath
-> FilePath
-> [ProgramInvocation]
vcsCloneRepo verbosity prog repo srcuri destdir =
[ programInvocation prog
([branchCmd, srcuri, destdir] ++ tagArgs ++ verboseArg) ]
where
-- The @get@ command was deprecated in version 2.4 in favour of
-- the alias @branch@
branchCmd | programVersion prog >= Just (mkVersion [2,4])
= "branch"
| otherwise = "get"
tagArgs = case repoTag repo of
Nothing -> []
Just tag -> ["-r", "tag:" ++ tag]
verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
vcsSyncRepos :: Verbosity -> ConfiguredProgram
-> [(SourceRepo, FilePath)] -> IO [MonitorFilePath]
vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for bzr"
bzrProgram :: Program
bzrProgram = (simpleProgram "bzr") {
programFindVersion = findProgramVersion "--version" $ \str ->
case words str of
-- "Bazaar (bzr) 2.6.0\n ... lots of extra stuff"
(_:_:ver:_) -> ver
_ -> ""
}
-- | VCS driver for Darcs.
--
vcsDarcs :: VCS Program
vcsDarcs =
VCS {
vcsRepoType = Darcs,
vcsProgram = darcsProgram,
vcsCloneRepo,
vcsSyncRepos
}
where
vcsCloneRepo :: Verbosity
-> ConfiguredProgram
-> SourceRepo
-> FilePath
-> FilePath
-> [ProgramInvocation]
vcsCloneRepo verbosity prog repo srcuri destdir =
[ programInvocation prog cloneArgs ]
where
cloneArgs = [cloneCmd, srcuri, destdir] ++ tagArgs ++ verboseArg
-- At some point the @clone@ command was introduced as an alias for
-- @get@, and @clone@ seems to be the recommended one now.
cloneCmd | programVersion prog >= Just (mkVersion [2,8])
= "clone"
| otherwise = "get"
tagArgs = case repoTag repo of
Nothing -> []
Just tag -> ["-t", tag]
verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
vcsSyncRepos :: Verbosity -> ConfiguredProgram
-> [(SourceRepo, FilePath)] -> IO [MonitorFilePath]
vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for darcs"
darcsProgram :: Program
darcsProgram = (simpleProgram "darcs") {
programFindVersion = findProgramVersion "--version" $ \str ->
case words str of
-- "2.8.5 (release)"
(ver:_) -> ver
_ -> ""
}
-- | VCS driver for Git.
--
vcsGit :: VCS Program
vcsGit =
VCS {
vcsRepoType = Git,
vcsProgram = gitProgram,
vcsCloneRepo,
vcsSyncRepos
}
where
vcsCloneRepo :: Verbosity
-> ConfiguredProgram
-> SourceRepo
-> 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 (repoTag repo) ]
where
cloneArgs = ["clone", srcuri, destdir]
++ branchArgs ++ verboseArg
branchArgs = case repoBranch repo of
Just b -> ["--branch", b]
Nothing -> []
checkoutArgs tag = "checkout" : verboseArg ++ [tag, "--"]
verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
vcsSyncRepos :: Verbosity
-> ConfiguredProgram
-> [(SourceRepo, FilePath)]
-> IO [MonitorFilePath]
vcsSyncRepos _ _ [] = return []
vcsSyncRepos verbosity gitProg
((primaryRepo, primaryLocalDir) : secondaryRepos) = do
vcsSyncRepo verbosity gitProg primaryRepo primaryLocalDir Nothing
sequence_
[ vcsSyncRepo verbosity gitProg repo localDir (Just primaryLocalDir)
| (repo, localDir) <- secondaryRepos ]
return [ monitorDirectoryExistence dir
| dir <- (primaryLocalDir : map snd secondaryRepos) ]
vcsSyncRepo verbosity gitProg SourceRepo{..} localDir peer = do
exists <- doesDirectoryExist localDir
if exists
then git localDir ["fetch"]
else git (takeDirectory localDir) cloneArgs
git localDir checkoutArgs
where
git :: FilePath -> [String] -> IO ()
git cwd args = runProgramInvocation verbosity $
(programInvocation gitProg args) {
progInvokeCwd = Just cwd
}
cloneArgs = ["clone", "--no-checkout", loc, localDir]
++ case peer of
Nothing -> []
Just peerLocalDir -> ["--reference", peerLocalDir]
++ verboseArg
where Just loc = repoLocation
checkoutArgs = "checkout" : verboseArg ++ ["--detach", "--force"
, checkoutTarget, "--" ]
checkoutTarget = fromMaybe "HEAD" (repoBranch `mplus` repoTag)
verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
gitProgram :: Program
gitProgram = (simpleProgram "git") {
programFindVersion = findProgramVersion "--version" $ \str ->
case words str of
-- "git version 2.5.5"
(_:_:ver:_) | all isTypical ver -> ver
-- or annoyingly "git version 2.17.1.windows.2" yes, really
(_:_:ver:_) -> intercalate "."
. takeWhile (all isNum)
. split
$ ver
_ -> ""
}
where
isNum c = c >= '0' && c <= '9'
isTypical c = isNum c || c == '.'
split cs = case break (=='.') cs of
(chunk,[]) -> chunk : []
(chunk,_:rest) -> chunk : split rest
-- | VCS driver for Mercurial.
--
vcsHg :: VCS Program
vcsHg =
VCS {
vcsRepoType = Mercurial,
vcsProgram = hgProgram,
vcsCloneRepo,
vcsSyncRepos
}
where
vcsCloneRepo :: Verbosity
-> ConfiguredProgram
-> SourceRepo
-> FilePath
-> FilePath
-> [ProgramInvocation]
vcsCloneRepo verbosity prog repo srcuri destdir =
[ programInvocation prog cloneArgs ]
where
cloneArgs = ["clone", srcuri, destdir]
++ branchArgs ++ tagArgs ++ verboseArg
branchArgs = case repoBranch repo of
Just b -> ["--branch", b]
Nothing -> []
tagArgs = case repoTag repo of
Just t -> ["--rev", t]
Nothing -> []
verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
vcsSyncRepos :: Verbosity
-> ConfiguredProgram
-> [(SourceRepo, FilePath)]
-> IO [MonitorFilePath]
vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for hg"
hgProgram :: Program
hgProgram = (simpleProgram "hg") {
programFindVersion = findProgramVersion "--version" $ \str ->
case words str of
-- Mercurial Distributed SCM (version 3.5.2)\n ... long message
(_:_:_:_:ver:_) -> takeWhile (\c -> Char.isDigit c || c == '.') ver
_ -> ""
}
-- | VCS driver for Subversion.
--
vcsSvn :: VCS Program
vcsSvn =
VCS {
vcsRepoType = SVN,
vcsProgram = svnProgram,
vcsCloneRepo,
vcsSyncRepos
}
where
vcsCloneRepo :: Verbosity
-> ConfiguredProgram
-> SourceRepo
-> FilePath
-> FilePath
-> [ProgramInvocation]
vcsCloneRepo verbosity prog _repo srcuri destdir =
[ programInvocation prog checkoutArgs ]
where
checkoutArgs = ["checkout", srcuri, destdir] ++ verboseArg
verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
--TODO: branch or tag?
vcsSyncRepos :: Verbosity
-> ConfiguredProgram
-> [(SourceRepo, FilePath)]
-> IO [MonitorFilePath]
vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for svn"
svnProgram :: Program
svnProgram = (simpleProgram "svn") {
programFindVersion = findProgramVersion "--version" $ \str ->
case words str of
-- svn, version 1.9.4 (r1740329)\n ... long message
(_:_:ver:_) -> ver
_ -> ""
}