Commit a4120f49 authored by Duncan Coutts's avatar Duncan Coutts Committed by Alexis Williams
Browse files

Change 'get -s' impl to use new VCS abstraction

This replaces the previous Brancher abstraction. It improves the error
messages.

There is a very slight change of behaviour: previously if a package
specified multiple source repos with different types (e.g. git/darcs)
and only one of those VCS tools was installed on the system, it could
fall back to selecting the other repo using the other tool. The new
behaviour is that it picks the repo to use deterministically, and then
simply fails if the VCS program is not available. This situation is very
rare, and arguably the new behaviour is more predictable.
parent fa30556d
......@@ -14,7 +14,12 @@
-----------------------------------------------------------------------------
module Distribution.Client.Get (
get
get,
-- * Cloning 'SourceRepo's
-- | Mainly exported for testing purposes
clonePackagesFromSourceRepo,
ClonePackageException(..),
) where
import Prelude ()
......@@ -25,39 +30,33 @@ import Distribution.Package
import Distribution.Simple.Setup
( Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe )
import Distribution.Simple.Utils
( notice, die', info, rawSystemExitCode, writeFileAtomic )
( notice, die', info, writeFileAtomic )
import Distribution.Verbosity
( Verbosity )
import Distribution.Text(display)
import Distribution.Text (display)
import qualified Distribution.PackageDescription as PD
import Distribution.Simple.Program
( programName )
import Distribution.Client.Setup
( GlobalFlags(..), GetFlags(..), RepoContext(..) )
import Distribution.Client.Types
import Distribution.Client.Targets
import Distribution.Client.Dependency
import Distribution.Client.VCS
import Distribution.Client.FetchUtils
import qualified Distribution.Client.Tar as Tar (extractTarGzFile)
import Distribution.Client.IndexUtils as IndexUtils
( getSourcePackagesAtIndexState )
import Distribution.Client.Compat.Process
( readProcessWithExitCode )
import Distribution.Compat.Exception
( catchIO )
import Distribution.Solver.Types.SourcePackage
import Control.Exception
( finally )
( Exception(..), catch, throwIO )
import Control.Monad
( forM_, mapM_ )
import qualified Data.Map
import Data.Ord
( comparing )
( mapM, forM_, mapM_ )
import qualified Data.Map as Map
import System.Directory
( createDirectoryIfMissing, doesDirectoryExist, doesFileExist
, getCurrentDirectory, setCurrentDirectory
)
( createDirectoryIfMissing, doesDirectoryExist, doesFileExist )
import System.Exit
( ExitCode(..) )
import System.FilePath
......@@ -110,10 +109,14 @@ get verbosity repoCtxt globalFlags getFlags userTargets = do
prefix = fromFlagOrDefault "" (getDestDir getFlags)
clone :: [UnresolvedSourcePackage] -> IO ()
clone pkgs = do
let kind = fromFlag . getSourceRepository $ getFlags
branchers <- findUsableBranchers
mapM_ (clonePackage verbosity branchers prefix kind) pkgs
clone = clonePackagesFromSourceRepo verbosity prefix kind
. map (\pkg -> (packageId pkg, packageSourceRepos pkg))
where
kind = fromFlag . getSourceRepository $ getFlags
packageSourceRepos :: SourcePackage loc -> [SourceRepo]
packageSourceRepos = PD.sourceRepos
. PD.packageDescription
. packageDescription
unpack :: [UnresolvedSourcePackage] -> IO ()
unpack pkgs = do
......@@ -181,171 +184,112 @@ unpackPackage verbosity prefix pkgid descOverride pkgPath = do
-- * Cloning packages from their declared source repositories
-- ------------------------------------------------------------
data BranchCmd = BranchCmd (Verbosity -> FilePath -> IO ExitCode)
data Brancher = Brancher
{ brancherBinary :: String
, brancherBuildCmd :: PD.SourceRepo -> Maybe BranchCmd
}
-- | The set of all supported branch drivers.
allBranchers :: [(PD.RepoType, Brancher)]
allBranchers =
[ (PD.Bazaar, branchBzr)
, (PD.Darcs, branchDarcs)
, (PD.Git, branchGit)
, (PD.Mercurial, branchHg)
, (PD.SVN, branchSvn)
]
-- | Find which usable branch drivers (selected from 'allBranchers') are
-- available and usable on the local machine.
data ClonePackageException =
ClonePackageNoSourceRepos PackageId
| ClonePackageNoSourceReposOfKind PackageId (Maybe RepoKind)
| ClonePackageNoRepoType PackageId SourceRepo
| ClonePackageUnsupportedRepoType PackageId SourceRepo RepoType
| ClonePackageNoRepoLocation PackageId SourceRepo
| ClonePackageDestinationExists PackageId FilePath Bool
| ClonePackageFailedWithExitCode PackageId SourceRepo String ExitCode
deriving (Show, Eq)
instance Exception ClonePackageException where
displayException (ClonePackageNoSourceRepos pkgid) =
"Cannot fetch a source repository for package " ++ display pkgid
++ ". The package does not specify any source repositories."
displayException (ClonePackageNoSourceReposOfKind pkgid repoKind) =
"Cannot fetch a source repository for package " ++ display pkgid
++ ". The package does not specify a source repository of the requested "
++ "kind" ++ maybe "." (\k -> " (kind " ++ display k ++ ").") repoKind
displayException (ClonePackageNoRepoType pkgid _repo) =
"Cannot fetch the source repository for package " ++ display pkgid
++ ". The package's description specifies a source repository but does "
++ "not specify the repository 'type' field (e.g. git, darcs or hg)."
displayException (ClonePackageUnsupportedRepoType pkgid _ repoType) =
"Cannot fetch the source repository for package " ++ display pkgid
++ ". The repository type '" ++ display repoType
++ "' is not yet supported."
displayException (ClonePackageNoRepoLocation pkgid _repo) =
"Cannot fetch the source repository for package " ++ display pkgid
++ ". The package's description specifies a source repository but does "
++ "not specify the repository 'location' field (i.e. the URL)."
displayException (ClonePackageDestinationExists pkgid dest isdir) =
"Not fetching the source repository for package " ++ display pkgid ++ ". "
++ if isdir then "The destination directory " ++ dest ++ " already exists."
else "A file " ++ dest ++ " is in the way."
displayException (ClonePackageFailedWithExitCode
pkgid repo vcsprogname exitcode) =
"Failed to fetch the source repository for package " ++ display pkgid
++ maybe "" (", repository location " ++) (PD.repoLocation repo) ++ " ("
++ vcsprogname ++ " failed with " ++ show exitcode ++ ")."
-- | Given a bunch of package ids and their corresponding available
-- 'SourceRepo's, pick a single 'SourceRepo' for each one and clone into
-- new subdirs of the given directory.
--
-- Each driver's main command is run with @--help@, and if the child process
-- exits successfully, that brancher is considered usable.
findUsableBranchers :: IO (Data.Map.Map PD.RepoType Brancher)
findUsableBranchers = do
let usable (_, brancher) = flip catchIO (const (return False)) $ do
let cmd = brancherBinary brancher
(exitCode, _, _) <- readProcessWithExitCode cmd ["--help"] ""
return (exitCode == ExitSuccess)
pairs <- filterM usable allBranchers
return (Data.Map.fromList pairs)
-- | Clone a single package from a remote source repository to the local
-- file system.
clonePackage :: Verbosity
-> Data.Map.Map PD.RepoType Brancher
-- ^ Branchers supported by the local machine.
-> FilePath
-- ^ The directory in which new branches or repositories will
-- be created.
-> (Maybe PD.RepoKind)
-- ^ Which repo to choose.
-> SourcePackage loc
-- ^ The package to fork.
-> IO ()
clonePackage verbosity branchers prefix kind src = do
let desc = PD.packageDescription (packageDescription src)
pkgid = display (packageId src)
pkgname = display (packageName src)
destdir = prefix </> pkgname
destDirExists <- doesDirectoryExist destdir
when destDirExists $ do
die' verbosity ("The directory " ++ show destdir ++ " already exists, not forking.")
destFileExists <- doesFileExist destdir
when destFileExists $ do
die' verbosity ("A file " ++ show destdir ++ " is in the way, not forking.")
let repos = PD.sourceRepos desc
case findBranchCmd branchers repos kind of
Just (BranchCmd io) -> do
exitCode <- io verbosity destdir
case exitCode of
ExitSuccess -> return ()
ExitFailure _ -> die' verbosity ("Couldn't fork package " ++ pkgid)
Nothing -> case repos of
[] -> die' verbosity ("Package " ++ pkgid
++ " does not have any source repositories.")
_ -> die' verbosity ("Package " ++ pkgid
++ " does not have any usable source repositories.")
-- | Given a set of possible branchers, and a set of possible source
-- repositories, find a repository that is both 1) likely to be specific to
-- this source version and 2) is supported by the local machine.
findBranchCmd :: Data.Map.Map PD.RepoType Brancher -> [PD.SourceRepo]
-> (Maybe PD.RepoKind) -> Maybe BranchCmd
findBranchCmd branchers allRepos maybeKind = cmd where
-- 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.
repos' = sortBy (comparing thisFirst) allRepos
thisFirst r = case PD.repoKind r of
PD.RepoThis -> 0 :: Int
PD.RepoHead -> case PD.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
PD.RepoKindUnknown _ -> 2
-- If the user has specified the repo kind, filter out the repositories
-- she's not interested in.
repos = maybe repos' (\k -> filter ((==) k . PD.repoKind) repos') maybeKind
repoBranchCmd repo = do
t <- PD.repoType repo
brancher <- Data.Map.lookup t branchers
brancherBuildCmd brancher repo
cmd = listToMaybe (mapMaybe repoBranchCmd repos)
-- | Branch driver for Bazaar.
branchBzr :: Brancher
branchBzr = Brancher "bzr" $ \repo -> do
src <- PD.repoLocation repo
let args dst = case PD.repoTag repo of
Just tag -> ["branch", src, dst, "-r", "tag:" ++ tag]
Nothing -> ["branch", src, dst]
return $ BranchCmd $ \verbosity dst -> do
notice verbosity ("bzr: branch " ++ show src)
rawSystemExitCode verbosity "bzr" (args dst)
-- | Branch driver for Darcs.
branchDarcs :: Brancher
branchDarcs = Brancher "darcs" $ \repo -> do
src <- PD.repoLocation repo
let args dst = case PD.repoTag repo of
Just tag -> ["get", src, dst, "-t", tag]
Nothing -> ["get", src, dst]
return $ BranchCmd $ \verbosity dst -> do
notice verbosity ("darcs: get " ++ show src)
rawSystemExitCode verbosity "darcs" (args dst)
-- | Branch driver for Git.
branchGit :: Brancher
branchGit = Brancher "git" $ \repo -> do
src <- PD.repoLocation repo
let postClone verbosity dst = case PD.repoTag repo of
Just t -> do
cwd <- getCurrentDirectory
setCurrentDirectory dst
finally
(rawSystemExitCode verbosity "git" ["checkout", t])
(setCurrentDirectory cwd)
Nothing -> return ExitSuccess
return $ BranchCmd $ \verbosity dst -> do
notice verbosity ("git: clone " ++ show src)
code <- rawSystemExitCode verbosity "git" (["clone", src, dst] ++
case PD.repoBranch repo of
Nothing -> []
Just b -> ["--branch", b])
case code of
ExitFailure _ -> return code
ExitSuccess -> postClone verbosity dst
-- | Branch driver for Mercurial.
branchHg :: Brancher
branchHg = Brancher "hg" $ \repo -> do
src <- PD.repoLocation repo
let branchArgs = case PD.repoBranch repo of
Just b -> ["--branch", b]
Nothing -> []
let tagArgs = case PD.repoTag repo of
Just t -> ["--rev", t]
Nothing -> []
let args dst = ["clone", src, dst] ++ branchArgs ++ tagArgs
return $ BranchCmd $ \verbosity dst -> do
notice verbosity ("hg: clone " ++ show src)
rawSystemExitCode verbosity "hg" (args dst)
-- | Branch driver for Subversion.
branchSvn :: Brancher
branchSvn = Brancher "svn" $ \repo -> do
src <- PD.repoLocation repo
let args dst = ["checkout", src, dst]
return $ BranchCmd $ \verbosity dst -> do
notice verbosity ("svn: checkout " ++ show src)
rawSystemExitCode verbosity "svn" (args dst)
clonePackagesFromSourceRepo :: Verbosity
-> FilePath -- ^ destination dir prefix
-> Maybe RepoKind -- ^ preferred 'RepoKind'
-> [(PackageId, [SourceRepo])]
-- ^ the packages and their
-- available 'SourceRepo's
-> IO ()
clonePackagesFromSourceRepo verbosity destDirPrefix
preferredRepoKind pkgrepos = do
-- Do a bunch of checks and collect the required info
pkgrepos' <- mapM preCloneChecks pkgrepos
-- Configure the VCS drivers for all the repository types we may need
vcss <- configureVCSs verbosity $
Map.fromList [ (vcsRepoType vcs, vcs)
| (_, _, vcs, _) <- pkgrepos' ]
-- Now execute all the required commands for each repo
sequence_
[ cloneSourceRepo verbosity vcs' repo destDir
`catch` \exitcode ->
throwIO (ClonePackageFailedWithExitCode
pkgid repo (programName (vcsProgram vcs)) exitcode)
| (pkgid, repo, vcs, destDir) <- pkgrepos'
, let Just vcs' = Map.lookup (vcsRepoType vcs) vcss
]
where
preCloneChecks :: (PackageId, [SourceRepo])
-> IO (PackageId, SourceRepo, VCS Program, FilePath)
preCloneChecks (pkgid, repos) = do
repo <- case selectPackageSourceRepo preferredRepoKind repos of
Just repo -> return repo
Nothing | null repos -> throwIO (ClonePackageNoSourceRepos pkgid)
Nothing -> throwIO (ClonePackageNoSourceReposOfKind
pkgid preferredRepoKind)
vcs <- case selectSourceRepoVCS repo of
Right x -> return x
Left SourceRepoRepoTypeUnspecified ->
throwIO (ClonePackageNoRepoType pkgid repo)
Left (SourceRepoRepoTypeUnsupported repoType) ->
throwIO (ClonePackageUnsupportedRepoType pkgid repo repoType)
Left SourceRepoLocationUnspecified ->
throwIO (ClonePackageNoRepoLocation pkgid repo)
let destDir = destDirPrefix </> display (packageName pkgid)
destDirExists <- doesDirectoryExist destDir
destFileExists <- doesFileExist destDir
when (destDirExists || destFileExists) $
throwIO (ClonePackageDestinationExists pkgid destDir destDirExists)
return (pkgid, repo, vcs, destDir)
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