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

cabal-install/Distribution/Client/Unpack.hs → cabal-install/Distribution/Client/Get.hs

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

cabal-install/Distribution/Client/Setup.hs

@@ -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
 

cabal-install/cabal-install.cabal

@@ -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

cabal-install/src/Main.hs

@@ -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