Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Improved VCS support #5333

Closed
wants to merge 1 commit into from
Closed

Improved VCS support #5333

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
326 changes: 138 additions & 188 deletions cabal-install/Distribution/Client/Get.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -14,7 +14,10 @@
-----------------------------------------------------------------------------

module Distribution.Client.Get (
get
get,
forkPackages,
ForkException(..),
forkPackagesRepo,
) where

import Prelude ()
Expand All @@ -25,39 +28,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
Expand Down Expand Up @@ -108,12 +105,10 @@ get verbosity repoCtxt globalFlags getFlags userTargets = do
standardInstallPolicy mempty sourcePkgDb pkgSpecifiers

prefix = fromFlagOrDefault "" (getDestDir getFlags)
kind = fromFlag . getSourceRepository $ getFlags

fork :: [UnresolvedSourcePackage] -> IO ()
fork pkgs = do
let kind = fromFlag . getSourceRepository $ getFlags
branchers <- findUsableBranchers
mapM_ (forkPackage verbosity branchers prefix kind) pkgs
fork = forkPackages verbosity prefix kind

unpack :: [UnresolvedSourcePackage] -> IO ()
unpack pkgs = do
Expand Down Expand Up @@ -143,6 +138,7 @@ checkTarget verbosity target = case target of
UserTargetLocalCabalFile file -> die' verbosity (notTarball file)
_ -> return ()
where
notTarball :: String -> String
notTarball t =
"The 'get' command is for tarball packages. "
++ "The target '" ++ t ++ "' is not a tarball."
Expand Down Expand Up @@ -181,171 +177,125 @@ unpackPackage verbosity prefix pkgid descOverride pkgPath = do
-- * Forking the source repository
-- ------------------------------------------------------------

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.
--
-- 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)

-- | Fork a single package from a remote source repository to the local
-- file system.
forkPackage :: 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 ()
forkPackage 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)
forkPackages :: Verbosity
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This whole chunk seems to be very similar to what will be needed to actually fix #2189, so I don't know if it should be 'owned' by .Get. I'd probably put it with the other VCS code.

Copy link
Member

@alexbiehl alexbiehl May 20, 2018 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Actually, new-build is a different problem. Here in forkPackages we already have [SourcePackage loc] which indicate which packages (e.g. via package name and package description) come from this repository.

In new-build you have the repository but no clue which packages it contains. You have to clone the repo first and then discover the packages. So I think forkPackages is fine here as new-build needs different codepath anyways.

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Oh, that makes perfect sense. 🤦🏻‍♀️

-> FilePath -- ^ destination dir prefix
-> Maybe RepoKind -- ^
-> [SourcePackage loc] -- ^ the packages
-> IO ()
forkPackages verbosity destDirPrefix preferredRepoKind =
forkPackagesRepo verbosity destDirPrefix preferredRepoKind
. map (\pkg -> (packageId pkg, packageSourceRepos pkg))
where
packageSourceRepos :: SourcePackage loc -> [SourceRepo]
packageSourceRepos = PD.sourceRepos
. PD.packageDescription
. packageDescription

data ForkException =
ForkExceptionNoSourceRepos PackageId
| ForkExceptionNoSourceReposOfKind PackageId (Maybe RepoKind)
| ForkExceptionNoRepoType PackageId SourceRepo
| ForkExceptionUnsupportedRepoType PackageId SourceRepo RepoType
| ForkExceptionNoRepoLocation PackageId SourceRepo
| ForkExceptionDestinationExists PackageId FilePath Bool
| ForkExceptionFailedWithExitCode PackageId SourceRepo
String ExitCode
deriving (Show, Eq)

instance Exception ForkException where
displayException (ForkExceptionNoSourceRepos pkgid) =
"Cannot fetch a source repository for package " ++ display pkgid
++ ". The package does not specify any source repositories."

displayException (ForkExceptionNoSourceReposOfKind 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 (ForkExceptionNoRepoType 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 (ForkExceptionUnsupportedRepoType pkgid _repo repoType) =
"Cannot fetch the source repository for package " ++ display pkgid
++ ". The repository type '" ++ display repoType
++ "' is not yet supported."

displayException (ForkExceptionNoRepoLocation 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 (ForkExceptionDestinationExists 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 (ForkExceptionFailedWithExitCode 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 ++ ")."


forkPackagesRepo :: Verbosity
-> FilePath
-> Maybe RepoKind
-> [(PackageId, [SourceRepo])]
-> IO ()
forkPackagesRepo verbosity destDirPrefix preferredRepoKind pkgrepos = do

-- Do a bunch of checks and collect the required info
pkgrepos' <- mapM (prepareClonePackageRepo
preferredRepoKind destDirPrefix) 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 srcURL destDir
`catch` \exitcode ->
throwIO (ForkExceptionFailedWithExitCode
pkgid repo (programName (vcsProgram vcs)) exitcode)
| (pkgid, repo, vcs, srcURL, destDir) <- pkgrepos'
, let Just vcs' = Map.lookup (vcsRepoType vcs) vcss
]


prepareClonePackageRepo :: Maybe RepoKind
-> FilePath
-> (PackageId, [SourceRepo])
-> IO (PackageId, SourceRepo,
VCS Program, String, FilePath)
prepareClonePackageRepo preferredRepoKind destDirPrefix
(pkgid, repos) = do
repo <- case selectPackageSourceRepo preferredRepoKind repos of
Nothing | null repos -> throwIO (ForkExceptionNoSourceRepos pkgid)
Nothing -> throwIO (ForkExceptionNoSourceReposOfKind pkgid
preferredRepoKind)
Just repo -> return repo

(vcs, srcURL) <- case selectSourceRepoVCS repo of
Right x -> return x
Left SourceRepoRepoTypeUnspecified ->
throwIO (ForkExceptionNoRepoType pkgid repo)

Left (SourceRepoRepoTypeUnsupported repoType) ->
throwIO (ForkExceptionUnsupportedRepoType pkgid repo repoType)

Left SourceRepoLocationUnspecified ->
throwIO (ForkExceptionNoRepoLocation pkgid repo)

destDirExists <- doesDirectoryExist destDir
destFileExists <- doesFileExist destDir
when (destDirExists || destFileExists) $
throwIO (ForkExceptionDestinationExists pkgid destDir destDirExists)

return (pkgid, repo, vcs, srcURL, destDir)
where
destDir = destDirPrefix </> display (packageName pkgid)

Loading