Commit f8665a4c authored by refold's avatar refold

Replace the 'unpack' command with a more general 'get'.

'cabal get PACKAGE' is the new name of 'cabal unpack'.

'cabal get --source-repository' reads the source-repositories from a package's
description, determines which VCS to use, and then creates a local repository or
branch of the package's repository.

'cabal get --source-repository=[head|this|...]' additionally allows to specify
which source-repository to use.

Based on the code originally written by John Millikin <jmillikin@gmail.com>.
parent f02a8651
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Unpack
-- Module : Distribution.Client.Get
-- Copyright : (c) Andrea Vezzosi 2008
-- Duncan Coutts 2011
-- John Millikin 2012
-- License : BSD-like
--
-- Maintainer : cabal-devel@haskell.org
-- Stability : provisional
-- Portability : portable
--
--
-- The 'cabal get' command.
-----------------------------------------------------------------------------
module Distribution.Client.Unpack (
-- * Commands
unpack,
module Distribution.Client.Get (
get
) where
import Distribution.Package
( PackageId, packageId, packageName )
import Distribution.Simple.Setup
( fromFlag, fromFlagOrDefault )
( Flag(..), fromFlag, fromFlagOrDefault )
import Distribution.Simple.Utils
( notice, die, info, writeFileAtomic )
import Distribution.Verbosity
( Verbosity )
import Distribution.Text(display)
import qualified Distribution.PackageDescription as PD
import Distribution.Client.Setup
( GlobalFlags(..), UnpackFlags(..) )
( GlobalFlags(..), GetFlags(..) )
import Distribution.Client.Types
import Distribution.Client.Targets
import Distribution.Client.Dependency
......@@ -38,26 +38,63 @@ import qualified Distribution.Client.Tar as Tar (extractTarGzFile)
import Distribution.Client.IndexUtils as IndexUtils
( getSourcePackages )
import System.Directory
( createDirectoryIfMissing, doesDirectoryExist, doesFileExist )
import Control.Exception
( finally )
import Control.Monad
( unless, when, forM_ )
( filterM, unless, when )
import Data.List
( sortBy )
import qualified Data.Map
import Data.Maybe
( listToMaybe, mapMaybe )
import Data.Monoid
( mempty )
import Data.Ord
( comparing )
import System.Cmd
( rawSystem )
import System.Directory
( createDirectoryIfMissing, doesDirectoryExist, doesFileExist
, getCurrentDirectory, setCurrentDirectory
)
import System.Exit
( ExitCode(..) )
import System.FilePath
( (</>), (<.>), addTrailingPathSeparator )
import System.Process
( readProcessWithExitCode )
-- | Entry point for the 'cabal get' command.
get :: Verbosity
-> [Repo]
-> GlobalFlags
-> GetFlags
-> [UserTarget]
-> IO ()
get verbosity _ _ _ [] =
notice verbosity "No packages requested. Nothing to do."
get verbosity repos globalFlags getFlags userTargets =
case getSourceRepository getFlags
of NoFlag -> unpack verbosity
repos globalFlags getFlags userTargets
_ -> fork verbosity
repos globalFlags getFlags userTargets
-- ------------------------------------------------------------
-- * Unpacking the source tarball
-- ------------------------------------------------------------
unpack :: Verbosity
-> [Repo]
-> GlobalFlags
-> UnpackFlags
-> [UserTarget]
-> GetFlags
-> [UserTarget]
-> IO ()
unpack verbosity _ _ _ [] =
notice verbosity "No packages requested. Nothing to do."
unpack verbosity repos globalFlags unpackFlags userTargets = do
unpack verbosity repos globalFlags getFlags userTargets = do
mapM_ checkTarget userTargets
sourcePkgDb <- getSourcePackages verbosity repos
......@@ -74,7 +111,7 @@ unpack verbosity repos globalFlags unpackFlags userTargets = do
unless (null prefix) $
createDirectoryIfMissing True prefix
forM_ pkgs $ \pkg -> do
flip mapM_ pkgs $ \pkg -> do
location <- fetchPackage verbosity (packageSource pkg)
let pkgid = packageId pkg
descOverride | usePristine = Nothing
......@@ -90,7 +127,7 @@ unpack verbosity repos globalFlags unpackFlags userTargets = do
unpackPackage verbosity prefix pkgid descOverride tarballPath
LocalUnpackedPackage _ ->
error "Distribution.Client.Unpack.unpack: the impossible happened."
error "Distribution.Client.Get.unpack: the impossible happened."
where
resolverParams sourcePkgDb pkgSpecifiers =
......@@ -98,8 +135,8 @@ unpack verbosity repos globalFlags unpackFlags userTargets = do
standardInstallPolicy mempty sourcePkgDb pkgSpecifiers
prefix = fromFlagOrDefault "" (unpackDestDir unpackFlags)
usePristine = fromFlagOrDefault False (unpackPristine unpackFlags)
prefix = fromFlagOrDefault "" (getDestDir getFlags)
usePristine = fromFlagOrDefault False (getPristine getFlags)
checkTarget :: UserTarget -> IO ()
checkTarget target = case target of
......@@ -108,7 +145,7 @@ checkTarget target = case target of
_ -> return ()
where
notTarball t =
"The 'unpack' command is for tarball packages. "
"The 'get' command is for tarball packages. "
++ "The target '" ++ t ++ "' is not a tarball."
unpackPackage :: Verbosity -> FilePath -> PackageId
......@@ -135,3 +172,198 @@ unpackPackage verbosity prefix pkgid descOverride pkgPath = do
"Updating " ++ descFilePath
++ " with the latest revision from the index."
writeFileAtomic descFilePath pkgtxt
-- ------------------------------------------------------------
-- * Forking the source repository
-- ------------------------------------------------------------
fork :: Verbosity
-> [Repo]
-> GlobalFlags
-> GetFlags
-> [UserTarget]
-> IO ()
fork verbosity repos globalFlags getFlags userTargets = do
let prefix = fromFlagOrDefault "" (getDestDir getFlags)
--TODO: add commandline constraint and preference args?
let resolverParams sourcePkgDb pkgSpecifiers =
standardInstallPolicy mempty sourcePkgDb pkgSpecifiers
sourcePkgDb <- getSourcePackages verbosity repos
pkgSpecifiers <- resolveUserTargets
verbosity
(fromFlag $ globalWorldFile globalFlags)
(packageIndex sourcePkgDb)
userTargets
pkgs <- case resolveWithoutDependencies (resolverParams sourcePkgDb pkgSpecifiers) of
Right pkgs -> return pkgs
Left errors -> die (unlines (map show errors))
unless (null prefix) $
createDirectoryIfMissing True prefix
branchers <- findUsableBranchers
mapM_ (forkPackage verbosity branchers prefix) pkgs
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) = 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
-- filesystem.
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.
-> SourcePackage
-- ^ The package to fork.
-> IO ()
forkPackage verbosity branchers prefix src = do
let desc = PD.packageDescription (packageDescription src)
let pkgname = display (packageId src)
let destdir = prefix </> pkgname
destDirExists <- doesDirectoryExist destdir
when destDirExists $ do
die ("The directory " ++ show destdir ++ " already exists, not forking.")
destFileExists <- doesFileExist destdir
when destFileExists $ do
die ("A file " ++ show destdir ++ " is in the way, not forking.")
let repos = PD.sourceRepos desc
case findBranchCmd branchers repos of
Just (BranchCmd io) -> do
exitCode <- io verbosity destdir
case exitCode of
ExitSuccess -> return ()
ExitFailure _ -> die ("Couldn't fork package " ++ pkgname)
Nothing -> case repos of
[] -> die ("Package " ++ pkgname ++ " does not have any source repositories.")
_ -> die ("Package " ++ pkgname ++ " 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 BranchCmd
findBranchCmd branchers allRepos = 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
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)
rawSystem "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)
rawSystem "darcs" (args dst)
-- | Branch driver for Git.
branchGit :: Brancher
branchGit = Brancher "git" $ \repo -> do
src <- PD.repoLocation repo
let branchArgs = case PD.repoBranch repo of
Just b -> ["--branch", b]
Nothing -> []
let postClone dst = case PD.repoTag repo of
Just t -> do
cwd <- getCurrentDirectory
setCurrentDirectory dst
finally
(rawSystem "git" (["checkout", t] ++ branchArgs))
(setCurrentDirectory cwd)
Nothing -> return ExitSuccess
return $ BranchCmd $ \verbosity dst -> do
notice verbosity ("git: clone " ++ show src)
code <- rawSystem "git" (["clone", src, dst] ++ branchArgs)
case code of
ExitFailure _ -> return code
ExitSuccess -> postClone 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)
rawSystem "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)
rawSystem "svn" (args dst)
......@@ -22,11 +22,11 @@ module Distribution.Client.Setup
, upgradeCommand
, infoCommand, InfoFlags(..)
, fetchCommand, FetchFlags(..)
, getCommand, GetFlags(..)
, checkCommand
, uploadCommand, UploadFlags(..)
, reportCommand, ReportFlags(..)
, runCommand
, unpackCommand, UnpackFlags(..)
, initCommand, IT.InitFlags(..)
, sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..)
, win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)
......@@ -67,6 +67,8 @@ import Distribution.Version
( Version(Version), anyVersion, thisVersion )
import Distribution.Package
( PackageIdentifier, packageName, packageVersion, Dependency(..) )
import Distribution.PackageDescription
( RepoKind(..) )
import Distribution.Text
( Text(..), display )
import Distribution.ReadE
......@@ -511,51 +513,62 @@ instance Monoid ReportFlags where
where combine field = field a `mappend` field b
-- ------------------------------------------------------------
-- * Unpack flags
-- * Get flags
-- ------------------------------------------------------------
data UnpackFlags = UnpackFlags {
unpackDestDir :: Flag FilePath,
unpackVerbosity :: Flag Verbosity,
unpackPristine :: Flag Bool
}
data GetFlags = GetFlags {
getDestDir :: Flag FilePath,
getPristine :: Flag Bool,
getSourceRepository :: Flag (Maybe RepoKind),
getVerbosity :: Flag Verbosity
}
defaultUnpackFlags :: UnpackFlags
defaultUnpackFlags = UnpackFlags {
unpackDestDir = mempty,
unpackVerbosity = toFlag normal,
unpackPristine = toFlag False
defaultGetFlags :: GetFlags
defaultGetFlags = GetFlags {
getDestDir = mempty,
getPristine = mempty,
getSourceRepository = mempty,
getVerbosity = toFlag normal
}
unpackCommand :: CommandUI UnpackFlags
unpackCommand = CommandUI {
commandName = "unpack",
commandSynopsis = "Unpacks packages for user inspection.",
getCommand :: CommandUI GetFlags
getCommand = CommandUI {
commandName = "get",
commandSynopsis = "Gets a package's source code.",
commandDescription = Nothing,
commandUsage = usagePackages "unpack",
commandUsage = usagePackages "get",
commandDefaultFlags = mempty,
commandOptions = \_ -> [
optionVerbosity unpackVerbosity (\v flags -> flags { unpackVerbosity = v })
optionVerbosity getVerbosity (\v flags -> flags { getVerbosity = v })
,option "d" ["destdir"]
"where to unpack the packages, defaults to the current directory."
unpackDestDir (\v flags -> flags { unpackDestDir = v })
"where to place the package source, defaults to the current directory."
getDestDir (\v flags -> flags { getDestDir = v })
(reqArgFlag "PATH")
,option "s" ["source-repository"]
"fork the package's source repository."
getSourceRepository (\v flags -> flags { getSourceRepository = v })
(optArg "[head|this|...]" (readP_to_E (const "invalid source-repository")
(fmap (toFlag . Just) parse))
(Flag Nothing)
(map (fmap show) . flagToList))
, option [] ["pristine"]
("Unpack the original pristine tarball, rather than updating the "
++ ".cabal file with the latest revision from the package archive.")
unpackPristine (\v flags -> flags { unpackPristine = v })
getPristine (\v flags -> flags { getPristine = v })
trueArg
]
}
instance Monoid UnpackFlags where
mempty = defaultUnpackFlags
mappend a b = UnpackFlags {
unpackDestDir = combine unpackDestDir,
unpackVerbosity = combine unpackVerbosity,
unpackPristine = combine unpackPristine
instance Monoid GetFlags where
mempty = defaultGetFlags
mappend a b = GetFlags {
getDestDir = combine getDestDir,
getPristine = combine getPristine,
getSourceRepository = combine getSourceRepository,
getVerbosity = combine getVerbosity
}
where combine field = field a `mappend` field b
......
......@@ -76,6 +76,7 @@ Library
Distribution.Client.Dependency.Modular.Version
Distribution.Client.Fetch
Distribution.Client.FetchUtils
Distribution.Client.Get
Distribution.Client.GZipUtils
Distribution.Client.Haddock
Distribution.Client.HttpUtils
......@@ -102,7 +103,6 @@ Library
Distribution.Client.Tar
Distribution.Client.Targets
Distribution.Client.Types
Distribution.Client.Unpack
Distribution.Client.Update
Distribution.Client.Upload
Distribution.Client.Utils
......
......@@ -21,6 +21,7 @@ import Distribution.Client.Setup
, InstallFlags(..), defaultInstallFlags
, installCommand, upgradeCommand
, FetchFlags(..), fetchCommand
, GetFlags(..), getCommand
, checkCommand
, updateCommand
, ListFlags(..), listCommand
......@@ -37,7 +38,7 @@ import Distribution.Client.Setup
, sandboxBuildCommand, sandboxInstallCommand
, dumpPkgEnvCommand
, reportCommand
, unpackCommand, UnpackFlags(..) )
)
import Distribution.Simple.Setup
( HaddockFlags(..), haddockCommand
, HscolourFlags(..), hscolourCommand
......@@ -65,7 +66,7 @@ import Distribution.Client.Check as Check (check)
import Distribution.Client.Upload as Upload (upload, check, report)
import Distribution.Client.Run (run)
import Distribution.Client.SrcDist (sdist)
import Distribution.Client.Unpack (unpack)
import Distribution.Client.Get (get)
import Distribution.Client.Index (index)
import Distribution.Client.Sandbox (sandboxInit
, sandboxDelete
......@@ -149,7 +150,7 @@ mainWorker args = topHandler $
,listCommand `commandAddAction` listAction
,infoCommand `commandAddAction` infoAction
,fetchCommand `commandAddAction` fetchAction
,unpackCommand `commandAddAction` unpackAction
,getCommand `commandAddAction` getAction
,checkCommand `commandAddAction` checkAction
,sdistCommand `commandAddAction` sdistAction
,uploadCommand `commandAddAction` uploadAction
......@@ -568,17 +569,17 @@ runAction buildFlags extraArgs globalFlags = do
run verbosity buildFlags extraArgs
unpackAction :: UnpackFlags -> [String] -> GlobalFlags -> IO ()
unpackAction unpackFlags extraArgs globalFlags = do
let verbosity = fromFlag (unpackVerbosity unpackFlags)
getAction :: GetFlags -> [String] -> GlobalFlags -> IO ()
getAction getFlags extraArgs globalFlags = do
let verbosity = fromFlag (getVerbosity getFlags)
targets <- readUserTargets verbosity extraArgs
config <- loadConfig verbosity (globalConfigFile globalFlags) mempty
let globalFlags' = savedGlobalFlags config `mappend` globalFlags
unpack verbosity
(globalRepos (savedGlobalFlags config))
globalFlags'
unpackFlags
targets
get verbosity
(globalRepos (savedGlobalFlags config))
globalFlags'
getFlags
targets
initAction :: InitFlags -> [String] -> GlobalFlags -> IO ()
initAction initFlags _extraArgs globalFlags = do
......
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