Commit d697af23 authored by Saizan's avatar Saizan

Implement 'cabal unpack' command as in #390

parent 4d49172e
......@@ -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
-- ------------------------------------------------------------
......
-----------------------------------------------------------------------------
-- |
-- 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
, 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
......
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