Commit d697af23 authored by Saizan's avatar Saizan
Browse files

Implement 'cabal unpack' command as in #390

parent 4d49172e
...@@ -22,6 +22,7 @@ module Distribution.Client.Setup ...@@ -22,6 +22,7 @@ module Distribution.Client.Setup
, checkCommand , checkCommand
, uploadCommand, UploadFlags(..) , uploadCommand, UploadFlags(..)
, reportCommand , reportCommand
, unpackCommand, UnpackFlags(..)
, parsePackageArgs , parsePackageArgs
--TODO: stop exporting these: --TODO: stop exporting these:
...@@ -272,6 +273,46 @@ reportCommand = CommandUI { ...@@ -272,6 +273,46 @@ reportCommand = CommandUI {
commandOptions = \_ -> [optionVerbosity id const] 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 -- * List flags
-- ------------------------------------------------------------ -- ------------------------------------------------------------
......
-----------------------------------------------------------------------------
-- |
-- 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
...@@ -22,6 +22,7 @@ import Distribution.Client.Setup ...@@ -22,6 +22,7 @@ import Distribution.Client.Setup
, ListFlags(..), listCommand , ListFlags(..), listCommand
, UploadFlags(..), uploadCommand , UploadFlags(..), uploadCommand
, reportCommand , reportCommand
, unpackCommand, UnpackFlags(..)
, parsePackageArgs, configPackageDB' ) , parsePackageArgs, configPackageDB' )
import Distribution.Simple.Setup import Distribution.Simple.Setup
( BuildFlags(..), buildCommand ( BuildFlags(..), buildCommand
...@@ -48,6 +49,7 @@ import Distribution.Client.Check as Check (check) ...@@ -48,6 +49,7 @@ import Distribution.Client.Check as Check (check)
--import Distribution.Client.Clean (clean) --import Distribution.Client.Clean (clean)
import Distribution.Client.Upload as Upload (upload, check, report) import Distribution.Client.Upload as Upload (upload, check, report)
import Distribution.Client.SrcDist (sdist) import Distribution.Client.SrcDist (sdist)
import Distribution.Client.Unpack (unpack)
import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade
import Distribution.Simple.Program (defaultProgramConfiguration) import Distribution.Simple.Program (defaultProgramConfiguration)
...@@ -114,6 +116,7 @@ mainWorker args = ...@@ -114,6 +116,7 @@ mainWorker args =
,checkCommand `commandAddAction` checkAction ,checkCommand `commandAddAction` checkAction
,sdistCommand `commandAddAction` sdistAction ,sdistCommand `commandAddAction` sdistAction
,reportCommand `commandAddAction` reportAction ,reportCommand `commandAddAction` reportAction
,unpackCommand `commandAddAction` unpackAction
,wrapperAction (buildCommand defaultProgramConfiguration) ,wrapperAction (buildCommand defaultProgramConfiguration)
buildVerbosity buildDistPref buildVerbosity buildDistPref
,wrapperAction copyCommand ,wrapperAction copyCommand
...@@ -291,6 +294,13 @@ reportAction verbosityFlag extraArgs globalFlags = do ...@@ -291,6 +294,13 @@ reportAction verbosityFlag extraArgs globalFlags = do
Upload.report verbosity (globalRepos (savedGlobalFlags config)) 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 :: [String] -> IO ()
win32SelfUpgradeAction (pid:path:rest) = win32SelfUpgradeAction (pid:path:rest) =
Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path
......
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