Implement 'cabal unpack' command as in #390

cabal-install/Distribution/Client/Setup.hs

@@ -22,6 +22,7 @@ module Distribution.Client.Setup
     , checkCommand
     , uploadCommand, UploadFlags(..)
     , reportCommand
+    , unpackCommand, UnpackFlags(..)
 
     , parsePackageArgs
     --TODO: stop exporting these:
@@ -272,6 +273,46 @@ reportCommand = CommandUI {
     commandOptions      = \_ -> [optionVerbosity id const]
   }
 
+-- ------------------------------------------------------------
+-- * Unpack flags
+-- ------------------------------------------------------------
+
+data UnpackFlags = UnpackFlags {
+      unpackDestDir :: Flag FilePath,
+      unpackVerbosity :: Flag Verbosity
+    }
+
+defaultUnpackFlags :: UnpackFlags
+defaultUnpackFlags = UnpackFlags {
+    unpackDestDir = mempty,
+    unpackVerbosity = toFlag normal
+   }
+
+unpackCommand :: CommandUI UnpackFlags
+unpackCommand = CommandUI {
+    commandName         = "unpack",
+    commandSynopsis     = "Unpacks packages for user inspection.",
+    commandDescription  = Nothing,
+    commandUsage        = usagePackages "unpack",
+    commandDefaultFlags = mempty,
+    commandOptions      = \_ -> [
+        optionVerbosity unpackVerbosity (\v flags -> flags { unpackVerbosity = v })
+
+       ,option "d" ["destdir"]
+         "where to unpack the packages, defaults to the current directory."
+         unpackDestDir (\v flags -> flags { unpackDestDir = v })
+         (reqArgFlag "PATH")
+       ]
+  }
+
+instance Monoid UnpackFlags where
+  mempty = defaultUnpackFlags
+  mappend a b = UnpackFlags {
+     unpackDestDir = combine unpackDestDir
+    ,unpackVerbosity = combine unpackVerbosity
+  }
+    where combine field = field a `mappend` field b
+
 -- ------------------------------------------------------------
 -- * List flags
 -- ------------------------------------------------------------

cabal-install/Distribution/Client/Unpack.hs

+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Distribution.Client.Unpack
+-- Copyright   :  (c) Andrea Vezzosi 2008
+-- License     :  BSD-like
+--
+-- Maintainer  :  cabal-devel@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+--
+-----------------------------------------------------------------------------
+module Distribution.Client.Unpack (
+
+    -- * Commands
+    unpack,
+
+  ) where
+
+import Distribution.Package ( packageId, Dependency(..) )
+import Distribution.Simple.PackageIndex as PackageIndex (lookupDependency)
+import Distribution.Simple.Setup(fromFlag, fromFlagOrDefault)
+import Distribution.Simple.Utils(info, notice)
+import Distribution.Text(display)
+import Distribution.Version (VersionRange(..))
+
+import Distribution.Client.Setup(UnpackFlags(unpackVerbosity,
+                                             unpackDestDir))
+import Distribution.Client.Types(UnresolvedDependency(..),
+                                 Repo, AvailablePackageSource(RepoTarballPackage),
+                                 AvailablePackage(AvailablePackage),
+                                 AvailablePackageDb(AvailablePackageDb))
+import Distribution.Client.Fetch(fetchPackage)
+import Distribution.Client.Tar(extractTarGzFile)
+import Distribution.Client.IndexUtils as IndexUtils
+    (getAvailablePackages, disambiguateDependencies)
+
+import System.Directory(createDirectoryIfMissing)
+import Control.Monad(unless)
+import Data.Ord (comparing)
+import Data.List(null, maximumBy)
+import System.FilePath((</>))
+import qualified Data.Map as Map
+
+unpack :: UnpackFlags -> [Repo] -> [Dependency] -> IO ()
+unpack flags repos deps 
+    | null deps = notice verbosity
+                  "No packages requested. Nothing to do."
+    | otherwise = do
+  db@(AvailablePackageDb available _)
+            <- getAvailablePackages verbosity repos
+  deps' <- fmap (map dependency) 
+           . IndexUtils.disambiguateDependencies available 
+           . map toUnresolved $ deps
+
+  let pkgs = resolvePackages db deps'
+
+  unless (null prefix) $
+         createDirectoryIfMissing True prefix
+  sequence_
+      [ do pkgPath <- fetchPackage verbosity repo pkgid
+           let pkgdir = display pkgid
+           notice verbosity $ "Unpacking " ++ display pkgid ++ "..."
+           info verbosity $ "Extracting " ++ pkgPath
+                    ++ " to " ++ prefix </> pkgdir ++ "..."
+           extractTarGzFile prefix pkgPath
+      | (AvailablePackage pkgid _ (RepoTarballPackage repo)) <- pkgs ]
+
+    where 
+      verbosity = fromFlag (unpackVerbosity flags)
+      prefix = fromFlagOrDefault "" (unpackDestDir flags)
+      toUnresolved d = UnresolvedDependency d []
+
+resolvePackages :: AvailablePackageDb
+                   -> [Dependency]
+                   -> [AvailablePackage]
+resolvePackages (AvailablePackageDb available prefs) deps =
+    map (maximumBy (comparing packageId) . candidates) deps
+    where
+      candidates dep@(Dependency name ver) =
+          let [x,y] = map (PackageIndex.lookupDependency available)
+                      [ Dependency name
+                        (maybe AnyVersion id (Map.lookup name prefs)
+                         `IntersectVersionRanges` ver)
+                      , dep ]
+          in if null x then y else x

cabal-install/Main.hs

@@ -22,6 +22,7 @@ import Distribution.Client.Setup
          , ListFlags(..), listCommand
          , UploadFlags(..), uploadCommand
          , reportCommand
+         , unpackCommand, UnpackFlags(..)
          , parsePackageArgs, configPackageDB' )
 import Distribution.Simple.Setup
          ( BuildFlags(..), buildCommand
@@ -48,6 +49,7 @@ import Distribution.Client.Check as Check   (check)
 --import Distribution.Client.Clean            (clean)
 import Distribution.Client.Upload as Upload (upload, check, report)
 import Distribution.Client.SrcDist          (sdist)
+import Distribution.Client.Unpack           (unpack)
 import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade
 
 import Distribution.Simple.Program (defaultProgramConfiguration)
@@ -114,6 +116,7 @@ mainWorker args =
       ,checkCommand           `commandAddAction` checkAction
       ,sdistCommand           `commandAddAction` sdistAction
       ,reportCommand          `commandAddAction` reportAction
+      ,unpackCommand          `commandAddAction` unpackAction
       ,wrapperAction (buildCommand defaultProgramConfiguration)
                      buildVerbosity    buildDistPref
       ,wrapperAction copyCommand
@@ -291,6 +294,13 @@ reportAction verbosityFlag extraArgs globalFlags = do
 
   Upload.report verbosity (globalRepos (savedGlobalFlags config))
 
+unpackAction :: UnpackFlags -> [String] -> GlobalFlags -> IO ()
+unpackAction flags extraArgs globalFlags = do
+  pkgs <- either die return (parsePackageArgs extraArgs)
+  let verbosity = fromFlag (unpackVerbosity flags)
+  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty
+  unpack flags (globalRepos (savedGlobalFlags config)) pkgs
+
 win32SelfUpgradeAction :: [String] -> IO ()
 win32SelfUpgradeAction (pid:path:rest) =
   Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path